[SCM] snd/master: Imported Upstream version 16.5~dfsg
umlaeute at users.alioth.debian.org
umlaeute at users.alioth.debian.org
Tue May 17 11:40:38 UTC 2016
The following commit has been merged in the master branch:
commit 248790aca5d5b6dc9a8edeea1abed0195ac1338e
Author: IOhannes m zmölnig <zmoelnig at umlautQ.umlaeute.mur.at>
Date: Tue May 17 12:21:04 2016 +0200
Imported Upstream version 16.5~dfsg
diff --git a/CM_patterns.scm b/CM_patterns.scm
index c148528..10c2b96 100644
--- a/CM_patterns.scm
+++ b/CM_patterns.scm
@@ -1329,7 +1329,7 @@
(let ((obj (%alloc-pattern))
(flags 0)
)
- (initialize-pattern obj (list) for stop
+ (initialize-pattern obj (list) for limit
flags
0
1
@@ -1365,3 +1365,6 @@
(pattern-data-set! obj (cdr data))
(car data)))))
+
+;; (define aaa (make-repeater (make-weighting '(a b c d)) :for 2))
+;; (next aaa #t)
diff --git a/HISTORY.Snd b/HISTORY.Snd
index 54ea4b7..046780c 100644
--- a/HISTORY.Snd
+++ b/HISTORY.Snd
@@ -1,5 +1,14 @@
Snd change log
+ 6-May: Snd 16.5.
+ 29-Mar: --with-webserver configuration (Kjetil Matheussen)
+ 28-Mar: Snd 16.4.
+ 18-Mar: s7webserver directory (Kjetil Matheussen)
+ 20-Feb: Snd 16.3.
+ 11-Jan-16: Snd 16.2.
+
+2015 ----------------------------------------------------------------
+
30-Nov: Snd 16.1.
19-Oct: Snd 16.0.
11-Sep: Snd 15.9.
diff --git a/NEWS b/NEWS
index e20683a..bd5c9ce 100644
--- a/NEWS
+++ b/NEWS
@@ -1,11 +1,14 @@
-Snd 16.1:
+Snd 16.5
-most of my time went into lint.scm, but the harder I work
-on it, the longer my TODO list.
+Kjetil Matheussen added the --with-webserver configuration flag to Snd, and
+ made all the supporting changes.
-s7: :key and :optional removed.
+Daniel Hensel sent instructions to build Snd in OSX -- see README.Snd.
-checked: gtk 3.19.1|2|3, sbcl 1.3.0|1, GSL 2.0
+ttaenc removed: it appears to be dead (no movement in 10 years), or infected.
-Thanks!: Norman Gray
+changed spectr.scm to export only *spectr*, rgb.scm *rgb*.
+checked: sbcl 1.3.4|5, gtk 3.20.2|3 3.21.1, gsl 2.1
+
+Thanks!: Greg Santucci, Daniel Lopez, Kjetil Matheussen, Daniel Hensel
diff --git a/README.Snd b/README.Snd
index 382733f..1dc7a6d 100644
--- a/README.Snd
+++ b/README.Snd
@@ -338,6 +338,53 @@ also need to install gtk-devel.
---- Mac OSX: ----
+Daniel Hensel sends these instructions to get Snd running with Motif:
+
+Download and install XQuartz:
+http://www.xquartz.org
+
+Download and install XCode
+open terminal:
+install Command Line Tools by typing
+xcode-select --install
+
+Install Macports
+Install Homebrew
+
+In Terminal type if not already installed:
+
+brew install gcc
+brew install ruby
+brew install gtk+
+brew install openmotif
+brew install poppler
+
+brew install timidity
+brew install wavpack
+brew install mpg123
+brew install mpg321
+
+sudo port -v install vorbis-tools +flac
+
+untar snd-16.4
+cd into the snd-16.4 folder
+type:
+./configure CFLAGS="-arch x86_64 -I/sw/include" LDFLAGS="-L/sw/lib -lmx -bind_at_load" --with-motif
+make
+sudo make install
+
+now it works
+
+you may start snd by typing snd from the command line, but you also may add it to XQuartz: open
+/Applications/Utilities/Xquartz/
+
+tab on /Applications, adapt the Path by adding Object and typing /usr/local/bin/snd
+
+Create your shortcut in XQuartz so it will start immediately by typing Command-s
+
+
+---- old, possibly out-of-date instructions
+
You can use either Motif or Gtk running under X11; to start Snd from an
ordinary shell, use the open-x11 command:
diff --git a/analog-filter.scm b/analog-filter.scm
index 5298ee1..ae71184 100644
--- a/analog-filter.scm
+++ b/analog-filter.scm
@@ -27,7 +27,7 @@
(do ((n 0 (+ n 1)))
((= n (+ L M)))
(let ((sum 0.0)
- (start (max 0 (- n (+ L 1))))
+ (start (max 0 (- n L 1)))
(end (min n M)))
(do ((m start (+ m 1)))
((> m end))
@@ -48,48 +48,47 @@
(j 0 (+ j 3))
(k 0 (+ k 4)))
((>= i n))
- (let* ((nt0 (/ (num (+ j 0)) (* wc wc)))
+ (let* ((nt0 (/ (num j) (* wc wc)))
(nt1 (/ (num (+ j 1)) wc))
(nt2 (num (+ j 2)))
- (dt0 (/ (den (+ j 0)) (* wc wc)))
+ (dt0 (/ (den j) (* wc wc)))
(dt1 (/ (den (+ j 1)) (* wc Q)))
(dt2 (den (+ j 2)))
(kd (+ dt0 dt1 dt2))
(kn (+ nt0 nt1 nt2)))
(set! (c k ) (/ (- (* 2.0 dt2) (* 2.0 dt0)) kd))
- (set! (c (+ k 1)) (/ (+ dt0 (- dt1) dt2) kd))
+ (set! (c (+ k 1)) (/ (- (+ dt0 dt2) dt1) kd))
(set! (c (+ k 2)) (/ (- (* 2.0 nt2) (* 2.0 nt0)) kn))
- (set! (c (+ k 3)) (/ (+ nt0 (- nt1) nt2) kn))
+ (set! (c (+ k 3)) (/ (- (+ nt0 nt2) nt1) kn))
(set! g (* g (/ kn kd)))))
- (let ((a ())
- (b ()))
- (do ((i 0 (+ i 2))
- (k 0 (+ k 4))) ; c
- ((>= i n))
- (set! a (cons (float-vector (c (+ k 3)) (c (+ k 2)) (c (+ k 3))) a))
- (set! b (cons (float-vector 1.0 (c k) (c (+ k 1))) b)))
+ (do ((a ())
+ (b ())
+ (i 0 (+ i 2))
+ (k 0 (+ k 4))) ; c
+ ((>= i n)
+ (list (float-vector-scale! (cascade->canonical a) g) ; scale entire numerator because this is the convolved form
+ (cascade->canonical b)))
+ (set! a (cons (float-vector (c (+ k 3)) (c (+ k 2)) (c (+ k 3))) a))
+ (set! b (cons (float-vector 1.0 (c k) (c (+ k 1))) b)))))
- (list (float-vector-scale! (cascade->canonical a) g) ; scale entire numerator because this is the convolved form
- (cascade->canonical b)))))
(define (prototype->highpass n num den)
- (let ((g 1.0)
- (numt (make-float-vector (length num)))
- (dent (make-float-vector (length den))))
- (do ((k 0 (+ k 2))
- (i 0 (+ i 3)))
- ((>= k n))
- (set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
- (set! (numt i ) 1.0)
- (set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
- (set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
- (set! (dent i ) 1.0)
- (set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
- (set! (dent (+ i 2)) (/ (den i) (den (+ i 2)))))
- (set! (numt 0) g)
- (list numt dent)))
-
+ (do ((g 1.0)
+ (numt (make-float-vector (length num)))
+ (dent (make-float-vector (length den)))
+ (k 0 (+ k 2))
+ (i 0 (+ i 3)))
+ ((>= k n)
+ (set! (numt 0) g)
+ (list numt dent))
+ (set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
+ (set! (numt i ) 1.0)
+ (set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
+ (set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
+ (set! (dent i ) 1.0)
+ (set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
+ (set! (dent (+ i 2)) (/ (den i) (den (+ i 2))))))
;;; ---------------- Butterworth ----------------
@@ -159,11 +158,11 @@ are (1.0-based) edge freqs: (make-butterworth-bandstop 4 .1 .2)"))
(len (/ (* n 3) 2))
(num (make-float-vector len))
(den (make-float-vector len)))
- (do ((l 1.0 (+ l 2.0))
+ (do ((k 1.0 (+ k 2.0))
(j 0 (+ j 3)))
- ((>= l n))
- (let ((u (- (* (sinh v0) (sin (/ (* l pi) (* 2.0 n))))))
- (w (* (cosh v0) (cos (/ (* l pi) (* 2.0 n))))))
+ ((>= k n))
+ (let ((u (- (* (sinh v0) (sin (/ (* k pi) (* 2.0 n))))))
+ (w (* (cosh v0) (cos (/ (* k pi) (* 2.0 n))))))
(set! (num j ) 0.0)
(set! (num (+ j 1)) 0.0)
(set! (num (+ j 2)) 1.0)
@@ -223,19 +222,19 @@ fl and fh = edge freqs (srate = 1.0): (make-chebyshev-bandstop 8 .1 .4 .01)"))
(len (/ (* n 3) 2))
(num (make-float-vector len))
(den (make-float-vector len)))
- (let ((pl 0.0))
- (do ((l 1.0 (+ l 2.0))
- (j 0 (+ j 3)))
- ((>= l n))
- (let ((u (- (* (sinh v0) (sin (/ (* l pi) (* 2.0 n))))))
- (w (* (cosh v0) (cos (/ (* l pi) (* 2.0 n)))))
- (t (/ 1.0 (sin (/ (* (+ l pl) pi) (* 2.0 n))))))
- (set! (num j ) 1.0)
- (set! (num (+ j 1)) 0.0)
- (set! (num (+ j 2)) (* t t))
- (set! (den j ) 1.0)
- (set! (den (+ j 1)) (/ (* -2.0 u) (+ (* u u) (* w w))))
- (set! (den (+ j 2)) (/ 1.0 (+ (* u u) (* w w)))))))
+ (do ((pl 0.0)
+ (L 1.0 (+ L 2.0))
+ (j 0 (+ j 3)))
+ ((>= L n))
+ (let ((u (- (* (sinh v0) (sin (/ (* L pi) (* 2.0 n))))))
+ (w (* (cosh v0) (cos (/ (* L pi) (* 2.0 n)))))
+ (t (/ 1.0 (sin (/ (* (+ L pl) pi) (* 2.0 n))))))
+ (set! (num j ) 1.0)
+ (set! (num (+ j 1)) 0.0)
+ (set! (num (+ j 2)) (* t t))
+ (set! (den j ) 1.0)
+ (set! (den (+ j 1)) (/ (* -2.0 u) (+ (* u u) (* w w))))
+ (set! (den (+ j 2)) (/ 1.0 (+ (* u u) (* w w))))))
(list num den
(expt 1.122 (- loss-dB))))) ; argh
@@ -282,33 +281,34 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(define (bessel-prototype n)
- (define (fact n)
- (let ((x 1))
- (do ((i 2 (+ i 1)))
- ((> i n))
- (set! x (* x i)))
- x))
- ; this form overflows if we don't have bignums
- ; (define (bessel-i n)
- ; (let ((cs (make-float-vector (+ n 1))))
- ; (do ((i 0 (+ i 1)))
- ; ((> i n))
- ; (set! (cs i) (/ (fact (- (* 2 n) i))
- ; (* (expt 2 (- n i))
- ; (fact i)
- ; (fact (- n i))))))
- ; cs))
(define (bessel-i n)
- (let ((cs (make-float-vector (+ n 1))))
- (do ((i 0 (+ i 1)))
- ((> i n))
- (let ((val (/ 1.0 (* (fact i) (expt 2 (- n i))))))
- (do ((k 1 (+ k 1))
- (f (- n i -1) (+ f 1))) ; (f (+ 1 (- n i)) (+ 1 f))
- ((> k n))
- (set! val (* val f)))
- (set! (cs i) val)))
- cs))
+
+ (define (fact n)
+ (let ((x 1))
+ (do ((i 2 (+ i 1)))
+ ((> i n))
+ (set! x (* x i)))
+ x))
+ ;; this form overflows if we don't have bignums
+ ;; (define (bessel-i n)
+ ;; (let ((cs (make-float-vector (+ n 1))))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((> i n))
+ ;; (set! (cs i) (/ (fact (- (* 2 n) i))
+ ;; (* (expt 2 (- n i))
+ ;; (fact i)
+ ;; (fact (- n i))))))
+ ;; cs))
+
+ (do ((cs (make-float-vector (+ n 1)))
+ (i 0 (+ i 1)))
+ ((> i n) cs)
+ (do ((val (/ 1.0 (* (fact i) (expt 2 (- n i)))))
+ (k 1 (+ k 1))
+ (f (- n i -1) (+ f 1))) ; (f (+ 1 (- n i)) (+ 1 f))
+ ((> k n)
+ (set! (cs i) val))
+ (set! val (* val f)))))
(let* ((len (/ (* n 3) 2))
(num (make-float-vector len))
@@ -376,12 +376,12 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(fx (f xmin arg1 arg2)))
(do ((i 0 (+ i 1)))
((= i n))
- (let ((step (/ (- xmax xmin) (- n 1.0))))
- (do ((j 0 (+ j 1))
- (s xmin (+ s step)))
- ((= j (- n 1)))
- (float-vector-set! x j s))
- (set! (x (- n 1)) xmax))
+ (do ((step (/ (- xmax xmin) (- n 1.0)))
+ (j 0 (+ j 1))
+ (s xmin (+ s step)))
+ ((= j (- n 1)))
+ (float-vector-set! x j s))
+ (set! (x (- n 1)) xmax)
(do ((j 0 (+ j 1)))
((= j n))
(let ((ft (f (x j) arg1 arg2)))
@@ -402,17 +402,17 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(let* ((e (sqrt (- (expt 10.0 (* 0.1 ripple)) 1.0)))
(k1 (/ e (sqrt (- (expt 10.0 (* 0.1 loss-dB)) 1.0))))
(k1p (sqrt (- 1.0 (* k1 k1))))
- (kr 0.0)
(m 0.0)
(k 0.0)
(len (/ (* n 3) 2))
(num (make-float-vector len))
(den (make-float-vector len))
- (g 1.0)
- (eps 0.0000001))
- (if (> (abs (- 1.0 (* k1p k1p))) eps)
- (set! kr (* n (/ (gsl-ellipk (* k1 k1)) (gsl-ellipk (* k1p k1p))))))
- (set! m (minimize-function findm 0.001 0.999 kr))
+ (g 1.0))
+ (let ((eps 0.0000001)
+ (kr 0.0))
+ (if (> (abs (- 1.0 (* k1p k1p))) eps)
+ (set! kr (* n (/ (gsl-ellipk (* k1 k1)) (gsl-ellipk (* k1p k1p))))))
+ (set! m (minimize-function findm 0.001 0.999 kr)))
(set! k (gsl-ellipk m))
(let ((cv (make-float-vector (floor (* 0.5 3 (+ n 1))))))
(do ((i 0 (+ i 2))
@@ -443,15 +443,15 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(do ((i 0 (+ i 2))
(j 0 (+ j 3)))
((>= i n))
- (let ((p (/ (- (+ (* (cv (+ j 1)) (cv (+ j 2)) sn cn)
- (* 0.0+i (cv j) dn)))
- (- 1.0 (* (cv (+ j 2)) sn
- (cv (+ j 2)) sn)))))
- (let ((pp (real-part (* p (complex (real-part p) (- (imag-part p)))))))
- (set! g (* g pp))
- (set! (den j ) 1.0)
- (set! (den (+ j 1)) (* -2.0 (real-part p)))
- (set! (den (+ j 2)) pp))))))
+ (let* ((p (/ (- (+ (* (cv (+ j 1)) (cv (+ j 2)) sn cn)
+ (* 0.0+i (cv j) dn)))
+ (- 1.0 (* (cv (+ j 2)) sn
+ (cv (+ j 2)) sn))))
+ (pp (real-part (* p (complex (real-part p) (- (imag-part p)))))))
+ (set! g (* g pp))
+ (set! (den j ) 1.0)
+ (set! (den (+ j 1)) (* -2.0 (real-part p)))
+ (set! (den (+ j 2)) pp)))))
(set! g (abs (/ g (sqrt (+ 1.0 (* e e))))))
(list num den g)))
diff --git a/animals.scm b/animals.scm
index 4fe41c0..bcbf665 100644
--- a/animals.scm
+++ b/animals.scm
@@ -256,7 +256,7 @@
(*clm-notehook* (symbol->string ',name) , at targs))
(let ((start (get-internal-real-time)))
, at body
- (format #t "~A: ~A~%" (- (get-internal-real-time) start) ,name)))
+ (format () "~A: ~A~%" (- (get-internal-real-time) start) ,name)))
,@(if *definstrument-hook*
(list (*definstrument-hook* name targs))
(list)))))
@@ -607,10 +607,7 @@
(* gen1trp-1 (+ (* gen4trp-1 (oscil gen1 gen2trp))
(* gen4trp (oscil gen3 (+ gen3trp
(polywave gen6))))))))))))
- (mus-reset pulsef1)
- (mus-reset pulsef2)
- (mus-reset gen1)
- (mus-reset gen2)
+ (for-each mus-reset (vector pulsef1 pulsef2 gen1 gen2))
(set! (mus-location pulf) (- (+ i pulse-sep) start))
(set! pulse-sep (seconds->samples (env pulf)))))))))
@@ -642,10 +639,10 @@
(frm3 (make-formant 4500 .99))
(frm4 (make-formant 7200 .9))
- (ampfr1 (make-env '(0 .5 1 3) :duration dur :scaler (* 2 5 (sin (hz->radians 900))) :base 3))
- (ampfr2 (make-env '(0 .25 .5 .4 1 1) :duration dur :scaler (* 2 5 (sin (hz->radians 1260)))))
- (ampfr4 (make-env '(0 0 .3 1 1 1) :duration dur :scaler (* 2 5 (sin (hz->radians 7200)))))
- (ampfr3 (* 2 5 (sin (hz->radians 4500))))
+ (ampfr1 (make-env '(0 .5 1 3) :duration dur :scaler (* 10 (sin (hz->radians 900))) :base 3))
+ (ampfr2 (make-env '(0 .25 .5 .4 1 1) :duration dur :scaler (* 10 (sin (hz->radians 1260)))))
+ (ampfr4 (make-env '(0 0 .3 1 1 1) :duration dur :scaler (* 10 (sin (hz->radians 7200)))))
+ (ampfr3 (* 10 (sin (hz->radians 4500))))
(gen1 (make-rk!cos 100 13.0))
(ampf1 (make-env '(0 1 1 0) :base 3 :duration dur))
@@ -770,11 +767,7 @@
((= pulse pulses))
(let ((pulse-amp (pulse-amps pulse))
(pulse-stop (+ pulse-start pulse-samps)))
-
- (if (< pulse 3)
- (set! (mus-frequency gen1) (* pitch 10))
- (set! (mus-frequency gen1) (* pitch 11)))
-
+ (set! (mus-frequency gen1) (* pitch (if (< pulse 3) 10 11)))
(do ((k pulse-start (+ k 1)))
((= k pulse-stop))
(let ((noise (rand-interp rnd)))
@@ -782,11 +775,11 @@
(env pulsef)
(+ (* .9 (oscil gen1 (* .1 noise)))
(* .08 (oscil gen3 (* .18 noise)))
- (* .02 (oscil gen4 (* .28 noise))))))))
- (mus-reset pulsef)
- (set! (mus-phase gen1) (* 0.5 pi))
- (set! (mus-phase gen3) (* 0.5 pi))
- (set! (mus-phase gen4) (* 0.5 pi))))
+ (* .02 (oscil gen4 (* .28 noise)))))))))
+ (mus-reset pulsef)
+ (set! (mus-phase gen1) (* 0.5 pi))
+ (set! (mus-phase gen3) (* 0.5 pi))
+ (set! (mus-phase gen4) (* 0.5 pi)))
(set! pulses (if (> (random 1.0) .6) 5 4))))))
@@ -832,10 +825,7 @@
(* (env indf-1) (oscil gen3 (* 24.0 ind)))
(* .1 (oscil gen5 (* 14.0 ind)))
(* .1 (oscil gen6 (* 6.0 ind))))))))
- (mus-reset frqf)
- (mus-reset pulsef)
- (mus-reset indf-1)
- (mus-reset indf))))))
+ (for-each mus-reset (vector frqf pulsef indf-1 indf)))))))
;;; (with-sound (:play #t) (squirrel-tree-frog 0 1.0 .5))
@@ -863,9 +853,7 @@
((= k reset-stop))
(outa k (* (env pulsef) (polywave gen1))))
(mus-reset pulsef)
- (if (> (random 1.0) .8)
- (set! next-pulse (seconds->samples (+ .25 (random .3))))
- (set! next-pulse (seconds->samples .4))))))))
+ (set! next-pulse (seconds->samples (if (> (random 1.0) .8) (+ .25 (random .3)) .4))))))))
;; (with-sound (:play #t) (ornate-chorus-frog 0 4 .5))
@@ -943,10 +931,10 @@
(env pulsef)
(+ (* .5 (oscil gen1 (+ frq (* index (oscil fmd (* frq .067))))))
(* (env intrp) (polywave poly1 frq))
- (* (env intrp-1) (polywave poly2 frq)))))))
- (mus-reset pulsef)
- (mus-reset gen1)
- (mus-reset fmd))))))
+ (* (env intrp-1) (polywave poly2 frq))))))))
+ (mus-reset pulsef)
+ (mus-reset gen1)
+ (mus-reset fmd)))))
;; (with-sound (:play #t) (crawfish-frog 0 .5))
@@ -1011,11 +999,11 @@
(ampf (make-env '(0 0 1 1 2 1 3 0) :duration dur :scaler amp :base 10))
(frqf (make-env '(0 0 1 6 2 0) :duration dur :scaler (hz->radians 1.0)))
- (f1 (make-rxyk!cos 200 (/ 100 200) 0.6))
- (f2 (make-rxyk!cos 230 (/ 100 230) 1.2))
+ (f1 (make-rxyk!cos 200 1/2 0.6))
+ (f2 (make-rxyk!cos 230 10/23 1.2))
- (f3 (make-rxyk!cos 600 (/ 100 600) 8.0))
- (f4 (make-rxyk!cos 630 (/ 100 630) 8.0))
+ (f3 (make-rxyk!cos 600 1/6 8.0))
+ (f4 (make-rxyk!cos 630 10/63 8.0))
(rnd (make-rand-interp 4000 .2))
(rnd1 (make-rand-interp 200 (hz->radians 2)))
@@ -1024,9 +1012,9 @@
(frm2 (make-formant 1200 .98))
(frm3 (make-formant 5000 .97))
- (frm1f (* 2 7.0 (sin (hz->radians 400))))
- (frm2f (* 2 14.0 (sin (hz->radians 1200))))
- (frm3f (* 2 4.0 (sin (hz->radians 5000))))
+ (frm1f (* 14 (sin (hz->radians 400))))
+ (frm2f (* 28 (sin (hz->radians 1200))))
+ (frm3f (* 8 (sin (hz->radians 5000))))
(intrpf (make-env '(0 1 .6 0 1 1) :offset 1000.0 :scaler 200.0 :duration dur)))
@@ -1106,14 +1094,14 @@
(do ((i start (+ i pulse-samps)))
((>= i stop))
(set! (mus-location ampf) (- i start))
- (let ((reset-stop (min stop (+ i pulse-out)))
- (pulse-amp (env ampf)))
- (set! gen1 (make-polywave 0.0 (list 1 (* pulse-amp .94)
- 2 (* pulse-amp .03)
- 3 (* pulse-amp .01)
- 4 (* pulse-amp .003)
- 5 (* pulse-amp .005)
- 7 (* pulse-amp .002))))
+ (let ((reset-stop (min stop (+ i pulse-out))))
+ (let ((pulse-amp (env ampf)))
+ (set! gen1 (make-polywave 0.0 (list 1 (* pulse-amp .94)
+ 2 (* pulse-amp .03)
+ 3 (* pulse-amp .01)
+ 4 (* pulse-amp .003)
+ 5 (* pulse-amp .005)
+ 7 (* pulse-amp .002)))))
(set! (mus-location ampf) (- i start))
(do ((k i (+ k 1)))
((= k reset-stop))
@@ -1152,13 +1140,14 @@
(pulse-amp (env ampf))
(pulse-amp2 (env ampf2))
(pulse-frq (env frqf)))
- (if (= pulse-amp2 0.0)
- (set! gen2 (make-polywave 0.0 (list 1 0.0)))
- (set! gen2 (make-polywave 0.0 (list 1 (* pulse-amp2 .01)
- 2 (* pulse-amp2 .01)
- 6 (* pulse-amp2 .01)
- 8 (* pulse-amp2 .1)
- 10 (* pulse-amp2 .01)))))
+ (set! gen2 (make-polywave 0.0
+ (if (= pulse-amp2 0.0)
+ (list 1 0.0)
+ (list 1 (* pulse-amp2 .01)
+ 2 (* pulse-amp2 .01)
+ 6 (* pulse-amp2 .01)
+ 8 (* pulse-amp2 .1)
+ 10 (* pulse-amp2 .01)))))
(set! pulsef (make-env (list 0.000 0.000 0.03 pulse-amp 0.08 pulse-amp
0.160 (* pulse-amp 0.486) 0.304 (* pulse-amp 0.202)
0.508 (* pulse-amp 0.087) 1.000 0.000)
@@ -1216,43 +1205,40 @@
;;; Western toad
(defanimal (western-toad beg dur amp)
- (let ((start (seconds->samples beg)))
- (let ((stop (seconds->samples (+ beg dur)))
- (gen (make-polywave 0.0 '(1 .95 2 .02 3 .03 4 .005)))
- (cur-start start)
- (cur-is-long #t))
- (do ()
- ((>= cur-start stop))
- (let ((pulse-samps (seconds->samples (if cur-is-long
- (+ 0.04 (random .04))
- (+ .01 (random .02))))))
- (let ((pulse-ampf (make-env (if cur-is-long
- (vector 0 0 .1 .5 2 1 3 0)
- (vector 0 0 1 1 1.5 .3 2 0))
- :scaler (* amp (if cur-is-long (+ .6 (random .4)) (+ .1 (random .7))))
- :length pulse-samps
- :base (if cur-is-long 6.0 3.0)))
- (pulse-frqf (make-env (if cur-is-long
- '(0 -.5 .5 0 1 -.3)
- '(0 -1 .1 0 1 0))
- :length pulse-samps
- :base .1
- :offset (hz->radians (if cur-is-long (if (> (random 1.0) .6) 1340 1260) 1200))
- :scaler (hz->radians (random 500.0))))
- (cur-end (+ cur-start pulse-samps)))
- (do ((i cur-start (+ i 1)))
- ((= i cur-end))
- (outa i (* (env pulse-ampf)
- (polywave gen (env pulse-frqf)))))
-
- (if cur-is-long
- (set! cur-start (+ cur-end
- (seconds->samples (+ .015 (if (> (random 1.0) .8)
- (random .15)
- (random .04))))))
- (set! cur-start (+ cur-end
- (seconds->samples (+ .01 (random .01))))))
- (set! cur-is-long (or (not cur-is-long) (> (random 1.0) .3)))))))))
+ (do ((stop (seconds->samples (+ beg dur)))
+ (gen (make-polywave 0.0 '(1 .95 2 .02 3 .03 4 .005)))
+ (cur-start (seconds->samples beg))
+ (cur-is-long #t))
+ ((>= cur-start stop))
+ (let ((pulse-samps (seconds->samples (if cur-is-long
+ (+ 0.04 (random .04))
+ (+ .01 (random .02))))))
+ (let ((pulse-ampf (make-env (vector 0 0 (if cur-is-long
+ (values .1 .5 2 1 3 0)
+ (values 1 1 1.5 .3 2 0)))
+ :scaler (* amp (if cur-is-long (+ .6 (random .4)) (+ .1 (random .7))))
+ :length pulse-samps
+ :base (if cur-is-long 6.0 3.0)))
+ (pulse-frqf (make-env (if cur-is-long
+ '(0 -.5 .5 0 1 -.3)
+ '(0 -1 .1 0 1 0))
+ :length pulse-samps
+ :base .1
+ :offset (hz->radians (if cur-is-long (if (> (random 1.0) .6) 1340 1260) 1200))
+ :scaler (hz->radians (random 500.0))))
+ (cur-end (+ cur-start pulse-samps)))
+ (do ((i cur-start (+ i 1)))
+ ((= i cur-end))
+ (outa i (* (env pulse-ampf)
+ (polywave gen (env pulse-frqf)))))
+
+ (set! cur-start (+ cur-end
+ (seconds->samples
+ (if cur-is-long
+ (+ .015 (random (if (> (random 1.0) .8) .15 .04)))
+ (+ .01 (random .01))))))
+
+ (set! cur-is-long (or (not cur-is-long) (> (random 1.0) .3)))))))
;; (with-sound (:play #t) (western-toad 0 2 .5))
@@ -1428,9 +1414,9 @@
(do ((i start (+ i pulse-samps)))
((>= i stop))
(set! (mus-location ampf) (- i start))
- (let ((reset-stop (min stop (+ i pulse-out)))
- (pulse-amp (env ampf)))
- (set! gen1 (make-polywave 0.0 (list 1 (* pulse-amp .99) 3 (* pulse-amp .005))))
+ (let ((reset-stop (min stop (+ i pulse-out))))
+ (let ((pulse-amp (env ampf)))
+ (set! gen1 (make-polywave 0.0 (list 1 (* pulse-amp .99) 3 (* pulse-amp .005)))))
(set! (mus-location ampf) (- i start))
(set! (mus-location frqf) (- i start))
(do ((k i (+ k 1)))
@@ -1607,7 +1593,7 @@
(let ((begs (vector 0.0 0.15 0.325 0.47 0.61))
(durs (vector 0.027 0.06 0.065 0.042 0.05))
(amps (vector 0.9 1.0 1.0 0.4 0.1))
- (frqs (vector 14800 14020 (* 1/3 14800) 14800 (* 1/2 14800)))
+ (frqs (vector 14800 14020 14800/3 14800 7400))
(ampenvs (vector '(0.000 0.000 0.085 0.906 0.117 1.000 0.328 0.909 0.715 0.464 0.892 0.118 1.000 0.000)
'(0.000 0.000 0.025 1.000 0.056 0.201 0.121 0.848 0.151 0.503 0.217 0.395 0.441 0.556
@@ -1766,10 +1752,10 @@
(+ .93 (triangle-wave ampmod))
(+ (polywave gp buzz)
(* (env indf)
- (polywave gb buzz)))))))
- (mus-reset pulsef)
- (mus-reset frqf)
- (mus-reset indf))))))
+ (polywave gb buzz))))))))
+ (mus-reset pulsef)
+ (mus-reset frqf)
+ (mus-reset indf)))))
;; (with-sound (:play #t) (broad-winged-tree-cricket 0 1.0 0.3))
@@ -1941,7 +1927,7 @@
(rnd (make-rand-interp 200))
(rndf (make-env '(0 .3 .7 .3 .8 1 1 0) :duration dur :scaler (hz->radians 120)))
(frqf (make-env '(0 -.5 .2 0 .85 0 1 -1) :scaler (hz->radians 400) :duration dur))
- (rx (make-rxyk!cos 4000 (/ 600 4000) 8.0)))
+ (rx (make-rxyk!cos 4000 3/20 8.0)))
(do ((i start (+ i 1)))
((= i stop))
(outa i (* (env ampf)
@@ -2158,8 +2144,8 @@
(defanimal (striped-ground-cricket beg dur amp)
(let ((start (seconds->samples beg))
(stop (seconds->samples (+ beg dur)))
- (gen1 (make-oscil (* 2 6600)))
- (gen2 (make-oscil (* 2 66) (* 0.5 (+ pi (hz->radians (* 2 66))))))
+ (gen1 (make-oscil 13200)) ;(* 2 6600)))
+ (gen2 (make-oscil 132 (* 0.5 (+ pi (hz->radians 132)))))
(gen3 (make-oscil 6600))
(gen4 (make-oscil 66 (* 0.5 (+ pi (hz->radians 66)))))
(pulsef (make-env '(0.000 0.000 0.041 0.466 0.144 0.775 0.359 1.0 0.484 0.858 1.000 0.000) :scaler amp :duration .012))
@@ -2167,11 +2153,11 @@
(pulse-samps (seconds->samples 0.012))
(pulse-sep (seconds->samples 0.015))
(long-pulse-samps (seconds->samples .54))
- (rnd (make-rand-interp (* 3 66) .04)))
+ (rnd (make-rand-interp 198 .04))) ; (* 3 66)
(do ((i start (+ i long-pulse-samps)))
((>= i stop))
- ;; do the 1st 0.5 amp pulse
+ ;; do the first 0.5 amp pulse
(let ((pstop (+ i pulse-samps))
(next-start i)
(pulses (+ 8 (random 3))))
@@ -2207,7 +2193,7 @@
(let ((start (seconds->samples beg))
(stop (seconds->samples (+ beg dur)))
(gen1 (make-oscil 8850))
- (gen2 (make-oscil (* 8850 2)))
+ (gen2 (make-oscil 17700)) ;(* 8850 2)))
(rnd1 (make-rand-interp 885 .03))
(rnd2 (make-rand-interp 885 .1))
(ampf (make-env '(0 0 1 1 10 1 11 0) :duration dur :scaler amp))
@@ -2239,7 +2225,7 @@
(let ((start (seconds->samples beg))
(stop (seconds->samples (+ beg dur)))
(gen1 (make-polywave 4730 '(1 .8 2 .1 3 .1)))
- (rnd (make-rand-interp (* 2 473) 1))
+ (rnd (make-rand-interp 946 1)) ; (* 2 473)
(oz (make-one-zero 1.0 -1.0))
(ampf (make-env '(0 0 1 1 10 1 11 0) :duration dur :scaler amp))
(pulsef (make-env '(0.0 0.0 0.05 0.38 0.14 0.77 0.26 0.95 0.47 1.0 0.57 0.9 0.81 0.5 0.85 0.3 1.0 0.0) :duration .014))
@@ -2257,19 +2243,19 @@
((= k reset-stop))
(outa k (* pulse-amp
(env pulsef)
- (polywave gen1 (one-zero oz (rand-interp rnd))))))
+ (polywave gen1 (one-zero oz (rand-interp rnd)))))))
- (mus-reset pulsef)
- (set! pulses (- pulses 1))
- (if (<= pulses 0)
- (begin
- (set! current-pulse-samps (+ pulse-samps (seconds->samples (+ .2 (random .1)))))
- (set! pulses (+ 30 (random 70))))
- (begin
- (if (> (random 1.0) .95)
- (set! pulse-samps (seconds->samples (+ pulse-dur .005 (random .01))))
- (set! pulse-samps (seconds->samples pulse-dur)))
- (set! current-pulse-samps pulse-samps))))))))
+ (mus-reset pulsef)
+ (set! pulses (- pulses 1))
+ (if (<= pulses 0)
+ (begin
+ (set! current-pulse-samps (+ pulse-samps (seconds->samples (+ .2 (random .1)))))
+ (set! pulses (+ 30 (random 70))))
+ (begin
+ (set! pulse-samps (seconds->samples (if (> (random 1.0) .95)
+ (+ pulse-dur .005 (random .01))
+ pulse-dur)))
+ (set! current-pulse-samps pulse-samps)))))))
;; (with-sound (:play #t) (southeastern-field-cricket 0 5 .3))
@@ -2528,38 +2514,37 @@
((= i 10))
(set! (v i) (- (ends i) (begs i))))
v))
- (scls (vector .09 .19 .22 .19 .27 .23 .21 .04 .17 .17))
- (amps (vector '(0.000 0.000 0.17 0.13 0.38 0.67 0.64 1.0 0.78 0.79 0.9 0.04 1.0 0.0)
- '(0.000 0.000 0.15 0.15 0.27 0.67 0.37 0.89 0.69 1.0 0.79 0.6 0.8 0.05 1.0 0.0)
- '(0.000 0.000 0.11 0.28 0.18 0.66 0.35 0.98 0.90 0.92 1.0 0.0)
- '(0.000 0.000 0.11 0.28 0.14 0.70 0.32 0.98 0.85 0.84 1.0 0.0)
- '(0.000 0.000 0.11 0.28 0.14 0.70 0.32 0.98 0.85 0.84 1.0 0.0)
- '(0.000 0.000 0.15 0.86 0.24 1.00 0.63 0.64 0.89 0.61 1.0 0.0)
- '(0.000 0.000 0.27 0.80 0.37 1.00 0.63 0.64 0.88 0.51 1.0 0.0)
- '(0.000 0.000 0.08 0.48 0.37 1.00 0.88 0.76 1.00 0.0)
- '(0.000 0.000 0.12 0.43 0.24 1.00 0.59 0.72 0.88 0.35 1.0 0.0)
- '(0.000 0.000 0.12 0.43 0.24 1.00 0.59 0.72 0.88 0.35 1.0 0.0)))
- (frqs (vector '(0 1 1 0)
- '(0 0 1 .5 8 .6 9 1.0)
- '(0 1 1 .5 2 .2 3 0)
- '(0 1 1 0 5 0)
- '(0 1 1 .3 2 0)
- '(0 1 1 1)
- '(0 1 2 .2 3 0)
- '(0 0 1 .9 2 1)
- '(0 1 1 .4 2 0)
- '(0 1 1 .3 2 0)))
(rnd (make-rand-interp 100 .01)))
-
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (amp-envs i) (make-env (amps i)
- :scaler (/ (* amp (scls i)) .27)
- :duration (durs i)))
- (set! (frq-envs i) (make-env (frqs i)
- :scaler (hz->radians (- (high-frqs i) (low-frqs i)))
- :offset (hz->radians (low-frqs i))
- :duration (durs i))))
+ (let ((scls (vector .09 .19 .22 .19 .27 .23 .21 .04 .17 .17))
+ (amps (vector '(0.000 0.000 0.17 0.13 0.38 0.67 0.64 1.0 0.78 0.79 0.9 0.04 1.0 0.0)
+ '(0.000 0.000 0.15 0.15 0.27 0.67 0.37 0.89 0.69 1.0 0.79 0.6 0.8 0.05 1.0 0.0)
+ '(0.000 0.000 0.11 0.28 0.18 0.66 0.35 0.98 0.90 0.92 1.0 0.0)
+ '(0.000 0.000 0.11 0.28 0.14 0.70 0.32 0.98 0.85 0.84 1.0 0.0)
+ '(0.000 0.000 0.11 0.28 0.14 0.70 0.32 0.98 0.85 0.84 1.0 0.0)
+ '(0.000 0.000 0.15 0.86 0.24 1.00 0.63 0.64 0.89 0.61 1.0 0.0)
+ '(0.000 0.000 0.27 0.80 0.37 1.00 0.63 0.64 0.88 0.51 1.0 0.0)
+ '(0.000 0.000 0.08 0.48 0.37 1.00 0.88 0.76 1.00 0.0)
+ '(0.000 0.000 0.12 0.43 0.24 1.00 0.59 0.72 0.88 0.35 1.0 0.0)
+ '(0.000 0.000 0.12 0.43 0.24 1.00 0.59 0.72 0.88 0.35 1.0 0.0)))
+ (frqs (vector '(0 1 1 0)
+ '(0 0 1 .5 8 .6 9 1.0)
+ '(0 1 1 .5 2 .2 3 0)
+ '(0 1 1 0 5 0)
+ '(0 1 1 .3 2 0)
+ '(0 1 1 1)
+ '(0 1 2 .2 3 0)
+ '(0 0 1 .9 2 1)
+ '(0 1 1 .4 2 0)
+ '(0 1 1 .3 2 0))))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (amp-envs i) (make-env (amps i)
+ :scaler (/ (* amp (scls i)) .27)
+ :duration (durs i)))
+ (set! (frq-envs i) (make-env (frqs i)
+ :scaler (hz->radians (- (high-frqs i) (low-frqs i)))
+ :offset (hz->radians (low-frqs i))
+ :duration (durs i)))))
(set! peep-dur (seconds->samples (durs 0)))
(set! peep-start (+ start (seconds->samples (begs 0))))
@@ -2589,7 +2574,7 @@
;;;
;;; White-throated sparrow
;;;
-;;; probably music of birds 14, 1st song
+;;; probably music of birds 14, first song
(defanimal (white-throated-sparrow beg amp)
(let ((dur (+ 3.25 (random .2)))
@@ -2975,19 +2960,17 @@
(do ((i 0 (+ i 1)))
((= i 40))
(savannah-2 (+ beg 1.29 .36 (* i .0145)) (* amp af) 5600)
- (if (< i 20)
- (set! af (+ af .004))
- (set! af (- af .004)))))
+ (set! af (if (< i 20) (+ af .004) (- af .004)))))
(savannah-7 (+ beg 2.27) (* .4 amp))
-
- (let ((dist 0.01))
- (do ((i 0 (+ i 1))
- (beg2 (+ beg 2.36) (+ beg2 dist))
- (af .1 (* af .85)))
- ((= i 20))
- (savannah-8 beg2 (* amp af))
- (set! dist (+ dist .001)))))
+
+ (do ((dist 0.01)
+ (i 0 (+ i 1))
+ (beg2 (+ beg 2.36) (+ beg2 dist))
+ (af .1 (* af .85)))
+ ((= i 20))
+ (savannah-8 beg2 (* amp af))
+ (set! dist (+ dist .001))))
;; (with-sound (:play #t) (savannah-sparrow 0 .5))
@@ -3025,9 +3008,9 @@
(do ((k i (+ k 1)))
((= k reset-stop))
(outa k (* (env pulsef)
- (polywave gen1 (+ (env frqf) (rand-interp rnd))))))
- (mus-reset pulsef)
- (mus-reset frqf)))))))
+ (polywave gen1 (+ (env frqf) (rand-interp rnd)))))))
+ (mus-reset pulsef)
+ (mus-reset frqf))))))
;; (with-sound (:play #t) (chipping-sparrow 0 .3))
@@ -3185,9 +3168,9 @@
(do ((k i (+ k 1)))
((= k reset-stop))
(outa k (* (env pulsef)
- (polywave gen1 (env frqf)))))
- (mus-reset pulsef)
- (mus-reset frqf))))))
+ (polywave gen1 (env frqf))))))
+ (mus-reset pulsef)
+ (mus-reset frqf)))))
;; (with-sound (:play #t) (carolina-wren 0 .25))
@@ -3238,9 +3221,9 @@
(do ((k i (+ k 1)))
((= k reset-stop))
(outa k (* (env ampf2)
- (polywave gen1 (env frqf2)))))
- (mus-reset ampf2)
- (mus-reset frqf2))))))
+ (polywave gen1 (env frqf2))))))
+ (mus-reset ampf2)
+ (mus-reset frqf2)))))
;; (with-sound (:play #t) (bachmans-sparrow 0 .25))
@@ -3610,11 +3593,11 @@
(do ((k i (+ k 1)))
((= k reset-stop))
(outa k (* (env ampf)
- (polywave gen1 (env frqf)))))
+ (polywave gen1 (env frqf))))))
- (set! start (starts peep-ctr))
- (mus-reset ampf)
- (mus-reset frqf))))))
+ (set! start (starts peep-ctr))
+ (mus-reset ampf)
+ (mus-reset frqf)))))
;; (with-sound (:play #t) (california-towhee 0 .25))
@@ -3643,9 +3626,9 @@
(initial-gen (make-oscil initial-pitch))
(buzz-frq-table (let ((v (make-float-vector buzz-size 0.0))
- (bfrqf (make-env (if gliss-up
- (list 0 buzz-low .5 buzz-mid 1 buzz-high)
- (list 0 buzz-high .5 buzz-mid 1 buzz-low))
+ (bfrqf (make-env (vector 0 (if gliss-up
+ (values buzz-low .5 buzz-mid 1 buzz-high)
+ (values buzz-high .5 buzz-mid 1 buzz-low)))
:length buzz-size
:scaler (hz->radians 1.0))))
(do ((i 0 (+ i 1)))
@@ -3939,14 +3922,14 @@
(do ((i start (+ i pulse-samps)))
((>= i stop))
(set! (mus-location ampf) (- i start))
- (let ((reset-stop (min stop (+ i pulse-out)))
- (pulse-amp (env ampf)))
- (set! gen (make-polywave
- :partials (let ((xcoord #f))
- (map (lambda (x)
- (set! xcoord (not xcoord))
- (if xcoord x (* x pulse-amp)))
- partials))))
+ (let ((reset-stop (min stop (+ i pulse-out))))
+ (let ((pulse-amp (env ampf)))
+ (set! gen (make-polywave
+ :partials (let ((xcoord #f))
+ (map (lambda (x)
+ (set! xcoord (not xcoord))
+ (if xcoord x (* x pulse-amp)))
+ partials)))))
(set! (mus-frequency gen) (- (env pulse-off) 300.0))
(do ((k i (+ k 1)))
((= k reset-stop))
@@ -4090,18 +4073,17 @@
(polywave gen1 (env frqf))))))))
(let ((amps1 (vector .2 .5 .7 .9 1.0 1.0)))
-
(do ((call 0 (+ call 1)))
((= call 6))
- (nashville-warbler-1 (+ beg (* .21 call)) (+ .15 (random .02)) (* amp (amps1 call))))
-
- (do ((call 0 (+ call 1)))
- ((= call 3))
- (nashville-warbler-2 (+ beg 1.26 (* .17 call)) (+ .13 (random .02)) amp))
-
- (nashville-warbler-3 (+ beg 1.8) amp)
+ (nashville-warbler-1 (+ beg (* .21 call)) (+ .15 (random .02)) (* amp (amps1 call)))))
- (nashville-warbler-4 (+ beg 1.94) (* 0.4 amp))))
+ (do ((call 0 (+ call 1)))
+ ((= call 3))
+ (nashville-warbler-2 (+ beg 1.26 (* .17 call)) (+ .13 (random .02)) amp))
+
+ (nashville-warbler-3 (+ beg 1.8) amp)
+
+ (nashville-warbler-4 (+ beg 1.94) (* 0.4 amp)))
;; (with-sound (:play #t) (nashville-warbler 0 .25))
@@ -4306,8 +4288,7 @@
;;; American crow
(define (nrcos->polywave n r scl)
- (if (and (positive? n)
- (< n 8192))
+ (if (< 0 n 8192)
(let ((lst ())
(total (polynomial (make-float-vector n 1.0) r)))
(set! scl (/ scl total))
@@ -4331,9 +4312,9 @@
(frm2 (make-formant 5500 .98))
(frm3 (make-formant 3800 .98))
- (fr1 (* 2 20 (sin (hz->radians 1400))))
+ (fr1 (* 40 (sin (hz->radians 1400))))
(fr2 (* 2 (sin (hz->radians 5500))))
- (fr3 (* 2 2 (sin (hz->radians 3800))))
+ (fr3 (* 4 (sin (hz->radians 3800))))
(gen (make-polywave 0.0 (nrcos->polywave 15 .75 1.0)))
(rnd (make-rand-interp 5000 .007)))
@@ -4476,9 +4457,9 @@
(+ .5 (* .5 (abs (oscil trem (rand-interp rnd1)))))
(oscil gen1 (+ (env frqf)
(env pulse-frqf)
- (rand-interp rnd)))))))
- (mus-reset pulse-ampf)
- (mus-reset pulse-frqf)))))))
+ (rand-interp rnd))))))))
+ (mus-reset pulse-ampf)
+ (mus-reset pulse-frqf))))))
;; (with-sound (:play #t) (loggerhead-shrike-1 0 .5))
@@ -4516,14 +4497,10 @@
(+ (* (env ampf1)
(polywave gen1 (* pulse-frq (+ noise (env frqf1)))))
(* (env ampf2)
- (polywave gen2 (* pulse-frq (+ noise (env frqf2))))))))))
- (set! pulse-frq (frqs pulse-ctr))
- (set! pulse-ctr (+ pulse-ctr 1))
- (mus-reset pulse-ampf)
- (mus-reset ampf1)
- (mus-reset ampf2)
- (mus-reset frqf1)
- (mus-reset frqf2)))))))
+ (polywave gen2 (* pulse-frq (+ noise (env frqf2)))))))))))
+ (set! pulse-frq (frqs pulse-ctr))
+ (set! pulse-ctr (+ pulse-ctr 1))
+ (for-each mus-reset (vector pulse-ampf ampf1 ampf2 frqf1 frqf2)))))))
;; (with-sound (:play #t) (loggerhead-shrike-2 0 .5))
@@ -4545,13 +4522,13 @@
(frm2 (make-formant 1700 .99))
(frm3 (make-formant 5600 .98))
- (fr1 (* 2 5 (sin (hz->radians 1000))))
- (fr2 (* 2 15 (sin (hz->radians 1700))))
- (fr3 (* 2 5 (sin (hz->radians 5600)))))
+ (fr1 (* 10 (sin (hz->radians 1000))))
+ (fr2 (* 30 (sin (hz->radians 1700))))
+ (fr3 (* 10 (sin (hz->radians 5600)))))
- (let ((fb (vector frm1 frm2 frm3))
- (fs (float-vector fr1 fr2 fr3)))
- (set! fb (make-formant-bank fb fs))
+ (let ((fb (vector frm1 frm2 frm3)))
+ (let ((fs (float-vector fr1 fr2 fr3)))
+ (set! fb (make-formant-bank fb fs)))
(do ((i 0 (+ i 1)))
((= i 3))
@@ -4774,7 +4751,7 @@
(frm2 (make-formant 1090 .999))
(frm3 (make-formant 2240 .993))
- (fr1 (* 2 15 (sin (hz->radians 730))))
+ (fr1 (* 30 (sin (hz->radians 730))))
(fr2 (* 2 (sin (hz->radians 1090))))
(fr3 (* 2 (sin (hz->radians 2240))))
(vib (make-polywave 12.0 (list 1 (hz->radians 7.0)))))
@@ -5001,10 +4978,10 @@
(frm3 (make-formant 3800 .98))
(frm4 (make-formant 1800 .99))
- (fr1 (* 2 5 (sin (hz->radians 2300))))
- (fr2 (* 2 3 (sin (hz->radians 6100))))
- (fr3 (* 2 5 (sin (hz->radians 3800))))
- (fr4 (* 2 7 (sin (hz->radians 1800))))
+ (fr1 (* 10 (sin (hz->radians 2300))))
+ (fr2 (* 6 (sin (hz->radians 6100))))
+ (fr3 (* 10 (sin (hz->radians 3800))))
+ (fr4 (* 14 (sin (hz->radians 1800))))
(rnd2 (make-rand-interp 300 (hz->radians 15))))
@@ -5468,9 +5445,9 @@
(frm1 (make-formant frmfrq .99))
(frm2 (make-formant 4200 .98))
(frm3 (make-formant 2800 .98))
- (fr1 (* 2 20 (sin (hz->radians frmfrq))))
+ (fr1 (* 40 (sin (hz->radians frmfrq))))
(fr2 (* 2 (sin (hz->radians 4200))))
- (fr3 (* 2 8 (sin (hz->radians 2800))))
+ (fr3 (* 16 (sin (hz->radians 2800))))
(gen (make-polywave 0.0 (nrcos->polywave 15 .75 1.0)))
(rnd (make-rand-interp 5000 .03))
(rnd1 (make-rand-interp 1000 .15))
@@ -5851,10 +5828,10 @@
(frm2 (make-formant 3200 .99))
(frm3 (make-formant 5300 .97))
(frm4 (make-formant 1600 .99))
- (fr1 (* 2 10 (sin (hz->radians 2300))))
- (fr2 (* 2 3 (sin (hz->radians 3200))))
- (fr3 (* 2 5 (sin (hz->radians 5300))))
- (fr4 (* 2 5 (sin (hz->radians 1600))))
+ (fr1 (* 20 (sin (hz->radians 2300))))
+ (fr2 (* 6 (sin (hz->radians 3200))))
+ (fr3 (* 10 (sin (hz->radians 5300))))
+ (fr4 (* 10 (sin (hz->radians 1600))))
(rnd (make-rand-interp 400 (hz->radians 10))))
(let ((fb (vector frm1 frm2 frm3 frm4))
(fs (float-vector fr1 fr2 fr3 fr4)))
@@ -6051,9 +6028,9 @@
(frm1 (make-formant 2460 .99))
(frm2 (make-formant 5200 .98))
(frm3 (make-formant 8200 .97))
- (fr1 (* 2 5 (sin (hz->radians 2460))))
- (fr2 (* 2 5 (sin (hz->radians 5200))))
- (fr3 (* 2 2 (sin (hz->radians 8200))))
+ (fr1 (* 10 (sin (hz->radians 2460))))
+ (fr2 (* 10 (sin (hz->radians 5200))))
+ (fr3 (* 4 (sin (hz->radians 8200))))
(frmaf (make-env '(0 0 .6 .3 .9 .8 1 .5) :duration dur))
(frmaf-1 (make-env '(0 0 .6 .3 .9 .8 1 .5) :duration dur :offset 1.0 :scaler -1.0))
(frmf (make-env '(0 5200 .7 4900 .9 2200 1 2000) :scaler (hz->radians 1.0) :duration dur))
@@ -6280,12 +6257,12 @@
(* (env ampf2)
(polywave gen2 frq))))))))))
- (let ((amps (vector .5 1.0 1.0 .9)))
- (do ((i 0 (+ i 1))
- (bg beg1 (+ bg .35)))
- ((= i 4))
- (oak-titmouse-1 bg (* amp1 (amps i)))
- (oak-titmouse-2 (+ bg .156) (* amp1 (amps i))))))
+ (do ((amps (vector .5 1.0 1.0 .9))
+ (i 0 (+ i 1))
+ (bg beg1 (+ bg .35)))
+ ((= i 4))
+ (oak-titmouse-1 bg (* amp1 (amps i)))
+ (oak-titmouse-2 (+ bg .156) (* amp1 (amps i)))))
;; (with-sound (:play #t) (oak-titmouse 0 .5))
@@ -6370,17 +6347,17 @@
(polywave gen2 (+ (env frqf2)
(rand-interp rnd1)))))))))))
- (let ((amps (vector .4 .6 .8 .9 1.0)))
- (do ((note 0 (+ 1 note))
- (bg beg1 (+ bg 0.18)))
- ((= note 5))
- (macgillivrays-warbler-1 bg (* amp1 (amps note)))))
+ (do ((amps (vector .4 .6 .8 .9 1.0))
+ (note 0 (+ 1 note))
+ (bg beg1 (+ bg 0.18)))
+ ((= note 5))
+ (macgillivrays-warbler-1 bg (* amp1 (amps note))))
- (let ((amps (vector 1.0 .9 .7)))
- (do ((note 0 (+ 1 note))
- (bg (+ beg1 0.93) (+ bg 0.17)))
- ((= note 3))
- (macgillivrays-warbler-2 bg (* amp1 (amps note))))))
+ (do ((amps (vector 1.0 .9 .7))
+ (note 0 (+ 1 note))
+ (bg (+ beg1 0.93) (+ bg 0.17)))
+ ((= note 3))
+ (macgillivrays-warbler-2 bg (* amp1 (amps note)))))
;; (with-sound (:play #t) (macgillivrays-warbler 0 .5))
@@ -6446,7 +6423,7 @@
(define (western-meadowlark beg1 amp1)
- ;; 1st sequence of notes
+ ;; first sequence of notes
(defanimal (western-meadowlark-1 beg amp)
(let ((dur 1.075))
(let ((start (seconds->samples beg))
@@ -6810,14 +6787,14 @@
(pulse-ampf2 (make-env '(0 0 .65 0 .8 1 .9 1 1 0)
:duration pulse-dur :scaler .4))
(pulse-frqf2 (make-env '(0 5400 .6 5400 .75 6300 1 5400)
- :duration pulse-dur :scaler (hz->radians 0.2) :base .1))
- (first-stop (+ start pulse-samps)))
+ :duration pulse-dur :scaler (hz->radians 0.2) :base .1)))
- (do ((i start (+ i 1)))
- ((= i first-stop))
- (outa i (* (env pulse-ampf)
- (polywave gen1 (+ (env pulse-frqf)
- (env frqf))))))
+ (let ((first-stop (+ start pulse-samps)))
+ (do ((i start (+ i 1)))
+ ((= i first-stop))
+ (outa i (* (env pulse-ampf)
+ (polywave gen1 (+ (env pulse-frqf)
+ (env frqf)))))))
(set! start (+ start pulse-spacing))
(mus-reset pulse-ampf)
(mus-reset pulse-frqf)
@@ -6832,10 +6809,7 @@
(env frqf))))
(* (env pulse-ampf2)
(polywave gen2 (env pulse-frqf2))))))
- (mus-reset pulse-ampf)
- (mus-reset pulse-frqf)
- (mus-reset pulse-ampf2)
- (mus-reset pulse-frqf2)))))))
+ (for-each mus-reset (vector pulse-ampf pulse-frqf pulse-ampf2 pulse-frqf2))))))))
;; (with-sound (:play #t) (bushtit 0 .5))
@@ -7142,12 +7116,12 @@
(song-sparrow-little-buzz (+ beg1 .37) (* .4 amp1))
(song-sparrow-clear-tone (+ beg1 0.57) 1.0 amp1)
- (let ((amps (vector .14 .33 .37 .37 .30 .30 .30)))
- (do ((i 0 (+ i 1))
- (x 0.68 (+ x .1)))
- ((= i 7))
- (song-sparrow-sweep-tone (+ beg1 x) (* (amps i) amp1))
- (song-sparrow-sweep-caw (+ beg1 x .05) (* 0.5 amp1))))
+ (do ((amps (vector .14 .33 .37 .37 .30 .30 .30))
+ (i 0 (+ i 1))
+ (x 0.68 (+ x .1)))
+ ((= i 7))
+ (song-sparrow-sweep-tone (+ beg1 x) (* (amps i) amp1))
+ (song-sparrow-sweep-caw (+ beg1 x .05) (* 0.5 amp1)))
(song-sparrow-sweep-tone (+ beg1 1.37) (* .27 amp1))
(song-sparrow-big-buzz (+ beg1 1.44) (* 0.75 amp1))
@@ -7970,10 +7944,10 @@
(frm5 (make-formant 7500 .96))
(frm3 (make-formant 9000 .96))
- (fr1 (* 2 7 (sin (hz->radians 2800))))
- (fr2 (* 2 3 (sin (hz->radians 4400))))
- (fr3 (* 2 0.5 (sin (hz->radians 9000))))
- (fr4 (* 2 3 (sin (hz->radians 6000))))
+ (fr1 (* 14 (sin (hz->radians 2800))))
+ (fr2 (* 6 (sin (hz->radians 4400))))
+ (fr3 (sin (hz->radians 9000)))
+ (fr4 (* 6 (sin (hz->radians 6000))))
(fr5 (* 2 (sin (hz->radians 7500)))))
(let ((fb (vector frm1 frm2 frm3 frm4 frm5))
(fs (float-vector fr1 fr2 fr3 fr4 fr5)))
@@ -8033,7 +8007,7 @@
((= i stop))
(let ((rf (env rndf)))
(outa i (* (env ampf)
- (+ (- 1.0 rf) (* rf (rand-interp rnd)))
+ (- (+ 1.0 (* rf (rand-interp rnd))) rf)
(polywave gen1 (env frqf))))))))
(summer-tanager-1 beg1 .29 (* .4 amp1)
@@ -8794,7 +8768,7 @@
;; east 12 3.5
(defanimal (chestnut-sided-warbler-1 beg amp)
- ;; 1st 6 notes
+ ;; first 6 notes
(let ((dur 0.11))
(let ((start (seconds->samples beg))
(stop (seconds->samples (+ beg dur)))
@@ -9067,8 +9041,7 @@
(frq (+ (env frqf)
(rand-interp rnd))))
(outa i (* (env ampf)
- (+ (- 1.0 rf)
- (* rf (abs (rand-interp rnd1))))
+ (- (+ 1.0 (* rf (abs (rand-interp rnd1)))) rf)
(+ (* (env ampf1) (oscil gen1 frq))
(* (env ampf2) (oscil gen2 (* 2.0 frq)))
(* (env ampf3) (oscil gen3 (* 3.0 frq)))))))))))
@@ -9145,8 +9118,8 @@
(rnd (make-rand-interp 10000 vibamp))
(frm1 (make-formant frm1frq .97))
(frm2 (make-formant frm2frq .95))
- (fr1 (* 2 5 (sin (hz->radians frm1frq))))
- (fr2 (* 2 4 (sin (hz->radians frm2frq))))
+ (fr1 (* 10 (sin (hz->radians frm1frq))))
+ (fr2 (* 8 (sin (hz->radians frm2frq))))
(frmf (make-env frmamp :duration dur)))
(do ((i start (+ i 1)))
((= i stop))
@@ -10937,11 +10910,11 @@
(define (calling-all-animals)
(with-sound (:srate 44100) ;(srate needed by snd-test)
- (let ((beg 0.0))
- (set! beg (calling-all-frogs beg))
- (set! beg (calling-all-mammals beg))
- (set! beg (calling-all-insects beg))
- (set! beg (calling-all-birds beg)))))
+ (calling-all-birds
+ (calling-all-insects
+ (calling-all-mammals
+ (calling-all-frogs 0.0))))))
+
diff --git a/audio.c b/audio.c
index 4bc2ed7..f57f402 100644
--- a/audio.c
+++ b/audio.c
@@ -83,7 +83,13 @@
/* these pull in stdbool.h apparently, so they have to precede sndlib.h */
#endif
-#define HAVE_JACK_IN_LINUX (MUS_JACK && __linux__)
+/* #define HAVE_JACK_IN_LINUX (MUS_JACK && __linux__) */
+/* using JACK on GNU/linux, GNU/kFreeBSD and GNU/Hurd is all the same */
+#if ((defined __linux__) || ((defined __FreeBSD_kernel__) && (defined __GLIBC__)) || (defined __GNU__))
+ #define HAVE_JACK_IN_LINUX MUS_JACK
+#else
+ #define HAVE_JACK_IN_LINUX 0
+#endif
#include "_sndlib.h"
#include "sndlib-strings.h"
@@ -4799,7 +4805,7 @@ int mus_audio_read(int line, char *buf, int bytes)
#include <fcntl.h>
#include <sys/audioio.h>
#include <sys/ioctl.h>
-
+#include <sys/param.h>
#define return_error_exit(Error_Type, Audio_Line, Ur_Error_Message) \
do { char *Error_Message; Error_Message = Ur_Error_Message; \
@@ -4871,6 +4877,11 @@ static int cur_chans = 1, cur_srate = 22050;
int mus_audio_write(int line, char *buf, int bytes)
{
+#if defined(__NetBSD__) && (__NetBSD_Version__ >= 700000000)
+ if (write(line, buf, bytes) != bytes)
+ return_error_exit(MUS_AUDIO_WRITE_ERROR, line,
+ mus_format("write error: %s", strerror(errno)));
+#else
/* trouble... AUDIO_WSEEK always returns 0, no way to tell that I'm about to
* hit "hiwat", but when I do, it hangs. Can't use AUDIO_DRAIN --
* it introduces interruptions. Not sure what to do...
@@ -4888,14 +4899,26 @@ int mus_audio_write(int line, char *buf, int bytes)
else usleep(10000);
mus_audio_write(line, (char *)(buf + b), bytes - b);
}
+#endif
return(MUS_NO_ERROR);
}
+/* from Mike Scholz, 11-Feb-16 (edited):
+ * On Netbsd sound output with Snd and Sndplay stops before the sound is really at the end.
+ * [In audioplay] after the read-write loop they call ioctl(fd, AUDIO_DRAIN, NULL).
+ * Before closing sound output they call ioctl(fd, AUDIO_FLUSH, NULL) (like in audio.c),
+ * and in addition ioctl(fd, AUDIO_SETINFO, &info). The latter requires that
+ * audio_info_t a_info be a global variable. The AUDIO_DRAIN call has been in their
+ * sources since version 1.1 of /usr/src/usr.bin/audio/play/play.c from March 1999.
+ */
+
+static audio_info_t a_info;
int mus_audio_close(int line)
{
- usleep(100000);
- ioctl(line, AUDIO_FLUSH, 0);
+ ioctl(line, AUDIO_DRAIN, NULL);
+ ioctl(line, AUDIO_FLUSH, NULL);
+ ioctl(line, AUDIO_SETINFO, &a_info);
close(line);
return(MUS_NO_ERROR);
}
@@ -4906,7 +4929,6 @@ static int netbsd_default_outputs = (AUDIO_HEADPHONE | AUDIO_LINE_OUT | AUDIO_SP
int mus_audio_open_output(int dev, int srate, int chans, mus_sample_t samp_type, int size)
{
int line, encode;
- audio_info_t a_info;
line = open("/dev/sound", O_WRONLY); /* /dev/audio assumes mono 8-bit mulaw */
if (line == -1)
@@ -5080,16 +5102,14 @@ static pa_simple *pa_out = NULL, *pa_in = NULL;
int mus_audio_open_output(int dev, int srate, int chans, mus_sample_t samp_type, int size)
{
- pa_sample_spec *spec;
+ pa_sample_spec spec = {0};
int error;
- spec = (pa_sample_spec *)malloc(sizeof(pa_sample_spec));
- spec->format = sndlib_to_pa_format(samp_type);
- spec->rate = srate;
- spec->channels = chans;
+ spec.format = sndlib_to_pa_format(samp_type);
+ spec.rate = srate;
+ spec.channels = chans;
- pa_out = pa_simple_new(NULL, "snd", PA_STREAM_PLAYBACK, NULL, "playback", spec, NULL, NULL, &error);
- free(spec);
+ pa_out = pa_simple_new(NULL, "snd", PA_STREAM_PLAYBACK, NULL, "playback", &spec, NULL, NULL, &error);
if (!pa_out)
{
fprintf(stderr, "can't play: %s\n", pa_strerror(error));
diff --git a/autosave.scm b/autosave.scm
index f8c5aeb..2d78052 100644
--- a/autosave.scm
+++ b/autosave.scm
@@ -20,20 +20,9 @@
"")
"#" (short-file-name snd) "#"))
- (define (unsaved-edits snd)
- (or (sound-property 'auto-save snd)
- 0))
-
(define (clear-unsaved-edits snd)
(set! (sound-property 'auto-save snd) 0))
- (define (increment-unsaved-edits snd)
- (set! (sound-property 'auto-save snd) (+ 1 (sound-property 'auto-save snd))))
-
- (define (upon-edit snd)
- (lambda ()
- (increment-unsaved-edits snd)))
-
(define (auto-save-open-func snd)
(let ((temp-file (auto-save-temp-name snd)))
(if (and (file-exists? temp-file)
@@ -44,7 +33,9 @@
(do ((i 0 (+ 1 i)))
((= i (channels snd)))
(if (null? (hook-functions (edit-hook snd i)))
- (hook-push (edit-hook snd i) (lambda (hook) (upon-edit (hook 'snd))))))
+ (hook-push (edit-hook snd i) (lambda (hook)
+ (let ((snd (hook 'snd)))
+ (set! (sound-property 'auto-save snd) (+ 1 (sound-property 'auto-save snd))))))))
(clear-unsaved-edits snd)))
(define (auto-save-done snd)
@@ -57,14 +48,14 @@
(if auto-saving
(begin
(for-each (lambda (snd)
- (if (> (unsaved-edits snd) 0)
+ (if (positive? (or (sound-property 'auto-save snd) 0))
(let ((save-name (auto-save-temp-name snd)))
(status-report (string-append "auto-saving as " save-name "...") snd)
- (in (* 1000 3) (lambda () (status-report "" snd)))
+ (in 3000 (lambda () (status-report "" snd)))
(save-sound-as save-name snd)
(clear-unsaved-edits snd))))
(sounds))
- (in (* 1000 auto-save-interval) auto-save-func))))
+ (in (floor (* 1000 auto-save-interval)) auto-save-func))))
(if (not (member auto-save-done (hook-functions close-hook)))
(begin
diff --git a/bess.scm b/bess.scm
index eb3e9b2..7c6e5b3 100644
--- a/bess.scm
+++ b/bess.scm
@@ -1,252 +1,252 @@
;;; this is obsolete -- it needs some replacement for the mus-audio* functions
-(if (provided? 'snd-motif)
- (with-let (sublet *motif*)
- ;; set up our user-interface
- (let* ((app (car (main-widgets)))
-
- (shell (let* ((xdismiss (XmStringCreate "Go away" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "FM Forever!" XmFONTLIST_DEFAULT_TAG))
- (dialog (XmCreateTemplateDialog (cadr (main-widgets)) "FM Forever!"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNtransient #f))))
- (XtAddCallback dialog
- XmNhelpCallback (lambda (w context info)
- (snd-print "This dialog lets you experiment with simple FM")))
- (XmStringFree xhelp)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
- dialog))
-
- (dpy (XtDisplay shell))
- (screen (DefaultScreenOfDisplay dpy))
- ;; (cmap (DefaultColormap dpy (DefaultScreen dpy)))
- (black (BlackPixelOfScreen screen))
- (white (WhitePixelOfScreen screen)))
-
- (define (set-flabel label value)
- (let ((s1 (XmStringCreate (format #f "~,3F" value) XmFONTLIST_DEFAULT_TAG)))
- (XtVaSetValues label (list XmNlabelString s1))
- (XmStringFree s1)))
-
- (define (set-ilabel label value)
- (let ((s1 (XmStringCreate (format #f "~D" value) XmFONTLIST_DEFAULT_TAG)))
- (XtVaSetValues label (list XmNlabelString s1))
- (XmStringFree s1)))
-
- (let* ((light-blue *position-color*)
- (form (XtCreateManagedWidget "form" xmFormWidgetClass shell
- (list XmNbackground white
- XmNforeground black
- XmNresizePolicy XmRESIZE_GROW)))
- ;; toggle named "play"
- (play-button (XtCreateManagedWidget "play" xmToggleButtonWidgetClass form
- (list XmNleftAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNbackground white)))
- ;; carrier freq
- (carrier (XtCreateManagedWidget "carrier freq:" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget play-button
- XmNrightAttachment XmATTACH_NONE
- XmNrecomputeSize #f
- XmNbackground white)))
- (freq-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget carrier
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget carrier
- XmNrightAttachment XmATTACH_NONE
- XmNbackground white)))
- (freq-scale (XtCreateManagedWidget "carrier freq" xmScaleWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget freq-label
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget freq-label
- XmNrightAttachment XmATTACH_FORM
- XmNshowValue #f
- XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
- ;; amp
- (amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget carrier
- XmNrightAttachment XmATTACH_NONE
- XmNrecomputeSize #f
- XmNbackground white)))
- (amp-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget amp
+(when (provided? 'snd-motif)
+ (with-let (sublet *motif*)
+ ;; set up our user-interface
+ (let* ((app (car (main-widgets)))
+
+ (shell (let* ((xdismiss (XmStringCreate "Go away" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "FM Forever!" XmFONTLIST_DEFAULT_TAG))
+ (dialog (XmCreateTemplateDialog (cadr (main-widgets)) "FM Forever!"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNtransient #f))))
+ (XtAddCallback dialog
+ XmNhelpCallback (lambda (w context info)
+ (snd-print "This dialog lets you experiment with simple FM")))
+ (XmStringFree xhelp)
+ (XmStringFree xdismiss)
+ (XmStringFree titlestr)
+ dialog))
+
+ (dpy (XtDisplay shell))
+ (screen (DefaultScreenOfDisplay dpy))
+ ;; (cmap (DefaultColormap dpy (DefaultScreen dpy)))
+ (black (BlackPixelOfScreen screen))
+ (white (WhitePixelOfScreen screen)))
+
+ (define (set-flabel label value)
+ (let ((s1 (XmStringCreate (format #f "~,3F" value) XmFONTLIST_DEFAULT_TAG)))
+ (XtVaSetValues label (list XmNlabelString s1))
+ (XmStringFree s1)))
+
+ (define (set-ilabel label value)
+ (let ((s1 (XmStringCreate (format #f "~D" value) XmFONTLIST_DEFAULT_TAG)))
+ (XtVaSetValues label (list XmNlabelString s1))
+ (XmStringFree s1)))
+
+ (let* ((light-blue *position-color*)
+ (form (XtCreateManagedWidget "form" xmFormWidgetClass shell
+ (list XmNbackground white
+ XmNforeground black
+ XmNresizePolicy XmRESIZE_GROW)))
+ ;; toggle named "play"
+ (play-button (XtCreateManagedWidget "play" xmToggleButtonWidgetClass form
+ (list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget amp
+ XmNtopAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_NONE
XmNbackground white)))
- (amp-scale (XtCreateManagedWidget "amp" xmScaleWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget amp-label
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget amp-label
- XmNrightAttachment XmATTACH_FORM
- XmNshowValue #f
- XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
- ;; fm index
- (fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget amp-scale
- XmNrightAttachment XmATTACH_NONE
- XmNrecomputeSize #f
- XmNbackground white)))
- (fm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
+ ;; carrier freq
+ (carrier (XtCreateManagedWidget "carrier freq:" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget play-button
+ XmNrightAttachment XmATTACH_NONE
+ XmNrecomputeSize #f
+ XmNbackground white)))
+ (freq-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget fm-index
+ XmNleftWidget carrier
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget fm-index
+ XmNtopWidget carrier
XmNrightAttachment XmATTACH_NONE
XmNbackground white)))
- (fm-scale (XtCreateManagedWidget "fm index" xmScaleWidgetClass form
+ (freq-scale (XtCreateManagedWidget "carrier freq" xmScaleWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget fm-label
+ XmNleftWidget freq-label
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget fm-label
+ XmNtopWidget freq-label
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground light-blue)))
- ;; c/m ratio
- (cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget fm-scale
- XmNrightAttachment XmATTACH_NONE
- XmNrecomputeSize #f
- XmNbackground white)))
- (cm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget cm-ratio
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget cm-ratio
- XmNrightAttachment XmATTACH_NONE
- XmNbackground white)))
- (cm-scale (XtCreateManagedWidget "cm ratio" xmScaleWidgetClass form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget cm-label
- XmNbottomAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget cm-label
- XmNrightAttachment XmATTACH_FORM
- XmNshowValue #f
- XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
- (frequency 220.0)
- (low-frequency 40.0)
- (high-frequency 2000.0)
- (amplitude 0.5)
- (index 1.0)
- (high-index 3.0)
- (ratio 1)
- (high-ratio 10)
- (playing 0.0)
- (carosc (make-oscil 0.0))
- (modosc (make-oscil 0.0)))
-
- (define (freq-callback w c i)
- (set! frequency (+ low-frequency (* (.value i) (/ (- high-frequency low-frequency) 100.0))))
- (set-flabel freq-label frequency))
-
- (define (amp-callback w c i)
- (set! amplitude (/ (.value i) 100.0))
- (set-flabel amp-label amplitude))
-
- (define (fm-callback w c i)
- (set! index (* (.value i) (/ high-index 100.0)))
- (set-flabel fm-label index))
-
- (define (ratio-callback w c i)
- (set! ratio (floor (* (.value i) (/ high-ratio 100.0))))
- (set-ilabel cm-label ratio))
-
- ;; add scale-change (drag and value-changed) callbacks
- (XtAddCallback freq-scale XmNdragCallback freq-callback)
- (XtAddCallback freq-scale XmNvalueChangedCallback freq-callback)
-
- (XtAddCallback amp-scale XmNdragCallback amp-callback)
- (XtAddCallback amp-scale XmNvalueChangedCallback amp-callback)
-
- (XtAddCallback fm-scale XmNdragCallback fm-callback)
- (XtAddCallback fm-scale XmNvalueChangedCallback fm-callback)
-
- (XtAddCallback cm-scale XmNdragCallback ratio-callback)
- (XtAddCallback cm-scale XmNvalueChangedCallback ratio-callback)
-
- (XtAddCallback play-button XmNvalueChangedCallback (lambda (w c i) (set! playing (if (.set i) 1.0 0.0))))
-
- ;; set initial values
- (set-flabel freq-label frequency)
- (set-flabel amp-label amplitude)
- (set-flabel fm-label index)
- (set-ilabel cm-label ratio)
-
- (XmScaleSetValue freq-scale (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency)))))
- (XmScaleSetValue amp-scale (floor (* 100 amplitude)))
- (XmScaleSetValue fm-scale (floor (* 100 (/ index high-index))))
- (XmScaleSetValue cm-scale (floor (* ratio (/ 100 high-ratio))))
-
- (XtManageChild shell)
- (XtRealizeWidget shell)
+ ;; amp
+ (amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget carrier
+ XmNrightAttachment XmATTACH_NONE
+ XmNrecomputeSize #f
+ XmNbackground white)))
+ (amp-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget amp
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget amp
+ XmNrightAttachment XmATTACH_NONE
+ XmNbackground white)))
+ (amp-scale (XtCreateManagedWidget "amp" xmScaleWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget amp-label
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget amp-label
+ XmNrightAttachment XmATTACH_FORM
+ XmNshowValue #f
+ XmNorientation XmHORIZONTAL
+ XmNbackground light-blue)))
+ ;; fm index
+ (fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget amp-scale
+ XmNrightAttachment XmATTACH_NONE
+ XmNrecomputeSize #f
+ XmNbackground white)))
+ (fm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget fm-index
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget fm-index
+ XmNrightAttachment XmATTACH_NONE
+ XmNbackground white)))
+ (fm-scale (XtCreateManagedWidget "fm index" xmScaleWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget fm-label
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget fm-label
+ XmNrightAttachment XmATTACH_FORM
+ XmNshowValue #f
+ XmNorientation XmHORIZONTAL
+ XmNbackground light-blue)))
+ ;; c/m ratio
+ (cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget fm-scale
+ XmNrightAttachment XmATTACH_NONE
+ XmNrecomputeSize #f
+ XmNbackground white)))
+ (cm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget cm-ratio
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget cm-ratio
+ XmNrightAttachment XmATTACH_NONE
+ XmNbackground white)))
+ (cm-scale (XtCreateManagedWidget "cm ratio" xmScaleWidgetClass form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget cm-label
+ XmNbottomAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget cm-label
+ XmNrightAttachment XmATTACH_FORM
+ XmNshowValue #f
+ XmNorientation XmHORIZONTAL
+ XmNbackground light-blue)))
+ (frequency 220.0)
+ (low-frequency 40.0)
+ (high-frequency 2000.0)
+ (amplitude 0.5)
+ (index 1.0)
+ (high-index 3.0)
+ (ratio 1)
+ (high-ratio 10)
+ (playing 0.0)
+ (carosc (make-oscil 0.0))
+ (modosc (make-oscil 0.0)))
+
+ (define (freq-callback w c i)
+ (set! frequency (+ low-frequency (* (.value i) (/ (- high-frequency low-frequency) 100.0))))
+ (set-flabel freq-label frequency))
+
+ (define (amp-callback w c i)
+ (set! amplitude (/ (.value i) 100.0))
+ (set-flabel amp-label amplitude))
+
+ (define (fm-callback w c i)
+ (set! index (* (.value i) (/ high-index 100.0)))
+ (set-flabel fm-label index))
+
+ (define (ratio-callback w c i)
+ (set! ratio (floor (* (.value i) (/ high-ratio 100.0))))
+ (set-ilabel cm-label ratio))
+
+ ;; add scale-change (drag and value-changed) callbacks
+ (XtAddCallback freq-scale XmNdragCallback freq-callback)
+ (XtAddCallback freq-scale XmNvalueChangedCallback freq-callback)
+
+ (XtAddCallback amp-scale XmNdragCallback amp-callback)
+ (XtAddCallback amp-scale XmNvalueChangedCallback amp-callback)
+
+ (XtAddCallback fm-scale XmNdragCallback fm-callback)
+ (XtAddCallback fm-scale XmNvalueChangedCallback fm-callback)
+
+ (XtAddCallback cm-scale XmNdragCallback ratio-callback)
+ (XtAddCallback cm-scale XmNvalueChangedCallback ratio-callback)
+
+ (XtAddCallback play-button XmNvalueChangedCallback (lambda (w c i) (set! playing (if (.set i) 1.0 0.0))))
+
+ ;; set initial values
+ (set-flabel freq-label frequency)
+ (set-flabel amp-label amplitude)
+ (set-flabel fm-label index)
+ (set-ilabel cm-label ratio)
+
+ (XmScaleSetValue freq-scale (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency)))))
+ (XmScaleSetValue amp-scale (floor (* 100 amplitude)))
+ (XmScaleSetValue fm-scale (floor (* 100 (/ index high-index))))
+ (XmScaleSetValue cm-scale (floor (* ratio (/ 100 high-ratio))))
+
+ (XtManageChild shell)
+ (XtRealizeWidget shell)
+
+ ;; send fm data to dac
+ (let* ((bufsize 256)
+ (srate 22050)
+ (work-proc #f)
+ ;(data (make-float-vector bufsize 0.0))
+ (port (mus-audio-open-output mus-audio-default srate 1 mus-lshort (* bufsize 2))))
+ (if (< port 0)
+ (format () "can't open DAC!"))
- ;; send fm data to dac
- (let* ((bufsize 256)
- (srate 22050)
- (work-proc #f)
- ;(data (make-float-vector bufsize 0.0))
- (port (mus-audio-open-output mus-audio-default srate 1 mus-lshort (* bufsize 2))))
- (if (< port 0)
- (format #t "can't open DAC!"))
-
- (XmAddWMProtocolCallback (cadr (main-widgets)) ; shell
- (XmInternAtom dpy "WM_DELETE_WINDOW" #f)
- (lambda (w c i)
- (XtRemoveWorkProc work-proc) ; odd that there's no XtAppRemoveWorkProc
- (mus-audio-close port))
- #f)
- (XtAddCallback shell
- XmNcancelCallback (lambda (w context info)
- (XtRemoveWorkProc work-proc)
- (mus-audio-close port)
- (XtUnmanageChild shell)))
- (set! work-proc (XtAppAddWorkProc app
- (lambda (ignored-arg)
- (let ((data (make-float-vector bufsize 0.0)))
- (do ((i 0 (+ 1 i)))
- ((= i bufsize))
- (float-vector-set! data i (* amplitude playing
- (oscil carosc
- (+ (hz->radians frequency)
- (* index
- (oscil modosc
- (hz->radians (* ratio frequency)))))))))
- (mus-audio-write port data bufsize)
- #f)))))))))
\ No newline at end of file
+ (XmAddWMProtocolCallback (cadr (main-widgets)) ; shell
+ (XmInternAtom dpy "WM_DELETE_WINDOW" #f)
+ (lambda (w c i)
+ (XtRemoveWorkProc work-proc) ; odd that there's no XtAppRemoveWorkProc
+ (mus-audio-close port))
+ #f)
+ (XtAddCallback shell
+ XmNcancelCallback (lambda (w context info)
+ (XtRemoveWorkProc work-proc)
+ (mus-audio-close port)
+ (XtUnmanageChild shell)))
+ (set! work-proc (XtAppAddWorkProc app
+ (lambda (ignored-arg)
+ (let ((data (make-float-vector bufsize 0.0)))
+ (do ((i 0 (+ 1 i)))
+ ((= i bufsize))
+ (float-vector-set! data i (* amplitude playing
+ (oscil carosc
+ (+ (hz->radians frequency)
+ (* index
+ (oscil modosc
+ (hz->radians (* ratio frequency)))))))))
+ (mus-audio-write port data bufsize)
+ #f)))))))))
diff --git a/bess1.scm b/bess1.scm
index 4dacc2c..98fc8e9 100644
--- a/bess1.scm
+++ b/bess1.scm
@@ -63,7 +63,7 @@
(let* ((frq-scl (hz->radians freq))
(maxdev (* frq-scl fm-index))
(index1 (* maxdev (/ 5.0 (log freq))))
- (index2 (* maxdev 3.0 (/ (- 8.5 (log freq)) (+ 3.0 (/ freq 1000)))))
+ (index2 (/ (* maxdev 3.0 (- 8.5 (log freq))) (+ 3.0 (/ freq 1000))))
(index3 (* maxdev (/ 4.0 (sqrt freq))))
(carrier (make-oscil :frequency freq))
(fmosc1 (make-oscil :frequency freq))
@@ -101,8 +101,8 @@
(dur 0.0))
(do ((i 0 (+ 1 i)))
((= i lim))
- (set! (vpits i) (floor (random 12.0)))
- (set! (vbegs i) (+ 1 (floor (random 3.0)))))
+ (set! (vpits i) (random 12))
+ (set! (vbegs i) (+ 1 (random 3))))
(set! *clm-srate* srate)
(set! *clm-rt-bufsize* bufsize)
(set! *output* (mus-audio-open-output mus-audio-default srate 1 sample-type (* bufsize 2)))
@@ -118,7 +118,7 @@
(if (> (random 1.0) 0.5) (set! cellsiz (+ 1 cellsiz)))
(set! cellctr cellbeg)))
- (format #t "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
+ (format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
dur
(let ((freq (* cfreq 16.351 16
(expt 2 (/ (vmode (vpits cellctr))
@@ -153,10 +153,8 @@
(define amps (make-vector (+ 1 lim) 0))
(define (tune x)
- (let* ((pit (modulo x 12))
- (oct (floor (/ x 12)))
- (base (rats pit)))
- (* base (expt 2 oct))))
+ (* (rats (modulo x 12))
+ (expt 2 (floor (/ x 12)))))
(define (rbell x)
(envelope-interp (* x 100) bell))
@@ -189,11 +187,11 @@
(do ((i 0 (+ i 1)))
((= i lim))
(set! (octs i) (floor (+ 4 (* 2 (rbell (random 1.0))))))
- (set! (pits i) (mode (floor (random 12.0))))
- (set! (rhys i) (floor (+ 4 (random 6.0))))
+ (set! (pits i) (mode (random 12)))
+ (set! (rhys i) (+ 4 (random 6)))
(set! (begs i) (if (< (random 1.0) 0.9)
- (floor (+ 4 (random 2.0)))
- (floor (random 24.0))))
+ (+ 4 (random 2))
+ (random 24)))
(set! (amps i) (floor (+ 1 (* 8 (rbell (random 1.0)))))))
(set! *clm-srate* srate)
(set! *clm-rt-bufsize* bufsize)
@@ -213,12 +211,14 @@
(begin
(set! cellbeg (+ 1 cellbeg))
(if (> (random 1.0) 0.5) (set! cellsiz (+ cellsiz whichway)))
- (if (and (> cellsiz 10) (> (random 1.0) 0.99))
- (set! whichway -2)
- (if (and (> cellsiz 6) (> (random 1.0) 0.999))
- (set! whichway -1)
- (if (< cellsiz 4)
- (set! whichway 1))))
+ (cond ((and (> cellsiz 10)
+ (> (random 1.0) 0.99))
+ (set! whichway -2))
+ ((and (> cellsiz 6)
+ (> (random 1.0) 0.999))
+ (set! whichway -1))
+ ((< cellsiz 4)
+ (set! whichway 1)))
(set! nextbeg (+ nextbeg (random 1.0)))
(set! cellctr cellbeg)))
(set! func (make-rt-violin dur freq ampl
@@ -263,11 +263,11 @@
(shell (car shell-app))
(dpy (XtDisplay shell))
(screen (DefaultScreenOfDisplay dpy))
- (cmap (DefaultColormap dpy (DefaultScreen dpy)))
(black (BlackPixelOfScreen screen)))
(define (get-color color)
- (let ((col (XColor)))
+ (let ((col (XColor))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(if (= (XAllocNamedColor dpy cmap color col col) 0)
(error (format #f "can't allocate ~A" color))
(.pixel col))))
@@ -444,7 +444,6 @@
XmNbackground light-blue)))
(low-tempo 0.05)
(high-tempo 0.5)
- (high-amp 1.0)
(low-freq 0.1)
(high-freq 4.0)
(high-index 2.0)
@@ -457,7 +456,8 @@
(set-flabel tempo-label ctempo))
(define (amp-callback w c i)
- (set! camp (* (.value i) (/ high-amp 100.0)))
+ (let ((high-amp 1.0))
+ (set! camp (* (.value i) (/ high-amp 100.0))))
(set-flabel amp-label camp))
(define (freq-callback w c i)
@@ -523,9 +523,7 @@
(if cplay
(begin
(set-defaults)
- (if (= which-play 0)
- (set! func (apply make-agn (or args ())))
- (set! func (apply make-float-vector-test (or args ()))))
+ (set! func (apply (if (= which-play 0) make-agn make-float-vector-test) (or args ())))
(set! proc (XtAppAddWorkProc app (lambda (c) (rt-send->dac func)))))
(if proc (XtRemoveWorkProc proc)))))
(XmToggleButtonSetState play-button cplay #f)
diff --git a/big-gens.scm b/big-gens.scm
index 222bb04..561c088 100644
--- a/big-gens.scm
+++ b/big-gens.scm
@@ -9,7 +9,7 @@
(/ (* hz 2 pi) *clm-srate*))
(define (big-radians->hz rad)
- (/ (* rad *clm-srate*) (* 2 pi)))
+ (/ (* rad *clm-srate*) 2 pi))
(define (big-db->linear x)
(expt 10.0 (/ x 20.0)))
@@ -59,8 +59,7 @@
(do ((i 0 (+ i 1)))
((= i len))
(set! pk (max pk (abs (v i)))))
- (if (and (not (= pk 0.0))
- (not (= pk 1.0)))
+ (if (not (member pk '(0.0 1.0) =))
(do ((i 0 (+ i 1)))
((= i len))
(set! (v i) (/ (v i) pk))))
@@ -92,11 +91,11 @@
;;; -------- dot-product --------
(define (big-dot-product v1 v2)
- (let ((len (min (length v1) (length v2))))
- (do ((sum 0.0)
- (i 0 (+ i 1)))
- ((= i len) sum)
- (set! sum (+ sum (* (v1 i) (v2 i)))))))
+ (do ((len (min (length v1) (length v2)))
+ (sum 0.0)
+ (i 0 (+ i 1)))
+ ((= i len) sum)
+ (set! sum (+ sum (* (v1 i) (v2 i))))))
;;; -------- ring-modulate --------
@@ -181,31 +180,31 @@
:make-wrapper
(lambda (g)
(letrec ((ns (lambda (x n)
- (let* ((a2 (/ x 2))
- (den (sin a2)))
- (if (= den 0.0)
- 0.0
- (/ (* (sin (* n a2))
- (sin (* (+ n 1) a2)))
- den)))))
+ (let* ((a2 (/ x 2))
+ (den (sin a2)))
+ (if (= den 0.0)
+ 0.0
+ (/ (* (sin (* n a2))
+ (sin (* (+ n 1) a2)))
+ den)))))
(find-scaler (lambda (n lo hi)
- (let ((mid (/ (+ lo hi) 2))
- (ylo (ns lo n))
- (yhi (ns hi n)))
- (if (< (abs (- yhi ylo)) 1e-12)
- (ns mid n)
- (if (> ylo yhi)
- (find-scaler n lo mid)
- (find-scaler n mid hi)))))))
- (if (<= (g 'n) 0)
- (set! (g 'n) 1))
- (set! (g 'r) (/ 1.0 (find-scaler (g 'n) 0.0 (/ pi (+ (g 'n) 1/2)))))
- (set! (g 'frequency) (big-hz->radians (g 'frequency)))
- g)))
- (frequency *clm-default-frequency*)
- (n 1)
- (angle 0.0)
- (r 1.0))
+ (let ((mid (/ (+ lo hi) 2))
+ (ylo (ns lo n))
+ (yhi (ns hi n)))
+ (if (< (abs (- yhi ylo)) 1e-12)
+ (ns mid n)
+ (find-scaler n (if (> ylo yhi)
+ (values lo mid)
+ (values mid hi))))))))
+ (if (<= (g 'n) 0)
+ (set! (g 'n) 1))
+ (set! (g 'r) (/ 1.0 (find-scaler (g 'n) 0.0 (/ pi (+ (g 'n) 1/2)))))
+ (set! (g 'frequency) (big-hz->radians (g 'frequency)))
+ g)))
+ (frequency *clm-default-frequency*)
+ (n 1)
+ (angle 0.0)
+ (r 1.0))
(define* (big-nsin gen (fm 0.0))
(let* ((n (gen 'n))
@@ -232,9 +231,9 @@
(defgenerator (big-table-lookup
:make-wrapper
(lambda (g)
- (if (not (g 'wave))
- (set! (g 'wave) (make-vector (g 'size) 0.0))
- (set! (g 'size) (length (g 'wave))))
+ (if (g 'wave)
+ (set! (g 'size) (length (g 'wave)))
+ (set! (g 'wave) (make-vector (g 'size) 0.0)))
(set! (g 'frequency) (/ (* (g 'frequency) (g 'size)) *clm-srate*))
(set! (g 'angle) (/ (* (g 'angle) (g 'size)) (* 2 pi)))
g))
@@ -247,7 +246,7 @@
(let ((x (gen 'angle))
(w (gen 'wave))
(n (gen 'size)))
- (set! (gen 'angle) (+ x (gen 'frequency) (/ (* fm n) (* 2 pi))))
+ (set! (gen 'angle) (+ x (gen 'frequency) (/ (* fm n) 2 pi)))
(big-array-interp w x n)))
#|
diff --git a/binary-io.scm b/binary-io.scm
index 07697b1..b5ce723 100644
--- a/binary-io.scm
+++ b/binary-io.scm
@@ -14,11 +14,12 @@
(do ((c (read-byte) (read-byte)))
((or (eof-object? c)
(= c 0))
- (apply string (reverse chars)))
+ (reverse (apply string chars)))
(set! chars (cons (integer->char c) chars)))))
(define (io-write-string str)
- (for-each write-char str) ; or maybe (lambda (c) (write-byte (char->integer c)))
+ (format () "~{~A~}" str)
+ ;(for-each write-char str)
(write-byte 0))
@@ -31,7 +32,8 @@
(set! (str i) (read-char)))))
(define (write-chars str)
- (for-each write-char str))
+ (format () "~{~A~}" str))
+; (for-each write-char str))
;;; -------- 16-bit ints
@@ -72,16 +74,15 @@
int)))
(define (write-bint32 int)
- (write-byte (logand (ash int -24) #xff))
- (write-byte (logand (ash int -16) #xff))
- (write-byte (logand (ash int -8) #xff))
- (write-byte (logand int #xff)))
-
+ (for-each write-byte (vector (logand (ash int -24) 255)
+ (logand (ash int -16) 255)
+ (logand (ash int -8) 255)
+ (logand int 255))))
(define (write-lint32 int)
- (write-byte (logand int #xff))
- (write-byte (logand (ash int -8) #xff))
- (write-byte (logand (ash int -16) #xff))
- (write-byte (logand (ash int -24) #xff)))
+ (for-each write-byte (vector (logand int 255)
+ (logand (ash int -8) 255)
+ (logand (ash int -16) 255)
+ (logand (ash int -24) 255))))
;;; -------- 64-bit ints
@@ -135,7 +136,7 @@
;; we're assuming floats are (64-bit) doubles in s7, so this is coercing to a 32-bit float in a sense
;; this causes some round-off error
(logior (if (negative? sign) #x80000000 0)
- (ash (+ expon 52 127) 23)
+ (ash (+ expon 179) 23) ; 179 = (+ 52 127)
(logand (ash signif -29) #x7fffff)))))
(define (write-bfloat32 flt)
@@ -170,7 +171,7 @@
(if (= expon signif 0)
0
(logior (if (negative? sign) #x8000000000000000 0)
- (ash (+ expon 52 1023) 52)
+ (ash (+ expon 1075) 52) ; 1075 = (+ 52 1023)
(logand signif #xfffffffffffff)))))
(define (write-bfloat64 flt)
@@ -216,7 +217,7 @@
(if (not (zero? val))
(begin
(set! exp (round (+ (log val 2.0) 16383.0)))
- (set! val (* val (expt 2 (- (+ 16383 31) exp))))
+ (set! val (* val (expt 2 (- 16414 exp)))) ; 16414 = (+ 16383 31)
(set! mant1 (floor val))
(set! val (- val mant1))
(set! mant0 (floor (* val (expt 2 32))))))
@@ -241,12 +242,12 @@
(let ((magic (read-chars 4)))
(if (not (string=? magic ".snd"))
(error 'bad-header "~A is not an au file: ~A" file)
- (let ((data-location (read-bint32))
- (data-size (read-bint32))
- (sample-type (read-bint32))
- (srate (read-bint32))
- (chns (read-bint32))
- (comment (io-read-string)))
+ (let* ((data-location (read-bint32))
+ (data-size (read-bint32))
+ (sample-type (read-bint32))
+ (srate (read-bint32))
+ (chns (read-bint32))
+ (comment (io-read-string)))
(list magic data-location data-size sample-type srate chns comment)))))))
(define (write-au-header file chns srate data-size sample-type comment) ; data-size in bytes
@@ -257,11 +258,7 @@
(data-location (+ 24 (* 4 (floor (+ 1 (/ comlen 4))))))
(curloc 24))
(write-chars ".snd")
- (write-bint32 data-location)
- (write-bint32 data-size)
- (write-bint32 sample-type)
- (write-bint32 srate)
- (write-bint32 chns)
+ (for-each write-bint32 (vector data-location data-size sample-type srate chns))
(if (> comlen 0)
(begin
(io-write-string comment)
@@ -286,8 +283,7 @@
(let (;(size (read-bint32))
(magic (read-chars 4)))
(set! current-location 12)
- (if (and (not (string=? magic "AIFF"))
- (not (string=? magic "AIFC")))
+ (if (not (member magic '("AIFF" "AIFC") string=?))
(error 'bad-header "~A is not an aif file: ~A" file magic)
;; now look for the "SSND" and "COMM" chunks
(call-with-exit
diff --git a/bird.scm b/bird.scm
index 351a87d..52128f5 100644
--- a/bird.scm
+++ b/bird.scm
@@ -48,7 +48,6 @@
(oridwn '(.00 1.00 1.00 .0))
(oriupdwna '(.00 .00 .60 1.00 1.00 .60 ))
(oriupdwnb '(.00 .50 .30 1.00 1.00 .0))
- (oribiga '(.00 .90 .15 1.00 .40 .30 .60 .60 .85 .00 1.00 .0))
(orimid '(.00 1.00 .05 .50 .10 1.00 .25 .00 .85 .50 1.00 .0))
(oridwnup '(.00 .30 .25 .00 1.00 1.0))
(oriamp '(.00 .00 .10 1.00 1.00 .0)))
@@ -57,7 +56,8 @@
(bird (+ beg .41) .05 2500 1000 .1 oriup main-amp)
(bigbird (+ beg .5) .1 2000 800 .2 oriupdwna main-amp '(1 1 2 .02 3 .05))
(bird (+ beg .65) .03 3900 1200 .1 oridwn main-amp)
- (bigbird (+ beg .7) .21 2000 1200 .15 oribiga main-amp '(1 1 2 .05))
+ (let ((oribiga '(.00 .90 .15 1.00 .40 .30 .60 .60 .85 .00 1.00 .0)))
+ (bigbird (+ beg .7) .21 2000 1200 .15 oribiga main-amp '(1 1 2 .05)))
(bird (+ beg 1.0) .05 4200 1000 .1 oridwn main-amp)
(bigbird (+ beg 1.1) .1 2000 1000 .25 orimid main-amp '(1 1 2 .05))
(bigbird (+ beg 1.3) .1 2000 1000 .25 orimid main-amp '(1 1 2 .05))
@@ -117,11 +117,11 @@
(define b-western-meadowlark
(let ((documentation "(western-meadowlark beg) produces a western meadowlark call at time 'beg'"))
(lambda (beg)
- (let ((no-skw '(.00 .00 1.00 .0))
- (down-skw '(.00 1.00 .40 .40 1.00 .0))
+ (let ((down-skw '(.00 1.00 .40 .40 1.00 .0))
(fas-down '(.00 1.00 1.00 .0)))
(set! beg (- beg .8))
- (bigbird (+ beg .800) .1 2010.000 0.000 .100 no-skw main-amp '(1 1 2 .04))
+ (let ((no-skw '(.00 .00 1.00 .0)))
+ (bigbird (+ beg .800) .1 2010.000 0.000 .100 no-skw main-amp '(1 1 2 .04)))
(bigbird (+ beg 1.100) .15 3000.000 100.000 .110 down-skw main-amp '(1 1 2 .04))
(bigbird (+ beg 1.300) .25 2000.000 150.000 .200 down-skw main-amp '(1 1 2 .04))
(bigbird (+ beg 1.650) .15 3010.000 250.000 .110 down-skw main-amp '(1 1 2 .04))
@@ -173,12 +173,12 @@
(define b-yellow-warbler
(let ((documentation "(yellow-warbler beg) produces a yellow warbler call at time 'beg'"))
(lambda (beg)
- (let ((yellow-up '(.00 .00 .60 1.00 1.00 .50 ))
- (yellow-swirl '(.00 1.00 .05 1.00 .60 .00 .80 .30 1.00 .10 ))
+ (let ((yellow-swirl '(.00 1.00 .05 1.00 .60 .00 .80 .30 1.00 .10 ))
(yellow-down '(.00 1.00 1.00 .0))
(yellow-last '(.00 .00 .30 .20 .80 .70 1.00 1.0))
(swirl-amp '(.00 .00 .90 1.00 1.00 .0)))
- (bird beg .05 5600 400 .05 yellow-up main-amp)
+ (let ((yellow-up '(.00 .00 .60 1.00 1.00 .50 )))
+ (bird beg .05 5600 400 .05 yellow-up main-amp))
(bird (+ beg .23) .12 5000 1500 .15 yellow-swirl swirl-amp)
(bird (+ beg .45) .13 5000 1700 .17 yellow-swirl swirl-amp)
(bird (+ beg .62) .16 5000 2000 .20 yellow-swirl swirl-amp)
@@ -310,13 +310,13 @@
(buntv '(.00 .00 .50 1.00 1.00 .0))
(bunty '(.00 1.00 .50 .00 1.00 .90 ))
(buntn '(.00 .80 .30 1.00 .70 .20 1.00 .0))
- (buntx '(.00 1.00 .10 .50 .25 .90 1.00 .0))
(buntup '(.00 .00 1.00 1.0)))
(set! beg (- beg .4))
(bird (+ beg .4) .08 3000 700 .25 buntdwn main-amp)
(bird (+ beg .52) .02 6200 1000 .05 buntdwn main-amp)
(bird (+ beg .55) .15 3500 2300 .1 buntv main-amp)
- (bird (+ beg .74) .02 6200 1800 .05 buntx main-amp)
+ (let ((buntx '(.00 1.00 .10 .50 .25 .90 1.00 .0)))
+ (bird (+ beg .74) .02 6200 1800 .05 buntx main-amp))
(bird (+ beg .80) .15 3400 2300 .1 buntv main-amp)
(bird (+ beg 1.00) .1 3400 800 .2 buntv main-amp)
(bird (+ beg 1.13) .03 4100 2000 .05 buntdwn main-amp)
@@ -382,18 +382,18 @@
(define b-louisiana-waterthrush
(let ((documentation "(louisiana-waterthrush beg) produces a louisiana waterthrush call at time 'beg'"))
(lambda (beg)
- (let ((water-one '(.00 .80 .35 .40 .45 .90 .50 1.00 .75 1.00 1.00 .10 ))
- (water-two '(.00 1.00 .40 .00 .60 .10 1.00 .80 ))
- (water-three '(.00 1.00 .95 .00 1.00 .0))
- (water-four '(.00 .00 1.00 1.0))
+ (let ((water-four '(.00 .00 1.00 1.0))
(water-five '(.00 1.00 1.00 .0))
- (water-amp '(.00 .00 .35 1.00 .50 .20 .90 1.00 1.00 .0))
(water-damp '(.00 .00 .90 1.00 1.00 .0)))
- (bird beg .17 4100 2000 .2 water-one water-amp)
- (bird (+ beg .32) .18 4050 2050 .3 water-one water-amp)
- (bird (+ beg .64) .20 4000 1900 .25 water-one water-amp)
- (bird (+ beg .9) .2 3900 2000 .3 water-two bird-tap)
- (bird (+ beg 1.25) .12 3000 3000 .25 water-three water-damp)
+ (let ((water-one '(.00 .80 .35 .40 .45 .90 .50 1.00 .75 1.00 1.00 .10 ))
+ (water-amp '(.00 .00 .35 1.00 .50 .20 .90 1.00 1.00 .0)))
+ (bird beg .17 4100 2000 .2 water-one water-amp)
+ (bird (+ beg .32) .18 4050 2050 .3 water-one water-amp)
+ (bird (+ beg .64) .20 4000 1900 .25 water-one water-amp))
+ (let ((water-two '(.00 1.00 .40 .00 .60 .10 1.00 .80 )))
+ (bird (+ beg .9) .2 3900 2000 .3 water-two bird-tap))
+ (let ((water-three '(.00 1.00 .95 .00 1.00 .0)))
+ (bird (+ beg 1.25) .12 3000 3000 .25 water-three water-damp))
(bird (+ beg 1.4) .1 2700 1500 .2 water-four water-damp)
(bird (+ beg 1.58) .02 5200 1000 .1 water-five main-amp)
(bird (+ beg 1.65) .02 5200 1000 .1 water-five main-amp)
@@ -403,18 +403,18 @@
(define b-robin
(let ((documentation "(robin beg) produces a robin call at time 'beg'"))
(lambda (beg)
- (let ((r-one '(.00 .10 .08 .70 .30 .00 .35 1.00 .40 .30 1.00 .30 ))
- (r-two '(.00 .00 .10 1.00 .20 .70 .35 .70 .65 .30 .70 .50 .80 .00 .90 .20 1.00 .0))
- (r-three '(.00 .20 .25 1.00 .60 .70 .90 .00 1.00 .10 ))
- (r-four '(.00 1.00 1.00 .0))
- (r-five '(.00 .50 .10 .00 .20 1.00 .30 .00 .40 1.00 .50 .00 .60 1.00 .70 .50 1.00 .20 ))
- (r-six '(.00 .00 .12 .70 .30 .00 .70 1.00 1.00 .50 )))
- (set! beg (- beg .45))
- (bigbird (+ beg .45) .06 2000 800 .15 r-six main-amp '(1 1 2 .1))
- (bigbird (+ beg .56) .10 2000 900 .15 r-one main-amp '(1 1 2 .1))
- (bigbird (+ beg 1.04) .24 2000 2000 .25 r-two main-amp '(1 1 2 .1))
- (bigbird (+ beg 1.63) .13 1900 1600 .20 r-three main-amp '(1 1 2 .1))
- (bigbird (+ beg 1.80) .11 2200 1200 .25 r-four main-amp '(1 1 2 .1))
+ (set! beg (- beg .45))
+ (let ((r-six '(.00 .00 .12 .70 .30 .00 .70 1.00 1.00 .50 )))
+ (bigbird (+ beg .45) .06 2000 800 .15 r-six main-amp '(1 1 2 .1)))
+ (let ((r-one '(.00 .10 .08 .70 .30 .00 .35 1.00 .40 .30 1.00 .30 )))
+ (bigbird (+ beg .56) .10 2000 900 .15 r-one main-amp '(1 1 2 .1)))
+ (let ((r-two '(.00 .00 .10 1.00 .20 .70 .35 .70 .65 .30 .70 .50 .80 .00 .90 .20 1.00 .0)))
+ (bigbird (+ beg 1.04) .24 2000 2000 .25 r-two main-amp '(1 1 2 .1)))
+ (let ((r-three '(.00 .20 .25 1.00 .60 .70 .90 .00 1.00 .10 )))
+ (bigbird (+ beg 1.63) .13 1900 1600 .20 r-three main-amp '(1 1 2 .1)))
+ (let ((r-four '(.00 1.00 1.00 .0)))
+ (bigbird (+ beg 1.80) .11 2200 1200 .25 r-four main-amp '(1 1 2 .1)))
+ (let ((r-five '(.00 .50 .10 .00 .20 1.00 .30 .00 .40 1.00 .50 .00 .60 1.00 .70 .50 1.00 .20 )))
(bigbird (+ beg 2.31) .21 1950 2000 .15 r-five main-amp '(1 1 2 .1))))))
@@ -463,19 +463,19 @@
(define b-cerulean-warbler
(let ((documentation "(cerulean-warbler beg) produces a cerulean warbler call at time 'beg'"))
(lambda (beg)
- (let ((w-down '(.00 1.00 1.00 .0))
- (trill '(.00 .80 .10 1.00 .25 .50 .40 1.00 .55 .50 .70 1.00 1.00 .0))
- (w-up '(.00 .00 1.00 1.0)))
+ (let ((w-up '(.00 .00 1.00 1.0)))
(set! beg (- beg .27))
- (bird (+ beg .27) .05 3000 1000 .05 w-down main-amp)
- (bird (+ beg .33) .05 3000 800 .075 w-up main-amp)
- (bird (+ beg .41) .01 3200 700 .07 w-down main-amp)
- (bird (+ beg .42) .01 3200 700 .08 w-down main-amp)
- (bird (+ beg .43) .06 3200 700 .09 w-down main-amp)
+ (let ((w-down '(.00 1.00 1.00 .0)))
+ (bird (+ beg .27) .05 3000 1000 .05 w-down main-amp)
+ (bird (+ beg .33) .05 3000 800 .075 w-up main-amp)
+ (bird (+ beg .41) .01 3200 700 .07 w-down main-amp)
+ (bird (+ beg .42) .01 3200 700 .08 w-down main-amp)
+ (bird (+ beg .43) .06 3200 700 .09 w-down main-amp))
(bird (+ beg .51) .06 3200 500 .1 w-up main-amp)
- (bird (+ beg .6) .10 3000 1200 .2 trill main-amp)
- (bird (+ beg .72) .05 3000 800 .2 w-up main-amp)
- (bird (+ beg .8) .10 3000 1200 .2 trill main-amp)
+ (let ((trill '(.00 .80 .10 1.00 .25 .50 .40 1.00 .55 .50 .70 1.00 1.00 .0)))
+ (bird (+ beg .6) .10 3000 1200 .2 trill main-amp)
+ (bird (+ beg .72) .05 3000 800 .2 w-up main-amp)
+ (bird (+ beg .8) .10 3000 1200 .2 trill main-amp))
(bird (+ beg .92) .05 3000 800 .2 w-up main-amp)
(bird (+ beg 1.00) .01 3900 600 .1 w-up main-amp)
(bird (+ beg 1.01) .01 3910 800 .1 w-up main-amp)
@@ -536,49 +536,49 @@
(define b-eastern-phoebe
(let ((documentation "(eastern-phoebe beg) produces an eastern-phoebe call at time 'beg'"))
(lambda (beg)
- (let ((phoebe-one '(.00 .00 .30 .30 .35 .50 .55 .40 .70 .80 .75 .70 .80 1.00 .95 .90 1.00 .0))
- (phoebe-two '(.00 .00 .50 1.00 1.00 .0))
- (phoebe-three '(.00 .00 .10 .40 .80 1.00 1.00 .10 ))
- (phoebe-four '(.00 1.00 .50 .70 1.00 .0))
- (phoebe-amp '(.00 .00 .10 1.00 1.00 .0)))
- (bird beg .225 3000 1300 .3 phoebe-one main-amp)
- (bird (+ beg .35) .12 3000 500 .1 phoebe-two phoebe-amp)
- (bird (+ beg .4) .10 3000 1500 .2 phoebe-three phoebe-amp)
- (bird (+ beg .55) .05 3000 1400 .2 phoebe-four phoebe-amp)))))
+ (let ((phoebe-amp '(.00 .00 .10 1.00 1.00 .0)))
+ (let ((phoebe-one '(.00 .00 .30 .30 .35 .50 .55 .40 .70 .80 .75 .70 .80 1.00 .95 .90 1.00 .0)))
+ (bird beg .225 3000 1300 .3 phoebe-one main-amp))
+ (let ((phoebe-two '(.00 .00 .50 1.00 1.00 .0)))
+ (bird (+ beg .35) .12 3000 500 .1 phoebe-two phoebe-amp))
+ (let ((phoebe-three '(.00 .00 .10 .40 .80 1.00 1.00 .10 )))
+ (bird (+ beg .4) .10 3000 1500 .2 phoebe-three phoebe-amp))
+ (let ((phoebe-four '(.00 1.00 .50 .70 1.00 .0)))
+ (bird (+ beg .55) .05 3000 1400 .2 phoebe-four phoebe-amp))))))
(define b-painted-bunting
(let ((documentation "(painted-bunting beg) produces a painted bunting call at time 'beg'"))
(lambda (beg)
- (let ((b-one '(.00 .00 1.00 1.0))
- (b-two '(.00 .00 .90 1.00 1.00 .0))
- (b-three '(.00 1.00 1.00 .0))
- (b-four '(.00 .00 .50 1.00 1.00 .0))
- (b-five '(.00 .70 .15 .00 .40 1.00 .80 1.00 1.00 .50 ))
- (b-six '(.00 .00 .10 .50 .15 .00 .40 1.00 .90 1.00 1.00 .0))
- (b-seven '(.00 1.00 .25 .40 .75 .50 1.00 .0))
- (b-eight '(.00 .30 .40 .40 .50 1.00 .60 .20 1.00 .0))
- (b-nine '(.00 .00 .05 1.00 .30 1.00 .50 .30 .90 1.00 1.00 .0))
- (b-ten '(.00 .40 .25 .00 .35 1.00 .50 .00 .65 1.00 .75 .00 .85 1.00 1.00 .0))
- (b-eleven '(.00 1.00 1.00 .0))
- (b-twelve '(.00 .00 .50 1.00 1.00 .50 ))
- (b-thirteen '(.00 .00 .05 1.00 .30 .20 .60 .20 .90 1.00 1.00 .0))
- (b-fourteen '(.00 .30 .30 1.00 .60 .30 1.00 .0))
- (b-fifteen '(.00 .00 .10 .50 .50 .50 .90 1.00 1.00 .0)))
+ (let ((b-one '(.00 .00 1.00 1.0)))
(set! beg (- beg .05))
- (bird (+ beg .05) .10 3100 900 .05 b-one b-two)
- (bird (+ beg .21) .07 4100 700 .15 b-three main-amp)
- (bird (+ beg .36) .12 3700 1000 .20 b-four main-amp)
- (bird (+ beg .52) .08 2300 1600 .15 b-five b-six)
+ (let ((b-two '(.00 .00 .90 1.00 1.00 .0)))
+ (bird (+ beg .05) .10 3100 900 .05 b-one b-two))
+ (let ((b-three '(.00 1.00 1.00 .0)))
+ (bird (+ beg .21) .07 4100 700 .15 b-three main-amp))
+ (let ((b-four '(.00 .00 .50 1.00 1.00 .0)))
+ (bird (+ beg .36) .12 3700 1000 .20 b-four main-amp))
+ (let ((b-five '(.00 .70 .15 .00 .40 1.00 .80 1.00 1.00 .50 ))
+ (b-six '(.00 .00 .10 .50 .15 .00 .40 1.00 .90 1.00 1.00 .0)))
+ (bird (+ beg .52) .08 2300 1600 .15 b-five b-six))
(bird (+ beg .68) .1 4000 1000 .25 b-one bird-tap)
- (bird (+ beg .8) .12 2300 1700 .2 b-seven main-amp)
- (bird (+ beg .96) .15 3800 2200 .3 b-eight b-nine)
- (bird (+ beg 1.18) .1 2300 1600 .15 b-ten main-amp)
- (bird (+ beg 1.3) .02 3200 1000 .1 b-eleven main-amp)
- (bird (+ beg 1.33) .02 3200 1000 .1 b-eleven main-amp)
- (bird (+ beg 1.36) .02 3200 1000 .1 b-eleven main-amp)
- (bird (+ beg 1.40) .03 4000 2000 .12 b-twelve b-thirteen)
- (bird (+ beg 1.47) .1 2300 1700 .2 b-fourteen b-fifteen)))))
+ (let ((b-seven '(.00 1.00 .25 .40 .75 .50 1.00 .0)))
+ (bird (+ beg .8) .12 2300 1700 .2 b-seven main-amp))
+ (let ((b-eight '(.00 .30 .40 .40 .50 1.00 .60 .20 1.00 .0))
+ (b-nine '(.00 .00 .05 1.00 .30 1.00 .50 .30 .90 1.00 1.00 .0)))
+ (bird (+ beg .96) .15 3800 2200 .3 b-eight b-nine))
+ (let ((b-ten '(.00 .40 .25 .00 .35 1.00 .50 .00 .65 1.00 .75 .00 .85 1.00 1.00 .0)))
+ (bird (+ beg 1.18) .1 2300 1600 .15 b-ten main-amp))
+ (let ((b-eleven '(.00 1.00 1.00 .0)))
+ (bird (+ beg 1.3) .02 3200 1000 .1 b-eleven main-amp)
+ (bird (+ beg 1.33) .02 3200 1000 .1 b-eleven main-amp)
+ (bird (+ beg 1.36) .02 3200 1000 .1 b-eleven main-amp))
+ (let ((b-twelve '(.00 .00 .50 1.00 1.00 .50 ))
+ (b-thirteen '(.00 .00 .05 1.00 .30 .20 .60 .20 .90 1.00 1.00 .0)))
+ (bird (+ beg 1.40) .03 4000 2000 .12 b-twelve b-thirteen))
+ (let ((b-fourteen '(.00 .30 .30 1.00 .60 .30 1.00 .0))
+ (b-fifteen '(.00 .00 .10 .50 .50 .50 .90 1.00 1.00 .0)))
+ (bird (+ beg 1.47) .1 2300 1700 .2 b-fourteen b-fifteen))))))
(define b-western-flycatcher
@@ -595,12 +595,10 @@
(define b-bachmans-sparrow
(let ((documentation "(bachmans-sparrow beg) produces a bachmans sparrow call at time 'beg'"))
(lambda (beg)
- (let ((sopening '(.00 1.00 .10 .50 .90 .50 1.00 .0))
- (sup '(.00 .10 .35 .00 1.00 1.0))
- (sdwn '(.00 1.00 .40 .50 1.00 .0))
- (supn '(.00 .00 1.00 1.0))
- (slast '(.00 1.00 .25 .00 .75 .40 1.00 .50 )))
- (bird beg .51 4900 200 .3 sopening main-amp)
+ (let ((sup '(.00 .10 .35 .00 1.00 1.0))
+ (sdwn '(.00 1.00 .40 .50 1.00 .0)))
+ (let ((sopening '(.00 1.00 .10 .50 .90 .50 1.00 .0)))
+ (bird beg .51 4900 200 .3 sopening main-amp))
(bird (+ beg .52) .015 3800 200 .1 sup main-amp)
(bird (+ beg .52) .015 3750 250 .1 sup main-amp)
(bird (+ beg .54) .015 3600 300 .1 sup main-amp)
@@ -624,23 +622,25 @@
(bird (+ beg 1.55) .07 3000 750 .2 sup main-amp)
(bird (+ beg 1.63) .03 5000 1000 .1 sdwn main-amp)
- (bird (+ beg 2.8) .06 4000 1700 .1 supn main-amp)
- (bird (+ beg 2.87) .01 5200 0 .2 supn main-amp)
- (bird (+ beg 2.9) .06 4000 1700 .1 supn main-amp)
- (bird (+ beg 2.97) .01 5200 0 .2 supn main-amp)
- (bird (+ beg 3.0) .06 4000 1700 .1 supn main-amp)
- (bird (+ beg 3.07) .01 5200 0 .2 supn main-amp)
- (bird (+ beg 3.1) .06 4000 1700 .1 supn main-amp)
- (bird (+ beg 3.17) .01 5200 0 .2 supn main-amp)
- (bird (+ beg 3.2) .06 4000 1700 .1 supn main-amp)
- (bird (+ beg 3.27) .01 5200 0 .2 supn main-amp)
+ (let ((supn '(.00 .00 1.00 1.0)))
+ (bird (+ beg 2.8) .06 4000 1700 .1 supn main-amp)
+ (bird (+ beg 2.87) .01 5200 0 .2 supn main-amp)
+ (bird (+ beg 2.9) .06 4000 1700 .1 supn main-amp)
+ (bird (+ beg 2.97) .01 5200 0 .2 supn main-amp)
+ (bird (+ beg 3.0) .06 4000 1700 .1 supn main-amp)
+ (bird (+ beg 3.07) .01 5200 0 .2 supn main-amp)
+ (bird (+ beg 3.1) .06 4000 1700 .1 supn main-amp)
+ (bird (+ beg 3.17) .01 5200 0 .2 supn main-amp)
+ (bird (+ beg 3.2) .06 4000 1700 .1 supn main-amp)
+ (bird (+ beg 3.27) .01 5200 0 .2 supn main-amp))
- (bird (+ beg 3.4) .15 3000 1000 .2 slast main-amp)
- (bird (+ beg 3.6) .15 3000 1000 .2 slast main-amp)
- (bird (+ beg 3.8) .15 3000 1000 .2 slast main-amp)
- (bird (+ beg 4.0) .15 3000 1000 .2 slast main-amp)
- (bird (+ beg 4.2) .15 3000 1000 .2 slast main-amp)
- (bird (+ beg 4.4) .15 3000 1000 .2 slast main-amp)))))
+ (let ((slast '(.00 1.00 .25 .00 .75 .40 1.00 .50 )))
+ (bird (+ beg 3.4) .15 3000 1000 .2 slast main-amp)
+ (bird (+ beg 3.6) .15 3000 1000 .2 slast main-amp)
+ (bird (+ beg 3.8) .15 3000 1000 .2 slast main-amp)
+ (bird (+ beg 4.0) .15 3000 1000 .2 slast main-amp)
+ (bird (+ beg 4.2) .15 3000 1000 .2 slast main-amp)
+ (bird (+ beg 4.4) .15 3000 1000 .2 slast main-amp))))))
(define b-cedar-waxwing
@@ -654,16 +654,17 @@
(define b-bairds-sparrow
(let ((documentation "(bairds-sparrow beg) produces a bairds sparrow call at time 'beg'"))
(lambda (beg)
- (let ((bairdend '(.00 .00 .25 1.00 .50 .00 .75 1.00 1.00 .0))
- (bairdstart '(.00 .50 .05 1.00 .10 .00 .15 1.00 .20 .00 .25 1.00 .30 .00 .35 1.00 .40 .00 .45 1.00 .50 .00 .55 1.00 .60 .00 .65 1.00 .70 .00 .75 1.00 .80 .00 .85 1.00 .90 .00 .95 1.00 1.00 .0)))
- (bird beg .09 6500 1500 .2 bairdstart main-amp)
- (bird (+ beg .22) .01 5900 100 .2 bairdend main-amp)
- (bird (+ beg .25) .09 6000 1000 .2 bairdstart main-amp)
- (bird (+ beg .45) .01 4200 100 .2 bairdend main-amp)
- (bird (+ beg .50) .08 4200 600 .2 bairdstart main-amp)
- (bird (+ beg .59) .01 4400 100 .2 bairdend main-amp)
- (bird (+ beg .60) .01 4400 100 .2 bairdend main-amp)
- (bird (+ beg .68) .07 5400 700 .2 bairdstart main-amp)
+ (let ((bairdend '(.00 .00 .25 1.00 .50 .00 .75 1.00 1.00 .0)))
+ (let ((bairdstart '(.00 .50 .05 1.00 .10 .00 .15 1.00 .20 .00 .25 1.00 .30 .00 .35 1.00 .40 .00 .45 1.00
+ .50 .00 .55 1.00 .60 .00 .65 1.00 .70 .00 .75 1.00 .80 .00 .85 1.00 .90 .00 .95 1.00 1.00 .0)))
+ (bird beg .09 6500 1500 .2 bairdstart main-amp)
+ (bird (+ beg .22) .01 5900 100 .2 bairdend main-amp)
+ (bird (+ beg .25) .09 6000 1000 .2 bairdstart main-amp)
+ (bird (+ beg .45) .01 4200 100 .2 bairdend main-amp)
+ (bird (+ beg .50) .08 4200 600 .2 bairdstart main-amp)
+ (bird (+ beg .59) .01 4400 100 .2 bairdend main-amp)
+ (bird (+ beg .60) .01 4400 100 .2 bairdend main-amp)
+ (bird (+ beg .68) .07 5400 700 .2 bairdstart main-amp))
(bird (+ beg .75) .01 4200 100 .2 bairdend main-amp)
(bird (+ beg .79) .01 4400 100 .2 bairdend main-amp)
(bird (+ beg .83) .01 4200 100 .19 bairdend main-amp)
@@ -702,11 +703,11 @@
(lambda (beg)
(let ((kenstart '(.00 .30 .50 1.00 1.00 .0))
(kendwn '(.00 .90 .10 1.00 1.00 .0))
- (kenup '(.00 .00 1.00 1.0))
(kentrill '(.00 1.00 .25 .00 .50 .00 .75 1.00 1.00 .0)))
(set! beg (- beg .6))
(bigbird (+ beg .6) .02 3800 200 .05 kenstart main-amp '(1 1 2 .03))
- (bigbird (+ beg .65) .03 4300 200 .15 kenup main-amp '(1 1 2 .1))
+ (let ((kenup '(.00 .00 1.00 1.0)))
+ (bigbird (+ beg .65) .03 4300 200 .15 kenup main-amp '(1 1 2 .1)))
(bigbird (+ beg .73) .02 3200 100 .1 kendwn main-amp '(1 1 2 .1))
(bigbird (+ beg .75) .05 3000 800 .15 kenstart main-amp '(1 1 2 .01))
@@ -741,14 +742,15 @@
(define b-rufous-sided-towhee
(let ((documentation "(rufous-sided-towhee beg) produces a rufous sided towhee call at time 'beg'"))
(lambda (beg)
- (let ((towhee-one '(.00 .10 .02 .05 .04 .15 .06 .05 .08 .20 .10 .04 .12 .25 .14 .03 .16 .30 .18 .02 .20 .35 .22 .01 .24 .40 .26 .00 .28 .45 .30 .00 .32 .50 .34 .00 .36 .50 .80 1.00 1.00 .0))
- (towhee-two '(.00 .00 1.00 1.0))
+ (let ((towhee-two '(.00 .00 1.00 1.0))
(towhee-three '(.00 1.00 1.00 .0)))
(set! beg (- beg .25))
- (bigbird (+ beg .25) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
- (bigbird (+ beg .45) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
- (bigbird (+ beg .60) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
- (bigbird (+ beg .75) .10 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
+ (let ((towhee-one '(.00 .10 .02 .05 .04 .15 .06 .05 .08 .20 .10 .04 .12 .25 .14 .03 .16 .30 .18 .02 .20 .35 .22 .01 .24
+ .40 .26 .00 .28 .45 .30 .00 .32 .50 .34 .00 .36 .50 .80 1.00 1.00 .0)))
+ (bigbird (+ beg .25) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
+ (bigbird (+ beg .45) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
+ (bigbird (+ beg .60) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
+ (bigbird (+ beg .75) .10 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03)))
(bird (+ beg .88) .01 5100 2000 .1 towhee-two main-amp)
(bird (+ beg .895) .01 5100 1600 .1 towhee-two main-amp)
@@ -955,20 +957,22 @@
(let ((documentation "(black-throated-sparrow beg) produces a black throated sparrow call at time 'beg'"))
(lambda (beg)
(let ((black-up '(.00 .00 1.00 1.0))
- (black-down '(.00 1.00 1.00 .0))
- (black-down-amp '(.00 .00 .75 1.00 1.00 .0))
- (black-trill '(.00 .00 .03 .70 .06 .00 .09 .75 .12 .00 .15 .80 .18 .05 .21 .85 .24 .10 .27 .90 .30 .10 .33 1.00 .36 .10 .39 1.00 .42 .10 .45 1.00 .48 .10 .51 1.00 .54 .10 .57 1.00 .60 .10 .63 1.00 .66 .10 .69 1.00 .72 .10 .75 1.00 .78 .10 .81 1.00 .84 .10 .87 1.00 .90 .00 .93 .95 .96 .00 1.00 .90 ))
- (black-up-down '(.00 .00 .50 1.00 1.00 .20 ))
(black-amp '(.00 .00 .50 1.00 1.00 .0)))
(set! beg (- beg .8))
- (bird (+ beg .8) .02 2200 1000 .1 black-down bird-amp)
- (bird (+ beg .83) .01 3000 200 .05 black-up bird-amp)
- (bird (+ beg .96) .02 5800 500 .05 black-up bird-amp)
- (bird (+ beg 1.00) .02 4000 200 .05 black-up bird-amp)
- (bird (+ beg 1.04) .10 2100 1700 .15 black-down black-down-amp)
+ (let ((black-down '(.00 1.00 1.00 .0))
+ (black-down-amp '(.00 .00 .75 1.00 1.00 .0)))
+ (bird (+ beg .8) .02 2200 1000 .1 black-down bird-amp)
+ (bird (+ beg .83) .01 3000 200 .05 black-up bird-amp)
+ (bird (+ beg .96) .02 5800 500 .05 black-up bird-amp)
+ (bird (+ beg 1.00) .02 4000 200 .05 black-up bird-amp)
+ (bird (+ beg 1.04) .10 2100 1700 .15 black-down black-down-amp))
(bird (+ beg 1.15) .05 5700 400 .25 black-up bird-amp)
- (bird (+ beg 1.25) .25 2000 900 .2 black-trill bird-amp)
- (bird (+ beg 1.52) .05 5600 400 .15 black-up-down bird-amp)
+ (let ((black-trill '(.00 .00 .03 .70 .06 .00 .09 .75 .12 .00 .15 .80 .18 .05 .21 .85 .24 .10 .27 .90
+ .30 .10 .33 1.00 .36 .10 .39 1.00 .42 .10 .45 1.00 .48 .10 .51 1.00 .54 .10 .57 1.00
+ .60 .10 .63 1.00 .66 .10 .69 1.00 .72 .10 .75 1.00 .78 .10 .81 1.00 .84 .10 .87 1.00 .90 .00 .93 .95 .96 .00 1.00 .90 )))
+ (bird (+ beg 1.25) .25 2000 900 .2 black-trill bird-amp))
+ (let ((black-up-down '(.00 .00 .50 1.00 1.00 .20 )))
+ (bird (+ beg 1.52) .05 5600 400 .15 black-up-down bird-amp))
(bird (+ beg 1.6) .04 3900 1100 .15 black-up bird-amp)
(bird (+ beg 1.66) .01 1900 100 .10 black-up black-amp)
@@ -1004,12 +1008,12 @@
(define b-black-chinned-sparrow
(let ((documentation "(black-chinned-sparrow beg) produces a black chinned sparrow call at time 'beg'"))
(lambda (beg)
- (let ((chin-up '(.00 .00 1.00 1.0))
- (chin-up2 '(.00 .00 .30 .20 1.00 1.0)))
+ (let ((chin-up '(.00 .00 1.00 1.0)))
(set! beg (- beg .6))
(bird (+ beg .6) .2 4200 100 .1 chin-up bird-amp)
- (bird (+ beg 1.0) .09 3800 2000 .1 chin-up2 bird-amp)
- (bird (+ beg 1.25) .08 3900 1700 .12 chin-up2 bird-amp)
+ (let ((chin-up2 '(.00 .00 .30 .20 1.00 1.0)))
+ (bird (+ beg 1.0) .09 3800 2000 .1 chin-up2 bird-amp)
+ (bird (+ beg 1.25) .08 3900 1700 .12 chin-up2 bird-amp))
(bird (+ beg 1.40) .08 3600 2300 .13 chin-up bird-amp)
(bird (+ beg 1.50) .11 3100 2800 .14 chin-up bird-amp)
(bird (+ beg 1.65) .07 2900 2700 .15 chin-up bird-amp)
diff --git a/clean.scm b/clean.scm
index 11c60e4..3ea8ab9 100644
--- a/clean.scm
+++ b/clean.scm
@@ -21,12 +21,12 @@
(define* (check-freq freq snd chn)
- (let ((hum 0.0))
- (do ((i 0 (+ i 1))
- (loc 0.0 (+ loc (round (/ (framples snd chn) 5)))))
- ((= i 4))
- (set! hum (+ hum (goertzel-channel freq loc 2048 snd chn))))
- (/ hum 4.0)))
+ (do ((hum 0.0)
+ (i 0 (+ i 1))
+ (loc 0.0 (+ loc (round (/ (framples snd chn) 5)))))
+ ((= i 4)
+ (/ hum 4.0))
+ (set! hum (+ hum (goertzel-channel freq loc 2048 snd chn)))))
;;; -------- single sample clicks
@@ -39,7 +39,7 @@
(samp2 0.0)
(fixed 0)
(len (framples snd chn))
- (block-size (min len (* 1024 1024))) ; do edits by blocks rather than sample-at-a-time (saves time, memory etc)
+ (block-size (min len 1048576)) ; do edits by blocks rather than sample-at-a-time (saves time, memory etc) 1048576=1024*1024
(block-ctr 0)
(block-beg 0)
(block (make-float-vector block-size))
@@ -73,7 +73,7 @@
(begin
(float-vector->channel block block-beg block-size snd chn)
(set! block-changed #f)))
- (set! block-beg (+ block-beg (- block-size 1)))
+ (set! block-beg (- (+ block-beg block-size) 1))
(set! block-ctr 1)
(set! (block 0) samp2))))
(if block-changed
@@ -93,7 +93,7 @@
(let ((mx (maxamp))
(loc (maxamp-position)))
(if (> mx 0.06)
- (format #t "~%;remove-single-sample-clicks 0: ~A (at ~D)" mx loc)))
+ (format () "~%;remove-single-sample-clicks 0: ~A (at ~D)" mx loc)))
(revert-sound)
(do ((i 0 (+ i 1))
(ang 0.0 (+ ang .01)))
@@ -102,7 +102,7 @@
(float-vector->channel data)
(remove-single-sample-clicks)
(if (fneq (maxamp) .2)
- (format #t "~%;remove-single-sample-clicks sin max: ~A" (maxamp)))
+ (format () "~%;remove-single-sample-clicks sin max: ~A" (maxamp)))
(let ((cur-data (channel->float-vector 0))
(diff 0.0))
(do ((i 0 (+ i 1))
@@ -110,7 +110,7 @@
((= i 1000))
(set! diff (max diff (abs (- ( cur-data i) (* .2 (sin ang)))))))
(if (> diff .2)
- (format #t "~%;remove-single-sample-clicks sine max diff: ~A" diff))))
+ (format () "~%;remove-single-sample-clicks sine max diff: ~A" diff))))
(close-sound test)))
;;; -------- pops
@@ -143,7 +143,7 @@
(len (framples snd chn))
(pad (* 8 size))
- (block-size (min (+ len pad) (* 1024 1024)))
+ (block-size (min (+ len pad) 1048576)) ; 1048576=1024*1024
(block-ctr 0)
(block-beg 0)
(block (make-float-vector block-size))
@@ -209,7 +209,7 @@
(begin
(float-vector->channel block block-beg (- block-ctr pad) snd chn)
(set! block-changed #f)))
- (set! block-beg (+ block-beg (- block-ctr pad)))
+ (set! block-beg (- (+ block-beg block-ctr) pad))
(do ((i 0 (+ i 1))
(j (- block-ctr pad) (+ j 1)))
((= i pad))
@@ -234,7 +234,7 @@
(remove-pops)
(let ((mx (maxamp)))
(if (> mx .01)
- (format #t "~%;test remove-pops 0 case: ~A" mx)))
+ (format () "~%;test remove-pops 0 case: ~A" mx)))
(revert-sound)
(do ((i 0 (+ i 1))
(ang 0.0 (+ ang .01)))
@@ -245,7 +245,7 @@
(remove-pops)
(let ((mx (maxamp)))
(if (fneq mx .2)
- (format #t "~%;test remove-pops sine case: ~A" mx)))
+ (format () "~%;test remove-pops sine case: ~A" mx)))
(close-sound)))
@@ -262,7 +262,7 @@
(notch-channel (list 60.0) #f #f #f #f #f #f #t 8)
(let ((mx (maxamp)))
(if (> mx .02)
- (format #t "~%;notch hum 0: ~A" mx)))
+ (format () "~%;notch hum 0: ~A" mx)))
(close-sound (find-sound test)))
(let ((test (with-sound ("test.snd" :srate 22050)
(let ((p (make-polywave 20.0 (list 2 1 3 1 4 1)))
@@ -281,7 +281,7 @@
(if (or (fneq (/ e60 v60) 0.0)
(fneq (/ e40 v40) 1.0)
(fneq (/ e80 v80) 1.0))
- (format #t "~%;notch 60: ~A ~A ~A -> ~A ~A ~A" v40 v60 v80 e40 e60 e80))))
+ (format () "~%;notch 60: ~A ~A ~A -> ~A ~A ~A" v40 v60 v80 e40 e60 e80))))
(close-sound (find-sound test)))
(let ((test (with-sound ("test.snd" :srate 22050)
@@ -301,7 +301,7 @@
(if (or (> (/ e60 v60) 0.01)
(< (/ e40 v40) 0.99)
(< (/ e80 v80) 0.99))
- (format #t "~%;notch 60 tight: ~A ~A ~A -> ~A ~A ~A" v40 v60 v80 e40 e60 e80))))
+ (format () "~%;notch 60 tight: ~A ~A ~A -> ~A ~A ~A" v40 v60 v80 e40 e60 e80))))
(close-sound (find-sound test))))
@@ -323,7 +323,7 @@
(nsig (goertzel 35.0)))
(if (or (> (/ ndc dc) .1)
(< (/ nsig sig) .4))
- (format #t "~%;remove-DC: ~A -> ~A (~A), ~A -> ~A (~A)" dc ndc (/ ndc dc) sig nsig (/ nsig sig))))))
+ (format () "~%;remove-DC: ~A -> ~A (~A), ~A -> ~A (~A)" dc ndc (/ ndc dc) sig nsig (/ nsig sig))))))
(close-sound test)))
@@ -370,31 +370,25 @@
xhatminus))
0 size snd chn)
- (let ((mx1 (maxamp snd chn)))
- (scale-channel (/ mx mx1) snd chn))
-
-; (format #t ";K ~A to ~A, avg ~A to ~A" minK maxK ming maxg)
-; avg-data
- ))
-
+ (scale-channel (/ mx (maxamp snd chn)) snd chn)))
(define* (clean-channel snd chn)
;; look for obvious simple clicks
(let ((clicks (as-one-edit (lambda () (remove-single-sample-clicks 8 snd chn)))))
- (if (> clicks 0)
- (format #t "~%; fixed ~D single sample clicks" clicks)
- (format #t "~%; no single-sample clicks found")))
+ (format () (if (> clicks 0)
+ (values "~%; fixed ~D single sample clicks" clicks)
+ "~%; no single-sample clicks found")))
;; look for obvious clipping and try to reconstruct
(let ((mx (maxamp snd chn)))
(if (>= mx 1.0)
(let ((clips (unclip-channel snd chn)))
- (if (eq? clips 'no-clips)
- (format #t "~%; no clipped portions found")
- (format #t "~%; reconstructed ~D clipped portions" (list-ref clips 3))))
- (format #t "~%; no obvious clipping (max amp: ~A)" mx)))
+ (format () (if (eq? clips 'no-clips)
+ "~%; no clipped portions found"
+ (values "~%; reconstructed ~D clipped portions" (list-ref clips 3)))))
+ (format () "~%; no obvious clipping (max amp: ~A)" mx)))
;; look for pops
(let ((total-pops 0))
@@ -405,11 +399,11 @@
(let ((pops (as-one-edit (lambda () (remove-pops size snd chn)))))
(set! total-pops (+ total-pops pops))
(if (> pops 0)
- (format #t "~%; fixed ~D ~D-sample ~A" pops size (if (= pops 1) "pop" "pops"))
+ (format () "~%; fixed ~D ~D-sample ~A" pops size (if (= pops 1) "pop" "pops"))
(quit))))
(list 4 8 16 32))))
(if (= total-pops 0)
- (format #t "~%; no pops found")))
+ (format () "~%; no pops found")))
;; look for hum
(let* ((hum60 (check-freq 60.0 snd chn))
@@ -418,14 +412,14 @@
(if (> hum 30.0)
(let ((humf (if (> hum60 hum55) 60.0 55.0)))
(notch-channel (list humf) 4096 0 (framples snd chn) snd chn #f #t 4)
- (format #t "~%; notch out ~D cycle hum: ~A -> ~A" (floor humf) hum (check-freq humf snd chn)))))
+ (format () "~%; notch out ~D cycle hum: ~A -> ~A" (floor humf) hum (check-freq humf snd chn)))))
;; look for DC
(let ((dc (check-freq 0.0 snd chn)))
(if (> dc 30.0)
(let ((dcflt (make-filter 2 (float-vector 1 -1) (float-vector 0 -0.99))))
(map-channel (lambda (y) (filter dcflt y)) 0 (framples snd chn) snd chn)
- (format #t "~%; block DC: ~A -> ~A" dc (check-freq 0.0 snd chn)))))
+ (format () "~%; block DC: ~A -> ~A" dc (check-freq 0.0 snd chn)))))
;; time-varying low-pass filter
(tvf-channel snd chn)
diff --git a/clm-ins.scm b/clm-ins.scm
index 84d013d..205b986 100644
--- a/clm-ins.scm
+++ b/clm-ins.scm
@@ -22,24 +22,25 @@
Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
'lossfact' can be used to shorten decays. Most useful values are between .8 and 1.0. (with-sound () (pluck 0 1 330 .3 .7 .995))"
- (define (getOptimumC S o p)
- (let* ((pa (* (/ 1.0 o) (atan (* S (sin o)) (+ (- 1.0 S) (* S (cos o))))))
- (tmpInt (floor (- p pa)))
- (pc (- p pa tmpInt)))
- (if (< pc .1)
- (do ()
- ((>= pc .1))
- (set! tmpInt (- tmpInt 1))
- (set! pc (+ pc 1.0))))
- (list tmpInt (/ (- (sin o) (sin (* o pc))) (sin (+ o (* o pc)))))))
-
(define (tuneIt f s1)
+
+ (define (getOptimumC S o p)
+ (let* ((pa (* (/ 1.0 o) (atan (* S (sin o)) (+ (- 1.0 S) (* S (cos o))))))
+ (tmpInt (floor (- p pa)))
+ (pc (- p pa tmpInt)))
+ (if (< pc .1)
+ (do ()
+ ((>= pc .1))
+ (set! tmpInt (- tmpInt 1))
+ (set! pc (+ pc 1.0))))
+ (list tmpInt (/ (- (sin o) (sin (* o pc))) (sin (+ o (* o pc)))))))
+
(let ((p (/ *clm-srate* f)) ;period as float
(s (if (= s1 0.0) 0.5 s1))
(o (hz->radians f)))
(let ((vals (getOptimumC s o p))
(vals1 (getOptimumC (- 1.0 s) o p)))
- (if (and (not (= s .5))
+ (if (and (not (= s 1/2))
(< (abs (cadr vals)) (abs (cadr vals1))))
(list (- 1.0 s) (cadr vals) (car vals))
(list s (cadr vals1) (car vals1))))))
@@ -83,157 +84,163 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
;;; this version translated (and simplified slightly) from CLM's mlbvoi.ins
(definstrument (vox beg dur freq amp ampfun freqfun freqscl phonemes formant-amps formant-indices (vibscl .1) (deg 0) (pcrev 0))
- (let ((formants
- '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
- (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
- (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
- (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
- (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
- (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
- (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
- (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
- (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
- (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
- (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
- (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400))))
- ;;formant center frequencies for a male speaker
-
- (define (find-phoneme phoneme forms)
- (if (eq? phoneme (caar forms))
- (cdar forms)
- (find-phoneme phoneme (cdr forms))))
-
- (define (vox-fun phons which)
+
+ (define (vox-fun phons which)
+ (let ((formants
+ '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
+ (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
+ (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
+ (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
+ (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
+ (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
+ (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
+ (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
+ (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
+ (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
+ (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
+ (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400))))
+ ;;formant center frequencies for a male speaker
+
+ (define (find-phoneme phoneme forms)
+ (if (eq? phoneme (caar forms))
+ (cdar forms)
+ (find-phoneme phoneme (cdr forms))))
+
(let ((f1 ())
(len (length phons)))
(do ((i 0 (+ i 2)))
((>= i len))
- (set! f1 (cons (phons i) f1))
- (set! f1 (cons ((find-phoneme (phons (+ i 1)) formants) which) f1)))
- (reverse f1)))
+ (set! f1 (cons ((find-phoneme (phons (+ i 1)) formants) which) (cons (phons i) f1))))
+ (reverse f1))))
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (car-os (make-oscil 0))
- (fs (length formant-amps))
- (per-vib (make-triangle-wave :frequency 6 :amplitude (hz->radians (* freq vibscl))))
- (ran-vib (make-rand-interp :frequency 20 :amplitude (hz->radians (* freq .5 vibscl))))
- (freqf (make-env freqfun :duration dur :scaler (hz->radians (* freqscl freq)) :offset (hz->radians freq))))
-
- (if (and (= fs 3)
- (= (channels *output*) 1))
- ;; optimize the common case
- (let ((a0 (make-env ampfun :scaler (* amp (formant-amps 0)) :duration dur))
- (a1 (make-env ampfun :scaler (* amp (formant-amps 1)) :duration dur))
- (a2 (make-env ampfun :scaler (* amp (formant-amps 2)) :duration dur))
- (o0 (make-oscil 0.0))
- (o1 (make-oscil 0.0))
- (o2 (make-oscil 0.0))
- (e0 (make-oscil 0.0))
- (e1 (make-oscil 0.0))
- (e2 (make-oscil 0.0))
- (ind0 (formant-indices 0))
- (ind1 (formant-indices 1))
- (ind2 (formant-indices 2))
- (f0 (make-env (vox-fun phonemes 0) :scaler (hz->radians 1.0) :duration dur))
- (f1 (make-env (vox-fun phonemes 1) :scaler (hz->radians 1.0) :duration dur))
- (f2 (make-env (vox-fun phonemes 2) :scaler (hz->radians 1.0) :duration dur)))
- (do ((i start (+ i 1)))
- ((= i end))
- (let* ((frq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
- (carg (oscil car-os frq))
- (frm0 (/ (env f0) frq))
- (frm1 (/ (env f1) frq))
- (frm2 (/ (env f2) frq)))
- (outa i (+
- (* (env a0)
- (+ (* (even-weight frm0) (oscil e0 (+ (* ind0 carg) (even-multiple frm0 frq))))
- (* (odd-weight frm0) (oscil o0 (+ (* ind0 carg) (odd-multiple frm0 frq))))))
- (* (env a1)
- (+ (* (even-weight frm1) (oscil e1 (+ (* ind1 carg) (even-multiple frm1 frq))))
- (* (odd-weight frm1) (oscil o1 (+ (* ind1 carg) (odd-multiple frm1 frq))))))
- (* (env a2)
- (+ (* (even-weight frm2) (oscil e2 (+ (* ind2 carg) (even-multiple frm2 frq))))
- (* (odd-weight frm2) (oscil o2 (+ (* ind2 carg) (odd-multiple frm2 frq)))))))))))
+ (let ((start (seconds->samples beg))
+ (end (seconds->samples (+ beg dur)))
+ (car-os (make-oscil 0))
+ (fs (length formant-amps))
+ (per-vib (make-triangle-wave :frequency 6 :amplitude (hz->radians (* freq vibscl))))
+ (ran-vib (make-rand-interp :frequency 20 :amplitude (hz->radians (* freq .5 vibscl))))
+ (freqf (make-env freqfun :duration dur :scaler (hz->radians (* freqscl freq)) :offset (hz->radians freq))))
+
+ (if (and (= fs 3)
+ (= (channels *output*) 1))
+ ;; optimize the common case
+ (let ((a0 (make-env ampfun :scaler (* amp (formant-amps 0)) :duration dur))
+ (a1 (make-env ampfun :scaler (* amp (formant-amps 1)) :duration dur))
+ (a2 (make-env ampfun :scaler (* amp (formant-amps 2)) :duration dur))
+ (o0 (make-oscil 0.0))
+ (o1 (make-oscil 0.0))
+ (o2 (make-oscil 0.0))
+ (e0 (make-oscil 0.0))
+ (e1 (make-oscil 0.0))
+ (e2 (make-oscil 0.0))
+ (ind0 (formant-indices 0))
+ (ind1 (formant-indices 1))
+ (ind2 (formant-indices 2))
+ (f0 (make-env (vox-fun phonemes 0) :scaler (hz->radians 1.0) :duration dur))
+ (f1 (make-env (vox-fun phonemes 1) :scaler (hz->radians 1.0) :duration dur))
+ (f2 (make-env (vox-fun phonemes 2) :scaler (hz->radians 1.0) :duration dur)))
+ (do ((i start (+ i 1)))
+ ((= i end))
+ (let* ((frq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
+ (carg (oscil car-os frq))
+ (frm0 (/ (env f0) frq))
+ (frm1 (/ (env f1) frq))
+ (frm2 (/ (env f2) frq)))
+ (outa i (+
+ (* (env a0)
+ (+ (* (even-weight frm0) (oscil e0 (+ (* ind0 carg) (even-multiple frm0 frq))))
+ (* (odd-weight frm0) (oscil o0 (+ (* ind0 carg) (odd-multiple frm0 frq))))))
+ (* (env a1)
+ (+ (* (even-weight frm1) (oscil e1 (+ (* ind1 carg) (even-multiple frm1 frq))))
+ (* (odd-weight frm1) (oscil o1 (+ (* ind1 carg) (odd-multiple frm1 frq))))))
+ (* (env a2)
+ (+ (* (even-weight frm2) (oscil e2 (+ (* ind2 carg) (even-multiple frm2 frq))))
+ (* (odd-weight frm2) (oscil o2 (+ (* ind2 carg) (odd-multiple frm2 frq)))))))))))
+
+ (let ((evens (make-vector fs))
+ (odds (make-vector fs))
+ (ampfs (make-vector fs))
+ (indices (make-float-vector fs 0.0))
+ (frmfs (make-vector fs))
+ (carrier 0.0)
+ (frm-int 0)
+ (rfrq 0.0)
+ (frm0 0.0)
+ (frac 0.0)
+ (fracf 0.0)
+ (loc (make-locsig deg 1.0 pcrev)))
+ (do ((i 0 (+ i 1)))
+ ((= i fs))
+ (set! (evens i) (make-oscil 0))
+ (set! (odds i) (make-oscil 0))
+ (set! (ampfs i) (make-env ampfun :scaler (* amp (formant-amps i)) :duration dur))
+ (set! (indices i) (formant-indices i))
+ (set! (frmfs i) (make-env (vox-fun phonemes i) :scaler (hz->radians 1.0) :duration dur)))
- (let ((evens (make-vector fs))
- (odds (make-vector fs))
- (ampfs (make-vector fs))
- (indices (make-float-vector fs 0.0))
- (frmfs (make-vector fs))
- (carrier 0.0)
- (frm-int 0)
- (rfrq 0.0)
- (frm0 0.0)
- (frac 0.0)
- (fracf 0.0)
- (loc (make-locsig deg 1.0 pcrev)))
- (do ((i 0 (+ i 1)))
- ((= i fs))
- (set! (evens i) (make-oscil 0))
- (set! (odds i) (make-oscil 0))
- (set! (ampfs i) (make-env ampfun :scaler (* amp (formant-amps i)) :duration dur))
- (set! (indices i) (formant-indices i))
- (set! (frmfs i) (make-env (vox-fun phonemes i) :scaler (hz->radians 1.0) :duration dur)))
-
- (if (= fs 3)
- (let ((frmfs0 (frmfs 0)) (frmfs1 (frmfs 1)) (frmfs2 (frmfs 2))
- (index0 (indices 0)) (index1 (indices 1)) (index2 (indices 2))
- (ampfs0 (ampfs 0)) (ampfs1 (ampfs 1)) (ampfs2 (ampfs 2))
- (evens0 (evens 0)) (evens1 (evens 1)) (evens2 (evens 2))
- (odds0 (odds 0)) (odds1 (odds 1)) (odds2 (odds 2)))
- (do ((i start (+ i 1)))
- ((= i end))
- (set! rfrq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
- (set! carrier (oscil car-os rfrq))
-
- (set! frm0 (/ (env frmfs0) rfrq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (+ (* index0 carrier) (* frm-int rfrq)))
- (if (even? frm-int)
- (locsig loc i (* (env ampfs0) (+ (* (- 1.0 frac) (oscil evens0 fracf)) (* frac (oscil odds0 (+ fracf rfrq))))))
- (locsig loc i (* (env ampfs0) (+ (* frac (oscil evens0 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds0 fracf))))))
-
- (set! frm0 (/ (env frmfs1) rfrq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (+ (* index1 carrier) (* frm-int rfrq)))
- (if (even? frm-int)
- (locsig loc i (* (env ampfs1) (+ (* (- 1.0 frac) (oscil evens1 fracf)) (* frac (oscil odds1 (+ fracf rfrq))))))
- (locsig loc i (* (env ampfs1) (+ (* frac (oscil evens1 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds1 fracf))))))
-
- (set! frm0 (/ (env frmfs2) rfrq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (+ (* index2 carrier) (* frm-int rfrq)))
- (if (even? frm-int)
- (locsig loc i (* (env ampfs2) (+ (* (- 1.0 frac) (oscil evens2 fracf)) (* frac (oscil odds2 (+ fracf rfrq))))))
- (locsig loc i (* (env ampfs2) (+ (* frac (oscil evens2 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds2 fracf))))))))
-
+ (if (= fs 3)
+ (let ((frmfs0 (frmfs 0)) (frmfs1 (frmfs 1)) (frmfs2 (frmfs 2))
+ (index0 (indices 0)) (index1 (indices 1)) (index2 (indices 2))
+ (ampfs0 (ampfs 0)) (ampfs1 (ampfs 1)) (ampfs2 (ampfs 2))
+ (evens0 (evens 0)) (evens1 (evens 1)) (evens2 (evens 2))
+ (odds0 (odds 0)) (odds1 (odds 1)) (odds2 (odds 2)))
(do ((i start (+ i 1)))
((= i end))
(set! rfrq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
- (set! carrier (oscil car-os rfrq)) ; better name: modulator or perhaps perceived-carrier?
+ (set! carrier (oscil car-os rfrq))
+
+ (set! frm0 (/ (env frmfs0) rfrq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (+ (* index0 carrier) (* frm-int rfrq)))
+ (locsig loc i
+ (* (env ampfs0)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (oscil evens0 fracf)) (* frac (oscil odds0 (+ fracf rfrq))))
+ (+ (* frac (oscil evens0 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds0 fracf))))))
- (do ((k 0 (+ k 1)))
- ((= k fs))
- (set! frm0 (/ (env (vector-ref frmfs k)) rfrq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (+ (* (float-vector-ref indices k) carrier) (* frm-int rfrq)))
- (if (even? frm-int)
- (locsig loc i (* (env (vector-ref ampfs k))
- (+ (* (- 1.0 frac) (oscil (vector-ref evens k) fracf))
- (* frac (oscil (vector-ref odds k) (+ fracf rfrq))))))
- (locsig loc i (* (env (vector-ref ampfs k))
- (+ (* frac (oscil (vector-ref evens k) (+ fracf rfrq)))
- (* (- 1.0 frac) (oscil (vector-ref odds k) fracf))))))))))))))
+ (set! frm0 (/ (env frmfs1) rfrq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (+ (* index1 carrier) (* frm-int rfrq)))
+ (locsig loc i
+ (* (env ampfs1)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (oscil evens1 fracf)) (* frac (oscil odds1 (+ fracf rfrq))))
+ (+ (* frac (oscil evens1 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds1 fracf))))))
+
+ (set! frm0 (/ (env frmfs2) rfrq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (+ (* index2 carrier) (* frm-int rfrq)))
+ (locsig loc i
+ (* (env ampfs2)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (oscil evens2 fracf)) (* frac (oscil odds2 (+ fracf rfrq))))
+ (+ (* frac (oscil evens2 (+ fracf rfrq))) (* (- 1.0 frac) (oscil odds2 fracf))))))))
+
+ (do ((i start (+ i 1)))
+ ((= i end))
+ (set! rfrq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
+ (set! carrier (oscil car-os rfrq)) ; better name: modulator or perhaps perceived-carrier?
+
+ (do ((k 0 (+ k 1)))
+ ((= k fs))
+ (set! frm0 (/ (env (vector-ref frmfs k)) rfrq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (+ (* (float-vector-ref indices k) carrier) (* frm-int rfrq)))
+ (locsig loc i
+ (* (env (vector-ref ampfs k))
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (oscil (vector-ref evens k) fracf))
+ (* frac (oscil (vector-ref odds k) (+ fracf rfrq))))
+ (+ (* frac (oscil (vector-ref evens k) (+ fracf rfrq)))
+ (* (- 1.0 frac) (oscil (vector-ref odds k) fracf)))))))))))))
;;; (with-sound (:statistics #t) (vox 0 2 170 .4 '(0 0 25 1 75 1 100 0) '(0 0 5 .5 10 0 100 1) .1 '(0 E 25 AE 35 ER 65 ER 75 I 100 UH) '(.8 .15 .05) '(.005 .0125 .025) .05 .1))
;;; (with-sound () (vox 0 2 300 .4 '(0 0 25 1 75 1 100 0) '(0 0 5 .5 10 0 100 1) .1 '(0 I 5 OW 10 I 50 AE 100 OO) '(.8 .15 .05) '(.05 .0125 .025) .02 .1))
;;; (with-sound () (vox 0 5 600 .4 '(0 0 25 1 75 1 100 0) '(0 0 5 .5 10 0 100 1) .1 '(0 I 5 OW 10 I 50 AE 100 OO) '(.8 .16 .04) '(.01 .01 .1) .01 .1))
-
+
;;; -------- PQWVOX
;;; translation of CLM pqwvox.ins (itself translated from MUS10 of MLB's waveshaping voice instrument (using phase quadrature waveshaping))
@@ -242,34 +249,35 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
"(pqw-vox beg dur freq spacing-freq amp ampfun freqfun freqscl phonemes formant-amps formant-shapes) produces
vocal sounds using phase quadrature waveshaping"
- (define formants
- '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
- (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
- (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
- (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
- (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
- (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
- (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
- (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
- (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
- (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
- (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
- (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))
- ;;formant center frequencies for a male speaker
-
- (define (find-phoneme phoneme form)
- (if (eq? (caar form) phoneme)
- (cdar form)
- (find-phoneme phoneme (cdr form))))
-
(define (vox-fun phons which newenv)
+
+ (define formants
+ '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
+ (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
+ (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
+ (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
+ (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
+ (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
+ (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
+ (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
+ (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
+ (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
+ (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
+ (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))
+ ;;formant center frequencies for a male speaker
+
;; make an envelope from which-th entry of phoneme data referred to by phons
(if (null? phons)
newenv
- (vox-fun (cddr phons) which
- (append newenv
- (list (car phons)
- ((find-phoneme (cadr phons) formants) which))))))
+ (vox-fun (cddr phons) which
+ (append newenv
+ (list (car phons)
+ ((let find-phoneme ((phoneme (cadr phons))
+ (form formants))
+ (if (eq? (caar form) phoneme)
+ (cdar form)
+ (find-phoneme phoneme (cdr form))))
+ which))))))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
@@ -324,13 +332,13 @@ vocal sounds using phase quadrature waveshaping"
(set! fracf (* frm-int rfrq))
(set! fax (polynomial cos-coeffs0 carcos))
(set! yfax (* carsin (polynomial sin-coeffs0 carcos)))
- (if (even? frm-int)
- (outa i (* (env ampfs0)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens0 fracf)) (* fax (oscil cos-evens0 fracf))))
- (* frac (- (* yfax (oscil sin-odds0 (+ fracf rfrq))) (* fax (oscil cos-odds0 (+ fracf rfrq))))))))
- (outa i (* (env ampfs0)
- (+ (* frac (- (* yfax (oscil sin-evens0 (+ fracf rfrq))) (* fax (oscil cos-evens0 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds0 fracf)) (* fax (oscil cos-odds0 fracf))))))))
+ (outa i
+ (* (env ampfs0)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens0 fracf)) (* fax (oscil cos-evens0 fracf))))
+ (* frac (- (* yfax (oscil sin-odds0 (+ fracf rfrq))) (* fax (oscil cos-odds0 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens0 (+ fracf rfrq))) (* fax (oscil cos-evens0 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds0 fracf)) (* fax (oscil cos-odds0 fracf))))))))
(set! frm0 (/ (env frmfs1) frq))
(set! frm-int (floor frm0))
@@ -338,13 +346,13 @@ vocal sounds using phase quadrature waveshaping"
(set! fracf (* frm-int rfrq))
(set! fax (polynomial cos-coeffs1 carcos))
(set! yfax (* carsin (polynomial sin-coeffs1 carcos)))
- (if (even? frm-int)
- (outa i (* (env ampfs1)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens1 fracf)) (* fax (oscil cos-evens1 fracf))))
- (* frac (- (* yfax (oscil sin-odds1 (+ fracf rfrq))) (* fax (oscil cos-odds1 (+ fracf rfrq))))))))
- (outa i (* (env ampfs1)
- (+ (* frac (- (* yfax (oscil sin-evens1 (+ fracf rfrq))) (* fax (oscil cos-evens1 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds1 fracf)) (* fax (oscil cos-odds1 fracf))))))))
+ (outa i
+ (* (env ampfs1)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens1 fracf)) (* fax (oscil cos-evens1 fracf))))
+ (* frac (- (* yfax (oscil sin-odds1 (+ fracf rfrq))) (* fax (oscil cos-odds1 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens1 (+ fracf rfrq))) (* fax (oscil cos-evens1 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds1 fracf)) (* fax (oscil cos-odds1 fracf))))))))
(set! frm0 (/ (env frmfs2) frq))
(set! frm-int (floor frm0))
@@ -352,13 +360,13 @@ vocal sounds using phase quadrature waveshaping"
(set! fracf (* frm-int rfrq))
(set! fax (polynomial cos-coeffs2 carcos))
(set! yfax (* carsin (polynomial sin-coeffs2 carcos)))
- (if (even? frm-int)
- (outa i (* (env ampfs2)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens2 fracf)) (* fax (oscil cos-evens2 fracf))))
- (* frac (- (* yfax (oscil sin-odds2 (+ fracf rfrq))) (* fax (oscil cos-odds2 (+ fracf rfrq))))))))
- (outa i (* (env ampfs2)
- (+ (* frac (- (* yfax (oscil sin-evens2 (+ fracf rfrq))) (* fax (oscil cos-evens2 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds2 fracf)) (* fax (oscil cos-odds2 fracf))))))))))
+ (outa i
+ (* (env ampfs2)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens2 fracf)) (* fax (oscil cos-evens2 fracf))))
+ (* frac (- (* yfax (oscil sin-odds2 (+ fracf rfrq))) (* fax (oscil cos-odds2 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens2 (+ fracf rfrq))) (* fax (oscil cos-evens2 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds2 fracf)) (* fax (oscil cos-odds2 fracf))))))))))
(do ((i start (+ i 1)))
((= i end))
@@ -374,13 +382,12 @@ vocal sounds using phase quadrature waveshaping"
(set! fracf (* frm-int rfrq))
(set! fax (polynomial (vector-ref cos-coeffs k) carcos))
(set! yfax (* carsin (polynomial (vector-ref sin-coeffs k) carcos)))
- (if (even? frm-int)
- (outa i (* (env (vector-ref ampfs k))
+ (outa i (* (env (vector-ref ampfs k))
+ (if (even? frm-int)
(+ (* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-evens k) fracf))
(* fax (oscil (vector-ref cos-evens k) fracf))))
(* frac (- (* yfax (oscil (vector-ref sin-odds k) (+ fracf rfrq)))
- (* fax (oscil (vector-ref cos-odds k) (+ fracf rfrq))))))))
- (outa i (* (env (vector-ref ampfs k))
+ (* fax (oscil (vector-ref cos-odds k) (+ fracf rfrq))))))
(+ (* frac (- (* yfax (oscil (vector-ref sin-evens k) (+ fracf rfrq)))
(* fax (oscil (vector-ref cos-evens k) (+ fracf rfrq)))))
(* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-odds k) fracf))
@@ -1020,18 +1027,16 @@ is a physical model of a flute:
;; reverb-factor controls the length of the decay -- it should not exceed (/ 1.0 .823)
;; lp-coeff controls the strength of the low pass filter inserted in the feedback loop
;; output-scale can be used to boost the reverb output
- (define (prime? val)
- (or (= val 2)
- (and (odd? val)
- (do ((i 3 (+ i 2))
- (lim (sqrt val)))
- ((or (= 0 (modulo val i)) (> i lim))
- (> i lim))))))
+
(define (next-prime val)
- (if (prime? val)
+ (if (or (= val 2)
+ (and (odd? val)
+ (do ((i 3 (+ i 2))
+ (lim (sqrt val)))
+ ((or (= 0 (modulo val i)) (> i lim)) (> i lim)))))
val
(next-prime (+ val 2))))
-
+
(let ((srscale (/ *clm-srate* 25641))
(dly-len (list 1433 1601 1867 2053 2251 2399 347 113 37 59 53 43 37 29 19))
(chan2 (> (channels *output*) 1))
@@ -1119,7 +1124,7 @@ is a physical model of a flute:
(set! (indfs i) (make-env (stretch-envelope indxfun 25 indxat 75 indxdc) :duration dur
:scaler (- dev1 dev0) :offset dev0))
(set! (ampfs i) (make-env (stretch-envelope ampf 25 ampat 75 ampdc) :duration dur
- :scaler (* rsamp amp (/ rfamp totalamp))))
+ :scaler (/ (* rsamp amp rfamp) totalamp)))
(set! (c-rats i) harm)
(set! (carriers i) (make-oscil cfq))))
(if (= numformants 2)
@@ -1341,423 +1346,421 @@ is a physical model of a flute:
(definstrument (lbj-piano begin-time duration frequency amplitude pfreq
(degree 45) (reverb-amount 0) (distance 1))
- (let ((piano-spectra (list
-
- (list 1.97 .0326 2.99 .0086 3.95 .0163 4.97 .0178 5.98 .0177 6.95 .0315 8.02 .0001
- 8.94 .0076 9.96 .0134 10.99 .0284 11.98 .0229 13.02 .0229 13.89 .0010 15.06 .0090 16.00 .0003
- 17.08 .0078 18.16 .0064 19.18 .0129 20.21 .0085 21.27 .0225 22.32 .0061 23.41 .0102 24.48 .0005
- 25.56 .0016 26.64 .0018 27.70 .0113 28.80 .0111 29.91 .0158 31.06 .0093 32.17 .0017 33.32 .0002
- 34.42 .0018 35.59 .0027 36.74 .0055 37.90 .0037 39.06 .0064 40.25 .0033 41.47 .0014 42.53 .0004
- 43.89 .0010 45.12 .0039 46.33 .0039 47.64 .0009 48.88 .0016 50.13 .0006 51.37 .0010 52.70 .0002
- 54.00 .0004 55.30 .0008 56.60 .0025 57.96 .0010 59.30 .0012 60.67 .0011 61.99 .0003 62.86 .0001
- 64.36 .0005 64.86 .0001 66.26 .0004 67.70 .0006 68.94 .0002 70.10 .0001 70.58 .0002 72.01 .0007
- 73.53 .0006 75.00 .0002 77.03 .0005 78.00 .0002 79.57 .0006 81.16 .0005 82.70 .0005 84.22 .0003
- 85.41 .0002 87.46 .0001 90.30 .0001 94.02 .0001 95.26 .0002 109.39 .0003)
-
- (list 1.98 .0194 2.99 .0210 3.97 .0276 4.96 .0297 5.96 .0158 6.99 .0207 8.01 .0009
- 9.00 .0101 10.00 .0297 11.01 .0289 12.02 .0211 13.04 .0127 14.07 .0061 15.08 .0174 16.13 .0009
- 17.12 .0093 18.16 .0117 19.21 .0122 20.29 .0108 21.30 .0077 22.38 .0132 23.46 .0073 24.14 .0002
- 25.58 .0026 26.69 .0035 27.77 .0053 28.88 .0024 30.08 .0027 31.13 .0075 32.24 .0027 33.36 .0004
- 34.42 .0004 35.64 .0019 36.78 .0037 38.10 .0009 39.11 .0027 40.32 .0010 41.51 .0013 42.66 .0019
- 43.87 .0007 45.13 .0017 46.35 .0019 47.65 .0021 48.89 .0014 50.18 .0023 51.42 .0015 52.73 .0002
- 54.00 .0005 55.34 .0006 56.60 .0010 57.96 .0016 58.86 .0005 59.30 .0004 60.75 .0005 62.22 .0003
- 63.55 .0005 64.82 .0003 66.24 .0003 67.63 .0011 69.09 .0007 70.52 .0004 72.00 .0005 73.50 .0008
- 74.95 .0003 77.13 .0013 78.02 .0002 79.48 .0004 82.59 .0004 84.10 .0003)
-
- (list 2.00 .0313 2.99 .0109 4.00 .0215 5.00 .0242 5.98 .0355 7.01 .0132 8.01 .0009
- 9.01 .0071 10.00 .0258 11.03 .0221 12.02 .0056 13.06 .0196 14.05 .0160 15.11 .0107 16.11 .0003
- 17.14 .0111 18.21 .0085 19.23 .0010 20.28 .0048 21.31 .0128 22.36 .0051 23.41 .0041 24.05 .0006
- 25.54 .0019 26.62 .0028 27.72 .0034 28.82 .0062 29.89 .0039 30.98 .0058 32.08 .0011 33.21 .0002
- 34.37 .0008 35.46 .0018 36.62 .0036 37.77 .0018 38.92 .0042 40.07 .0037 41.23 .0011 42.67 .0003
- 43.65 .0018 44.68 .0025 45.99 .0044 47.21 .0051 48.40 .0044 49.67 .0005 50.88 .0019 52.15 .0003
- 53.42 .0008 54.69 .0010 55.98 .0005 57.26 .0013 58.53 .0027 59.83 .0011 61.21 .0027 62.54 .0003
- 63.78 .0003 65.20 .0001 66.60 .0006 67.98 .0008 69.37 .0019 70.73 .0007 72.14 .0004 73.62 .0002
- 74.40 .0003 76.52 .0006 77.97 .0002 79.49 .0004 80.77 .0003 81.00 .0001 82.47 .0005 83.97 .0001
- 87.27 .0002)
-
- (list 2.00 .0257 2.99 .0142 3.97 .0202 4.95 .0148 5.95 .0420 6.95 .0037 7.94 .0004
- 8.94 .0172 9.95 .0191 10.96 .0115 11.97 .0059 12.98 .0140 14.00 .0178 15.03 .0121 16.09 .0002
- 17.07 .0066 18.08 .0033 19.15 .0022 20.18 .0057 21.22 .0077 22.29 .0037 23.33 .0066 24.97 .0002
- 25.49 .0019 26.55 .0042 27.61 .0043 28.73 .0038 29.81 .0084 30.91 .0040 32.03 .0025 33.14 .0005
- 34.26 .0003 35.38 .0019 36.56 .0037 37.68 .0049 38.86 .0036 40.11 .0011 41.28 .0008 42.50 .0004
- 43.60 .0002 44.74 .0022 45.99 .0050 47.20 .0009 48.40 .0036 49.68 .0004 50.92 .0009 52.17 .0005
- 53.46 .0007 54.76 .0006 56.06 .0005 57.34 .0011 58.67 .0005 59.95 .0015 61.37 .0008 62.72 .0004
- 65.42 .0009 66.96 .0003 68.18 .0003 69.78 .0003 71.21 .0004 72.45 .0002 74.22 .0003 75.44 .0001
- 76.53 .0003 78.31 .0004 79.83 .0003 80.16 .0001 81.33 .0003 82.44 .0001 83.17 .0002 84.81 .0003
- 85.97 .0003 89.08 .0001 90.70 .0002 92.30 .0002 95.59 .0002 97.22 .0003 98.86 .0001 108.37 .0001
- 125.54 .0001)
-
- (list 1.99 .0650 3.03 .0040 4.03 .0059 5.02 .0090 5.97 .0227 6.98 .0050 8.04 .0020
- 9.00 .0082 9.96 .0078 11.01 .0056 12.01 .0095 13.02 .0050 14.04 .0093 15.08 .0064 16.14 .0017
- 17.06 .0020 18.10 .0025 19.14 .0023 20.18 .0015 21.24 .0032 22.29 .0029 23.32 .0014 24.37 .0005
- 25.43 .0030 26.50 .0022 27.60 .0027 28.64 .0024 29.76 .0035 30.81 .0136 31.96 .0025 33.02 .0003
- 34.13 .0005 35.25 .0007 36.40 .0014 37.51 .0020 38.64 .0012 39.80 .0019 40.97 .0004 42.09 .0003
- 43.24 .0003 44.48 .0002 45.65 .0024 46.86 .0005 48.07 .0013 49.27 .0008 50.49 .0006 52.95 .0001
- 54.23 .0005 55.45 .0004 56.73 .0001 58.03 .0003 59.29 .0002 60.59 .0003 62.04 .0002 65.89 .0002
- 67.23 .0002 68.61 .0002 69.97 .0004 71.36 .0005 85.42 .0001)
-
- (list 1.98 .0256 2.96 .0158 3.95 .0310 4.94 .0411 5.95 .0238 6.94 .0152 7.93 .0011
- 8.95 .0185 9.92 .0166 10.93 .0306 11.94 .0258 12.96 .0202 13.97 .0403 14.95 .0228 15.93 .0005
- 17.01 .0072 18.02 .0034 19.06 .0028 20.08 .0124 21.13 .0137 22.16 .0102 23.19 .0058 23.90 .0013
- 25.30 .0039 26.36 .0039 27.41 .0025 28.47 .0071 29.64 .0031 30.60 .0027 31.71 .0021 32.84 .0003
- 33.82 .0002 35.07 .0019 36.09 .0054 37.20 .0038 38.33 .0024 39.47 .0055 40.55 .0016 41.77 .0006
- 42.95 .0002 43.27 .0018 44.03 .0006 45.25 .0019 46.36 .0033 47.50 .0024 48.87 .0012 50.03 .0016
- 51.09 .0004 53.52 .0017 54.74 .0012 56.17 .0003 57.40 .0011 58.42 .0020 59.70 .0007 61.29 .0008
- 62.56 .0003 63.48 .0002 64.83 .0002 66.12 .0012 67.46 .0017 68.81 .0003 69.13 .0003 70.53 .0002
- 71.84 .0001 73.28 .0002 75.52 .0010 76.96 .0005 77.93 .0003 78.32 .0003 79.73 .0003 81.69 .0002
- 82.52 .0001 84.01 .0001 84.61 .0002 86.88 .0001 88.36 .0002 89.85 .0002 91.35 .0003 92.86 .0002
- 93.40 .0001 105.28 .0002 106.22 .0002 107.45 .0001 108.70 .0003 122.08 .0002)
-
- (list 1.97 .0264 2.97 .0211 3.98 .0234 4.98 .0307 5.96 .0085 6.94 .0140 7.93 .0005
- 8.96 .0112 9.96 .0209 10.98 .0194 11.98 .0154 12.99 .0274 13.99 .0127 15.01 .0101 15.99 .0002
- 17.04 .0011 18.08 .0032 19.14 .0028 20.12 .0054 21.20 .0053 22.13 .0028 23.22 .0030 24.32 .0006
- 25.24 .0004 26.43 .0028 27.53 .0048 28.52 .0039 29.54 .0047 30.73 .0044 31.82 .0007 32.94 .0008
- 34.04 .0012 35.13 .0018 36.29 .0007 37.35 .0075 38.51 .0045 39.66 .0014 40.90 .0004 41.90 .0002
- 43.08 .0002 44.24 .0017 45.36 .0013 46.68 .0020 47.79 .0015 48.98 .0010 50.21 .0012 51.34 .0001
- 53.82 .0003 55.09 .0004 56.23 .0005 57.53 .0004 58.79 .0005 59.30 .0002 60.03 .0002 61.40 .0003
- 62.84 .0001 66.64 .0001 67.97 .0001 69.33 .0001 70.68 .0001 73.57 .0002 75.76 .0002 76.45 .0001
- 79.27 .0001 80.44 .0002 81.87 .0002)
-
- (list 2.00 .0311 2.99 .0086 3.99 .0266 4.97 .0123 5.98 .0235 6.97 .0161 7.97 .0008
- 8.96 .0088 9.96 .0621 10.99 .0080 11.99 .0034 12.99 .0300 14.03 .0228 15.04 .0105 16.03 .0004
- 17.06 .0036 18.09 .0094 18.95 .0009 20.17 .0071 21.21 .0161 22.25 .0106 23.28 .0104 24.33 .0008
- 25.38 .0030 26.46 .0035 27.50 .0026 28.59 .0028 29.66 .0128 30.75 .0139 31.81 .0038 32.93 .0006
- 34.04 .0004 35.16 .0005 36.25 .0023 37.35 .0012 38.46 .0021 39.59 .0035 40.71 .0006 41.86 .0007
- 42.42 .0001 43.46 .0003 44.17 .0032 45.29 .0013 46.57 .0004 47.72 .0011 48.79 .0005 50.11 .0005
- 51.29 .0003 52.47 .0002 53.68 .0004 55.02 .0005 56.18 .0003 57.41 .0003 58.75 .0007 59.33 .0009
- 60.00 .0004 61.34 .0001 64.97 .0003 65.20 .0002 66.48 .0002 67.83 .0002 68.90 .0003 70.25 .0003
- 71.59 .0002 73.68 .0001 75.92 .0001 77.08 .0002 78.45 .0002 81.56 .0002 82.99 .0001 88.39 .0001)
-
- (list .97 .0059 1.98 .0212 2.99 .0153 3.99 .0227 4.96 .0215 5.97 .0153 6.98 .0085
- 7.98 .0007 8.97 .0179 9.98 .0512 10.98 .0322 12.00 .0098 13.02 .0186 14.00 .0099 15.05 .0109
- 15.88 .0011 17.07 .0076 18.11 .0071 19.12 .0045 20.16 .0038 21.23 .0213 22.27 .0332 23.34 .0082
- 24.34 .0014 25.42 .0024 26.47 .0012 27.54 .0014 28.60 .0024 29.72 .0026 30.10 .0008 31.91 .0021
- 32.13 .0011 33.02 .0007 34.09 .0014 35.17 .0007 36.27 .0024 37.39 .0029 38.58 .0014 39.65 .0017
- 40.95 .0012 41.97 .0004 42.43 .0002 43.49 .0001 44.31 .0012 45.42 .0031 46.62 .0017 47.82 .0013
- 49.14 .0013 50.18 .0010 51.54 .0003 53.90 .0006 55.06 .0010 56.31 .0003 57.63 .0001 59.02 .0003
- 60.09 .0004 60.35 .0004 61.62 .0009 63.97 .0001 65.19 .0001 65.54 .0002 66.92 .0002 67.94 .0002
- 69.17 .0003 69.60 .0004 70.88 .0002 72.24 .0002 76.12 .0001 78.94 .0001 81.75 .0001 82.06 .0001
- 83.53 .0001 90.29 .0002 91.75 .0001 92.09 .0002 93.28 .0001 97.07 .0001)
-
- (list 1.98 .0159 2.98 .1008 3.98 .0365 4.98 .0133 5.97 .0101 6.97 .0115 7.97 .0007
- 8.99 .0349 10.01 .0342 11.01 .0236 12.00 .0041 13.02 .0114 14.05 .0137 15.06 .0100 16.05 .0007
- 17.04 .0009 18.12 .0077 19.15 .0023 20.12 .0017 21.24 .0113 22.26 .0126 23.30 .0093 24.36 .0007
- 25.43 .0007 26.47 .0009 27.55 .0013 28.59 .0025 29.61 .0010 30.77 .0021 31.86 .0023 32.96 .0003
- 34.03 .0007 35.06 .0005 36.20 .0006 37.34 .0006 38.36 .0009 39.60 .0016 40.69 .0005 41.77 .0002
- 42.92 .0002 44.02 .0003 45.24 .0006 46.33 .0004 47.50 .0007 48.71 .0007 49.87 .0002 51.27 .0002
- 53.42 .0003 55.88 .0003 57.10 .0004 58.34 .0002 59.86 .0003 61.13 .0003 67.18 .0001 68.50 .0001
- 71.17 .0001 83.91 .0001 90.55 .0001)
-
- (list .98 .0099 2.00 .0181 2.99 .0353 3.98 .0285 4.97 .0514 5.96 .0402 6.96 .0015
- 7.98 .0012 8.98 .0175 9.98 .0264 10.98 .0392 11.98 .0236 13.00 .0153 14.04 .0049 15.00 .0089
- 16.01 .0001 17.03 .0106 18.03 .0028 19.05 .0024 20.08 .0040 21.11 .0103 22.12 .0104 23.20 .0017
- 24.19 .0008 25.20 .0007 26.24 .0011 27.36 .0009 27.97 .0030 29.40 .0044 30.37 .0019 31.59 .0017
- 32.65 .0008 33.59 .0005 34.79 .0009 35.75 .0027 36.88 .0035 37.93 .0039 39.00 .0031 40.08 .0025
- 41.16 .0010 43.25 .0004 44.52 .0012 45.62 .0023 45.85 .0012 47.00 .0006 47.87 .0008 48.99 .0003
- 50.48 .0003 51.62 .0001 52.43 .0001 53.56 .0002 54.76 .0002 56.04 .0002 56.68 .0006 57.10 .0003
- 58.28 .0005 59.47 .0003 59.96 .0002 60.67 .0001 63.08 .0002 64.29 .0002 66.72 .0001 67.97 .0001
- 68.65 .0001 70.43 .0001 79.38 .0001 80.39 .0001 82.39 .0001)
-
- (list 1.00 .0765 1.99 .0151 2.99 .0500 3.99 .0197 5.00 .0260 6.00 .0145 6.98 .0128
- 7.97 .0004 8.98 .0158 9.99 .0265 11.02 .0290 12.02 .0053 13.03 .0242 14.03 .0103 15.06 .0054
- 16.04 .0006 17.08 .0008 18.10 .0058 19.16 .0011 20.16 .0055 21.18 .0040 22.20 .0019 23.22 .0014
- 24.05 .0005 25.31 .0019 26.38 .0018 27.44 .0022 28.45 .0024 29.57 .0073 30.58 .0032 31.66 .0071
- 32.73 .0015 33.85 .0005 34.96 .0003 36.00 .0020 37.11 .0018 38.18 .0055 39.23 .0006 40.33 .0004
- 41.52 .0003 43.41 .0028 45.05 .0003 45.99 .0002 47.07 .0003 48.52 .0002 49.48 .0003 50.63 .0003
- 51.81 .0002 54.05 .0002 55.24 .0001 56.62 .0001 57.81 .0004 59.16 .0013 60.23 .0003 66.44 .0001
- 68.99 .0004 75.49 .0001 87.56 .0004)
-
- (list .98 .0629 1.99 .0232 2.98 .0217 4.00 .0396 4.98 .0171 5.97 .0098 6.99 .0167
- 7.99 .0003 8.98 .0192 9.98 .0266 10.99 .0256 12.01 .0061 13.02 .0135 14.02 .0062 15.05 .0158
- 16.06 .0018 17.08 .0101 18.09 .0053 19.11 .0074 20.13 .0020 21.17 .0052 22.22 .0077 23.24 .0035
- 24.00 .0009 25.32 .0016 26.40 .0022 27.43 .0005 28.55 .0026 29.60 .0026 30.65 .0010 31.67 .0019
- 32.77 .0008 33.81 .0003 34.91 .0003 36.01 .0005 37.11 .0010 38.20 .0014 39.29 .0039 40.43 .0012
- 41.50 .0006 43.38 .0017 43.75 .0002 44.94 .0005 46.13 .0002 47.11 .0003 48.28 .0005 48.42 .0005
- 49.44 .0003 50.76 .0004 51.93 .0002 54.15 .0003 55.31 .0005 55.50 .0003 56.98 .0003 57.90 .0004
- 60.33 .0002 61.39 .0001 61.59 .0001 65.09 .0002 66.34 .0001 68.85 .0001 70.42 .0002 71.72 .0001
- 73.05 .0003 79.65 .0001 85.28 .0002 93.52 .0001)
-
- (list 1.02 .0185 1.99 .0525 2.98 .0613 3.99 .0415 4.98 .0109 5.97 .0248 6.99 .0102
- 7.98 .0005 8.98 .0124 9.99 .0103 10.99 .0124 12.00 .0016 13.01 .0029 14.03 .0211 15.04 .0128
- 16.07 .0021 17.09 .0009 18.09 .0043 19.14 .0022 20.13 .0016 21.20 .0045 22.21 .0088 23.26 .0046
- 24.29 .0013 25.35 .0009 26.39 .0028 27.49 .0009 28.51 .0006 29.58 .0012 30.70 .0010 31.74 .0019
- 32.75 .0002 33.85 .0001 34.95 .0005 36.02 .0003 37.16 .0009 38.25 .0018 39.35 .0008 40.54 .0004
- 41.61 .0002 43.40 .0004 43.74 .0003 45.05 .0001 46.11 .0003 47.40 .0002 48.36 .0004 49.55 .0004
- 50.72 .0002 52.00 .0001 55.58 .0002 57.02 .0001 57.98 .0002 59.13 .0003 61.56 .0001 66.56 .0001
- 87.65 .0002)
-
- (list 1.00 .0473 1.99 .0506 2.99 .0982 3.99 .0654 5.00 .0196 5.99 .0094 6.99 .0118
- 7.93 .0001 8.99 .0057 10.01 .0285 11.01 .0142 12.03 .0032 13.03 .0056 14.06 .0064 15.06 .0059
- 16.11 .0005 17.09 .0033 18.14 .0027 19.15 .0014 20.17 .0010 21.21 .0059 22.26 .0043 23.31 .0031
- 24.31 .0018 25.33 .0009 26.41 .0005 27.47 .0015 28.53 .0015 29.58 .0041 30.65 .0025 31.73 .0011
- 32.83 .0010 34.98 .0003 36.07 .0009 37.23 .0001 38.26 .0020 39.41 .0014 40.53 .0005 41.40 .0003
- 42.80 .0002 43.48 .0028 43.93 .0001 45.03 .0003 46.18 .0007 47.41 .0001 48.57 .0002 49.67 .0001
- 50.83 .0002 54.39 .0001 55.58 .0002 57.97 .0005 58.11 .0002 59.21 .0001 60.42 .0002 61.66 .0001)
-
- (list 1.00 .0503 2.00 .0963 2.99 .1304 3.99 .0218 4.98 .0041 5.98 .0292 6.98 .0482
- 7.99 .0005 8.99 .0280 10.00 .0237 11.00 .0152 12.02 .0036 12.95 .0022 14.06 .0111 15.07 .0196
- 16.08 .0016 17.11 .0044 18.13 .0073 19.17 .0055 20.19 .0028 21.20 .0012 22.27 .0068 23.30 .0036
- 24.35 .0012 25.35 .0002 26.46 .0005 27.47 .0005 28.59 .0009 29.65 .0021 30.70 .0020 31.78 .0012
- 32.89 .0010 35.06 .0005 36.16 .0008 37.27 .0010 38.36 .0010 39.47 .0014 40.58 .0004 41.43 .0007
- 41.82 .0003 43.48 .0008 44.53 .0001 45.25 .0003 46.43 .0002 47.46 .0002 48.76 .0005 49.95 .0004
- 50.96 .0002 51.12 .0002 52.33 .0001 54.75 .0001 55.75 .0002 56.90 .0002 58.17 .0002 59.40 .0004
- 60.62 .0002 65.65 .0001 66.91 .0002 69.91 .0001 71.25 .0002)
-
- (list 1.00 .1243 1.98 .1611 3.00 .0698 3.98 .0390 5.00 .0138 5.99 .0154 7.01 .0287
- 8.01 .0014 9.01 .0049 10.00 .0144 11.01 .0055 12.05 .0052 13.01 .0011 14.05 .0118 15.07 .0154
- 16.12 .0028 17.14 .0061 18.25 .0007 19.22 .0020 20.24 .0011 21.27 .0029 22.30 .0046 23.34 .0049
- 24.35 .0004 25.45 .0003 26.47 .0007 27.59 .0008 28.16 .0009 29.12 .0002 29.81 .0006 30.81 .0009
- 31.95 .0004 33.00 .0011 34.12 .0005 35.18 .0003 36.30 .0008 37.38 .0003 38.55 .0003 39.64 .0006
- 40.77 .0007 41.52 .0006 41.89 .0006 43.04 .0011 43.60 .0009 44.31 .0002 45.68 .0002 46.56 .0003
- 47.60 .0001 48.83 .0006 50.01 .0003 51.27 .0003 56.04 .0005 57.21 .0003 58.56 .0004 59.83 .0003
- 61.05 .0001 62.20 .0001 67.37 .0002 76.53 .0001)
-
- (list .99 .0222 1.99 .0678 2.99 .0683 4.00 .0191 5.00 .0119 6.01 .0232 6.98 .0336
- 7.99 .0082 9.01 .0201 10.01 .0189 11.01 .0041 12.01 .0053 13.05 .0154 14.04 .0159 15.06 .0092
- 16.11 .0038 17.12 .0014 18.15 .0091 19.16 .0006 20.30 .0012 21.25 .0061 22.28 .0099 23.34 .0028
- 24.38 .0012 25.43 .0016 26.49 .0048 27.55 .0025 28.62 .0015 29.71 .0032 30.78 .0077 31.88 .0011
- 32.97 .0007 34.08 .0006 35.16 .0008 36.28 .0004 37.41 .0006 38.54 .0005 39.62 .0002 40.80 .0003
- 41.93 .0001 43.06 .0002 44.21 .0003 45.38 .0002 46.54 .0007 47.78 .0003 48.95 .0004 50.10 .0003
- 51.37 .0002 53.79 .0003 56.20 .0001 58.71 .0002 66.47 .0003)
-
- (list 1.01 .0241 1.99 .1011 2.98 .0938 3.98 .0081 4.99 .0062 5.99 .0291 6.99 .0676
- 7.59 .0004 8.98 .0127 9.99 .0112 10.99 .0142 12.00 .0029 13.02 .0071 14.02 .0184 15.03 .0064
- 16.07 .0010 17.09 .0011 18.11 .0010 19.15 .0060 20.19 .0019 21.24 .0025 22.29 .0013 23.31 .0050
- 25.41 .0030 26.50 .0018 27.53 .0006 28.63 .0012 29.66 .0013 30.77 .0020 31.84 .0006 34.04 .0001
- 35.14 .0001 36.32 .0004 37.41 .0007 38.53 .0007 39.67 .0009 40.85 .0003 45.49 .0002 46.65 .0001
- 47.81 .0004 49.01 .0002 53.91 .0002 55.14 .0002 57.69 .0002)
-
- (list 1.00 .0326 2.00 .1066 2.99 .1015 4.00 .0210 4.97 .0170 5.99 .0813 6.98 .0820
- 7.96 .0011 8.99 .0248 10.03 .0107 11.01 .0126 12.01 .0027 13.01 .0233 14.04 .0151 15.05 .0071
- 16.04 .0002 17.10 .0061 18.12 .0059 19.15 .0087 20.23 .0005 21.25 .0040 22.30 .0032 23.35 .0004
- 24.40 .0001 25.45 .0030 26.54 .0022 27.60 .0003 28.70 .0009 29.80 .0029 30.85 .0006 31.97 .0006
- 34.19 .0004 35.30 .0003 36.43 .0007 37.56 .0005 38.68 .0019 39.88 .0013 41.00 .0003 43.35 .0003
- 44.51 .0002 45.68 .0006 46.93 .0010 48.11 .0006 49.29 .0003 55.58 .0002)
-
- (list .98 .0113 1.99 .0967 3.00 .0719 3.98 .0345 4.98 .0121 6.00 .0621 7.00 .0137
- 7.98 .0006 9.01 .0314 10.01 .0171 11.02 .0060 12.03 .0024 13.05 .0077 14.07 .0040 15.12 .0032
- 16.13 .0004 17.15 .0011 18.20 .0028 19.18 .0003 20.26 .0003 21.31 .0025 22.35 .0021 23.39 .0005
- 25.55 .0002 26.62 .0014 27.70 .0003 28.78 .0005 29.90 .0030 31.01 .0011 32.12 .0005 34.31 .0001
- 35.50 .0002 36.62 .0002 37.76 .0005 38.85 .0002 40.09 .0004 43.60 .0001 44.73 .0002 46.02 .0002
- 47.25 .0004 48.44 .0004)
-
- (list .99 .0156 1.98 .0846 2.98 .0178 3.98 .0367 4.98 .0448 5.98 .0113 6.99 .0189
- 8.00 .0011 9.01 .0247 10.02 .0089 11.01 .0184 12.03 .0105 13.00 .0039 14.07 .0116 15.09 .0078
- 16.13 .0008 17.14 .0064 18.19 .0029 19.22 .0028 20.25 .0017 21.32 .0043 22.37 .0055 23.42 .0034
- 24.48 .0004 25.54 .0002 26.61 .0017 27.70 .0011 28.80 .0002 29.89 .0019 30.97 .0028 32.09 .0007
- 34.30 .0002 35.44 .0003 36.55 .0001 37.69 .0004 38.93 .0002 40.05 .0005 41.20 .0005 42.37 .0002
- 43.54 .0003 44.73 .0001 45.95 .0002 47.16 .0001 48.43 .0005 49.65 .0004 55.90 .0002 59.81 .0004)
-
- (list 1.01 .0280 2.00 .0708 2.99 .0182 3.99 .0248 4.98 .0245 5.98 .0279 6.98 .0437
- 7.99 .0065 8.99 .0299 10.00 .0073 10.99 .0011 12.03 .0122 13.03 .0028 14.08 .0044 15.11 .0097
- 16.15 .0010 17.17 .0025 18.19 .0017 19.24 .0008 20.28 .0040 21.32 .0024 22.38 .0008 23.46 .0032
- 24.52 .0010 25.59 .0008 26.68 .0009 27.76 .0012 28.88 .0003 29.95 .0005 31.05 .0017 32.14 .0002
- 33.29 .0003 37.88 .0002 39.03 .0002 40.19 .0004 41.37 .0003 43.74 .0002 46.20 .0001 48.68 .0001
- 49.93 .0001 51.19 .0002)
-
- (list 1.00 .0225 1.99 .0921 2.98 .0933 3.99 .0365 4.99 .0100 5.98 .0213 6.98 .0049
- 7.98 .0041 8.98 .0090 9.99 .0068 11.01 .0040 12.03 .0086 13.02 .0015 14.04 .0071 15.09 .0082
- 16.14 .0011 17.15 .0014 18.18 .0010 19.26 .0013 20.26 .0005 21.33 .0006 22.36 .0011 23.46 .0016
- 24.52 .0004 25.59 .0002 26.70 .0006 27.78 .0007 28.87 .0002 30.03 .0008 31.14 .0010 32.24 .0006
- 33.37 .0002 35.67 .0003 37.99 .0004 39.17 .0004 40.35 .0005 41.53 .0001 46.42 .0001)
-
- (list 1.00 .0465 1.99 .0976 2.98 .0678 4.00 .0727 4.99 .0305 5.98 .0210 6.98 .0227
- 8.00 .0085 9.01 .0183 10.02 .0258 11.05 .0003 12.06 .0061 13.05 .0021 14.10 .0089 15.12 .0077
- 16.16 .0016 17.21 .0061 18.23 .0011 19.29 .0031 20.36 .0031 21.41 .0007 22.48 .0013 23.55 .0020
- 24.64 .0004 25.74 .0005 26.81 .0006 27.95 .0006 29.03 .0001 30.22 .0010 31.30 .0004 32.48 .0001
- 33.60 .0002 38.30 .0003)
-
- (list 1.00 .0674 1.99 .0841 2.98 .0920 3.99 .0328 4.99 .0368 5.98 .0206 6.99 .0246
- 8.01 .0048 9.01 .0218 10.03 .0155 11.05 .0048 12.06 .0077 13.00 .0020 14.10 .0083 15.15 .0084
- 16.18 .0015 17.22 .0039 18.27 .0032 19.34 .0026 20.40 .0012 21.47 .0009 22.54 .0008 23.62 .0016
- 24.71 .0005 25.82 .0004 26.91 .0002 28.03 .0008 29.17 .0002 30.32 .0028 31.45 .0004 32.61 .0005
- 33.77 .0001 36.14 .0003 37.32 .0002 38.54 .0005 39.75 .0002 42.23 .0002 48.65 .0001)
-
- (list 1.01 .0423 1.99 .0240 2.98 .0517 4.00 .0493 5.00 .0324 6.00 .0094 6.99 .0449
- 7.99 .0050 9.00 .0197 10.03 .0132 11.03 .0009 12.07 .0017 13.08 .0023 14.12 .0094 15.16 .0071
- 16.21 .0020 17.25 .0005 18.30 .0027 19.04 .0004 20.43 .0022 21.51 .0002 22.59 .0006 23.72 .0018
- 24.80 .0002 25.88 .0002 27.03 .0002 28.09 .0006 29.31 .0002 30.46 .0004 31.61 .0007 32.78 .0005
- 33.95 .0001 36.34 .0002 37.56 .0001 38.80 .0001 40.02 .0001 44.14 .0001)
-
- (list 1.00 .0669 1.99 .0909 2.99 .0410 3.98 .0292 4.98 .0259 5.98 .0148 6.98 .0319
- 7.99 .0076 9.01 .0056 10.02 .0206 11.04 .0032 12.05 .0085 13.08 .0040 14.12 .0037 15.16 .0030
- 16.20 .0013 17.24 .0021 18.30 .0010 19.36 .0015 20.44 .0013 21.50 .0009 22.60 .0015 23.69 .0014
- 24.80 .0006 25.87 .0002 27.02 .0006 28.12 .0002 29.28 .0003 30.43 .0002 31.59 .0007 32.79 .0001
- 35.14 .0001 37.57 .0001 40.03 .0002 41.28 .0004 44.10 .0001)
-
- (list .99 .0421 1.99 .1541 2.98 .0596 3.98 .0309 4.98 .0301 5.99 .0103 7.00 .0240
- 8.01 .0073 9.01 .0222 10.04 .0140 11.05 .0033 12.08 .0045 13.13 .0009 14.13 .0015 15.21 .0026
- 16.24 .0003 17.30 .0004 18.35 .0010 19.39 .0003 20.50 .0015 21.57 .0003 22.68 .0011 23.80 .0005
- 24.90 .0008 26.02 .0002 27.16 .0001 28.30 .0006 29.48 .0002 31.81 .0005 33.00 .0003 34.21 .0001
- 37.89 .0001)
-
- (list .99 .0389 2.00 .2095 3.00 .0835 3.99 .0289 5.00 .0578 5.99 .0363 7.01 .0387
- 8.01 .0056 9.04 .0173 10.05 .0175 11.08 .0053 12.10 .0056 13.15 .0064 14.19 .0036 15.22 .0019
- 16.29 .0010 17.36 .0017 18.43 .0018 19.51 .0004 20.60 .0011 21.70 .0003 22.82 .0003 23.95 .0001
- 25.05 .0004 26.17 .0001 28.50 .0003 29.68 .0001 32.07 .0003 33.28 .0004 34.52 .0001)
-
- (list 1.00 .1238 1.99 .2270 3.00 .0102 3.99 .0181 4.98 .0415 6.00 .0165 7.01 .0314
- 8.02 .0148 9.04 .0203 10.05 .0088 11.07 .0062 12.11 .0070 13.14 .0054 14.19 .0028 15.24 .0044
- 16.30 .0029 17.38 .0009 18.45 .0026 19.56 .0003 20.65 .0025 21.74 .0014 22.87 .0013 23.99 .0007
- 25.15 .0002 27.46 .0004 28.39 .0006 28.65 .0004 29.85 .0001 31.05 .0002 32.27 .0003 33.52 .0002
- 34.76 .0003)
-
- (list 1.00 .1054 2.00 .2598 2.99 .0369 3.98 .0523 4.99 .0020 5.99 .0051 7.00 .0268
- 8.01 .0027 9.04 .0029 10.05 .0081 11.08 .0047 12.12 .0051 13.16 .0091 14.19 .0015 15.27 .0030
- 16.34 .0017 17.42 .0006 18.51 .0003 19.61 .0007 20.72 .0003 21.84 .0001 22.99 .0010 24.13 .0001
- 28.44 .0001 30.09 .0001)
-
- (list .99 .0919 2.00 .0418 2.99 .0498 3.99 .0135 4.99 .0026 6.00 .0155 7.01 .0340
- 8.02 .0033 9.04 .0218 10.08 .0084 11.11 .0057 12.15 .0051 13.21 .0043 14.25 .0015 15.31 .0023
- 16.40 .0008 17.48 .0004 18.59 .0016 19.71 .0010 20.84 .0018 21.98 .0002 23.11 .0013 24.26 .0003
- 26.67 .0002 29.12 .0002 30.37 .0002 31.62 .0003 32.92 .0001)
-
- (list .99 .1174 1.99 .1126 2.99 .0370 3.99 .0159 5.01 .0472 6.01 .0091 7.03 .0211
- 8.05 .0015 9.07 .0098 10.11 .0038 11.15 .0042 12.20 .0018 13.24 .0041 14.32 .0033 15.41 .0052
- 16.49 .0001 17.61 .0004 18.71 .0004 19.84 .0004 20.99 .0002 22.14 .0006 23.31 .0006 24.50 .0004
- 25.70 .0002 28.09 .0002 28.66 .0002 32.00 .0001)
-
- (list 1.00 .1085 2.00 .1400 2.99 .0173 3.99 .0229 5.00 .0272 6.02 .0077 7.03 .0069
- 8.04 .0017 9.08 .0045 10.10 .0030 11.15 .0040 12.20 .0007 13.25 .0019 14.32 .0008 15.42 .0024
- 16.50 .0002 17.59 .0005 18.71 .0003 19.83 .0002 20.98 .0005 23.29 .0008)
-
- (list 1.00 .0985 2.00 .1440 2.99 .0364 3.99 .0425 5.00 .0190 6.01 .0089 7.03 .0278
- 8.04 .0006 9.07 .0083 10.10 .0021 11.14 .0050 12.18 .0005 13.26 .0036 14.33 .0005 15.41 .0026
- 17.62 .0004 18.75 .0004 19.89 .0003 21.04 .0012 22.21 .0002 23.38 .0004 27.04 .0001)
-
- (list .99 .1273 2.00 .1311 2.99 .0120 4.00 .0099 5.00 .0235 6.02 .0068 7.03 .0162
- 8.06 .0009 9.08 .0083 10.12 .0014 11.17 .0050 12.24 .0010 13.29 .0013 14.39 .0022 15.48 .0011
- 16.59 .0002 17.70 .0003 18.84 .0010 20.00 .0003 21.17 .0003 23.56 .0004 28.79 .0003)
-
- (list 1.00 .1018 2.00 .1486 3.00 .0165 4.00 .0186 5.01 .0194 6.02 .0045 7.04 .0083
- 8.06 .0012 9.10 .0066 10.15 .0009 11.19 .0008 12.26 .0011 13.34 .0028 14.45 .0006 15.53 .0009
- 16.66 .0002 17.79 .0006 18.94 .0005 20.11 .0003 21.29 .0005 22.49 .0003 23.73 .0005 26.22 .0001
- 27.52 .0001 28.88 .0002)
-
- (list 1.00 .1889 1.99 .1822 3.00 .0363 4.00 .0047 5.01 .0202 6.03 .0053 7.05 .0114
- 8.01 .0002 9.13 .0048 10.17 .0010 11.23 .0033 12.30 .0010 13.38 .0006 14.50 .0002 15.62 .0010
- 20.27 .0001 21.47 .0001)
-
- (list 1.00 .0522 1.99 .0763 2.99 .0404 4.00 .0139 5.01 .0185 6.01 .0021 7.06 .0045
- 8.09 .0002 9.11 .0003 10.17 .0006 11.25 .0004 12.32 .0005 13.40 .0003 14.53 .0003 15.65 .0007
- 16.80 .0001 17.95 .0002 19.14 .0006 20.34 .0002 21.56 .0003)
-
- (list .99 .1821 1.99 .0773 3.00 .0125 4.01 .0065 5.01 .0202 6.03 .0071 7.05 .0090
- 8.08 .0006 9.13 .0008 10.18 .0013 11.25 .0010 12.33 .0012 13.42 .0006 14.54 .0005 15.65 .0004
- 17.97 .0002 19.15 .0001)
-
- (list 1.00 .1868 2.00 .0951 3.00 .0147 4.01 .0134 5.02 .0184 6.04 .0132 7.06 .0011
- 8.11 .0008 9.15 .0010 10.22 .0012 11.30 .0011 12.40 .0003 13.11 .0004 13.49 .0002 14.62 .0003
- 15.77 .0001)
-
- (list 1.00 .1933 2.00 .0714 3.00 .0373 4.00 .0108 5.02 .0094 6.02 .0010 7.07 .0022
- 8.11 .0002 9.16 .0065 10.23 .0015 11.31 .0023 12.40 .0003 13.53 .0014 14.66 .0002 15.81 .0011
- 18.20 .0002 19.41 .0001)
-
- (list .99 .2113 1.99 .0877 3.00 .0492 4.01 .0094 5.02 .0144 6.04 .0103 7.07 .0117
- 8.12 .0006 9.19 .0019 10.25 .0007 11.35 .0017 12.45 .0010 13.58 .0003 14.74 .0003 15.91 .0003
- 19.57 .0002)
-
- (list .99 .2455 1.99 .0161 3.00 .0215 4.01 .0036 5.03 .0049 6.04 .0012 7.09 .0036
- 8.14 .0011 9.21 .0009 10.30 .0001 11.40 .0012 12.50 .0001 13.66 .0005 14.84 .0001)
-
- (list 1.00 .1132 2.00 .0252 3.00 .0292 4.01 .0136 5.03 .0045 6.06 .0022 7.11 .0101
- 8.17 .0004 9.23 .0010 10.33 .0012 11.44 .0013 12.58 .0011 13.75 .0002 14.93 .0005 16.14 .0002)
-
- (list 1.00 .1655 2.00 .0445 3.00 .0120 4.00 .0038 5.02 .0015 6.07 .0038 7.11 .0003
- 8.19 .0002 9.25 .0010 10.36 .0011 11.48 .0005 12.63 .0002 13.79 .0003 16.24 .0002)
-
- (list .99 .3637 1.99 .0259 3.01 .0038 4.01 .0057 5.03 .0040 6.07 .0067 7.12 .0014
- 8.19 .0004 9.27 .0003 10.38 .0002 12.67 .0001)
-
- (list 1.00 .1193 2.00 .0230 3.00 .0104 4.01 .0084 5.04 .0047 6.08 .0035 7.13 .0041
- 8.20 .0002 9.29 .0005 10.40 .0005 11.53 .0003 12.70 .0002 13.91 .0002)
-
- (list 1.00 .0752 2.00 .0497 3.00 .0074 4.02 .0076 5.05 .0053 6.09 .0043 7.15 .0024
- 8.22 .0001 9.32 .0006 10.45 .0002 11.58 .0001 12.78 .0001 15.22 .0001)
-
- (list 1.00 .2388 2.00 .0629 3.01 .0159 4.04 .0063 5.07 .0051 6.12 .0045 7.19 .0026
- 8.29 .0015 9.43 .0001 11.75 .0002)
-
- (list 1.00 .1919 2.01 .0116 3.01 .0031 4.03 .0090 5.07 .0061 6.13 .0036 7.19 .0013
- 8.30 .0016 9.13 .0001 10.59 .0002 11.78 .0002)
-
- (list 1.00 .1296 2.00 .0135 3.01 .0041 4.04 .0045 5.09 .0028 6.14 .0046 7.23 .0007
- 8.32 .0007 9.50 .0001)
-
- (list 1.00 .0692 2.00 .0209 3.02 .0025 4.05 .0030 5.09 .0047 6.17 .0022 7.25 .0015
- 8.36 .0015 9.53 .0010 10.69 .0001 13.40 .0001)
-
- (list 1.00 .1715 2.00 .0142 3.01 .0024 4.03 .0015 5.07 .0017 6.13 .0018 7.22 .0009
- 8.33 .0014 9.51 .0007 10.69 .0002)
-
- (list 1.00 .1555 2.01 .0148 3.02 .0007 4.06 .0006 5.10 .0005 6.16 .0008 7.26 .0009
- 8.39 .0008 9.58 .0002)
-
- (list 1.00 .1357 2.00 .0116 3.02 .0026 4.04 .0009 5.09 .0004 6.17 .0005 7.27 .0002
- 8.40 .0001)
-
- (list 1.00 .2185 2.01 .0087 3.03 .0018 4.06 .0025 5.11 .0020 6.20 .0012 7.32 .0005
- 8.46 .0001 9.66 .0003)
-
- (list 1.00 .2735 2.00 .0038 3.02 .0008 4.06 .0012 5.12 .0008 6.22 .0011 7.35 .0003
- 8.50 .0002)
-
- (list 1.00 .1441 1.99 .0062 3.01 .0023 4.05 .0011 5.11 .0012 6.20 .0003 7.33 .0004
- 8.50 .0001)
-
- (list 1.00 .0726 2.01 .0293 3.03 .0022 5.14 .0005 6.26 .0011 7.41 .0002 8.63 .0002)
-
- (list 1.00 .0516 2.00 .0104 3.02 .0029 5.15 .0002 6.27 .0001)
-
- (list 1.00 .0329 2.00 .0033 3.03 .0013 4.10 .0005 5.19 .0004 6.32 .0002)
-
- (list 1.00 .0179 1.99 .0012 3.04 .0005 4.10 .0017 5.20 .0005 6.35 .0001)
-
- (list 1.00 .0334 2.01 .0033 3.04 .0011 4.13 .0003 5.22 .0003)
-
- (list .99 .0161 2.01 .0100 3.04 .0020 4.13 .0003)
-
- (list 1.00 .0475 1.99 .0045 3.03 .0035 4.12 .0011)
-
- (list 1.00 .0593 2.00 .0014 4.17 .0002)
-
- (list 1.00 .0249 2.01 .0016)
-
- (list 1.00 .0242 2.00 .0038 4.19 .0002)
-
- (list 1.00 .0170 2.02 .0030)
-
- (list 1.00 .0381 2.00 .0017 3.09 .0002)
-
- (list 1.00 .0141 2.03 .0005 3.11 .0003 4.26 .0001)
-
- (list 1.00 .0122 2.03 .0024)
-
- (list 1.00 .0107 2.07 .0007 3.12 .0004)
-
- (list 1.00 .0250 2.02 .0026 3.15 .0002)
-
- (list 1.01 .0092)
-
- (list 1.01 .0102 2.09 .0005)
-
- (list 1.00 .0080 2.00 .0005 3.19 .0001)
-
- (list 1.01 .0298 2.01 .0005)))
-
- (*piano-attack-duration* .04)
- (*piano-release-duration* .2)
- (*db-drop-per-second* -10.0))
-
- (define (get-piano-partials freq)
- (let ((pitch (round (* 12 (log (/ freq 32.703) 2)))))
- (piano-spectra pitch)))
+ (define (get-piano-partials freq)
+ (let ((piano-spectra #((1.97 .0326 2.99 .0086 3.95 .0163 4.97 .0178 5.98 .0177 6.95 .0315 8.02 .0001
+ 8.94 .0076 9.96 .0134 10.99 .0284 11.98 .0229 13.02 .0229 13.89 .0010 15.06 .0090 16.00 .0003
+ 17.08 .0078 18.16 .0064 19.18 .0129 20.21 .0085 21.27 .0225 22.32 .0061 23.41 .0102 24.48 .0005
+ 25.56 .0016 26.64 .0018 27.70 .0113 28.80 .0111 29.91 .0158 31.06 .0093 32.17 .0017 33.32 .0002
+ 34.42 .0018 35.59 .0027 36.74 .0055 37.90 .0037 39.06 .0064 40.25 .0033 41.47 .0014 42.53 .0004
+ 43.89 .0010 45.12 .0039 46.33 .0039 47.64 .0009 48.88 .0016 50.13 .0006 51.37 .0010 52.70 .0002
+ 54.00 .0004 55.30 .0008 56.60 .0025 57.96 .0010 59.30 .0012 60.67 .0011 61.99 .0003 62.86 .0001
+ 64.36 .0005 64.86 .0001 66.26 .0004 67.70 .0006 68.94 .0002 70.10 .0001 70.58 .0002 72.01 .0007
+ 73.53 .0006 75.00 .0002 77.03 .0005 78.00 .0002 79.57 .0006 81.16 .0005 82.70 .0005 84.22 .0003
+ 85.41 .0002 87.46 .0001 90.30 .0001 94.02 .0001 95.26 .0002 109.39 .0003)
+
+ (1.98 .0194 2.99 .0210 3.97 .0276 4.96 .0297 5.96 .0158 6.99 .0207 8.01 .0009
+ 9.00 .0101 10.00 .0297 11.01 .0289 12.02 .0211 13.04 .0127 14.07 .0061 15.08 .0174 16.13 .0009
+ 17.12 .0093 18.16 .0117 19.21 .0122 20.29 .0108 21.30 .0077 22.38 .0132 23.46 .0073 24.14 .0002
+ 25.58 .0026 26.69 .0035 27.77 .0053 28.88 .0024 30.08 .0027 31.13 .0075 32.24 .0027 33.36 .0004
+ 34.42 .0004 35.64 .0019 36.78 .0037 38.10 .0009 39.11 .0027 40.32 .0010 41.51 .0013 42.66 .0019
+ 43.87 .0007 45.13 .0017 46.35 .0019 47.65 .0021 48.89 .0014 50.18 .0023 51.42 .0015 52.73 .0002
+ 54.00 .0005 55.34 .0006 56.60 .0010 57.96 .0016 58.86 .0005 59.30 .0004 60.75 .0005 62.22 .0003
+ 63.55 .0005 64.82 .0003 66.24 .0003 67.63 .0011 69.09 .0007 70.52 .0004 72.00 .0005 73.50 .0008
+ 74.95 .0003 77.13 .0013 78.02 .0002 79.48 .0004 82.59 .0004 84.10 .0003)
+
+ (2.00 .0313 2.99 .0109 4.00 .0215 5.00 .0242 5.98 .0355 7.01 .0132 8.01 .0009
+ 9.01 .0071 10.00 .0258 11.03 .0221 12.02 .0056 13.06 .0196 14.05 .0160 15.11 .0107 16.11 .0003
+ 17.14 .0111 18.21 .0085 19.23 .0010 20.28 .0048 21.31 .0128 22.36 .0051 23.41 .0041 24.05 .0006
+ 25.54 .0019 26.62 .0028 27.72 .0034 28.82 .0062 29.89 .0039 30.98 .0058 32.08 .0011 33.21 .0002
+ 34.37 .0008 35.46 .0018 36.62 .0036 37.77 .0018 38.92 .0042 40.07 .0037 41.23 .0011 42.67 .0003
+ 43.65 .0018 44.68 .0025 45.99 .0044 47.21 .0051 48.40 .0044 49.67 .0005 50.88 .0019 52.15 .0003
+ 53.42 .0008 54.69 .0010 55.98 .0005 57.26 .0013 58.53 .0027 59.83 .0011 61.21 .0027 62.54 .0003
+ 63.78 .0003 65.20 .0001 66.60 .0006 67.98 .0008 69.37 .0019 70.73 .0007 72.14 .0004 73.62 .0002
+ 74.40 .0003 76.52 .0006 77.97 .0002 79.49 .0004 80.77 .0003 81.00 .0001 82.47 .0005 83.97 .0001
+ 87.27 .0002)
+
+ (2.00 .0257 2.99 .0142 3.97 .0202 4.95 .0148 5.95 .0420 6.95 .0037 7.94 .0004
+ 8.94 .0172 9.95 .0191 10.96 .0115 11.97 .0059 12.98 .0140 14.00 .0178 15.03 .0121 16.09 .0002
+ 17.07 .0066 18.08 .0033 19.15 .0022 20.18 .0057 21.22 .0077 22.29 .0037 23.33 .0066 24.97 .0002
+ 25.49 .0019 26.55 .0042 27.61 .0043 28.73 .0038 29.81 .0084 30.91 .0040 32.03 .0025 33.14 .0005
+ 34.26 .0003 35.38 .0019 36.56 .0037 37.68 .0049 38.86 .0036 40.11 .0011 41.28 .0008 42.50 .0004
+ 43.60 .0002 44.74 .0022 45.99 .0050 47.20 .0009 48.40 .0036 49.68 .0004 50.92 .0009 52.17 .0005
+ 53.46 .0007 54.76 .0006 56.06 .0005 57.34 .0011 58.67 .0005 59.95 .0015 61.37 .0008 62.72 .0004
+ 65.42 .0009 66.96 .0003 68.18 .0003 69.78 .0003 71.21 .0004 72.45 .0002 74.22 .0003 75.44 .0001
+ 76.53 .0003 78.31 .0004 79.83 .0003 80.16 .0001 81.33 .0003 82.44 .0001 83.17 .0002 84.81 .0003
+ 85.97 .0003 89.08 .0001 90.70 .0002 92.30 .0002 95.59 .0002 97.22 .0003 98.86 .0001 108.37 .0001
+ 125.54 .0001)
+
+ (1.99 .0650 3.03 .0040 4.03 .0059 5.02 .0090 5.97 .0227 6.98 .0050 8.04 .0020
+ 9.00 .0082 9.96 .0078 11.01 .0056 12.01 .0095 13.02 .0050 14.04 .0093 15.08 .0064 16.14 .0017
+ 17.06 .0020 18.10 .0025 19.14 .0023 20.18 .0015 21.24 .0032 22.29 .0029 23.32 .0014 24.37 .0005
+ 25.43 .0030 26.50 .0022 27.60 .0027 28.64 .0024 29.76 .0035 30.81 .0136 31.96 .0025 33.02 .0003
+ 34.13 .0005 35.25 .0007 36.40 .0014 37.51 .0020 38.64 .0012 39.80 .0019 40.97 .0004 42.09 .0003
+ 43.24 .0003 44.48 .0002 45.65 .0024 46.86 .0005 48.07 .0013 49.27 .0008 50.49 .0006 52.95 .0001
+ 54.23 .0005 55.45 .0004 56.73 .0001 58.03 .0003 59.29 .0002 60.59 .0003 62.04 .0002 65.89 .0002
+ 67.23 .0002 68.61 .0002 69.97 .0004 71.36 .0005 85.42 .0001)
+
+ (1.98 .0256 2.96 .0158 3.95 .0310 4.94 .0411 5.95 .0238 6.94 .0152 7.93 .0011
+ 8.95 .0185 9.92 .0166 10.93 .0306 11.94 .0258 12.96 .0202 13.97 .0403 14.95 .0228 15.93 .0005
+ 17.01 .0072 18.02 .0034 19.06 .0028 20.08 .0124 21.13 .0137 22.16 .0102 23.19 .0058 23.90 .0013
+ 25.30 .0039 26.36 .0039 27.41 .0025 28.47 .0071 29.64 .0031 30.60 .0027 31.71 .0021 32.84 .0003
+ 33.82 .0002 35.07 .0019 36.09 .0054 37.20 .0038 38.33 .0024 39.47 .0055 40.55 .0016 41.77 .0006
+ 42.95 .0002 43.27 .0018 44.03 .0006 45.25 .0019 46.36 .0033 47.50 .0024 48.87 .0012 50.03 .0016
+ 51.09 .0004 53.52 .0017 54.74 .0012 56.17 .0003 57.40 .0011 58.42 .0020 59.70 .0007 61.29 .0008
+ 62.56 .0003 63.48 .0002 64.83 .0002 66.12 .0012 67.46 .0017 68.81 .0003 69.13 .0003 70.53 .0002
+ 71.84 .0001 73.28 .0002 75.52 .0010 76.96 .0005 77.93 .0003 78.32 .0003 79.73 .0003 81.69 .0002
+ 82.52 .0001 84.01 .0001 84.61 .0002 86.88 .0001 88.36 .0002 89.85 .0002 91.35 .0003 92.86 .0002
+ 93.40 .0001 105.28 .0002 106.22 .0002 107.45 .0001 108.70 .0003 122.08 .0002)
+
+ (1.97 .0264 2.97 .0211 3.98 .0234 4.98 .0307 5.96 .0085 6.94 .0140 7.93 .0005
+ 8.96 .0112 9.96 .0209 10.98 .0194 11.98 .0154 12.99 .0274 13.99 .0127 15.01 .0101 15.99 .0002
+ 17.04 .0011 18.08 .0032 19.14 .0028 20.12 .0054 21.20 .0053 22.13 .0028 23.22 .0030 24.32 .0006
+ 25.24 .0004 26.43 .0028 27.53 .0048 28.52 .0039 29.54 .0047 30.73 .0044 31.82 .0007 32.94 .0008
+ 34.04 .0012 35.13 .0018 36.29 .0007 37.35 .0075 38.51 .0045 39.66 .0014 40.90 .0004 41.90 .0002
+ 43.08 .0002 44.24 .0017 45.36 .0013 46.68 .0020 47.79 .0015 48.98 .0010 50.21 .0012 51.34 .0001
+ 53.82 .0003 55.09 .0004 56.23 .0005 57.53 .0004 58.79 .0005 59.30 .0002 60.03 .0002 61.40 .0003
+ 62.84 .0001 66.64 .0001 67.97 .0001 69.33 .0001 70.68 .0001 73.57 .0002 75.76 .0002 76.45 .0001
+ 79.27 .0001 80.44 .0002 81.87 .0002)
+
+ (2.00 .0311 2.99 .0086 3.99 .0266 4.97 .0123 5.98 .0235 6.97 .0161 7.97 .0008
+ 8.96 .0088 9.96 .0621 10.99 .0080 11.99 .0034 12.99 .0300 14.03 .0228 15.04 .0105 16.03 .0004
+ 17.06 .0036 18.09 .0094 18.95 .0009 20.17 .0071 21.21 .0161 22.25 .0106 23.28 .0104 24.33 .0008
+ 25.38 .0030 26.46 .0035 27.50 .0026 28.59 .0028 29.66 .0128 30.75 .0139 31.81 .0038 32.93 .0006
+ 34.04 .0004 35.16 .0005 36.25 .0023 37.35 .0012 38.46 .0021 39.59 .0035 40.71 .0006 41.86 .0007
+ 42.42 .0001 43.46 .0003 44.17 .0032 45.29 .0013 46.57 .0004 47.72 .0011 48.79 .0005 50.11 .0005
+ 51.29 .0003 52.47 .0002 53.68 .0004 55.02 .0005 56.18 .0003 57.41 .0003 58.75 .0007 59.33 .0009
+ 60.00 .0004 61.34 .0001 64.97 .0003 65.20 .0002 66.48 .0002 67.83 .0002 68.90 .0003 70.25 .0003
+ 71.59 .0002 73.68 .0001 75.92 .0001 77.08 .0002 78.45 .0002 81.56 .0002 82.99 .0001 88.39 .0001)
+
+ ( .97 .0059 1.98 .0212 2.99 .0153 3.99 .0227 4.96 .0215 5.97 .0153 6.98 .0085
+ 7.98 .0007 8.97 .0179 9.98 .0512 10.98 .0322 12.00 .0098 13.02 .0186 14.00 .0099 15.05 .0109
+ 15.88 .0011 17.07 .0076 18.11 .0071 19.12 .0045 20.16 .0038 21.23 .0213 22.27 .0332 23.34 .0082
+ 24.34 .0014 25.42 .0024 26.47 .0012 27.54 .0014 28.60 .0024 29.72 .0026 30.10 .0008 31.91 .0021
+ 32.13 .0011 33.02 .0007 34.09 .0014 35.17 .0007 36.27 .0024 37.39 .0029 38.58 .0014 39.65 .0017
+ 40.95 .0012 41.97 .0004 42.43 .0002 43.49 .0001 44.31 .0012 45.42 .0031 46.62 .0017 47.82 .0013
+ 49.14 .0013 50.18 .0010 51.54 .0003 53.90 .0006 55.06 .0010 56.31 .0003 57.63 .0001 59.02 .0003
+ 60.09 .0004 60.35 .0004 61.62 .0009 63.97 .0001 65.19 .0001 65.54 .0002 66.92 .0002 67.94 .0002
+ 69.17 .0003 69.60 .0004 70.88 .0002 72.24 .0002 76.12 .0001 78.94 .0001 81.75 .0001 82.06 .0001
+ 83.53 .0001 90.29 .0002 91.75 .0001 92.09 .0002 93.28 .0001 97.07 .0001)
+
+ (1.98 .0159 2.98 .1008 3.98 .0365 4.98 .0133 5.97 .0101 6.97 .0115 7.97 .0007
+ 8.99 .0349 10.01 .0342 11.01 .0236 12.00 .0041 13.02 .0114 14.05 .0137 15.06 .0100 16.05 .0007
+ 17.04 .0009 18.12 .0077 19.15 .0023 20.12 .0017 21.24 .0113 22.26 .0126 23.30 .0093 24.36 .0007
+ 25.43 .0007 26.47 .0009 27.55 .0013 28.59 .0025 29.61 .0010 30.77 .0021 31.86 .0023 32.96 .0003
+ 34.03 .0007 35.06 .0005 36.20 .0006 37.34 .0006 38.36 .0009 39.60 .0016 40.69 .0005 41.77 .0002
+ 42.92 .0002 44.02 .0003 45.24 .0006 46.33 .0004 47.50 .0007 48.71 .0007 49.87 .0002 51.27 .0002
+ 53.42 .0003 55.88 .0003 57.10 .0004 58.34 .0002 59.86 .0003 61.13 .0003 67.18 .0001 68.50 .0001
+ 71.17 .0001 83.91 .0001 90.55 .0001)
+
+ ( .98 .0099 2.00 .0181 2.99 .0353 3.98 .0285 4.97 .0514 5.96 .0402 6.96 .0015
+ 7.98 .0012 8.98 .0175 9.98 .0264 10.98 .0392 11.98 .0236 13.00 .0153 14.04 .0049 15.00 .0089
+ 16.01 .0001 17.03 .0106 18.03 .0028 19.05 .0024 20.08 .0040 21.11 .0103 22.12 .0104 23.20 .0017
+ 24.19 .0008 25.20 .0007 26.24 .0011 27.36 .0009 27.97 .0030 29.40 .0044 30.37 .0019 31.59 .0017
+ 32.65 .0008 33.59 .0005 34.79 .0009 35.75 .0027 36.88 .0035 37.93 .0039 39.00 .0031 40.08 .0025
+ 41.16 .0010 43.25 .0004 44.52 .0012 45.62 .0023 45.85 .0012 47.00 .0006 47.87 .0008 48.99 .0003
+ 50.48 .0003 51.62 .0001 52.43 .0001 53.56 .0002 54.76 .0002 56.04 .0002 56.68 .0006 57.10 .0003
+ 58.28 .0005 59.47 .0003 59.96 .0002 60.67 .0001 63.08 .0002 64.29 .0002 66.72 .0001 67.97 .0001
+ 68.65 .0001 70.43 .0001 79.38 .0001 80.39 .0001 82.39 .0001)
+
+ (1.00 .0765 1.99 .0151 2.99 .0500 3.99 .0197 5.00 .0260 6.00 .0145 6.98 .0128
+ 7.97 .0004 8.98 .0158 9.99 .0265 11.02 .0290 12.02 .0053 13.03 .0242 14.03 .0103 15.06 .0054
+ 16.04 .0006 17.08 .0008 18.10 .0058 19.16 .0011 20.16 .0055 21.18 .0040 22.20 .0019 23.22 .0014
+ 24.05 .0005 25.31 .0019 26.38 .0018 27.44 .0022 28.45 .0024 29.57 .0073 30.58 .0032 31.66 .0071
+ 32.73 .0015 33.85 .0005 34.96 .0003 36.00 .0020 37.11 .0018 38.18 .0055 39.23 .0006 40.33 .0004
+ 41.52 .0003 43.41 .0028 45.05 .0003 45.99 .0002 47.07 .0003 48.52 .0002 49.48 .0003 50.63 .0003
+ 51.81 .0002 54.05 .0002 55.24 .0001 56.62 .0001 57.81 .0004 59.16 .0013 60.23 .0003 66.44 .0001
+ 68.99 .0004 75.49 .0001 87.56 .0004)
+
+ ( .98 .0629 1.99 .0232 2.98 .0217 4.00 .0396 4.98 .0171 5.97 .0098 6.99 .0167
+ 7.99 .0003 8.98 .0192 9.98 .0266 10.99 .0256 12.01 .0061 13.02 .0135 14.02 .0062 15.05 .0158
+ 16.06 .0018 17.08 .0101 18.09 .0053 19.11 .0074 20.13 .0020 21.17 .0052 22.22 .0077 23.24 .0035
+ 24.00 .0009 25.32 .0016 26.40 .0022 27.43 .0005 28.55 .0026 29.60 .0026 30.65 .0010 31.67 .0019
+ 32.77 .0008 33.81 .0003 34.91 .0003 36.01 .0005 37.11 .0010 38.20 .0014 39.29 .0039 40.43 .0012
+ 41.50 .0006 43.38 .0017 43.75 .0002 44.94 .0005 46.13 .0002 47.11 .0003 48.28 .0005 48.42 .0005
+ 49.44 .0003 50.76 .0004 51.93 .0002 54.15 .0003 55.31 .0005 55.50 .0003 56.98 .0003 57.90 .0004
+ 60.33 .0002 61.39 .0001 61.59 .0001 65.09 .0002 66.34 .0001 68.85 .0001 70.42 .0002 71.72 .0001
+ 73.05 .0003 79.65 .0001 85.28 .0002 93.52 .0001)
+
+ (1.02 .0185 1.99 .0525 2.98 .0613 3.99 .0415 4.98 .0109 5.97 .0248 6.99 .0102
+ 7.98 .0005 8.98 .0124 9.99 .0103 10.99 .0124 12.00 .0016 13.01 .0029 14.03 .0211 15.04 .0128
+ 16.07 .0021 17.09 .0009 18.09 .0043 19.14 .0022 20.13 .0016 21.20 .0045 22.21 .0088 23.26 .0046
+ 24.29 .0013 25.35 .0009 26.39 .0028 27.49 .0009 28.51 .0006 29.58 .0012 30.70 .0010 31.74 .0019
+ 32.75 .0002 33.85 .0001 34.95 .0005 36.02 .0003 37.16 .0009 38.25 .0018 39.35 .0008 40.54 .0004
+ 41.61 .0002 43.40 .0004 43.74 .0003 45.05 .0001 46.11 .0003 47.40 .0002 48.36 .0004 49.55 .0004
+ 50.72 .0002 52.00 .0001 55.58 .0002 57.02 .0001 57.98 .0002 59.13 .0003 61.56 .0001 66.56 .0001
+ 87.65 .0002)
+
+ (1.00 .0473 1.99 .0506 2.99 .0982 3.99 .0654 5.00 .0196 5.99 .0094 6.99 .0118
+ 7.93 .0001 8.99 .0057 10.01 .0285 11.01 .0142 12.03 .0032 13.03 .0056 14.06 .0064 15.06 .0059
+ 16.11 .0005 17.09 .0033 18.14 .0027 19.15 .0014 20.17 .0010 21.21 .0059 22.26 .0043 23.31 .0031
+ 24.31 .0018 25.33 .0009 26.41 .0005 27.47 .0015 28.53 .0015 29.58 .0041 30.65 .0025 31.73 .0011
+ 32.83 .0010 34.98 .0003 36.07 .0009 37.23 .0001 38.26 .0020 39.41 .0014 40.53 .0005 41.40 .0003
+ 42.80 .0002 43.48 .0028 43.93 .0001 45.03 .0003 46.18 .0007 47.41 .0001 48.57 .0002 49.67 .0001
+ 50.83 .0002 54.39 .0001 55.58 .0002 57.97 .0005 58.11 .0002 59.21 .0001 60.42 .0002 61.66 .0001)
+
+ (1.00 .0503 2.00 .0963 2.99 .1304 3.99 .0218 4.98 .0041 5.98 .0292 6.98 .0482
+ 7.99 .0005 8.99 .0280 10.00 .0237 11.00 .0152 12.02 .0036 12.95 .0022 14.06 .0111 15.07 .0196
+ 16.08 .0016 17.11 .0044 18.13 .0073 19.17 .0055 20.19 .0028 21.20 .0012 22.27 .0068 23.30 .0036
+ 24.35 .0012 25.35 .0002 26.46 .0005 27.47 .0005 28.59 .0009 29.65 .0021 30.70 .0020 31.78 .0012
+ 32.89 .0010 35.06 .0005 36.16 .0008 37.27 .0010 38.36 .0010 39.47 .0014 40.58 .0004 41.43 .0007
+ 41.82 .0003 43.48 .0008 44.53 .0001 45.25 .0003 46.43 .0002 47.46 .0002 48.76 .0005 49.95 .0004
+ 50.96 .0002 51.12 .0002 52.33 .0001 54.75 .0001 55.75 .0002 56.90 .0002 58.17 .0002 59.40 .0004
+ 60.62 .0002 65.65 .0001 66.91 .0002 69.91 .0001 71.25 .0002)
+
+ (1.00 .1243 1.98 .1611 3.00 .0698 3.98 .0390 5.00 .0138 5.99 .0154 7.01 .0287
+ 8.01 .0014 9.01 .0049 10.00 .0144 11.01 .0055 12.05 .0052 13.01 .0011 14.05 .0118 15.07 .0154
+ 16.12 .0028 17.14 .0061 18.25 .0007 19.22 .0020 20.24 .0011 21.27 .0029 22.30 .0046 23.34 .0049
+ 24.35 .0004 25.45 .0003 26.47 .0007 27.59 .0008 28.16 .0009 29.12 .0002 29.81 .0006 30.81 .0009
+ 31.95 .0004 33.00 .0011 34.12 .0005 35.18 .0003 36.30 .0008 37.38 .0003 38.55 .0003 39.64 .0006
+ 40.77 .0007 41.52 .0006 41.89 .0006 43.04 .0011 43.60 .0009 44.31 .0002 45.68 .0002 46.56 .0003
+ 47.60 .0001 48.83 .0006 50.01 .0003 51.27 .0003 56.04 .0005 57.21 .0003 58.56 .0004 59.83 .0003
+ 61.05 .0001 62.20 .0001 67.37 .0002 76.53 .0001)
+
+ ( .99 .0222 1.99 .0678 2.99 .0683 4.00 .0191 5.00 .0119 6.01 .0232 6.98 .0336
+ 7.99 .0082 9.01 .0201 10.01 .0189 11.01 .0041 12.01 .0053 13.05 .0154 14.04 .0159 15.06 .0092
+ 16.11 .0038 17.12 .0014 18.15 .0091 19.16 .0006 20.30 .0012 21.25 .0061 22.28 .0099 23.34 .0028
+ 24.38 .0012 25.43 .0016 26.49 .0048 27.55 .0025 28.62 .0015 29.71 .0032 30.78 .0077 31.88 .0011
+ 32.97 .0007 34.08 .0006 35.16 .0008 36.28 .0004 37.41 .0006 38.54 .0005 39.62 .0002 40.80 .0003
+ 41.93 .0001 43.06 .0002 44.21 .0003 45.38 .0002 46.54 .0007 47.78 .0003 48.95 .0004 50.10 .0003
+ 51.37 .0002 53.79 .0003 56.20 .0001 58.71 .0002 66.47 .0003)
+
+ (1.01 .0241 1.99 .1011 2.98 .0938 3.98 .0081 4.99 .0062 5.99 .0291 6.99 .0676
+ 7.59 .0004 8.98 .0127 9.99 .0112 10.99 .0142 12.00 .0029 13.02 .0071 14.02 .0184 15.03 .0064
+ 16.07 .0010 17.09 .0011 18.11 .0010 19.15 .0060 20.19 .0019 21.24 .0025 22.29 .0013 23.31 .0050
+ 25.41 .0030 26.50 .0018 27.53 .0006 28.63 .0012 29.66 .0013 30.77 .0020 31.84 .0006 34.04 .0001
+ 35.14 .0001 36.32 .0004 37.41 .0007 38.53 .0007 39.67 .0009 40.85 .0003 45.49 .0002 46.65 .0001
+ 47.81 .0004 49.01 .0002 53.91 .0002 55.14 .0002 57.69 .0002)
+
+ (1.00 .0326 2.00 .1066 2.99 .1015 4.00 .0210 4.97 .0170 5.99 .0813 6.98 .0820
+ 7.96 .0011 8.99 .0248 10.03 .0107 11.01 .0126 12.01 .0027 13.01 .0233 14.04 .0151 15.05 .0071
+ 16.04 .0002 17.10 .0061 18.12 .0059 19.15 .0087 20.23 .0005 21.25 .0040 22.30 .0032 23.35 .0004
+ 24.40 .0001 25.45 .0030 26.54 .0022 27.60 .0003 28.70 .0009 29.80 .0029 30.85 .0006 31.97 .0006
+ 34.19 .0004 35.30 .0003 36.43 .0007 37.56 .0005 38.68 .0019 39.88 .0013 41.00 .0003 43.35 .0003
+ 44.51 .0002 45.68 .0006 46.93 .0010 48.11 .0006 49.29 .0003 55.58 .0002)
+
+ ( .98 .0113 1.99 .0967 3.00 .0719 3.98 .0345 4.98 .0121 6.00 .0621 7.00 .0137
+ 7.98 .0006 9.01 .0314 10.01 .0171 11.02 .0060 12.03 .0024 13.05 .0077 14.07 .0040 15.12 .0032
+ 16.13 .0004 17.15 .0011 18.20 .0028 19.18 .0003 20.26 .0003 21.31 .0025 22.35 .0021 23.39 .0005
+ 25.55 .0002 26.62 .0014 27.70 .0003 28.78 .0005 29.90 .0030 31.01 .0011 32.12 .0005 34.31 .0001
+ 35.50 .0002 36.62 .0002 37.76 .0005 38.85 .0002 40.09 .0004 43.60 .0001 44.73 .0002 46.02 .0002
+ 47.25 .0004 48.44 .0004)
+
+ ( .99 .0156 1.98 .0846 2.98 .0178 3.98 .0367 4.98 .0448 5.98 .0113 6.99 .0189
+ 8.00 .0011 9.01 .0247 10.02 .0089 11.01 .0184 12.03 .0105 13.00 .0039 14.07 .0116 15.09 .0078
+ 16.13 .0008 17.14 .0064 18.19 .0029 19.22 .0028 20.25 .0017 21.32 .0043 22.37 .0055 23.42 .0034
+ 24.48 .0004 25.54 .0002 26.61 .0017 27.70 .0011 28.80 .0002 29.89 .0019 30.97 .0028 32.09 .0007
+ 34.30 .0002 35.44 .0003 36.55 .0001 37.69 .0004 38.93 .0002 40.05 .0005 41.20 .0005 42.37 .0002
+ 43.54 .0003 44.73 .0001 45.95 .0002 47.16 .0001 48.43 .0005 49.65 .0004 55.90 .0002 59.81 .0004)
+
+ (1.01 .0280 2.00 .0708 2.99 .0182 3.99 .0248 4.98 .0245 5.98 .0279 6.98 .0437
+ 7.99 .0065 8.99 .0299 10.00 .0073 10.99 .0011 12.03 .0122 13.03 .0028 14.08 .0044 15.11 .0097
+ 16.15 .0010 17.17 .0025 18.19 .0017 19.24 .0008 20.28 .0040 21.32 .0024 22.38 .0008 23.46 .0032
+ 24.52 .0010 25.59 .0008 26.68 .0009 27.76 .0012 28.88 .0003 29.95 .0005 31.05 .0017 32.14 .0002
+ 33.29 .0003 37.88 .0002 39.03 .0002 40.19 .0004 41.37 .0003 43.74 .0002 46.20 .0001 48.68 .0001
+ 49.93 .0001 51.19 .0002)
+
+ (1.00 .0225 1.99 .0921 2.98 .0933 3.99 .0365 4.99 .0100 5.98 .0213 6.98 .0049
+ 7.98 .0041 8.98 .0090 9.99 .0068 11.01 .0040 12.03 .0086 13.02 .0015 14.04 .0071 15.09 .0082
+ 16.14 .0011 17.15 .0014 18.18 .0010 19.26 .0013 20.26 .0005 21.33 .0006 22.36 .0011 23.46 .0016
+ 24.52 .0004 25.59 .0002 26.70 .0006 27.78 .0007 28.87 .0002 30.03 .0008 31.14 .0010 32.24 .0006
+ 33.37 .0002 35.67 .0003 37.99 .0004 39.17 .0004 40.35 .0005 41.53 .0001 46.42 .0001)
+
+ (1.00 .0465 1.99 .0976 2.98 .0678 4.00 .0727 4.99 .0305 5.98 .0210 6.98 .0227
+ 8.00 .0085 9.01 .0183 10.02 .0258 11.05 .0003 12.06 .0061 13.05 .0021 14.10 .0089 15.12 .0077
+ 16.16 .0016 17.21 .0061 18.23 .0011 19.29 .0031 20.36 .0031 21.41 .0007 22.48 .0013 23.55 .0020
+ 24.64 .0004 25.74 .0005 26.81 .0006 27.95 .0006 29.03 .0001 30.22 .0010 31.30 .0004 32.48 .0001
+ 33.60 .0002 38.30 .0003)
+
+ (1.00 .0674 1.99 .0841 2.98 .0920 3.99 .0328 4.99 .0368 5.98 .0206 6.99 .0246
+ 8.01 .0048 9.01 .0218 10.03 .0155 11.05 .0048 12.06 .0077 13.00 .0020 14.10 .0083 15.15 .0084
+ 16.18 .0015 17.22 .0039 18.27 .0032 19.34 .0026 20.40 .0012 21.47 .0009 22.54 .0008 23.62 .0016
+ 24.71 .0005 25.82 .0004 26.91 .0002 28.03 .0008 29.17 .0002 30.32 .0028 31.45 .0004 32.61 .0005
+ 33.77 .0001 36.14 .0003 37.32 .0002 38.54 .0005 39.75 .0002 42.23 .0002 48.65 .0001)
+
+ (1.01 .0423 1.99 .0240 2.98 .0517 4.00 .0493 5.00 .0324 6.00 .0094 6.99 .0449
+ 7.99 .0050 9.00 .0197 10.03 .0132 11.03 .0009 12.07 .0017 13.08 .0023 14.12 .0094 15.16 .0071
+ 16.21 .0020 17.25 .0005 18.30 .0027 19.04 .0004 20.43 .0022 21.51 .0002 22.59 .0006 23.72 .0018
+ 24.80 .0002 25.88 .0002 27.03 .0002 28.09 .0006 29.31 .0002 30.46 .0004 31.61 .0007 32.78 .0005
+ 33.95 .0001 36.34 .0002 37.56 .0001 38.80 .0001 40.02 .0001 44.14 .0001)
+
+ (1.00 .0669 1.99 .0909 2.99 .0410 3.98 .0292 4.98 .0259 5.98 .0148 6.98 .0319
+ 7.99 .0076 9.01 .0056 10.02 .0206 11.04 .0032 12.05 .0085 13.08 .0040 14.12 .0037 15.16 .0030
+ 16.20 .0013 17.24 .0021 18.30 .0010 19.36 .0015 20.44 .0013 21.50 .0009 22.60 .0015 23.69 .0014
+ 24.80 .0006 25.87 .0002 27.02 .0006 28.12 .0002 29.28 .0003 30.43 .0002 31.59 .0007 32.79 .0001
+ 35.14 .0001 37.57 .0001 40.03 .0002 41.28 .0004 44.10 .0001)
+
+ ( .99 .0421 1.99 .1541 2.98 .0596 3.98 .0309 4.98 .0301 5.99 .0103 7.00 .0240
+ 8.01 .0073 9.01 .0222 10.04 .0140 11.05 .0033 12.08 .0045 13.13 .0009 14.13 .0015 15.21 .0026
+ 16.24 .0003 17.30 .0004 18.35 .0010 19.39 .0003 20.50 .0015 21.57 .0003 22.68 .0011 23.80 .0005
+ 24.90 .0008 26.02 .0002 27.16 .0001 28.30 .0006 29.48 .0002 31.81 .0005 33.00 .0003 34.21 .0001
+ 37.89 .0001)
+
+ ( .99 .0389 2.00 .2095 3.00 .0835 3.99 .0289 5.00 .0578 5.99 .0363 7.01 .0387
+ 8.01 .0056 9.04 .0173 10.05 .0175 11.08 .0053 12.10 .0056 13.15 .0064 14.19 .0036 15.22 .0019
+ 16.29 .0010 17.36 .0017 18.43 .0018 19.51 .0004 20.60 .0011 21.70 .0003 22.82 .0003 23.95 .0001
+ 25.05 .0004 26.17 .0001 28.50 .0003 29.68 .0001 32.07 .0003 33.28 .0004 34.52 .0001)
+
+ (1.00 .1238 1.99 .2270 3.00 .0102 3.99 .0181 4.98 .0415 6.00 .0165 7.01 .0314
+ 8.02 .0148 9.04 .0203 10.05 .0088 11.07 .0062 12.11 .0070 13.14 .0054 14.19 .0028 15.24 .0044
+ 16.30 .0029 17.38 .0009 18.45 .0026 19.56 .0003 20.65 .0025 21.74 .0014 22.87 .0013 23.99 .0007
+ 25.15 .0002 27.46 .0004 28.39 .0006 28.65 .0004 29.85 .0001 31.05 .0002 32.27 .0003 33.52 .0002
+ 34.76 .0003)
+
+ (1.00 .1054 2.00 .2598 2.99 .0369 3.98 .0523 4.99 .0020 5.99 .0051 7.00 .0268
+ 8.01 .0027 9.04 .0029 10.05 .0081 11.08 .0047 12.12 .0051 13.16 .0091 14.19 .0015 15.27 .0030
+ 16.34 .0017 17.42 .0006 18.51 .0003 19.61 .0007 20.72 .0003 21.84 .0001 22.99 .0010 24.13 .0001
+ 28.44 .0001 30.09 .0001)
+
+ ( .99 .0919 2.00 .0418 2.99 .0498 3.99 .0135 4.99 .0026 6.00 .0155 7.01 .0340
+ 8.02 .0033 9.04 .0218 10.08 .0084 11.11 .0057 12.15 .0051 13.21 .0043 14.25 .0015 15.31 .0023
+ 16.40 .0008 17.48 .0004 18.59 .0016 19.71 .0010 20.84 .0018 21.98 .0002 23.11 .0013 24.26 .0003
+ 26.67 .0002 29.12 .0002 30.37 .0002 31.62 .0003 32.92 .0001)
+
+ ( .99 .1174 1.99 .1126 2.99 .0370 3.99 .0159 5.01 .0472 6.01 .0091 7.03 .0211
+ 8.05 .0015 9.07 .0098 10.11 .0038 11.15 .0042 12.20 .0018 13.24 .0041 14.32 .0033 15.41 .0052
+ 16.49 .0001 17.61 .0004 18.71 .0004 19.84 .0004 20.99 .0002 22.14 .0006 23.31 .0006 24.50 .0004
+ 25.70 .0002 28.09 .0002 28.66 .0002 32.00 .0001)
+
+ (1.00 .1085 2.00 .1400 2.99 .0173 3.99 .0229 5.00 .0272 6.02 .0077 7.03 .0069
+ 8.04 .0017 9.08 .0045 10.10 .0030 11.15 .0040 12.20 .0007 13.25 .0019 14.32 .0008 15.42 .0024
+ 16.50 .0002 17.59 .0005 18.71 .0003 19.83 .0002 20.98 .0005 23.29 .0008)
+
+ (1.00 .0985 2.00 .1440 2.99 .0364 3.99 .0425 5.00 .0190 6.01 .0089 7.03 .0278
+ 8.04 .0006 9.07 .0083 10.10 .0021 11.14 .0050 12.18 .0005 13.26 .0036 14.33 .0005 15.41 .0026
+ 17.62 .0004 18.75 .0004 19.89 .0003 21.04 .0012 22.21 .0002 23.38 .0004 27.04 .0001)
+
+ ( .99 .1273 2.00 .1311 2.99 .0120 4.00 .0099 5.00 .0235 6.02 .0068 7.03 .0162
+ 8.06 .0009 9.08 .0083 10.12 .0014 11.17 .0050 12.24 .0010 13.29 .0013 14.39 .0022 15.48 .0011
+ 16.59 .0002 17.70 .0003 18.84 .0010 20.00 .0003 21.17 .0003 23.56 .0004 28.79 .0003)
+
+ (1.00 .1018 2.00 .1486 3.00 .0165 4.00 .0186 5.01 .0194 6.02 .0045 7.04 .0083
+ 8.06 .0012 9.10 .0066 10.15 .0009 11.19 .0008 12.26 .0011 13.34 .0028 14.45 .0006 15.53 .0009
+ 16.66 .0002 17.79 .0006 18.94 .0005 20.11 .0003 21.29 .0005 22.49 .0003 23.73 .0005 26.22 .0001
+ 27.52 .0001 28.88 .0002)
+
+ (1.00 .1889 1.99 .1822 3.00 .0363 4.00 .0047 5.01 .0202 6.03 .0053 7.05 .0114
+ 8.01 .0002 9.13 .0048 10.17 .0010 11.23 .0033 12.30 .0010 13.38 .0006 14.50 .0002 15.62 .0010
+ 20.27 .0001 21.47 .0001)
+
+ (1.00 .0522 1.99 .0763 2.99 .0404 4.00 .0139 5.01 .0185 6.01 .0021 7.06 .0045
+ 8.09 .0002 9.11 .0003 10.17 .0006 11.25 .0004 12.32 .0005 13.40 .0003 14.53 .0003 15.65 .0007
+ 16.80 .0001 17.95 .0002 19.14 .0006 20.34 .0002 21.56 .0003)
+
+ ( .99 .1821 1.99 .0773 3.00 .0125 4.01 .0065 5.01 .0202 6.03 .0071 7.05 .0090
+ 8.08 .0006 9.13 .0008 10.18 .0013 11.25 .0010 12.33 .0012 13.42 .0006 14.54 .0005 15.65 .0004
+ 17.97 .0002 19.15 .0001)
+
+ (1.00 .1868 2.00 .0951 3.00 .0147 4.01 .0134 5.02 .0184 6.04 .0132 7.06 .0011
+ 8.11 .0008 9.15 .0010 10.22 .0012 11.30 .0011 12.40 .0003 13.11 .0004 13.49 .0002 14.62 .0003
+ 15.77 .0001)
+
+ (1.00 .1933 2.00 .0714 3.00 .0373 4.00 .0108 5.02 .0094 6.02 .0010 7.07 .0022
+ 8.11 .0002 9.16 .0065 10.23 .0015 11.31 .0023 12.40 .0003 13.53 .0014 14.66 .0002 15.81 .0011
+ 18.20 .0002 19.41 .0001)
+
+ ( .99 .2113 1.99 .0877 3.00 .0492 4.01 .0094 5.02 .0144 6.04 .0103 7.07 .0117
+ 8.12 .0006 9.19 .0019 10.25 .0007 11.35 .0017 12.45 .0010 13.58 .0003 14.74 .0003 15.91 .0003
+ 19.57 .0002)
+
+ ( .99 .2455 1.99 .0161 3.00 .0215 4.01 .0036 5.03 .0049 6.04 .0012 7.09 .0036
+ 8.14 .0011 9.21 .0009 10.30 .0001 11.40 .0012 12.50 .0001 13.66 .0005 14.84 .0001)
+
+ (1.00 .1132 2.00 .0252 3.00 .0292 4.01 .0136 5.03 .0045 6.06 .0022 7.11 .0101
+ 8.17 .0004 9.23 .0010 10.33 .0012 11.44 .0013 12.58 .0011 13.75 .0002 14.93 .0005 16.14 .0002)
+
+ (1.00 .1655 2.00 .0445 3.00 .0120 4.00 .0038 5.02 .0015 6.07 .0038 7.11 .0003
+ 8.19 .0002 9.25 .0010 10.36 .0011 11.48 .0005 12.63 .0002 13.79 .0003 16.24 .0002)
+
+ ( .99 .3637 1.99 .0259 3.01 .0038 4.01 .0057 5.03 .0040 6.07 .0067 7.12 .0014
+ 8.19 .0004 9.27 .0003 10.38 .0002 12.67 .0001)
+
+ (1.00 .1193 2.00 .0230 3.00 .0104 4.01 .0084 5.04 .0047 6.08 .0035 7.13 .0041
+ 8.20 .0002 9.29 .0005 10.40 .0005 11.53 .0003 12.70 .0002 13.91 .0002)
+
+ (1.00 .0752 2.00 .0497 3.00 .0074 4.02 .0076 5.05 .0053 6.09 .0043 7.15 .0024
+ 8.22 .0001 9.32 .0006 10.45 .0002 11.58 .0001 12.78 .0001 15.22 .0001)
+
+ (1.00 .2388 2.00 .0629 3.01 .0159 4.04 .0063 5.07 .0051 6.12 .0045 7.19 .0026
+ 8.29 .0015 9.43 .0001 11.75 .0002)
+
+ (1.00 .1919 2.01 .0116 3.01 .0031 4.03 .0090 5.07 .0061 6.13 .0036 7.19 .0013
+ 8.30 .0016 9.13 .0001 10.59 .0002 11.78 .0002)
+
+ (1.00 .1296 2.00 .0135 3.01 .0041 4.04 .0045 5.09 .0028 6.14 .0046 7.23 .0007
+ 8.32 .0007 9.50 .0001)
+
+ (1.00 .0692 2.00 .0209 3.02 .0025 4.05 .0030 5.09 .0047 6.17 .0022 7.25 .0015
+ 8.36 .0015 9.53 .0010 10.69 .0001 13.40 .0001)
+
+ (1.00 .1715 2.00 .0142 3.01 .0024 4.03 .0015 5.07 .0017 6.13 .0018 7.22 .0009
+ 8.33 .0014 9.51 .0007 10.69 .0002)
+
+ (1.00 .1555 2.01 .0148 3.02 .0007 4.06 .0006 5.10 .0005 6.16 .0008 7.26 .0009
+ 8.39 .0008 9.58 .0002)
+
+ (1.00 .1357 2.00 .0116 3.02 .0026 4.04 .0009 5.09 .0004 6.17 .0005 7.27 .0002
+ 8.40 .0001)
+
+ (1.00 .2185 2.01 .0087 3.03 .0018 4.06 .0025 5.11 .0020 6.20 .0012 7.32 .0005
+ 8.46 .0001 9.66 .0003)
+
+ (1.00 .2735 2.00 .0038 3.02 .0008 4.06 .0012 5.12 .0008 6.22 .0011 7.35 .0003
+ 8.50 .0002)
+
+ (1.00 .1441 1.99 .0062 3.01 .0023 4.05 .0011 5.11 .0012 6.20 .0003 7.33 .0004
+ 8.50 .0001)
+
+ (1.00 .0726 2.01 .0293 3.03 .0022 5.14 .0005 6.26 .0011 7.41 .0002 8.63 .0002)
+
+ (1.00 .0516 2.00 .0104 3.02 .0029 5.15 .0002 6.27 .0001)
+
+ (1.00 .0329 2.00 .0033 3.03 .0013 4.10 .0005 5.19 .0004 6.32 .0002)
+
+ (1.00 .0179 1.99 .0012 3.04 .0005 4.10 .0017 5.20 .0005 6.35 .0001)
+
+ (1.00 .0334 2.01 .0033 3.04 .0011 4.13 .0003 5.22 .0003)
+
+ ( .99 .0161 2.01 .0100 3.04 .0020 4.13 .0003)
+
+ (1.00 .0475 1.99 .0045 3.03 .0035 4.12 .0011)
+
+ (1.00 .0593 2.00 .0014 4.17 .0002)
+
+ (1.00 .0249 2.01 .0016)
+
+ (1.00 .0242 2.00 .0038 4.19 .0002)
+
+ (1.00 .0170 2.02 .0030)
+
+ (1.00 .0381 2.00 .0017 3.09 .0002)
+
+ (1.00 .0141 2.03 .0005 3.11 .0003 4.26 .0001)
+
+ (1.00 .0122 2.03 .0024)
+
+ (1.00 .0107 2.07 .0007 3.12 .0004)
+
+ (1.00 .0250 2.02 .0026 3.15 .0002)
+
+ (1.01 .0092)
+
+ (1.01 .0102 2.09 .0005)
+
+ (1.00 .0080 2.00 .0005 3.19 .0001)
+
+ (1.01 .0298 2.01 .0005)))
+ (pitch (round (* 12 (log (/ freq 32.703) 2)))))
+ (piano-spectra pitch)))
+
+ (let ((*piano-attack-duration* .04)
+ (*piano-release-duration* .2))
+
(define (make-piano-ampfun dur)
- (let ((releaseAmp (db->linear (* *db-drop-per-second* dur)))
- (attackTime (/ (* *piano-attack-duration* 100) dur)))
- (list 0 0 (/ attackTime 4) 1.0 attackTime 1.0 100 releaseAmp)))
+ (let ((*db-drop-per-second* -10.0))
+ (let ((releaseAmp (db->linear (* *db-drop-per-second* dur)))
+ (attackTime (/ (* *piano-attack-duration* 100) dur)))
+ (list 0 0 (/ attackTime 4) 1.0 attackTime 1.0 100 releaseAmp))))
;; This thing sounds pretty good down low, below middle c or so.
;; The high notes sound pretty rotten--they just don't
@@ -1770,7 +1773,7 @@ is a physical model of a flute:
;; when you're repeating notes. Note that there's no nyquist detection;
;; a high freq with a low pfreq, will give you fold over (hmmm...maybe
;; I can get those high notes to sparkle after all).
-
+
(if (not (number? pfreq))
(set! pfreq frequency))
(let ((partials (normalize-partials (get-piano-partials pfreq)))
@@ -1844,9 +1847,10 @@ is a physical model of a flute:
(frqf (and (not with-noise)
(make-env freqcosfun :duration dur
:scaler (hz->radians (- cosfreq1 cosfreq0)))))
- (ampf (if with-noise
- (make-env noifun :scaler noiamp :duration dur)
- (make-env ampcosfun :scaler cosamp :duration dur)))
+ (ampf (make-env (if with-noise
+ (values noifun :scaler noiamp)
+ (values ampcosfun :scaler cosamp))
+ :duration dur))
(rn (and with-noise
(make-rand :frequency ranfreq)))
(cn (and (not with-noise)
@@ -1962,7 +1966,7 @@ is a physical model of a flute:
;; (lowest-magnitude .001)
(ihifreq (hz->radians ifreq))
- (fftscale (/ 1.0 (* fftsize-1 .42323))) ;integrate Blackman-Harris window = .42323*window width and shift by fftsize-1
+ (fftscale (/ 1.0 fftsize-1 .42323)) ;integrate Blackman-Harris window = .42323*window width and shift by fftsize-1
(fft-mag (/ *clm-srate* fftsize-1))
(furthest-away-accepted .1)
(filptr 0)
@@ -1975,150 +1979,150 @@ is a physical model of a flute:
(set! filend (mus-length fil))
(float-vector-scale! window fftscale)
- (if splice-attack
- (let ((cur-end (+ start attack-size)))
- ;; my experience in translating SMS, and rumor via Greg Sandell leads me to believe that
- ;; there is in fact no way to model some attacks successfully in this manner, so this block
- ;; simply splices the original attack on to the rest of the note. "attack" is the number
- ;; of samples to include bodily.
- (do ((i start (+ i 1)))
- ((= i cur-end))
- (outa i (* amp (readin fil))))
- (set! filptr attack_size)
- (let ((mult (make-env '(0 1.0 1.0 0.0) :length attack-size)))
- (do ((k 0 (+ k 1)))
- ((= k attack-size))
- (float-vector-set! ramped-attack k (* (env mult) (readin fil)))))
- (set! start cur-end)))
+ (when splice-attack
+ (let ((cur-end (+ start attack-size)))
+ ;; my experience in translating SMS, and rumor via Greg Sandell leads me to believe that
+ ;; there is in fact no way to model some attacks successfully in this manner, so this block
+ ;; simply splices the original attack on to the rest of the note. "attack" is the number
+ ;; of samples to include bodily.
+ (do ((i start (+ i 1)))
+ ((= i cur-end))
+ (outa i (* amp (readin fil))))
+ (set! filptr attack_size)
+ (let ((mult (make-env '(0 1.0 1.0 0.0) :length attack-size)))
+ (do ((k 0 (+ k 1)))
+ ((= k attack-size))
+ (float-vector-set! ramped-attack k (* (env mult) (readin fil)))))
+ (set! start cur-end)))
- (if (< start end)
- (do ((i start (+ i outhop)))
- ((>= i end))
- (if (<= filptr filend)
- (let ((peaks 0))
- ;; get next block of data and apply window to it
- (set! (mus-location fil) filptr)
- (do ((k 0 (+ k 1)))
- ((= k fftsize-1))
- (float-vector-set! fdr k (readin fil)))
- (float-vector-multiply! fdr window)
- (set! filptr (+ filptr hop))
- (fill! fdi 0.0)
- ;; get the fft
- (mus-fft fdr fdi fftsize-1 1)
- ;; change to polar coordinates (ignoring phases)
- (rectangular->magnitudes fdr fdi)
- (float-vector-scale! fdr 2.0)
-
- (float-vector-subseq current-peak-freqs 0 max-oscils last-peak-freqs)
- (float-vector-subseq current-peak-amps 0 max-oscils last-peak-amps)
- (fill! current-peak-amps 0.0)
- (fill! peak-amps 0.0)
-
- (let ((ra (fdr 0))
- (la 0.0)
- (ca 0.0))
- ;; search for current peaks following Xavier Serra's recommendations in
- ;; "A System for Sound Analysis/Transformation/Synthesis
- ;; Based on a Deterministic Plus Stochastic Decomposition"
- (do ((k 0 (+ k 1)))
- ((= k highest-bin-1))
- (set! la ca)
- (set! ca ra)
- (set! ra (fdr k))
- (if (and (> ca .001) ; lowest-magnitude
- (> ca ra)
- (> ca la)
- (not (zero? ra))
- (not (zero? la)))
- ;; found a local maximum above the current threshold (its bin number is k-1)
- (let ((logla (log la 10.0))
- (logca (log ca 10.0))
- (logra (log ra 10.0)))
- (let* ((offset (/ (* .5 (- logla logra)) (+ logla (* -2 logca) logra))) ; isn't logca always 0?
- (amp (expt 10.0 (- logca (* .25 (- logla logra) offset))))
- (freq (* fft-mag (+ k offset -1))))
- ;; (if (not (real? amp)) (format *stderr* "~A ~A ~A -> ~A ~A~%" la ca ra offset amp))
- (if (= peaks max-peaks-1)
- ;; gotta either flush this peak, or find current lowest and flush him
- (let ((minp 0)
- (minpeak (peak-amps 0)))
- (do ((j 1 (+ j 1)))
- ((= j max-peaks-1))
- (if (< (peak-amps j) minpeak)
- (begin
- (set! minp j)
- (set! minpeak (peak-amps j)))))
- (if (> amp minpeak)
- (begin
- (set! (peak-freqs minp) freq)
- (set! (peak-amps minp) amp))))
- (begin
- (set! (peak-freqs peaks) freq)
- (set! (peak-amps peaks) amp)
- (set! peaks (+ peaks 1)))))))))
- ;; now we have the current peaks -- match them to the previous set and do something interesting with the result
- ;; the end results are reflected in the updated values in the rates and sweeps arrays.
- ;; search for fits between last and current, set rates/sweeps for those found
- ;; try to go by largest amp first
- (do ((k 0 (+ k 1)))
- ((= k peaks))
- (let ((pl (float-vector-peak-and-location peak-amps)))
- (let ((maxpk (car pl))
- (maxp (cadr pl)))
- ;; now maxp points to next largest unmatched peak
- (if (> maxpk 0.0)
- (let ((closestp -1)
- (closestamp 10.0)
- (current-freq (peak-freqs maxp)))
- (let ((icf (/ 1.0 current-freq)))
- (do ((j 0 (+ j 1)))
- ((= j max-peaks-1))
- (if (> (last-peak-amps j) 0.0)
- (let ((closeness (* icf (abs (- (last-peak-freqs j) current-freq)))))
- (if (< closeness closestamp)
- (begin
- (set! closestamp closeness)
- (set! closestp j))))))
- (if (< closestamp furthest-away-accepted)
+ (when (< start end)
+ (do ((i start (+ i outhop)))
+ ((>= i end))
+ (when (<= filptr filend)
+ (let ((peaks 0))
+ ;; get next block of data and apply window to it
+ (set! (mus-location fil) filptr)
+ (do ((k 0 (+ k 1)))
+ ((= k fftsize-1))
+ (float-vector-set! fdr k (readin fil)))
+ (float-vector-multiply! fdr window)
+ (set! filptr (+ filptr hop))
+ (fill! fdi 0.0)
+ ;; get the fft
+ (mus-fft fdr fdi fftsize-1 1)
+ ;; change to polar coordinates (ignoring phases)
+ (rectangular->magnitudes fdr fdi)
+ (float-vector-scale! fdr 2.0)
+
+ (float-vector-subseq current-peak-freqs 0 max-oscils last-peak-freqs)
+ (float-vector-subseq current-peak-amps 0 max-oscils last-peak-amps)
+ (fill! current-peak-amps 0.0)
+ (fill! peak-amps 0.0)
+
+ (let ((ra (fdr 0))
+ (la 0.0)
+ (ca 0.0))
+ ;; search for current peaks following Xavier Serra's recommendations in
+ ;; "A System for Sound Analysis/Transformation/Synthesis
+ ;; Based on a Deterministic Plus Stochastic Decomposition"
+ (do ((k 0 (+ k 1)))
+ ((= k highest-bin-1))
+ (set! la ca)
+ (set! ca ra)
+ (set! ra (fdr k))
+ (when (and (> ca .001) ; lowest-magnitude
+ (> ca ra)
+ (> ca la)
+ (not (zero? ra))
+ (not (zero? la)))
+ ;; found a local maximum above the current threshold (its bin number is k-1)
+ (let ((logla (log la 10.0))
+ (logca (log ca 10.0))
+ (logra (log ra 10.0)))
+ (let* ((offset (/ (* .5 (- logla logra)) (+ logla (* -2 logca) logra))) ; isn't logca always 0?
+ (amp (expt 10.0 (- logca (* .25 (- logla logra) offset))))
+ (freq (* fft-mag (+ k offset -1))))
+ ;; (if (not (real? amp)) (format *stderr* "~A ~A ~A -> ~A ~A~%" la ca ra offset amp))
+ (if (= peaks max-peaks-1)
+ ;; gotta either flush this peak, or find current lowest and flush him
+ (let ((minp 0)
+ (minpeak (peak-amps 0)))
+ (do ((j 1 (+ j 1)))
+ ((= j max-peaks-1))
+ (if (< (peak-amps j) minpeak)
(begin
- ;; peak-amp is transferred to appropriate current-amp and zeroed,
- (set! (current-peak-amps closestp) (peak-amps maxp))
- (set! (peak-amps maxp) 0.0)
- (set! (current-peak-freqs closestp) current-freq)))))))))
- (do ((k 0 (+ k 1)))
- ((= k max-peaks-1))
- (if (> (peak-amps k) 0.0)
- ;; find a place for a new oscil and start it up
- (let ((new-place -1))
- (do ((j 0 (+ j 1)))
- ((or (not (= new-place -1))
- (= j max-oscils)))
- (if (= (last-peak-amps j) 0.0 (current-peak-amps j))
- (set! new-place j)))
- (set! (current-peak-amps new-place) (peak-amps k))
- (set! (peak-amps k) 0.0)
- (set! (current-peak-freqs new-place) (peak-freqs k))
- (set! (last-peak-freqs new-place) (peak-freqs k))
- (set! (freqs new-place) (hz->radians (* transposition (peak-freqs k)))))))
- (set! cur-oscils 0)
- (do ((k 0 (+ k 1)))
- ((= k max-oscils))
- (set! (rates k) (* amp ifreq (- (current-peak-amps k) (last-peak-amps k))))
- (if (or (not (= (current-peak-amps k) 0.0))
- (not (= (last-peak-amps k) 0.0)))
- (set! cur-oscils k))
- (set! (sweeps k) (* ihifreq transposition (- (current-peak-freqs k) (last-peak-freqs k)))))
- (set! cur-oscils (+ cur-oscils 1))
- (set! (mus-length obank) cur-oscils)
-
- (let ((stop (min end (+ i outhop))))
- (do ((k i (+ k 1)))
- ((= k stop))
- ;; run oscils, update envelopes
- (outa k (oscil-bank obank))
- (float-vector-add! amps rates)
- (float-vector-add! freqs sweeps))))))))))))
+ (set! minp j)
+ (set! minpeak (peak-amps j)))))
+ (if (> amp minpeak)
+ (begin
+ (set! (peak-freqs minp) freq)
+ (set! (peak-amps minp) amp))))
+ (begin
+ (set! (peak-freqs peaks) freq)
+ (set! (peak-amps peaks) amp)
+ (set! peaks (+ peaks 1)))))))))
+ ;; now we have the current peaks -- match them to the previous set and do something interesting with the result
+ ;; the end results are reflected in the updated values in the rates and sweeps arrays.
+ ;; search for fits between last and current, set rates/sweeps for those found
+ ;; try to go by largest amp first
+ (do ((k 0 (+ k 1)))
+ ((= k peaks))
+ (let ((pl (float-vector-peak-and-location peak-amps)))
+ (let ((maxpk (car pl))
+ (maxp (cadr pl)))
+ ;; now maxp points to next largest unmatched peak
+ (if (> maxpk 0.0)
+ (let ((closestp -1)
+ (closestamp 10.0)
+ (current-freq (peak-freqs maxp)))
+ (let ((icf (/ 1.0 current-freq)))
+ (do ((j 0 (+ j 1)))
+ ((= j max-peaks-1))
+ (if (> (last-peak-amps j) 0.0)
+ (let ((closeness (* icf (abs (- (last-peak-freqs j) current-freq)))))
+ (if (< closeness closestamp)
+ (begin
+ (set! closestamp closeness)
+ (set! closestp j))))))
+ (if (< closestamp furthest-away-accepted)
+ (begin
+ ;; peak-amp is transferred to appropriate current-amp and zeroed,
+ (set! (current-peak-amps closestp) (peak-amps maxp))
+ (set! (peak-amps maxp) 0.0)
+ (set! (current-peak-freqs closestp) current-freq)))))))))
+ (do ((k 0 (+ k 1)))
+ ((= k max-peaks-1))
+ (if (> (peak-amps k) 0.0)
+ ;; find a place for a new oscil and start it up
+ (let ((new-place -1))
+ (do ((j 0 (+ j 1)))
+ ((or (not (= new-place -1))
+ (= j max-oscils)))
+ (if (= (last-peak-amps j) 0.0 (current-peak-amps j))
+ (set! new-place j)))
+ (set! (current-peak-amps new-place) (peak-amps k))
+ (set! (peak-amps k) 0.0)
+ (set! (current-peak-freqs new-place) (peak-freqs k))
+ (set! (last-peak-freqs new-place) (peak-freqs k))
+ (set! (freqs new-place) (hz->radians (* transposition (peak-freqs k)))))))
+ (set! cur-oscils 0)
+ (do ((k 0 (+ k 1)))
+ ((= k max-oscils))
+ (set! (rates k) (* amp ifreq (- (current-peak-amps k) (last-peak-amps k))))
+ (if (not (and (= (current-peak-amps k) 0.0)
+ (= (last-peak-amps k) 0.0)))
+ (set! cur-oscils k))
+ (set! (sweeps k) (* ihifreq transposition (- (current-peak-freqs k) (last-peak-freqs k)))))
+ (set! cur-oscils (+ cur-oscils 1))
+ (set! (mus-length obank) cur-oscils)
+
+ (let ((stop (min end (+ i outhop))))
+ (do ((k i (+ k 1)))
+ ((= k stop))
+ ;; run oscils, update envelopes
+ (outa k (oscil-bank obank))
+ (float-vector-add! amps rates)
+ (float-vector-add! freqs sweeps))))))))))))
;; (with-sound (:statistics #t) (pins 0 2 "oboe.snd" 1.0 :max-peaks 8))
@@ -2267,24 +2271,25 @@ is a physical model of a flute:
;; now we set the granulate generator internal state to reflect all these envelopes
(set! vol (env ampe))
(set! (mus-length exA) (round sl))
- (set! (mus-ramp exA) (floor (* sl (env rampenv)))) ;current ramp length (0 to .5)
- (set! (mus-frequency exA) (env hopenv)) ;current hop size
- (set! (mus-increment exA) (env expenv)) ;current expansion amount
- (set! next-samp (+ next-samp (env srenv))) ;current resampling increment
- (if (> next-samp (+ 1 ex-samp))
- (let ((samps (floor (- next-samp ex-samp))))
- (if (> samps 2)
- (do ((k 0 (+ k 1)))
- ((= k (- samps 2)))
- (granulate exA)))
- (if (>= samps 2)
- (set! valA0 (* vol (granulate exA)))
- (set! valA0 valA1))
- (set! valA1 (* vol (granulate exA)))
- (set! ex-samp (+ ex-samp samps))))
- (if (= next-samp ex-samp)
- (outa i valA0)
- (outa i (+ valA0 (* (- next-samp ex-samp) (- valA1 valA0)))))))))))))
+ (set! (mus-ramp exA) (floor (* sl (env rampenv))))) ;current ramp length (0 to .5)
+ (set! (mus-frequency exA) (env hopenv)) ;current hop size
+ (set! (mus-increment exA) (env expenv)) ;current expansion amount
+ (set! next-samp (+ next-samp (env srenv))) ;current resampling increment
+ (if (> next-samp (+ 1 ex-samp))
+ (let ((samps (floor (- next-samp ex-samp))))
+ (if (> samps 2)
+ (do ((k 0 (+ k 1)))
+ ((= k (- samps 2)))
+ (granulate exA)))
+ (set! valA0 (if (>= samps 2)
+ (* vol (granulate exA))
+ (set! valA0 valA1)))
+ (set! valA1 (* vol (granulate exA)))
+ (set! ex-samp (+ ex-samp samps))))
+
+ (outa i (if (= next-samp ex-samp)
+ valA0
+ (+ valA0 (* (- next-samp ex-samp) (- valA1 valA0))))))))))))
;;; (with-sound (:statistics #t) (exp-snd "fyow.snd" 0 3 1 '(0 1 1 3) 0.4 .15 '(0 2 1 .5) 0.05))
;;; (with-sound () (exp-snd "oboe.snd" 0 3 1 '(0 1 1 3) 0.4 .15 '(0 2 1 .5) 0.2))
@@ -2317,80 +2322,78 @@ is a physical model of a flute:
(do ((i beg (+ i 1)))
((= i end))
(let ((val 0.0))
- (if (= i out1)
- (begin
- (set! val (with-let grn1
- (let ((inval (ina loc file)))
- (set! loc (+ loc 1))
- (if (= whichseg 0) ;ramp-up
+ (when (= i out1)
+ (set! val (with-let grn1
+ (let ((inval (ina loc file)))
+ (set! loc (+ loc 1))
+ (if (= whichseg 0) ;ramp-up
+ (begin
+ (set! inval (* inval rampval))
+ (set! rampval (+ rampval rampinc))
+ (set! segctr (+ segctr 1))
+ (if (= segctr ramplen)
+ (begin
+ (set! segctr 0)
+ (set! whichseg (+ whichseg 1)))))
+ (if (= whichseg 1) ;steady-state
(begin
+ (set! segctr (+ segctr 1))
+ (if (= segctr steadylen)
+ (begin
+ (set! segctr 0)
+ (set! whichseg (+ whichseg 1)))))
+ (begin ;ramp-down
(set! inval (* inval rampval))
- (set! rampval (+ rampval rampinc))
(set! segctr (+ segctr 1))
+ (set! rampval (- rampval rampinc))
(if (= segctr ramplen)
(begin
(set! segctr 0)
- (set! whichseg (+ whichseg 1)))))
- (if (= whichseg 1) ;steady-state
- (begin
- (set! segctr (+ segctr 1))
- (if (= segctr steadylen)
- (begin
- (set! segctr 0)
- (set! whichseg (+ whichseg 1)))))
- (begin ;ramp-down
- (set! inval (* inval rampval))
- (set! segctr (+ segctr 1))
- (set! rampval (- rampval rampinc))
- (if (= segctr ramplen)
- (begin
- (set! segctr 0)
- (set! trigger 1)
- (set! whichseg 0)
- (set! rampval 0.0))))))
- inval)))
- (set! out1 (+ out1 1))
- (if (= (grn1 'trigger) 1)
- (begin
- (set! (grn1 'trigger) 0)
- (set! out1 (+ out1 hop))))))
- (if (= i out2)
- (begin
- (set! val (+ val (with-let grn2
- (let ((inval (ina loc file)))
- (set! loc (+ loc 1))
- (if (= whichseg 0) ;ramp-up
+ (set! trigger 1)
+ (set! whichseg 0)
+ (set! rampval 0.0))))))
+ inval)))
+ (set! out1 (+ out1 1))
+ (if (= (grn1 'trigger) 1)
+ (begin
+ (set! (grn1 'trigger) 0)
+ (set! out1 (+ out1 hop)))))
+ (when (= i out2)
+ (set! val (+ val (with-let grn2
+ (let ((inval (ina loc file)))
+ (set! loc (+ loc 1))
+ (if (= whichseg 0) ;ramp-up
+ (begin
+ (set! inval (* inval rampval))
+ (set! rampval (+ rampval rampinc))
+ (set! segctr (+ segctr 1))
+ (if (= segctr ramplen)
+ (begin
+ (set! segctr 0)
+ (set! whichseg (+ whichseg 1)))))
+ (if (= whichseg 1) ;steady-state
(begin
+ (set! segctr (+ segctr 1))
+ (if (= segctr steadylen)
+ (begin
+ (set! segctr 0)
+ (set! whichseg (+ whichseg 1)))))
+ (begin ;ramp-down
(set! inval (* inval rampval))
- (set! rampval (+ rampval rampinc))
(set! segctr (+ segctr 1))
+ (set! rampval (- rampval rampinc))
(if (= segctr ramplen)
(begin
(set! segctr 0)
- (set! whichseg (+ whichseg 1)))))
- (if (= whichseg 1) ;steady-state
- (begin
- (set! segctr (+ segctr 1))
- (if (= segctr steadylen)
- (begin
- (set! segctr 0)
- (set! whichseg (+ whichseg 1)))))
- (begin ;ramp-down
- (set! inval (* inval rampval))
- (set! segctr (+ segctr 1))
- (set! rampval (- rampval rampinc))
- (if (= segctr ramplen)
- (begin
- (set! segctr 0)
- (set! trigger 1)
- (set! whichseg 0)
- (set! rampval 0.0))))))
- inval))))
- (set! out2 (+ out2 1))
- (if (= (grn2 'trigger) 1)
- (begin
- (set! (grn2 'trigger) 0)
- (set! out2 (+ out2 hop))))))
+ (set! trigger 1)
+ (set! whichseg 0)
+ (set! rampval 0.0))))))
+ inval))))
+ (set! out2 (+ out2 1))
+ (if (= (grn2 'trigger) 1)
+ (begin
+ (set! (grn2 'trigger) 0)
+ (set! out2 (+ out2 hop)))))
(outa i val))))))
;;; (with-sound () (expfil 0 2 .2 .01 .1 "oboe.snd" "fyow.snd"))
@@ -2459,7 +2462,8 @@ nil doesnt print anything, which will speed up a bit the process.
(make-vector (length freq-list))))
(if-list-in-gain (pair? (car gain-list)))
(frm-size (make-vector (length freq-list)))
- (gains (make-float-vector (length freq-list) 1.0)))
+ (gains (make-float-vector (length freq-list) 1.0))
+ (filt-scl (* filt-gain-scale (- 1.0 a1))))
(do ((k 0 (+ k 1)))
((= k half-list))
@@ -2468,14 +2472,12 @@ nil doesnt print anything, which will speed up a bit the process.
(if (pair? gval)
(begin
(set! (env-size k) (make-env gval
- :scaler (* filt-gain-scale (- 1.0 a1))
+ :scaler filt-scl
:duration durata :base filt-gain-base))
(set! (frm-size k) (make-formant fval a1)))
(begin
(set! (frm-size k) (make-formant fval a1))
- (set! (gains k) (if (< (+ offset-gain gval) 0)
- 0
- (+ offset-gain gval)))))))
+ (set! (gains k) (max 0 (+ offset-gain gval)))))))
(set! frm-size (make-formant-bank frm-size gains))
(if if-list-in-gain
@@ -2508,15 +2510,14 @@ nil doesnt print anything, which will speed up a bit the process.
(beg (seconds->samples start))
(end (seconds->samples (+ start dur)))
(file (make-file->sample infile))
- (radius (- 1.0 (/ r fftsize)))
- (bin (/ *clm-srate* fftsize))
(fs (make-vector freq-inc))
(samp 0)
(fdrc 0.0))
-
- (do ((ctr 0 (+ ctr 1)))
- ((= ctr freq-inc))
- (set! (fs ctr) (make-formant (* ctr bin) radius)))
+ (let ((bin (/ *clm-srate* fftsize))
+ (radius (- 1.0 (/ r fftsize))))
+ (do ((ctr 0 (+ ctr 1)))
+ ((= ctr freq-inc))
+ (set! (fs ctr) (make-formant (* ctr bin) radius))))
(set! fs (make-formant-bank fs scales))
(set! (scales 0) 0.0)
@@ -2535,12 +2536,11 @@ nil doesnt print anything, which will speed up a bit the process.
((= ctr freq-inc))
(set! fdrc (fdr ctr))
(set! (spectr ctr) (+ (* .9 (spectr ctr)) (* .1 fdrc)))
- (if (>= (spectr ctr) fdrc)
- (set! (diffs ctr) (/ (scales ctr) (- fftsize)))
- (set! (diffs ctr)
- (/ (- (/ (- fdrc (spectr ctr)) fdrc)
- (scales ctr))
- fftsize))))))
+ (set! (diffs ctr) (if (>= (spectr ctr) fdrc)
+ (/ (scales ctr) (- fftsize))
+ (/ (- (/ (- fdrc (spectr ctr)) fdrc)
+ (scales ctr))
+ fftsize))))))
(outa i (* amp (formant-bank fs inval)))
(float-vector-add! scales diffs))))))
@@ -2654,9 +2654,8 @@ mjkoskin at sci.fi
(let ((documentation "(make-rmsgain (hp 10.0)) makes an RMS gain generator"))
(lambda* ((hp 10.0))
(let* ((b (- 2.0 (cos (* hp (/ (* 2.0 pi) *clm-srate*)))))
- (c2 (- b (sqrt (- (* b b) 1.0))))
- (c1 (- 1.0 c2)))
- (make-rmsg :c1 c1 :c2 c2)))))
+ (c2 (- b (sqrt (- (* b b) 1.0)))))
+ (make-rmsg :c1 (- 1.0 c2) :c2 c2)))))
(define rms
(let ((documentation "(rms gen sig) runs an RMS gain generator"))
diff --git a/clm.c b/clm.c
index 3baf6cc..350e6e6 100644
--- a/clm.c
+++ b/clm.c
@@ -10711,14 +10711,13 @@ mus_any *mus_make_readin_with_buffer_size(const char *filename, int chan, mus_lo
gen = (rdin *)mus_make_file_to_sample(filename);
if (gen)
{
- mus_float_t **saved_data = NULL;
gen->core = &READIN_CLASS;
gen->loc = start;
gen->dir = direction;
gen->chan = chan;
/* the saved data option does not save us anything in file_to_sample above */
gen->saved_data = mus_sound_saved_data(filename);
- if (!saved_data)
+ if (!gen->saved_data)
{
char *str;
str = mus_expand_filename(filename);
@@ -15780,7 +15779,6 @@ mus_float_t mus_phase_vocoder_with_editors(mus_any *ptr,
if (pv_analyze == NULL) pv_analyze = pv->analyze;
if (pv_edit == NULL) pv_edit = pv->edit;
if (input) {pv->input = input; pv->block_input = NULL;}
-
pv->outctr = 0;
if ((pv_analyze == NULL) ||
diff --git a/clm.rb b/clm.rb
index 3d78d94..f745e99 100644
--- a/clm.rb
+++ b/clm.rb
@@ -2,7 +2,7 @@
# Author: Michael Scholz <mi-scholz at users.sourceforge.net>
# Created: 09/10/14 23:02:57
-# Changed: 14/11/30 18:00:42
+# Changed: 16/01/05 22:49:21
# Ruby extensions:
#
@@ -1615,11 +1615,11 @@ end
class Numeric
def positive?
self > 0
- end
+ end unless defined? 1.positive?
def negative?
self < 0
- end
+ end unless defined? 1.negative?
# According to Ruby's ChangeLog-2.0.0:
# Wed Nov 21 21:53:29 2012 Tadayoshi Funaba <tadf at dotrb.org>
diff --git a/clm23.scm b/clm23.scm
index 47ab88b..a225004 100644
--- a/clm23.scm
+++ b/clm23.scm
@@ -1,4 +1,4 @@
-;;; these are CLM test instruments
+;;; these are (ancient!) CLM test instruments
(provide 'snd-clm23.scm)
(if (provided? 'snd)
@@ -78,11 +78,10 @@
(if (> revb 0.0) (outb i (* revb val) *reverb*))))))
(define (simple-ssb beg dur freq amp)
- (let ((os (make-ssb-am freq))
- (start (seconds->samples beg))
+ (let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(arr (make-vector 3)))
- (set! (arr 0) os)
+ (set! (arr 0) (make-ssb-am freq))
(set! (arr 1) #f)
(set! (arr 2) (make-ssb-am 660 40))
(do ((k 0 (+ k 1)))
@@ -246,7 +245,7 @@
;(define w1 (make-polyshape :frequency 100.0
; :partials (let ((frqs ()))
; (do ((i 1 (+ i 1)))
- ; ((= i 10) (begin (format #t frqs) (reverse frqs)))
+ ; ((= i 10) (begin (format () frqs) (reverse frqs)))
; (set! frqs (cons (/ 1.0 (* i i)) (cons i frqs)))))))
(define (simple-poly beg dur freq amp)
@@ -504,12 +503,7 @@
((= i end))
(outa i (* amp (src sr)))))))
-(define (simple-sr2a beg dur amp speed file)
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (sr (make-src :input (make-readin file) :srate speed)))
- (do ((i start (+ i 1))) ((= i end))
- (outa i (* amp (src sr))))))
+(define simple-sr2a simple-src)
(define (simple-sro beg dur amp speed freq)
(let ((os (make-oscil freq)))
@@ -567,12 +561,7 @@
((= i end))
(outa i (* amp (file->sample fil ctr))))))
-(define (simple-rdf beg dur amp file)
- (let ((rd (make-readin file))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (do ((i start (+ i 1))) ((= i end))
- (outa i (* amp (readin rd))))))
+(define simple-rdf simple-rd)
(define (simple-loc beg dur freq amp)
(let ((os (make-oscil freq))
@@ -622,8 +611,8 @@
(do ((i start (+ i 1))) ((= i end))
(let ((amp .3)
(j 4))
- (if (not (= j 4)) (format #t "local j is ~D\n" j))
- (if (> (abs (- amp .3)) .001) (format #t "local amp is ~F\n" amp)))
+ (if (not (= j 4)) (format () "local j is ~D\n" j))
+ (if (> (abs (- amp .3)) .001) (format () "local amp is ~F\n" amp)))
(if (= j 2)
(outa i (* amp (oscil os)))))))
@@ -635,11 +624,11 @@
(start (seconds->samples beg))
(end (seconds->samples (+ beg dur))))
(do ((i start (+ i 1))) ((= i end))
- (if (not (= j 2199023256786)) (format #t "local j is ~A" j))
- (if (not (= jj -1099511632097)) (format #t "local jj is ~A" jj))
+ (if (not (= j 2199023256786)) (format () "local j is ~A" j))
+ (if (not (= jj -1099511632097)) (format () "local jj is ~A" jj))
(if (= mj -3)
(outa i (* amp (oscil os)))
- (format #t "minus 3: ~D" mj)))))
+ (format () "minus 3: ~D" mj)))))
(define (sample-desc beg dur freq amp)
(let ((os (make-oscil freq))
@@ -650,9 +639,9 @@
(if (not printed)
(begin
(if (not (string=? (mus-describe os) "oscil freq: 440.000Hz, phase: 0.000"))
- (format #t "describe oscil: ~A~%" (mus-describe os)))
+ (format () "describe oscil: ~A~%" (mus-describe os)))
(if (> (abs (- (mus-frequency os) freq)) .001)
- (format #t "osc freq: ~A (~A)~%" (mus-frequency os) freq))
+ (format () "osc freq: ~A (~A)~%" (mus-frequency os) freq))
(set! printed #t)))
(outa i (* amp (oscil os))))))
@@ -719,10 +708,10 @@
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(os (make-oscil freq)))
- (let ((sr2 (make-src :srate speed :input (lambda (dir) (oscil os)))))
- (let ((sr1 (make-src :srate speed :input (lambda (dir) (src sr2)))))
- (do ((i start (+ i 1))) ((= i end))
- (outa i (* amp (src sr1))))))))
+ (let* ((sr2 (make-src :srate speed :input (lambda (dir) (oscil os))))
+ (sr1 (make-src :srate speed :input (lambda (dir) (src sr2)))))
+ (do ((i start (+ i 1))) ((= i end))
+ (outa i (* amp (src sr1)))))))
(define (sample-srl3 beg dur amp speed freq)
(let ((start (seconds->samples beg))
@@ -787,7 +776,7 @@
:fft-size size
:edit (lambda (pv)
(if (not (= (mus-location pv) 0))
- (format #t "outctr: ~A" (mus-location pv)))
+ (format () "outctr: ~A" (mus-location pv)))
#t))))
(do ((i start (+ i 1))) ((= i end))
(outa i (* amp (phase-vocoder sr))))))
@@ -831,7 +820,7 @@
(begin
(set! (mus-frequency g) frq)
(if (> (abs (- (mus-frequency g) frq)) .001)
- (format #t "oops ~A ~A" (mus-frequency g) frq))
+ (format () "oops ~A ~A" (mus-frequency g) frq))
(do ((k start (+ k 1)))
((= k end))
(outa k (* amp (oscil g))))))))))
@@ -851,10 +840,10 @@
(do ((i 0 (+ i 1)))
((= i (length phases)))
(set! (phases i) (+ (phases i) (freqs i))))
- (if (not (= (ints 0) 32)) (format #t "int array trouble"))
+ (if (not (= (ints 0) 32)) (format () "int array trouble"))
(set! (ints 1) 3)
- (if (not (= (ints 1) 3)) (format #t "set int array trouble"))
- (if (not (= (length amps) 3)) (format #t "amps len: ~A" (length amps)))
+ (if (not (= (ints 1) 3)) (format () "set int array trouble"))
+ (if (not (= (length amps) 3)) (format () "amps len: ~A" (length amps)))
(outa i (clm23-sine-bank amps phases 3)))))
(define (sample-flt beg dur freq amp)
@@ -872,13 +861,13 @@
(let ((xs (mus-xcoeffs flt)))
(if (or (> (abs (- (xs 1) (mus-xcoeff flt 1))) .001)
(> (abs (- (xs 1) 0.0625)) .001))
- (format #t "~A ~A~%" (xs 1) (mus-xcoeff flt 1))))
+ (format () "~A ~A~%" (xs 1) (mus-xcoeff flt 1))))
(let ((data (mus-data flt)))
- (if (> (data 0) 1.0) (format #t "data overflow? ~A~%" (data 0))))
+ (if (> (data 0) 1.0) (format () "data overflow? ~A~%" (data 0))))
(let ((is intdat)
(fs fltdat))
- (if (not (= (is 1) 3)) (format #t "intdat let: ~A~%" (is 1)))
- (if (> (abs (- (fs 1) 3.14)) .001) (format #t "fltdat let: ~A~%" (fs 1))))
+ (if (not (= (is 1) 3)) (format () "intdat let: ~A~%" (is 1)))
+ (if (> (abs (- (fs 1) 3.14)) .001) (format () "fltdat let: ~A~%" (fs 1))))
(outa i (* amp (filter flt (oscil os)))))))
(define (sample-arrintp beg dur freq amp)
@@ -897,73 +886,6 @@
((= i end))
(outa i (* amp (array-interp arr loc) (oscil os)))))))
-(define (sample-if beg dur freq amp)
- (let ((os (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (k -123)
- (j 0)
- (bool #t))
- (do ((i start (+ i 1))) ((= i end))
- (if (and (= i start) (not (= k -123))) (format #t "init k: ~A~%" k))
- (if (not bool) (format #t "bool: ~A~%" bool))
- (set! j (if bool 1 2))
- (if (not (= j 1)) (format #t "if expr: ~A~%" j))
- (if bool (set! j 3) (set! j 4))
- (if (not (= j 3)) (format #t "if statement: ~A~%" j))
- (if (integer? k) (set! j 5))
- (if (not (= j 5)) (format #t "int k? ~A ~A~%" (integer? k) j))
- (if (= j k) (set! j 6))
- (if (= j 6) (format #t "j if false: ~A~%" j))
- (set! j (if (= j k) (+ k 7) (+ k 8)))
- (if (not (= j (+ k 8))) (format #t "if false expr: ~A ~A~%" j k))
- (set! j (if (> j -1234) (if (> k -1234) 9 10) 11))
- (if (not (= j 9)) (format #t "if 2 expr: ~A~%" j))
- (set! j (if (> j -1234) (begin (set! k 0) 12) 13))
- (if (not (= j 12)) (format #t "if begin expr: ~A~%" j))
- (if (> j -1234) (begin (set! j 1234) (set! j 14)) (set! j 15))
- (if (not (= j 14)) (format #t "if begin: ~A~%" j))
- ; (if (> j -1234) (set! j (prog1 16 (set! k 0))))
- ; (if (not (= j 16)) (format #t "if prog1: ~A~%" j))
- ; (if (> j -1234) (set! j (prog2 (set! k 0) 17 (set! k 0))))
- ; (if (not (= j 17)) (format #t "if prog2: ~A~%" j))
- ; (set! k (loop for j from 1 to 4 sum j))
- ; (if (not (= k 10)) (format #t "loop sum: ~A~%" k))
- ; (if (> j -1234) (set! j (prog2 (set! k 0) (if (> j -1234) (begin (set! k 123) 18) 19) (set! k 0))))
- ; (if (not (= j 18)) (format #t "if nested prog2: ~A~%" j))
- (set! j 123)
- (cond ((= j 0) (set! k -1))
- ((= j 12) (set! k -2))
- ((= j 123) (set! k -3))
- (#t (set! k -4)))
- (if (not (= k -3)) (format #t "cond: ~A ~A~%" j k))
- (set! k (cond ((= j 0) -4)
- ((= j 12) -5)
- (#t -6)))
- (if (not (= k -6)) (format #t "cond expr: ~A ~A~%" j k))
- (set! k (let ((a 123))
- (if (> a 0)
- 20
- 32)))
- (if (not (= k 20)) (format #t "let expr: ~A ~A~%" j k))
- (let ((a 123))
- (set! k a))
- (if (not (= k 123)) (format #t "let: ~A ~A~%" j k))
- (set! k 123)
- (set! bool (= k 123))
- (if (not bool) (format #t "bool expr: ~A~%" bool))
- (set! bool (if (= k 123) (> k 0) (< k 0)))
- (if (not bool) (format #t "if bool expr: ~A~%" bool))
- (set! j 0)
- (set! k (do ((m 0 (+ 1 m)))
- ((= m 3) j)
- (set! j (+ j 1))))
- (if (not (= k 3)) (format #t "do expr: ~A~%" k))
- ; (dotimes (m 2)
- ; (set! k (- k 1)))
- ; (if (not (= k 1)) (format #t "dotimes: ~A~%" k))
- (outa i (* amp (oscil os))))))
-
(define (sample-arrfile beg dur freq amp)
(let ((os (make-oscil freq))
(start (seconds->samples beg))
@@ -973,7 +895,7 @@
(dir 1))
(do ((i 0 (+ i 1)))
((= i 100))
- (set! (arr i) (* amp (+ -.5 (* i .01)))))
+ (set! (arr i) (* amp (- (* i .01) 0.5))))
(array->file "testx.data" arr 100 22050 1)
(fill! arr 0.0)
(file->array "testx.data" 0 0 100 arr)
@@ -1001,23 +923,9 @@
(outa i (* amp (granulate sr))))))
;(with-sound () (simple-grn-f2 0 1 1 2 "oboe.snd"))
-
-(define (simple-grn-f3 beg dur amp speed file)
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (sr (make-granulate :input (make-readin file) :expansion speed)))
- (do ((i start (+ i 1))) ((= i end))
- (outa i (* amp (granulate sr))))))
-
+(define simple-grn-f3 simple-grn-f2)
;(with-sound () (simple-grn-f3 0 1 1 2 "oboe.snd"))
-
-(define (simple-grn-f4 beg dur amp speed file)
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (sr (make-granulate :input (make-readin file) :expansion speed)))
- (do ((i start (+ i 1))) ((= i end))
- (outa i (* amp (granulate sr))))))
-
+(define simple-grn-f4 simple-grn-f2)
;(with-sound () (simple-grn-f4 0 1 1 2 "oboe.snd"))
(define (simple-grn-f5 beg dur amp speed file)
@@ -1121,7 +1029,6 @@
(sample-ardcl 5.5 .2 440 .1)
(sample-flt 6 .2 440 .1)
(sample-arrintp 6.25 .2 440 .1)
- (sample-if 6.5 .2 440 .1)
(sample-arrfile 6.75 .2 440 .15)
(sample-pvoc5 7 .2 .1 256 "oboe.snd" 440.0)
)
@@ -1168,24 +1075,23 @@
((= k size))
(float-vector-set! paincrs buf (* (in-data k) (window k)))
(set! buf (+ buf 1))
- (if (>= buf size) (set! buf 0)))
- (set! filptr (+ filptr D))
- (mus-fft paincrs freqs size 1)
- (rectangular->polar paincrs freqs)
- #f))
+ (if (>= buf size) (set! buf 0))))
+ (set! filptr (+ filptr D))
+ (mus-fft paincrs freqs size 1)
+ (rectangular->polar paincrs freqs)
+ #f)
:edit (lambda (pv)
- (let ((pscl (/ 1.0 D))
- (kscl (/ two-pi size)))
- (do ((k 0 (+ k 1))
- (ks 0.0 (+ ks kscl)))
- ((= k N2))
- (let* ((freq (freqs k))
- (diff (- freq (lastphases k))))
- (set! (lastphases k) freq)
- (if (> diff pi) (set! diff (- diff two-pi)))
- (if (< diff (- pi)) (set! diff (+ diff two-pi)))
- (float-vector-set! freqs k (+ (* diff pscl) ks))))
- #f))
+ (do ((pscl (/ 1.0 D))
+ (kscl (/ two-pi size))
+ (k 0 (+ k 1))
+ (ks 0.0 (+ ks kscl)))
+ ((= k N2) #f)
+ (let* ((freq (freqs k))
+ (diff (- freq (lastphases k))))
+ (set! (lastphases k) freq)
+ (if (> diff pi) (set! diff (- diff two-pi)))
+ (if (< diff (- pi)) (set! diff (+ diff two-pi)))
+ (float-vector-set! freqs k (+ (* diff pscl) ks)))))
:synthesize (lambda (pv)
(float-vector-add! amps paincrs)
(float-vector-add! ppincrs freqs)
@@ -1202,122 +1108,6 @@
((= i end))
(outa i (* amp (phase-vocoder sr))))))))
-(define (or1)
- (let ((e1 (make-env '(0 0 1 1) :length 10))
- (e2 (make-env '(0 1 1 0) :length 10))
- (e3 #f)
- (ok1 0.0))
- (do ((i 0 (+ i 1)))
- ((= i 1))
- (set! ok1 0.0)
- (if (or e1 e2)
- (set! ok1 (+ ok1 (env e1)))
- (format #t ";or1 a~%"))
- (if (not (or e1 e2))
- (format #t ";or1 1~%"))
- (if (and e1 e2)
- (set! ok1 (+ ok1 (env e2)))
- (format #t ";or1 b~%"))
- (if (not (and e1 e2))
- (format #t ";or1 2~%"))
- (if (or e3 e1 e2)
- (mus-reset e2) ; resets e2 -> 1.0
- (format #t ";or1 c~%"))
- (if (and e1 e3 e2)
- (format #t ";or1 3~%"))
- (if (not e1)
- (format #t ";or1 4~%"))
- (if (< (abs ok1) .001)
- (format #t ";or1 ok1: ~A~%" ok1)))))
-
-(define (or2)
- (let ((e1 (make-env '(0 0 1 1) :length 10))
- (e2 (make-env '(0 1 1 0) :length 10))
- (e3 #f)
- (ok1 0.0)
- (oki 0)
- (okb #f))
- (do ((i 0 (+ i 1)))
- ((= i 1))
- (set! ok1 0.0)
- (set! oki (+ oki 1))
- (set! okb #t)
- (if (or e1 e2)
- (set! ok1 (+ ok1 (env e1)))
- (format #t ";or2 a~%"))
- (if (not (or e1 e2 okb))
- (format #t ";or2 1~%"))
- (if (and e1 e2)
- (set! ok1 (+ ok1 (env e2)))
- (format #t ";or2 b~%"))
- (if (not (and e1 e2))
- (format #t ";or2 2~%"))
- (if (or e3 e1 e2)
- (mus-reset e2) ; resets e2 -> 1.0
- (format #t ";or2 c~%"))
- (if (and e1 e3 e2)
- (format #t ";or2 3~%"))
- (if (not e1)
- (format #t ";or2 4~%"))
- (if (< (abs ok1) .001)
- (format #t ";or1 ok1: ~A~%" ok1)))))
-
-(define (or3)
- (let ((e1 (make-env '(0 0 1 1) :length 10))
- (i1 (make-vector 3 32))
- (f1 (make-float-vector 3 3.14))
- (i2 (make-vector 3 3))
- (f2 (make-vector 3 1.5))
- (ok1 0.0)
- (oki 0))
- (do ((i 0 (+ i 1)))
- ((= i 1))
- (cond (e1 (set! ok1 (+ ok1 (env e1))))
- (#t (format #t ";or3 1~%")))
- (if (or f1 f2)
- (set! ok1 (+ ok1 (f2 0)))
- (format #t ";or3 a~%"))
- (if (not (or f2 f1))
- (format #t ";or3 2~%"))
- (if (and f2 f1)
- (set! ok1 (+ ok1 (f1 1)))
- (format #t ";or3 b~%"))
- (if (or i1 i2)
- (set! oki (+ oki (i2 0)))
- (format #t ";or3 d~%"))
- (if (not (or i2 i1))
- (format #t ";or3 3~%"))
- (if (and i2 i1)
- (set! oki (+ oki (i1 1)))
- (format #t ";or3 e~%")))))
-
-(define (or4)
- (let ((e1 (make-env '(0 0 1 1) :length 10))
- (e2 (make-env '(0 1 1 0) :length 10))
- (i1 (make-vector 3 32))
- (f1 (make-float-vector 3 3.14))
- (i2 (make-vector 3 3))
- (f2 (make-vector 3 1.5))
- (oki 0))
- (do ((i 0 (+ i 1)))
- ((= i 1))
- (if (or (and e1 e2)
- (and f1 f2)
- (and i1 i2))
- (set! oki (+ oki 1))
- (format #t ";or4 a~%"))
- (if (and (or f1 f2)
- (not (or i1 i2))
- (or e1 e2))
- (format #t ";or4 1~%"))
- (if f1
- (if e1
- (if (not e2)
- (format #t ";or4 2~%")
- (set! oki (+ oki 1)))
- (format #t ";or4 3~%"))
- (format #t ";or4 4~%")))))
-
;;; --------------------------------------------------------------------------------
;;;
@@ -1461,9 +1251,9 @@
(outa i (* (env ampf)
(oscil carrier
(+ vib
- (+ (* (env indf1) (oscil fmosc1 vib))
- (* (env indf2) (oscil fmosc2 (* 3.0 vib)))
- (* (env indf3) (oscil fmosc3 (* 4.0 vib)))))))))))))))
+ (* (env indf1) (oscil fmosc1 vib))
+ (* (env indf2) (oscil fmosc2 (* 3.0 vib)))
+ (* (env indf3) (oscil fmosc3 (* 4.0 vib))))))))))))))
(define (fmdoc-cascade beg dur freq amp modrat modind casrat casind caspha)
(let ((start (seconds->samples beg))
@@ -1591,29 +1381,9 @@
((= i end))
(outa i (* amp (oscil os))))))
-(define (sndclmdoc-simp-1 beg dur freq amp)
- (let ((os (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (do ((i start (+ i 1)))
- ((= i end))
- (outa i (* amp (oscil os))))))
-
-(define (sndclmdoc-simp-2 beg dur freq amp)
- (let ((os (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (do ((i start (+ i 1)))
- ((= i end))
- (outa i (* amp (oscil os))))))
-
-(definstrument (sndclmdoc-simp-3 beg dur freq amp)
- (let ((os (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (do ((i start (+ i 1)))
- ((= i end))
- (outa i (* amp (oscil os))))))
+(define sndclmdoc-simp-1 simple-out)
+(define sndclmdoc-simp-2 simple-out)
+(define sndclmdoc-simp-3 simple-out)
(define (sndclmdoc-telephone start telephone-number)
(let ((touch-tab-1 '(0 697 697 697 770 770 770 852 852 852 941 941 941))
@@ -1688,7 +1458,7 @@
(let ((zval (env zv)))
(outa i
(* amp
- (sin (* pi2 zval (* zval zval)))
+ (sin (* pi2 zval zval zval))
(oscil osc)))))))
(definstrument (sndclmdoc-simple-table dur)
@@ -1762,10 +1532,13 @@
(polynomial cos-coeffs ax))))))))
(definstrument (sndclmdoc-bl-saw start dur frequency order)
- (let ((norm (if (= order 1) 1.0 ; these peak amps were determined empirically
- (if (= order 2) 1.3 ; actual limit is supposed to be pi/2 (G&R 1.441)
- (if (< order 9) 1.7 ; but Gibbs phenomenon pushes it to 1.851
- 1.9)))) ; if order>25, numerical troubles -- use table-lookup
+ (let ((norm (cond ((assoc order '((1 . 1.0) (2 . 1.3)) =) => cdr)
+ ((< order 9) 1.7)
+ (else 1.9)))
+ ;; these peak amps were determined empirically
+ ;; actual limit is supposed to be pi/2 (G&R 1.441)
+ ;; but Gibbs phenomenon pushes it to 1.851
+ ;; if order>25, numerical troubles -- use table-lookup
(freqs ()))
(do ((i 1 (+ i 1)))
((> i order))
@@ -1803,9 +1576,9 @@
(let ((top (* 0.5 range))
(val (if (= ang 0.0) 1.0 (/ (sin ang) ang)))
(new-ang (+ ang frq fm)))
- (if (> new-ang top)
- (set! (gen 0) (- new-ang range))
- (set! (gen 0) new-ang))
+ (set! (gen 0) (if (> new-ang top)
+ (- new-ang range)
+ new-ang))
val)))
(define (sndclmdoc-make-sum-of-odd-sines frequency n)
@@ -1989,13 +1762,7 @@
((= i stop))
(outa i (granulate exA)))))
-(definstrument (sndclmdoc-simple-pvoc beg dur amp size file)
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (sr (make-phase-vocoder (make-readin file) :fft-size size)))
- (do ((i start (+ i 1)))
- ((= i end))
- (outa i (* amp (phase-vocoder sr))))))
+(define sndclmdoc-simple-pvoc sample-pvoc1)
(definstrument (sndclmdoc-asy beg dur freq amp index (r 1.0) (ratio 1.0))
(let ((st (seconds->samples beg))
@@ -2005,14 +1772,7 @@
((= i nd))
(outa i (* amp (asymmetric-fm asyf index))))))
-(define (sndclmdoc-simple-f2s beg dur amp file)
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (fil (make-file->sample file)))
- (do ((i start (+ i 1))
- (ctr 0 (+ ctr 1)))
- ((= i end))
- (outa i (* amp (file->sample fil ctr))))))
+(define sndclmdoc-simple-f2s simple-f2s)
(definstrument (sndclmdoc-simple-ina beg dur amp file)
(let ((start (seconds->samples beg))
@@ -2070,24 +1830,7 @@
(if *reverb* (locsig-reverb-set! loc 0 (* reverb-amount (sqrt dist-scaler))))
(locsig loc i (* (env amp-env) (readin rdA)))))))
-(define (sndclmdoc-simple-dloc beg dur freq amp)
- (let ((os (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (let ((loc (make-move-sound (list start end 4 0
- (make-delay 12)
- (make-env '(0 0 10 1) :duration dur)
- #f
- (make-vector 4 #f)
- (vector (make-env '(0 0 1 1 2 0 3 0 4 0) :duration dur)
- (make-env '(0 0 1 0 2 1 3 0 4 0) :duration dur)
- (make-env '(0 0 1 0 2 0 3 1 4 0) :duration dur)
- (make-env '(0 0 1 0 2 0 3 0 4 1) :duration dur))
- #f
- (vector 0 1 2 3)))))
- (do ((i start (+ i 1)))
- ((= i end))
- (move-sound loc i (* amp (oscil os)))))))
+(define sndclmdoc-simple-dloc simple-dloc-4)
(definstrument (when? start-time duration start-freq end-freq grain-file)
(let ((beg (seconds->samples start-time))
@@ -2216,11 +1959,7 @@
freq phase fm res)
(define* (sndscm-osc1 gen fm)
- (let-set! gen 'fm fm)
- (with-let gen
- (set! res (sin phase))
- (set! phase (+ phase freq fm))
- res))
+ (sndscm-osc gen fm))
(definstrument (sndscm-osc1-fm beg dur freq amp mc-ratio (fm-index 1.0))
(let ((start (seconds->samples beg))
@@ -2258,11 +1997,7 @@
freq phase fm res)
(define* (sndscm-osc2 gen fm)
- (let-set! gen 'fm fm)
- (with-let gen
- (set! res (sin phase))
- (set! phase (+ phase freq fm))
- res))
+ (sndscm-osc gen fm))
(definstrument (sndscm-osc2-fm beg dur freq amp mc-ratio (fm-index 1.0))
(let ((start (seconds->samples beg))
@@ -2271,7 +2006,7 @@
(modulator (make-sndscm-osc2 (* mc-ratio freq)))
(index (hz->radians (* freq mc-ratio fm-index))))
(if (fneq (mus-frequency carrier) freq)
- (format #t ";sndscm-osc2 (sclm23.scm) mus-frequency ~A: ~A ~A" (mus-describe carrier) (mus-frequency carrier) freq))
+ (format () ";sndscm-osc2 (sclm23.scm) mus-frequency ~A: ~A ~A" (mus-describe carrier) (mus-frequency carrier) freq))
(do ((i start (+ i 1)))
((= i end))
(outa i (* amp (sndscm-osc2 carrier (* index (sndscm-osc2 modulator 0.0))))))))
@@ -2341,15 +2076,6 @@
(if (< i end)
(loop (+ i 1))))))
-(define (simp-tail-recursion beg dur freq amp)
- (let ((o (make-oscil freq))
- (start (seconds->samples beg))
- (end (seconds->samples (+ beg dur))))
- (define (simper i)
- (outa i (* amp (oscil o)))
- (if (< i end)
- (simper (+ i 1))))
- (simper start)))
;;; --------------------------------------------------------------------------------
@@ -2421,7 +2147,7 @@
(with-sound () ; one of JC's favorite demos
(sndclmdoc-fofins 0 4 270 .2 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 .5 1 3 .5 10 .2 20 .1 50 .1 60 .2 85 1 100 0))
- (sndclmdoc-fofins 0 4 (* 6/5 540) .2 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
+ (sndclmdoc-fofins 0 4 648 .2 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 .5 .5 3 .25 6 .1 10 .1 50 .1 60 .2 85 1 100 0))
(sndclmdoc-fofins 0 4 135 .2 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 1 3 3 1 6 .2 10 .1 50 .1 60 .2 85 1 100 0)))
@@ -2453,12 +2179,9 @@
(sndclmdoc-space "pistol.snd" 0 1 :distance-env '(0 1 1 2) :degree-env '(0 0 1 90)))
(with-sound ()
- (let ((gen (sndclmdoc-make-sum-of-odd-sines 440.0 10)))
- (sndclmdoc-sum-of-odd-sines gen 0.0))
- (let ((gen (sndclmdoc-make-sinc-train 440.0)))
- (sndclmdoc-sinc-train gen))
- (let ((gen (sndclmdoc-make-moving-max)))
- (sndclmdoc-moving-max gen 0.1))
+ (sndclmdoc-sum-of-odd-sines (sndclmdoc-make-sum-of-odd-sines 440.0 10) 0.0)
+ (sndclmdoc-sinc-train (sndclmdoc-make-sinc-train 440.0))
+ (sndclmdoc-moving-max (sndclmdoc-make-moving-max) 0.1)
(sndclmdoc-asy 0 .1 440 .1 1.0)
(sndclmdoc-simple-table 1000)
(sndclmdoc-simple-f2s .1 .1 .1 "oboe.snd")
@@ -2497,8 +2220,7 @@
(sndscm-osc-fm 0 1 440 .1 1 1)
(sndscm-osc1-fm 0 1 440 .1 1)
(sndscm-osc2-fm 0 1 440.0 .1 1)
- (simp-named-let 0 .01 440 .1)
- (simp-tail-recursion 0 .01 440 .1))
+ (simp-named-let 0 .01 440 .1))
(with-sound ()
(let ((gen (make-dsp-asyfm :freq 2000 :ratio .1)))
diff --git a/clm2xen.c b/clm2xen.c
index 43f35d1..a8e00e1 100644
--- a/clm2xen.c
+++ b/clm2xen.c
@@ -82,9 +82,10 @@ struct mus_xen {
};
-enum {MUS_DATA_WRAPPER, MUS_INPUT_FUNCTION, MUS_ANALYZE_FUNCTION, MUS_EDIT_FUNCTION, MUS_SYNTHESIZE_FUNCTION, MUS_SELF_WRAPPER, MUS_INPUT_DATA, MUS_MAX_VCTS};
+enum {MUS_DATA_WRAPPER, MUS_INPUT_FUNCTION, MUS_ANALYZE_FUNCTION, MUS_EDIT_FUNCTION, MUS_SYNTHESIZE_FUNCTION, MUS_SAVED_FUNCTION,
+ MUS_SELF_WRAPPER, MUS_INPUT_DATA, MUS_MAX_VCTS}; /* order matters, stuff before self_wrapper is GC marked */
-static mus_xen *mx_free_lists[8] = {NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL};
+static mus_xen *mx_free_lists[9] = {NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL};
static mus_xen *mx_alloc(int vcts)
{
@@ -1331,10 +1332,10 @@ static Xen_object_mark_t mark_mus_xen(Xen obj)
lim = MUS_SELF_WRAPPER;
if (ms->nvcts < lim) lim = ms->nvcts;
#if HAVE_SCHEME
- if (ms->free_data)
+ if (ms->free_data) /* set if rf functions are using these two vct slots */
{
for (i = 0; i < lim; i++)
- if ((i != MUS_INPUT_FUNCTION) &&
+ if ((i != MUS_INPUT_FUNCTION) &&
(i != MUS_INPUT_DATA) &&
(Xen_is_bound(ms->vcts[i])))
xen_gc_mark(ms->vcts[i]);
@@ -8253,7 +8254,8 @@ static void set_as_needed_input_choices(mus_any *gen, Xen obj, mus_xen *gn)
}
#if HAVE_SCHEME
- if (Xen_is_procedure(obj))
+ if ((Xen_is_procedure(obj)) &&
+ (!Xen_is_procedure(gn->vcts[MUS_ANALYZE_FUNCTION]))) /* this assumes scheme-ready input function at least in phase-vocoder case */
{
s7_pointer body;
body = s7_closure_body(s7, obj);
@@ -8285,7 +8287,7 @@ static void set_as_needed_input_choices(mus_any *gen, Xen obj, mus_xen *gn)
rf = s7_rf_function(s7, fcar)(s7, res);
if (rf)
{
- /* fprintf(stderr, "try %s\n", DISPLAY(res)); */
+ gn->vcts[MUS_SAVED_FUNCTION] = gn->vcts[MUS_INPUT_FUNCTION]; /* needed for GC protection */
gn->vcts[MUS_INPUT_DATA] = (s7_pointer)s7_xf_detach(s7);
gn->vcts[MUS_INPUT_FUNCTION] = (s7_pointer)rf;
gn->free_data = true;
@@ -8805,10 +8807,13 @@ static mus_float_t pvsynthesize(void *ptr)
static bool pvanalyze(void *ptr, mus_float_t (*input)(void *arg1, int direction))
{
mus_xen *gn = (mus_xen *)ptr;
- /* we can only get input func if it's already set up by the outer gen call, so (?) we can use that function here */
+ /* we can only get input func if it's already set up by the outer gen call, so (?) we can use that function here.
+ * but the gc might be called during this call, and scan the args, so the input function should be
+ * in the arg list only if its a legit pointer?
+ */
return(Xen_boolean_to_C_bool(Xen_unprotected_call_with_2_args(gn->vcts[MUS_ANALYZE_FUNCTION],
- gn->vcts[MUS_SELF_WRAPPER],
- gn->vcts[MUS_INPUT_FUNCTION])));
+ gn->vcts[MUS_SELF_WRAPPER],
+ gn->vcts[MUS_INPUT_FUNCTION])));
}
@@ -12487,12 +12492,12 @@ static char *mus_generator_to_readable_string(s7_scheme *sc, void *obj)
static void mus_xen_init(void)
{
#if HAVE_SCHEME
- s7_pointer s, i, p, t, r, c, f, v, b, d;
+ s7_pointer s, i, p, t, r, c, f, v, b, d, j;
s7_pointer pcl_ct, pl_rcr, pl_bt, pl_ir, pl_cc, pl_ccic, pl_ccrr, pl_fc, pl_fcif, pl_cs, pl_ff, pl_tt, pl_fffifi, pl_ffftii, pl_fffi,
pl_fti, pl_fif, pl_fiir, pl_fttb, pl_ic, pl_rciir, pl_rcir, pl_ririt, pl_rcrr, pl_rirt, pl_riirfff, pl_rirfff, pl_rrpr, pcl_zt,
pl_sc, pl_sssrs, pl_tc, pl_ct, pl_ici, pl_i, pl_fcf, pl_dcr, pl_dr, pl_dffi, pl_dfri, pl_dirfir, pl_dc, pl_dci, pl_dcir, pl_dv,
- pl_dvir, pl_drf, pl_drc, pl_diit, pl_dit, pl_dct, pl_d;
+ pl_dvir, pl_drf, pl_drc, pl_diit, pl_dit, pl_dct, pl_d, pl_dcf, pl_dcrt, pl_djr, pl_it, pl_iti;
#endif
mus_initialize();
@@ -12512,6 +12517,7 @@ static void mus_xen_init(void)
r = s7_make_symbol(s7, "real?");
c = s7_make_symbol(s7, "c-object?");
f = s7_make_symbol(s7, "float-vector?");
+ j = s7_make_symbol(s7, "int-vector?");
v = s7_make_symbol(s7, "vector?");
b = s7_make_symbol(s7, "boolean?");
d = s7_make_symbol(s7, "float?");
@@ -12523,6 +12529,9 @@ static void mus_xen_init(void)
pl_d = s7_make_signature(s7, 1, d);
pl_dcr = s7_make_circular_signature(s7, 2, 3, d, c, r);
+ pl_djr = s7_make_circular_signature(s7, 2, 3, d, j, r);
+ pl_dcf = s7_make_signature(s7, 3, d, c, s7_make_signature(s7, 2, r, f));
+ pl_dcrt = s7_make_signature(s7, 4, d, c, r, t);
pl_dct = s7_make_signature(s7, 3, d, c, t);
pl_dci = s7_make_circular_signature(s7, 2, 3, d, c, i);
pl_dcir = s7_make_signature(s7, 4, d, c, i, r);
@@ -12543,6 +12552,7 @@ static void mus_xen_init(void)
pl_ct = s7_make_signature(s7, 2, c, t);
pl_cc = s7_make_circular_signature(s7, 1, 2, c, c);
pl_ici = s7_make_signature(s7, 3, i, c, i);
+ pl_iti = s7_make_signature(s7, 3, i, t, i);
pl_ccic = s7_make_signature(s7, 3, c, c, i, c);
pl_ccrr = s7_make_signature(s7, 4, c, c, r, r);
pl_fc = s7_make_signature(s7, 2, s7_make_signature(s7, 2, f, b), c);
@@ -12558,6 +12568,7 @@ static void mus_xen_init(void)
pl_fiir = s7_make_signature(s7, 4, f, i, i, r);
pl_fttb = s7_make_signature(s7, 4, f, t, t, b);
pl_ic = s7_make_signature(s7, 2, i, c);
+ pl_it = s7_make_signature(s7, 2, i, t);
pl_rciir = s7_make_signature(s7, 5, r, c, i, i, r);
pl_rcir = s7_make_signature(s7, 4, r, c, i, r);
pl_ririt = s7_make_signature(s7,5, r, i, r, i, t);
@@ -12769,7 +12780,7 @@ static void mus_xen_init(void)
Xen_define_typed_dilambda(S_mus_scaler, g_mus_scaler_w, H_mus_scaler, S_set S_mus_scaler, g_mus_set_scaler_w, 1, 0, 2, 0, pl_dc, pl_dcr);
Xen_define_typed_dilambda(S_mus_width, g_mus_width_w, H_mus_width, S_set S_mus_width, g_mus_set_width_w, 1, 0, 2, 0, pl_ic, pl_ici);
Xen_define_typed_dilambda(S_mus_frequency, g_mus_frequency_w, H_mus_frequency, S_set S_mus_frequency, g_mus_set_frequency_w, 1, 0, 2, 0, pl_dc, pl_dcr);
- Xen_define_typed_dilambda(S_mus_length, g_mus_length_w, H_mus_length, S_set S_mus_length, g_mus_set_length_w, 1, 0, 2, 0, pl_ic, pl_ici);
+ Xen_define_typed_dilambda(S_mus_length, g_mus_length_w, H_mus_length, S_set S_mus_length, g_mus_set_length_w, 1, 0, 2, 0, pl_it, pl_iti);
Xen_define_typed_dilambda(S_mus_data, g_mus_data_w, H_mus_data, S_set S_mus_data, g_mus_set_data_w, 1, 0, 2, 0, pl_fc, pl_fcf);
Xen_define_typed_dilambda(S_mus_xcoeff, g_mus_xcoeff_w, H_mus_xcoeff, S_set S_mus_xcoeff, g_mus_set_xcoeff_w, 2, 0, 3, 0, pl_dci, pl_dcir);
Xen_define_typed_dilambda(S_mus_ycoeff, g_mus_ycoeff_w, H_mus_ycoeff, S_set S_mus_ycoeff, g_mus_set_ycoeff_w, 2, 0, 3, 0, pl_dci, pl_dcir);
@@ -12903,7 +12914,7 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_make_formant, g_make_formant_w, 0, 4, 0, H_make_formant, pcl_ct);
Xen_define_typed_procedure(S_formant, g_formant_w, 1, 2, 0, H_formant, pl_dcr);
- Xen_define_typed_procedure(S_formant_bank, g_formant_bank_w, 1, 1, 0, H_formant_bank, pl_dcr);
+ Xen_define_typed_procedure(S_formant_bank, g_formant_bank_w, 1, 1, 0, H_formant_bank, pl_dcf);
Xen_define_typed_procedure(S_is_formant_bank, g_is_formant_bank_w, 1, 0, 0, H_is_formant_bank, pl_bt);
Xen_define_typed_procedure(S_make_formant_bank, g_make_formant_bank_w, 1, 1, 0, H_make_formant_bank, pcl_zt);
@@ -12971,7 +12982,7 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_locsig, g_locsig_w, 3, 0, 0, H_locsig, pl_rcr);
Xen_define_typed_procedure(S_make_locsig, g_make_locsig_w, 0, 0, 1, H_make_locsig, pcl_ct);
Xen_define_typed_procedure(S_move_locsig, g_move_locsig_w, 3, 0, 0, H_move_locsig, pl_ccrr);
- Xen_define_typed_procedure(S_mus_channels, g_mus_channels_w, 1, 0, 0, H_mus_channels, pl_ic);
+ Xen_define_typed_procedure(S_mus_channels, g_mus_channels_w, 1, 0, 0, H_mus_channels, pl_it);
#if HAVE_RUBY
Xen_define_procedure(S_locsig_ref, g_locsig_ref_w, 2, 0, 0, H_locsig_ref);
@@ -13049,7 +13060,7 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_clear_sincs, g_mus_clear_sincs_w, 0, 0, 0, "clears out any sinc tables", NULL);
Xen_define_typed_procedure(S_is_src, g_is_src_w, 1, 0, 0, H_is_src, pl_bt);
- Xen_define_typed_procedure(S_src, g_src_w, 1, 2, 0, H_src, pl_dcr);
+ Xen_define_typed_procedure(S_src, g_src_w, 1, 2, 0, H_src, pl_dcrt);
Xen_define_typed_procedure(S_make_src, g_make_src_w, 0, 6, 0, H_make_src, pcl_ct);
@@ -13101,7 +13112,7 @@ static void mus_xen_init(void)
#endif
#if HAVE_SCHEME
- Xen_define_typed_procedure(S_piano_noise, g_piano_noise_w, 2, 0, 0, H_piano_noise, pl_dcr);
+ Xen_define_typed_procedure(S_piano_noise, g_piano_noise_w, 2, 0, 0, H_piano_noise, pl_djr);
Xen_define_typed_procedure(S_singer_filter, g_singer_filter_w, 6, 0, 0, H_singer_filter, pl_riirfff);
Xen_define_typed_procedure(S_singer_nose_filter, g_singer_nose_filter_w, 5, 0, 0, H_singer_nose_filter, pl_rirfff);
#endif
diff --git a/cload.scm b/cload.scm
index 64ceeb3..5898fc8 100644
--- a/cload.scm
+++ b/cload.scm
@@ -104,7 +104,9 @@
;;; --------------------------------------------------------------------------------
(define *cload-cflags* "")
-(define *cload-ldflags* "")
+(define *cload-ldflags* "")
+(if (not (defined? '*cload-directory*))
+ (define *cload-directory* ""))
(define-macro (defvar name value)
@@ -228,7 +230,7 @@
(set! c-define-output-file-counter (+ c-define-output-file-counter 1))
- (let* ((file-name (or output-name (format "temp-s7-output-~D" c-define-output-file-counter)))
+ (let* ((file-name (string-append *cload-directory* (or output-name (format "temp-s7-output-~D" c-define-output-file-counter))))
(c-file-name (string-append file-name ".c"))
(o-file-name (string-append file-name ".o"))
(so-file-name (string-append file-name ".so"))
@@ -404,7 +406,7 @@
((int)
(format p "static s7_int ~A_if_i(s7_scheme *sc, s7_pointer **p)~
{s7_if_t f; s7_int x; f = (s7_if_t)(**p); (*p)++; x = f(sc, p); return(~A(x));}~%"
- func-name func-name)
+ func-name (if (string=? func-name "abs") "llabs" func-name))
(format p "static s7_if_t ~A_if(s7_scheme *sc, s7_pointer expr) ~
{if (s7_arg_to_if(sc, s7_cadr(expr))) return(~A_if_i); return(NULL);}~%"
func-name func-name))
@@ -574,28 +576,28 @@
(if (provided? 'osx)
(begin
;; I assume the caller is also compiled with these flags?
- (system (format #f "gcc -c ~A ~A"
- c-file-name (string-append *cload-cflags* " " cflags)))
+ (system (format #f "gcc -c ~A -o ~A ~A"
+ c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
(system (format #f "gcc ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A"
o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
(if (provided? 'freebsd)
(begin
- (system (format #f "cc -fPIC -c ~A ~A"
- c-file-name (string-append *cload-cflags* " " cflags)))
+ (system (format #f "cc -fPIC -c ~A -o ~A ~A"
+ c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
(system (format #f "cc ~A -shared -o ~A ~A"
o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
(if (provided? 'openbsd)
(begin
- (system (format #f "cc -fPIC -ftrampolines -c ~A ~A"
- c-file-name (string-append *cload-cflags* " " cflags)))
+ (system (format #f "cc -fPIC -ftrampolines -c ~A -o ~A ~A"
+ c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
(system (format #f "cc ~A -shared -o ~A ~A"
o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
(begin
- (system (format #f "gcc -fPIC -c ~A ~A"
- c-file-name (string-append *cload-cflags* " " cflags)))
+ (system (format #f "gcc -fPIC -c ~A -o ~A ~A"
+ c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
(system (format #f "gcc ~A -shared -o ~A ~A"
o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))))))
diff --git a/configure b/configure
index 195c06b..ad64317 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 16.1.
+# Generated by GNU Autoconf 2.69 for snd 16.5.
#
# Report bugs to <bil at 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-16.tar.gz'
-PACKAGE_VERSION='16.1'
-PACKAGE_STRING='snd 16.1'
+PACKAGE_VERSION='16.5'
+PACKAGE_STRING='snd 16.5'
PACKAGE_BUGREPORT='bil at ccrma.stanford.edu'
PACKAGE_URL=''
@@ -627,6 +627,8 @@ LIBOBJS
MAKE_TARGET
ORIGINAL_LDFLAGS
INSTALL
+WEBSERVER_FILES
+WEBSERVER_LIBS
SO_LD
SO_FLAGS
LDSO_FLAGS
@@ -635,7 +637,6 @@ JACK_LIBS
AUDIO_LIB
PATH_WVUNPACK
PATH_WAVPACK
-PATH_TTA
PATH_TIMIDITY
PATH_FLAC
PATH_SPEEXENC
@@ -755,6 +756,7 @@ with_audio
with_temp_dir
with_save_dir
with_doc_dir
+with_weebserver
enable_deprecated
with_x
'
@@ -1308,7 +1310,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 16.1 to adapt to many kinds of systems.
+\`configure' configures snd 16.5 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1378,7 +1380,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of snd 16.1:";;
+ short | recursive ) echo "Configuration of snd 16.5:";;
esac
cat <<\_ACEOF
@@ -1414,6 +1416,7 @@ Optional Packages:
--with-temp-dir directory to use for temp files
--with-save-dir directory to use for saved-state files
--with-doc-dir directory to search for documentation
+ --with-webserver use webserver, default=no
--with-x use the X Window System
Some influential environment variables:
@@ -1493,7 +1496,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-snd configure 16.1
+snd configure 16.5
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
@@ -1954,7 +1957,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 16.1, which was
+It was created by snd $as_me 16.5, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
@@ -3301,12 +3304,12 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=16.1
+VERSION=16.5
#--------------------------------------------------------------------------------
# configuration options
-# --with-motif use Motif (the default)
-# --with-gtk use Gtk+
+# --with-motif use Motif
+# --with-gtk use Gtk+ (the default)
# --with-alsa use ALSA if possible (the default)
# --with-oss use OSS
# --with-jack use Jack
@@ -3329,6 +3332,7 @@ VERSION=16.1
# --without-fftw omit FFTW even if it exists
# --with-pulseaudio use PulseAudio
# --with-portaudio use portaudio
+# --with-webserver use webserver
@@ -3483,6 +3487,12 @@ _ACEOF
fi
+# Check whether --with-weebserver was given.
+if test "${with_weebserver+set}" = set; then :
+ withval=$with_weebserver;
+fi
+
+
# Check whether --enable-deprecated was given.
if test "${enable_deprecated+set}" = set; then :
enableval=$enable_deprecated;
@@ -5754,58 +5764,6 @@ _ACEOF
fi
-# Extract the first word of "ttaenc", so it can be a program name with args.
-set dummy ttaenc; ac_word=$2
-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-$as_echo_n "checking for $ac_word... " >&6; }
-if ${ac_cv_path_PATH_TTA+:} false; then :
- $as_echo_n "(cached) " >&6
-else
- case $PATH_TTA in
- [\\/]* | ?:[\\/]*)
- ac_cv_path_PATH_TTA="$PATH_TTA" # Let the user override the test with a path.
- ;;
- *)
- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- ac_cv_path_PATH_TTA="$as_dir/$ac_word$ac_exec_ext"
- $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
- test -z "$ac_cv_path_PATH_TTA" && ac_cv_path_PATH_TTA="no"
- ;;
-esac
-fi
-PATH_TTA=$ac_cv_path_PATH_TTA
-if test -n "$PATH_TTA"; then
- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PATH_TTA" >&5
-$as_echo "$PATH_TTA" >&6; }
-else
- { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
-$as_echo "no" >&6; }
-fi
-
-
-
-if test "$PATH_TTA" != "no" ; then
- $as_echo "#define HAVE_TTA 1" >>confdefs.h
-
- cat >>confdefs.h <<_ACEOF
-#define PATH_TTA "${PATH_TTA}"
-_ACEOF
-
-fi
-
-
# Extract the first word of "wavpack", so it can be a program name with args.
set dummy wavpack; ac_word=$2
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
@@ -5920,7 +5878,7 @@ if test "$with_audio" != no ; then
if test "$with_pulseaudio" = yes ; then
$as_echo "#define MUS_PULSEAUDIO 1" >>confdefs.h
- AUDIO_LIB="-lpulse-simple"
+ AUDIO_LIB="-lpulse-simple -lpulse"
AUDIO_SYSTEM=pulseaudio
fi
@@ -6066,6 +6024,37 @@ case "$host" in
fi
;;
+ *-*-kfreebsd*|*-*-gnu*)
+ LDSO_FLAGS="-shared"
+ LIBS="$LIBS -lm -ldl"
+ if test "$GCC" = yes ; then
+ SO_FLAGS="-fPIC $SO_FLAGS"
+ fi
+
+ AUDIO_SYSTEM=OSS
+
+ if test "$with_jack" = yes ; then
+ if test "$with_oss" != yes ; then
+ AUDIO_SYSTEM=JACK
+ fi
+ fi
+
+ case $AUDIO_SYSTEM in
+ JACK)
+ $as_echo "#define HAVE_JACK_IN_LINUX 1" >>confdefs.h
+
+ $as_echo "#define HAVE_OSS 1" >>confdefs.h
+
+ AUDIO_LIB="-lsamplerate"
+ ;;
+ OSS)
+ $as_echo "#define HAVE_OSS 1" >>confdefs.h
+
+ AUDIO_SYSTEM=OSS
+ ;;
+ esac
+ ;;
+
*-*-sunos4*)
LIBS="$LIBS -lm"
;;
@@ -6136,6 +6125,27 @@ esac
+#--------------------------------------------------------------------------------
+# webserver
+#--------------------------------------------------------------------------------
+
+WEBSERVER_LIBS=""
+WEBSERVER_FILES=""
+
+if test "$with_webserver" = yes ; then
+ $as_echo "#define ENABLE_WEBSERVER 1" >>confdefs.h
+
+
+ WEBSERVER_FILES="s7webserver/s7webserver.o s7webserver/qhttpserver-master/lib/libqhttpserver.a"
+ WEBSERVER_LIBS="`pkg-config --libs QtNetwork` -lstdc++"
+
+ RANDOM_FEATURES="$RANDOM_FEATURES webserver"
+fi
+
+
+
+
+
#--------------------------------------------------------------------------------
# export-dynamic
@@ -6681,7 +6691,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 16.1, which was
+This file was extended by snd $as_me 16.5, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -6743,7 +6753,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 16.1
+snd config.status 16.5
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index 361da46..58f8703 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
-AC_INIT(snd, 16.1, bil at ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-16.tar.gz)
+AC_INIT(snd, 16.5, bil at ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-16.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=16.1
+VERSION=16.5
#--------------------------------------------------------------------------------
# configuration options
@@ -52,6 +52,7 @@ VERSION=16.1
# --without-fftw omit FFTW even if it exists
# --with-pulseaudio use PulseAudio
# --with-portaudio use portaudio
+# --with-webserver use webserver
AC_ARG_WITH(gtk, [ --with-gtk use Gtk+ to build Snd])
@@ -81,6 +82,7 @@ AC_ARG_WITH(audio, [ --without-audio don't include any audio func
AC_ARG_WITH(temp-dir, [ --with-temp-dir directory to use for temp files], AC_DEFINE_UNQUOTED(MUS_DEFAULT_TEMP_DIR, "${withval}"))
AC_ARG_WITH(save-dir, [ --with-save-dir directory to use for saved-state files], AC_DEFINE_UNQUOTED(MUS_DEFAULT_SAVE_DIR, "${withval}"))
AC_ARG_WITH(doc-dir, [ --with-doc-dir directory to search for documentation], AC_DEFINE_UNQUOTED(MUS_DEFAULT_DOC_DIR, "${withval}"))
+AC_ARG_WITH(weebserver, [ --with-webserver use webserver, default=no])
AC_ARG_ENABLE(deprecated,[ --disable-deprecated do not include any deprecated stuff from gtk, s7, motif, clm, snd, or sndlib])
@@ -487,14 +489,6 @@ if test "$PATH_TIMIDITY" != "no" ; then
fi
-AC_PATH_PROG(PATH_TTA, ttaenc, no)
-
-if test "$PATH_TTA" != "no" ; then
- AC_DEFINE(HAVE_TTA)
- AC_DEFINE_UNQUOTED(PATH_TTA, "${PATH_TTA}")
-fi
-
-
AC_PATH_PROG(PATH_WAVPACK, wavpack, no)
AC_PATH_PROG(PATH_WVUNPACK, wvunpack, no)
@@ -521,7 +515,7 @@ if test "$with_audio" != no ; then
if test "$with_pulseaudio" = yes ; then
AC_DEFINE(MUS_PULSEAUDIO)
- AUDIO_LIB="-lpulse-simple"
+ AUDIO_LIB="-lpulse-simple -lpulse"
AUDIO_SYSTEM=pulseaudio
fi
@@ -657,6 +651,34 @@ case "$host" in
fi
;;
+ *-*-kfreebsd*|*-*-gnu*)
+ LDSO_FLAGS="-shared"
+ LIBS="$LIBS -lm -ldl"
+ if test "$GCC" = yes ; then
+ SO_FLAGS="-fPIC $SO_FLAGS"
+ fi
+
+ AUDIO_SYSTEM=OSS
+
+ if test "$with_jack" = yes ; then
+ if test "$with_oss" != yes ; then
+ AUDIO_SYSTEM=JACK
+ fi
+ fi
+
+ case $AUDIO_SYSTEM in
+ JACK)
+ AC_DEFINE(HAVE_JACK_IN_LINUX)
+ AC_DEFINE(HAVE_OSS)
+ AUDIO_LIB="-lsamplerate"
+ ;;
+ OSS)
+ AC_DEFINE(HAVE_OSS)
+ AUDIO_SYSTEM=OSS
+ ;;
+ esac
+ ;;
+
*-*-sunos4*)
LIBS="$LIBS -lm"
;;
@@ -727,6 +749,26 @@ AC_SUBST(SO_FLAGS)
AC_SUBST(SO_LD)
+#--------------------------------------------------------------------------------
+# webserver
+#--------------------------------------------------------------------------------
+
+WEBSERVER_LIBS=""
+WEBSERVER_FILES=""
+
+if test "$with_webserver" = yes ; then
+ AC_DEFINE(ENABLE_WEBSERVER)
+
+ WEBSERVER_FILES="s7webserver/s7webserver.o s7webserver/qhttpserver-master/lib/libqhttpserver.a"
+ WEBSERVER_LIBS="`pkg-config --libs QtNetwork` -lstdc++"
+
+ RANDOM_FEATURES="$RANDOM_FEATURES webserver"
+fi
+
+AC_SUBST(WEBSERVER_LIBS)
+AC_SUBST(WEBSERVER_FILES)
+
+
#--------------------------------------------------------------------------------
# export-dynamic
diff --git a/dlocsig.scm b/dlocsig.scm
index 84418aa..a59f61e 100644
--- a/dlocsig.scm
+++ b/dlocsig.scm
@@ -1,12 +1,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Copyright (c) 92, 93, 94, 98, 99, 2000, 2001 Fernando Lopez Lezcano.
-;;; All rights reserved.
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted and may be copied as long as
-;;; no fees or compensation are charged for use, copying, or accessing
-;;; this software and all copies of this software include this copyright
-;;; notice. Suggestions, comments and bug reports are welcome. Please
+;;; Suggestions, comments and bug reports are welcome. Please
;;; address email to: nando at ccrma.stanford.edu
+;;;
+;;; see the file COPYING for license info.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -113,12 +109,12 @@
(define x-norm
(let ((documentation "(x-norm e xmax) changes 'e' x axis values so that they run to 'xmax'"))
(lambda (e xmax)
- (define (x-norm-1 e scl new-e)
- (if (null? e)
- (reverse! new-e)
- (x-norm-1 (cddr e) scl (cons (cadr e) (cons (* scl (car e)) new-e)))))
- (x-norm-1 e (/ xmax (e (- (length e) 2))) ()))))
-
+ (let x-norm-1 ((e e)
+ (scl (/ xmax (e (- (length e) 2))))
+ (new-e ()))
+ (if (null? e)
+ (reverse! new-e)
+ (x-norm-1 (cddr e) scl (cons (cadr e) (cons (* scl (car e)) new-e))))))))
;;;;;;;;;;;;;;;;;;;;;
@@ -201,9 +197,6 @@
(lambda (a)
(exp (* 0.0+1.0i a)))))
-;; built-in 1-Feb-14
-;; (define-macro (when test . forms) `(if ,test (begin , at forms)))
-
(define third
(let ((documentation "(third lst) returns the 3rd element of 'lst'"))
(lambda (a)
@@ -214,27 +207,9 @@
(lambda (a)
(and (>= (length a) 4) (a 3)))))
-(define last
- (let ((documentation "(last lst n) returns the last 'n' elements of 'lst' as a list"))
- (lambda* (a n)
- (and (not (null? a))
- (if (not n)
- (list (a (- (length a) 1)))
- (let ((res ()))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (set! res (cons (a (- (length a) (+ i 1))) res)))
- res))))))
-
-(define listp pair?)
-
-(define (make-list-1 n val)
- (let ((lst ()))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (set! lst (cons val lst)))
- lst))
-
+(define* (last lst (n 1))
+ (and (pair? lst)
+ (list-tail lst (- (length lst) n))))
(define* (arrange-speakers (speakers ())
(groups ())
@@ -270,39 +245,37 @@
(set! det (+ (* (m 0 0) (mat 0 0))
(* (m 0 1) (mat 1 0))
(* (m 0 2) (mat 2 0))))
- (if (<= (abs det) 1e-06)
- #f
- (begin
- (set! invdet (/ 1.0 det))
- (do ((row 0 (+ 1 row)))
- ((= row 3))
- (do ((col 0 (+ 1 col)))
- ((= col 3))
- (set! (mat row col) (* (mat row col) invdet))))
- mat))))
+ (and (> (abs det) 1e-06)
+ (begin
+ (set! invdet (/ 1.0 det))
+ (do ((row 0 (+ 1 row)))
+ ((= row 3))
+ (do ((col 0 (+ 1 col)))
+ ((= col 3))
+ (set! (mat row col) (* (mat row col) invdet))))
+ mat))))
(define (invert2x2 mat) ; invert a 2x2 matrix
(let ((m (make-float-vector (list 2 2) 0.0))
(det (- (* (mat 0 0) (mat 1 1))
(* (mat 1 0) (mat 0 1)))))
- (if (<= (abs det) 1e-06)
- #f
- (begin
- (set! (m 0 0) (/ (mat 1 1) det))
- (set! (m 1 1) (/ (mat 0 0) det))
- (set! (m 0 1) (- (/ (mat 0 1) det)))
- (set! (m 1 0) (- (/ (mat 1 0) det)))
- m))))
+ (and (> (abs det) 1e-06)
+ (begin
+ (set! (m 0 0) (/ (mat 1 1) det))
+ (set! (m 1 1) (/ (mat 0 0) det))
+ (set! (m 0 1) (- (/ (mat 0 1) det)))
+ (set! (m 1 0) (- (/ (mat 1 0) det)))
+ m))))
(if (null? speakers)
- (error 'mus-error "ERROR: a speaker configuration must have at least one speaker!~%"))
+ (error 'mus-error "a speaker configuration must have at least one speaker!~%"))
(if (pair? groups)
(let ((first-len (length (car groups))))
(for-each
(lambda (group)
(if (not (= (length group) first-len))
- (error 'mus-error "ERROR: all groups must be of the same length! (~A)~%" first-len)))
+ (error 'mus-error "all groups must be of the same length! (~A)~%" first-len)))
groups))
;; if the speakers are defined with only azimuth angles (no elevation)
@@ -322,39 +295,39 @@
(set! groups (reverse groups)))))))
(if (null? groups)
- (error 'mus-error "ERROR: no groups specified, speakers must be arranged in groups~%"))
+ (error 'mus-error "no groups specified, speakers must be arranged in groups~%"))
(if (and (pair? delays)
(pair? distances))
- (error 'mus-error "ERROR: please specify delays or distances but not both~%"))
+ (error 'mus-error "please specify delays or distances but not both~%"))
(if (pair? delays)
(if (> (length speakers) (length delays))
- (error 'mus-error "ERROR: all speaker delays have to be specified, only ~A supplied [~A]~%" (length delays) delays)
+ (error 'mus-error "all speaker delays have to be specified, only ~A supplied [~A]~%" (length delays) delays)
(if (< (length speakers) (length delays))
- (error 'mus-error "ERROR: more speaker delays than speakers, ~A supplied instead of ~A [~A]~%" (length delays) (length speakers) delays))))
+ (error 'mus-error "more speaker delays than speakers, ~A supplied instead of ~A [~A]~%" (length delays) (length speakers) delays))))
(for-each
(lambda (dly)
- (if (< dly 0.0) (error 'mus-error "ERROR: delays must be all positive, ~A is negative~%" dly)))
+ (if (< dly 0.0) (error 'mus-error "delays must be all positive, ~A is negative~%" dly)))
delays)
(if (pair? distances)
(if (> (length speakers) (length distances))
- (error 'mus-error "ERROR: all speaker distances have to be specified, only ~A supplied [~A]~%" (length distances) distances)
+ (error 'mus-error "all speaker distances have to be specified, only ~A supplied [~A]~%" (length distances) distances)
(if (< (length speakers) (length distances))
- (error 'mus-error "ERROR: more speaker distances than speakers, ~A supplied instead of ~A [~A]~%" (length distances) (length speakers) distances))))
+ (error 'mus-error "more speaker distances than speakers, ~A supplied instead of ~A [~A]~%" (length distances) (length speakers) distances))))
(for-each
(lambda (dly)
- (if (< dly 0.0) (error 'mus-error "ERROR: distances must be all positive, ~A is negative~%" dly)))
+ (if (< dly 0.0) (error 'mus-error "distances must be all positive, ~A is negative~%" dly)))
distances)
(if (pair? channel-map)
(if (> (length speakers) (length channel-map))
- (error 'mus-error "ERROR: must map all speakers to output channels, only ~A mapped [~A]~%" (length channel-map) channel-map)
+ (error 'mus-error "must map all speakers to output channels, only ~A mapped [~A]~%" (length channel-map) channel-map)
(if (< (length speakers) (length channel-map))
- (error 'mus-error "ERROR: trying to map more channels than there are speakers, ~A supplied instead of ~A [~A]~%"
+ (error 'mus-error "trying to map more channels than there are speakers, ~A supplied instead of ~A [~A]~%"
(length channel-map) (length speakers) channel-map))))
;; collect unit vectors describing the speaker positions
@@ -377,14 +350,9 @@
;; minimum distance
(min-dist (if (pair? distances)
- (let ((mind (car distances)))
- (for-each
- (lambda (d)
- (if (< d mind) (set! mind d)))
- distances)
- mind)
+ (apply min distances)
0.0))
-
+
;; find delay times from specified distances or delays
(times (let ((v (make-float-vector (length speakers))))
(do ((i 0 (+ i 1)))
@@ -412,15 +380,14 @@
((= j 3))
(set! (m i j) ((vertices i) j))))
(invert3x3 m))
- (if (= size 2)
- (let ((m (make-float-vector (list 2 2) 0.0)))
- (do ((i 0 (+ i 1)))
- ((= i 2))
- (do ((j 0 (+ j 1)))
- ((= j 2))
- (set! (m i j) ((vertices i) j))))
- (invert2x2 m))
- #f))))
+ (and (= size 2)
+ (let ((m (make-float-vector (list 2 2) 0.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i 2))
+ (do ((j 0 (+ j 1)))
+ ((= j 2))
+ (set! (m i j) ((vertices i) j))))
+ (invert2x2 m))))))
(set! vals (cons (make-group :id id
:size size
:speakers group
@@ -437,10 +404,10 @@
(for-each
(lambda (entry)
(if (>= entry entries)
- (error 'mus-error "ERROR: channel ~A in map ~A is out of range (max=~A)~%" entry channel-map entries)))
+ (error 'mus-error "channel ~A in map ~A is out of range (max=~A)~%" entry channel-map entries)))
channel-map)
(if (has-duplicates? channel-map)
- (error 'mus-error "ERROR: there are duplicate channels in channel-map ~A~%" channel-map))))
+ (error 'mus-error "there are duplicate channels in channel-map ~A~%" channel-map))))
;; create the speaker configuration structure
@@ -548,7 +515,7 @@
(lambda* (channels (3d dlocsig-3d) (configs dlocsig-speaker-configs))
(let ((config (if 3d ((cadr configs) channels) ((car configs) channels))))
(if (null? config)
- (error 'mus-error "ERROR: no speaker configuration exists for ~A ~A output channel~A~%~%"
+ (error 'mus-error "no speaker configuration exists for ~A ~A output channel~A~%~%"
(if 3d "tridimensional" "bidimensional")
channels (if (= channels 1) "s" "")))
config))))
@@ -598,8 +565,6 @@
(define dlocsig-ambisonics-scaler point707)
(define dlocsig-ambisonics-ho-rev-scaler 0.05)
;; for 3rd order FuMa
-(define ambisonics-k1 (sqrt (/ (* 21 45) 224 8)))
-(define ambisonics-k2 (* (sqrt 3) 3 0.5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Get number of channels needed by ambisonics
@@ -608,7 +573,8 @@
(h-order dlocsig-ambisonics-h-order)
(v-order dlocsig-ambisonics-v-order))
(let ((count 0))
- (if (>= h-order 0)
+ (if (< h-order 0)
+ 0 ;; error: we need at least horizontal order 1!
(begin
(if (>= h-order 1)
;; W X Y
@@ -628,9 +594,8 @@
(if (>= h-order 3)
;; P Q
(set! count (+ count 2)))
- count)
- ;; error: we need at least horizontal order 1!
- 0)))
+ count))))
+
;;;;;;;;;
;;; Paths
@@ -651,17 +616,22 @@
(define path-tt (dilambda (lambda (p) (p 9)) (lambda (p val) (set! (p 9) val))))
;(define (make-path) (list 'path () () () () () () () () ()))
-
+#|
(define (describe path)
- (cond ((memq (car path) '(bezier-path open-bezier-path))
- (format #f "<bezier-path>:~% rx: ~A~% ry: ~A~% rz: ~A~% rv: ~A~% rt: ~A~% tx: ~A~% ty: ~A~% tz: ~A~% tt: ~A~% ~
+ (format #f
+ (if (memq (car path) '(bezier-path open-bezier-path))
+ (values
+ "<bezier-path>:~% rx: ~A~% ry: ~A~% rz: ~A~% rv: ~A~% rt: ~A~% tx: ~A~% ty: ~A~% tz: ~A~% tt: ~A~% ~
x: ~A~% y: ~A~% z: ~A~% v: ~A~% bx: ~A~% by: ~A~% bz: ~A~% error: ~A~% curvature: ~A~%"
- (path-rx path) (path-ry path) (path-rz path) (path-rv path) (path-rt path) (path-tx path) (path-ty path) (path-tz path) (path-tt path)
- (bezier-x path) (bezier-y path) (bezier-z path) (bezier-v path) (bezier-bx path) (bezier-by path) (bezier-bz path) (bezier-error path) (bezier-curvature path)))
- (else
- (format #f "<path>:~% rx: ~A~% ry: ~A~% rz: ~A~% rv: ~A~% rt: ~A~% tx: ~A~% ty: ~A~% tz: ~A~% tt: ~A~%"
- (path-rx path) (path-ry path) (path-rz path) (path-rv path) (path-rt path) (path-tx path) (path-ty path) (path-tz path) (path-tt path)))))
-
+ (path-rx path) (path-ry path) (path-rz path) (path-rv path) (path-rt path) (path-tx path)
+ (path-ty path) (path-tz path) (path-tt path) (bezier-x path) (bezier-y path)
+ (bezier-z path) (bezier-v path) (bezier-bx path) (bezier-by path) (bezier-bz path)
+ (bezier-error path) (bezier-curvature path))
+ (values
+ "<path>:~% rx: ~A~% ry: ~A~% rz: ~A~% rv: ~A~% rt: ~A~% tx: ~A~% ty: ~A~% tz: ~A~% tt: ~A~%"
+ (path-rx path) (path-ry path) (path-rz path) (path-rv path) (path-rt path) (path-tx path)
+ (path-ty path) (path-tz path) (path-tt path)))))
+|#
;;; Inquiries into the state of the path
@@ -695,7 +665,7 @@
(define list??
(let ((documentation "list?? returns a if it is a list"))
(lambda (a)
- (and (listp a) a))))
+ (and (pair? a) a))))
(define (path-x path)
(or (list?? (path-tx path))
@@ -763,54 +733,60 @@
;;; Generic defining function (for open, closed, polar and cartesian paths)
;;;
-(define* (make-path path
- (3d path-3d)
- polar
- closed
- curvature
- (error 0.01)
- ;; only for open paths
- initial-direction
- final-direction)
- ;; some sanity checks
- (if (null? path)
- (error 'mus-error "ERROR: Can't define a path with no points in it~%"))
- (if (and closed initial-direction)
- (error 'mus-error "ERROR: Can't specify initial direction ~A for a closed path ~A~%" initial-direction path))
- (if (and closed final-direction)
- (error 'mus-error "ERROR: Can't specify final direction ~A for a closed path ~A~%" final-direction path))
-
- (if (and closed
- (not (if (pair? (car path))
- (let ((start (car path))
- (end (car (last path))))
- (and (= (car start) (car end))
- (= (cadr start) (cadr end))
- (or (not path-3d)
- (= (third start) (third end)))))
- (let ((end (last path (if path-3d 3 2))))
- (and (= (car path) (car end))
- (= (cadr path) (cadr end))
- (or (not path-3d)
- (= (third path) (third end))))))))
- (error 'mus-error "ERROR: Closed path ~A is not closed~%" path))
+(define make-path
+ (let ()
+
+ (define (make-path-error-checks path closed initial-direction final-direction)
+ ;; some sanity checks
+ (if (null? path)
+ (error 'mus-error "Can't define a path with no points in it~%"))
+ (when closed
+ (if initial-direction
+ (error 'mus-error "Can't specify initial direction ~A for a closed path ~A~%" initial-direction path))
+ (if final-direction
+ (error 'mus-error "Can't specify final direction ~A for a closed path ~A~%" final-direction path))
+ (if (not (if (pair? (car path))
+ (let ((start (car path))
+ (end (car (last path))))
+ (and (= (car start) (car end))
+ (= (cadr start) (cadr end))
+ (or (not path-3d)
+ (= (third start) (third end)))))
+ (let ((end (last path (if path-3d 3 2))))
+ (and (= (car path) (car end))
+ (= (cadr path) (cadr end))
+ (or (not path-3d)
+ (= (third path) (third end)))))))
+ (error 'mus-error "Closed path ~A is not closed~%" path))))
+
+ (lambda* (path
+ (3d path-3d)
+ polar
+ closed
+ curvature
+ (error 0.01) ; this name ("error") is a bad idea -- it means we can't call the real error function (this is Scheme, not CL)
+ ;; only for open paths
+ initial-direction
+ final-direction)
- ;; create the path structure
- (if closed
- (make-bezier-path
- :path path
- :3d 3d
- :polar polar
- :curvature curvature
- :error error)
- (make-open-bezier-path
- :path path
- :3d 3d
- :polar polar
- :curvature curvature
- :error error
- :initial-direction initial-direction
- :final-direction final-direction)))
+ (make-path-error-checks path closed initial-direction final-direction) ; the error check uses path-3d -- was 3d intended?
+
+ ;; create the path structure
+ (if closed
+ (make-bezier-path
+ :path path
+ :3d 3d
+ :polar polar
+ :curvature curvature
+ :error error)
+ (make-open-bezier-path
+ :path path
+ :3d 3d
+ :polar polar
+ :curvature curvature
+ :error error
+ :initial-direction initial-direction
+ :final-direction final-direction)))))
;;; Some convenient abbreviations
@@ -896,111 +872,104 @@
(list (reverse x) (reverse y) (reverse z) (reverse v)))
;; decode a plain list
- (if 3d
- ;; it's a three dimensional list
- ;; '(x0 y0 z0 x1 y1 z1 ... xn yn zn)
- ;; x, y, z: coordinates of source
- (let ((px ())
- (py ())
- (pz ())
- (len (length points)))
- (do ((i 0 (+ i 3)))
- ((>= i len))
- (set! px (cons (points i) px))
- (set! py (cons (points (+ i 1)) py))
- (set! pz (cons (points (+ i 2)) pz)))
- (list (reverse px) (reverse py) (reverse pz) (make-list-1 (length px) #f)))
+ (let ((px ())
+ (py ())
+ (len (length points)))
+ (if 3d
+ ;; it's a three dimensional list
+ ;; '(x0 y0 z0 x1 y1 z1 ... xn yn zn)
+ ;; x, y, z: coordinates of source
+ (let ((pz ()))
+ (do ((i 0 (+ i 3)))
+ ((>= i len))
+ (set! px (cons (points i) px))
+ (set! py (cons (points (+ i 1)) py))
+ (set! pz (cons (points (+ i 2)) pz)))
+ (list (reverse px) (reverse py) (reverse pz) (make-list (length px) #f)))
- ;; it's a two dimensional list
- ;; '(x0 y0 x1 y1 ... xn yn)
- ;; x, y, z: coordinates of source [missing z's assumed 0.0]
- (let ((px ())
- (py ())
- (len (length points)))
- (do ((i 0 (+ i 2)))
- ((>= i len))
- (set! px (cons (points i) px))
- (set! py (cons (points (+ i 1)) py)))
- (list (reverse px) (reverse py) (make-list-1 (length px) 0.0) (make-list-1 (length px) #f))))))))
+ ;; it's a two dimensional list
+ ;; '(x0 y0 x1 y1 ... xn yn)
+ ;; x, y, z: coordinates of source [missing z's assumed 0.0]
+ (let ()
+ (do ((i 0 (+ i 2)))
+ ((>= i len))
+ (set! px (cons (points i) px))
+ (set! py (cons (points (+ i 1)) py)))
+ (list (reverse px) (reverse py) (make-list (length px) 0.0) (make-list (length px) #f)))))))))
;;; Parse a set of 2d or 3d polar points into the separate coordinates
(define parse-polar-coordinates
(let ((documentation "(parse-polar-coordinates points 3d) parses a polar path"))
(lambda (points 3d)
- (if (pair? (car points))
- ;; decode a list of lists of d:a:e:v into x:y:z:v components
- ;; 3d --> t [default]
- ;; '((d0 a0 e0 v0) (d1 a1 e1 v1)...(dn an en vn))
- ;; '((d0 a0 e0) (d1 a1 e1)...(dn an en))
- ;; '((d0 a0) (d1 a1)...(dn an))
- ;; 3d --> nil
- ;; '((d0 a0 v0) (d1 a1 v1)...(dn an vn))
- ;; '((d0 a0) (d1 a1)...(dn an))
- ;; v: velocity
- ;; d: distance
- ;; a: azimut angle
- ;; e: elevarion angle [missing elevations assumed 0.0]
- (let ((x ())
- (y ())
- (z ())
- (v ()))
- (for-each
- (lambda (p)
- (let* ((d (car p))
- (a (cadr p))
- (e (if 3d (if (pair? (cddr p)) (caddr p) 0.0) 0.0))
- (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
- (dxy (* d (real-part evec)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
- (set! x (cons (* dxy (imag-part avec)) x))
- (set! y (cons (* dxy (real-part avec)) y))
- (set! z (cons (* d (imag-part evec)) z))
- (set! v (cons (if 3d (fourth p) (third p)) v))))
- points)
- (list (reverse x) (reverse y) (reverse z) (reverse v)))
-
- ;; decode a list of d:a:e components
- (if 3d
- ;; decode a three dimensional list
- ;; '(d0 a0 e0 d1 a1 e1 ... dn an en)
- ;; d: distance
- ;; a: azimut angle
- ;; e: elevarion angle [missing elevations assumed 0.0]
- (let ((x ())
- (y ())
- (z ())
- (len (length points)))
- (do ((i 0 (+ i 3)))
- ((>= i len))
- (let* ((d (points i))
- (a (points (+ i 1)))
- (e (points (+ i 2)))
- (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
- (dxy (* d (real-part evec)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
- (set! x (cons (* dxy (imag-part avec)) x))
- (set! y (cons (* dxy (real-part avec)) y))
- (set! z (cons (* d (imag-part evec)) z))))
- (list (reverse x) (reverse y) (reverse z) (make-list-1 (length x) #f)))
-
- ;; decode a two dimensional list
- ;; '(d0 a0 d1 a1 ... dn an)
- ;; d: distance
- ;; a: azimut angle
- ;; e: elevarion angle [missing elevations assumed 0.0]
- (let ((x ())
- (y ())
- (len (length points)))
- (do ((i 0 (+ i 2)))
- ((>= i len))
- (let* ((d (points i))
- (a (points (+ i 1)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
- (set! x (cons (* d (imag-part avec)) x))
- (set! y (cons (* d (real-part avec)) y))))
- (list (reverse x) (reverse y) (make-list-1 (length x) 0.0) (make-list-1 (length x) #f))))))))
-
+ (let ((x ())
+ (y ()))
+ (if (pair? (car points))
+ ;; decode a list of lists of d:a:e:v into x:y:z:v components
+ ;; 3d --> t [default]
+ ;; '((d0 a0 e0 v0) (d1 a1 e1 v1)...(dn an en vn))
+ ;; '((d0 a0 e0) (d1 a1 e1)...(dn an en))
+ ;; '((d0 a0) (d1 a1)...(dn an))
+ ;; 3d --> nil
+ ;; '((d0 a0 v0) (d1 a1 v1)...(dn an vn))
+ ;; '((d0 a0) (d1 a1)...(dn an))
+ ;; v: velocity
+ ;; d: distance
+ ;; a: azimut angle
+ ;; e: elevarion angle [missing elevations assumed 0.0]
+ (let ((z ())
+ (v ()))
+ (for-each
+ (lambda (p)
+ (let* ((d (car p))
+ (a (cadr p))
+ (e (if (and 3d (pair? (cddr p))) (caddr p) 0.0))
+ (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
+ (dxy (* d (real-part evec)))
+ (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (set! x (cons (* dxy (imag-part avec)) x))
+ (set! y (cons (* dxy (real-part avec)) y))
+ (set! z (cons (* d (imag-part evec)) z))
+ (set! v (cons (if 3d (fourth p) (third p)) v))))
+ points)
+ (list (reverse x) (reverse y) (reverse z) (reverse v)))
+
+ ;; decode a list of d:a:e components
+ (let ((len (length points)))
+ (if 3d
+ ;; decode a three dimensional list
+ ;; '(d0 a0 e0 d1 a1 e1 ... dn an en)
+ ;; d: distance
+ ;; a: azimut angle
+ ;; e: elevarion angle [missing elevations assumed 0.0]
+ (do ((z ())
+ (i 0 (+ i 3)))
+ ((>= i len)
+ (list (reverse x) (reverse y) (reverse z) (make-list (length x) #f)))
+ (let* ((d (points i))
+ (a (points (+ i 1)))
+ (e (points (+ i 2)))
+ (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
+ (dxy (* d (real-part evec)))
+ (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (set! x (cons (* dxy (imag-part avec)) x))
+ (set! y (cons (* dxy (real-part avec)) y))
+ (set! z (cons (* d (imag-part evec)) z))))
+
+ ;; decode a two dimensional list
+ ;; '(d0 a0 d1 a1 ... dn an)
+ ;; d: distance
+ ;; a: azimut angle
+ ;; e: elevarion angle [missing elevations assumed 0.0]
+ (do ((i 0 (+ i 2)))
+ ((>= i len)
+ (list (reverse x) (reverse y) (make-list (length x) 0.0) (make-list (length x) #f)))
+ (let* ((d (points i))
+ (a (points (+ i 1)))
+ (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (set! x (cons (* d (imag-part avec)) x))
+ (set! y (cons (* d (real-part avec)) y)))))))))))
+
(define (xparse-path xpath)
(let ((polar (bezier-polar xpath))
@@ -1023,7 +992,7 @@
(lambda (v)
(if (and (number? v)
(< v 0))
- (error 'mus-error "ERROR: velocities for path ~A must be all positive~%" (bezier-path xpath))))
+ (error 'mus-error "velocities for path ~A must be all positive~%" (bezier-path xpath))))
(bezier-v xpath))
(reset-fit xpath))
@@ -1043,55 +1012,50 @@
(define (nearest-point x0 y0 z0 x1 y1 z1 px py pz)
- (define (vmag a b c)
- (sqrt (+ (* a a) (* b b) (* c c))))
-
(define (vcos a0 b0 c0 a1 b1 c1)
(/ (+ (* a0 a1) (* b0 b1) (* c0 c1))
- (* (vmag a0 b0 c0) (vmag a1 b1 c1))))
+ (* (distance a0 b0 c0) (distance a1 b1 c1))))
(define (same a0 b0 c0 a1 b1 c1)
(and (= a0 a1) (= b0 b1) (= c0 c1)))
- (if (same x0 y0 z0 px py pz)
- (list x0 y0 z0)
- (if (same x1 y1 z1 px py pz)
- (list x1 y1 z1)
- (if (same x0 y0 z0 x1 y1 z1)
- (list x0 y0 z0)
- (let* ((xm0 (- x1 x0))
+ (cond ((same x0 y0 z0 px py pz) (list x0 y0 z0))
+ ((same x1 y1 z1 px py pz) (list x1 y1 z1))
+ ((same x0 y0 z0 x1 y1 z1) (list x0 y0 z0))
+ (else (let* ((xm0 (- x1 x0))
(ym0 (- y1 y0))
(zm0 (- z1 z0))
(xm1 (- px x0))
(ym1 (- py y0))
(zm1 (- pz z0))
- (p (* (vmag xm1 ym1 zm1) (vcos xm0 ym0 zm0 xm1 ym1 zm1)))
- (l (vmag xm0 ym0 zm0))
- (ratio (/ p l)))
+ (p (* (distance xm1 ym1 zm1) (vcos xm0 ym0 zm0 xm1 ym1 zm1)))
+ (k (distance xm0 ym0 zm0))
+ (ratio (/ p k)))
(list (+ x0 (* xm0 ratio))
(+ y0 (* ym0 ratio))
- (+ z0 (* zm0 ratio))))))))
+ (+ z0 (* zm0 ratio)))))))
;;; Bezier curve fitting auxilliary functions
(define path-ak-even #f)
(define path-ak-odd #f)
(define path-maxcoeff 8)
-(define path-gtab #f)
(define (make-a-even)
- (define (g m)
- (if (not path-gtab)
- (begin
- (set! path-gtab (make-vector path-maxcoeff))
- (set! (path-gtab 0) 1)
- (set! (path-gtab 1) -4)
- (do ((i 2 (+ i 1)))
- ((= i path-maxcoeff))
- (set! (path-gtab i) (- (* -4 (path-gtab (- i 1)))
- (path-gtab (- i 2)))))))
- (path-gtab m))
+ (define g
+ (let ((path-gtab #f))
+ (lambda (m)
+ (if (not path-gtab)
+ (begin
+ (set! path-gtab (make-vector path-maxcoeff))
+ (set! (path-gtab 0) 1)
+ (set! (path-gtab 1) -4)
+ (do ((i 2 (+ i 1)))
+ ((= i path-maxcoeff))
+ (set! (path-gtab i) (- (* -4 (path-gtab (- i 1)))
+ (path-gtab (- i 2)))))))
+ (path-gtab m))))
(set! path-ak-even (make-vector (- path-maxcoeff 1)))
(do ((m 1 (+ 1 m)))
@@ -1101,21 +1065,21 @@
((> k m))
(set! ((path-ak-even (- m 1)) (- k 1)) (* 1.0 (/ (- (g (- m k))) (g m)))))))
-(define path-ftab #f)
-
(define (make-a-odd)
- (define (f m)
- (if (not path-ftab)
- (begin
- (set! path-ftab (make-vector path-maxcoeff))
- (set! (path-ftab 0) 1)
- (set! (path-ftab 1) -3)
- (do ((i 2 (+ i 1)))
- ((= i path-maxcoeff))
- (set! (path-ftab i) (- (* -4 (path-ftab (- i 1)))
- (path-ftab (- i 2)))))))
- (path-ftab m))
+ (define f
+ (let ((path-ftab #f))
+ (lambda (m)
+ (if (not path-ftab)
+ (begin
+ (set! path-ftab (make-vector path-maxcoeff))
+ (set! (path-ftab 0) 1)
+ (set! (path-ftab 1) -3)
+ (do ((i 2 (+ i 1)))
+ ((= i path-maxcoeff))
+ (set! (path-ftab i) (- (* -4 (path-ftab (- i 1)))
+ (path-ftab (- i 2)))))))
+ (path-ftab m))))
(set! path-ak-odd (make-vector (- path-maxcoeff 1)))
(do ((m 1 (+ 1 m)))
@@ -1193,17 +1157,11 @@
((path-ak-even (- un 2)) (- k 1))))
(define (ref z j i)
- (if (> i n)
- ((z j) (- i n))
- (if (< i 0)
- ((z j) (+ i n))
- (if (= i n)
- (- ((z j) n)
- ((d j) n))
- (if (= i 0)
- (+ ((z j) 0)
- ((d j) 0))
- ((z j) i))))))
+ (cond ((> i n) ((z j) (- i n)))
+ ((< i 0) ((z j) (+ i n)))
+ ((= i n) (- ((z j) n) ((d j) n)))
+ ((= i 0) (+ ((z j) 0) ((d j) 0)))
+ (else ((z j) i))))
;; forced initial direction
(if (initial-direction path)
@@ -1266,75 +1224,75 @@
(xparse-path path))
(let ((points (length (bezier-x path))))
- (if (> points 2)
- (let* ((vals (calculate-fit path))
- (n (car vals))
- (p (cadr vals))
- (d (caddr vals)))
- (let ((c (bezier-curvature path))
- (cs (make-vector n)))
- ;; setup the curvatures array
- (if (or (not c) (null? c)) ; no curvature specified, default is 1.0
- (do ((i 0 (+ i 1)))
- ((= i n))
- (set! (cs i) (list 1.0 1.0)))
- (if (number? c) ; same curvature for all segments
- (do ((i 0 (+ i 1)))
- ((= i n))
- (set! (cs i) (list c c)))
- (if (and (pair? c) (= n (length c))) ; list of curvatures
- (let ((i 0))
- (for-each
- (lambda (ci)
- (set! (cs i) (if (pair? ci)
- (if (not (= (length ci) 2))
- (error 'mus-error "ERROR: curvature sublist must have two elements ~A~%" ci)
- ci)
- (list ci ci)))
- (set! i (+ i 1)))
- c))
- (error 'mus-error "ERROR: bad curvature argument ~A to path, need ~A elements~%" c n))))
-
- ;; calculate control points
- (let ((xc ())
- (yc ())
- (zc ()))
- (do ((i 0 (+ i 1)))
- ((= i n))
-
- (set! xc (cons (list ((p 0) i)
- (+ ((p 0) i) (* ((d 0) i) (car (cs i))))
- (- ((p 0) (+ i 1)) (* ((d 0) (+ i 1)) (cadr (cs i))))
- ((p 0) (+ i 1))) xc))
- (set! yc (cons (list ((p 1) i)
- (+ ((p 1) i) (* ((d 1) i) (car (cs i))))
- (- ((p 1) (+ i 1)) (* ((d 1) (+ i 1)) (cadr (cs i))))
- ((p 1) (+ i 1))) yc))
- (set! zc (cons (list ((p 2) i)
- (+ ((p 2) i) (* ((d 2) i) (car (cs i))))
- (- ((p 2) (+ i 1)) (* ((d 2) (+ i 1)) (cadr (cs i))))
- ((p 2) (+ i 1))) zc)))
- (set! (bezier-bx path) (reverse xc))
- (set! (bezier-by path) (reverse yc))
- (set! (bezier-bz path) (reverse zc)))))
-
- (if (= points 2)
- ;; just a line, stays a line
- (let ((x1 (car (bezier-x path)))
- (x2 (cadr (bezier-x path)))
- (y1 (car (bezier-y path)))
- (y2 (cadr (bezier-y path)))
- (z1 (car (bezier-z path)))
- (z2 (cadr (bezier-z path))))
- (set! (bezier-bx path) (list (list x1 x1 x2 x2)))
- (set! (bezier-by path) (list (list y1 y1 y2 y2)))
- (set! (bezier-bz path) (list (list z1 z1 z2 z2))))
- (if (= points 1)
- ;; just one point, bezier won't do much here
- (begin
- (set! (bezier-bx path) ())
- (set! (bezier-by path) ())
- (set! (bezier-bz path) ())))))
+ (cond ((> points 2)
+ (let* ((vals (calculate-fit path))
+ (n (car vals))
+ (p (cadr vals))
+ (d (caddr vals)))
+ (let ((c (bezier-curvature path))
+ (cs (make-vector n)))
+ ;; setup the curvatures array
+ (cond ((memq c '(#f ())) ; no curvature specified, default is 1.0
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (set! (cs i) (list 1.0 1.0))))
+ ((number? c) ; same curvature for all segments
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (set! (cs i) (list c c))))
+ ((and (pair? c) (= n (length c))) ; list of curvatures
+ (let ((i 0))
+ (for-each
+ (lambda (ci)
+ (set! (cs i) (if (pair? ci)
+ (if (= (length ci) 2)
+ ci
+ (error 'mus-error "curvature sublist must have two elements ~A~%" ci))
+ (list ci ci)))
+ (set! i (+ i 1)))
+ c)))
+ (else (error 'mus-error "bad curvature argument ~A to path, need ~A elements~%" c n)))
+
+ ;; calculate control points
+ (let ((xc ())
+ (yc ())
+ (zc ()))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+
+ (set! xc (cons (list ((p 0) i)
+ (+ ((p 0) i) (* ((d 0) i) (car (cs i))))
+ (- ((p 0) (+ i 1)) (* ((d 0) (+ i 1)) (cadr (cs i))))
+ ((p 0) (+ i 1))) xc))
+ (set! yc (cons (list ((p 1) i)
+ (+ ((p 1) i) (* ((d 1) i) (car (cs i))))
+ (- ((p 1) (+ i 1)) (* ((d 1) (+ i 1)) (cadr (cs i))))
+ ((p 1) (+ i 1))) yc))
+ (set! zc (cons (list ((p 2) i)
+ (+ ((p 2) i) (* ((d 2) i) (car (cs i))))
+ (- ((p 2) (+ i 1)) (* ((d 2) (+ i 1)) (cadr (cs i))))
+ ((p 2) (+ i 1))) zc)))
+ (set! (bezier-bx path) (reverse xc))
+ (set! (bezier-by path) (reverse yc))
+ (set! (bezier-bz path) (reverse zc))))))
+
+ ((= points 2)
+ ;; just a line, stays a line
+ (let ((x1 (car (bezier-x path)))
+ (x2 (cadr (bezier-x path)))
+ (y1 (car (bezier-y path)))
+ (y2 (cadr (bezier-y path)))
+ (z1 (car (bezier-z path)))
+ (z2 (cadr (bezier-z path))))
+ (set! (bezier-bx path) (list (list x1 x1 x2 x2)))
+ (set! (bezier-by path) (list (list y1 y1 y2 y2)))
+ (set! (bezier-bz path) (list (list z1 z1 z2 z2)))))
+ ((= points 1)
+ ;; just one point, bezier won't do much here
+ (set! (bezier-bx path) ())
+ (set! (bezier-by path) ())
+ (set! (bezier-bz path) ())))
+
(reset-rendering path)))
(else
@@ -1380,20 +1338,20 @@
;; not enough points to fit a closed path
(let ((xc ())
(yc ())
- (zc ())
- (len (min (length (bezier-x path)) (length (bezier-y path)) (length (bezier-z path)))))
- (do ((i 0 (+ i 1)))
- ((>= i len))
- (let ((x1 ((bezier-x path) i))
- (x2 ((bezier-x path) (+ i 1)))
- (y1 ((bezier-y path) i))
- (y2 ((bezier-y path) (+ i 1)))
- (z1 ((bezier-z path) i))
- (z2 ((bezier-z path) (+ i 1))))
- (set! xc (cons (list x1 x1 x2 x2) xc))
- (set! yc (cons (list y1 y1 y2 y2) yc))
- (set! zc (cons (list z1 z1 z2 z2) zc))))
- (format *stderr* "[fit-path:closed-path] not enough points to do bezier fit (~A points)" len)
+ (zc ()))
+ (let ((len (min (length (bezier-x path)) (length (bezier-y path)) (length (bezier-z path)))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (let ((x1 ((bezier-x path) i))
+ (x2 ((bezier-x path) (+ i 1)))
+ (y1 ((bezier-y path) i))
+ (y2 ((bezier-y path) (+ i 1)))
+ (z1 ((bezier-z path) i))
+ (z2 ((bezier-z path) (+ i 1))))
+ (set! xc (cons (list x1 x1 x2 x2) xc))
+ (set! yc (cons (list y1 y1 y2 y2) yc))
+ (set! zc (cons (list z1 z1 z2 z2) zc))))
+ (format *stderr* "[fit-path:closed-path] not enough points to do bezier fit (~A points)" len))
(set! (bezier-bx path) (reverse xc))
(set! (bezier-by path) (reverse yc))
(set! (bezier-bz path) (reverse zc))))
@@ -1439,7 +1397,7 @@
(height '(0 0 1 0))
(velocity '(0 1 1 1)))
(if (and total-angle (pair? turns))
- (error 'mus-error "ERROR: can't specify total-angle [~A] and turns [~A] at the same time for the spiral path~%" total-angle turns))
+ (error 'mus-error "can't specify total-angle [~A] and turns [~A] at the same time for the spiral path~%" total-angle turns))
(list 'spiral-path () () () () () () () () () () path-3d #f
start-angle total-angle
@@ -1455,55 +1413,54 @@
(fit-path path))
(let ((xrx ()) (xry ()) (xrz ()) (xrv ()))
- (define (bezier-point u c)
- ;; Evaluate a point at parameter u in bezier segment
- (let ((u1 (- 1 u))
- (cr (vector (make-vector 3 0.0) (make-vector 3 0.0) (make-vector 3 0.0))))
- (do ((j 0 (+ j 1)))
- ((= j 3))
- (set! ((cr 0) j) (+ (* u1 ((c 0) j)) (* u ((c 0) (+ j 1)))))
- (set! ((cr 1) j) (+ (* u1 ((c 1) j)) (* u ((c 1) (+ j 1)))))
- (set! ((cr 2) j) (+ (* u1 ((c 2) j)) (* u ((c 2) (+ j 1))))))
- (do ((i 1 (- i 1)))
- ((< i 0))
- (do ((j 0 (+ j 1)))
- ((> j i))
-
- (set! ((cr 0) j) (+ (* u1 ((cr 0) j)) (* u ((cr 0) (+ j 1)))))
- (set! ((cr 1) j) (+ (* u1 ((cr 1) j)) (* u ((cr 1) (+ j 1)))))
- (set! ((cr 2) j) (+ (* u1 ((cr 2) j)) (* u ((cr 2) (+ j 1)))))
- ))
- (list ((cr 0) 0)
- ((cr 1) 0)
- ((cr 2) 0))))
-
(define (berny xl yl zl xh yh zh ul u uh c err)
;; Create a linear segment rendering of a bezier segment
+
+ (define (bezier-point u c)
+ ;; Evaluate a point at parameter u in bezier segment
+ (let ((u1 (- 1 u))
+ (cr (vector (make-vector 3 0.0) (make-vector 3 0.0) (make-vector 3 0.0))))
+ (do ((j 0 (+ j 1)))
+ ((= j 3))
+ (set! ((cr 0) j) (+ (* u1 ((c 0) j)) (* u ((c 0) (+ j 1)))))
+ (set! ((cr 1) j) (+ (* u1 ((c 1) j)) (* u ((c 1) (+ j 1)))))
+ (set! ((cr 2) j) (+ (* u1 ((c 2) j)) (* u ((c 2) (+ j 1))))))
+ (do ((i 1 (- i 1)))
+ ((< i 0))
+ (do ((j 0 (+ j 1)))
+ ((> j i))
+ (set! ((cr 0) j) (+ (* u1 ((cr 0) j)) (* u ((cr 0) (+ j 1)))))
+ (set! ((cr 1) j) (+ (* u1 ((cr 1) j)) (* u ((cr 1) (+ j 1)))))
+ (set! ((cr 2) j) (+ (* u1 ((cr 2) j)) (* u ((cr 2) (+ j 1)))))))
+ (list ((cr 0) 0)
+ ((cr 1) 0)
+ ((cr 2) 0))))
+
(let* ((vals (bezier-point u c))
(x (car vals))
(y (cadr vals))
- (z (caddr vals)))
- (let* ((val1 (nearest-point xl yl zl xh yh zh x y z))
- (xn (car val1))
- (yn (cadr val1))
- (zn (caddr val1)))
- (if (> (distance (- xn x) (- yn y) (- zn z)) err)
- (let* ((val2 (berny xl yl zl x y z ul (/ (+ ul u) 2) u c err))
- (xi (car val2))
- (yi (cadr val2))
- (zi (caddr val2)))
- (let* ((val3 (berny x y z xh yh zh u (/ (+ u uh) 2) uh c err))
- (xj (car val3))
- (yj (cadr val3))
- (zj (caddr val3)))
- (list (append xi (list x) xj)
- (append yi (list y) yj)
- (append zi (list z) zj))))
- (list () () ())))))
+ (z (caddr vals))
+ (val1 (nearest-point xl yl zl xh yh zh x y z))
+ (xn (car val1))
+ (yn (cadr val1))
+ (zn (caddr val1)))
+ (if (<= (distance (- xn x) (- yn y) (- zn z)) err)
+ (list () () ())
+ (let* ((val2 (berny xl yl zl x y z ul (/ (+ ul u) 2) u c err))
+ (xi (car val2))
+ (yi (cadr val2))
+ (zi (caddr val2))
+ (val3 (berny x y z xh yh zh u (/ (+ u uh) 2) uh c err))
+ (xj (car val3))
+ (yj (cadr val3))
+ (zj (caddr val3)))
+ (list (append xi (list x) xj)
+ (append yi (list y) yj)
+ (append zi (list z) zj))))))
;; Create linear segment approximations of the bezier segments
;; make sure there are initial and final velocity values
- (if (not (listp (bezier-v path)))
+ (if (not (pair? (bezier-v path)))
(set! (bezier-v path) (list 1 1))
(if (not (car (bezier-v path)))
(begin
@@ -1534,53 +1491,52 @@
(yi-bz (car y-bz))
(yf-bz (y-bz (- (length y-bz) 1)))
(zi-bz (car z-bz))
- (zf-bz (z-bz (- (length z-bz) 1))))
- (let* ((vals (berny xi-bz yi-bz zi-bz xf-bz yf-bz zf-bz 0.0 0.5 1.0
- (vector (apply vector x-bz)
- (apply vector y-bz)
- (apply vector z-bz))
- (bezier-error path)))
- (xs (car vals))
- (ys (cadr vals))
- (zs (caddr vals)))
-
- ;; approximate the bezier curve with linear segments
- (set! xrx (append xrx (list xi-bz) xs))
- (set! xry (append xry (list yi-bz) ys))
- (set! xrz (append xrz (list zi-bz) zs))
-
- ;; accumulate intermediate unknown velocities as nils
- (set! xrv (append xrv (list vi-bz) (make-list-1 (length xs) #f)))
- (if (= i (- len 1))
- (begin
- ;; add the last point
- (set! xrx (append xrx (list xf-bz)))
- (set! xry (append xry (list yf-bz)))
- (set! xrz (append xrz (list zf-bz)))
- (set! xrv (append xrv (list vf-bz)))
- ))))))
+ (zf-bz (z-bz (- (length z-bz) 1)))
+ (vals (berny xi-bz yi-bz zi-bz xf-bz yf-bz zf-bz 0.0 0.5 1.0
+ (vector (apply vector x-bz)
+ (apply vector y-bz)
+ (apply vector z-bz))
+ (bezier-error path)))
+ (xs (car vals))
+ (ys (cadr vals))
+ (zs (caddr vals)))
+
+ ;; approximate the bezier curve with linear segments
+ (set! xrx (append xrx (list xi-bz) xs))
+ (set! xry (append xry (list yi-bz) ys))
+ (set! xrz (append xrz (list zi-bz) zs))
+
+ ;; accumulate intermediate unknown velocities as nils
+ (set! xrv (append xrv (list vi-bz) (make-list (length xs) #f)))
+ (if (= i (- len 1))
+ (begin
+ ;; add the last point
+ (set! xrx (append xrx (list xf-bz)))
+ (set! xry (append xry (list yf-bz)))
+ (set! xrz (append xrz (list zf-bz)))
+ (set! xrv (append xrv (list vf-bz))))))))
;; calculate times for each velocity segment
- (let ((len (- (length xrx) 1))
- (ti 0)
- (times (list 0))
- (xseg (list (xrx 0)))
- (yseg (list (xry 0)))
- (zseg (list (xrz 0)))
- (vseg (list (xrv 0)))
- (vi (xrv 0)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let ((x (xrx (+ i 1)))
- (y (xry (+ i 1)))
- (z (xrz (+ i 1)))
- (v (xrv (+ i 1))))
- (set! xseg (append xseg (list x)))
- (set! yseg (append yseg (list y)))
- (set! zseg (append zseg (list z)))
- (set! vseg (append vseg (list v)))
-
- (if v
+ (let ((ti 0)
+ (times (list 0)))
+ (let ((len (- (length xrx) 1))
+ (xseg (list (xrx 0)))
+ (yseg (list (xry 0)))
+ (zseg (list (xrz 0)))
+ (vseg (list (xrv 0)))
+ (vi (xrv 0)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (let ((x (xrx (+ i 1)))
+ (y (xry (+ i 1)))
+ (z (xrz (+ i 1)))
+ (v (xrv (+ i 1))))
+ (set! xseg (append xseg (list x)))
+ (set! yseg (append yseg (list y)))
+ (set! zseg (append zseg (list z)))
+ (set! vseg (append vseg (list v)))
+
+ (when v
(let ((dseg (list))
(sum 0.0)
(len (- (length xseg) 1)))
@@ -1598,17 +1554,16 @@
(let ((df (car dseg)))
(set! dseg (reverse dseg))
- (let* ((tseg ())
- (vf v)
- (a (/ (* (- vf vi) (+ vf vi)) df 4)))
- (if (= vi 0.0) (set! vi 1))
- (for-each
- (lambda (d)
- (set! tseg (cons (+ ti (if (= vf vi)
- (/ d vi)
- (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))
- tseg)))
- dseg)
+ (let ((tseg ()))
+ (let ((a (/ (* (- v vi) (+ v vi)) df 4)))
+ (if (= vi 0.0) (set! vi 1))
+ (for-each
+ (lambda (d)
+ (set! tseg (cons (+ ti (if (= v vi)
+ (/ d vi)
+ (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))
+ tseg)))
+ dseg))
(set! ti (car tseg))
(set! tseg (reverse tseg))
@@ -1617,8 +1572,7 @@
(set! yseg (list y))
(set! zseg (list z))
(set! vseg (list v))
- (set! vi v)))))
- ))
+ (set! vi v))))))))
(set! (path-rx path) xrx)
(set! (path-ry path) xry)
@@ -1686,40 +1640,39 @@
(set! zseg (append zseg (list z)))
(set! vseg (append vseg (list v)))
- (if (number? v) ; when v
- (let ((sofar 0.0)
- (dseg ())
- (len (- (length xseg) 1)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let ((xsi (xseg i))
- (ysi (yseg i))
- (zsi (zseg i))
- (xsf (xseg (+ i 1)))
- (ysf (yseg (+ i 1)))
- (zsf (zseg (+ i 1))))
- (set! sofar (+ sofar (distance (- xsf xsi) (- ysf ysi) (- zsf zsi))))
- (set! dseg (cons sofar dseg))))
- (let ((df (car dseg)))
- (set! dseg (reverse dseg))
- (let* ((tseg ())
- (vf v)
- (a (/ (* (- vf vi) (+ vf vi)) df 4)))
+ (when (number? v)
+ (let ((sofar 0.0)
+ (dseg ())
+ (len (- (length xseg) 1)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (let ((xsi (xseg i))
+ (ysi (yseg i))
+ (zsi (zseg i))
+ (xsf (xseg (+ i 1)))
+ (ysf (yseg (+ i 1)))
+ (zsf (zseg (+ i 1))))
+ (set! sofar (+ sofar (distance (- xsf xsi) (- ysf ysi) (- zsf zsi))))
+ (set! dseg (cons sofar dseg))))
+ (let ((df (car dseg)))
+ (set! dseg (reverse dseg))
+ (let ((tseg ()))
+ (let ((a (/ (* (- v vi) (+ v vi)) df 4)))
(for-each
(lambda (d)
- (set! tseg (cons (+ ti (if (= vf vi)
+ (set! tseg (cons (+ ti (if (= v vi)
(/ d vi)
(/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))
tseg)))
- dseg)
- (set! ti (car tseg))
- (set! tseg (reverse tseg))
- (set! times (append times tseg))
- (set! xseg (list x))
- (set! yseg (list y))
- (set! zseg (list z))
- (set! vseg (list v))
- (set! vi v)))))))
+ dseg))
+ (set! ti (car tseg))
+ (set! tseg (reverse tseg))
+ (set! times (append times tseg))
+ (set! xseg (list x))
+ (set! yseg (list y))
+ (set! zseg (list z))
+ (set! vseg (list v))
+ (set! vi v)))))))
(set! (path-rt path) (let ((val ())
(tf (times (- (length times) 1))))
@@ -1738,7 +1691,7 @@
(* (/ (spiral-total-angle path) dlocsig-one-turn) 2 pi)
(if (spiral-turns path)
(* (spiral-turns path) 2 pi)
- (error 'mus-error "ERROR: a spiral-path needs either a total-angle or turns, none specified~%"))))
+ (error 'mus-error "a spiral-path needs either a total-angle or turns, none specified~%"))))
(steps (abs (/ total (* (/ (spiral-step-angle path) dlocsig-one-turn) 2 pi))))
(step (/ total (ceiling steps)
(if (< (spiral-step-angle path) 0) -1 1)))
@@ -1805,11 +1758,10 @@
(define (render-path path)
- (cond ((memq (car path) '(bezier-path open-bezier-path))
- (bezier-render path))
- ((eq? (car path) 'literal-path)
- (literal-render path))
- (#t (spiral-render path))))
+ (case (car path)
+ ((bezier-path open-bezier-path) (bezier-render path))
+ ((literal-path) (literal-render path))
+ (else (spiral-render path))))
@@ -1836,7 +1788,7 @@
;; (http://www.magic-software.com/)
(define (normalize a b c)
- (let ((mag (sqrt (+ (* a a) (* b b) (* c c)))))
+ (let ((mag (distance a b c)))
(list (/ a mag) (/ b mag) (/ c mag))))
(let* ((vals (normalize x y z))
@@ -1887,71 +1839,71 @@
(yc (path-y path))
(zc (path-z path)))
(if (and rotation-center (not (= (length rotation-center) 3)))
- (error 'mus-error "ERROR: rotation center has to have all three coordinates~%"))
+ (error 'mus-error "rotation center has to have all three coordinates~%"))
(if (and rotation-axis (not (= (length rotation-axis) 3)))
- (error 'mus-error "ERROR: rotation axis has to have all three coordinates~%"))
- (let ((len (length xc))
- (xtr ())
+ (error 'mus-error "rotation axis has to have all three coordinates~%"))
+ (do ((xtr ())
(ytr ())
- (ztr ()))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let* ((x (xc i))
- (y (yc i))
- (z (zc i))
- (xw x)
- (yw y)
- (zw z))
+ (ztr ())
+ (len (length xc))
+ (i 0 (+ i 1)))
+ ((= i len)
+ (set! (path-tx path) (reverse xtr))
+ (set! (path-ty path) (reverse ytr))
+ (set! (path-tz path) (reverse ztr)))
+
+ (let* ((x (xc i))
+ (y (yc i))
+ (z (zc i))
+ (xw x)
+ (yw y)
+ (zw z))
+ (when rotation
;; rotating around non-triple zero? translate first
- (if (and rotation-center rotation)
- (begin
- (set! xw (- xw (car rotation-center)))
- (set! yw (- yw (cadr rotation-center)))
- (set! zw (- zw (third rotation-center)))))
+ (when rotation-center
+ (set! xw (- xw (car rotation-center)))
+ (set! yw (- yw (cadr rotation-center)))
+ (set! zw (- zw (third rotation-center))))
;; rotation
- (if rotation
- (let ((xr (+ (* ((matrix 0) 0) xw)
- (* ((matrix 1) 0) yw)
- (* ((matrix 2) 0) zw)))
- (yr (+ (* ((matrix 0) 1) xw)
- (* ((matrix 1) 1) yw)
- (* ((matrix 2) 1) zw)))
- (zr (+ (* ((matrix 0) 2) xw)
- (* ((matrix 1) 2) yw)
- (* ((matrix 2) 2) zw))))
- (set! xw xr)
- (set! yw yr)
- (set! zw zr)))
+ (let ((xr (+ (* ((matrix 0) 0) xw)
+ (* ((matrix 1) 0) yw)
+ (* ((matrix 2) 0) zw)))
+ (yr (+ (* ((matrix 0) 1) xw)
+ (* ((matrix 1) 1) yw)
+ (* ((matrix 2) 1) zw)))
+ (zr (+ (* ((matrix 0) 2) xw)
+ (* ((matrix 1) 2) yw)
+ (* ((matrix 2) 2) zw))))
+ (set! xw xr)
+ (set! yw yr)
+ (set! zw zr))
;; rotating around non-triple zero? untranslate
- (if (and rotation-center rotation)
- (begin
- (set! xw (+ xw (car rotation-center)))
- (set! yw (+ yw (cadr rotation-center)))
- (set! zw (+ zw (third rotation-center)))))
- ;; scaling
- (if scaling
- (begin
- (set! xw (* xw (car scaling)))
- (if (cadr scaling)
- (set! yw (* yw (cadr scaling))))
- (if (third scaling)
- (set! zw (* zw (third scaling))))))
- ;; translating
- (if translation
- (begin
- (set! xw (+ xw (car translation)))
- (if (cadr translation)
- (set! yw (+ yw (cadr translation))))
- (if (third translation)
- (set! zw (+ zw (third translation))))))
- ;; collect the points
- (set! xtr (cons xw xtr))
- (set! ytr (cons yw ytr))
- (set! ztr (cons zw ztr))))
+ (when rotation-center
+ (set! xw (+ xw (car rotation-center)))
+ (set! yw (+ yw (cadr rotation-center)))
+ (set! zw (+ zw (third rotation-center)))))
+
+ ;; scaling
+ (when scaling
+ (set! xw (* xw (car scaling)))
+ (if (cadr scaling)
+ (set! yw (* yw (cadr scaling))))
+ (if (third scaling)
+ (set! zw (* zw (third scaling)))))
+
+ ;; translating
+ (when translation
+ (set! xw (+ xw (car translation)))
+ (if (cadr translation)
+ (set! yw (+ yw (cadr translation))))
+ (if (third translation)
+ (set! zw (+ zw (third translation)))))
+
+ ;; collect the points
+ (set! xtr (cons xw xtr))
+ (set! ytr (cons yw ytr))
+ (set! ztr (cons zw ztr)))))
- (set! (path-tx path) (reverse xtr))
- (set! (path-ty path) (reverse ytr))
- (set! (path-tz path) (reverse ztr))))
(begin
;; if there's no transformation just copy the rendered path
(set! (path-tt path) (copy (path-rt path)))
@@ -1985,19 +1937,20 @@
(define* (mirror-path path (axis 'y) (around 0))
(if (not-transformed path)
(transform-path path))
- (if (eq? axis 'y)
- (let ((val ()))
- (for-each
- (lambda (x)
- (set! val (cons (- around x) val)))
- (path-tx path))
- (set! (path-tx path) (reverse val)))
- (let ((val ()))
- (for-each
- (lambda (y)
- (set! val (cons (- around y) val)))
- (path-ty path))
- (set! (path-ty path) (reverse val))))
+ (let ((val ()))
+ (if (eq? axis 'y)
+ (begin
+ (for-each
+ (lambda (x)
+ (set! val (cons (- around x) val)))
+ (path-tx path))
+ (set! (path-tx path) (reverse val)))
+ (begin
+ (for-each
+ (lambda (y)
+ (set! val (cons (- around y) val)))
+ (path-ty path))
+ (set! (path-ty path) (reverse val)))))
path)
;;; Change the times of the rendered envelope so that the velocity is constant
@@ -2028,25 +1981,25 @@
(start-time (car tcoords))
(end-time (tcoords (- (length tcoords) 1)))
(total-time (- end-time start-time))
- (velocity (/ total-distance total-time)))
- (let ((len (length xcoords))
- (now ())
- (dist 0.0))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let ((xp (xcoords i))
- (x (xcoords (+ i 1)))
- (yp (ycoords i))
- (y (ycoords (+ i 1)))
- (zp (zcoords i))
- (z (zcoords (+ i 1))))
- (set! dist (+ dist (distance (- x xp) (- y yp) (- z zp))))
- (set! now (cons (/ dist velocity) now))))
- (set! now (reverse now))
- (set! (path-rt path) (append (list start-time) now))
- (set! (path-tx path) (copy (path-rx path)))
- (set! (path-ty path) (copy (path-ry path)))
- (set! (path-tz path) (copy (path-rz path)))))
+ (velocity (/ total-distance total-time))
+ (now ()))
+ (do ((dist 0.0)
+ (len (length xcoords))
+ (i 0 (+ i 1)))
+ ((= i len))
+ (let ((xp (xcoords i))
+ (x (xcoords (+ i 1)))
+ (yp (ycoords i))
+ (y (ycoords (+ i 1)))
+ (zp (zcoords i))
+ (z (zcoords (+ i 1))))
+ (set! dist (+ dist (distance (- x xp) (- y yp) (- z zp))))
+ (set! now (cons (/ dist velocity) now))))
+ (set! now (reverse now))
+ (set! (path-rt path) (cons start-time now))
+ (set! (path-tx path) (copy (path-rx path)))
+ (set! (path-ty path) (copy (path-ry path)))
+ (set! (path-tz path) (copy (path-rz path))))
path)))
@@ -2073,34 +2026,33 @@
rev-channels)
(if (null? start-time)
- (error 'mus-error "ERROR: a start time is required in make-dlocsig~%"))
+ (error 'mus-error "a start time is required in make-dlocsig~%"))
(if (null? duration)
- (error 'mus-error "ERROR: a duration has to be specified in make-dlocsig~%"))
+ (error 'mus-error "a duration has to be specified in make-dlocsig~%"))
;; check to see if we have the right number of channels for b-format ambisonics
(if (= render-using ambisonics)
(begin
(if (or (> ambisonics-h-order 3)
(> ambisonics-v-order 3))
- (error 'mus-error "ERROR: ambisonics encoding is currently limited to third order components~%"))
+ (error 'mus-error "ambisonics encoding is currently limited to third order components~%"))
(let ((channels (ambisonics-channels ambisonics-h-order ambisonics-v-order)))
(if (< (or out-channels (mus-channels *output*)) channels)
- (error 'mus-error "ERROR: ambisonics number of channels is wrong, dlocsig needs ~A output channels for h:~A, v:~A order (current number is ~A)~%"
+ (error 'mus-error "ambisonics number of channels is wrong, dlocsig needs ~A output channels for h:~A, v:~A order (current number is ~A)~%"
channels ambisonics-h-order ambisonics-v-order (or out-channels (mus-channels *output*)))))))
(if (not out-channels)
(if *output*
(set! out-channels (channels *output*))
(begin
- (format #t "WARNING: no *output*? Will set out-channels to 2~%")
+ (format () "warning: no *output*? Will set out-channels to 2~%")
(set! out-channels 2))))
(if (not rev-channels)
(set! rev-channels (if *reverb* (channels *reverb*) 0)))
(let* (;; speaker configuration for current number of channels
- (speakers (if (= render-using ambisonics)
- #f
- (get-speaker-configuration out-channels)))
+ (speakers (and (not (= render-using ambisonics))
+ (get-speaker-configuration out-channels)))
;; array of gains -- envelopes
(channel-gains (make-vector out-channels ()))
@@ -2117,9 +2069,6 @@
(tpoints (path-time path))
;; speed of sound expressed in terms of path time coordinates
- (speed-limit (/ (* dlocsig-speed-of-sound
- (- (car (last tpoints)) (car tpoints)))
- duration))
(start 0)
;(end 0)
(dly ())
@@ -2127,10 +2076,6 @@
(real-dur 0)
(prev-time #f)
(prev-dist #f)
- (prev-group #f)
- (prev-x #f)
- (prev-y #f)
- (prev-z #f)
(first-dist #f)
(last-dist #f)
(min-dist #f)
@@ -2148,9 +2093,6 @@
(run-end #f)
;; channel offsets in output stream for ambisonics
;; (depends on horizontal and vertical order, default is h=1,v=1)
- (w-offset 0)
- (x-offset 1)
- (y-offset 2)
(z-offset #f)
(r-offset #f)
(s-offset #f)
@@ -2165,407 +2107,417 @@
(p-offset #f)
(q-offset #f))
- (if (= render-using ambisonics)
- ;; calculate output channel offsets for ambisonics rendering
- (let ((offset 3))
- ;; the default is at least a horizontal order of 1
- (if (>= ambisonics-v-order 1)
- (begin
- ;; add Z
- (set! z-offset offset)
- (set! offset (+ offset 1))))
- (if (>= ambisonics-v-order 2)
- (begin
- ;; add R S T
- (set! r-offset offset)
- (set! s-offset (+ offset 1))
- (set! t-offset (+ offset 2))
- (set! offset (+ offset 3))))
- (if (>= ambisonics-h-order 2)
- (begin
- ;; add U V
- (set! u-offset offset)
- (set! v-offset (+ offset 1))
- (set! offset (+ offset 2))))
- (if (>= ambisonics-v-order 3)
- (begin
- ;; add K L M N O
- (set! k-offset offset)
- (set! l-offset (+ offset 1))
- (set! m-offset (+ offset 2))
- (set! n-offset (+ offset 3))
- (set! o-offset (+ offset 4))
- (set! offset (+ offset 5))))
- (if (>= ambisonics-h-order 3)
- (begin
- ;; add P Q
- (set! p-offset offset)
- (set! q-offset (+ offset 1)))
- (set! offset (+ offset 2)))))
-
- (define (equalp-intersection l1 l2)
- (if (null? l2)
- l2
- (let loop1 ((l1 l1)
- (result ()))
- (cond ((null? l1)
- (reverse! result))
- ((member (car l1) l2)
- (loop1 (cdr l1)
- (cons (car l1)
- result)))
- (else (loop1 (cdr l1)
- result))))))
+ (when (= render-using ambisonics)
+ ;; calculate output channel offsets for ambisonics rendering
+ (let ((offset 3))
+ ;; the default is at least a horizontal order of 1
+ (if (>= ambisonics-v-order 1)
+ (begin
+ ;; add Z
+ (set! z-offset offset)
+ (set! offset (+ offset 1))))
+ (if (>= ambisonics-v-order 2)
+ (begin
+ ;; add R S T
+ (set! r-offset offset)
+ (set! s-offset (+ offset 1))
+ (set! t-offset (+ offset 2))
+ (set! offset (+ offset 3))))
+ (if (>= ambisonics-h-order 2)
+ (begin
+ ;; add U V
+ (set! u-offset offset)
+ (set! v-offset (+ offset 1))
+ (set! offset (+ offset 2))))
+ (if (>= ambisonics-v-order 3)
+ (begin
+ ;; add K L M N O
+ (set! k-offset offset)
+ (set! l-offset (+ offset 1))
+ (set! m-offset (+ offset 2))
+ (set! n-offset (+ offset 3))
+ (set! o-offset (+ offset 4))
+ (set! offset (+ offset 5))))
+ (if (>= ambisonics-h-order 3)
+ (begin
+ ;; add P Q
+ (set! p-offset offset)
+ (set! q-offset (+ offset 1)))
+ (set! offset (+ offset 2)))))
(define (dist->samples d) (round (* d (/ *clm-srate* dlocsig-speed-of-sound))))
;; (define (dist->seconds d) (/ d dlocsig-speed-of-sound))
(define (time->samples time) (round (* time *clm-srate*)))
- (define (transition-point-3 vert-a vert-b xa ya za xb yb zb)
- (define (cross v1 v2)
- (list (- (* (cadr v1) (third v2))
- (* (third v1) (cadr v2)))
- (- (* (third v1) (car v2))
- (* (car v1) (third v2)))
- (- (* (car v1) (cadr v2))
- (* (cadr v1) (car v2)))))
- (define (dot v1 v2)
- (+ (* (car v1) (car v2))
- (* (cadr v1) (cadr v2))
- (* (third v1) (third v2))))
- (define (sub v1 v2)
- (list (- (car v1) (car v2))
- (- (cadr v1) (cadr v2))
- (- (third v1) (third v2))))
- (define (add v1 v2)
- (list (+ (car v1) (car v2))
- (+ (cadr v1) (cadr v2))
- (+ (third v1) (third v2))))
- (define (scale v1 c)
- (list (* (car v1) c)
- (* (cadr v1) c)
- (* (third v1) c)))
-
- (let* ((tolerance 1.0e-6)
- (line-b (list xa ya za))
- (line-m (sub (list xb yb zb) line-b))
- (normal (cross vert-a vert-b))
- (denominator (dot normal line-m)))
- (if (<= (abs denominator) tolerance)
- #f
- (add line-b (scale line-m (/ (- (dot normal line-b)) denominator))))))
-
- ;; calculate transition point between two adjacent two-speaker groups
- ;; original line intersection code from Graphic Gems III
- (define (transition-point-2 vert xa ya xb yb)
- (let* ((Ax (car vert))
- (Bx (- xa xb))
- (Ay (cadr vert))
- (By (- ya yb))
- (Cx (- xa))
- (Cy (- ya))
- (d (- (* By Cx) (* Bx Cy)))
- (f (- (* Ay Bx) (* Ax By))))
- (and (not (= f 0))
- (list (/ (* d Ax) f)
- (/ (* d Ay) f)))))
-
;; calculate speaker gains for group
(define (calculate-gains x y z group)
(let ((zero-coord 1.0e-10)
(zero-gain 1.0e-10)
(size (group-size group))
(mat (group-matrix group))) ; returns float-vector
- (if (and (< (abs x) zero-coord)
- (< (abs y) zero-coord)
- (< (abs z) zero-coord))
- (list #t (list 1.0 1.0 1.0))
-
- (if (= size 3)
- (let* ((gain-a (+ (* (mat 0 0) x)
- (* (mat 1 0) y)
- (* (mat 2 0) z)))
- (gain-b (+ (* (mat 0 1) x)
- (* (mat 1 1) y)
- (* (mat 2 1) z)))
- (gain-c (+ (* (mat 0 2) x)
- (* (mat 1 2) y)
- (* (mat 2 2) z)))
- (mag (sqrt (+ (* gain-a gain-a)
- (* gain-b gain-b)
- (* gain-c gain-c)))))
- ;; truncate to zero roundoff errors
- (if (< (abs gain-a) zero-gain)
- (set! gain-a 0.0))
- (if (< (abs gain-b) zero-gain)
- (set! gain-b 0.0))
- (if (< (abs gain-c) zero-gain)
- (set! gain-c 0.0))
- (list (and (>= gain-a 0) (>= gain-b 0) (>= gain-c 0))
- (list (/ gain-a mag) (/ gain-b mag) (/ gain-c mag))))
-
- (if (= size 2)
- (let* ((gain-a (+ (* (mat 0 0) x)
- (* (mat 1 0) y)))
- (gain-b (+ (* (mat 0 1) x)
- (* (mat 1 1) y)))
- (mag (sqrt (+ (* gain-a gain-a)
- (* gain-b gain-b)))))
- ;; truncate to zero roundoff errors
- (if (< (abs gain-a) zero-gain)
- (set! gain-a 0.0))
- (if (< (abs gain-b) zero-gain)
- (set! gain-b 0.0))
- (list (and (>= gain-a 0) (>= gain-b 0))
- (list (/ gain-a mag) (/ gain-b mag))))
-
- (if (= size 1)
- (list #t (list 1.0))))))))
-
- ;; find the speaker group that contains a point
- (define (find-group x y z)
- (call-with-exit
- (lambda (return)
- (for-each
- (lambda (group)
- (let* ((vals (calculate-gains x y z group))
- (inside (car vals))
- (gains (cadr vals)))
- (if inside
- (return (list group gains)))))
- (speaker-config-groups speakers))
- (list #f #f))))
-
- ;; push zero gains on all channels
- (define (push-zero-gains time)
- (let ((len (speaker-config-number speakers)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (set! (channel-gains i) (cons time (channel-gains i)))
- (set! (channel-gains i) (cons 0.0 (channel-gains i)))))
- (let ((len rev-channels))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (set! (channel-rev-gains i) (cons time (channel-rev-gains i)))
- (set! (channel-rev-gains i) (cons 0.0 (channel-rev-gains i))))))
-
- (define (position val lst)
- (define (position-1 val lst pos)
- (call-with-exit
- (lambda (return)
- (and (not (null? lst))
- (if (= val (car lst))
- (return pos)
- (position-1 val (cdr lst) (+ 1 pos)))))))
- (position-1 val lst 0))
+ (cond ((and (< (abs x) zero-coord)
+ (< (abs y) zero-coord)
+ (< (abs z) zero-coord))
+ (list #t (list 1.0 1.0 1.0)))
+
+ ((= size 3)
+ (let* ((gain-a (+ (* (mat 0 0) x)
+ (* (mat 1 0) y)
+ (* (mat 2 0) z)))
+ (gain-b (+ (* (mat 0 1) x)
+ (* (mat 1 1) y)
+ (* (mat 2 1) z)))
+ (gain-c (+ (* (mat 0 2) x)
+ (* (mat 1 2) y)
+ (* (mat 2 2) z)))
+ (mag (distance gain-a gain-b gain-c)))
+ ;; truncate to zero roundoff errors
+ (if (< (abs gain-a) zero-gain)
+ (set! gain-a 0.0))
+ (if (< (abs gain-b) zero-gain)
+ (set! gain-b 0.0))
+ (if (< (abs gain-c) zero-gain)
+ (set! gain-c 0.0))
+ (list (and (>= gain-a 0) (>= gain-b 0) (>= gain-c 0))
+ (list (/ gain-a mag) (/ gain-b mag) (/ gain-c mag)))))
+
+ ((= size 2)
+ (let* ((gain-a (+ (* (mat 0 0) x)
+ (* (mat 1 0) y)))
+ (gain-b (+ (* (mat 0 1) x)
+ (* (mat 1 1) y)))
+ (mag (sqrt (+ (* gain-a gain-a)
+ (* gain-b gain-b)))))
+ ;; truncate to zero roundoff errors
+ (if (< (abs gain-a) zero-gain)
+ (set! gain-a 0.0))
+ (if (< (abs gain-b) zero-gain)
+ (set! gain-b 0.0))
+ (list (and (>= gain-a 0) (>= gain-b 0))
+ (list (/ gain-a mag) (/ gain-b mag)))))
+
+ ((= size 1)
+ (list #t (list 1.0))))))
- ;; push gain and time into envelopes
- (define (push-gains group gains dist time num)
- (let ((outputs (make-vector out-channels 0.0))
- (rev-outputs (make-vector rev-channels 0.0))
- ;; attenuation with distance of direct signal
- (att (if (>= dist inside-radius)
- (/ (expt dist direct-power))
- (- 1.0 (expt (/ dist inside-radius) (/ inside-direct-power)))))
- ;; attenuation with distance of reverberated signal
- (ratt (if (>= dist inside-radius)
- (/ (expt dist reverb-power))
- (- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))))
- (if (>= dist inside-radius)
- ;; outside the inner sphere, signal is sent to group
- (let ((len (length gains)))
+
+ ;; Render a trajectory breakpoint through amplitude panning
+ (define famplitude-panning
+ (let ((speed-limit (/ (* dlocsig-speed-of-sound (- (car (last tpoints)) (car tpoints))) duration))
+ (prev-group #f)
+ (prev-x #f)
+ (prev-y #f)
+ (prev-z #f))
+
+ (define (equalp-intersection L1 L2)
+ (if (null? L2)
+ L2
+ (let loop1 ((L1 L1)
+ (result ()))
+ (cond ((null? L1)
+ (reverse! result))
+ ((member (car L1) L2)
+ (loop1 (cdr L1)
+ (cons (car L1)
+ result)))
+ (else (loop1 (cdr L1)
+ result))))))
+
+ (define (transition-point-3 vert-a vert-b xa ya za xb yb zb)
+ (define (cross v1 v2)
+ (list (- (* (cadr v1) (third v2))
+ (* (third v1) (cadr v2)))
+ (- (* (third v1) (car v2))
+ (* (car v1) (third v2)))
+ (- (* (car v1) (cadr v2))
+ (* (cadr v1) (car v2)))))
+ (define (dot v1 v2)
+ (+ (* (car v1) (car v2))
+ (* (cadr v1) (cadr v2))
+ (* (third v1) (third v2))))
+ (define (sub v1 v2)
+ (list (- (car v1) (car v2))
+ (- (cadr v1) (cadr v2))
+ (- (third v1) (third v2))))
+ (define (add v1 v2)
+ (list (+ (car v1) (car v2))
+ (+ (cadr v1) (cadr v2))
+ (+ (third v1) (third v2))))
+ (define (scale v1 c)
+ (list (* (car v1) c)
+ (* (cadr v1) c)
+ (* (third v1) c)))
+
+ (let* ((tolerance 1.0e-6)
+ (line-b (list xa ya za))
+ (line-m (sub (list xb yb zb) line-b))
+ (normal (cross vert-a vert-b))
+ (denominator (dot normal line-m)))
+ (and (> (abs denominator) tolerance)
+ (add line-b (scale line-m (/ (- (dot normal line-b)) denominator))))))
+
+ ;; calculate transition point between two adjacent two-speaker groups
+ ;; original line intersection code from Graphic Gems III
+ (define (transition-point-2 vert xa ya xb yb)
+ (let* ((Ax (car vert))
+ (Bx (- xa xb))
+ (Ay (cadr vert))
+ (By (- ya yb))
+ (Cx (- xa))
+ (Cy (- ya))
+ (d (- (* By Cx) (* Bx Cy)))
+ (f (- (* Ay Bx) (* Ax By))))
+ (and (not (= f 0))
+ (list (/ (* d Ax) f)
+ (/ (* d Ay) f)))))
+
+ ;; find the speaker group that contains a point
+ (define (find-group x y z)
+ (call-with-exit
+ (lambda (return)
+ (for-each
+ (lambda (group)
+ (let* ((vals (calculate-gains x y z group))
+ (inside (car vals))
+ (gains (cadr vals)))
+ (if inside
+ (return (list group gains)))))
+ (speaker-config-groups speakers))
+ (list #f #f))))
+
+ ;; push zero gains on all channels
+ (define (push-zero-gains time)
+ (let ((len (speaker-config-number speakers)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (set! (channel-gains i) (cons time (channel-gains i)))
+ (set! (channel-gains i) (cons 0.0 (channel-gains i)))))
+ (let ((len rev-channels))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (set! (channel-rev-gains i) (cons time (channel-rev-gains i)))
+ (set! (channel-rev-gains i) (cons 0.0 (channel-rev-gains i))))))
+
+ ;; push gain and time into envelopes
+ (define (push-gains group gains dist time)
+
+ (define* (position val lst (pos 0))
+ (call-with-exit
+ (lambda (return)
+ (and (not (null? lst))
+ (if (= val (car lst))
+ (return pos)
+ (position val (cdr lst) (+ 1 pos)))))))
+
+ (let ((outputs (make-vector out-channels 0.0))
+ (rev-outputs (make-vector rev-channels 0.0))
+ ;; attenuation with distance of reverberated signal
+ (ratt (if (>= dist inside-radius)
+ (/ (expt dist reverb-power))
+ (- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))))
+ (let (;; attenuation with distance of direct signal
+ (att (if (>= dist inside-radius)
+ (/ (expt dist direct-power))
+ (- 1.0 (expt (/ dist inside-radius) (/ inside-direct-power))))))
+ (if (>= dist inside-radius)
+ ;; outside the inner sphere, signal is sent to group
+ (let ((len (length gains)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (let ((speaker ((group-speakers group) i))
+ (gain (gains i)))
+ (set! (outputs speaker) (* gain att))
+ (if (and (> rev-channels 1)
+ (< speaker (length rev-outputs)))
+ (set! (rev-outputs speaker) (* gain ratt))))))
+
+ (let ((gain 0.0)
+ (len (speaker-config-number speakers)))
+ (do ((speaker 0 (+ 1 speaker)))
+ ((= speaker len))
+ ;; inside the inner sphere, signal is sent to all speakers
+ (let ((found (position speaker (group-speakers group))))
+ (if found
+ ;; speaker belongs to group, add to existing gain
+ (begin
+ (set! gain (gains found))
+ (set! (outputs speaker) (+ gain (* (- 1.0 gain) att)))
+ (if (> rev-channels 1) (set! (rev-outputs speaker) (+ gain (* (- 1.0 gain) ratt)))))
+ ;; speaker outside of group
+ (begin
+ (set! (outputs speaker) att)
+ (if (> rev-channels 1) (set! (rev-outputs speaker) ratt)))))))))
+
+ ;; push all channel gains into envelopes
+ (let ((len (speaker-config-number speakers)))
(do ((i 0 (+ i 1)))
((= i len))
- (let ((speaker ((group-speakers group) i))
- (gain (gains i)))
- (set! (outputs speaker) (* gain att))
- (if (and (> rev-channels 1)
- (< speaker (length rev-outputs)))
- (set! (rev-outputs speaker) (* gain ratt))))))
+ (if (or (null? (channel-gains i))
+ (> time (cadr (channel-gains i))))
+ (begin
+ (set! (channel-gains i) (cons time (channel-gains i)))
+ (set! (channel-gains i) (cons (outputs i) (channel-gains i)))))))
- (let ((gain 0.0)
- (len (speaker-config-number speakers)))
- (do ((speaker 0 (+ 1 speaker)))
- ((= speaker len))
- ;; inside the inner sphere, signal is sent to all speakers
- (let ((found (position speaker (group-speakers group))))
- (if found
- ;; speaker belongs to group, add to existing gain
- (begin
- (set! gain (gains found))
- (set! (outputs speaker) (+ gain (* (- 1.0 gain) att)))
- (if (> rev-channels 1) (set! (rev-outputs speaker) (+ gain (* (- 1.0 gain) ratt)))))
- ;; speaker outside of group
+ (if (> rev-channels 1)
+ (do ((i 0 (+ i 1)))
+ ((= i rev-channels))
+ (if (or (null? (channel-rev-gains i))
+ (> time (cadr (channel-rev-gains i))))
(begin
- (set! (outputs speaker) att)
- (if (> rev-channels 1) (set! (rev-outputs speaker) ratt))))))))
-
- ;; push all channel gains into envelopes
- (let ((len (speaker-config-number speakers)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (if (or (null? (channel-gains i))
- (> time (cadr (channel-gains i))))
+ (set! (channel-rev-gains i) (cons time (channel-rev-gains i)))
+ (set! (channel-rev-gains i) (cons (rev-outputs i) (channel-rev-gains i)))))))
+
+ ;; push reverb gain into envelope for mono reverb
+ (if (and (= rev-channels 1)
+ (or (null? (channel-rev-gains 0))
+ (> time (cadr (channel-rev-gains 0)))))
(begin
- (set! (channel-gains i) (cons time (channel-gains i)))
- (set! (channel-gains i) (cons (outputs i) (channel-gains i)))))))
-
- (if (> rev-channels 1)
- (do ((i 0 (+ i 1)))
- ((= i rev-channels))
- (if (or (null? (channel-rev-gains i))
- (> time (cadr (channel-rev-gains i))))
- (begin
- (set! (channel-rev-gains i) (cons time (channel-rev-gains i)))
- (set! (channel-rev-gains i) (cons (rev-outputs i) (channel-rev-gains i)))))))
+ (set! (channel-rev-gains 0) (cons time (channel-rev-gains 0)))
+ (set! (channel-rev-gains 0) (cons ratt (channel-rev-gains 0)))))))
- ;; push reverb gain into envelope for mono reverb
- (if (and (= rev-channels 1)
- (or (null? (channel-rev-gains 0))
- (> time (cadr (channel-rev-gains 0)))))
- (begin
- (set! (channel-rev-gains 0) (cons time (channel-rev-gains 0)))
- (set! (channel-rev-gains 0) (cons ratt (channel-rev-gains 0)))))))
-
- ;; Render a trajectory breakpoint through amplitude panning
- (define (famplitude-panning x y z dist time q)
- ;; output gains for current point
- (if prev-group
- (let* ((vals (calculate-gains x y z prev-group))
- (inside (car vals))
- (gains (cadr vals)))
- ;; check that the source is not moving faster than sound
- (if (not (= time prev-time))
- (let ((speed (/ (- dist prev-dist) (- time prev-time))))
- (if (> speed speed-limit)
- (format #t "WARNING: supersonic radial movement at [~F,~F,~F, ~F], speed=~F~%" x y z time speed))))
- (if inside
- ;; still in the same group
- (begin
- (push-gains prev-group gains dist time 1)
- (set! prev-x x)
- (set! prev-y y)
- (set! prev-z z))
- ;; left the group
- (let* ((vals (find-group x y z))
- (group (car vals))
- (gains (cadr vals)))
- (if group
- ;; we have to interpolate a new point that lies on the shared
- ;; edge of the adjacent groups so that the speakers opposite
- ;; the edge have zero gain when the trajectory switches groups
- (let ((edge (equalp-intersection (group-vertices group)
- (group-vertices prev-group))))
- (if (= (length edge) 2)
- ;; the groups have two shared points (ie: share an edge)
- ;; this must be a three speaker groups transition
- (let ((pint (transition-point-3 (car edge) (cadr edge) x y z prev-x prev-y prev-z)))
- (if pint
- (let* ((xi (car pint))
- (yi (cadr pint))
- (zi (third pint))
- (di (distance xi yi zi))
- (ti (+ prev-time (max .00001 (* (/ (distance (- xi prev-x)
- (- yi prev-y)
- (- zi prev-z))
- (distance (- x prev-x)
- (- y prev-y)
- (- z prev-z)))
- (- time prev-time))))))
- ;; see if we are inside the previous group
- ;; we can be on either side due to roundoff errors
- (let* ((vals (calculate-gains xi yi zi prev-group))
- (inside (car vals))
- (gains (cadr vals)))
- (if inside
- (push-gains prev-group gains di ti 2)
- (let* ((val1 (calculate-gains xi yi zi group))
- (inside (car val1))
- (gains (cadr val1)))
- (if inside
- (push-gains group gains di ti 3)
- ;; how did we get here?
- (error 'mus-error "ERROR: Outside of both adjacent groups [~A:~A:~A @~A]~%~%" xi yi zi ti))))))))
-
- (if (and (= (length edge) 1) (= (group-size group) 2))
- ;; two two-speaker groups share one point
- ;; z coordinates are silently ignored
- (let ((pint (transition-point-2 (car edge) x y prev-x prev-y)))
- (if pint
- (let* ((xi (car pint))
- (yi (cadr pint))
- (di (distance xi yi 0.0))
- (ti (+ prev-time (max .00001 (* (/ (distance (- xi prev-x)
- (- yi prev-y)
- 0.0)
- (distance (- x prev-x)
- (- y prev-y)
- 0.0))
- (- time prev-time))))))
- ;; see if we are inside the previous group
- ;; we can be on either side due to roundoff errors
- (let* ((vals (calculate-gains xi yi 0.0 prev-group))
- (inside (car vals))
- (gains (cadr vals)))
- (if inside
- (push-gains prev-group gains di ti 4)
- (let* ((val1 (calculate-gains xi yi 0.0 group))
- (inside (car val1))
- (gains (cadr val1)))
- (if inside
- (push-gains group gains di ti 5)
- ;; how did we get here?
- (format #t "Outside of both adjacent groups [~A:~A @~A]~%~%" xi yi ti))))))))
- (if (= (length edge) 1)
- ;; groups share only one point... for now a warning
- ;; we should calculate two additional interpolated
- ;; points as the trajectory must be crossing a third
- ;; group
- (begin
- (for-each
- (lambda (int-group)
- (if (and (member (car edge) (group-vertices int-group))
- (not (equal? int-group group))
- (not (equal? int-group prev-group)))
- (let ((edge1 (equalp-intersection (group-vertices int-group)
- (group-vertices prev-group)))
- (edge2 (equalp-intersection (group-vertices int-group)
- (group-vertices group))))
- (format #t "e1=~A; e2=~A~%~%" edge1 edge2))))
- (speaker-config-groups speakers))
- (format #t "WARNING: crossing between groups with only one point in common~% prev=~A~% curr=~A~%" prev-group group))
+ (lambda (x y z dist time)
+
+ ;; output gains for current point
+ (if prev-group
+ (let* ((vals (calculate-gains x y z prev-group))
+ (inside (car vals))
+ (gains (cadr vals)))
+ ;; check that the source is not moving faster than sound
+ (if (not (= time prev-time))
+ (let ((speed (/ (- dist prev-dist) (- time prev-time))))
+ (if (> speed speed-limit)
+ (format () "warning: supersonic radial movement at [~F,~F,~F, ~F], speed=~F~%" x y z time speed))))
+ (if inside
+ ;; still in the same group
+ (begin
+ (push-gains prev-group gains dist time)
+ (set! prev-x x)
+ (set! prev-y y)
+ (set! prev-z z))
+ ;; left the group
+ (let* ((vals (find-group x y z))
+ (group (car vals))
+ (gains (cadr vals)))
+ (if (not group)
+ (begin
+ ;; current point is outside all defined groups
+ ;; we should send a warning at this point...
+ (push-zero-gains time)
+ (set! prev-group #f))
+ (begin
+ ;; we have to interpolate a new point that lies on the shared
+ ;; edge of the adjacent groups so that the speakers opposite
+ ;; the edge have zero gain when the trajectory switches groups
+ (let ((edge (equalp-intersection (group-vertices group)
+ (group-vertices prev-group))))
+ (cond ((= (length edge) 2)
+ ;; the groups have two shared points (ie: share an edge)
+ ;; this must be a three speaker groups transition
+ (let ((pint (transition-point-3 (car edge) (cadr edge) x y z prev-x prev-y prev-z)))
+ (when pint
+ (let* ((xi (car pint))
+ (yi (cadr pint))
+ (zi (third pint))
+ (di (distance xi yi zi))
+ (ti (+ prev-time (max .00001 (* (/ (distance (- xi prev-x)
+ (- yi prev-y)
+ (- zi prev-z))
+ (distance (- x prev-x)
+ (- y prev-y)
+ (- z prev-z)))
+ (- time prev-time)))))
+ ;; see if we are inside the previous group
+ ;; we can be on either side due to roundoff errors
+ (vals (calculate-gains xi yi zi prev-group))
+ (inside (car vals))
+ (gains (cadr vals)))
+ (if inside
+ (push-gains prev-group gains di ti)
+ (let* ((val1 (calculate-gains xi yi zi group))
+ (inside (car val1))
+ (gains (cadr val1)))
+ (if inside
+ (push-gains group gains di ti)
+ ;; how did we get here?
+ (error 'mus-error "Outside of both adjacent groups [~A:~A:~A @~A]~%~%" xi yi zi ti))))))))
+
+ ((and (pair? edge)
+ (null? (cdr edge))
+ (= (group-size group) 2))
+ ;; two two-speaker groups share one point
+ ;; z coordinates are silently ignored
+ (let ((pint (transition-point-2 (car edge) x y prev-x prev-y)))
+ (when pint
+ (let* ((xi (car pint))
+ (yi (cadr pint))
+ (di (distance xi yi 0.0))
+ (ti (+ prev-time (max .00001 (* (/ (distance (- xi prev-x)
+ (- yi prev-y)
+ 0.0)
+ (distance (- x prev-x)
+ (- y prev-y)
+ 0.0))
+ (- time prev-time)))))
+ ;; see if we are inside the previous group
+ ;; we can be on either side due to roundoff errors
+ (vals (calculate-gains xi yi 0.0 prev-group))
+ (inside (car vals))
+ (gains (cadr vals)))
+ (if inside
+ (push-gains prev-group gains di ti)
+ (let* ((val1 (calculate-gains xi yi 0.0 group))
+ (inside (car val1))
+ (gains (cadr val1)))
+ (if inside
+ (push-gains group gains di ti)
+ ;; how did we get here?
+ (format () "Outside of both adjacent groups [~A:~A @~A]~%~%" xi yi ti))))))))
+
+ ((and (pair? edge)
+ (null? (cdr edge)))
+ ;; groups share only one point... for now a warning
+ ;; we should calculate two additional interpolated
+ ;; points as the trajectory must be crossing a third
+ ;; group
+ (for-each
+ (lambda (int-group)
+ (if (and (member (car edge) (group-vertices int-group))
+ (not (equal? int-group group))
+ (not (equal? int-group prev-group)))
+ (format () "e1=~A; e2=~A~%~%"
+ (equalp-intersection (group-vertices int-group)
+ (group-vertices prev-group))
+ (equalp-intersection (group-vertices int-group)
+ (group-vertices group)))))
+
+ (speaker-config-groups speakers))
+ (format () "warning: crossing between groups with only one point in common~% prev=~A~% curr=~A~%" prev-group group))
;; groups don't share points... how did we get here?
- (if (= (length edge) 0)
- (format #t "WARNING: crossing between groups with no common points, ~A~A to ~A~A~%"
- (group-id prev-group) (group-speakers prev-group)
- (group-id group) (group-speakers group))))))
-
- ;; finally push gains for current group
- (push-gains group gains dist time 6)
- (set! prev-group group)
- (set! prev-x x)
- (set! prev-y y)
- (set! prev-z z))
- ;; current point is outside all defined groups
- ;; we should send a warning at this point...
- (begin
- (push-zero-gains time)
- (set! prev-group #f))))))
- ;; first time around
- (let* ((vals (find-group x y z))
- (group (car vals))
- (gains (cadr vals)))
- (if group
- (begin
- (push-gains group gains dist time 7)
- (set! prev-group group)
- (set! prev-x x)
- (set! prev-y y)
- (set! prev-z z))
- (begin
- (push-zero-gains time)
- (set! prev-group #f))))))
+ ((null? edge)
+ (format () "warning: crossing between groups with no common points, ~A~A to ~A~A~%"
+ (group-id prev-group) (group-speakers prev-group)
+ (group-id group) (group-speakers group)))))
+
+ ;; finally push gains for current group
+ (push-gains group gains dist time)
+ (set! prev-group group)
+ (set! prev-x x)
+ (set! prev-y y)
+ (set! prev-z z))))))
+ ;; first time around
+ (let* ((vals (find-group x y z))
+ (group (car vals))
+ (gains (cadr vals)))
+ (if group
+ (begin
+ (push-gains group gains dist time)
+ (set! prev-group group)
+ (set! prev-x x)
+ (set! prev-y y)
+ (set! prev-z z))
+ (begin
+ (push-zero-gains time)
+ (set! prev-group #f))))))))
;; Render a trajectory breakpoint for ambisonics b-format coding
;; http://www.york.ac.uk/inst/mustech/3d_audio/ambis2.htm
@@ -2622,71 +2574,73 @@
;; see also: http://wiki.xiph.org/index.php/Ambisonics
;; for mixed order systems
;;
- (define (render-ambisonics x y z dist time)
- (let* ((att (if (> dist inside-radius)
- (expt (/ inside-radius dist) direct-power)
- (expt (/ dist inside-radius) (/ inside-direct-power))))
- (attW (if (> dist inside-radius)
- (* point707 att)
- (- 1 (* (- 1 point707) (expt (/ dist inside-radius) direct-power)))))
- (ratt (if (> dist inside-radius)
- (expt (/ inside-radius dist) reverb-power)
- (expt (/ dist inside-radius) (/ inside-reverb-power))))
- (rattW (if (> dist inside-radius)
- (* point707 ratt)
- (- 1 (* (- 1 point707) (expt (/ dist inside-radius) reverb-power)))))
- ;; storage for some intermediate calculations
- (u 0)
- (v 0)
- (lm 0)
- (no 0))
- ;; output encoding gains for point
- ;; W: 0.707
- (set! (channel-gains w-offset) (cons time (channel-gains w-offset)))
- (set! (channel-gains w-offset) (cons attW (channel-gains w-offset)))
- ;; X: (* (cos A) (cos E))
- (set! (channel-gains x-offset) (cons time (channel-gains x-offset)))
- (set! (channel-gains x-offset) (cons (* (if (zero? dist) 0 (/ y dist)) att) (channel-gains x-offset)))
- ;; Y: (* (sin A) (cos E))
- (set! (channel-gains y-offset) (cons time (channel-gains y-offset)))
- (set! (channel-gains y-offset) (cons (* (if (zero? dist) 0 (/ (- x) dist)) att) (channel-gains y-offset)))
- (if (>= ambisonics-v-order 1)
- (begin
+ (define render-ambisonics
+ (let ((w-offset 0)
+ (x-offset 1)
+ (y-offset 2)
+ (ambisonics-k1 (sqrt 135/256)) ;(/ (* 21 45) 224 8)
+ (ambisonics-k2 (* (sqrt 3) 3 0.5)))
+ (lambda (x y z dist time)
+ (let* ((att (if (> dist inside-radius)
+ (expt (/ inside-radius dist) direct-power)
+ (expt (/ dist inside-radius) (/ inside-direct-power))))
+ (attW (if (> dist inside-radius)
+ (* point707 att)
+ (- 1 (* (- 1 point707) (expt (/ dist inside-radius) direct-power)))))
+ (ratt (if (> dist inside-radius)
+ (expt (/ inside-radius dist) reverb-power)
+ (expt (/ dist inside-radius) (/ inside-reverb-power))))
+ (rattW (if (> dist inside-radius)
+ (* point707 ratt)
+ (- 1 (* (- 1 point707) (expt (/ dist inside-radius) reverb-power)))))
+ ;; storage for some intermediate calculations
+ (u 0)
+ (v 0)
+ (lm 0)
+ (no 0))
+ ;; output encoding gains for point
+ ;; W: 0.707
+ (set! (channel-gains w-offset) (cons time (channel-gains w-offset)))
+ (set! (channel-gains w-offset) (cons attW (channel-gains w-offset)))
+ ;; X: (* (cos A) (cos E))
+ (set! (channel-gains x-offset) (cons time (channel-gains x-offset)))
+ (set! (channel-gains x-offset) (cons (* (if (zero? dist) 0 (/ y dist)) att) (channel-gains x-offset)))
+ ;; Y: (* (sin A) (cos E))
+ (set! (channel-gains y-offset) (cons time (channel-gains y-offset)))
+ (set! (channel-gains y-offset) (cons (* (if (zero? dist) 0 (/ (- x) dist)) att) (channel-gains y-offset)))
+ (when (>= ambisonics-v-order 1)
;; Z: (sin E)
(set! (channel-gains z-offset) (cons time (channel-gains z-offset)))
- (set! (channel-gains z-offset) (cons (* (if (zero? dist) 0 (/ z dist)) att) (channel-gains z-offset)))))
- (if (>= ambisonics-v-order 2)
- (begin
+ (set! (channel-gains z-offset) (cons (* (if (zero? dist) 0 (/ z dist)) att) (channel-gains z-offset))))
+ (when (>= ambisonics-v-order 2)
;; R
(set! (channel-gains r-offset) (cons time (channel-gains r-offset)))
- (set! (channel-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 0.5)) att)
+ (set! (channel-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 0.5)) att)
(channel-gains r-offset)))
;; S
(set! (channel-gains s-offset) (cons time (channel-gains s-offset)))
- (set! (channel-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 (* dist dist))) att)
+ (set! (channel-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 dist dist)) att)
(channel-gains s-offset)))
;; T
(set! (channel-gains t-offset) (cons time (channel-gains t-offset)))
- (set! (channel-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 (* dist dist))) att)
- (channel-gains t-offset)))))
- (if (>= ambisonics-h-order 2)
- (begin
- (set! u (* (if (zero? dist) 0 1) (- (* x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* y y (if (zero? dist) 1 (/ 1.0 (* dist dist))))) att))
- (set! v (* (if (zero? dist) 0 2) (- x) y (if (zero? dist) 1 (/ 1.0 (* dist dist))) att))
+ (set! (channel-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 dist dist)) att)
+ (channel-gains t-offset))))
+ (when (>= ambisonics-h-order 2)
+ (set! u (* (if (zero? dist) 0 1) (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist)))) att))
+ (set! v (* (if (zero? dist) 0 2) (- x) y (if (zero? dist) 1 (/ 1.0 dist dist)) att))
;; U
(set! (channel-gains u-offset) (cons time (channel-gains u-offset)))
(set! (channel-gains u-offset) (cons u (channel-gains u-offset)))
;; V
(set! (channel-gains v-offset) (cons time (channel-gains v-offset)))
- (set! (channel-gains v-offset) (cons v (channel-gains v-offset)))))
- (if (>= ambisonics-v-order 3)
- (begin
- (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 1) att))
+ (set! (channel-gains v-offset) (cons v (channel-gains v-offset))))
+ (when (>= ambisonics-v-order 3)
+ (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1) att))
(set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) att))
;; K
(set! (channel-gains k-offset) (cons time (channel-gains k-offset)))
- (set! (channel-gains k-offset) (cons (* (if (zero? dist) 0 1) (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 1.5) att) (channel-gains k-offset)))
+ (set! (channel-gains k-offset) (cons (* (if (zero? dist) 0 1) (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1.5) att) (channel-gains k-offset)))
;; L
(set! (channel-gains l-offset) (cons time (channel-gains l-offset)))
(set! (channel-gains l-offset) (cons (* (if (zero? dist) 0 (/ x dist)) lm) (channel-gains l-offset)))
@@ -2698,105 +2652,101 @@
(set! (channel-gains n-offset) (cons (* (if (zero? dist) 0 no) u) (channel-gains n-offset)))
;; O
(set! (channel-gains o-offset) (cons time (channel-gains o-offset)))
- (set! (channel-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-gains o-offset)))))
- (if (>= ambisonics-h-order 3)
- (begin
+ (set! (channel-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-gains o-offset))))
+ (when (>= ambisonics-h-order 3)
;; P
(set! (channel-gains p-offset) (cons time (channel-gains p-offset)))
(set! (channel-gains p-offset) (cons (* (if (zero? dist) 0 (/ att dist)) x
- (- (* x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* 3 y y (if (zero? dist) 1 (/ 1.0 (* dist dist)))))) (channel-gains p-offset)))
+ (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-gains p-offset)))
;; Q
(set! (channel-gains q-offset) (cons time (channel-gains q-offset)))
(set! (channel-gains q-offset) (cons (* (if (zero? dist) 0 (/ att dist)) y
- (- (* 3 x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* y y (if (zero? dist) 1 (/ 1.0 (* dist dist)))))) (channel-gains q-offset)))))
- ;; push reverb gain into envelope
- (if (= rev-channels 1)
- (begin
+ (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-gains q-offset))))
+ ;; push reverb gain into envelope
+ (when (= rev-channels 1)
;; mono reverb output
(set! (channel-rev-gains 0) (cons time (channel-rev-gains 0)))
(set! (channel-rev-gains 0) (cons (if (>= dist inside-radius)
(/ (expt dist reverb-power))
(- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))
- (channel-rev-gains 0)))))
- (if (> rev-channels 1)
- (let ((ho-ratt dlocsig-ambisonics-ho-rev-scaler))
- ;; multichannel reverb, send ambisonics components
- ;; W: 0.707
- (set! (channel-rev-gains w-offset) (cons time (channel-rev-gains w-offset)))
- (set! (channel-rev-gains w-offset) (cons rattW (channel-rev-gains w-offset)))
- ;; X: (* (cos A)(cos E))
- (set! (channel-rev-gains x-offset) (cons time (channel-rev-gains x-offset)))
- (set! (channel-rev-gains x-offset) (cons (* (if (zero? dist) 0 1) y (if (zero? dist) 1 (/ dist)) ratt)(channel-rev-gains x-offset)))
- ;; Y: (* (sin A)(cos E))
- (set! (channel-rev-gains y-offset) (cons time (channel-rev-gains y-offset)))
- (set! (channel-rev-gains y-offset) (cons (* (if (zero? dist) 0 1) (- x) (if (zero? dist) 1 (/ dist)) ratt)
- (channel-rev-gains y-offset)))
- (if (>= ambisonics-v-order 1)
- (begin
- ;; Z: (sin E)
- (set! (channel-rev-gains z-offset) (cons time (channel-rev-gains z-offset)))
- (set! (channel-rev-gains z-offset) (cons (* (if (zero? dist) 0 1) z (if (zero? dist) 1 (/ dist)) ratt)
- (channel-rev-gains z-offset)))))
- (if (>= ambisonics-v-order 2)
- (begin
- ;; R
- (set! (channel-rev-gains r-offset) (cons time (channel-rev-gains r-offset)))
- (set! (channel-rev-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 0.5)) ho-ratt ratt)
- (channel-rev-gains r-offset)))
- ;; S
- (set! (channel-rev-gains s-offset) (cons time (channel-rev-gains s-offset)))
- (set! (channel-rev-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 (* dist dist))) ho-ratt ratt)
- (channel-rev-gains s-offset)))
- ;; T
- (set! (channel-rev-gains t-offset) (cons time (channel-rev-gains t-offset)))
- (set! (channel-rev-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 (* dist dist))) ho-ratt ratt)
- (channel-rev-gains t-offset)))))
- (if (>= ambisonics-h-order 2)
- (begin
- ;; U
- (set! (channel-rev-gains u-offset) (cons time (channel-rev-gains u-offset)))
- (set! (channel-rev-gains u-offset) (cons (* (if (zero? dist) 0 (- (* x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* y y (if (zero? dist) 1 (/ 1.0 (* dist dist)))))) ho-ratt ratt)
- (channel-rev-gains u-offset)))
- ;; V
- (set! (channel-rev-gains v-offset) (cons time (channel-rev-gains v-offset)))
- (set! (channel-rev-gains v-offset) (cons (* (if (zero? dist) 0 2) (- x) y (if (zero? dist) 1 (/ 1.0 (* dist dist))) ho-ratt ratt)
- (channel-rev-gains v-offset)))))
-
- (if (>= ambisonics-v-order 3)
- (begin
- (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 1) ho-ratt ratt))
- (set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) ratt))
- ;; K
- (set! (channel-rev-gains k-offset) (cons time (channel-rev-gains k-offset)))
- (set! (channel-rev-gains k-offset) (cons (* (if (zero? dist) 0 1) (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 (* dist dist)))) 1.5) ho-ratt ratt) (channel-rev-gains k-offset)))
- ;; L
- (set! (channel-rev-gains l-offset) (cons time (channel-rev-gains l-offset)))
- (set! (channel-rev-gains l-offset) (cons (* (if (zero? dist) 0 (/ x dist)) lm) (channel-rev-gains l-offset)))
- ;; M
- (set! (channel-rev-gains m-offset) (cons time (channel-rev-gains m-offset)))
- (set! (channel-rev-gains m-offset) (cons (* (if (zero? dist) 0 (/ y dist)) lm) (channel-rev-gains m-offset)))
- ;; N
- (set! (channel-rev-gains n-offset) (cons time (channel-rev-gains n-offset)))
- (set! (channel-rev-gains n-offset) (cons (* (if (zero? dist) 0 no) u) (channel-rev-gains n-offset)))
- ;; O
- (set! (channel-rev-gains o-offset) (cons time (channel-rev-gains o-offset)))
- (set! (channel-rev-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-rev-gains o-offset)))))
- (if (>= ambisonics-h-order 3)
- (begin
- ;; P
- (set! (channel-rev-gains p-offset) (cons time (channel-rev-gains p-offset)))
- (set! (channel-rev-gains p-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt x
- (- (* x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* 3 y y (if (zero? dist) 1 (/ 1.0 (* dist dist)))))) (channel-rev-gains p-offset)))
- ;; Q
- (set! (channel-rev-gains q-offset) (cons time (channel-rev-gains q-offset)))
- (set! (channel-rev-gains q-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt y
- (- (* 3 x x (if (zero? dist) 1 (/ 1.0 (* dist dist))))
- (* y y (if (zero? dist) 1 (/ 1.0 (* dist dist)))))) (channel-rev-gains q-offset)))))
- ))))
+ (channel-rev-gains 0))))
+ (when (> rev-channels 1)
+ (let ((ho-ratt dlocsig-ambisonics-ho-rev-scaler))
+ ;; multichannel reverb, send ambisonics components
+ ;; W: 0.707
+ (set! (channel-rev-gains w-offset) (cons time (channel-rev-gains w-offset)))
+ (set! (channel-rev-gains w-offset) (cons rattW (channel-rev-gains w-offset)))
+ ;; X: (* (cos A)(cos E))
+ (set! (channel-rev-gains x-offset) (cons time (channel-rev-gains x-offset)))
+ (set! (channel-rev-gains x-offset) (cons (* (if (zero? dist) 0 1) y (if (zero? dist) 1 (/ dist)) ratt)(channel-rev-gains x-offset)))
+ ;; Y: (* (sin A)(cos E))
+ (set! (channel-rev-gains y-offset) (cons time (channel-rev-gains y-offset)))
+ (set! (channel-rev-gains y-offset) (cons (* (if (zero? dist) 0 1) (- x) (if (zero? dist) 1 (/ dist)) ratt)
+ (channel-rev-gains y-offset)))
+ (when (>= ambisonics-v-order 1)
+ ;; Z: (sin E)
+ (set! (channel-rev-gains z-offset) (cons time (channel-rev-gains z-offset)))
+ (set! (channel-rev-gains z-offset) (cons (* (if (zero? dist) 0 1) z (if (zero? dist) 1 (/ dist)) ratt)
+ (channel-rev-gains z-offset))))
+ (when (>= ambisonics-v-order 2)
+ ;; R
+ (set! (channel-rev-gains r-offset) (cons time (channel-rev-gains r-offset)))
+ (set! (channel-rev-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 0.5)) ho-ratt ratt)
+ (channel-rev-gains r-offset)))
+ ;; S
+ (set! (channel-rev-gains s-offset) (cons time (channel-rev-gains s-offset)))
+ (set! (channel-rev-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
+ (channel-rev-gains s-offset)))
+ ;; T
+ (set! (channel-rev-gains t-offset) (cons time (channel-rev-gains t-offset)))
+ (set! (channel-rev-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
+ (channel-rev-gains t-offset))))
+ (when (>= ambisonics-h-order 2)
+ ;; U
+ (set! (channel-rev-gains u-offset) (cons time (channel-rev-gains u-offset)))
+ (set! (channel-rev-gains u-offset) (cons (* (if (zero? dist) 0 (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) ho-ratt ratt)
+ (channel-rev-gains u-offset)))
+ ;; V
+ (set! (channel-rev-gains v-offset) (cons time (channel-rev-gains v-offset)))
+ (set! (channel-rev-gains v-offset) (cons (* (if (zero? dist) 0 2) (- x) y (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
+ (channel-rev-gains v-offset))))
+
+ (when (>= ambisonics-v-order 3)
+ (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1) ho-ratt ratt))
+ (set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) ratt))
+ ;; K
+ (set! (channel-rev-gains k-offset) (cons time (channel-rev-gains k-offset)))
+ (set! (channel-rev-gains k-offset) (cons (* (if (zero? dist) 0 1)
+ (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1.5)
+ ho-ratt ratt)
+ (channel-rev-gains k-offset)))
+ ;; L
+ (set! (channel-rev-gains l-offset) (cons time (channel-rev-gains l-offset)))
+ (set! (channel-rev-gains l-offset) (cons (* (if (zero? dist) 0 (/ x dist)) lm) (channel-rev-gains l-offset)))
+ ;; M
+ (set! (channel-rev-gains m-offset) (cons time (channel-rev-gains m-offset)))
+ (set! (channel-rev-gains m-offset) (cons (* (if (zero? dist) 0 (/ y dist)) lm) (channel-rev-gains m-offset)))
+ ;; N
+ (set! (channel-rev-gains n-offset) (cons time (channel-rev-gains n-offset)))
+ (set! (channel-rev-gains n-offset) (cons (* (if (zero? dist) 0 no) u) (channel-rev-gains n-offset)))
+ ;; O
+ (set! (channel-rev-gains o-offset) (cons time (channel-rev-gains o-offset)))
+ (set! (channel-rev-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-rev-gains o-offset))))
+ (when (>= ambisonics-h-order 3)
+ ;; P
+ (set! (channel-rev-gains p-offset) (cons time (channel-rev-gains p-offset)))
+ (set! (channel-rev-gains p-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt x
+ (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-rev-gains p-offset)))
+ ;; Q
+ (set! (channel-rev-gains q-offset) (cons time (channel-rev-gains q-offset)))
+ (set! (channel-rev-gains q-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt y
+ (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-rev-gains q-offset))))
+ ))))))
;; Render a trajectory breakpoint to a room for decoded ambisonics
;;
@@ -2867,7 +2817,7 @@
(set! (channel-rev-gains i) (cons signal (channel-rev-gains i))))))))
;; Loop through all virtual rooms for one breakpoint in the trajectory
- (define (walk-all-rooms x y z time num)
+ (define (walk-all-rooms x y z time)
(let ((room 0)
(dist (distance x y z)))
;; remember first and last distances
@@ -2883,8 +2833,8 @@
(if (or (null? dly)
(> time (cadr dly)))
(begin
- (set! dly (cons time dly))
- (set! dly (cons (dist->samples dist) dly))
+ (set! dly (cons (dist->samples dist)
+ (cons time dly)))
;; doppler should be easy, yeah right. We use "relativistic" correction
;; as the sound object can be travelling close to the speed of sound.
;; http://www.mathpages.com/rr/s2-04/2-04.htm,
@@ -2894,18 +2844,19 @@
(if prev-time
(let ((ratio (/ (- dist prev-dist)
(* duration (- time prev-time) dlocsig-speed-of-sound))))
- (set! doppler (cons (/ (+ prev-time time) 2) doppler))
- (set! doppler (cons (* (/ 1.0 (+ 1 ratio)) (sqrt (- 1 (* ratio ratio)))) doppler))))))
+ (set! doppler (cons (* (/ 1.0 (+ 1 ratio)) (sqrt (- 1 (* ratio ratio))))
+ (cons (/ (+ prev-time time) 2) doppler)))))))
+
;; do the rendering of the point
- (if (= render-using amplitude-panning)
- ;; amplitude panning
- (famplitude-panning x y z dist time 1)
- (if (= render-using ambisonics)
- ;; ambisonics b format
- (render-ambisonics x y z dist time)
- (if (= render-using decoded-ambisonics)
- ;; ambisonics decoded
- (fdecoded-ambisonics x y z dist time))))
+ (cond ((= render-using amplitude-panning)
+ ;; amplitude panning
+ (famplitude-panning x y z dist time))
+ ((= render-using ambisonics)
+ ;; ambisonics b format
+ (render-ambisonics x y z dist time))
+ ((= render-using decoded-ambisonics)
+ ;; ambisonics decoded
+ (fdecoded-ambisonics x y z dist time)))
(set! room (+ 1 room))
;; remember current time and distance for next point
@@ -2918,12 +2869,12 @@
;; a change in radial direction implies a change in
;; doppler shift that has to be reflected as a new
;; point in the rendered envelopes
- (define (change-direction xa ya za ta xb yb zb tb num)
- (walk-all-rooms xa ya za ta 1)
- (if (or (not (= xa xb))
- (not (= ya yb))
- (not (= za zb))
- (not (= ta tb)))
+ (define (change-direction xa ya za ta xb yb zb tb)
+ (walk-all-rooms xa ya za ta)
+ (if (not (and (= xa xb)
+ (= ya yb)
+ (= za zb)
+ (= ta tb)))
(let* ((vals (nearest-point xa ya za xb yb zb 0 0 0))
(xi (car vals))
(yi (cadr vals))
@@ -2934,9 +2885,7 @@
(walk-all-rooms xi yi zi
(+ tb (* (- ta tb)
(/ (distance (- xb xi) (- yb yi) (- zb zi))
- (distance (- xb xa) (- yb ya) (- zb za)))))
- 2
- )))))
+ (distance (- xb xa) (- yb ya) (- zb za))))))))))
;; Check to see if a segment intersects the inner sphere:
;; points inside are rendered differently so we need to
@@ -2951,11 +2900,12 @@
(* inside-radius inside-radius)))
(disc (- (* bsq bsq) u))
(hit (>= disc 0.0)))
- (if hit
+ (if (not hit)
+ (change-direction xa ya za ta xb yb zb tb)
;; ray defined by two points hits sphere
(let* ((root (sqrt disc))
- (rin (- (- bsq) root))
- (rout (+ (- bsq) root))
+ (rin (- (+ bsq root)))
+ (rout (- root bsq))
(xi #f) (yi #f) (zi #f) (ti #f) (xo #f) (yo #f) (zo #f) (to #f))
(if (> mag rin 0) ;(and (> rin 0) (< rin mag))
;; intersects entering sphere
@@ -2977,18 +2927,17 @@
(distance (- xb xa) (- yb ya) (- zb za))))))))
(if xi
(begin
- (change-direction xa ya za ta xi yi zi ti 1)
+ (change-direction xa ya za ta xi yi zi ti)
(if xo
(begin
- (change-direction xi yi zi ti xo yo zo to 2)
- (change-direction xo yo zo to xb yb zb tb 3))
- (change-direction xi yi zi ti xb yb zb tb 4)))
+ (change-direction xi yi zi ti xo yo zo to)
+ (change-direction xo yo zo to xb yb zb tb))
+ (change-direction xi yi zi ti xb yb zb tb)))
(if xo
(begin
- (change-direction xa ya za ta xo yo zo to 5)
- (change-direction xo yo zo to xb yb zb tb 6))
- (change-direction xa ya za ta xb yb zb tb 7))))
- (change-direction xa ya za ta xb yb zb tb 8))))
+ (change-direction xa ya za ta xo yo zo to)
+ (change-direction xo yo zo to xb yb zb tb))
+ (change-direction xa ya za ta xb yb zb tb)))))))
;; Recursively split segment if longer than minimum rendering distance:
;; otherwise long line segments that have changes in distance render
@@ -3024,15 +2973,16 @@
(y1 (e (+ i 3)))
(area (if (< (abs (real-part (- y0 y1))) .0001)
(/ (- x1 x0) (* y0 all-x))
- (* (/ (- (log y1) (log y0))
- (- y1 y0))
- (/ (- x1 x0) all-x)))))
+ (/ (* (- (log y1) (log y0))
+ (- x1 x0))
+ (* (- y1 y0) all-x)))))
(set! dur (+ dur (abs (real-part area))))))))
;; Loop for each pair of points in the position envelope and render them
- (if (= (length xpoints) 1)
+ (if (and (pair? xpoints)
+ (null? (cdr xpoints)))
;; static source (we should check if this is inside the inner radius?)
- (walk-all-rooms (car xpoints) (car ypoints) (car zpoints) (car tpoints) 3)
+ (walk-all-rooms (car xpoints) (car ypoints) (car zpoints) (car tpoints))
;; moving source
(let ((len (- (min (length xpoints) (length ypoints) (length zpoints) (length tpoints)) 1)))
@@ -3048,7 +2998,7 @@
(tb (tpoints (+ i 1))))
(fminimum-segment-length xa ya za ta xb yb zb tb)
(if (= i len)
- (walk-all-rooms xb yb zb tb 4))))))
+ (walk-all-rooms xb yb zb tb))))))
;; create delay lines for output channels that need them
(if speakers
@@ -3067,7 +3017,7 @@
;;
;; this does not work quite right but the error leads to a longer
;; run with zeroed samples at the end so it should be fine
- ; (format #t "doppler: ~S~%" doppler)
+ ; (format () "doppler: ~S~%" doppler)
(set! real-dur (* duration (if (null? doppler) 1.0 (src-duration (reverse doppler)))))
@@ -3082,40 +3032,38 @@
;; sample at which signal first arrives to the listener
(set! start (+ run-beg (dist->samples (- first-dist (if initial-delay 0.0 min-dist)))))
;; minimum distance for unity gain calculation
- (set! min-dist-unity (if (< min-dist inside-radius)
- inside-radius
- min-dist))
+ (set! min-dist-unity (max min-dist inside-radius))
;; unity-gain gain scalers
(set! unity-gain (* scaler
(if (number? unity-gain-dist)
(expt unity-gain-dist direct-power)
- (if (not unity-gain-dist)
- (expt min-dist-unity direct-power)
- 1.0))))
+ (if unity-gain-dist
+ 1.0
+ (expt min-dist-unity direct-power)))))
(set! unity-rev-gain (* scaler
(if (number? unity-gain-dist)
(expt unity-gain-dist reverb-power)
- (if (not unity-gain-dist) ; defaults to #f above
- (expt min-dist-unity reverb-power)
- 1.0))))
+ (if unity-gain-dist ; defaults to #f above
+ 1.0
+ (expt min-dist-unity reverb-power)))))
;; unity-gain ambisonics gain scalers
(set! amb-unity-gain (* scaler
(if (number? unity-gain-dist)
(expt unity-gain-dist direct-power)
- (if (not unity-gain-dist)
- (expt min-dist-unity direct-power)
- 1.0))))
+ (if unity-gain-dist
+ 1.0
+ (expt min-dist-unity direct-power)))))
(set! amb-unity-rev-gain (* scaler
(if (number? unity-gain-dist)
(expt unity-gain-dist reverb-power)
- (if (not unity-gain-dist) ; defaults to #f above
- (expt min-dist-unity reverb-power)
- 1.0))))
+ (if unity-gain-dist ; defaults to #f above
+ 1.0
+ (expt min-dist-unity reverb-power)))))
;;; XXX hack!! this should be intercepted in the calling code, no 0 duration please...
(if (<= real-dur 0.0)
(begin
- (format #t ";;; ERROR: resetting real duration to 0.1 (was ~A)~%" real-dur)
+ (format () ";;; error: resetting real duration to 0.1 (was ~A)~%" real-dur)
(set! real-dur 0.1)))
(list
@@ -3151,15 +3099,14 @@
:duration real-dur)))
v)
;; :rev-gains
- (if (> rev-channels 0)
- (let ((v (make-vector rev-channels)))
- (do ((i 0 (+ i 1)))
- ((= i rev-channels))
- (set! (v i) (make-env (reverse (channel-rev-gains i))
- :scaler (if (= render-using ambisonics) amb-unity-rev-gain unity-rev-gain)
- :duration real-dur)))
- v)
- #f)
+ (and (> rev-channels 0)
+ (let ((v (make-vector rev-channels)))
+ (do ((i 0 (+ i 1)))
+ ((= i rev-channels))
+ (set! (v i) (make-env (reverse (channel-rev-gains i))
+ :scaler (if (= render-using ambisonics) amb-unity-rev-gain unity-rev-gain)
+ :duration real-dur)))
+ v))
;; :out-map
(if speakers
(speaker-config-map speakers)
diff --git a/draw.scm b/draw.scm
index 60bfbac..b235935 100644
--- a/draw.scm
+++ b/draw.scm
@@ -72,20 +72,20 @@
(x0 0)
(y0 0)
(line-ctr 2)
- (lines (make-vector (* 2 (+ 1 (- (axinf 12) (axinf 10)))) 0)))
+ (lines (make-vector (* 2 (- (+ (axinf 12) 1) (axinf 10))) 0)))
(dynamic-wind
(lambda ()
(set! (foreground-color snd chn) red))
(lambda ()
- (if (< start left) ; check previous samples to get first rms value
- (do ((i start (+ 1 i)))
+ (if (< start left) ; check previous samples to get first rms value
+ (do ((i start (+ 1 i)))
((= i left))
(moving-rms rms (reader))))
(let ((first-sample (next-sample reader)))
(set! x0 (grf-it (* left sr) xdata))
- (set! y0 (grf-it first-sample ydata))
- (set! (lines 0) x0) ; first graph point
- (set! (lines 1) y0))
+ (set! y0 (grf-it first-sample ydata)))
+ (set! (lines 0) x0) ; first graph point
+ (set! (lines 1) y0)
(do ((i (+ left 1) (+ 1 i))) ; loop through all samples calling moving-rms
((= i right))
(let ((x1 (grf-it (* i sr) xdata))
@@ -121,29 +121,29 @@ whenever they're in the current view."))
(end (+ beg dur))
(old-color (foreground-color snd chn))
(cr (make-cairo (car (channel-widgets snd chn)))))
- (if (and (< left end)
- (> right beg))
- (let ((data (make-graph-data snd chn)))
- (if (float-vector? data)
- (let* ((samps (- (min right end) (max left beg)))
- (offset (max 0 (- beg left)))
- (new-data (float-vector-subseq data offset (+ offset samps))))
- (set! (foreground-color snd chn) color)
- (graph-data new-data snd chn copy-context (max beg left) (min end right) (time-graph-style snd chn) cr)
- (set! (foreground-color snd chn) old-color))
- (let* ((low-data (car data))
- (high-data (cadr data))
- (size (length low-data))
- (samps (- right left))
- (left-offset (max 0 (- beg left)))
- (left-bin (floor (/ (* size left-offset) samps)))
- (right-offset (- (min end right) left))
- (right-bin (floor (/ (* size right-offset) samps)))
- (new-low-data (float-vector-subseq low-data left-bin right-bin))
- (new-high-data (float-vector-subseq high-data left-bin right-bin)))
- (set! (foreground-color snd chn) color)
- (graph-data (list new-low-data new-high-data) snd chn copy-context left-bin right-bin (time-graph-style snd chn) cr)
- (set! (foreground-color snd chn) old-color)))))
+ (when (and (< left end)
+ (> right beg))
+ (let ((data (make-graph-data snd chn)))
+ (if (float-vector? data)
+ (let* ((samps (- (min right end) (max left beg)))
+ (offset (max 0 (- beg left)))
+ (new-data (float-vector-subseq data offset (+ offset samps))))
+ (set! (foreground-color snd chn) color)
+ (graph-data new-data snd chn copy-context (max beg left) (min end right) (time-graph-style snd chn) cr)
+ (set! (foreground-color snd chn) old-color))
+ (let* ((low-data (car data))
+ (high-data (cadr data))
+ (size (length low-data))
+ (samps (- right left))
+ (left-offset (max 0 (- beg left)))
+ (left-bin (floor (/ (* size left-offset) samps)))
+ (right-offset (- (min end right) left))
+ (right-bin (floor (/ (* size right-offset) samps)))
+ (new-low-data (float-vector-subseq low-data left-bin right-bin))
+ (new-high-data (float-vector-subseq high-data left-bin right-bin)))
+ (set! (foreground-color snd chn) color)
+ (graph-data (list new-low-data new-high-data) snd chn copy-context left-bin right-bin (time-graph-style snd chn) cr)
+ (set! (foreground-color snd chn) old-color)))))
(free-cairo cr)))))
@@ -153,7 +153,7 @@ whenever they're in the current view."))
;; intended as after-graph-hook member
;; run through 'colored-samples lists passing each to display-colored-samples
(let ((colors (channel-property 'colored-samples snd chn)))
- (if colors
+ (if (pair? colors)
(for-each
(lambda (vals)
(apply display-colored-samples (append vals (list snd chn))))
@@ -177,37 +177,36 @@ whenever they're in the current view."))
(define uncolor-samples
(let ((documentation "(uncolor-samples snd chn) cancels sample coloring in the given channel"))
(lambda* (usnd uchn)
- (let* ((snd (or usnd (selected-sound) (car (sounds))))
- (chn (or uchn (selected-channel snd) 0)))
+ (let* ((snd (or usnd (selected-sound) (car (sounds))))
+ (chn (or uchn (selected-channel snd) 0)))
(set! (channel-property 'colored-samples snd chn) ())
(update-time-graph snd chn)))))
-
(define display-previous-edits
(let ((documentation "(display-previous-edits snd chn) displays all edits of the current sound, with older versions gradually fading away"))
(lambda (snd chn)
(let ((edits (edit-position snd chn)))
- (if (> edits 0)
- (let* ((old-color (foreground-color snd chn))
- (clist (color->list old-color))
- (r (car clist))
- (g (cadr clist))
- (b (caddr clist))
- (rinc (/ (- 1.0 r) (+ edits 1)))
- (ginc (/ (- 1.0 g) (+ edits 1)))
- (binc (/ (- 1.0 b) (+ edits 1)))
- (cr (make-cairo (car (channel-widgets snd chn)))))
- (do ((pos 0 (+ 1 pos))
- (re (- 1.0 rinc) (- re rinc))
- (ge (- 1.0 ginc) (- ge ginc))
- (be (- 1.0 binc) (- be binc)))
- ((> pos edits))
- (let ((data (make-graph-data snd chn pos)))
- (set! (foreground-color snd chn) (make-color re ge be))
- (graph-data data snd chn copy-context #f #f (time-graph-style snd chn) cr)))
- (set! (foreground-color snd chn) old-color)
- (free-cairo cr)))))))
+ (when (> edits 0)
+ (let* ((old-color (foreground-color snd chn))
+ (clist (color->list old-color))
+ (r (car clist))
+ (g (cadr clist))
+ (b (caddr clist))
+ (rinc (/ (- 1.0 r) (+ edits 1)))
+ (ginc (/ (- 1.0 g) (+ edits 1)))
+ (binc (/ (- 1.0 b) (+ edits 1)))
+ (cr (make-cairo (car (channel-widgets snd chn)))))
+ (do ((pos 0 (+ 1 pos))
+ (re (- 1.0 rinc) (- re rinc))
+ (ge (- 1.0 ginc) (- ge ginc))
+ (be (- 1.0 binc) (- be binc)))
+ ((> pos edits))
+ (let ((data (make-graph-data snd chn pos)))
+ (set! (foreground-color snd chn) (make-color re ge be))
+ (graph-data data snd chn copy-context #f #f (time-graph-style snd chn) cr)))
+ (set! (foreground-color snd chn) old-color)
+ (free-cairo cr)))))))
(define overlay-sounds
@@ -234,35 +233,35 @@ whenever they're in the current view."))
(define samples-via-colormap
(let ((documentation "(samples-via-colormap snd chn) displays time domain graph using current colormap (just an example of colormap-ref)"))
(lambda (snd chn)
- (let ((left (left-sample snd chn))
- (right (right-sample snd chn))
- (old-color (foreground-color snd chn))
- (data (make-graph-data snd chn))
+ (let ((data (make-graph-data snd chn))
(cr (make-cairo (car (channel-widgets snd chn)))))
(define (samples-1 cur-data)
- (let* ((x0 (x->position (/ left (srate snd))))
- (y0 (y->position (cur-data 0)))
- (colors (make-vector *colormap-size* #f))
- (len (length cur-data))
- (incr (/ (+ 1 (- right left)) len)))
- (do ((i (+ left incr) (+ i incr))
- (j 1 (+ 1 j)))
- ((or (>= i right)
- (>= j len)))
- (let* ((x1 (x->position (/ i (srate snd))))
- (y1 (y->position (cur-data j)))
- (x (abs (cur-data j)))
- (ref (floor (* *colormap-size* x)))
- (color (or (colors ref)
- (let ((new-color (apply make-color (colormap-ref (colormap) x))))
- (set! (colors ref) new-color)))))
- (set! (foreground-color snd chn) color)
- (draw-line x0 y0 x1 y1 snd chn time-graph cr)
- (set! x0 x1)
- (set! y0 y1)))
- (set! (foreground-color snd chn) old-color)))
-
+ (let ((left (left-sample snd chn))
+ (right (right-sample snd chn))
+ (old-color (foreground-color snd chn))
+ (y0 (y->position (cur-data 0)))
+ (colors (make-vector *colormap-size* #f))
+ (len (length cur-data)))
+ (let ((x0 (x->position (/ left (srate snd))))
+ (incr (/ (- (+ right 1) left) len)))
+ (do ((i (+ left incr) (+ i incr))
+ (j 1 (+ 1 j)))
+ ((or (>= i right)
+ (>= j len)))
+ (let ((x1 (x->position (/ i (srate snd))))
+ (y1 (y->position (cur-data j))))
+ (let* ((x (abs (cur-data j)))
+ (ref (floor (* *colormap-size* x))))
+ (set! (foreground-color snd chn)
+ (or (colors ref)
+ (let ((new-color (apply make-color (colormap-ref (colormap) x))))
+ (set! (colors ref) new-color)))))
+ (draw-line x0 y0 x1 y1 snd chn time-graph cr)
+ (set! x0 x1)
+ (set! y0 y1)))
+ (set! (foreground-color snd chn) old-color))))
+
(if data
(if (float-vector? data)
(samples-1 data)
diff --git a/dsp.scm b/dsp.scm
index 49ca44a..3009c85 100644
--- a/dsp.scm
+++ b/dsp.scm
@@ -50,8 +50,10 @@
(y1 (e (+ i 3)))
(area (if (< (abs (- y0 y1)) .0001)
(/ (- x1 x0) (* y0 all-x))
- (* (/ (- (log y1) (log y0)) (- y1 y0)) ; or (/ (log (/ y1 y0)) (- y1 y0))
- (/ (- x1 x0) all-x)))))
+ (/ (* (- (log y1) (log y0)) (- x1 x0))
+ (* (- y1 y0) all-x)))))
+ ;; or (* (/ (- (log y1) (log y0)) (- y1 y0)) ; or (/ (log (/ y1 y0)) (- y1 y0))
+ ;; (/ (- x1 x0) all-x)))
(set! dur (+ dur (abs area)))))))))
;;; :(src-duration '(0 1 1 2))
@@ -83,8 +85,7 @@
(set! (rl i) (real-part val))
(set! (im i) (imag-part val)))) ;this is always essentially 0.0
(fft rl im -1) ;direction could also be 1
- (let ((pk (float-vector-peak rl)))
- (float-vector-scale! rl (/ 1.0 pk)))
+ (float-vector-scale! rl (/ 1.0 (float-vector-peak rl)))
(do ((i 0 (+ i 1))
(j (/ N 2)))
((= i N))
@@ -105,13 +106,12 @@
(freq (/ pi N))
(vals (make-vector N))
(w (make-vector N))
- (pk 0.0)
- (mult -1))
- (do ((i 0 (+ i 1))
+ (pk 0.0))
+ (do ((mult -1 (- mult))
+ (i 0 (+ i 1))
(phase (* -0.5 pi) (+ phase freq)))
((= i N))
- (set! (vals i) (* mult den (cos (* N (acos (* alpha (cos phase)))))))
- (set! mult (- mult)))
+ (set! (vals i) (* mult den (cos (* N (acos (* alpha (cos phase))))))))
;; now take the DFT
(do ((i 0 (+ i 1)))
((= i N))
@@ -120,7 +120,7 @@
((= k N))
(set! sum (+ sum (* (vals k) (exp (/ (* 2.0 0+1.0i pi k i) N))))))
(set! (w i) (magnitude sum))
- (if (> (w i) pk) (set! pk (w i)))))
+ (set! pk (max pk (w i)))))
;; scale to 1.0 (it's usually pretty close already, that is pk is close to 1.0)
(do ((i 0 (+ i 1)))
((= i N))
@@ -302,9 +302,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(set! mx (float-vector-max vals))
(do ((k 0 (+ k 1)))
((= k size))
- (if (negative? (float-vector-ref vals k))
- (float-vector-set! data (+ i k) mn)
- (float-vector-set! data (+ i k) mx))))
+ (float-vector-set! data (+ i k) (if (negative? (float-vector-ref vals k)) mn mx))))
(float-vector->channel data beg len snd chn current-edit-position (format #f "adsat ~A ~A ~A" size beg dur)))))))
@@ -336,14 +334,14 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(lambda* (snd chn)
(let* ((len (framples snd chn))
(data (channel->float-vector 0 (+ len 2) snd chn))
- (amp (maxamp snd chn))) ; keep resultant peak at maxamp
- ;; multiply x[0]*x[1]*x[2]
- (let ((data1 (make-float-vector (+ len 1))))
- (copy data data1 1)
- (float-vector-abs! (float-vector-multiply! data1 data))
- (float-vector-multiply! data (make-shared-vector data1 (list len) 1))
- (let ((amp1 (/ amp (float-vector-peak data))))
- (float-vector->channel (float-vector-scale! data amp1) 0 len snd chn current-edit-position "spike")))))))
+ (amp (maxamp snd chn)) ; keep resultant peak at maxamp
+ ;; multiply x[0]*x[1]*x[2]
+ (data1 (make-float-vector (+ len 1))))
+ (copy data data1 1)
+ (float-vector-abs! (float-vector-multiply! data1 data))
+ (float-vector-multiply! data (make-shared-vector data1 (list len) 1))
+ (let ((amp1 (/ amp (float-vector-peak data))))
+ (float-vector->channel (float-vector-scale! data amp1) 0 len snd chn current-edit-position "spike"))))))
;;; the more successive samples we include in the product, the more we
;;; limit the output to pulses placed at (just after) wave peaks
@@ -382,23 +380,26 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
;;; -------- chorus (doesn't always work and needs speedup)
(define chorus-size 5)
-(define chorus-time .05)
-(define chorus-amount 20.0)
-(define chorus-speed 10.0)
(define chorus
(let ((documentation "(chorus) tries to produce the chorus sound effect"))
(lambda ()
- (define (make-flanger)
- (let* ((ri (make-rand-interp :frequency chorus-speed :amplitude chorus-amount))
- (len (floor (random (* 3.0 chorus-time (srate)))))
- (gen (make-delay len :max-size (+ len chorus-amount 1))))
- (list gen ri)))
+
+ (define make-flanger
+ (let ((chorus-time .05)
+ (chorus-amount 20.0)
+ (chorus-speed 10.0))
+ (lambda ()
+ (let ((ri (make-rand-interp :frequency chorus-speed :amplitude chorus-amount))
+ (len (floor (random (* 3.0 chorus-time (srate))))))
+ (list (make-delay len :max-size (+ len chorus-amount 1)) ri)))))
+
(define (flanger dly inval)
(+ inval
(delay (car dly)
inval
(rand-interp (cadr dly)))))
+
(let ((dlys (make-vector chorus-size)))
(do ((i 0 (+ i 1)))
((= i chorus-size))
@@ -587,15 +588,15 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((k (+ i len))
(denom (* pi i))
(num (- 1.0 (cos (* pi i)))))
- (if (or (= num 0.0)
- (= i 0))
- (set! (arr k) 0.0)
- ;; this is the "ideal" -- rectangular window -- version:
- ;; (set! (arr k) (/ num denom))
- ;; this is the Hamming window version:
- (set! (arr k) (* (/ num denom)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))) ; window
- )))
+ (set! (arr k)
+ (if (or (= num 0.0)
+ (= i 0))
+ 0.0
+ ;; this is the "ideal" -- rectangular window -- version:
+ ;; (set! (arr k) (/ num denom))
+ ;; this is the Hamming window version:
+ (* (/ num denom)
+ (+ .54 (* .46 (cos (/ (* i pi) len))))))))) ; window
(make-fir-filter arrlen arr)))))
(define hilbert-transform fir-filter)
@@ -657,10 +658,11 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((k (+ i len))
(denom (* pi i))
(num (- (sin (* fc i)))))
- (if (= i 0)
- (set! (arr k) (- 1.0 (/ fc pi)))
- (set! (arr k) (* (/ num denom)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
+ (set! (arr k)
+ (if (= i 0)
+ (- 1.0 (/ fc pi))
+ (* (/ num denom)
+ (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(make-fir-filter arrlen arr)))))
(define highpass fir-filter)
@@ -684,10 +686,11 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((k (+ i len))
(denom (* pi i))
(num (sin (* fc i))))
- (if (= i 0)
- (set! (arr k) (/ fc pi))
- (set! (arr k) (* (/ num denom)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
+ (set! (arr k)
+ (if (= i 0)
+ (/ fc pi)
+ (* (/ num denom)
+ (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(make-fir-filter arrlen arr)))))
(define lowpass fir-filter)
@@ -710,10 +713,11 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((k (+ i len))
(denom (* pi i))
(num (- (sin (* fhi i)) (sin (* flo i)))))
- (if (= i 0)
- (set! (arr k) (/ (- fhi flo) pi))
- (set! (arr k) (* (/ num denom)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
+ (set! (arr k)
+ (if (= i 0)
+ (/ (- fhi flo) pi)
+ (* (/ num denom)
+ (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(make-fir-filter arrlen arr)))))
(define bandpass fir-filter)
@@ -751,10 +755,11 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((k (+ i len))
(denom (* pi i))
(num (- (sin (* flo i)) (sin (* fhi i)))))
- (if (= i 0)
- (set! (arr k) (- 1.0 (/ (- fhi flo) pi)))
- (set! (arr k) (* (/ num denom)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
+ (set! (arr k)
+ (if (= i 0)
+ (- 1.0 (/ (- fhi flo) pi))
+ (* (/ num denom)
+ (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(make-fir-filter arrlen arr)))))
(define bandstop fir-filter)
@@ -775,10 +780,11 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(do ((i (- len) (+ i 1)))
((= i len))
(let ((k (+ i len)))
- (if (= i 0)
- (set! (arr k) 0.0)
- (set! (arr k) (* (/ (cos (* pi i)) i)
- (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
+ (set! (arr k)
+ (if (= i 0)
+ 0.0
+ (* (/ (cos (* pi i)) i)
+ (+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(make-fir-filter arrlen arr)))))
(define differentiator fir-filter)
@@ -810,14 +816,14 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
;; this is the same as iir-low-pass-2 below with 'din' set to (sqrt 2.0) -- similarly with the others
(let* ((r (tan (/ (* pi fq) (srate))))
(r2 (* r r))
- (c1 (/ 1.0 (+ 1.0 (* r (sqrt 2.0)) r2)))
- (c2 (* -2.0 c1))
- (c3 c1)
- (c4 (* 2.0 (- r2 1.0) c1))
- (c5 (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1)))
+ (c1 (/ 1.0 (+ 1.0 (* r (sqrt 2.0)) r2))))
(make-filter 3
- (float-vector c1 c2 c3)
- (float-vector 0.0 c4 c5))))))
+ (float-vector c1
+ (* -2.0 c1)
+ c1)
+ (float-vector 0.0
+ (* 2.0 (- r2 1.0) c1)
+ (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1)))))))
(define make-butter-low-pass
(let ((documentation "(make-butter-low-pass freq) makes a Butterworth filter with low pass cutoff at 'freq'. The result \
@@ -825,28 +831,24 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(lambda (fq)
(let* ((r (/ 1.0 (tan (/ (* pi fq) (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)))
+ (c1 (/ 1.0 (+ 1.0 (* r (sqrt 2.0)) r2))))
(make-filter 3
- (float-vector c1 c2 c3)
- (float-vector 0.0 c4 c5))))))
+ (float-vector c1 (* 2.0 c1) c1)
+ (float-vector 0.0
+ (* 2.0 (- 1.0 r2) c1)
+ (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1)))))))
(define make-butter-band-pass
(let ((documentation "(make-butter-band-pass freq band) makes a bandpass Butterworth filter with low edge at 'freq' and width 'band'"))
(lambda (fq bw)
(let* ((d (* 2.0 (cos (/ (* 2.0 pi fq) (srate)))))
(c (/ 1.0 (tan (/ (* pi bw) (srate)))))
- (c1 (/ 1.0 (+ 1.0 c)))
- (c2 0.0)
- (c3 (- c1))
- (c4 (* (- c) d c1))
- (c5 (* (- c 1.0) c1)))
+ (c1 (/ 1.0 (+ 1.0 c))))
(make-filter 3
- (float-vector c1 c2 c3)
- (float-vector 0.0 c4 c5))))))
+ (float-vector c1 0.0 (- c1))
+ (float-vector 0.0
+ (* (- c) d c1)
+ (* (- c 1.0) c1)))))))
(define make-butter-band-reject
(let ((documentation "(make-butter-band-reject freq band) makes a band-reject Butterworth filter with low edge at 'freq' and width 'band'"))
@@ -854,13 +856,10 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(let* ((d (* 2.0 (cos (/ (* 2.0 pi fq) (srate)))))
(c (tan (/ (* pi bw) (srate))))
(c1 (/ 1.0 (+ 1.0 c)))
- (c2 (* (- d) c1))
- (c3 c1)
- (c4 c2)
- (c5 (* (- 1.0 c) c1)))
+ (c2 (* (- d) c1)))
(make-filter 3
- (float-vector c1 c2 c3)
- (float-vector 0.0 c4 c5))))))
+ (float-vector c1 c2 c1)
+ (float-vector 0.0 c2 (* (- 1.0 c) c1)))))))
;;; simplest use is (filter-sound (make-butter-low-pass 500.0))
;;; see also effects.scm
@@ -886,10 +885,8 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(beta (* 0.5 (/ (- 1.0 (* (/ d 2) (sin theta)))
(+ 1.0 (* (/ d 2) (sin theta))))))
(gamma (* (+ 0.5 beta) (cos theta)))
- (alpha (* 0.5 (+ 0.5 beta (- gamma)))))
- (make-filter 3
- (float-vector alpha (* 2.0 alpha) alpha)
- (float-vector 0.0 (* -2.0 gamma) (* 2.0 beta)))))
+ (alpha (* 0.5 (- (+ 0.5 beta) gamma))))
+ (make-biquad alpha (* 2.0 alpha) alpha (* -2.0 gamma) (* 2.0 beta))))
(define* (make-iir-high-pass-2 fc din)
(let* ((theta (/ (* 2 pi fc) *clm-srate*))
@@ -898,9 +895,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 (* (/ d 2) (sin theta))))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (* 0.5 (+ 0.5 beta gamma))))
- (make-filter 3
- (float-vector alpha (* -2.0 alpha) alpha)
- (float-vector 0.0 (* -2.0 gamma) (* 2.0 beta)))))
+ (make-biquad alpha (* -2.0 alpha) alpha (* -2.0 gamma) (* 2.0 beta))))
(define (make-iir-band-pass-2 f1 f2)
(let* ((theta (/ (* 2 pi (sqrt (* f1 f2))) *clm-srate*))
@@ -910,9 +905,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (- 0.5 beta)))
- (make-filter 3
- (float-vector alpha 0.0 (- alpha))
- (float-vector 0.0 (* -2.0 gamma) (* 2.0 beta)))))
+ (make-biquad alpha 0.0 (- alpha) (* -2.0 gamma) (* 2.0 beta))))
(define (make-iir-band-stop-2 f1 f2)
(let* ((theta (/ (* 2 pi (sqrt (* f1 f2))) *clm-srate*))
@@ -922,10 +915,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (+ 0.5 beta)))
- (make-filter 3
- (float-vector alpha (* -2.0 gamma) alpha)
- (float-vector 0.0 (* -2.0 gamma) (* 2.0 beta)))))
-
+ (make-biquad alpha (* -2.0 gamma) alpha (* -2.0 gamma) (* 2.0 beta))))
#|
(define* (old-make-eliminate-hum (hum-freq 60.0) (hum-harmonics 5) (bandwidth 10))
@@ -974,9 +964,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (- 0.5 beta))
- (flt (make-filter 3
- (float-vector alpha 0.0 (- alpha))
- (float-vector 0.0 (* -2.0 gamma) (* 2.0 beta))))
+ (flt (make-biquad alpha 0.0 (- alpha) (* -2.0 gamma) (* 2.0 beta)))
(m1 (- m 1.0)))
(lambda (x) (+ x (* m1 (filter flt x))))))
@@ -990,7 +978,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(do ((n 0 (+ n 1)))
((= n (+ L M)))
(let ((sum 0.0)
- (start (max 0 (- n (+ L 1))))
+ (start (max 0 (- n L 1)))
(end (min n M)))
(do ((m start (+ m 1)))
((> m end))
@@ -1022,7 +1010,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(beta (* 0.5 (/ (- 1.0 (* 0.5 d st))
(+ 1.0 (* 0.5 d st)))))
(gamma (* ct (+ 0.5 beta)))
- (alpha (* 0.25 (+ 0.5 beta (- gamma)))))
+ (alpha (* 0.25 (- (+ 0.5 beta) gamma))))
(set! xcoeffs (cons (float-vector (* 2 alpha) (* 4 alpha) (* 2 alpha)) xcoeffs))
(set! ycoeffs (cons (float-vector 1.0 (* -2.0 gamma) (* 2.0 beta)) ycoeffs))))
(make-filter (+ 1 (* 2 M))
@@ -1071,9 +1059,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ Ak (sqrt (- (* Ak Ak) 1))))))
(Bk (* de2 (/ Dk dk1)))
(Wk (real-part (+ Bk (sqrt (- (* Bk Bk) 1.0))))) ; fp inaccuracies causing tiny (presumably bogus) imaginary part here
- (thetajk (if (= j 1)
- (* 2 (atan tn0 Wk))
- (* 2 (atan (* tn0 Wk)))))
+ (thetajk (* 2 (if (= j 1) (atan tn0 Wk) (atan (* tn0 Wk)))))
(betajk (* 0.5 (/ (- 1.0 (* 0.5 dk1 (sin thetajk)))
(+ 1.0 (* 0.5 dk1 (sin thetajk))))))
(gammajk (* (+ 0.5 betajk) (cos thetajk)))
@@ -1112,9 +1098,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ Ak (sqrt (- (* Ak Ak) 1))))))
(Bk (* de2 (/ Dk dk1)))
(Wk (real-part (+ Bk (sqrt (- (* Bk Bk) 1.0)))))
- (thetajk (if (= j 1)
- (* 2 (atan tn0 Wk))
- (* 2 (atan (* tn0 Wk)))))
+ (thetajk (* 2 (if (= j 1) (atan tn0 Wk) (atan (* tn0 Wk)))))
(betajk (* 0.5 (/ (- 1.0 (* 0.5 dk1 (sin thetajk)))
(+ 1.0 (* 0.5 dk1 (sin thetajk))))))
(gammajk (* (+ 0.5 betajk) (cos thetajk)))
@@ -1137,14 +1121,10 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(let ((freq-response (list 1.0 0.0)))
(for-each
(lambda (i)
- (set! freq-response (cons (/ (* 2 (- i notch-width)) cur-srate) freq-response)) ; left upper y hz
- (set! freq-response (cons 1.0 freq-response)) ; left upper y resp
- (set! freq-response (cons (/ (* 2 (- i (/ notch-width 2))) cur-srate) freq-response)) ; left bottom y hz
- (set! freq-response (cons 0.0 freq-response)) ; left bottom y resp
- (set! freq-response (cons (/ (* 2 (+ i (/ notch-width 2))) cur-srate) freq-response)) ; right bottom y hz
- (set! freq-response (cons 0.0 freq-response)) ; right bottom y resp
- (set! freq-response (cons (/ (* 2 (+ i notch-width)) cur-srate) freq-response)) ; right upper y hz
- (set! freq-response (cons 1.0 freq-response))) ; right upper y resp
+ (set! freq-response (cons 1.0 (cons (/ (* 2 (- i notch-width)) cur-srate) freq-response))) ; left upper y resp hz
+ (set! freq-response (cons 0.0 (cons (/ (* 2 (- i (/ notch-width 2))) cur-srate) freq-response))) ; left bottom y resp hz
+ (set! freq-response (cons 0.0 (cons (/ (* 2 (+ i (/ notch-width 2))) cur-srate) freq-response))) ; right bottom y resp hz
+ (set! freq-response (cons 1.0 (cons (/ (* 2 (+ i notch-width)) cur-srate) freq-response)))) ; right upper y resp hz
freqs)
(set! freq-response (cons 1.0 (cons 1.0 freq-response)))
(reverse freq-response)))
@@ -1313,35 +1293,33 @@ the era when computers were human beings"))
0.0
(if (not e)
(random amount)
- (letrec ((next-random
- (lambda ()
- (let* ((len (length e))
- (x (random (* 1.0 (e (- len 2)))))
- (y (random 1.0)))
- (if (<= y (envelope-interp x e))
- x
- (next-random))))))
- (next-random)))))
+ (let next-random ()
+ (let* ((len (length e))
+ (x (random (* 1.0 (e (- len 2)))))
+ (y (random 1.0)))
+ (if (<= y (envelope-interp x e))
+ x
+ (next-random)))))))
(define (gaussian-distribution s)
- (let ((e ())
- (den (* 2.0 s s)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .05))
- (y -4.0 (+ y .4)))
- ((= i 21))
- (set! e (cons (exp (- (/ (* y y) den))) (cons x e))))
- (reverse e)))
-
+ (do ((e ())
+ (den (* 2.0 s s))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x .05))
+ (y -4.0 (+ y .4)))
+ ((= i 21)
+ (reverse e))
+ (set! e (cons (exp (- (/ (* y y) den))) (cons x e)))))
+
(define (pareto-distribution a)
- (let ((e ())
- (scl (/ (expt 1.0 (+ a 1.0)) a)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .05))
- (y 1.0 (+ y .2)))
- ((= i 21))
- (set! e (cons (* scl (/ a (expt y (+ a 1.0)))) (cons x e))))
- (reverse e)))
+ (do ((e ())
+ (scl (/ (expt 1.0 (+ a 1.0)) a))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x .05))
+ (y 1.0 (+ y .2)))
+ ((= i 21)
+ (reverse e))
+ (set! e (cons (* scl (/ a (expt y (+ a 1.0)))) (cons x e)))))
;(map-channel (lambda (y) (any-random 1.0 '(0 1 1 1)))) ; uniform distribution
;(map-channel (lambda (y) (any-random 1.0 '(0 0 0.95 0.1 1 1)))) ; mostly toward 1.0
@@ -1372,14 +1350,14 @@ the era when computers were human beings"))
data)))
(define (gaussian-envelope s)
- (let ((e ())
- (den (* 2.0 s s)))
- (do ((i 0 (+ i 1))
- (x -1.0 (+ x .1))
- (y -4.0 (+ y .4)))
- ((= i 21))
- (set! e (cons (exp (- (/ (* y y) den))) (cons x e))))
- (reverse e)))
+ (do ((e ())
+ (den (* 2.0 s s))
+ (i 0 (+ i 1))
+ (x -1.0 (+ x .1))
+ (y -4.0 (+ y .4)))
+ ((= i 21)
+ (reverse e))
+ (set! e (cons (exp (- (/ (* y y) den))) (cons x e)))))
;;; (make-rand :envelope (gaussian-envelope 1.0))
@@ -1431,9 +1409,9 @@ the era when computers were human beings"))
(let ((documentation "(channel-variance snd chn) returns the sample variance in the given channel: <f,f>-((<f,1>/ n)^2"))
(lambda* (snd chn)
(let* ((N (framples snd chn))
- (mu (* (/ N (- N 1)) (channel-mean snd chn))) ; avoid bias sez JOS
- (P (channel-total-energy snd chn)))
- (- P (* mu mu))))))
+ (mu (* (/ N (- N 1)) (channel-mean snd chn)))) ; avoid bias sez JOS
+ (- (channel-total-energy snd chn)
+ (* mu mu))))))
(define channel-norm ; sqrt(<f, f>)
(let ((documentation "(channel-norm snd chn) returns the norm of the samples in the given channel: sqrt(<f,f>)"))
@@ -1705,11 +1683,12 @@ shift the given channel in pitch without changing its length. The higher 'order
((= i num-coeffs))
(copy sound rl2)
(convolution rl1 rl2 fft-len)
- (let ((pk (float-vector-peak rl1)))
- (float-vector-add! newv (float-vector-scale! (copy rl1) (/ (* (coeffs i) peak) pk)))))
- (let ((pk (float-vector-peak newv)))
- (float-vector-scale! newv (/ peak pk)))))))
- (float-vector->channel newv 0 (max len (* len (- num-coeffs 1))) snd chn #f (format #f "spectral-polynomial ~A" (float-vector->string coeffs)))))
+ (float-vector-add! newv (float-vector-scale! (copy rl1)
+ (/ (* (coeffs i) peak) (float-vector-peak rl1)))))
+ (float-vector-scale! newv (/ peak (float-vector-peak newv)))))))
+ (float-vector->channel newv 0 (max len (* len (- num-coeffs 1)))
+ snd chn #f
+ (format #f "spectral-polynomial ~A" (float-vector->string coeffs)))))
;;; ----------------
@@ -1806,12 +1785,12 @@ the rendering frequency, the number of measurements per second; 'db-floor' is th
(set! (nfilt 0) (/ 1.0 (coeffs 0)))
(do ((i 1 (+ i 1)))
((= i order))
- (let ((sum 0.0))
- (do ((j 0 (+ j 1))
- (k i (- k 1)))
- ((= j i))
- (set! sum (+ sum (* (nfilt j) (coeffs k)))))
- (set! (nfilt i) (/ sum (- (coeffs 0))))))
+ (do ((sum 0.0)
+ (j 0 (+ j 1))
+ (k i (- k 1)))
+ ((= j i)
+ (set! (nfilt i) (/ sum (- (coeffs 0)))))
+ (set! sum (+ sum (* (nfilt j) (coeffs k))))))
nfilt)))))
@@ -1948,10 +1927,8 @@ and replaces it with the spectrum given in coeffs"))
(set! next (read-sample rd)))
(set! pos (- pos num))))
(set! intrp (+ pos sr))
- (+ last (* pos (- next last))))
- ))))
- (len (framples tempfile)))
- (set-samples 0 (- len 1) tempfile snd chn #t "linear-src" 0 #f #t)
+ (+ last (* pos (- next last)))))))))
+ (set-samples 0 (- (framples tempfile) 1) tempfile snd chn #t "linear-src" 0 #f #t)
;; first #t=truncate to new length, #f=at current edpos, #t=auto delete temp file
))))
@@ -1986,74 +1963,74 @@ and replaces it with the spectrum given in coeffs"))
(ls (left-sample snd chn))
(rs (right-sample snd chn))
(fftlen (floor (expt 2 (ceiling (log (+ 1 (- rs ls)) 2))))))
- (if (> fftlen 0)
- (let ((data (channel->float-vector ls fftlen snd chn))
- (normalized (not (= (transform-normalization snd chn) dont-normalize)))
- (linear #t)) ; can't currently show lisp graph in dB
- ;; snd-axis make_axes: WITH_LOG_Y_AXIS, but LINEAR currently in snd-chn.c 3250
- (if (float-vector? data)
- (let ((fftdata (snd-spectrum data ; returns fftlen / 2 data points
- (fft-window snd chn) fftlen linear
- (fft-window-beta snd chn) #f normalized)))
- (if (float-vector? fftdata)
- (let* ((sr (srate snd))
- (mx (float-vector-peak fftdata))
- (data-len (length fftdata))
-
- ;; bark settings
- (bark-low (floor (bark 20.0)))
- (bark-high (ceiling (bark (* 0.5 sr))))
- (bark-frqscl (/ data-len (- bark-high bark-low)))
- (bark-data (make-float-vector data-len))
-
- ;; mel settings
- (mel-low (floor (mel 20.0)))
- (mel-high (ceiling (mel (* 0.5 sr))))
- (mel-frqscl (/ data-len (- mel-high mel-low)))
- (mel-data (make-float-vector data-len))
-
- ;; erb settings
- (erb-low (floor (erb 20.0)))
- (erb-high (ceiling (erb (* 0.5 sr))))
- (erb-frqscl (/ data-len (- erb-high erb-low)))
- (erb-data (make-float-vector data-len)))
-
- (set! bark-fft-size fftlen)
-
- (do ((i 0 (+ i 1)))
- ((= i data-len))
- (let* ((val (fftdata i))
- (frq (* sr (/ i fftlen)))
- (bark-bin (round (* bark-frqscl (- (bark frq) bark-low))))
- (mel-bin (round (* mel-frqscl (- (mel frq) mel-low))))
- (erb-bin (round (* erb-frqscl (- (erb frq) erb-low)))))
- (if (and (>= bark-bin 0)
- (< bark-bin data-len))
- (set! (bark-data bark-bin) (+ val (bark-data bark-bin))))
- (if (and (>= mel-bin 0)
- (< mel-bin data-len))
- (set! (mel-data mel-bin) (+ val (mel-data mel-bin))))
- (if (and (>= erb-bin 0)
- (< erb-bin data-len))
- (set! (erb-data erb-bin) (+ val (erb-data erb-bin))))))
-
- (if normalized
- (let ((bmx (float-vector-peak bark-data))
- (mmx (float-vector-peak mel-data))
- (emx (float-vector-peak erb-data)))
- (if (> (abs (- mx bmx)) .01)
- (float-vector-scale! bark-data (/ mx bmx)))
- (if (> (abs (- mx mmx)) .01)
- (float-vector-scale! mel-data (/ mx mmx)))
- (if (> (abs (- mx emx)) .01)
- (float-vector-scale! erb-data (/ mx emx)))))
-
- (graph (list bark-data mel-data erb-data)
- "ignored"
- 20.0 (* 0.5 sr)
- 0.0 (if normalized 1.0 (* data-len (y-zoom-slider snd chn)))
- snd chn
- #f show-bare-x-axis)))))))
+ (when (> fftlen 0)
+ (let ((data (channel->float-vector ls fftlen snd chn))
+ (normalized (not (= (transform-normalization snd chn) dont-normalize)))
+ (linear #t)) ; can't currently show lisp graph in dB
+ ;; snd-axis make_axes: WITH_LOG_Y_AXIS, but LINEAR currently in snd-chn.c 3250
+ (when (float-vector? data)
+ (let ((fftdata (snd-spectrum data ; returns fftlen / 2 data points
+ (fft-window snd chn) fftlen linear
+ (fft-window-beta snd chn) #f normalized)))
+ (when (float-vector? fftdata)
+ (let* ((sr (srate snd))
+ (mx (float-vector-peak fftdata))
+ (data-len (length fftdata))
+
+ ;; bark settings
+ (bark-low (floor (bark 20.0)))
+ (bark-high (ceiling (bark (* 0.5 sr))))
+ (bark-frqscl (/ data-len (- bark-high bark-low)))
+ (bark-data (make-float-vector data-len))
+
+ ;; mel settings
+ (mel-low (floor (mel 20.0)))
+ (mel-high (ceiling (mel (* 0.5 sr))))
+ (mel-frqscl (/ data-len (- mel-high mel-low)))
+ (mel-data (make-float-vector data-len))
+
+ ;; erb settings
+ (erb-low (floor (erb 20.0)))
+ (erb-high (ceiling (erb (* 0.5 sr))))
+ (erb-frqscl (/ data-len (- erb-high erb-low)))
+ (erb-data (make-float-vector data-len)))
+
+ (set! bark-fft-size fftlen)
+
+ (do ((i 0 (+ i 1)))
+ ((= i data-len))
+ (let* ((val (fftdata i))
+ (frq (* sr (/ i fftlen)))
+ (bark-bin (round (* bark-frqscl (- (bark frq) bark-low))))
+ (mel-bin (round (* mel-frqscl (- (mel frq) mel-low))))
+ (erb-bin (round (* erb-frqscl (- (erb frq) erb-low)))))
+ (if (and (>= bark-bin 0)
+ (< bark-bin data-len))
+ (set! (bark-data bark-bin) (+ val (bark-data bark-bin))))
+ (if (and (>= mel-bin 0)
+ (< mel-bin data-len))
+ (set! (mel-data mel-bin) (+ val (mel-data mel-bin))))
+ (if (and (>= erb-bin 0)
+ (< erb-bin data-len))
+ (set! (erb-data erb-bin) (+ val (erb-data erb-bin))))))
+
+ (if normalized
+ (let ((bmx (float-vector-peak bark-data))
+ (mmx (float-vector-peak mel-data))
+ (emx (float-vector-peak erb-data)))
+ (if (> (abs (- mx bmx)) .01)
+ (float-vector-scale! bark-data (/ mx bmx)))
+ (if (> (abs (- mx mmx)) .01)
+ (float-vector-scale! mel-data (/ mx mmx)))
+ (if (> (abs (- mx emx)) .01)
+ (float-vector-scale! erb-data (/ mx emx)))))
+
+ (graph (list bark-data mel-data erb-data)
+ "ignored"
+ 20.0 (* 0.5 sr)
+ 0.0 (if normalized 1.0 (* data-len (y-zoom-slider snd chn)))
+ snd chn
+ #f show-bare-x-axis)))))))
(list color1 color2 color3))) ; tell lisp graph display what colors to use
@@ -2066,56 +2043,59 @@ and replaces it with the spectrum given in coeffs"))
(let* ((axinfo (axis-info snd chn lisp-graph))
(axis-x0 (axinfo 10))
(axis-x1 (axinfo 12))
- (axis-y0 (axinfo 13))
(axis-y1 (axinfo 11))
(label-height 15)
(char-width 8)
- (sr2 (* 0.5 (srate snd)))
(minor-tick-len 6)
(major-tick-len 12)
- (tick-y0 axis-y1)
- (minor-y0 (+ axis-y1 minor-tick-len))
- (major-y0 (+ axis-y1 major-tick-len))
(bark-label-font (snd-font 3))
- (bark-numbers-font (snd-font 2))
(label-pos (+ axis-x0 (* .45 (- axis-x1 axis-x0))))
(cr (make-cairo (car (channel-widgets snd chn)))))
- (define (scale-position scale f)
- (let ((b20 (scale 20.0)))
- (round (+ axis-x0
- (/ (* (- axis-x1 axis-x0) (- (scale f) b20))
- (- (scale sr2) b20))))))
+ (define scale-position
+ (let ((sr2 (* 0.5 (srate snd))))
+ (lambda (scale f)
+ (let ((b20 (scale 20.0)))
+ (round (+ axis-x0
+ (/ (* (- axis-x1 axis-x0) (- (scale f) b20))
+ (- (scale sr2) b20))))))))
(define (bark-position f) (scale-position bark f))
(define (mel-position f) (scale-position mel f))
(define (erb-position f) (scale-position erb f))
- (define (draw-bark-ticks bark-function)
- (if bark-numbers-font (set! (current-font snd chn copy-context) bark-numbers-font))
-
- (draw-line axis-x0 tick-y0 axis-x0 major-y0 snd chn copy-context cr)
- (let ((i1000 (scale-position bark-function 1000.0))
- (i10000 (scale-position bark-function 10000.0)))
-
- (draw-line i1000 tick-y0 i1000 major-y0 snd chn copy-context cr)
- (draw-line i10000 tick-y0 i10000 major-y0 snd chn copy-context cr)
-
- (draw-string "20" axis-x0 major-y0 snd chn copy-context cr)
- (draw-string "1000" (- i1000 (* 3 4)) major-y0 snd chn copy-context cr)
- (draw-string "10000" (- i10000 (* 6 4)) major-y0 snd chn copy-context cr)
-
- (draw-string (format #f "fft size: ~D" bark-fft-size) (+ axis-x0 10) axis-y0 snd chn copy-context cr)
+ (define draw-bark-ticks
+ (let ((tick-y0 axis-y1)
+ (minor-y0 (+ axis-y1 minor-tick-len))
+ (major-y0 (+ axis-y1 major-tick-len))
+ (axis-y0 (axinfo 13))
+ (bark-numbers-font (snd-font 2)))
- (do ((i 100 (+ i 100)))
- ((= i 1000))
- (let ((i100 (scale-position bark-function i)))
- (draw-line i100 tick-y0 i100 minor-y0 snd chn copy-context cr)))
-
- (do ((i 2000 (+ i 1000)))
- ((= i 10000))
- (let ((i1000 (scale-position bark-function i)))
- (draw-line i1000 tick-y0 i1000 minor-y0 snd chn copy-context cr)))))
+ (lambda (bark-function)
+ (if bark-numbers-font (set! (current-font snd chn copy-context) bark-numbers-font))
+
+ (draw-line axis-x0 tick-y0 axis-x0 major-y0 snd chn copy-context cr)
+ (let ((i1000 (scale-position bark-function 1000.0))
+ (i10000 (scale-position bark-function 10000.0)))
+
+ (draw-line i1000 tick-y0 i1000 major-y0 snd chn copy-context cr)
+ (draw-line i10000 tick-y0 i10000 major-y0 snd chn copy-context cr)
+
+ (draw-string "20" axis-x0 major-y0 snd chn copy-context cr)
+ (draw-string "1000" (- i1000 12) major-y0 snd chn copy-context cr)
+ (draw-string "10000" (- i10000 24) major-y0 snd chn copy-context cr)
+
+ (draw-string (format #f "fft size: ~D" bark-fft-size) (+ axis-x0 10) axis-y0 snd chn copy-context cr)
+
+ (do ((i 100 (+ i 100)))
+ ((= i 1000))
+ (let ((i100 (scale-position bark-function i)))
+ (draw-line i100 tick-y0 i100 minor-y0 snd chn copy-context cr)))
+
+ (do ((i 2000 (+ i 1000)))
+ ((= i 10000))
+ (let ((i1000 (scale-position bark-function i)))
+ (draw-line i1000 tick-y0 i1000 minor-y0 snd chn copy-context cr)))))))
;; bark label/ticks
(set! (foreground-color snd chn copy-context) color1)
@@ -2133,7 +2113,7 @@ and replaces it with the spectrum given in coeffs"))
(set! (foreground-color snd chn copy-context) color3)
(if (= bark-tick-function 2) (draw-bark-ticks erb-position))
(if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
- (draw-string "erb" (+ (* char-width (+ 6 5)) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
+ (draw-string "erb" (+ (* char-width 11) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
(free-cairo cr))
(set! (foreground-color snd chn copy-context) old-foreground-color)))
@@ -2202,7 +2182,7 @@ and replaces it with the spectrum given in coeffs"))
(let ((d-k (d k)))
(do ((i 0 (+ i 1))
(k1 (- k 1) (- k1 1)))
- ((= i k)) ; 1st time is skipped presumably
+ ((= i k)) ; first time is skipped presumably
(float-vector-set! d i (- (float-vector-ref wkm i) (* d-k (float-vector-ref wkm k1))))))
(if (< k (- m 1))
(let ((end (- n k 2)))
@@ -2239,11 +2219,7 @@ is assumed to be outside -1.0 to 1.0."))
;; added this block
(if clipped
- (if (> sum 0.0)
- (if (< sum 1.0)
- (set! sum 1.0))
- (if (> sum -1.0)
- (set! sum -1.0))))
+ (set! sum (if (> sum 0.0) (max sum 1.0) (min sum -1.0))))
(set! (reg 0) sum)
(set! (future j) sum)))))))
@@ -2284,11 +2260,10 @@ is assumed to be outside -1.0 to 1.0."))
(set! clip-data new-clip-data)
(set! clip-size (* 2 clip-size))))))))))
- (if (> clips 0)
+ (if (<= clips 0)
+ 'no-clips
;; try to restore clipped portions
-
- (let ((min-data-len 32)
- (max-len 0))
+ (let ((max-len 0))
(as-one-edit
(lambda ()
(do ((clip 0 (+ clip 2))) ; so go through all...
@@ -2296,10 +2271,10 @@ is assumed to be outside -1.0 to 1.0."))
(let* ((clip-beg (clip-data clip)) ; clip-beg to clip-end inclusive are clipped
(clip-end (clip-data (+ 1 clip)))
(clip-len (+ 1 (- clip-end clip-beg)))
+ (min-data-len 32)
(data-len (max min-data-len (* clip-len 4))))
- (if (> clip-len max-len)
- (set! max-len clip-len))
+ (set! max-len (max max-len clip-len))
(let ((forward-data-len data-len)
(backward-data-len data-len)
@@ -2357,9 +2332,8 @@ is assumed to be outside -1.0 to 1.0."))
(if (> unclipped-max .95) (set! unclipped-max .999))
(scale-channel (/ unclipped-max (maxamp snd chn)) 0 (framples snd chn) snd chn)
- (list 'max unclipped-max 'clips (/ clips 2) 'max-len max-len))
-
- 'no-clips)))))
+ (list 'max unclipped-max 'clips (/ clips 2) 'max-len max-len)))))))
+
(define unclip-sound
(let ((documentation "(unclip-sound snd) applies unclip-channel to each channel of 'snd'."))
@@ -2419,7 +2393,7 @@ is assumed to be outside -1.0 to 1.0."))
(lambda* (matrix b (zero 1.0e-7))
;; translated from Numerical Recipes (gaussj)
- ;(format #t "~%~%invert-matrix n: ~D, ~S, b: ~A, ~S~%" (length matrix) matrix (and b (length b)) b)
+ ;(format () "~%~%invert-matrix n: ~D, ~S, b: ~A, ~S~%" (length matrix) matrix (and b (length b)) b)
(call-with-exit
(lambda (return)
(let* ((n (car (vector-dimensions matrix)))
@@ -2428,28 +2402,29 @@ is assumed to be outside -1.0 to 1.0."))
(pivots (make-vector n 0)))
(do ((i 0 (+ i 1)))
((= i n))
- (let ((biggest 0.0)
- (col 0)
+ (let ((col 0)
(row 0))
- (do ((j 0 (+ j 1)))
- ((= j n))
- ;(format #t "j: ~A, n: ~A~%" j n)
- (if (not (= (pivots j) 1))
- (do ((k 0 (+ k 1)))
- ((= k n))
- (if (= (pivots k) 0)
- (let ((val (abs (matrix j k))))
- (if (> val biggest)
- (begin
- (set! col k)
- (set! row j)
- ;(format #t "k: ~A, row: ~D, col: ~A~%" k row col)
- (set! biggest val))))
- (if (> (pivots k) 1)
- (return #f))))))
- (if (< biggest zero) (return #f)) ; this can be fooled (floats...): (invert-matrix (make-share-vector (float-vector 1 2 3 3 2 1 4 5 6) (list 3 3)))
+ (let ((biggest 0.0))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ ;(format () "j: ~A, n: ~A~%" j n)
+ (if (not (= (pivots j) 1))
+ (do ((k 0 (+ k 1)))
+ ((= k n))
+ (if (= (pivots k) 0)
+ (let ((val (abs (matrix j k))))
+ (if (> val biggest)
+ (begin
+ (set! col k)
+ (set! row j)
+ ;(format () "k: ~A, row: ~D, col: ~A~%" k row col)
+ (set! biggest val))))
+ (if (> (pivots k) 1)
+ (return #f))))))
+ (if (< biggest zero)
+ (return #f))) ; this can be fooled (floats...): (invert-matrix (make-share-vector (float-vector 1 2 3 3 2 1 4 5 6) (list 3 3)))
(set! (pivots col) (+ (pivots col) 1))
- ;(format #t "i: ~D, row: ~D, col: ~A~%" i row col)
+ ;(format () "i: ~D, row: ~D, col: ~A~%" i row col)
(if (not (= row col))
(let ((temp (if b (b row) 0.0)))
(if b
@@ -2492,8 +2467,7 @@ is assumed to be outside -1.0 to 1.0."))
(list matrix b)))))))
(define (matrix-solve A b)
- (let ((val (invert-matrix A b)))
- (and val (cadr val))))
+ (cond ((invert-matrix A b) => cadr) (else #f)))
(define* (make-savitzky-golay-filter size (order 2)) ;assuming symmetric filter (left = right)
(if (even? size)
@@ -2575,23 +2549,22 @@ the multi-modulator FM case described by the list of modulator frequencies and i
(set! sum (+ sum (fm-parallel-component freq-we-want (+ wc (* k wm)) (cdr wms) (cdr inds)
(append ns (list k)) (append bs (list index))
using-sine)))))
- (if (< (abs (- freq-we-want (abs wc))) .1)
+ (if (>= (abs (- freq-we-want (abs wc))) .1)
+ 0.0
(let ((bmult 1.0))
(for-each
(lambda (n index)
(set! bmult (* bmult (bes-jn n index))))
ns bs)
(if (and using-sine (< wc 0.0)) (set! bmult (- bmult)))
- ;(format #t ";add ~A from ~A ~A" bmult ns bs)
- bmult)
- 0.0)))))
+ ;(format () ";add ~A from ~A ~A" bmult ns bs)
+ bmult))))))
;;; this returns the component in FM with complex index (using-sine ignored for now)
;;; this needs the Bessel functions (gsl or snd-test.scm)
(define (fm-complex-component freq-we-want wc wm a b interp using-sine)
- (define (~,3f x) (format #f "~,3F" x))
(let ((sum 0.0)
(mxa (ceiling (* 7 a)))
(mxb (ceiling (* 7 b))))
@@ -2599,13 +2572,13 @@ the multi-modulator FM case described by the list of modulator frequencies and i
((>= k mxa))
(do ((j (- mxb) (+ j 1)))
((>= j mxb))
- (if (< (abs (- freq-we-want (+ wc (* k wm) (* j wm)))) 0.1)
+ (if (< (abs (- freq-we-want wc (* k wm) (* j wm))) 0.1)
(let ((curJI (* (bes-jn k a)
(bes-in (abs j) b)
(expt 0.0+1.0i j))))
(set! sum (+ sum curJI))
(if (> (magnitude curJI) 0.001)
- (format #t ";fm-complex-component add ~,3f from J~D(~A) = ~,3f and I~D(~A) = ~,3f~%"
+ (format () ";fm-complex-component add ~,3f from J~D(~A) = ~,3f and I~D(~A) = ~,3f~%"
curJI
k a (bes-jn k a)
j b (bes-in (abs j) b)))))))
@@ -2618,7 +2591,6 @@ the multi-modulator FM case described by the list of modulator frequencies and i
(define (fm-cascade-component freq-we-want wc wm1 a wm2 b)
- (define (~,3f x) (format #f "~,3F" x))
(let ((sum 0.0)
(mxa (ceiling (* 7 a)))
(mxb (ceiling (* 7 b))))
@@ -2626,12 +2598,12 @@ the multi-modulator FM case described by the list of modulator frequencies and i
((>= k mxa))
(do ((j (- mxb) (+ j 1)))
((>= j mxb))
- (if (< (abs (- freq-we-want (+ wc (* k wm1) (* j wm2)))) 0.1)
+ (if (< (abs (- freq-we-want wc (* k wm1) (* j wm2))) 0.1)
(let ((curJJ (* (bes-jn k a)
(bes-jn j (* k b)))))
(set! sum (+ sum curJJ))
(if (> (magnitude curJJ) 0.001)
- (format #t ";fm-cascade-component add ~,3f from J~D(~A) = ~,3f and J~D(~A) = ~,3f~%"
+ (format () ";fm-cascade-component add ~,3f from J~D(~A) = ~,3f and J~D(~A) = ~,3f~%"
curJJ
k a (bes-jn k a)
j b (bes-jn j (* k b))))))))
@@ -2731,9 +2703,7 @@ the multi-modulator FM case described by the list of modulator frequencies and i
(do ((i 0 (+ i 2)))
((>= i len))
(let ((hnum (new-partials i)))
- (if (= hnum 0)
- (set! (new-partials (+ i 1)) DC)
- (set! (new-partials (+ i 1)) (new-amps (- hnum 1))))))
+ (set! (new-partials (+ i 1)) (if (= hnum 0) DC (new-amps (- hnum 1))))))
new-partials)))
diff --git a/edit-menu.scm b/edit-menu.scm
index 5f72c23..e4f5b27 100644
--- a/edit-menu.scm
+++ b/edit-menu.scm
@@ -71,7 +71,7 @@
(lambda ()
(let ((snc (sync)))
(define (trim-front-one-channel snd chn)
- (if (< (length (marks snd chn)) 1)
+ (if (null? (marks snd chn))
(status-report "trim-front needs a mark" snd)
(delete-samples 0 (mark-sample (car (marks snd chn))) snd chn)))
(if (> snc 0)
@@ -91,7 +91,7 @@
(lambda ()
(let ((snc (sync)))
(define (trim-back-one-channel snd chn)
- (if (< (length (marks snd chn)) 1)
+ (if (null? (marks snd chn))
(status-report "trim-back needs a mark" snd)
(let ((endpt (mark-sample (car (reverse (marks snd chn))))))
(delete-samples (+ endpt 1) (- (framples snd chn) endpt)))))
@@ -139,35 +139,31 @@
;;; -------- add these to the Edit menu, if possible
-(if (and (not (provided? 'snd-gtk))
- (provided? 'xm))
- (with-let (sublet *motif*)
- (let* ((edit-cascade (list-ref (menu-widgets) 2))
- (edit-menu (cadr (XtGetValues edit-cascade (list XmNsubMenuId 0)))))
-
- (define (for-each-child w func)
- ;; (for-each-child w func) applies func to w and its descendents
- (func w)
- (if (XtIsComposite w)
- (for-each
- (lambda (n)
- (for-each-child n func))
- (cadr (XtGetValues w (list XmNchildren 0) 1)))))
-
- (XtAddCallback edit-cascade XmNcascadingCallback
- (lambda (w c i)
- (for-each-child
- edit-menu
- (lambda (child)
- (if (or (string=? (XtName child) "Selection->new")
- (string=? (XtName child) "Cut selection->new")
- (string=? (XtName child) "Append selection"))
- (XtSetSensitive child (selection?))
- (if (string=? (XtName child) "Crop")
- (XtSetSensitive child (and (selected-sound)
- (> (length (marks (selected-sound) (selected-channel))) 1)))
- (if (or (string=? (XtName child) "Trim front")
- (string=? (XtName child) "Trim back"))
- (XtSetSensitive child (and (selected-sound)
- (>= (length (marks (selected-sound) (selected-channel))) 1))))))))))))
- )
+(when (and (not (provided? 'snd-gtk))
+ (provided? 'xm))
+ (with-let (sublet *motif*)
+ (let* ((edit-cascade (list-ref (menu-widgets) 2))
+ (edit-menu (cadr (XtGetValues edit-cascade (list XmNsubMenuId 0)))))
+
+ (define (for-each-child w func)
+ ;; (for-each-child w func) applies func to w and its descendents
+ (func w)
+ (if (XtIsComposite w)
+ (for-each
+ (lambda (n)
+ (for-each-child n func))
+ (cadr (XtGetValues w (list XmNchildren 0) 1)))))
+
+ (XtAddCallback edit-cascade XmNcascadingCallback
+ (lambda (w c i)
+ (for-each-child
+ edit-menu
+ (lambda (child)
+ (cond ((member (XtName child) '("Selection->new" "Cut selection->new" "Append selection") string=?)
+ (XtSetSensitive child (selection?)))
+ ((string=? (XtName child) "Crop")
+ (XtSetSensitive child (and (selected-sound)
+ (> (length (marks (selected-sound) (selected-channel))) 1))))
+ ((member (XtName child) '("Trim front" "Trim back") string=?)
+ (XtSetSensitive child (and (selected-sound)
+ (>= (length (marks (selected-sound) (selected-channel))) 1))))))))))))
diff --git a/edit123.scm b/edit123.scm
index ff63e2f..b80bc7a 100644
--- a/edit123.scm
+++ b/edit123.scm
@@ -76,8 +76,7 @@
(set! last-file-opened filename)
(display last-file-opened)
(let ((new-path (directory-from-path (mus-expand-filename filename))))
- (if (or (not (string? current-directory))
- (not (string=? current-directory new-path)))
+ (if (not (equal? current-directory new-path))
(get-current-files new-path)))))
(lambda ()
@@ -143,8 +142,7 @@
(define (delete-named-mark name)
(select-channel 0)
- (if (find-mark name)
- (delete-mark (find-mark name))))
+ (cond ((find-mark name) => delete-mark)))
(define (my-play-selection pos1 pos2)
(stop-playing)
@@ -400,12 +398,7 @@
(else (set! status 0))
)))
-(bind-key (char->integer #\1) 8 (lambda () (case status
- ((0) (set! status 2))
- ((1) (set! status 3))
- ((3) (set! status 1))
- (else (set! status 0))
- )))
+(bind-key (char->integer #\1) 8 (lambda () (set! status (case status ((0) 2) ((1) 3) ((3) 1) (else 0)))))
(bind-key (char->integer #\2) 4 (lambda () (case status
((0) (mark-start 30000))
diff --git a/effects-utils.scm b/effects-utils.scm
index 64e6ccb..6a7b153 100644
--- a/effects-utils.scm
+++ b/effects-utils.scm
@@ -109,11 +109,7 @@
XmNforeground (BlackPixelOfScreen (current-screen))
XmNarmColor *selection-color*))))
(XtAddCallback reset-button XmNactivateCallback reset-callback)))
-
- (XmStringFree xhelp)
- (XmStringFree xok)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
+ (for-each XmStringFree (vector xhelp xok xdismiss titlestr))
(if target-ok-callback
(begin
@@ -155,10 +151,9 @@
(let ((documentation "(scale-linear->log lo val hi) given user-relative lo..hi and scale-relative val, returns the user-relative val"))
(lambda (lo val hi)
;; since log-scale widget assumes 0..log-scale-ticks, val can be used as ratio (log-wise) between lo and hi
- (let* ((log-lo (log (max lo 1.0) 2))
- (log-hi (log hi 2))
- (log-val (+ log-lo (* (/ val log-scale-ticks) (- log-hi log-lo)))))
- (expt 2.0 log-val)))))
+ (let ((log-lo (log (max lo 1.0) 2))
+ (log-hi (log hi 2)))
+ (expt 2.0 (+ log-lo (* (/ val log-scale-ticks) (- log-hi log-lo))))))))
(define scale-log-label
(let ((documentation "(scale-log-label lo val hi) makes a log scale label"))
@@ -166,8 +161,8 @@
(format #f "~,2F" (scale-linear->log lo val hi)))))
(define create-log-scale-widget
- (let ((documentation "(create-log-scale-widget parent title low initial high callback scale) returns a log scale widget"))
- (lambda (parent title low initial high callback scale)
+ (let ((documentation "(create-log-scale-widget parent title low initial high) returns a log scale widget"))
+ (lambda (parent title low initial high)
(let ((label (XtCreateManagedWidget (format #f "~,2F" initial) xmLabelWidgetClass parent
(list XmNbackground *basic-color*)))
(scale (XtCreateManagedWidget "scale" xmScaleWidgetClass parent
@@ -211,8 +206,8 @@
(round (* 12 (log ratio 2))))))
(define create-semi-scale-widget
- (let ((documentation "(create-semi-scale-widget parent title initial callback) returns a semitone scale widget"))
- (lambda (parent title initial callback)
+ (let ((documentation "(create-semi-scale-widget parent title initial) returns a semitone scale widget"))
+ (lambda (parent title initial)
(let ((label (XtCreateManagedWidget (format #f "semitones: ~D" (ratio->semitones initial)) xmLabelWidgetClass parent
(list XmNbackground *basic-color*)))
(scale (XtCreateManagedWidget "scale" xmScaleWidgetClass parent
@@ -258,15 +253,15 @@ and returns a list of widgets (for reset callbacks)"))
(scale (slider-data 5))
(new-slider (if (= (length slider-data) 7)
(if (eq? (slider-data 6) 'log)
- (create-log-scale-widget mainform title low initial high func scale)
- (create-semi-scale-widget mainform title initial func))
+ (create-log-scale-widget mainform title low initial high)
+ (create-semi-scale-widget mainform title initial))
(XtCreateManagedWidget (car slider-data) xmScaleWidgetClass mainform
(list XmNorientation XmHORIZONTAL
XmNshowValue #t
XmNminimum (floor (* low scale))
XmNmaximum (floor (* high scale))
XmNvalue (floor (* initial scale))
- XmNdecimalPoints (if (= scale 10000) 4 (if (= scale 1000) 3 (if (= scale 100) 2 (if (= scale 10) 1 0))))
+ XmNdecimalPoints (case scale ((10000) 4) ((1000) 3) ((100) 2) ((10) 1) (else 0))
XmNtitleString title
XmNleftAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_FORM
diff --git a/env.scm b/env.scm
index 80496b4..0c043f5 100644
--- a/env.scm
+++ b/env.scm
@@ -28,7 +28,7 @@
end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
(lambda (beg end e)
(let ((nenv ())
- (lasty (if e (cadr e) 0.0))
+ (lasty (if (pair? e) (cadr e) 0.0))
(len (length e)))
(call-with-exit
(lambda (return-early)
@@ -37,21 +37,19 @@ end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
(let ((x (e i))
(y (e (+ i 1))))
(set! lasty y)
- (if (null? nenv)
- (if (>= x beg)
- (begin
- (set! nenv (append nenv (list beg (envelope-interp beg e))))
- (if (not (= x beg))
- (if (>= x end)
- (return-early (append nenv (list end (envelope-interp end e))))
- (set! nenv (append nenv (list x y)))))))
- (if (<= x end)
- (begin
- (set! nenv (append nenv (list x y)))
- (if (= x end)
- (return-early nenv)))
- (if (> x end)
- (return-early (append nenv (list end (envelope-interp end e)))))))))
+ (cond ((null? nenv)
+ (when (>= x beg)
+ (set! nenv (append nenv (list beg (envelope-interp beg e))))
+ (if (not (= x beg))
+ (if (>= x end)
+ (return-early (append nenv (list end (envelope-interp end e))))
+ (set! nenv (append nenv (list x y)))))))
+ ((<= x end)
+ (set! nenv (append nenv (list x y)))
+ (if (= x end) (return-early nenv)))
+ ((> x end)
+ (return-early
+ (append nenv (list end (envelope-interp end e))))))))
(append nenv (list end lasty))))))))
@@ -61,26 +59,24 @@ end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
(let ((documentation "(map-envelopes func env1 env2) maps func over the breakpoints in env1 and env2 returning a new envelope"))
(lambda (op e1 e2)
(let ((xs ()))
- (letrec ((at0
- (lambda (e)
- (let* ((diff (car e))
- (len (length e))
- (lastx (e (- len 2)))
- (newe (copy e)))
- (do ((i 0 (+ i 2)))
- ((>= i len) newe)
- (let ((x (/ (- (newe i) diff) lastx)))
- (set! xs (cons x xs))
- (set! (newe i) x))))))
- (remove-duplicates
- (lambda (lst)
- (letrec ((rem-dup
- (lambda (lst nlst)
- (cond ((null? lst) nlst)
- ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
- (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
- (rem-dup lst ())))))
-
+ (let ((at0
+ (lambda (e)
+ (let* ((diff (car e))
+ (len (length e))
+ (lastx (e (- len 2)))
+ (newe (copy e)))
+ (do ((i 0 (+ i 2)))
+ ((>= i len) newe)
+ (let ((x (/ (- (newe i) diff) lastx)))
+ (set! xs (cons x xs))
+ (set! (newe i) x))))))
+ (remove-duplicates
+ (lambda (lst)
+ (let rem-dup ((lst lst)
+ (nlst ()))
+ (cond ((null? lst) nlst)
+ ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
+ (else (rem-dup (cdr lst) (cons (car lst) nlst))))))))
(if (null? e1)
(at0 e2)
(if (null? e2)
@@ -116,36 +112,33 @@ envelope: (multiply-envelopes '(0 0 2 .5) '(0 0 1 2 2 1)) -> '(0 0 0.5 0.5 1.0 0
(define max-envelope
(let ((documentation "(max-envelope env) -> max y value in env"))
(lambda (env1)
- (define (max-envelope-1 e mx)
- (if (null? e)
- mx
- (max-envelope-1 (cddr e) (max mx (cadr e)))))
- (max-envelope-1 (cddr env1) (cadr env1)))))
-
+ (let max-envelope-1 ((e (cddr env1))
+ (mx (cadr env1)))
+ (if (null? e)
+ mx
+ (max-envelope-1 (cddr e) (max mx (cadr e))))))))
;;; -------- min-envelope
(define min-envelope
(let ((documentation "(min-envelope env) -> min y value in env"))
(lambda (env1)
- (define (min-envelope-1 e mx)
- (if (null? e)
- mx
- (min-envelope-1 (cddr e) (min mx (cadr e)))))
- (min-envelope-1 (cddr env1) (cadr env1)))))
-
+ (let min-envelope-1 ((e (cddr env1))
+ (mx (cadr env1)))
+ (if (null? e)
+ mx
+ (min-envelope-1 (cddr e) (min mx (cadr e))))))))
;;; -------- integrate-envelope
(define integrate-envelope
(let ((documentation "(integrate-envelope env) -> area under env"))
(lambda (env1)
- (define (integrate-envelope-1 e sum)
- (if (or (null? e) (null? (cddr e)))
- sum
- (integrate-envelope-1 (cddr e) (+ sum (* (+ (cadr e) (cadddr e)) .5 (- (caddr e) (car e)))))))
- (integrate-envelope-1 env1 0.0))))
-
+ (let integrate-envelope-1 ((e env1)
+ (sum 0.0000))
+ (if (or (null? e) (null? (cddr e)))
+ sum
+ (integrate-envelope-1 (cddr e) (+ sum (* (+ (cadr e) (cadddr e)) 0.5 (- (caddr e) (car e))))))))))
;;; -------- envelope-last-x
@@ -170,64 +163,56 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
(stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) -> (0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)"))
(lambda* (fn old-att new-att old-dec new-dec)
- (if (and old-att
- (not new-att))
- (error 'wrong-number-of-args (list "stretch-envelope"
- old-att
- "old-attack but no new-attack?"))
- (if (not new-att)
- fn
- (if (and old-dec
- (not new-dec))
- (error 'wrong-number-of-args (list "stretch-envelope"
- old-att new-att old-dec
- "old-decay but no new-decay?"))
- (let* ((x0 (car fn))
- (new-x x0)
- (last-x (fn (- (length fn) 2)))
- (y0 (cadr fn))
- (new-fn (list y0 x0))
- (scl (/ (- new-att x0) (max .0001 (- old-att x0)))))
- (define (stretch-envelope-1 new-fn old-fn)
- (if (null? old-fn)
- new-fn
- (let ((x1 (car old-fn))
- (y1 (cadr old-fn)))
- (if (and (< x0 old-att)
- (>= x1 old-att))
- (begin
- (if (= x1 old-att)
- (set! y0 y1)
- (set! y0 (+ y0 (* (- y1 y0) (/ (- old-att x0) (- x1 x0))))))
- (set! x0 old-att)
- (set! new-x new-att)
- (set! new-fn (cons y0 (cons new-x new-fn)))
- (set! scl (if old-dec
- (/ (- new-dec new-att) (- old-dec old-att))
- (/ (- last-x new-att) (- last-x old-att))))))
- (if (and old-dec
- (< x0 old-dec)
- (>= x1 old-dec))
- (begin
- (if (= x1 old-dec)
- (set! y0 y1)
- (set! y0 (+ y0 (* (- y1 y0) (/ (- old-dec x0) (- x1 x0))))))
- (set! x0 old-dec)
- (set! new-x new-dec)
- (set! new-fn (cons y0 (cons new-x new-fn)))
- (set! scl (/ (- last-x new-dec) (- last-x old-dec)))))
- (if (not (= x0 x1))
- (begin
- (set! new-x (+ new-x (* scl (- x1 x0))))
- (set! new-fn (cons y1 (cons new-x new-fn)))
- (set! x0 x1)
- (set! y0 y1)))
- (stretch-envelope-1 new-fn (cddr old-fn)))))
-
- (if (and old-dec
- (= old-dec old-att))
- (set! old-dec (* .000001 last-x)))
- (reverse (stretch-envelope-1 new-fn (cddr fn))))))))))
+ (cond ((not new-att)
+ (if old-att
+ (error 'wrong-number-of-args "stretch-envelope: ~A, old-attack but no new-attack?" old-att)
+ fn))
+ ((and old-dec (not new-dec))
+ (error 'wrong-number-of-args "stretch-envelope:~A ~A ~A, old-decay but no new-decay?" old-att new-att old-dec))
+ (else
+ (let* ((x0 (car fn))
+ (new-x x0)
+ (last-x (fn (- (length fn) 2)))
+ (y0 (cadr fn))
+ (new-fn (list y0 x0))
+ (scl (/ (- new-att x0) (max .0001 (- old-att x0)))))
+
+ (if (and (number? old-dec)
+ (= old-dec old-att))
+ (set! old-dec (* 1e-06 last-x)))
+ (reverse
+ (let stretch-envelope-1 ((new-fn new-fn)
+ (old-fn (cddr fn)))
+ (if (null? old-fn)
+ new-fn
+ (let ((x1 (car old-fn))
+ (y1 (cadr old-fn)))
+ (when (and (< x0 old-att) (>= x1 old-att))
+ (set! y0 (if (= x1 old-att)
+ y1
+ (+ y0 (* (- y1 y0) (/ (- old-att x0) (- x1 x0))))))
+ (set! x0 old-att)
+ (set! new-x new-att)
+ (set! new-fn (cons y0 (cons new-x new-fn)))
+ (set! scl (if old-dec
+ (/ (- new-dec new-att) (- old-dec old-att))
+ (/ (- last-x new-att) (- last-x old-att)))))
+ (when (and old-dec
+ (< x0 old-dec)
+ (>= x1 old-dec))
+ (set! y0 (if (= x1 old-dec)
+ y1
+ (+ y0 (* (- y1 y0) (/ (- old-dec x0) (- x1 x0))))))
+ (set! x0 old-dec)
+ (set! new-x new-dec)
+ (set! new-fn (cons y0 (cons new-x new-fn)))
+ (set! scl (/ (- last-x new-dec) (- last-x old-dec))))
+ (unless (= x0 x1)
+ (set! new-x (+ new-x (* scl (- x1 x0))))
+ (set! new-fn (cons y1 (cons new-x new-fn)))
+ (set! x0 x1)
+ (set! y0 y1))
+ (stretch-envelope-1 new-fn (cddr old-fn))))))))))))
;;; -------- scale-envelope
@@ -257,8 +242,7 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
(let ((len (length e)))
(if (memv len '(0 2))
e
- (let ((xmax (e (- len 2))))
- (reverse-env-1 e () xmax)))))))
+ (reverse-env-1 e () (e (- len 2))))))))
;;; -------- concatenate-envelopes
@@ -299,7 +283,8 @@ to have the same extent as the original's. 'reflected' causes every other
repetition to be in reverse."))
(lambda* (ur-env repeats reflected normalized)
(let* ((times (if reflected (floor (/ repeats 2)) repeats))
- (e (if reflected
+ (e (if (not reflected)
+ ur-env
(let ((lastx (ur-env (- (length ur-env) 2)))
(rev-env (cddr (reverse ur-env)))
(new-env (reverse ur-env)))
@@ -307,24 +292,23 @@ repetition to be in reverse."))
(set! new-env (cons (+ lastx (- lastx (cadr rev-env))) new-env))
(set! new-env (cons (car rev-env) new-env))
(set! rev-env (cddr rev-env)))
- (reverse new-env))
- ur-env))
+ (reverse new-env))))
(first-y (cadr e))
(x-max (e (- (length e) 2)))
(x (car e))
(first-y-is-last-y (= first-y (e (- (length e) 1))))
- (new-env (list first-y x))
- (len (length e)))
- (do ((i 0 (+ i 1)))
- ((= i times))
- (do ((j 2 (+ j 2)))
- ((>= j len))
- (set! x (+ x (- (e j) (e (- j 2)))))
- (set! new-env (cons (e (+ j 1)) (cons x new-env))))
- (if (and (< i (- times 1)) (not first-y-is-last-y))
- (begin
- (set! x (+ x (/ x-max 100.0)))
- (set! new-env (cons first-y (cons x new-env))))))
+ (new-env (list first-y x)))
+ (let ((len (length e)))
+ (do ((i 0 (+ i 1)))
+ ((= i times))
+ (do ((j 2 (+ j 2)))
+ ((>= j len))
+ (set! x (+ x (- (e j) (e (- j 2)))))
+ (set! new-env (cons (e (+ j 1)) (cons x new-env))))
+ (if (and (< i (- times 1)) (not first-y-is-last-y))
+ (begin
+ (set! x (+ x (/ x-max 100.0)))
+ (set! new-env (cons first-y (cons x new-env)))))))
(set! new-env (reverse new-env))
(if normalized
(let ((scl (/ x-max x))
@@ -482,36 +466,36 @@ each segment: (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))"))
(mus-sound-framples file)))
(rms (make-moving-average incrsamps)) ; this could use make-moving-rms from dsp.scm
(rms-val 0.0)
- (jend 0))
- (let* ((len (+ 1 (- end start)))
- (data (make-float-vector len)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (float-vector-set! data i (next-sample reader)))
- (float-vector-multiply! data data)
- (do ((i 0 (+ i incrsamps)))
- ((>= i end)
- (reverse e))
- (set! jend (min end (+ i incrsamps)))
- (do ((j i (+ j 1)))
- ((= j jend))
- (moving-average rms (float-vector-ref data j)))
- (set! e (cons (* 1.0 (/ i fsr)) e))
- (set! rms-val (sqrt (* (mus-scaler rms) (mus-increment rms))))
- (if db
- (if (< rms-val .00001)
- (set! e (cons -100.0 e))
- (set! e (cons (* 20.0 (log rms-val 10.0)) e)))
- (set! e (cons rms-val e)))))))))
+ (jend 0)
+ (len (+ 1 (- end start)))
+ (data (make-float-vector len)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (float-vector-set! data i (next-sample reader)))
+ (float-vector-multiply! data data)
+ (do ((i 0 (+ i incrsamps)))
+ ((>= i end)
+ (reverse e))
+ (set! jend (min end (+ i incrsamps)))
+ (do ((j i (+ j 1)))
+ ((= j jend))
+ (moving-average rms (float-vector-ref data j)))
+ (set! e (cons (* 1.0 (/ i fsr)) e))
+ (set! rms-val (sqrt (* (mus-scaler rms) (mus-increment rms))))
+ (set! e (cons (if db
+ (if (< rms-val 1e-05) -100.0 (* 20.0 (log rms-val 10.0)))
+ rms-val)
+ e)))))))
(define* (normalize-envelope env1 (new-max 1.0))
- (define (abs-max-envelope-1 e mx)
- (if (null? e)
- mx
- (abs-max-envelope-1 (cddr e) (max mx (abs (cadr e))))))
- (let ((peak (abs-max-envelope-1 (cddr env1) (abs (cadr env1)))))
- (scale-envelope env1 (/ new-max peak))))
+ (scale-envelope env1
+ (/ new-max
+ (let abs-max-envelope-1 ((e (cddr env1))
+ (mx (abs (cadr env1))))
+ (if (null? e)
+ mx
+ (abs-max-envelope-1 (cddr e) (max mx (abs (cadr e)))))))))
;;; simplify-envelope
@@ -543,8 +527,9 @@ each segment: (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))"))
(if (or (< px qx tx) (< py qy ty) (< tx qx px) (< ty qy py))
:after
:within)))))
- (if (and env1
- (> (length env1) 4))
+ (if (not (and env1
+ (> (length env1) 4)))
+ env1
(let ((new-env (list (cadr env1) (car env1)))
(ymax (max-envelope env1))
(ymin (min-envelope env1))
@@ -578,5 +563,4 @@ each segment: (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))"))
(set! qtx ttx)
(set! qty tty)))
(set! new-env (cons qty (cons qtx new-env)))
- (reverse new-env))))
- env1))
+ (reverse new-env))))))
diff --git a/enved.scm b/enved.scm
index 3281530..b3b658b 100644
--- a/enved.scm
+++ b/enved.scm
@@ -43,36 +43,34 @@
(let ((snd (hook 'snd))
(chn (hook 'chn))
(ux (hook 'x))
- (uy (hook 'y))
- (mouse-radius .03))
+ (uy (hook 'y)))
(define (add-envelope-point x y cur-env)
(let ((new-env ()))
- (define (search-point e)
- (if (null? e)
- (append new-env (list x y))
- (if (= (car e) x)
- (append new-env (list x y) (cddr e))
- (if (> (car e) x)
- (append new-env (list x y) e)
- (begin
- (set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e)))))))
- (search-point cur-env)))
-
+ (let search-point ((e cur-env))
+ (cond ((null? e) (append new-env (list x y)))
+ ((= (car e) x) (append new-env (list x y) (cddr e)))
+ ((> (car e) x) (append new-env (list x y) e))
+ (else
+ (set! new-env (append new-env (list (car e) (cadr e))))
+ (search-point (cddr e)))))))
+
(define (envelope-position x cur-env)
- (define (search-point e pos)
- (if (= (car e) x)
- pos
- (search-point (cddr e) (+ pos 2))))
- (search-point cur-env 0))
+ (let search-point ((e cur-env)
+ (pos 0))
+ (if (= (car e) x)
+ pos
+ (search-point (cddr e) (+ pos 2)))))
- (define (on-dot? x y cur-env pos)
- (and (pair? cur-env)
- (or (and (< (abs (- (car cur-env) x)) mouse-radius)
- (< (abs (- (cadr cur-env) y)) mouse-radius)
- pos)
- (on-dot? x y (cddr cur-env) (+ pos 2)))))
+ (define on-dot?
+ (let ((mouse-radius .03))
+ (lambda (x y cur-env pos)
+ (and (pair? cur-env)
+ (pair? (cdr cur-env))
+ (or (and (< (abs (- (car cur-env) x)) mouse-radius)
+ (< (abs (- (cadr cur-env) y)) mouse-radius)
+ pos)
+ (on-dot? x y (cddr cur-env) (+ pos 2)))))))
(let* ((x (max 0.0 (min ux 1.0)))
(y (max 0.0 (min uy 1.0)))
@@ -80,12 +78,13 @@
(pos (on-dot? x y cur-env 0)))
(set! mouse-new (not pos))
(set! mouse-down (get-internal-real-time))
- (if (not pos)
+ (if pos
+ (set! mouse-pos pos)
(let ((new-x (max 0.001 (min x .999))))
(set! (channel-envelope snd chn)
(add-envelope-point new-x y cur-env))
- (set! mouse-pos (envelope-position new-x (channel-envelope snd chn))))
- (set! mouse-pos pos)))))
+ (set! mouse-pos (envelope-position new-x (channel-envelope snd chn))))))))
+
(define (mouse-drag-envelope hook)
(let ((snd (hook 'snd))
@@ -96,14 +95,14 @@
(define (edit-envelope-point pos x y cur-env)
(let ((new-env ()))
- (define (search-point e npos)
+ (let search-point ((e cur-env)
+ (npos 0))
(if (= npos pos)
(append new-env (list x y) (cddr e))
(begin
(set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e) (+ npos 2)))))
- (search-point cur-env 0)))
-
+ (search-point (cddr e) (+ npos 2)))))))
+
(let* ((cur-env (channel-envelope snd chn))
(lx (if (= mouse-pos 0)
0.0
@@ -124,28 +123,28 @@
(define (remove-envelope-point pos cur-env)
(let ((new-env ()))
- (define (search-point e npos)
+ (let search-point ((e cur-env)
+ (npos 0))
(if (null? e)
new-env
(if (= pos npos)
(append new-env (cddr e))
(begin
(set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e) (+ npos 2))))))
- (search-point cur-env 0)))
+ (search-point (cddr e) (+ npos 2))))))))
- (if (= axis lisp-graph)
- (let ((cur-env (channel-envelope snd chn)))
- (set! mouse-up (get-internal-real-time))
- (if (and (not mouse-new)
- (<= (- mouse-up mouse-down) click-time)
- (not (= mouse-pos 0))
- (< mouse-pos (- (length cur-env) 2)))
- (set! (channel-envelope snd chn)
- (remove-envelope-point mouse-pos cur-env)))
- (update-lisp-graph snd chn)
- (set! mouse-new #f)
- (set! (hook 'result) #t)))))
+ (when (= axis lisp-graph)
+ (let ((cur-env (channel-envelope snd chn)))
+ (set! mouse-up (get-internal-real-time))
+ (if (and (not mouse-new)
+ (<= (- mouse-up mouse-down) click-time)
+ (not (= mouse-pos 0))
+ (< mouse-pos (- (length cur-env) 2)))
+ (set! (channel-envelope snd chn)
+ (remove-envelope-point mouse-pos cur-env))))
+ (update-lisp-graph snd chn)
+ (set! mouse-new #f)
+ (set! (hook 'result) #t))))
(define (enveloping-key-press hook)
(let ((snd (hook 'snd))
@@ -228,6 +227,6 @@
(set! samp (+ samp bufsize))
(>= samp len))))
(res)))
- (lambda args (format #t ";play-panned error: ~A" args)))
+ (lambda args (format () ";play-panned error: ~A" args)))
(mus-audio-close audio-fd)))))))
|#
diff --git a/examp.scm b/examp.scm
index 918e741..557122e 100644
--- a/examp.scm
+++ b/examp.scm
@@ -167,8 +167,7 @@
(srate file)
(mus-header-type-name (mus-sound-header-type file))
(mus-sample-type-name (mus-sound-sample-type file))
- (/ (mus-sound-samples file)
- (* 1.0 (channels file) (srate file)))))))
+ (* 1.0 (/ (mus-sound-samples file) (channels file) (srate file)))))))
;;; -------- Correlation --------
@@ -179,9 +178,10 @@
(let ((documentation "(display-correlation hook) returns the correlation of snd's 2 channels (intended for use with graph-hook). y0 and y1 are ignored."))
(lambda (hook)
(let ((snd (hook 'snd)))
- (if (and (= (channels snd) 2)
- (> (framples snd 0) 1)
- (> (framples snd 1) 1))
+ (if (not (and (= (channels snd) 2)
+ (> (framples snd 0) 1)
+ (> (framples snd 1) 1)))
+ (status-report "display-correlation wants stereo input")
(let* ((ls (left-sample snd 0))
(rs (right-sample snd 0))
(ilen (+ 1 (- rs ls)))
@@ -204,8 +204,7 @@
(float-vector-subtract! im2 rl2) ; subtract the 4th from the 3rd
(fft tmprl im2 -1)
(float-vector-scale! tmprl fftscale) ; scale by fftscale
- (graph tmprl "lag time" 0 fftlen)))
- (status-report "display-correlation wants stereo input"))))))
+ (graph tmprl "lag time" 0 fftlen))))))))
;(hook-push graph-hook display-correlation)
@@ -282,8 +281,8 @@
(b2 (char->integer (read-char fd)))
(b3 (char->integer (read-char fd))))
(close-input-port fd)
- (if (or (not (= b0 255))
- (not (= (logand b1 #b11100000) #b11100000)))
+ (if (not (and (= b0 255)
+ (= (logand b1 #b11100000) #b11100000)))
(snd-print (format #f "~S is not an MPEG file (first 11 bytes: #b~B #b~B)" mpgfile b0 (logand b1 #b11100000)))
(let ((id (ash (logand b1 #b11000) -3))
(layer (ash (logand b1 #b110) -1))
@@ -304,7 +303,7 @@
(let* ((chans (if (= channel-mode 3) 1 2))
(mpegnum (if (= id 0) 4 (if (= id 2) 2 1)))
(mpeg-layer (if (= layer 3) 1 (if (= layer 2) 2 3)))
- (srate (/ (list-ref (list 44100 48000 32000 0) srate-index) mpegnum)))
+ (srate (/ (#(44100 48000 32000 0) srate-index) mpegnum)))
(snd-print (format #f "~S: ~A Hz, ~A, MPEG-~A~%"
mpgfile srate (if (= chans 1) "mono" "stereo") mpeg-layer))
(system (format #f "mpg123 -s ~A > ~A" mpgfile rawfile))
@@ -322,10 +321,7 @@
;; (open-sound (read-ogg "/home/bil/sf1/oboe.ogg"))
(and (call-with-input-file filename
(lambda (fd)
- (and (char=? (read-char fd) #\O)
- (char=? (read-char fd) #\g)
- (char=? (read-char fd) #\g)
- (char=? (read-char fd) #\S))))
+ (string=? (read-string 4 fd) "OggS")))
(let ((aufile (string-append filename ".au")))
(if (file-exists? aufile) (delete-file aufile))
(system (format #f "ogg123 -d au -f ~A ~A" aufile filename))
@@ -373,7 +369,7 @@
(save-sound-as file snd :header-type mus-riff)
(system (format #f "speexenc ~A ~A" file spxfile))
(delete-file file))
- (system (format #f "speexenc ~A ~A" (file-name snd) (string-append (file-name snd) ".spx")))))))
+ (system (format #f "speexenc ~A ~A.spx" (file-name snd) (file-name snd)))))))
;;; -------- read and write FLAC files
@@ -449,15 +445,11 @@ read an ASCII sound file"))
(chn (hook 'chn))
(dots (- (right-sample snd chn)
(left-sample snd chn))))
- (if (> dots 100)
- (set! (dot-size snd chn) 1)
- (if (> dots 50)
- (set! (dot-size snd chn) 2)
- (if (> dots 25)
- (set! (dot-size snd chn) 3)
- (set! (dot-size snd chn) 5))))))))
+ (set! (dot-size snd chn)
+ (cond ((assoc dots '((100 . 1) (50 . 2) (25 . 3)) >) => cdr)
+ (else 5)))))))
- ;(hook-push graph-hook auto-dot)
+;;; (hook-push graph-hook auto-dot)
@@ -473,14 +465,15 @@ read an ASCII sound file"))
(lambda ()
(let* ((keysnd (or (selected-sound) (car (sounds))))
(keychn (or (selected-channel keysnd) 0))
- (current-left-sample (left-sample keysnd keychn))
(chan-marks (marks keysnd keychn)))
- (define (find-leftmost-mark samps)
- (and (pair? samps)
- (if (> (car samps) current-left-sample)
- (car samps)
- (find-leftmost-mark (cdr samps)))))
- (if (= (length chan-marks) 0)
+ (define find-leftmost-mark
+ (let ((current-left-sample (left-sample keysnd keychn)))
+ (lambda (samps)
+ (and (pair? samps)
+ (if (> (car samps) current-left-sample)
+ (car samps)
+ (find-leftmost-mark (cdr samps)))))))
+ (if (null? chan-marks)
(status-report "no marks!")
(let ((leftmost (find-leftmost-mark (map mark-sample chan-marks))))
(if (number? leftmost)
@@ -488,7 +481,7 @@ read an ASCII sound file"))
(set! (left-sample keysnd keychn) leftmost)
keyboard-no-action)
(status-report "no mark in window"))))))))
-
+
;(bind-key #\m 0 (lambda () "align window left edge with mark" (first-mark-in-window-at-left)))
@@ -537,11 +530,10 @@ two sounds open (indices 0 and 1 for example), and the second has two channels,
(let ((sndlist ())
(chnlist ()))
(for-each (lambda (snd)
- (let ((chntop (- (channels snd) 1)))
- (do ((i chntop (- i 1)))
- ((< i 0))
- (set! sndlist (cons snd sndlist))
- (set! chnlist (cons i chnlist)))))
+ (do ((i (- (channels snd) 1) (- i 1)))
+ ((< i 0))
+ (set! sndlist (cons snd sndlist))
+ (set! chnlist (cons i chnlist))))
(sounds))
(list sndlist chnlist)))))
@@ -620,11 +612,11 @@ otherwise it moves the cursor to the first offending sample"))
it into two copies whose amplitudes depend on the envelope 'pan-env'. If 'pan-env' is
a number, the sound is split such that 0 is all in channel 0 and 90 is all in channel 1."))
(lambda (mono-snd stereo-snd pan-env)
- (let ((len (framples mono-snd)))
+ (let ((len (framples mono-snd))
+ (reader0 (make-sampler 0 mono-snd))
+ (reader1 (make-sampler 0 mono-snd)))
(if (number? pan-env)
- (let ((pos (/ pan-env 90.0))
- (reader0 (make-sampler 0 mono-snd))
- (reader1 (make-sampler 0 mono-snd)))
+ (let ((pos (/ pan-env 90.0)))
(map-channel (lambda (y)
(+ y (* pos (read-sample reader1))))
0 len stereo-snd 1)
@@ -632,9 +624,7 @@ a number, the sound is split such that 0 is all in channel 0 and 90 is all in ch
(+ y (* (- 1.0 pos) (read-sample reader0))))
0 len stereo-snd 0))
(let ((e0 (make-env pan-env :length len))
- (e1 (make-env pan-env :length len))
- (reader0 (make-sampler 0 mono-snd))
- (reader1 (make-sampler 0 mono-snd)))
+ (e1 (make-env pan-env :length len)))
(map-channel (lambda (y)
(+ y (* (env e1) (read-sample reader1))))
0 len stereo-snd 1)
@@ -657,8 +647,8 @@ then inverse ffts."))
(fsize2 (/ fsize 2))
(rdata (channel->float-vector 0 fsize snd chn))
(idata (make-float-vector fsize))
- (lo (round (/ bottom (/ sr fsize))))
- (hi (round (/ top (/ sr fsize)))))
+ (lo (round (/ (* bottom fsize) sr)))
+ (hi (round (/ (* top fsize) sr))))
(fft rdata idata 1)
(if (> lo 0)
(begin
@@ -779,12 +769,11 @@ then inverse ffts."))
((= i fft-size))
(float-vector-set! rl i (read-sample read-ahead)))
(fill! im 0.0)))
- (let ((rval (- 1.0 (ramp ramper in-vowel))))
+ (* y (- 1.0 (ramp ramper in-vowel))))
; squelch consonants if just ramp value (not 1.0-val)
;(and (> rval 0.0) ; if this is included, the vowel-portions are omitted
- (* y rval) ; squelch vowels
+ ; squelch vowels
;(* y (+ (* 2 rval) .1)) ;accentuate consonants
- ))
0 #f snd chn #f "squelch-vowels")))))
@@ -855,10 +844,11 @@ current spectrum value. (filter-fft (lambda (y) (if (< y .01) 0.0 y))) is like
(float-vector-multiply! rdata vf)
(float-vector-multiply! idata vf)
(fft rdata idata -1)
- (if (not (= mx 0.0))
+ (if (= mx 0.0)
+ (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt))
(let ((pk (float-vector-peak rdata)))
- (float-vector->channel (float-vector-scale! rdata (/ mx pk)) 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt)))
- (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt)))))))
+ (float-vector->channel (float-vector-scale! rdata (/ mx pk)) 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt))))))))
+
;; (let ((op (make-one-zero .5 .5))) (filter-fft op))
;; (let ((op (make-one-pole .05 .95))) (filter-fft op))
@@ -1290,8 +1280,7 @@ selected sound: (map-channel (cross-synthesis (integer->sound 0) .5 128 6.0))"))
(if (odd? ctr) (set! ctr (- ctr 1)))
(set! fdr (channel->float-vector inctr fftsize snd chn))
- (let ((pk (float-vector-peak fdr)))
- (if (> pk old-peak-amp) (set! old-peak-amp pk)))
+ (set! old-peak-amp (max (float-vector-peak fdr) old-peak-amp))
(spectrum fdr fdi #f 2)
(float-vector-subtract! fdr spectr)
(float-vector-scale! fdr (/ 2.0 freq-inc))
@@ -1337,8 +1326,7 @@ selected sound: (map-channel (cross-synthesis (integer->sound 0) .5 128 6.0))"))
(set! ctr (min (- len i) freq-inc))
(set! fdr (channel->float-vector inctr fftsize snd chn))
- (let ((pk (float-vector-peak fdr)))
- (if (> pk old-peak-amp) (set! old-peak-amp pk)))
+ (set! old-peak-amp (max (float-vector-peak fdr) old-peak-amp))
(spectrum fdr fdi #f 2)
(float-vector-subtract! fdr spectr)
(float-vector-scale! fdr (/ 1.0 freq-inc))
@@ -1389,12 +1377,12 @@ selected sound: (map-channel (cross-synthesis (integer->sound 0) .5 128 6.0))"))
(let* ((start (cursor))
(sf (make-sampler start)))
(do ((n start (+ 1 n))
- (val0 (abs (next-sample sf)) val1)
+ (val0 (abs (next-sample sf)))
(val1 (abs (next-sample sf)) (abs (next-sample sf))))
((or (sampler-at-end? sf)
(< (+ val0 val1) limit))
- (set! (cursor) n)
- n))))))
+ (set! (cursor) n))
+ (set! val0 val1))))))
;;; -------- sound interp
@@ -1455,16 +1443,16 @@ selected sound: (map-channel (cross-synthesis (integer->sound 0) .5 128 6.0))"))
;; since the old/new sounds can be any length, we'll write a temp file rather than trying to use map-channel
(let* ((len (framples snd chn))
- (newlen (floor (* time-scale len))))
- (let ((new-snd (with-sound ((snd-tempnam) :to-snd #f :srate (srate snd))
+ (newlen (floor (* time-scale len)))
+ (new-snd (with-sound ((snd-tempnam) :to-snd #f :srate (srate snd))
(let ((data (channel->float-vector 0 #f snd chn))
(read-env (make-env envelope :length (+ 1 newlen) :scaler len)))
(do ((i 0 (+ i 1)))
((= i newlen))
(outa i (array-interp data (env read-env) len)))))))
- (set-samples 0 newlen new-snd snd chn #t
- (format #f "env-sound-interp '~A ~A" envelope time-scale)
- 0 current-edit-position #t))))))
+ (set-samples 0 newlen new-snd snd chn #t
+ (format #f "env-sound-interp '~A ~A" envelope time-scale)
+ 0 current-edit-position #t)))))
;;; (env-sound-interp '(0 0 1 1 2 0) 2.0)
@@ -1507,10 +1495,10 @@ the given channel following 'envelope' (as in env-sound-interp), using grains to
(set! (mus-location read-env) i)
(let ((position-in-original (env read-env)))
(set! (readers next-reader)
- (make-sampler (max 0 (round (+ position-in-original (mus-random jitter)))) snd chn))
- (mus-reset (grain-envs next-reader)) ; restart grain env
- (set! next-reader (modulo (+ next-reader 1) num-readers))
- (if (< cur-readers next-reader) (set! cur-readers next-reader)))
+ (make-sampler (max 0 (round (+ position-in-original (mus-random jitter)))) snd chn)))
+ (mus-reset (grain-envs next-reader)) ; restart grain env
+ (set! next-reader (modulo (+ next-reader 1) num-readers))
+ (set! cur-readers (max cur-readers next-reader))
(do ((k 0 (+ k 1)))
((= k cur-readers))
@@ -1607,13 +1595,12 @@ as env moves to 0.0, low-pass gets more intense; amplitude and low-pass amount m
(let ((documentation "(remove-clicks) tries to find and smooth-over clicks"))
(lambda ()
;; this is very conservative -- the click detection limits above could be set much tighter in many cases
- (define (remove-click loc)
- (let ((click (find-click loc)))
- (if click
- (begin
- (smooth-sound (- click 2) 4)
- (remove-click (+ click 2))))))
- (remove-click 0))))
+ (let remove-click ((loc 0))
+ (let ((click (find-click loc)))
+ (if click
+ (begin
+ (smooth-sound (- click 2) 4)
+ (remove-click (+ click 2)))))))))
;;; -------- searching examples (zero+, next-peak)
@@ -1700,7 +1687,7 @@ In most cases, this will be slightly offset from the true beginning of the note"
(begin
(set! pk (spectr i))
(set! pkloc i))))))
- (if (< (abs (- pitch pit)) (/ (srate) (* 2 *transform-size*))) ; uh... why not do it direct?
+ (if (< (abs (- pitch pit)) (/ (srate) 2 *transform-size*)) ; uh... why not do it direct?
(set! rtn #t)))))
(fill! data 0.0)))
rtn))))))
@@ -1763,30 +1750,27 @@ a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (li
(define explode-sf2
(let ((documentation "(explode-sf2) turns the currently selected soundfont file into a bunch of files of the form sample-name.aif"))
(lambda ()
- (letrec ((sf2it
- (lambda (lst)
- (if (pair? lst)
- (let* ((vals (car lst))
- ;; each inner list is: '(name start loop-start loop-end)
- (name (car vals))
- (start (cadr vals))
- (end (if (null? (cdr lst))
- (framples)
- (cadadr lst)))
- (loop-start (- (caddr vals) start))
- (loop-end (- (cadddr vals) start))
- (filename (string-append name ".aif")))
- (if (selection?)
- (set! (selection-member? #t) #f)) ; clear entire current selection, if any
- (set! (selection-member?) #t)
- (set! (selection-position) start)
- (set! (selection-framples) (- end start))
- (save-selection filename (selection-srate) mus-bshort mus-aifc)
- (let ((temp (open-sound filename)))
- (set! (sound-loop-info temp) (list loop-start loop-end))
- (close-sound temp))
- (sf2it (cdr lst)))))))
- (sf2it (soundfont-info))))))
+ (let sf2it ((lst (soundfont-info)))
+ (if (pair? lst)
+ (let* ((vals (car lst))
+ (name (car vals))
+ (start (cadr vals))
+ (end (if (null? (cdr lst))
+ (framples)
+ (cadadr lst)))
+ (loop-start (- (caddr vals) start))
+ (loop-end (- (cadddr vals) start))
+ (filename (string-append name ".aif")))
+ (if (selection?)
+ (set! (selection-member? #t) #f))
+ (set! (selection-member?) #t)
+ (set! (selection-position) start)
+ (set! (selection-framples) (- end start))
+ (save-selection filename (selection-srate) mus-bshort mus-aifc)
+ (let ((temp (open-sound filename)))
+ (set! (sound-loop-info temp) (list loop-start loop-end))
+ (close-sound temp))
+ (sf2it (cdr lst))))))))
;;; -------- open-next-file-in-directory
@@ -1836,8 +1820,7 @@ a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (li
(set! last-file-opened filename)
(display last-file-opened)
(let ((new-path (directory-from-path (file-name filename))))
- (if (or (not (string? current-directory))
- (not (string=? current-directory new-path)))
+ (if (not (equal? current-directory new-path))
(get-current-files new-path)))
#f)
@@ -1885,7 +1868,7 @@ a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (li
;; the calls are ordered out->in (or last first)
;; we take this list and create and evaluate a new function
- (let ((dsp-chain (apply vector (reverse (map (lambda (gen)
+ (let ((dsp-chain (reverse (apply vector (map (lambda (gen)
(if (pair? gen)
(make-env gen :duration dur)
gen))
@@ -1903,22 +1886,21 @@ a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (li
(let ((g (dsp-chain i))
(gname (string->symbol (format #f "g~D" i))))
(set! closure (cons `(,gname (dsp-chain ,i)) closure))
- (if (env? g)
- (set! body (if (eqv? body 0.0)
- `(env ,gname)
- `(* (env ,gname) ,body)))
- (if (readin? g)
- (set! body (if (eqv? body 0.0)
- `(readin ,gname)
- `(+ ,body (readin ,gname))))
- (if (mus-generator? g)
- (set! body (if (eqv? body 0.0)
- (list (string->symbol (mus-name g)) gname)
- (list (string->symbol (mus-name g)) gname body)))
- (set! body (list gname body)))))))
+ (cond ((env? g)
+ (set! body (if (eqv? body 0.0)
+ `(env ,gname)
+ `(* (env ,gname) ,body))))
+ ((readin? g)
+ (set! body (if (eqv? body 0.0)
+ `(readin ,gname)
+ `(+ ,body (readin ,gname)))))
+ ((mus-generator? g)
+ (set! body (if (eqv? body 0.0)
+ (list (string->symbol (mus-name g)) gname)
+ (list (string->symbol (mus-name g)) gname body))))
+ (else (set! body (list gname body))))))
;; now patch the two together (the apply let below) and evaluate the resultant thunk
-
(apply define (list 'inner)
`((let ,closure
(do ((k ,start (+ k 1)))
@@ -1948,14 +1930,13 @@ a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (li
passed as the arguments so to end with channel 3 in channel 0, 2 in 1, 0 in 2, and 1 in 3, (scramble-channels 3 2 0 1)"))
(lambda new-order
- (define (find-chan chans chan len)
- (let ((pos #f))
- (do ((i 0 (+ i 1)))
- ((or pos (= i len)) pos)
- (if (= (chans i) chan)
- (set! pos i)))))
-
(define (scramble-channels-1 cur-chans end-chans chans loc)
+ (define (find-chan chans chan len)
+ (let ((pos #f))
+ (do ((i 0 (+ i 1)))
+ ((or pos (= i len)) pos)
+ (if (= (chans i) chan)
+ (set! pos i)))))
(if (> chans loc)
(let* ((end-chan (end-chans loc)) ; we want this channel at loc
(cur-chan (cur-chans loc)) ; this (original) channel is currently at loc
@@ -1995,12 +1976,12 @@ passed as the arguments so to end with channel 3 in channel 0, 2 in 1, 0 in 2, a
(reader (make-sampler)))
(do ((i 0 (+ i 1)))
((= i len))
- (let ((y (next-sample reader)))
- (let* ((sum-of-squares (moving-average buffer (* y y)))
- (now-silent (< sum-of-squares silence)))
- (if (not (eq? in-silence now-silent))
- (set! edges (cons i edges)))
- (set! in-silence now-silent)))))
+ (let* ((y (next-sample reader))
+ (sum-of-squares (moving-average buffer (* y y)))
+ (now-silent (< sum-of-squares silence)))
+ (if (not (eq? in-silence now-silent))
+ (set! edges (cons i edges)))
+ (set! in-silence now-silent))))
(set! edges (append (reverse edges) (list (framples))))
(let* ((len (length edges))
(pieces (make-vector len #f))
@@ -2048,7 +2029,7 @@ passed as the arguments so to end with channel 3 in channel 0, 2 in 1, 0 in 2, a
(let ((documentation "(reverse-by-blocks block-len snd chn): divide sound into block-len blocks, recombine blocks in reverse order"))
(lambda* (block-len snd chn)
(let* ((len (framples snd chn))
- (num-blocks (floor (/ len (* (srate snd) block-len)))))
+ (num-blocks (floor (/ len (srate snd) block-len))))
(if (> num-blocks 1)
(let* ((actual-block-len (ceiling (/ len num-blocks)))
(rd (make-sampler (- len actual-block-len) snd chn))
@@ -2075,7 +2056,7 @@ passed as the arguments so to end with channel 3 in channel 0, 2 in 1, 0 in 2, a
(let ((documentation "(reverse-within-blocks block-len snd chn): divide sound into blocks, recombine in order, but each block internally reversed"))
(lambda* (block-len snd chn)
(let* ((len (framples snd chn))
- (num-blocks (floor (/ len (* (srate snd) block-len)))))
+ (num-blocks (floor (/ len (srate snd) block-len))))
(if (> num-blocks 1)
(let ((actual-block-len (ceiling (/ len num-blocks)))
(no-clicks-env (list 0.0 0.0 .01 1.0 .99 1.0 1.0 0.0)))
diff --git a/expandn.scm b/expandn.scm
index b2d39a3..ed77b86 100644
--- a/expandn.scm
+++ b/expandn.scm
@@ -82,9 +82,7 @@
(segment-scaler (if (> max-seg-len .15)
(/ (* grain-amp .15) max-seg-len)
grain-amp))
- (srenv (if (pair? srate)
- (make-env srate :duration duration)
- (make-env (list 0 srate) :duration duration)))
+ (srenv (make-env (if (pair? srate) srate (list 0 srate)) :duration duration))
(rampenv (make-env rampdata :duration (/ duration update-rate)))
(minramp-bug (<= (min-envelope rampdata) 0.0))
(maxramp-bug (>= (max-envelope rampdata) 0.5))
@@ -135,8 +133,7 @@
(* (mus-sound-duration fnam)
(/ (mus-sound-srate fnam) *clm-srate*)
(/ expand srate)))))))
- (if (> end file-end)
- (set! end file-end))
+ (set! end (min end file-end))
(do ((i beg (+ i 1)))
((= i end))
@@ -163,8 +160,9 @@
(set! sample-1 (* vol (granulate ingen)))))
(set! ex-samp (+ ex-samp samps))))
(if (= next-samp ex-samp)
- (outa i sample-0)
- (outa i (+ sample-0 (* (- next-samp ex-samp) (- sample-1 sample-0))))))))))
+ (outa i (if (= next-samp ex-samp)
+ sample-0
+ (+ sample-0 (* (- next-samp ex-samp) (- sample-1 sample-0)))))))))))
(do ((i beg (+ i 1)))
((= i end))
@@ -201,19 +199,16 @@
((= k samps))
(set! sample-0 sample-1)
(set! sample-1 (* vol (granulate ingen)))))
- (set! ex-samp (+ ex-samp samps))))))
+ (set! ex-samp (+ ex-samp samps)))))))
+ (set! (invals 0) (if (= next-samp ex-samp)
+ sample-0 ; output actual samples
+ (+ sample-0 (* (- next-samp ex-samp) (- sample-1 sample-0))))) ; output interpolated samples
- (if (= next-samp ex-samp)
- ;; output actual samples
- (set! (invals 0) sample-0)
- ;; output interpolated samples
- (set! (invals 0) (+ sample-0 (* (- next-samp ex-samp) (- sample-1 sample-0)))))
-
- ;; output mixed result
- (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
- ;; if reverb is turned on, output to the reverb streams
- (if rev-mx
- (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans)))))))
+ ;; output mixed result
+ (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
+ ;; if reverb is turned on, output to the reverb streams
+ (if rev-mx
+ (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans))))))
(if (= in-chans 2)
(let ((sample-0-0 0.0)
@@ -266,23 +261,23 @@
(set! sample-1-0 (* vol (granulate ingen0)))
(set! sample-0-1 sample-1-1)
(set! sample-1-1 (* vol (granulate ingen1))))
- (set! ex-samp (+ ex-samp samps))))))
-
- (if (= next-samp ex-samp)
- ;; output actual samples
- (begin
- (set! (invals 0) sample-0-0)
- (set! (invals 1) sample-0-1))
- (begin
- ;; output interpolated samples
- (set! (invals 0) (+ sample-0-0 (* (- next-samp ex-samp) (- sample-1-0 sample-0-0))))
- (set! (invals 1) (+ sample-0-1 (* (- next-samp ex-samp) (- sample-1-1 sample-0-1))))))
+ (set! ex-samp (+ ex-samp samps)))))))
- ;; output mixed result
- (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
- ;; if reverb is turned on, output to the reverb streams
- (if rev-mx
- (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans))))))
+ (if (= next-samp ex-samp)
+ ;; output actual samples
+ (begin
+ (set! (invals 0) sample-0-0)
+ (set! (invals 1) sample-0-1))
+ (begin
+ ;; output interpolated samples
+ (set! (invals 0) (+ sample-0-0 (* (- next-samp ex-samp) (- sample-1-0 sample-0-0))))
+ (set! (invals 1) (+ sample-0-1 (* (- next-samp ex-samp) (- sample-1-1 sample-0-1))))))
+
+ ;; output mixed result
+ (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
+ ;; if reverb is turned on, output to the reverb streams
+ (if rev-mx
+ (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans)))))
(let ((samples-0 (make-float-vector in-chans 0.0))
(samples-1 (make-float-vector in-chans 0.0)))
@@ -331,21 +326,21 @@
(let ((gen (vector-ref ex-array ix)))
(float-vector-set! samples-0 ix (float-vector-ref samples-1 ix))
(float-vector-set! samples-1 ix (* vol (granulate gen))))))
- (set! ex-samp (+ ex-samp samps))))))
+ (set! ex-samp (+ ex-samp samps)))))))
- (if (= next-samp ex-samp)
- ;; output actual samples
- (copy samples-0 invals 0 in-chans)
- ;; output interpolated samples
- (do ((ix 0 (+ ix 1)))
- ((= ix in-chans))
- (let ((v0 (float-vector-ref samples-0 ix))
- (v1 (float-vector-ref samples-1 ix)))
- (float-vector-set! invals ix (+ v0 (* (- next-samp ex-samp) (- v1 v0)))))))
- ;; output mixed result
- (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
- ;; if reverb is turned on, output to the reverb streams
- (if rev-mx
- (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans)))))))))))))))
+ (if (= next-samp ex-samp)
+ ;; output actual samples
+ (copy samples-0 invals 0 in-chans)
+ ;; output interpolated samples
+ (do ((ix 0 (+ ix 1)))
+ ((= ix in-chans))
+ (let ((v0 (float-vector-ref samples-0 ix))
+ (v1 (float-vector-ref samples-1 ix)))
+ (float-vector-set! invals ix (+ v0 (* (- next-samp ex-samp) (- v1 v0)))))))
+ ;; output mixed result
+ (frample->file *output* i (frample->frample mx invals ochans outvals ochans))
+ ;; if reverb is turned on, output to the reverb streams
+ (if rev-mx
+ (frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans))))))))))))))
;;; (with-sound () (expandn 0 1 "oboe.snd" 1 :expand 4))
diff --git a/extensions.scm b/extensions.scm
index 28fe6af..745b131 100644
--- a/extensions.scm
+++ b/extensions.scm
@@ -17,8 +17,8 @@
(define remove-if
(let ((documentation "(remove-if func lst) removes any element from 'lst' that 'func' likes"))
- (lambda (pred l)
- (map (lambda (x) (if (pred x) (values) x)) l))))
+ (lambda (pred lst)
+ (map (lambda (x) (if (pred x) (values) x)) lst))))
(if (not (defined? 'all-chans))
@@ -55,14 +55,14 @@ two sounds open (indices 0 and 1 for example), and the second has two channels,
(let ((original-maxamp (maxamp snd chn)))
(mix filename beg in-chan snd chn)
(let ((new-maxamp (maxamp snd chn)))
- (if (not (= original-maxamp new-maxamp))
+ (if (= original-maxamp new-maxamp)
+ 1.0
(let ((scaler (/ original-maxamp new-maxamp))
(old-sync (sync snd)))
(set! (sync snd) (+ (sync-max) 1))
(scale-by scaler snd chn)
(set! (sync snd) old-sync)
- scaler)
- 1.0))))))
+ scaler)))))))
;;;-------- mix with envelope on mixed-in file
@@ -112,15 +112,13 @@ two sounds open (indices 0 and 1 for example), and the second has two channels,
(let ((documentation "(match-sound-files func dir) applies func to each sound file in dir and returns a list of files for which func does not return #f"))
(lambda* (func dir)
(let ((matches ()))
- (for-each
- (lambda (file)
- (if (func file)
- (set! matches (cons file matches))))
- (sound-files-in-directory (or dir ".")))
+ (for-each-sound-file (lambda (file)
+ (if (func file)
+ (set! matches (cons file matches))))
+ dir)
matches))))
-
;;; -------- mix-channel, insert-channel, c-channel
(define mix-channel
@@ -157,38 +155,32 @@ a list (file-name-or-sound-object [beg [channel]])."))
(start (or beg 0)))
(if (< start 0)
(error 'no-such-sample "mix-channel: begin time < 0: ~A" beg)
- (if (> len 0)
- (if (not with-tag)
-
- ;; not a virtual mix
- (let ((d1 (samples input-beg len input input-channel))
- (d2 (samples start len snd chn edpos)))
- (float-vector-add! d1 d2)
- (float-vector->channel d1 start len snd chn current-edit-position
- (if (string? input-data)
- (format #f "mix-channel ~S ~A ~A" input-data beg dur)
- (format #f "mix-channel '~A ~A ~A" input-data beg dur))))
-
+ (when (> len 0)
+ (cond ((not with-tag)
+ ;; not a virtual mix
+ (let ((d1 (samples input-beg len input input-channel))
+ (d2 (samples start len snd chn edpos)))
+ (float-vector-add! d1 d2)
+ (float-vector->channel d1 start len snd chn
+ current-edit-position
+ (format #f (if (string? input-data)
+ "mix-channel ~S ~A ~A"
+ "mix-channel '~A ~A ~A")
+ input-data beg dur))))
;; a virtual mix -- use simplest method available
- (if (sound? input)
-
- ;; sound object case
- (channel->mix input input-channel input-beg len snd chn start)
-
- ;; file input
- (if (and (= start 0)
- (= len (framples input)))
-
- ;; mixing entire file
- (mix input start 0 snd chn #t #f) ; don't delete it!
-
- ;; mixing part of file
- (let* ((output-name (snd-tempnam))
- (output (new-sound output-name :size len)))
- (float-vector->channel (samples input-beg len input input-channel) 0 len output 0)
- (save-sound output)
- (close-sound output)
- (mix output-name start 0 snd chn #t #t)))))))))))
+ ((sound? input) ; sound object case
+ (channel->mix input input-channel input-beg len snd chn start))
+ ((and (= start 0) ; file input
+ (= len (framples input)))
+ (mix input start 0 snd chn #t #f)) ; mix entire file (don't delete it)
+ (else
+ ;; mix part of file
+ (let* ((output-name (snd-tempnam))
+ (output (new-sound output-name :size len)))
+ (float-vector->channel (samples input-beg len input input-channel) 0 len output 0)
+ (save-sound output)
+ (close-sound output)
+ (mix output-name start 0 snd chn #t #t))))))))))
(define insert-channel
@@ -210,9 +202,10 @@ a list (file-name-or-sound-object [beg [channel]])."))
(insert-samples start len
(samples file-beg len file-name file-channel)
snd chn edpos #f
- (if (string? file-data)
- (format #f "insert-channel ~S ~A ~A" file-data beg dur)
- (format #f "insert-channel '~A ~A ~A" file-data beg dur))))))))
+ (format #f (if (string? file-data)
+ "insert-channel ~S ~A ~A"
+ "insert-channel '~A ~A ~A")
+ file-data beg dur)))))))
;;; -------- redo-channel, undo-channel
@@ -240,33 +233,33 @@ a list (file-name-or-sound-object [beg [channel]])."))
connects them with 'func', and applies the result as an amplitude envelope to the given channel"))
(lambda* (e func (beg 0) dur snd chn edpos origin)
;; handled as a sequence of funcs and scales
- (if (pair? e)
- (let ((pts (/ (length e) 2)))
- (if (= pts 1)
- (scale-channel (car e) beg dur snd chn edpos)
- (let ((x0 0)
- (y0 0)
- (x1 (car e))
- (y1 (cadr e))
- (xrange (- (e (- (length e) 2)) (car e)))
- (ramp-beg beg)
- (ramp-dur 0))
- (if (not (number? dur)) (set! dur (framples snd chn)))
- (as-one-edit
- (lambda ()
- (do ((i 1 (+ 1 i))
- (j 2 (+ j 2)))
- ((= i pts))
- (set! x0 x1)
- (set! y0 y1)
- (set! x1 (e j))
- (set! y1 (e (+ 1 j)))
- (set! ramp-dur (round (* dur (/ (- x1 x0) xrange))))
- (if (= y0 y1)
- (scale-channel y0 ramp-beg ramp-dur snd chn edpos)
- (func y0 y1 ramp-beg ramp-dur snd chn edpos))
- (set! ramp-beg (+ ramp-beg ramp-dur))))
- origin))))))))
+ (when (pair? e)
+ (let ((pts (/ (length e) 2)))
+ (if (= pts 1)
+ (scale-channel (car e) beg dur snd chn edpos)
+ (let ((x0 0)
+ (y0 0)
+ (x1 (car e))
+ (y1 (cadr e))
+ (xrange (- (e (- (length e) 2)) (car e)))
+ (ramp-beg beg)
+ (ramp-dur 0))
+ (if (not (number? dur)) (set! dur (framples snd chn)))
+ (as-one-edit
+ (lambda ()
+ (do ((i 1 (+ 1 i))
+ (j 2 (+ j 2)))
+ ((= i pts))
+ (set! x0 x1)
+ (set! y0 y1)
+ (set! x1 (e j))
+ (set! y1 (e (+ 1 j)))
+ (set! ramp-dur (round (* dur (/ (- x1 x0) xrange))))
+ (if (= y0 y1)
+ (scale-channel y0 ramp-beg ramp-dur snd chn edpos)
+ (func y0 y1 ramp-beg ramp-dur snd chn edpos))
+ (set! ramp-beg (+ ramp-beg ramp-dur))))
+ origin))))))))
;;; -------- sine-ramp sine-env-channel
@@ -277,12 +270,12 @@ connects them with 'func', and applies the result as an amplitude envelope to th
(let ((data (samples beg len snd chn edpos))
(incr (/ pi len))
(scl (* 0.5 (- rmp1 rmp0))))
- (let ((off (+ rmp0 scl)))
- (do ((i 0 (+ i 1))
- (angle (- pi) (+ angle incr)))
- ((= i len))
- (float-vector-set! data i (* (float-vector-ref data i)
- (+ off (* scl (cos angle)))))))
+ (do ((off (+ rmp0 scl))
+ (i 0 (+ i 1))
+ (angle (- pi) (+ angle incr)))
+ ((= i len))
+ (float-vector-set! data i (* (float-vector-ref data i)
+ (+ off (* scl (cos angle))))))
(float-vector->channel data
beg len snd chn current-edit-position
(format #f "sine-ramp ~A ~A ~A ~A" rmp0 rmp1 beg dur)))))))
@@ -448,14 +441,14 @@ connects them with 'func', and applies the result as an amplitude envelope to th
(define dither-channel
(let ((documentation "(dither-channel (amount .00006) (beg 0) dur snd chn edpos) adds amount dither to each sample"))
(lambda* ((amount .00006) (beg 0) dur snd chn edpos)
- (let ((dither (* .5 amount)))
- (let* ((len (if (number? dur) dur (- (framples snd chn) beg)))
- (data (samples beg len snd chn edpos)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (float-vector-set! data i (+ (float-vector-ref data i) (mus-random dither) (mus-random dither))))
- (float-vector->channel data beg len snd chn current-edit-position
- (format #f "dither-channel ~,8F ~A ~A" amount beg dur)))))))
+ (let* ((dither (* .5 amount))
+ (len (if (number? dur) dur (- (framples snd chn) beg)))
+ (data (samples beg len snd chn edpos)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (float-vector-set! data i (+ (float-vector-ref data i) (mus-random dither) (mus-random dither))))
+ (float-vector->channel data beg len snd chn current-edit-position
+ (format #f "dither-channel ~,8F ~A ~A" amount beg dur))))))
(define dither-sound
diff --git a/extsnd.html b/extsnd.html
index 2d46494..a9a6614 100644
--- a/extsnd.html
+++ b/extsnd.html
@@ -2034,20 +2034,23 @@ we're saving the selection.
<pre class="indented">
(hook-push <em class=red>before-save-as-hook</em>
- (lambda (hook)
- ((lambda (index filename sr dformat htype comment)
- (if (not (= sr (<a class=quiet href="#srate">srate</a> index)))
- (let ((chns (<a class=quiet href="#chans">channels</a> index)))
- (do ((i 0 (+ i 1)))
- ((= i chns))
- (<a class=quiet href="#srcchannel">src-channel</a> (exact->inexact (/ (<a class=quiet href="#srate">srate</a> index) sr)) 0 #f index i))
- (<a class=quiet href="#savesoundas">save-sound-as</a> filename index :header-type htype :sample-type dformat :srate sr :comment comment)
- (do ((i 0 (+ i 1)))
- ((= i chns))
- (<a class=quiet href="#undo">undo</a> 1 index i))
- (set! (hook 'result) #t)))) ; tell Snd that the sound is already saved
- (hook 'snd) (hook 'name) (hook 'sampling-rate) (hook 'header-type) (hook 'sample-type) (hook 'comment))))
-
+ (lambda (hook)
+ (let ((index (hook 'snd))
+ (filename (hook 'name))
+ (sr (hook 'sampling-rate))
+ (dformat (hook 'sample-type))
+ (htype (hook 'header-type))
+ (comment (hook 'comment)))
+ (if (not (= sr (srate index)))
+ (let ((chns (channels index)))
+ (do ((i 0 (+ i 1)))
+ ((= i chns))
+ (src-channel (* 1.0 (/ (srate index) sr)) 0 #f index i))
+ (save-sound-as filename index :header-type htype :sample-type dformat :srate sr :comment comment)
+ (do ((i 0 (+ i 1)))
+ ((= i chns))
+ (undo 1 index i))
+ (set! (hook 'result) #t)))))) ; tell Snd that the sound is already saved
</pre>
<div class="spacer"></div>
@@ -2250,15 +2253,18 @@ and decay portions in the envelope editor, or use functions such as
<pre class="indented">
(hook-push <em class=red>enved-hook</em>
(lambda (hook)
- ((lambda (env pt x y reason)
- (if (and (= reason enved-move-point)
- (> x 0.0)
- (< x (<a class=quiet>envelope-last-x</a> env))) ; from env.scm
- (let* ((old-x (env (* pt 2)))
- (new-env (<em class=red>stretch-envelope</em> env old-x x)))
- (set! (new-env (+ (* pt 2) 1)) y)
- (set! (hook 'result) new-env))))
- (hook 'envelope) (hook 'point) (hook 'x) (hook 'y) (hook 'reason))))
+ (let ((env (hook 'envelope))
+ (pt (hook 'point))
+ (x (hook 'x))
+ (y (hook 'y))
+ (reason (hook 'reason)))
+ (if (and (= reason enved-move-point)
+ (> x 0.0)
+ (< x (envelope-last-x env)))
+ (let* ((old-x (env (* pt 2)))
+ (new-env (stretch-envelope env old-x x)))
+ (set! (new-env (+ (* pt 2) 1)) y)
+ (set! (hook 'result) new-env))))))
</pre>
<p>In Forth/Ruby, if there are several functions on the hook, each gets the envelope
@@ -2295,13 +2301,9 @@ See examp.scm for many examples. If you want to add your own graphics to the di
(let* ((snd (hook 'snd))
(chn (hook 'chn))
(dots (- (<a class=quiet href="#rightsample">right-sample</a> snd chn) (<a class=quiet href="#leftsample">left-sample</a> snd chn))))
- (if (> dots 100)
- (set! (<a class=quiet href="#dotsize">dot-size</a> snd chn) 1)
- (if (> dots 50)
- (set! (<a class=quiet href="#dotsize">dot-size</a> snd chn) 3)
- (if (> dots 25)
- (set! (<a class=quiet href="#dotsize">dot-size</a> snd chn) 5)
- (set! (<a class=quiet href="#dotsize">dot-size</a> snd chn) 8))))))))
+ (set! (dot-size snd chn)
+ (cond ((assoc dots '((100 . 1) (50 . 3) (25 . 5)) >) => cdr)
+ (else 8)))))))
</pre>
<div class="spacer"></div>
@@ -2460,9 +2462,9 @@ If it returns a thunk, that function is called rather than the standard graph ro
""))
(<a class=quiet href="#marksample">mark-sample</a> n)
(* 1.0 (/ (<a class=quiet href="#marksample">mark-sample</a> n) (<a class=quiet href="#srate">srate</a> (car (<a class=quiet href="#markhome">mark-home</a> n)))))
- (if (not (= (<a class=quiet href="#marksync">mark-sync</a> n) 0))
- (<a class=quiet>format</a> #f "~% sync: ~A" (<a class=quiet href="#marksync">mark-sync</a> n))
- "")
+ (if (zero? (<a class=quiet href="#marksync">mark-sync</a> n))
+ ""
+ (<a class=quiet>format</a> #f "~% sync: ~A" (<a class=quiet href="#marksync">mark-sync</a> n)))
(let ((props (<a class=quiet href="#markproperties">mark-properties</a> n)))
(if (pair? props)
(<a class=quiet>format</a> #f "~% properties: '~A" props)
@@ -2518,17 +2520,21 @@ and if the <a href="#marksync">mark-sync</a> is not 0, the hook is called on eac
;; when a mark is dragged, its end position is always on a beat
(hook-push <em class=red>mark-hook</em>
(lambda (hook)
- ((lambda (mrk snd chn reason)
- (let ((mark-release 4))
- (if (= reason mark-release)
- (let* ((samp (<a class=quiet href="#marksample">mark-sample</a> mrk))
- (bps (/ (<a class=quiet href="#beatsperminute">beats-per-minute</a> snd chn) 60.0))
- (sr (<a class=quiet href="#srate">srate</a> snd))
- (beat (floor (/ (* samp bps) sr)))
- (lower (floor (/ (* beat sr) bps)))
- (higher (floor (/ (* (+ 1 beat) sr) bps))))
- (set! (<a class=quiet href="#marksample">mark-sample</a> mrk) (if (< (- samp lower) (- higher samp)) lower higher))))))
- (hook 'id) (hook 'snd) (hook 'chn) (hook 'reason)))))
+ (let ((mrk (hook 'id))
+ (snd (hook 'snd))
+ (chn (hook 'chn))
+ (reason (hook 'reason)))
+ (let ((mark-release 4))
+ (if (= reason mark-release)
+ (let* ((samp (mark-sample mrk))
+ (bps (/ (beats-per-minute snd chn) 60.0))
+ (sr (srate snd))
+ (beat (floor (/ (* samp bps) sr)))
+ (lower (floor (/ (* beat sr) bps)))
+ (higher (floor (/ (* (+ 1 beat) sr) bps))))
+ (set! (mark-sample mrk) (if (< (- samp lower) (- higher samp))
+ lower
+ higher)))))))))
</pre>
<div class="spacer"></div>
@@ -2902,10 +2908,7 @@ If it returns a string (a filename), that file is opened instead of the original
;; check for "OggS" first word, if found, translate to something Snd can read
(call-with-input-file filename
(lambda (fd)
- (and (char=? (read-char fd) #\O)
- (char=? (read-char fd) #\g)
- (char=? (read-char fd) #\g)
- (char=? (read-char fd) #\S)))))
+ (equal? (read-string 4 fd) "OggS"))))
(let ((aufile (string-append filename ".au")))
(if (file-exists? aufile) (delete-file aufile))
(system (<a class=quiet>format</a> #f "ogg123 -d au -f ~A ~A" aufile filename))
@@ -3522,16 +3525,19 @@ in the Scheme, Ruby, and Forth files.
<pre class="indented">
(define* (region->float-vector reg (chn 0))
- (if (<a class=quiet href="#regionok">region?</a> reg)
- (if (< chn (channels reg))
- (let* ((reader (<em class=red>make-region-sampler</em> 0 reg chn))
- (len (<a class=quiet href="#regionframples">region-framples</a> reg))
- (data (make-float-vector len 0.0)))
- (do ((i 0 (+ i 1)))
- ((= i len) data)
- (set! (data i) (<em class=red>reader</em>))))
- (error 'no-such-channel (list "region->float-vector" reg chn)))
- (error 'no-such-region (list "region->float-vector" reg))))
+ (cond ((not (region? reg))
+ (error 'no-such-region (list "region->float-vector" reg)))
+
+ ((< chn (channels reg))
+ (let* ((reader (<em class=red>make-region-sampler</em> 0 reg chn))
+ (len (region-framples reg))
+ (data (make-float-vector len 0.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i len) data)
+ (set! (data i) (<em class=red>reader</em>)))))
+
+ (else
+ (error 'no-such-channel (list "region->float-vector" reg chn)))))
</pre>
<div class="spacer"></div>
@@ -4707,7 +4713,7 @@ throw 'mus-error upon encountering an error, rather than returning -1 like the u
", " (<a class=quiet href="#mussampletypename">mus-sample-type-name</a> (<a class=quiet href="#mussoundsampletype">mus-sound-sample-type</a> file))
", len: " (number->string
(/ (<a class=quiet href="#mussoundsamples">mus-sound-samples</a> file)
- (* (channels file) (srate file)))))))
+ (channels file) (srate file))))))
</pre>
@@ -5603,7 +5609,7 @@ example, if you know the frequency of the mix sound, you can reflect that in the
</p>
<pre class="indented">
-(set! (mix-tag-y mix-id) (round (* 100 (- 1.0 (/ (log (/ freq 40.0)) (* (log 2.0) 7))))))
+(set! (mix-tag-y mix-id) (round (* 100 (- 1.0 (/ (log (/ freq 40.0)) (log 2.0) 7)))))
</pre>
<p>See, for example, check-mix-tags in sndscm.html.
@@ -6439,7 +6445,7 @@ It's easy to extend the notion of a selection to an arbitrary list of sound port
<pre class="indented">
(define (make-section . members)
;; each member is '(beg dur snd chn)
- (append (list 'Section) members))
+ (cons 'Section members))
(define (section-for-each func section)
;; call func on each member of the section
@@ -6448,7 +6454,7 @@ It's easy to extend the notion of a selection to an arbitrary list of sound port
;; an example that scales each member of the section by .5
(section-for-each
(lambda (sect)
- (apply <a class=quiet href="#scalechannel">scale-channel</a> (append (list .5) sect)))
+ (apply <a class=quiet href="#scalechannel">scale-channel</a> (cons .5 sect)))
(make-section (list 0 10000 0 0) (list 30000 10000 0 0)))
</pre>
@@ -6602,24 +6608,23 @@ then restore that state upon "Page Up":
(<a class=quiet href="#sounds">sounds</a>))))
(<a class=quiet href="#bindkey">bind-key</a> "Page_Up" 0
(lambda ()
- (if last-page-state
- (for-each
- (lambda (lst)
- (let ((snd (lst 0))
- (name (lst 1)))
- (if (and (<a class=quiet href="#soundp">sound?</a> snd)
- (string=? (<a class=quiet href="#filename">file-name</a> snd) name))
- (for-each
- (lambda (chan-data)
- (let ((chn (chan-data 0))
- (x0 (chan-data 3))
- (x1 (chan-data 5))
- (y0 (chan-data 4))
- (y1 (chan-data 6)))
- (set! (<a class=quiet href="#xbounds">x-bounds</a> snd chn) (list x0 x1))
- (set! (<a class=quiet href="#ybounds">y-bounds</a> snd chn) (list y0 y1))))
- (cddr lst)))))
- last-page-state)))))))
+ (for-each
+ (lambda (lst)
+ (let ((snd (lst 0))
+ (name (lst 1)))
+ (if (and (<a class=quiet href="#soundp">sound?</a> snd)
+ (string=? (<a class=quiet href="#filename">file-name</a> snd) name))
+ (for-each
+ (lambda (chan-data)
+ (let ((chn (chan-data 0))
+ (x0 (chan-data 3))
+ (x1 (chan-data 5))
+ (y0 (chan-data 4))
+ (y1 (chan-data 6)))
+ (set! (<a class=quiet href="#xbounds">x-bounds</a> snd chn) (list x0 x1))
+ (set! (<a class=quiet href="#ybounds">y-bounds</a> snd chn) (list y0 y1))))
+ (cddr lst)))))
+ last-page-state))))))
</pre>
<div class="separator"></div>
@@ -6777,15 +6782,15 @@ so the function call is:
<pre class="indented">
(define* (selection->vct snd chn)
- (if (<a class=quiet href="#selectionmember">selection-member?</a> snd chn)
- (<em class=red>channel->vct</em> (<a class=quiet href="#selectionposition">selection-position</a> snd chn)
- (<a class=quiet href="#selectionframples">selection-framples</a> snd chn)
- snd chn)
- (if (<a class=quiet href="#selectionok">selection?</a>)
- (error 'no-such-channel
- (list "selection->vct"
- (<a class=quiet>format</a> #f "snd ~A channel ~D is not a member of the selection" snd chn)))
- (error 'no-active-selection (list "selection->vct")))))
+ (cond ((selection-member? snd chn)
+ (channel->vct (selection-position snd chn) (selection-framples snd chn) snd chn))
+
+ ((selection?)
+ (error 'no-such-channel
+ (list "selection->vct"
+ (format #f "snd ~A channel ~D is not a member of the selection" snd chn))))
+ (else
+ (error 'no-active-selection (list "selection->vct")))))
</pre>
<p>See also mark-explode in marks.scm.
@@ -7923,8 +7928,7 @@ something:
(let ((buffer (<a class=quiet href="sndclm.html#make-moving-average">make-moving-average</a> 128))
(silence (/ in-silence 128)))
(lambda (y)
- (let ((sum-of-squares (<a class=quiet href="sndclm.html#moving-average">moving-average</a> buffer (* y y))))
- (if (> sum-of-squares silence) y replacement)))))
+ (if (> (moving-average buffer (* y y)) silence) y replacement))))
(<em class=red>map-channel</em> (map-silence .01 0.0)) ; squelch background noise
(<em class=red>map-channel</em> (map-silence .001 #f)) ; remove silences altogether
@@ -9143,9 +9147,8 @@ file; 'auto-delete' set to #t asks Snd to handle cleanup).
((<a class=quiet href="#sampleratendQ">sampler-at-end?</a> rd))
(<a class=quiet href="sndclm.html#out-any">out-any</a> samp (<a class=quiet href="sndclm.html#src">src</a> s incr (lambda (dir) (<a class=quiet href="#readsample">read-sample</a> rd))) 0)
(if (= (modulo samp 2205) 0)
- (set! incr (+ 2.0 (<a class=quiet href="sndclm.html#oscil">oscil</a> o)))))))
- (len (<a class=quiet href="#mussoundframples">mus-sound-framples</a> tempfile)))
- (<em class=red>set-samples</em> 0 (- len 1) tempfile #f #f #t "step-src" 0 #f #t)))
+ (set! incr (+ 2.0 (<a class=quiet href="sndclm.html#oscil">oscil</a> o))))))))
+ (<em class=red>set-samples</em> 0 (- (<a class=quiet href="#mussoundframples">mus-sound-framples</a> tempfile) 1) tempfile #f #f #t "step-src" 0 #f #t)))
</pre>
<div class="separator"></div>
@@ -9341,17 +9344,14 @@ at the loop points:
</p>
<pre class="indented">
(define (mark-sf2)
- (letrec
- ((sf2it
- (lambda (lst)
- (if (pair? lst)
- (let* ((vals (car lst))
- (m1 (<a class=quiet href="#addmark">add-mark</a> (cadr vals))))
- (set! (<a class=quiet href="#markname">mark-name</a> m1) (car vals))
- (<a class=quiet href="#addmark">add-mark</a> (caddr vals))
- (<a class=quiet href="#addmark">add-mark</a> (cadddr vals))
- (sf2it (cdr lst)))))))
- (sf2it (<em class=red>soundfont-info</em>))))
+ (let sf2it ((lst (soundfont-info)))
+ (if (pair? lst)
+ (let ((vals (car lst)))
+ (let ((m1 (add-mark (cadr vals))))
+ (set! (mark-name m1) (car vals)))
+ (add-mark (caddr vals))
+ (add-mark (cadddr vals))
+ (sf2it (cdr lst))))))
</pre>
<img class="indented" src="pix/bongo.png" alt="soundfont marks">
@@ -9698,9 +9698,8 @@ how long the resultant note will be given an src envelope:
(y1 (e (+ i 3)))
(area (if (< (abs (- y0 y1)) .0001)
(/ (- x1 x0) (* y0 all-x))
- (* (/ (- (log y1) (log y0))
- (- y1 y0))
- (/ (- x1 x0) all-x)))))
+ (/ (* (- (log y1) (log y0)) (- x1 x0))
+ (* (- y1 y0) all-x)))))
(set! dur (+ dur (abs area)))))))
;;; (src-duration '(0 1 1 2)) -> 0.693147180559945
@@ -9799,14 +9798,14 @@ For example, the following function reverses the channel order:
<pre class="indented">
(define* (reverse-channels snd)
(let* ((ind (or snd (<a class=quiet href="#selectedsound">selected-sound</a>) (car (<a class=quiet href="#sounds">sounds</a>))))
- (chns (<a class=quiet href="#channels">channels</a> ind)))
- (let ((swaps (floor (/ chns 2))))
- (<a class=quiet href="#asoneedit">as-one-edit</a>
- (lambda ()
- (do ((i 0 (+ i 1))
- (j (- chns 1) (- j 1)))
- ((= i swaps))
- (<em class=red>swap-channels</em> ind i ind j)))))))
+ (chns (<a class=quiet href="#channels">channels</a> ind))
+ (swaps (floor (/ chns 2))))
+ (<a class=quiet href="#asoneedit">as-one-edit</a>
+ (lambda ()
+ (do ((i 0 (+ i 1))
+ (j (- chns 1) (- j 1)))
+ ((= i swaps))
+ (<em class=red>swap-channels</em> ind i ind j))))))
</pre>
<p>Channel rotation is similar, though slightly more work; see scramble-channels in examp.scm.
@@ -10666,7 +10665,7 @@ a vct suitable for use with the <a href="sndclm.html#filter">filter generator</a
<em class=def id="filtercontrolenvelope">filter-control-envelope</em> snd
</pre>
-<p>The <a class=quiet href="snd.html#filtercontrol">filter</a> (frequency reponse) envelope (a list of breakpoints).
+<p>The <a class=quiet href="snd.html#filtercontrol">filter</a> (frequency response) envelope (a list of breakpoints).
</p>
<div class="spacer"></div>
@@ -11222,8 +11221,8 @@ into an independent Snd process:
(with-output-to-file
scm1
(lambda ()
- (<a class=quiet>format</a> #t "(define sfile (<a class=quiet href="#opensound">open-sound</a> ~S))~%" name)
- (<a class=quiet>format</a> #t "(load ~S)~%" scm)))
+ (<a class=quiet>format</a> () "(define sfile (<a class=quiet href="#opensound">open-sound</a> ~S))~%" name)
+ (<a class=quiet>format</a> () "(load ~S)~%" scm)))
(system (<a class=quiet>format</a> #f "snd ~A &" scm1))))
</pre>
<div class="separator"></div>
@@ -11564,8 +11563,9 @@ to longer:
(lambda (a b)
(let ((dur1 (<a class=quiet href="#mussoundduration">mus-sound-duration</a> a))
(dur2 (<a class=quiet href="#mussoundduration">mus-sound-duration</a> b)))
- (if (> dur1 dur2) 1
- (if (< dur1 dur2) -1 0)))))
+ (cond ((> dur1 dur2) 1)
+ ((< dur1 dur2) -1)
+ (else 0)))))
</pre>
<div class="spacer"></div>
@@ -12488,6 +12488,16 @@ this is a test
<div class="spacer"></div>
+<!-- stdin-prompt -->
+<pre class="indented">
+<em class=def id="stdinprompt">stdin-prompt</em>
+</pre>
+
+<p>This is the stdin prompt which defaults to "".
+</p>
+<div class="spacer"></div>
+
+
<!-- transform-dialog -->
<pre class="indented">
<em class=def id="transformdialog">transform-dialog</em> managed
@@ -13033,7 +13043,7 @@ is named "call_in".
(cur-hour (cur-time 2))
(now (+ (* cur-hour 60) cur-minute))
(then (+ (* hour 60) minute)))
- (<em class=red>in</em> (* 1000 60 (- then now)) func)))
+ (<em class=red>in</em> (* 60000 (- then now)) func)))
(at 15 11 (lambda () (<a class=quiet href="#sndprint">snd-print</a> "it's 3:11 pm!")))
</pre>
@@ -13754,35 +13764,35 @@ of FractInt's royal colormap):
<pre class="indented">
(add-colormap "purple"
(lambda (size)
- (let ((r (make-float-vector size 0.0))
- (g (make-float-vector size 0.0))
- (b (make-float-vector size 0.0))
- (incr (/ 256.0 size))
- (er (list 0 60 60 116 128 252 192 252 256 60))
- (eg (list 0 0 64 0 128 252 192 252 256 0))
- (eb (list 0 80 128 252 192 0 256 80)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i size))
- (set! (r i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x er) 256.0)) ; from env.scm
- (set! (g i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x eg) 256.0))
- (set! (b i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x eb) 256.0)))
- (list r g b))))
+ (do ((r (make-float-vector size 0.0))
+ (g (make-float-vector size 0.0))
+ (b (make-float-vector size 0.0))
+ (incr (/ 256.0 size))
+ (er (list 0 60 60 116 128 252 192 252 256 60))
+ (eg (list 0 0 64 0 128 252 192 252 256 0))
+ (eb (list 0 80 128 252 192 0 256 80))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i size)
+ (list r g b))
+ (set! (r i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x er) 256.0)) ; from env.scm
+ (set! (g i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x eg) 256.0))
+ (set! (b i) (/ (<a class=quiet href="sndscm.html#envelopeinterp">envelope-interp</a> x eb) 256.0)))))
;;; another amusing colormap from FractInt:
(add-colormap "cos"
(lambda (size)
- (let ((r (make-float-vector size 0.0))
- (g (make-float-vector size 0.0))
- (b (make-float-vector size 0.0))
- (incr (/ 3.14159 size)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i size))
- (set! (r i) (abs (sin (* 1.5 x))))
- (set! (g i) (abs (sin (* 3.5 x))))
- (set! (b i) (abs (sin (* 2.5 x)))))
- (list r g b))))
+ (do ((r (make-float-vector size 0.0))
+ (g (make-float-vector size 0.0))
+ (b (make-float-vector size 0.0))
+ (incr (/ 3.14159 size))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i size)
+ (list r g b))
+ (set! (r i) (abs (sin (* 1.5 x))))
+ (set! (g i) (abs (sin (* 3.5 x))))
+ (set! (b i) (abs (sin (* 2.5 x)))))))
</pre>
<table><tr>
diff --git a/fade.scm b/fade.scm
index 7786a90..2f922bc 100644
--- a/fade.scm
+++ b/fade.scm
@@ -219,33 +219,33 @@
(float-vector-spatter inputs in2s in2-ctr inval2)
;; (do ((k 0 (+ k 1))) ((= k in2-ctr)) (float-vector-set! inputs (int-vector-ref in2s k) inval2))
- (if (> ramp-ctr 0)
- (let ((rk 0)
- (sp 0.0)
- (fixup-ramps #f))
- (do ((k 0 (+ k 1)))
- ((= k ramp-ctr))
- (set! rk (ramps k))
- (set! sp (vector-ref spectr rk))
- (float-vector-set! inputs k (+ (* sp inval1) (* (- 1.0 sp) inval2)))
- (set! sp (- sp ramp-inc))
- (if (> sp 0.0)
- (vector-set! spectr rk sp)
- (begin
- (set! (in2s in2-ctr) rk)
- (set! in2-ctr (+ in2-ctr 1))
- (set! fixup-ramps #t)
- (set! (ramps k) -1))))
- (if fixup-ramps
- (let ((j 0))
- (do ((k 0 (+ k 1)))
- ((= k ramp-ctr))
- (if (>= (ramps k) 0)
- (begin
- (set! (ramps j) (ramps k))
- (set! j (+ j 1)))))
- (set! ramp-ctr j)))))
-
+ (when (> ramp-ctr 0)
+ (let ((rk 0)
+ (sp 0.0)
+ (fixup-ramps #f))
+ (do ((k 0 (+ k 1)))
+ ((= k ramp-ctr))
+ (set! rk (ramps k))
+ (set! sp (vector-ref spectr rk))
+ (float-vector-set! inputs k (+ (* sp inval1) (* (- 1.0 sp) inval2)))
+ (set! sp (- sp ramp-inc))
+ (if (> sp 0.0)
+ (vector-set! spectr rk sp)
+ (begin
+ (set! (in2s in2-ctr) rk)
+ (set! in2-ctr (+ in2-ctr 1))
+ (set! fixup-ramps #t)
+ (set! (ramps k) -1))))
+ (if fixup-ramps
+ (let ((j 0))
+ (do ((k 0 (+ k 1)))
+ ((= k ramp-ctr))
+ (if (>= (ramps k) 0)
+ (begin
+ (set! (ramps j) (ramps k))
+ (set! j (+ j 1)))))
+ (set! ramp-ctr j)))))
+
(outa i (formant-bank fs inputs)))))))
diff --git a/fft-menu.scm b/fft-menu.scm
index 1504d11..d9dcf8b 100644
--- a/fft-menu.scm
+++ b/fft-menu.scm
@@ -22,12 +22,10 @@
(define fft-list ()) ; menu labels are updated to show current default settings
(define fft-menu (add-to-main-menu "FFT Edits" (lambda ()
- (define (update-label fft)
- (if (pair? fft)
- (begin
- ((car fft))
- (update-label (cdr fft)))))
- (update-label fft-list))))
+ (let update-label ((fft fft-list))
+ (when (pair? fft)
+ ((car fft))
+ (update-label (cdr fft)))))))
;;; ------ FFT edit
;;;
@@ -41,68 +39,63 @@
(define (cp-fft-edit)
(fft-edit fft-edit-low-frequency fft-edit-high-frequency))
-(if (or (provided? 'xg)
- (provided? 'xm))
+(if (not (or (provided? 'xg)
+ (provided? 'xm)))
+ (set! fft-edit-menu-label (add-to-menu fft-menu fft-edit-label cp-fft-edit))
(begin
-
(define (post-fft-edit-dialog)
- (if (not fft-edit-dialog)
- ;; if fft-edit-dialog doesn't exist, create it
- (let ((initial-fft-edit-low-frequency 100)
- (initial-fft-edit-high-frequency 1000)
- (sliders ()))
-
- (set! fft-edit-dialog
- (make-effect-dialog
- fft-edit-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-fft-edit))
- (lambda (w context info) (cp-fft-edit)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "FFT notch filter"
- "A simple example of FFT-based editing. It takes an FFT of the entire sound, \
+ (unless fft-edit-dialog
+ ;; if fft-edit-dialog doesn't exist, create it
+ (let ((initial-fft-edit-low-frequency 100)
+ (initial-fft-edit-high-frequency 1000)
+ (sliders ()))
+
+ (set! fft-edit-dialog
+ (make-effect-dialog fft-edit-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-fft-edit))
+ (lambda (w context)
+ (help-dialog "FFT notch filter"
+ "A simple example of FFT-based editing. It takes an FFT of the entire sound, \
removes all energy below the low frequency and above the high frequency, then computes the inverse FFT."))
- (lambda (w context info)
- (help-dialog "FFT notch filter"
- "A simple example of FFT-based editing. It takes an FFT of the entire sound, \
-removes all energy below the low frequency and above the high frequency, then computes the inverse FFT.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! fft-edit-low-frequency initial-fft-edit-low-frequency)
- (set! fft-edit-high-frequency initial-fft-edit-high-frequency)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) (floor fft-edit-low-frequency))
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) (floor fft-edit-high-frequency))
- )
- (lambda (w c i)
- (set! fft-edit-low-frequency initial-fft-edit-low-frequency)
- (set! fft-edit-high-frequency initial-fft-edit-high-frequency)
- ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) (floor fft-edit-low-frequency)))
- ((*motif* 'XtSetValues) (cadr sliders) (list (*motif* 'XmNvalue) (floor fft-edit-high-frequency)))))))
-
- (set! sliders
- (add-sliders
- fft-edit-dialog
-
- (list (list "low frequency" 20 initial-fft-edit-low-frequency 22050
- (if (provided? 'snd-gtk)
- (lambda (w data) (set! fft-edit-low-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fft-edit-low-frequency ((*motif* '.value) info))))
- 1)
-
- (list "high frequency" 20 initial-fft-edit-high-frequency 22050
- (if (provided? 'snd-gtk)
- (lambda (w data) (set! fft-edit-high-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fft-edit-high-frequency ((*motif* '.value) info))))
- 1))))))
+ (lambda (w data)
+ (set! fft-edit-low-frequency initial-fft-edit-low-frequency)
+ (set! fft-edit-high-frequency
+ initial-fft-edit-high-frequency)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders))
+ (floor fft-edit-low-frequency))
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders))
+ (floor fft-edit-high-frequency))))
+ (values (lambda (w context info)
+ (cp-fft-edit))
+ (lambda (w context info)
+ (help-dialog "FFT notch filter"
+ "A simple example of FFT-based editing. It takes an FFT of the entire sound,\
+ removes all energy below the low frequency and above the high frequency, then computes the inverse FFT."))
+ (lambda (w c i)
+ (set! fft-edit-low-frequency initial-fft-edit-low-frequency)
+ (set! fft-edit-high-frequency
+ initial-fft-edit-high-frequency)
+ ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) (floor fft-edit-low-frequency)))
+ ((*motif* 'XtSetValues) (cadr sliders) (list (*motif* 'XmNvalue) (floor fft-edit-high-frequency))))))))
+ (set! sliders
+ (add-sliders
+ fft-edit-dialog
+
+ (list (list "low frequency" 20 initial-fft-edit-low-frequency 22050
+ (if (provided? 'snd-gtk)
+ (lambda (w data) (set! fft-edit-low-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fft-edit-low-frequency ((*motif* '.value) info))))
+ 1)
+
+ (list "high frequency" 20 initial-fft-edit-high-frequency 22050
+ (if (provided? 'snd-gtk)
+ (lambda (w data) (set! fft-edit-high-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fft-edit-high-frequency ((*motif* '.value) info))))
+ 1))))))
(activate-dialog fft-edit-dialog))
-
- (set! fft-edit-menu-label (add-to-menu fft-menu "FFT notch filter" post-fft-edit-dialog)))
-
- (set! fft-edit-menu-label (add-to-menu fft-menu fft-edit-label cp-fft-edit)))
+ (set! fft-edit-menu-label (add-to-menu fft-menu "FFT notch filter" post-fft-edit-dialog))))
(set! fft-list (cons (lambda ()
(let ((new-label (format #f "FFT notch filter (~D ~D)" fft-edit-low-frequency fft-edit-high-frequency)))
@@ -123,58 +116,52 @@ removes all energy below the low frequency and above the high frequency, then co
(define (cp-fft-squelch)
(fft-squelch fft-squelch-amount))
-(if (or (provided? 'xg)
- (provided? 'xm))
+(if (not (or (provided? 'xg)
+ (provided? 'xm)))
+ (set! fft-squelch-menu-label (add-to-menu fft-menu fft-squelch-label cp-fft-squelch))
(begin
(define (post-fft-squelch-dialog)
-
- (if (not fft-squelch-dialog)
- ;; if fft-squelch-dialog doesn't exist, create it
- (let ((initial-fft-squelch-amount 0.0)
- (sliders ()))
-
- (set! fft-squelch-dialog
- (make-effect-dialog
- fft-squelch-label
-
- (if (provided? 'snd-gtk)
- (lambda (w data )(cp-fft-squelch))
- (lambda (w context info) (cp-fft-squelch)))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (help-dialog "FFT squelch"
- "Removes all energy below the squelch amount. This is sometimes useful for noise-reduction."))
- (lambda (w context info)
- (help-dialog "FFT squelch"
- "Removes all energy below the squelch amount. This is sometimes useful for noise-reduction.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! fft-squelch-amount initial-fft-squelch-amount)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) (round (* fft-squelch-amount 100)))
- )
- (lambda (w c i)
- (set! fft-squelch-amount initial-fft-squelch-amount)
- ((*motif* 'XtSetValues) (list-ref sliders 0) (list (*motif* 'XmNvalue) (round (* fft-squelch-amount 100))))))))
-
- (set! sliders
- (add-sliders
- fft-squelch-dialog
- (list (list "squelch amount" 0.0 initial-fft-squelch-amount 1.0
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! fft-squelch-amount (/ ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)) 100)))
- (lambda (w context info)
- (set! fft-squelch-amount (/ ((*motif* '.value) info) 100))))
- 100))))))
+ (unless fft-squelch-dialog
+ ;; if fft-squelch-dialog doesn't exist, create it
+ (let ((initial-fft-squelch-amount 0.0)
+ (sliders ()))
+
+ (set! fft-squelch-dialog
+ (make-effect-dialog fft-squelch-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w data)
+ (cp-fft-squelch))
+ (lambda (w data)
+ (help-dialog "FFT squelch"
+ "Removes all energy below the squelch amount. This is sometimes useful for noise-reduction."))
+ (lambda (w data)
+ (set! fft-squelch-amount initial-fft-squelch-amount)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders))
+ (round (* fft-squelch-amount 100)))))
+ (values (lambda (w context info)
+ (cp-fft-squelch))
+ (lambda (w context info)
+ (help-dialog "FFT squelch"
+ "Removes all energy below the squelch amount. This is sometimes useful for noise-reduction."))
+ (lambda (w c i)
+ (set! fft-squelch-amount initial-fft-squelch-amount)
+ ((*motif* 'XtSetValues) (list-ref sliders 0)
+ (list (*motif* 'XmNvalue) (round (* fft-squelch-amount 100)))))))))
+ (set! sliders
+ (add-sliders
+ fft-squelch-dialog
+ (list (list "squelch amount" 0.0 initial-fft-squelch-amount 1.0
+ (if (provided? 'snd-gtk)
+ (lambda (w data)
+ (set! fft-squelch-amount (/ ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)) 100)))
+ (lambda (w context info)
+ (set! fft-squelch-amount (/ ((*motif* '.value) info) 100))))
+ 100))))))
(activate-dialog fft-squelch-dialog))
-
- (set! fft-squelch-menu-label (add-to-menu fft-menu "FFT squelch" post-fft-squelch-dialog)))
-
- (set! fft-squelch-menu-label (add-to-menu fft-menu fft-squelch-label cp-fft-squelch)))
+ (set! fft-squelch-menu-label (add-to-menu fft-menu "FFT squelch" post-fft-squelch-dialog))))
+
(set! fft-list (cons (lambda ()
(let ((new-label (format #f "FFT squelch (~1,2F)" fft-squelch-amount)))
diff --git a/fmv.scm b/fmv.scm
index 17b8506..b3b9d5c 100644
--- a/fmv.scm
+++ b/fmv.scm
@@ -110,14 +110,14 @@ fm-violin takes the value returned by make-fm-violin and returns a new sample ea
(oscil carrier
(+ vib
(* (if ind-noi (+ 1.0 (rand-interp ind-noi)) 1.0)
- (if fmosc1
+ (if (not fmosc1)
+ 0.0
(if coeffs
(* (indf1)
(polynomial coeffs (oscil fmosc1 vib)))
(+ (* (indf1) (oscil fmosc1 (+ (* fm1-rat vib) fuzz)))
(* (indf2) (oscil fmosc2 (+ (* fm2-rat vib) fuzz)))
- (* (indf3) (oscil fmosc3 (+ (* fm3-rat vib) fuzz)))))
- 0.0)))))))))))
+ (* (indf3) (oscil fmosc3 (+ (* fm3-rat vib) fuzz))))))))))))))))
#|
(define test-v
diff --git a/freeverb.scm b/freeverb.scm
index 3f0dee6..dc9a809 100644
--- a/freeverb.scm
+++ b/freeverb.scm
@@ -83,7 +83,7 @@
(/ (- out-chans (* local-gain out-chans))
(- (* out-chans out-chans) out-chans))))
(if verbose
- (format #t ";;; freeverb: ~d input channels, ~d output channels~%" in-chans out-chans))
+ (format () ";;; freeverb: ~d input channels, ~d output channels~%" in-chans out-chans))
(if (and (> in-chans 1)
(not (= in-chans out-chans)))
(error "input must be mono or input channels must equal output channels"))
diff --git a/fullmix.scm b/fullmix.scm
index 78a89e1..03d757e 100644
--- a/fullmix.scm
+++ b/fullmix.scm
@@ -18,7 +18,7 @@
(in-chans (channels in-file))
(out-chans (channels *output*))
(reversed (or (and (number? srate) (negative? srate))
- (and (pair? srate) (negative? (cadr srate)))))
+ (and (pair? srate) (pair? (cdr srate)) (negative? (cadr srate)))))
(inloc (floor (* (or inbeg 0.0) (mus-sound-srate in-file)))))
@@ -38,9 +38,7 @@
(set! (rmx i 0) reverb-amount)) ; 0->assume 1 chan reverb stream, I think
rmx)))
- (file (if (or (not srate)
- (and (number? srate)
- (= srate 1.0)))
+ (file (if (memv srate '(#f 1 1.0))
(make-file->frample in-file)
(let ((vect (make-vector in-chans #f)))
(do ((i 0 (+ i 1)))
@@ -51,46 +49,44 @@
(srcenv (and (pair? srate)
(make-env srate :duration dur :scaler (if reversed -1.0 1.0)))))
- (if matrix
- (if (pair? matrix) ; matrix is list of scalers, envelopes (lists), or env gens
- (do ((inp 0 (+ inp 1))
- (off 0 (+ off out-chans)))
- ((= inp in-chans))
- (let ((inlist (list-ref matrix inp)))
- (do ((outp 0 (+ outp 1)))
- ((= outp out-chans))
- (let ((outn (list-ref inlist outp)))
- (if outn
- (if (number? outn)
- (set! (mx inp outp) outn)
- (if (or (env? outn)
- (pair? outn))
- (begin
- (if (not envs)
- (set! envs (make-vector (* in-chans out-chans) #f)))
- (if (env? outn)
- (vector-set! envs (+ off outp) outn)
- (vector-set! envs (+ off outp) (make-env outn :duration dur))))
- (format #t "unknown element in matrix: ~A" outn))))))))
- (do ((inp 0 (+ inp 1))) ; matrix is a number in this case (a global scaler)
- ((= inp in-chans))
- (if (< inp out-chans)
- (set! (mx inp inp) matrix)))))
+ (when matrix
+ (if (pair? matrix) ; matrix is list of scalers, envelopes (lists), or env gens
+ (do ((inp 0 (+ inp 1))
+ (off 0 (+ off out-chans)))
+ ((= inp in-chans))
+ (let ((inlist (list-ref matrix inp)))
+ (do ((outp 0 (+ outp 1)))
+ ((= outp out-chans))
+ (let ((outn (list-ref inlist outp)))
+ (if outn
+ (if (number? outn)
+ (set! (mx inp outp) outn)
+ (if (or (env? outn)
+ (pair? outn))
+ (begin
+ (if (not envs)
+ (set! envs (make-vector (* in-chans out-chans) #f)))
+ (vector-set! envs (+ off outp)
+ (if (env? outn)
+ outn
+ (make-env outn :duration dur))))
+ (format () "unknown element in matrix: ~A" outn))))))))
+ (do ((inp 0 (+ inp 1))) ; matrix is a number in this case (a global scaler)
+ ((= inp in-chans))
+ (if (< inp out-chans)
+ (set! (mx inp inp) matrix)))))
- (if (or (not srate)
- (and (number? srate)
- (= srate 1.0)))
+ (if (memv srate '(#f 1 1.0))
(let ((mxe (and envs
- (let ((v (make-vector in-chans)))
- (do ((i 0 (+ i 1))
- (off 0 (+ off out-chans)))
- ((= i in-chans))
- (let ((vo (make-vector out-chans #f)))
- (vector-set! v i vo)
- (do ((j 0 (+ j 1)))
- ((= j out-chans))
- (vector-set! vo j (vector-ref envs (+ off j))))))
- v))))
+ (do ((v (make-vector in-chans))
+ (i 0 (+ i 1))
+ (off 0 (+ off out-chans)))
+ ((= i in-chans) v)
+ (let ((vo (make-vector out-chans #f)))
+ (vector-set! v i vo)
+ (do ((j 0 (+ j 1)))
+ ((= j out-chans))
+ (vector-set! vo j (vector-ref envs (+ off j)))))))))
;; -------- no src
(mus-file-mix *output* file st samps inloc mx mxe)
(if rev-mx
diff --git a/generators.scm b/generators.scm
index c7d23d4..e95bcb3 100644
--- a/generators.scm
+++ b/generators.scm
@@ -75,39 +75,37 @@ similar to nxysin. (nssb gen (fm 0.0)) returns n sinusoids from frequency spaced
(define (find-nxysin-max n ratio)
- (define (ns x n)
- (let* ((a2 (/ x 2))
- (den (sin a2)))
- (if (= den 0.0)
- 0.0
- (/ (* (sin (* n a2)) (sin (* (+ 1 n) a2))) den))))
-
- (define (nodds x n)
- (let ((den (sin x))
- (num (sin (* n x))))
- (if (= den 0.0)
- 0.0
- (/ (* num num) den))))
-
(define (find-mid-max n lo hi)
- (let ((mid (/ (+ lo hi) 2)))
- (let ((ylo (ns lo n))
- (yhi (ns hi n)))
- (if (< (abs (- ylo yhi)) nearly-zero) ; was e-100 but that hangs if not using doubles
- (ns mid n)
- (if (> ylo yhi)
- (find-mid-max n lo mid)
- (find-mid-max n mid hi))))))
+ (define (ns x n)
+ (let* ((a2 (/ x 2))
+ (den (sin a2)))
+ (if (= den 0.0)
+ 0.0
+ (/ (* (sin (* n a2)) (sin (* (+ 1 n) a2))) den))))
+ (let ((mid (/ (+ lo hi) 2))
+ (ylo (ns lo n))
+ (yhi (ns hi n)))
+ (if (< (abs (- ylo yhi)) nearly-zero) ; was e-100 but that hangs if not using doubles
+ (ns mid n)
+ (find-mid-max n (if (> ylo yhi)
+ (values lo mid)
+ (values mid hi))))))
(define (find-nodds-mid-max n lo hi)
- (let ((mid (/ (+ lo hi) 2)))
- (let ((ylo (nodds lo n))
- (yhi (nodds hi n)))
- (if (< (abs (- ylo yhi)) nearly-zero)
- (nodds mid n)
- (if (> ylo yhi)
- (find-nodds-mid-max n lo mid)
- (find-nodds-mid-max n mid hi))))))
+ (define (nodds x n)
+ (let ((den (sin x))
+ (num (sin (* n x))))
+ (if (= den 0.0)
+ 0.0
+ (/ (* num num) den))))
+ (let ((mid (/ (+ lo hi) 2))
+ (ylo (nodds lo n))
+ (yhi (nodds hi n)))
+ (if (< (abs (- ylo yhi)) nearly-zero)
+ (nodds mid n)
+ (find-nodds-mid-max n (if (> ylo yhi)
+ (values lo mid)
+ (values mid hi))))))
(if (= ratio 1)
(find-mid-max n 0.0 (/ pi (+ n .5)))
@@ -327,26 +325,24 @@ returns n sines from frequency spaced by frequency * ratio with every other sine
;;; sndclm.html (G&R) first col 5th row (sum of odd sines)
-(define (find-noddsin-max n)
-
- (define (nodds x n)
- (let ((den (sin x))
- (num (sin (* n x))))
- (if (= den 0.0)
- 0.0
- (/ (* num num) den))))
-
- (define (find-mid-max n lo hi)
- (let ((mid (/ (+ lo hi) 2)))
- (let ((ylo (nodds lo n))
- (yhi (nodds hi n)))
- (if (< (abs (- ylo yhi)) 1e-9)
- (nodds mid n)
- (if (> ylo yhi)
- (find-mid-max n lo mid)
- (find-mid-max n mid hi))))))
-
- (find-mid-max n 0.0 (/ pi (+ (* 2 n) 0.5))))
+(define (find-noddsin-max n)
+ (let find-mid-max ((n n)
+ (lo 0.0000)
+ (hi (/ pi (+ (* 2 n) 0.5))))
+ (define (nodds x n)
+ (let ((den (sin x))
+ (num (sin (* n x))))
+ (if (= den 0.0)
+ 0.0000
+ (/ (* num num) den))))
+ (let ((mid (/ (+ lo hi) 2))
+ (ylo (nodds lo n))
+ (yhi (nodds hi n)))
+ (if (< (abs (- ylo yhi)) 1e-09)
+ (nodds mid n)
+ (find-mid-max n (if (> ylo yhi)
+ (values lo mid)
+ (values mid hi)))))))
(define noddsin-maxes (make-float-vector 100))
@@ -416,7 +412,7 @@ returns n odd-numbered cosines spaced by frequency."))
(den (* 2 n (sin angle)))) ; "n" here is normalization
(set! angle (+ angle fm frequency))
(if (< (abs den) nearly-zero)
- (let ((fang (modulo (abs cx) (* 2 pi))))
+ (let ((fang (modulo cx (* 2 pi))))
;; hopefully this almost never happens...
(if (or (< fang 0.001)
(< (abs (- fang (* 2 pi))) 0.001))
@@ -458,7 +454,7 @@ returns n sinusoids from frequency spaced by 2 * ratio * frequency."))
(den (* n (sin mx)))) ; "n" is normalization
(set! angle (+ angle fm frequency))
(if (< (abs den) nearly-zero)
- (if (< (modulo (abs mx) (* 2 pi)) .1)
+ (if (< (modulo mx (* 2 pi)) .1)
-1.0
1.0)
(- (* (sin x)
@@ -634,14 +630,13 @@ returns n cosines spaced by frequency. All are equal amplitude except the first
(define (find-nsin5-max n)
- (define (ns x n)
- (let* ((den (tan (* 0.5 x))))
- (if (< (abs den) nearly-zero)
- 0.0
- (/ (- 1.0 (cos (* n x)))
- den))))
-
(define (find-mid-max n lo hi)
+ (define (ns x n)
+ (let* ((den (tan (* 0.5 x))))
+ (if (< (abs den) nearly-zero)
+ 0.0
+ (/ (- 1.0 (cos (* n x)))
+ den))))
(let ((mid (/ (+ lo hi) 2)))
(let ((ylo (ns lo n))
(yhi (ns hi n)))
@@ -684,14 +679,13 @@ returns n sines spaced by frequency. All are equal amplitude except last at half
(define (find-nsin-max n)
- (define (ns x n)
- (let* ((a2 (/ x 2))
- (den (sin a2)))
- (if (= den 0.0)
- 0.0
- (/ (* (sin (* n a2)) (sin (* (+ 1 n) a2))) den))))
-
(define (find-mid-max n lo hi)
+ (define (ns x n)
+ (let* ((a2 (/ x 2))
+ (den (sin a2)))
+ (if (= den 0.0)
+ 0.0
+ (/ (* (sin (* n a2)) (sin (* (+ 1 n) a2))) den))))
(let ((mid (/ (+ lo hi) 2)))
(let ((ylo (ns lo n))
(yhi (ns hi n)))
@@ -719,7 +713,7 @@ returns n sines spaced by frequency. All are equal amplitude except last at half
((= i 20000))
(outa i (nsin5 gen))))))
(snd (find-sound res)))
- (format #t ";~D: ~A" i (maxamp snd 0))
+ (format () ";~D: ~A" i (maxamp snd 0))
(set! norms (cons (maxamp snd 0) norms))))
(reverse norms))
@@ -1449,9 +1443,7 @@ returns n cosines spaced by frequency."))
(set! (g 'rr-1) (- 1.0 (g 'rr)))
(set! (g 'r2) (* 2.0 (g 'r)))
(let ((absr (abs (g 'r))))
- (if (< absr nearly-zero)
- (set! (g 'norm) 0.0)
- (set! (g 'norm) (/ (- 1.0 absr) (* 2.0 absr)))))
+ (set! (g 'norm) (if (< absr nearly-zero) 0.0 (/ (- 1.0 absr) (* 2.0 absr)))))
val)))
(cons 'mus-phase
@@ -1468,9 +1460,7 @@ returns n cosines spaced by frequency."))
(set! (g 'rr-1) (- 1.0 (g 'rr)))
(set! (g 'r2) (* 2.0 (g 'r)))
(let ((absr (abs (g 'r))))
- (if (< absr nearly-zero)
- (set! (g 'norm) 0.0)
- (set! (g 'norm) (/ (- 1.0 absr) (* 2.0 absr)))))
+ (set! (g 'norm) (if (< absr nearly-zero) 0.0 (/ (- 1.0 absr) (* 2.0 absr)))))
g)
:methods rcos-methods)
(frequency *clm-default-frequency*) (r 0.5) fm
@@ -1908,9 +1898,7 @@ returns many cosines from frequency spaced by frequency * ratio with amplitude r
(if (not (= fm 0.0)) ;(set! r (clamp-rxycos-r (curlet) fm))
(let ((maxr (expt cutoff (/ (floor (- (/ two-pi (* 3 ratio (+ fm frequency))) (/ ratio)))))))
- (if (>= r 0.0)
- (set! r (min r maxr))
- (set! r (max r (- maxr))))))
+ (set! r (if (>= r 0.0) (min r maxr) (max r (- maxr))))))
(* (/ (- (cos x)
(* r (cos (- x y))))
@@ -3145,7 +3133,7 @@ returns many sines spaced by frequency with amplitude kr^k."))
(do ((i 0 (+ i 1)))
((= i 10000))
(outa i (krksin gen))))))))
- (format #t ";~A: ~A" (* 0.1 i) mx)))
+ (format () ";~A: ~A" (* 0.1 i) mx)))
;;; relation between 1/(1-x)^2 and peak amp:
(with-sound (:clipped #f)
@@ -3318,11 +3306,9 @@ returns many sines spaced by frequency with amplitude (-a+sqrt(a^2-b^2))^k/b^k."
(define (r2k2cos-norm a)
;; J 124
- (- (* (/ pi (* 2 a))
- (/ (cosh (* pi a))
- (sinh (* pi a))))
- (/ 1.0
- (* 2 a a))))
+ (- (/ (* pi (cosh (* pi a)))
+ (* 2 a (sinh (* pi a))))
+ (/ 1.0 (* 2 a a))))
(define r2k2cos
@@ -3465,7 +3451,7 @@ returns many cosines spaced by frequency with amplitude 1/(r^2+k^2)."))
((= i 1000))
(outa i (asymmetric-fm gen index))))))))
(if (> (abs (- peak 1.0)) .1)
- (format #t ";asymmetric-fm peak: ~A, index: ~A, r: ~A" peak index r))))
+ (format () ";asymmetric-fm peak: ~A, index: ~A, r: ~A" peak index r))))
(list -10.0 -1.5 -0.5 0.5 1.0 1.5 10.0)))
(list 1.0 3.0 10.0))
|#
@@ -3503,10 +3489,10 @@ returns many cosines spaced by frequency with amplitude 1/(r^2+k^2)."))
(defgenerator (bess
:make-wrapper (lambda (g)
(set! (g 'frequency) (hz->radians (g 'frequency)))
- (if (>= (g 'n) (length bessel-peaks))
- (set! (g 'norm) (/ 0.67 (expt (g 'n) 1/3)))
- ;; this formula comes from V P Krainov, "Selected Mathetical Methods in Theoretical Physics"
- (set! (g 'norm) (bessel-peaks (g 'n))))
+ (set! (g 'norm) (if (>= (g 'n) (length bessel-peaks))
+ (/ 0.67 (expt (g 'n) 1/3))
+ ;; this formula comes from V P Krainov, "Selected Mathetical Methods in Theoretical Physics"
+ (bessel-peaks (g 'n))))
g))
(frequency *clm-default-frequency*) (n 0) (angle 0.0) (norm 1.0) fm)
@@ -3545,7 +3531,7 @@ returns many cosines spaced by frequency with amplitude 1/(r^2+k^2)."))
(let ((val (bes-jn i k)))
(if (> (abs val) mx)
(set! mx (abs val)))))
- (format #t ";~A" (+ mx .001))))
+ (format () ";~A" (+ mx .001))))
(with-sound (:clipped #f :statistics #t :play #t)
(let ((gen1 (make-bess 400.0 :n 1))
@@ -3594,7 +3580,7 @@ returns a sum of cosines scaled by a product of Bessel functions."))
(set! angle (+ angle fm frequency))
(/ (- (bes-j0 (* k (sqrt (+ (* r r)
(* a a)
- (* a (* -2.0 r (cos x)))))))
+ (* a -2.0 r (cos x))))))
dc) ; get rid of DC component
norm))))))
@@ -3733,7 +3719,7 @@ index 10 (so 10/2 is the bes-jn arg):
(let ((base (* (bes-jn 4 5.0) (bes-jn 4 5.0)))) ; max (fft norms -> 1.0)
(do ((i 1 (+ i 1)))
((= i 11))
- (format #t ";~A: ~A ~A" i (* (bes-jn i 5.0) (bes-jn i 5.0)) (/ (* (bes-jn i 5.0) (bes-jn i 5.0)) base))))
+ (format () ";~A: ~A ~A" i (* (bes-jn i 5.0) (bes-jn i 5.0)) (/ (* (bes-jn i 5.0) (bes-jn i 5.0)) base))))
;1: 0.107308091385168 0.701072497819036
;2: 0.00216831005396058 0.0141661502497507
;3: 0.133101826831083 0.86958987897572
@@ -3889,7 +3875,7 @@ returns a sum of cosines scaled in a very complicated way."))
;; and in this context, we get -1..1 peak amps from the sin anyway.
(arg (+ (* r r)
(* a a)
- (* a (* -2.0 r (cos x))))))
+ (* a -2.0 r (cos x)))))
(set! angle (+ angle fm frequency))
(if (< (abs arg) nearly-zero) ; r = a, darn it! This will produce a spike, but at least it's not a NaN
1.0
@@ -3960,7 +3946,7 @@ returns a sum of cosines scaled in a very complicated way."))
(lambda* (gen (fm 0.0))
(let-set! gen 'fm fm)
(with-let gen
- (let ((arg (sqrt (+ ra (* a (* -2.0 r (cos angle)))))))
+ (let ((arg (sqrt (+ ra (* a -2.0 r (cos angle))))))
(set! angle (+ angle fm frequency))
(if (< arg nearly-zero)
1.0
@@ -4038,7 +4024,7 @@ returns a sum of cosines scaled in a very complicated way."))
(do ((i 0 (+ i 1)))
((= i 10000))
(outa i (j0j1cos gen))))))))
- (format #t ";~A: ~A" i pk)))
+ (format () ";~A: ~A" i pk)))
;0: 0.0
;1: 0.555559098720551
;2: 0.938335597515106
@@ -4076,9 +4062,9 @@ returns a sum of cosines scaled in a very complicated way."))
(let ((a (g 'a)) ; "c"
(r (g 'r))); "b"
(if (<= r a)
- (format #t ";jycos a: ~A must be < r: ~A" a r))
+ (format () ";jycos a: ~A must be < r: ~A" a r))
(if (<= (+ (* a a) (* r r)) (* 2 a r))
- (format #t ";jycos a: ~A, r: ~A will cause bes-y0 to return -inf!" a r)))
+ (format () ";jycos a: ~A, r: ~A will cause bes-y0 to return -inf!" a r)))
g))
(frequency *clm-default-frequency*) (r 1.0) (a 0.5) ; "b" and "c" in the docs
(angle 0.0) fm)
@@ -4998,18 +4984,16 @@ generator. (round-interp gen (fm 0.0)) returns a rand-interp sequence low-pass f
(define (sine-env e)
(env-any e (lambda (y)
- (* 0.5 (+ 1.0 (sin (+ (* -0.5 pi)
- (* pi y))))))))
+ (* 0.5 (+ 1.0 (sin (* pi (- y 0.5))))))))
(define (square-env e)
(env-any e (lambda (y)
(* y y))))
(define (blackman4-env e)
- (env-any e
- (lambda (y)
- (let ((cx (cos (* pi y))))
- (+ 0.084037 (* cx (+ -.29145 (* cx (+ .375696 (* cx (+ -.20762 (* cx .041194))))))))))))
+ (env-any e (lambda (y)
+ (let ((cx (cos (* pi y))))
+ (+ 0.084037 (* cx (- (* cx (+ 0.375696 (* cx (- (* cx 0.041194) 0.20762)))) 0.29145)))))))
(define (multi-expt-env e expts)
(env-any e (lambda (y)
@@ -5037,7 +5021,7 @@ generator. (round-interp gen (fm 0.0)) returns a rand-interp sequence low-pass f
(val1 (oscil gen1 0.0 pm))
(val2 (run-with-fm-and-pm gen2 0.0 pm)))
(if (fneq val1 val2)
- (format #t ";run-with-fm-and-pm: ~A ~A" val1 val2)))))
+ (format () ";run-with-fm-and-pm: ~A ~A" val1 val2)))))
|#
@@ -5468,13 +5452,13 @@ returns the sum of the absolute values in a moving window over the last n inputs
(defgenerator (moving-variance
:make-wrapper (lambda (g)
- (let ((g1 (make-moving-average (g 'n)))
- (g2 (make-moving-average (g 'n))))
+ (let ((g1 (make-moving-average (g 'n))))
(set! (g 'gen1) g1)
- (set! (mus-increment g1) 1.0)
+ (set! (mus-increment g1) 1.0))
+ (let ((g2 (make-moving-average (g 'n))))
(set! (g 'gen2) g2)
- (set! (mus-increment g2) 1.0)
- g)))
+ (set! (mus-increment g2) 1.0))
+ g))
(n 128) (gen1 #f) (gen2 #f) y)
@@ -5542,17 +5526,19 @@ the rms of the values in a window over the last n inputs."))
g)))
(n 128) (gen #f) y)
-
+(define moving-length moving-rms)
+#|
(define moving-length
(let ((documentation "(make-moving-length (n 128) returns a moving-length generator. (moving-length gen input)
returns the length of the values in a window over the last few inputs."))
(lambda (gen y)
+ (moving-rms gen y))))
(let-set! gen 'y y)
(with-let gen
(sqrt (max 0.0 (moving-average gen (* y y))))))))
-
+|#
#|
(let ((ml (make-moving-length 128))
@@ -5592,9 +5578,9 @@ returns the length of the values in a window over the last few inputs."))
(let ((n (g 'n)))
(let ((dly (make-moving-average n)))
(set! (mus-increment dly) 1.0)
- (set! (g 'dly) dly)
- (set! (g 'den) (* 0.5 (+ n 1) n))
- g))))
+ (set! (g 'dly) dly))
+ (set! (g 'den) (* 0.5 (+ n 1) n)))
+ g))
(n 128) (dly #f) (num 0.0) (sum 0.0) y den)
@@ -5871,59 +5857,51 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
((even) (set! (amps j) (max 1 (* 2 (- i 1))))))
(set! (amps (+ j 1)) (/ 1.0 n))
-
- (if (vector? phases)
- (set! (amps (+ j 2)) (phases (- i 1)))
- (if (not phases)
- (set! (amps (+ j 2)) (random (* 2 pi)))
- (if (eq? phases 'max-peak)
- (set! (amps (+ j 2)) (/ pi 2))
- ;; else min-peak, handled below
- ))))
-
- (if (eq? phases 'min-peak)
- (let ((vector-find-if (lambda (func vect)
- (let ((len (length vect))
- (result #f))
- (do ((i 0 (+ i 1)))
- ((or (= i len)
- result)
- result)
- (set! result (func (vect i))))))))
-
- (if (not (defined? 'noid-min-peak-phases))
- (load "peak-phases.scm"))
-
- (let ((min-dat (vector-find-if
- (lambda (val)
- (and val
- (vector? val)
- (= (val 0) n)
- (let* ((a-val (val 1))
- (a-len (length val))
- (a-data (list a-val (val 2))))
- (do ((k 2 (+ k 1)))
- ((= k a-len))
- (if (and (number? (val k))
- (< (val k) a-val))
- (begin
- (set! a-val (val k))
- (set! a-data (list a-val (val (+ k 1)))))))
- a-data)))
- (case choice
- ((all) noid-min-peak-phases)
- ((odd) nodd-min-peak-phases)
- ((prime) primoid-min-peak-phases)
- ((even) neven-min-peak-phases)))))
- (if min-dat
- (let (;(norm (car min-dat))
- (rats (cadr min-dat)))
- (do ((i 1 (+ i 1))
- (j 0 (+ j 3)))
- ((> i n))
- (set! (amps (+ j 1)) (/ 1.0 n)) ;(/ 0.999 norm)) -- can't decide about this -- I guess it should be consistent with the #f case
- (set! (amps (+ j 2)) (* pi (rats (- i 1))))))))))
+ (cond ((vector? phases) (set! (amps (+ j 2)) (phases (- i 1))))
+ ((not phases) (set! (amps (+ j 2)) (random (* 2 pi))))
+ ((eq? phases 'max-peak) (set! (amps (+ j 2)) (/ pi 2)))))
+ (when (eq? phases 'min-peak)
+ (let ((vector-find-if (lambda (func vect)
+ (let ((len (length vect))
+ (result #f))
+ (do ((i 0 (+ i 1)))
+ ((or (= i len)
+ result)
+ result)
+ (set! result (func (vect i))))))))
+
+ (if (not (defined? 'noid-min-peak-phases))
+ (load "peak-phases.scm"))
+
+ (let ((min-dat (vector-find-if
+ (lambda (val)
+ (and val
+ (vector? val)
+ (= (val 0) n)
+ (let* ((a-val (val 1))
+ (a-len (length val))
+ (a-data (list a-val (val 2))))
+ (do ((k 2 (+ k 1)))
+ ((= k a-len))
+ (if (and (number? (val k))
+ (< (val k) a-val))
+ (begin
+ (set! a-val (val k))
+ (set! a-data (list a-val (val (+ k 1)))))))
+ a-data)))
+ (case choice
+ ((all) noid-min-peak-phases)
+ ((odd) nodd-min-peak-phases)
+ ((prime) primoid-min-peak-phases)
+ ((even) neven-min-peak-phases)))))
+ (if min-dat
+ (do ((rats (cadr min-dat))
+ (i 1 (+ i 1))
+ (j 0 (+ j 3)))
+ ((> i n))
+ (set! (amps (+ j 1)) (/ 1.0 n)) ;(/ 0.999 norm)) -- can't decide about this -- I guess it should be consistent with the #f case
+ (set! (amps (+ j 2)) (* pi (rats (- i 1)))))))))
amps)))
(define noid polyoid)
@@ -6161,12 +6139,11 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
(partials '(1 1))
wave
(size *clm-table-size*)) ; size arg is for backwards compatibility
- (if (not wave)
- (make-polyshape frequency :partials partials)
- (make-polyshape frequency :coeffs wave)))
+ (make-polyshape frequency (if wave
+ (values :coeffs wave)
+ (values :partials partials))))
-(define* (partials->waveshape partials
- (size *clm-table-size*))
+(define* (partials->waveshape partials (size *clm-table-size*))
(partials->polynomial partials))
@@ -6299,61 +6276,60 @@ The magnitudes are available as mus-xcoeffs, the phases as mus-ycoeffs, and the
(define (moving-spectrum gen)
(with-let gen
- (let ((n2 (/ n 2)))
- (if (>= outctr hop)
+ (when (>= outctr hop)
+ (if (> outctr n) ; must be first time through -- fill data array
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (float-vector-set! data i (readin input)))
(begin
- (if (> outctr n) ; must be first time through -- fill data array
- (do ((i 0 (+ i 1)))
- ((= i n))
- (float-vector-set! data i (readin input)))
- (begin
- (float-vector-move! data 0 hop)
- (do ((i (- n hop) (+ i 1)))
- ((= i n))
- (float-vector-set! data i (readin input)))))
-
- (set! outctr 0) ; -1??
- (set! dataloc (modulo dataloc n))
-
- (fill! new-freq-incs 0.0)
- (do ((i 0 (+ i 1))
- (j dataloc (+ j 1)))
- ((= j n))
- (float-vector-set! amp-incs j (* (float-vector-ref fft-window i) (float-vector-ref data i))))
-
- (if (> dataloc 0)
- (do ((i (- n dataloc) (+ i 1))
- (j 0 (+ j 1)))
- ((= j dataloc))
- (float-vector-set! amp-incs j (* (float-vector-ref fft-window i) (float-vector-ref data i)))))
-
- (set! dataloc (+ dataloc hop))
-
- (mus-fft amp-incs new-freq-incs n 1)
- (rectangular->polar amp-incs new-freq-incs)
-
- (let ((scl (/ 1.0 hop))
- (kscl (/ two-pi n)))
- (float-vector-subtract! amp-incs amps)
- (float-vector-scale! amp-incs scl)
-
- (do ((i 0 (+ i 1))
- (ks 0.0 (+ ks kscl)))
- ((= i n2))
- (let ((diff (modulo (- (new-freq-incs i) (freq-incs i)) two-pi)))
- (set! (freq-incs i) (new-freq-incs i))
- (if (> diff pi) (set! diff (- diff (* 2 pi))))
- (if (< diff (- pi)) (set! diff (+ diff (* 2 pi))))
- (set! (new-freq-incs i) (+ (* diff scl) ks))))
-
- (float-vector-subtract! new-freq-incs freqs)
- (float-vector-scale! new-freq-incs scl))))
+ (float-vector-move! data 0 hop)
+ (do ((i (- n hop) (+ i 1)))
+ ((= i n))
+ (float-vector-set! data i (readin input)))))
+
+ (set! outctr 0) ; -1??
+ (set! dataloc (modulo dataloc n))
+
+ (fill! new-freq-incs 0.0)
+ (do ((i 0 (+ i 1))
+ (j dataloc (+ j 1)))
+ ((= j n))
+ (float-vector-set! amp-incs j (* (float-vector-ref fft-window i) (float-vector-ref data i))))
+
+ (if (> dataloc 0)
+ (do ((i (- n dataloc) (+ i 1))
+ (j 0 (+ j 1)))
+ ((= j dataloc))
+ (float-vector-set! amp-incs j (* (float-vector-ref fft-window i) (float-vector-ref data i)))))
+
+ (set! dataloc (+ dataloc hop))
- (set! outctr (+ outctr 1))
+ (mus-fft amp-incs new-freq-incs n 1)
+ (rectangular->polar amp-incs new-freq-incs)
- (float-vector-add! amps amp-incs)
- (float-vector-add! freqs new-freq-incs)
- (float-vector-add! phases freqs))))
+ (let ((scl (/ 1.0 hop))
+ (kscl (/ two-pi n)))
+ (float-vector-subtract! amp-incs amps)
+ (float-vector-scale! amp-incs scl)
+
+ (do ((n2 (/ n 2))
+ (i 0 (+ i 1))
+ (ks 0.0 (+ ks kscl)))
+ ((= i n2))
+ (let ((diff (modulo (- (new-freq-incs i) (freq-incs i)) two-pi)))
+ (set! (freq-incs i) (new-freq-incs i))
+ (if (> diff pi) (set! diff (- diff (* 2 pi))))
+ (if (< diff (- pi)) (set! diff (+ diff (* 2 pi))))
+ (set! (new-freq-incs i) (+ (* diff scl) ks))))
+
+ (float-vector-subtract! new-freq-incs freqs)
+ (float-vector-scale! new-freq-incs scl)))
+
+ (set! outctr (+ outctr 1))
+
+ (float-vector-add! amps amp-incs)
+ (float-vector-add! freqs new-freq-incs)
+ (float-vector-add! phases freqs)))
(define (test-sv)
@@ -6489,7 +6465,7 @@ The magnitudes are available as mus-xcoeffs, the phases as mus-ycoeffs, and the
(let ((val (moving-scentroid scn (data i))))
(if (= (modulo j (scn 'hop)) 0)
(begin
- (format #t "[~A ~A]~%" val (vals k))
+ (format () "[~A ~A]~%" val (vals k))
(set! k (+ k 1)))))))
(set! *clm-srate* old-srate)))
|#
@@ -6605,7 +6581,7 @@ input from the readin generator 'reader'. The output data is available via mus-
(set! last-pitch pitch)
(set! pitch (moving-pitch scn))
(if (not (= last-pitch pitch))
- (format #t "~A: ~A~%" (* 1.0 (/ i cur-srate)) pitch))))
+ (format () "~A: ~A~%" (* 1.0 (/ i cur-srate)) pitch))))
(set! *clm-srate* old-srate))
|#
diff --git a/gl.c b/gl.c
index 8cc8f7e..77303d0 100644
--- a/gl.c
+++ b/gl.c
@@ -4455,15 +4455,13 @@ static void define_functions(void)
{
#if HAVE_SCHEME
static s7_pointer s_boolean, s_integer, s_real, s_any;
-static s7_pointer pl_tb, pl_t, pl_bt, pl_tttti, pl_ttttb, pl_ttri, pl_ttit, pl_ttr, pl_ttir, pl_ttb, pl_tti, pl_ttiti, pl_ttrriir, pl_ttititiiti, pl_ttititi, pl_ttrri, pl_ttrrri, pl_iiiiitiiit, pl_iiiiiiiit, pl_iiiiiiiiiiit, pl_iiiiiiit, pl_iiiiiiiiiit, pl_iiiiiit, pl_iiiiiiiiit, pl_irrrt, pl_irrrrtttrrt, pl_i, pl_bit, pl_bi, pl_ittit, pl_tiirrrrt, pl_tiiiit, pl_tiiit, pl_tiiiiiiit, pl_tiiiiiiiit, pl_tirriit, pl_tirriirriit, pl_tirrir, pl_tir, pl_tit, pl_tiiiiiiiiit, pl_tiiiiiiiiiit, pl_tiiib, pl_ti, pl_tiiiiiit, pl_tiir, pl_tiiiiit, pl_tiit, pl_tibiit, pl_tiib, pl_trrrrt, pl_tr, pl_unused;
+static s7_pointer pl_t, pl_tttti, pl_ttttb, pl_ttri, pl_ttit, pl_ttr, pl_ttir, pl_ttb, pl_tti, pl_ttiti, pl_ttrriir, pl_ttititiiti, pl_ttititi, pl_ttrri, pl_ttrrri, pl_tb, pl_bt, pl_iiiiitiiit, pl_iiiiiiiit, pl_iiiiiiiiiiit, pl_iiiiiiit, pl_iiiiiiiiiit, pl_iiiiiit, pl_iiiiiiiiit, pl_irrrt, pl_irrrrtttrrt, pl_i, pl_ittit, pl_tiirrrrt, pl_tiiiit, pl_tiiit, pl_tiiiiiiit, pl_tiiiiiiiit, pl_tirriit, pl_tirriirriit, pl_tirrir, pl_tir, pl_tit, pl_tiiiiiiiiit, pl_tiiiiiiiiiit, pl_tiiib, pl_ti, pl_tiiiiiit, pl_tiir, pl_tiiiiit, pl_tiit, pl_tibiit, pl_tiib, pl_trrrrt, pl_tr, pl_bit, pl_bi, pl_unused;
s_boolean = s7_make_symbol(s7, "boolean?");
s_integer = s7_make_symbol(s7, "integer?");
s_real = s7_make_symbol(s7, "real?");
s_any = s7_t(s7);
- pl_tb = s7_make_circular_signature(s7, 1, 2, s_any, s_boolean);
pl_t = s7_make_circular_signature(s7, 0, 1, s_any);
- pl_bt = s7_make_circular_signature(s7, 1, 2, s_boolean, s_any);
pl_tttti = s7_make_circular_signature(s7, 4, 5, s_any, s_any, s_any, s_any, s_integer);
pl_ttttb = s7_make_circular_signature(s7, 4, 5, s_any, s_any, s_any, s_any, s_boolean);
pl_ttri = s7_make_circular_signature(s7, 3, 4, s_any, s_any, s_real, s_integer);
@@ -4478,6 +4476,8 @@ static s7_pointer pl_tb, pl_t, pl_bt, pl_tttti, pl_ttttb, pl_ttri, pl_ttit, pl_t
pl_ttititi = s7_make_circular_signature(s7, 6, 7, s_any, s_any, s_integer, s_any, s_integer, s_any, s_integer);
pl_ttrri = s7_make_circular_signature(s7, 4, 5, s_any, s_any, s_real, s_real, s_integer);
pl_ttrrri = s7_make_circular_signature(s7, 5, 6, s_any, s_any, s_real, s_real, s_real, s_integer);
+ pl_tb = s7_make_circular_signature(s7, 1, 2, s_any, s_boolean);
+ pl_bt = s7_make_circular_signature(s7, 1, 2, s_boolean, s_any);
pl_iiiiitiiit = s7_make_circular_signature(s7, 9, 10, s_integer, s_integer, s_integer, s_integer, s_integer, s_any, s_integer, s_integer, s_integer, s_any);
pl_iiiiiiiit = s7_make_circular_signature(s7, 8, 9, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_any);
pl_iiiiiiiiiiit = s7_make_circular_signature(s7, 11, 12, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_integer, s_any);
@@ -4488,8 +4488,6 @@ static s7_pointer pl_tb, pl_t, pl_bt, pl_tttti, pl_ttttb, pl_ttri, pl_ttit, pl_t
pl_irrrt = s7_make_circular_signature(s7, 4, 5, s_integer, s_real, s_real, s_real, s_any);
pl_irrrrtttrrt = s7_make_circular_signature(s7, 10, 11, s_integer, s_real, s_real, s_real, s_real, s_any, s_any, s_any, s_real, s_real, s_any);
pl_i = s7_make_circular_signature(s7, 0, 1, s_integer);
- pl_bit = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_any);
- pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer);
pl_ittit = s7_make_circular_signature(s7, 4, 5, s_integer, s_any, s_any, s_integer, s_any);
pl_tiirrrrt = s7_make_circular_signature(s7, 7, 8, s_any, s_integer, s_integer, s_real, s_real, s_real, s_real, s_any);
pl_tiiiit = s7_make_circular_signature(s7, 5, 6, s_any, s_integer, s_integer, s_integer, s_integer, s_any);
@@ -4513,6 +4511,8 @@ static s7_pointer pl_tb, pl_t, pl_bt, pl_tttti, pl_ttttb, pl_ttri, pl_ttit, pl_t
pl_tiib = s7_make_circular_signature(s7, 3, 4, s_any, s_integer, s_integer, s_boolean);
pl_trrrrt = s7_make_circular_signature(s7, 5, 6, s_any, s_real, s_real, s_real, s_real, s_any);
pl_tr = s7_make_circular_signature(s7, 1, 2, s_any, s_real);
+ pl_bit = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_any);
+ pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer);
pl_unused = NULL;
#endif
@@ -5721,7 +5721,7 @@ void Init_libgl(void)
define_integers();
define_functions();
Xen_provide_feature("gl");
- Xen_define("gl-version", C_string_to_Xen_string("26-Nov-15"));
+ Xen_define("gl-version", C_string_to_Xen_string("05-May-16"));
gl_already_inited = true;
}
}
diff --git a/grani.scm b/grani.scm
index d69e106..5b61db6 100644
--- a/grani.scm
+++ b/grani.scm
@@ -2,9 +2,6 @@
;;; ENVELOPES (env.scm)
;;; *************************
-(when (provided? 'pure-s7)
- (define-macro (call-with-values producer consumer) `(,consumer (,producer))))
-
;;;=============================================================================
;;; Exponential envelopes
@@ -50,67 +47,65 @@
(out-scaler (* 1.0 out-scaler))
(ycutoff (and cutoff (expt base (+ offset (* cutoff scaler)))))
(result ()))
+
;; linear interpolation
- (letrec ((interpolate (lambda (xl yl xh yh xi) (+ yl (* (- xi xl) (/ (- yh yl) (- xh xl))))))
- ;;
- ;; recursively render one segment
- ;; xl,xh = x coordinates of segment ends
- ;; yl,yh = y coordinates of segment ends
- ;; yle,yhe = exponential values of y coords of segment ends
- ;; error = linear domain error bound for rendering
- ;;
- (exp-seg (lambda (xl yle xh yhe yl yh error)
- (let* ((xint (/ (+ xl xh) 2.0))
- (yint (interpolate xl yl xh yh xint))
- (yinte (interpolate xl yle xh yhe xint))
- (yexp (expt base yint))
- (yerr (- (expt base (+ yint error)) yexp)))
- ;; is the linear approximation accurate enough?
- ;; are we still over the cutoff limit?
- (if (and (> (abs (- yexp yinte)) yerr)
- (or (not ycutoff) (> yinte ycutoff)))
- ;; no --> add a breakpoint and recurse right and left
- (call-with-values
- (lambda () (exp-seg xl yle xint yexp yl yint error))
- (lambda (xi yi)
- (call-with-values
- (lambda () (exp-seg xint yexp xh yhe yint yh error))
- (lambda (xj yj)
- (values (append xi (list xint) xj)
- (append yi (list yexp) yj))))))
- ;; yes --> don't need to add nu'ting to the envelope
- (values () ()))))))
- ;; loop for each segment in the envelope
- (let segs ((en env1))
- (let* ((x (car en))
- (y (* 1.0 (cadr en)))
- (nx (caddr en))
- (ny (* 1.0 (cadddr en)))
- (yscl (+ offset (* y scaler)))
- (nyscl (+ offset (* ny scaler)))
- (xy (list x (if (or (not ycutoff)
- (>= (expt base yscl) ycutoff))
- (* out-scaler (expt base yscl))
- 0.0))))
- (set! result (append result xy))
- (call-with-values
- (lambda () (exp-seg x (expt base yscl) nx (expt base nyscl) yscl nyscl error))
- (lambda (xs ys)
- (if (pair? ys)
- (let ((ys-scaled (map (lambda (y) (* y out-scaler)) ys)))
- (let vals ((xx xs)
- (yy ys-scaled))
- (let ((x (car xx))
- (y (car yy)))
- (set! result (append result (list x y)))
- (if (> (length xx) 1)
- (vals (cdr xx) (cdr yy)))))))))
- (if (<= (length en) 4)
- (append result (list nx (if (or (not ycutoff)
- (>= (expt base nyscl) ycutoff))
- (* out-scaler (expt base nyscl))
- 0.0)))
- (segs (cddr en))))))))
+ (define (interpolate xl yl xh yh xi)
+ (+ yl (* (- xi xl) (/ (- yh yl) (- xh xl)))))
+
+ ;; recursively render one segment
+ ;; xl,xh = x coordinates of segment ends
+ ;; yl,yh = y coordinates of segment ends
+ ;; yle,yhe = exponential values of y coords of segment ends
+ ;; error = linear domain error bound for rendering
+ (define (exp-seg xl yle xh yhe yl yh error)
+ (let* ((xint (/ (+ xl xh) 2.0))
+ (yint (interpolate xl yl xh yh xint))
+ (yinte (interpolate xl yle xh yhe xint))
+ (yexp (expt base yint))
+ (yerr (- (expt base (+ yint error)) yexp)))
+ ;; is the linear approximation accurate enough?
+ ;; are we still over the cutoff limit?
+ (if (not (and (> (abs (- yexp yinte)) yerr)
+ (or (not ycutoff)
+ (> yinte ycutoff))))
+ ;; yes --> don't need to add nu'ting to the envelope
+ (values () ())
+ ;; no --> add a breakpoint and recurse right and left
+ ((lambda (xi yi xj yj)
+ (values (append xi (list xint) xj)
+ (append yi (list yexp) yj)))
+ (exp-seg xl yle xint yexp yl yint error)
+ (exp-seg xint yexp xh yhe yint yh error)))))
+
+ ;; loop for each segment in the envelope
+ (let segs ((en env1))
+ (let* ((x (car en))
+ (y (* 1.0 (cadr en)))
+ (nx (caddr en))
+ (ny (* 1.0 (cadddr en)))
+ (yscl (+ offset (* y scaler)))
+ (nyscl (+ offset (* ny scaler)))
+ (xy (list x (if (or (not ycutoff)
+ (>= (expt base yscl) ycutoff))
+ (* out-scaler (expt base yscl))
+ 0.0))))
+ (set! result (append result xy))
+ ((lambda (xs ys)
+ (if (pair? ys)
+ (let vals ((xx xs)
+ (yy (map (lambda (y) (* y out-scaler)) ys)))
+ (let ((x (car xx))
+ (y (car yy)))
+ (set! result (append result (list x y)))
+ (if (pair? (cdr xx))
+ (vals (cdr xx) (cdr yy)))))))
+ (exp-seg x (expt base yscl) nx (expt base nyscl) yscl nyscl error))
+ (if (<= (length en) 4)
+ (append result (list nx (if (or (not ycutoff)
+ (>= (expt base nyscl) ycutoff))
+ (* out-scaler (expt base nyscl))
+ 0.0)))
+ (segs (cddr en)))))))
;;; Amplitude envelope in dBs
;;;
@@ -475,124 +470,122 @@
(and (not (zero? grains))
(>= grain-counter grains)))
(set! happy #f))))
- (if happy
- (begin
- ;; back to the beginning of the grain
- ;(set! gr-offset 0)
- ;; start of grain in samples from beginning of note
- (set! gr-from-beg (floor (- gr-start-sample beg)))
- ;; reset out-time dependent envelopes to current time
- (set! (mus-location amp-env) gr-from-beg)
- (set! (mus-location gr-dur) gr-from-beg)
- (set! (mus-location gr-dur-spread) gr-from-beg)
- (set! (mus-location sr-env) gr-from-beg)
- (set! (mus-location sr-spread-env) gr-from-beg)
- (set! (mus-location gr-start) gr-from-beg)
- (set! (mus-location gr-start-spread) gr-from-beg)
- (set! (mus-location gr-dens-env) gr-from-beg)
- (set! (mus-location gr-dens-spread-env) gr-from-beg)
- ;; start of grain in input file
- (set! in-start-value (+ (* (env gr-start) gr-start-scaler)
- (mus-random (* 0.5 (env gr-start-spread)
- gr-start-scaler))))
- (set! in-start (floor (* in-start-value in-file-sr)))
- ;; duration in seconds of the grain
- (set! gr-duration (max grain-duration-limit
- (+ (env gr-dur)
- (mus-random (* 0.5 (env gr-dur-spread))))))
- ;; number of samples in the grain
- (set! gr-samples (floor (* gr-duration *clm-srate*)))
- ;; new sample rate for grain
- (set! gr-srate (if srate-linear
- (+ (env sr-env)
- (mus-random (* 0.5 (env sr-spread-env))))
- (* (env sr-env)
- (expt srate-base
- (mus-random (* 0.5 (env sr-spread-env)))))))
- ;; set new sampling rate conversion factor
- (set! (mus-increment in-file-reader) gr-srate)
- ;; number of samples in input
- (set! in-samples (floor (* gr-samples srate-ratio)))
-
- ;; check for out of bounds condition in in-file pointers
- (if (> (+ in-start in-samples) last-in-sample)
- (set! in-start (- last-in-sample in-samples))
- (if (< in-start 0)
- (set! in-start 0)))
- ;; reset position of input file reader
- (set! (mus-location rd) in-start)
-
- ;; restart grain envelopes
- (set! (mus-phase gr-env) 0.0)
- (set! (mus-phase gr-env-end) 0.0)
- ;; reset grain envelope durations
- (set! (mus-frequency gr-env) (/ gr-duration))
- (set! (mus-frequency gr-env-end) (/ gr-duration))
- ;;
- ;; move position in output file for next grain
- ;;
- (set! gr-dens (env gr-dens-env))
- ;; increment spread in output file for next grain
- (set! gr-dens-spread (mus-random (* 0.5 (env gr-dens-spread-env))))
- (set! grain-counter (+ grain-counter 1))
- (set! where (cond (;; use duration of grains as delimiter
- (= where-to grani-to-grain-duration)
- gr-duration)
- (;; use start in input file as delimiter
- (= where-to grani-to-grain-start)
- in-start-value)
- (;; use sampling rate as delimiter
- (= where-to grani-to-grain-sample-rate)
- gr-srate)
- (;; use a random number as delimiter
- (= where-to grani-to-grain-random)
- (random 1.0))
- (else grani-to-locsig)))
- (if (and where-bins
- (not (zero? where)))
- ;; set output scalers according to criteria
+ (when happy
+ ;; back to the beginning of the grain
+ ;(set! gr-offset 0)
+ ;; start of grain in samples from beginning of note
+ (set! gr-from-beg (floor (- gr-start-sample beg)))
+ ;; reset out-time dependent envelopes to current time
+ (set! (mus-location amp-env) gr-from-beg)
+ (set! (mus-location gr-dur) gr-from-beg)
+ (set! (mus-location gr-dur-spread) gr-from-beg)
+ (set! (mus-location sr-env) gr-from-beg)
+ (set! (mus-location sr-spread-env) gr-from-beg)
+ (set! (mus-location gr-start) gr-from-beg)
+ (set! (mus-location gr-start-spread) gr-from-beg)
+ (set! (mus-location gr-dens-env) gr-from-beg)
+ (set! (mus-location gr-dens-spread-env) gr-from-beg)
+ ;; start of grain in input file
+ (set! in-start-value (+ (* (env gr-start) gr-start-scaler)
+ (mus-random (* 0.5 (env gr-start-spread)
+ gr-start-scaler))))
+ (set! in-start (floor (* in-start-value in-file-sr)))
+ ;; duration in seconds of the grain
+ (set! gr-duration (max grain-duration-limit
+ (+ (env gr-dur)
+ (mus-random (* 0.5 (env gr-dur-spread))))))
+ ;; number of samples in the grain
+ (set! gr-samples (floor (* gr-duration *clm-srate*)))
+ ;; new sample rate for grain
+ (set! gr-srate (if srate-linear
+ (+ (env sr-env)
+ (mus-random (* 0.5 (env sr-spread-env))))
+ (* (env sr-env)
+ (expt srate-base
+ (mus-random (* 0.5 (env sr-spread-env)))))))
+ ;; set new sampling rate conversion factor
+ (set! (mus-increment in-file-reader) gr-srate)
+ ;; number of samples in input
+ (set! in-samples (floor (* gr-samples srate-ratio)))
+
+ ;; check for out of bounds condition in in-file pointers
+ (set! in-start (if (> (+ in-start in-samples) last-in-sample)
+ (- last-in-sample in-samples)
+ (max in-start 0)))
+ ;; reset position of input file reader
+ (set! (mus-location rd) in-start)
+
+ ;; restart grain envelopes
+ (set! (mus-phase gr-env) 0.0)
+ (set! (mus-phase gr-env-end) 0.0)
+ ;; reset grain envelope durations
+ (set! (mus-frequency gr-env) (/ gr-duration))
+ (set! (mus-frequency gr-env-end) (/ gr-duration))
+ ;;
+ ;; move position in output file for next grain
+ ;;
+ (set! gr-dens (env gr-dens-env))
+ ;; increment spread in output file for next grain
+ (set! gr-dens-spread (mus-random (* 0.5 (env gr-dens-spread-env))))
+ (set! grain-counter (+ grain-counter 1))
+ (set! where (cond (;; use duration of grains as delimiter
+ (= where-to grani-to-grain-duration)
+ gr-duration)
+ (;; use start in input file as delimiter
+ (= where-to grani-to-grain-start)
+ in-start-value)
+ (;; use sampling rate as delimiter
+ (= where-to grani-to-grain-sample-rate)
+ gr-srate)
+ (;; use a random number as delimiter
+ (= where-to grani-to-grain-random)
+ (random 1.0))
+ (else grani-to-locsig)))
+ (if (and where-bins
+ (not (zero? where)))
+ ;; set output scalers according to criteria
+ (do ((chn 0 (+ chn 1)))
+ ((or (= chn out-chans)
+ (= chn where-bins-len)))
+ (locsig-set! loc chn (if (< (where-bins chn)
+ where
+ (where-bins (+ chn 1)))
+ 1.0
+ 0.0)))
+ ;; if not "where" see if the user wants to send to all channels
+ (if (= where-to grani-to-grain-allchans)
+ ;; send the grain to all channels
(do ((chn 0 (+ chn 1)))
- ((or (= chn out-chans)
- (= chn where-bins-len)))
- (locsig-set! loc chn (if (< (where-bins chn)
- where
- (where-bins (+ chn 1)))
- 1.0
- 0.0)))
- ;; if not "where" see if the user wants to send to all channels
- (if (= where-to grani-to-grain-allchans)
- ;; send the grain to all channels
- (do ((chn 0 (+ chn 1)))
- ((= chn out-chans))
- (locsig-set! loc chn 1.0))
- ;; "where" is zero or unknown: use normal n-channel locsig,
- ;; only understands mono reverb and 1, 2 or 4 channel output
- (begin
- (set! (mus-location gr-dist) gr-from-beg)
- (set! (mus-location gr-dist-spread) gr-from-beg)
- (set! (mus-location gr-degree) gr-from-beg)
- (set! (mus-location gr-degree-spread) gr-from-beg)
- ;; set locsig parameters, for now only understands stereo
- (move-locsig loc
- (+ (env gr-degree)
- (mus-random (* 0.5 (env gr-degree-spread))))
- (+ (env gr-dist)
- (mus-random (* 0.5 (env gr-dist-spread))))))))
-
- (let ((grend (+ gr-start-sample gr-samples)))
- (if interp-gr-envs
- (do ((gr-offset gr-start-sample (+ gr-offset 1)))
- ((= gr-offset grend))
- (locsig loc gr-offset (* (env amp-env)
- (src in-file-reader)
- (+ (* (env gr-int-env) (table-lookup gr-env-end))
- (* (env gr-int-env-1) (table-lookup gr-env))))))
-
- (do ((gr-offset gr-start-sample (+ gr-offset 1)))
- ((= gr-offset grend))
- (locsig loc gr-offset (* (env amp-env)
- (table-lookup gr-env)
- (src in-file-reader)))))))))))))
+ ((= chn out-chans))
+ (locsig-set! loc chn 1.0))
+ ;; "where" is zero or unknown: use normal n-channel locsig,
+ ;; only understands mono reverb and 1, 2 or 4 channel output
+ (begin
+ (set! (mus-location gr-dist) gr-from-beg)
+ (set! (mus-location gr-dist-spread) gr-from-beg)
+ (set! (mus-location gr-degree) gr-from-beg)
+ (set! (mus-location gr-degree-spread) gr-from-beg)
+ ;; set locsig parameters, for now only understands stereo
+ (move-locsig loc
+ (+ (env gr-degree)
+ (mus-random (* 0.5 (env gr-degree-spread))))
+ (+ (env gr-dist)
+ (mus-random (* 0.5 (env gr-dist-spread))))))))
+
+ (let ((grend (+ gr-start-sample gr-samples)))
+ (if interp-gr-envs
+ (do ((gr-offset gr-start-sample (+ gr-offset 1)))
+ ((= gr-offset grend))
+ (locsig loc gr-offset (* (env amp-env)
+ (src in-file-reader)
+ (+ (* (env gr-int-env) (table-lookup gr-env-end))
+ (* (env gr-int-env-1) (table-lookup gr-env))))))
+
+ (do ((gr-offset gr-start-sample (+ gr-offset 1)))
+ ((= gr-offset grend))
+ (locsig loc gr-offset (* (env amp-env)
+ (table-lookup gr-env)
+ (src in-file-reader))))))))))))
;; (with-sound (:channels 2 :reverb jc-reverb :reverb-channels 1) (let ((file "oboe.snd")) (grani 0 2 5 file :grain-envelope (raised-cosine))))
diff --git a/grfsnd.html b/grfsnd.html
index 9db38a6..51ed322 100644
--- a/grfsnd.html
+++ b/grfsnd.html
@@ -157,6 +157,7 @@ related documentation:
<li><a href="#sndandruby">Snd with Ruby</a>
<li><a href="#sndandforth">Snd with Forth</a>
<li><a href="#sndands7">Snd with s7</a>
+ <li><a href="#sndands7webserver">Snd with s7 webserver</a>
<li><a href="#sndandladspa">Snd and LADSPA plugins</a>
<li><a href="#sndandalsa">Snd and ALSA</a>
<li><a href="#sndandjack">Snd and Jack</a>
@@ -1310,48 +1311,48 @@ Here's a dialog window with a slider:
(define current-scaler 1.0)
(define (create-scale-dialog parent)
- (if (not (Widget? scale-dialog))
- (let ((xdismiss (XmStringCreate "Dismiss" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "Scaling" XmFONTLIST_DEFAULT_TAG)))
- (set! scale-dialog
- (XmCreateTemplateDialog parent "Scaling"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNtransient #f)))
- (XtAddCallback scale-dialog
- XmNcancelCallback (lambda (w context info)
- (XtUnmanageChild scale-dialog)))
- (XtAddCallback scale-dialog
- XmNhelpCallback (lambda (w context info)
- (<a class=quiet href="extsnd.html#sndprint">snd-print</a> "move the slider to affect the volume")))
- (XmStringFree xhelp)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
-
- (let* ((mainform
- (XtCreateManagedWidget "formd" xmFormWidgetClass scale-dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild scale-dialog XmDIALOG_SEPARATOR))))
- (scale
- (XtCreateManagedWidget "" xmScaleWidgetClass mainform
- (list XmNorientation XmHORIZONTAL
- XmNshowValue #t
- XmNvalue 100
- XmNmaximum 500
- XmNdecimalPoints 2))))
-
- (XtAddCallback scale XmNvalueChangedCallback (lambda (w context info)
- (set! current-scaler (/ (.value info) 100.0))))
- (XtAddCallback scale XmNdragCallback (lambda (w context info)
- (set! current-scaler (/ (.value info) 100.0)))))))
+ (unless (Widget? scale-dialog)
+ (let ((xdismiss (XmStringCreate "Dismiss" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "Scaling" XmFONTLIST_DEFAULT_TAG)))
+ (set! scale-dialog
+ (XmCreateTemplateDialog parent "Scaling"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNtransient #f)))
+ (XtAddCallback scale-dialog
+ XmNcancelCallback (lambda (w context info)
+ (XtUnmanageChild scale-dialog)))
+ (XtAddCallback scale-dialog
+ XmNhelpCallback (lambda (w context info)
+ (<a class=quiet href="extsnd.html#sndprint">snd-print</a> "move the slider to affect the volume")))
+ (XmStringFree xhelp)
+ (XmStringFree xdismiss)
+ (XmStringFree titlestr)
+
+ (let* ((mainform
+ (XtCreateManagedWidget "formd" xmFormWidgetClass scale-dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild scale-dialog XmDIALOG_SEPARATOR))))
+ (scale
+ (XtCreateManagedWidget "" xmScaleWidgetClass mainform
+ (list XmNorientation XmHORIZONTAL
+ XmNshowValue #t
+ XmNvalue 100
+ XmNmaximum 500
+ XmNdecimalPoints 2))))
+
+ (XtAddCallback scale XmNvalueChangedCallback (lambda (w context info)
+ (set! current-scaler (/ (.value info) 100.0))))
+ (XtAddCallback scale XmNdragCallback (lambda (w context info)
+ (set! current-scaler (/ (.value info) 100.0)))))))
(XtManageChild scale-dialog))
(create-scale-dialog (cadr (<a class=quiet href="extsnd.html#mainwidgets">main-widgets</a>))))
@@ -1431,7 +1432,7 @@ Here's the scale-dialog in xg/gtk:
(define scale-dialog #f)
(define current-scaler 1.0)
- (define (create-scale-dialog parent)
+ (define (create-scale-dialog)
(unless scale-dialog
(set! scale-dialog (gtk_dialog_new))
(g_signal_connect scale-dialog "delete-event"
@@ -1462,7 +1463,7 @@ Here's the scale-dialog in xg/gtk:
(gtk_widget_show scale))))
(gtk_widget_show scale-dialog))
-(create-scale-dialog (cadr (<a class=quiet href="extsnd.html#mainwidgets">main-widgets</a>))))
+ (create-scale-dialog))
</pre>
<p>The only change from the C code is the addition of GTK_ADJUSTMENT in the scale value_changed
@@ -1914,6 +1915,15 @@ The s7 initialization file is ~/.snd_s7.
</p>
+<div class="innerheader" id="sndands7webserver">Snd with s7 webserver</div>
+
+<p>If compiling Snd with the option --with-webserver, the s7 interpreter can be accessed through a web socket.
+</p>
+
+<p>
+The file "s7webserver/s7webserver_repl.py" is an independent program that can control s7 remotely.
+Similarly, s7 can also be controlled by opening "s7webserver/s7webserver_repl.html" in a web browser.
+</p>
<!-- INDEX sndandladspa:Plugins -->
@@ -2067,22 +2077,22 @@ than one input is required, the first argument to apply-ladspa should be a list
(copy (.Copyright descriptor)))
(for-each
(lambda (port ranges port-name)
- (if (and (not (= (logand port LADSPA_PORT_CONTROL) 0))
- (not (= (logand port LADSPA_PORT_INPUT) 0)))
- (let ((ldata ())
- (hint (car ranges))
- (lo (cadr ranges))
- (hi (caddr ranges)))
- (if (not (= (logand hint LADSPA_HINT_TOGGLED) 0)) (set! ldata (cons "toggle" ldata)))
- (if (not (= (logand hint LADSPA_HINT_LOGARITHMIC) 0)) (set! ldata (cons "logarithmic" ldata)))
- (if (not (= (logand hint LADSPA_HINT_INTEGER) 0)) (set! ldata (cons "integer" ldata)))
- (if (not (= (logand hint LADSPA_HINT_SAMPLE_RATE) 0)) (set! ldata (cons "sample_rate" ldata)))
- (if (not (= (logand hint LADSPA_HINT_BOUNDED_ABOVE) 0))
- (set! ldata (cons "maximum" (cons hi ldata))))
- (if (not (= (logand hint LADSPA_HINT_BOUNDED_BELOW) 0))
- (set! ldata (cons "minimum" (cons lo ldata))))
- (set! ldata (cons port-name ldata))
- (set! data (cons ldata data)))))
+ (unless (or (= (logand port LADSPA_PORT_CONTROL) 0)
+ (= (logand port LADSPA_PORT_INPUT) 0))
+ (let ((ldata ())
+ (hint (car ranges))
+ (lo (cadr ranges))
+ (hi (caddr ranges)))
+ (if (not (= (logand hint LADSPA_HINT_TOGGLED) 0)) (set! ldata (cons "toggle" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_LOGARITHMIC) 0)) (set! ldata (cons "logarithmic" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_INTEGER) 0)) (set! ldata (cons "integer" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_SAMPLE_RATE) 0)) (set! ldata (cons "sample_rate" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_BOUNDED_ABOVE) 0))
+ (set! ldata (cons "maximum" (cons hi ldata))))
+ (if (not (= (logand hint LADSPA_HINT_BOUNDED_BELOW) 0))
+ (set! ldata (cons "minimum" (cons lo ldata))))
+ (set! ldata (cons port-name ldata))
+ (set! data (cons ldata data)))))
descriptors hints names)
(append (list name maker copy) data)))
</pre>
@@ -2344,7 +2354,7 @@ bignum-fft performs an FFT using big floats; rl and im are vectors of big floats
<!-- bignum-precision -->
-<div class="bluish"><em class=emdef>(*s7* 'bignum-precision)</em> <code></code></div>
+<div class="bluish"><em class=emdef>(*s7* 'bignum-precision)</em></div>
<p>bignum-precision sets the number of bits used in floating-point big numbers (integer
bignums have whatever size it takes to represent them). The default is 128 which gives
diff --git a/gtk-effects-utils.scm b/gtk-effects-utils.scm
index 0fb0eb7..49ba280 100644
--- a/gtk-effects-utils.scm
+++ b/gtk-effects-utils.scm
@@ -39,6 +39,8 @@
(ok-button #f)
(reset-button #f))
+ (if (defined? 'gtk_widget_set_clip) ; gtk 3.14.0
+ (gtk_window_set_transient_for (GTK_WINDOW new-dialog) (GTK_WINDOW ((main-widgets) 1))))
(gtk_window_set_title (GTK_WINDOW new-dialog) label)
(gtk_container_set_border_width (GTK_CONTAINER new-dialog) 10)
(gtk_window_set_default_size (GTK_WINDOW new-dialog) -1 -1)
@@ -87,10 +89,7 @@
new-dialog))
(define (change-label w new-label)
- (if w
- (if (GTK_IS_LABEL w)
- (gtk_label_set_text (GTK_LABEL w) new-label)
- (gtk_label_set_text (GTK_LABEL (gtk_bin_get_child (GTK_BIN w))) new-label))))
+ (if w (gtk_label_set_text (GTK_LABEL (if (GTK_IS_LABEL w) w (gtk_bin_get_child (GTK_BIN w)))) new-label)))
;;; -------- log scaler widget
@@ -108,10 +107,9 @@
(define (scale-linear->log lo val hi)
;; given user-relative lo..hi and scale-relative val, return user-relative val
;; since log-scale widget assumes 0..log-scale-ticks, val can be used as ratio (log-wise) between lo and hi
- (let* ((log-lo (log (max lo 1.0) 2))
- (log-hi (log hi 2))
- (log-val (+ log-lo (* (/ val log-scale-ticks) (- log-hi log-lo)))))
- (expt 2.0 log-val)))
+ (let ((log-lo (log (max lo 1.0) 2))
+ (log-hi (log hi 2)))
+ (expt 2.0 (+ log-lo (* (/ val log-scale-ticks) (- log-hi log-lo))))))
(define (scale-log-label lo val hi)
(format #f "~,2F" (scale-linear->log lo val hi)))
@@ -120,7 +118,7 @@
;; sliders is a list of lists, each inner list being (title low initial high callback scale ['log])
;; returns list of widgets (for reset callbacks)
(let* ((mainform (gtk_box_new GTK_ORIENTATION_VERTICAL 2))
- (use-hbox (= (length sliders) 1))
+ (use-hbox (and (pair? sliders) (null? (cdr sliders))))
(table (if (not use-hbox) (gtk_grid_new)))
(slider 0))
(gtk_box_pack_start (GTK_BOX (gtk_dialog_get_content_area (GTK_DIALOG dialog))) mainform #f #f 4)
@@ -144,12 +142,13 @@
(hbox (and use-hbox (gtk_box_new GTK_ORIENTATION_HORIZONTAL 0)))
(label (gtk_label_new
(if use-hbox
- (if use-log
- (format #f "~A: ~,2F" title initial)
- (format #f "~A:" title))
- (if use-log
- (format #f "~A (~,2F)" title initial)
- (format #f "~A" title)))))
+ (format #f (if use-hbox
+ (if use-log
+ (values "~A: ~,2F" title initial)
+ (values "~A:" title))
+ (if use-log
+ (values "~A (~,2F)" title initial)
+ (values "~A" title)))))))
(adj (if use-log
(gtk_adjustment_new (scale-log->linear low initial high) 0 log-scale-ticks 1 10 1)
(gtk_adjustment_new initial low high 0.0 0.0 0.0)))
@@ -163,9 +162,9 @@
)
(gtk_widget_show label)
(gtk_scale_set_digits (GTK_SCALE scale)
- (if use-log
- 0
- (if (= scaler 1000) 3 (if (= scaler 100) 2 (if (= scaler 10) 1 0)))))
+ (cond (use-log 0)
+ ((assoc scaler '((1000 . 3) (100 . 2) (10 . 1)) =) => cdr)
+ (else 0)))
(gtk_scale_set_draw_value (GTK_SCALE scale) (not use-log))
(if use-hbox
(gtk_box_pack_start (GTK_BOX hbox) scale #t #t 0)
@@ -174,16 +173,16 @@
(gtk_grid_attach (GTK_GRID table) scale 1 slider 1 1)
(set! slider (+ 1 slider))))
(gtk_widget_show scale)
- (if use-log
- (g_signal_connect adj "value_changed"
+ (g_signal_connect adj "value_changed"
+ (if (not use-log)
+ func
(lambda (w d)
(func w d)
(change-label label
(format #f "~A: ~,2F"
title
- (scale-linear->log low (gtk_adjustment_get_value (GTK_ADJUSTMENT adj)) high))))
- #f)
- (g_signal_connect adj "value_changed" func #f))
+ (scale-linear->log low (gtk_adjustment_get_value (GTK_ADJUSTMENT adj)) high)))))
+ #f)
adj))
sliders)))
diff --git a/gtk-effects.scm b/gtk-effects.scm
index e5cc927..07e8a53 100644
--- a/gtk-effects.scm
+++ b/gtk-effects.scm
@@ -21,7 +21,7 @@
cw
(* .5 (+ lw rw)))))
;; favor is the point we center the search on
- (define (centered-points points)
+ (let centered-points ((points ms))
(if (= (length points) 2)
points
(let ((p1 (car points))
@@ -29,8 +29,7 @@
(p3 (caddr points)))
(if (< (abs (- p1 favor)) (abs (- p3 favor)))
(list p1 p2)
- (centered-points (cdr points))))))
- (centered-points ms))))))
+ (centered-points (cdr points)))))))))))
(define map-chan-over-target-with-sync
;; target: 'marks -> beg=closest marked sample, dur=samples to next mark
@@ -39,47 +38,46 @@
;; 'cursor -> beg=cursor, dur=samples to end of sound
;; decay is how long to run the effect past the end of the sound
(lambda (func target origin decay)
- (if (and (eq? target 'selection)
- (not (selection?)))
- (snd-print ";no selection")
- (if (and (eq? target 'sound)
- (null? (sounds)))
- (snd-print ";no sound")
- (if (and (eq? target 'marks)
- (or (null? (sounds))
- (< (length (marks (selected-sound) (selected-channel))) 2)))
- (snd-print ";no marks")
- (let* ((snc (sync))
- (ms (and (eq? target 'marks)
- (plausible-mark-samples)))
- (beg (if (eq? target 'sound)
- 0
- (if (eq? target 'selection)
- (selection-position)
- (if (eq? target 'cursor)
- (cursor (selected-sound) (selected-channel))
- (car ms)))))
- (overlap (if decay
- (floor (* (srate) decay))
- 0)))
- (apply for-each
- (lambda (snd chn)
- (let ((end (if (memq target '(sound cursor))
- (- (framples snd chn) 1)
- (if (eq? target 'selection)
- (+ (selection-position) (selection-framples))
- (cadr ms)))))
- (if (= (sync snd) snc)
- (map-channel (func (- end beg)) beg (+ end overlap 1) snd chn #f
- (format #f "~A ~A ~A"
- (origin target (- end beg))
- (if (eq? target 'sound) 0 beg)
- (and (not (eq? target 'sound)) (+ 1 (- end beg))))))))
-
- (if (> snc 0)
- (all-chans)
- (list (list (selected-sound))
- (list (selected-channel)))))))))))
+ (cond ((and (eq? target 'selection)
+ (not (selection?)))
+ (snd-print ";no selection"))
+ ((and (eq? target 'sound)
+ (null? (sounds)))
+ (snd-print ";no sound"))
+ ((and (eq? target 'marks)
+ (or (null? (sounds))
+ (< (length (marks (selected-sound) (selected-channel))) 2)))
+ (snd-print ";no marks"))
+ (else
+ (let* ((snc (sync))
+ (ms (and (eq? target 'marks)
+ (plausible-mark-samples)))
+ (beg (case target
+ ((sound) 0)
+ ((selection) (selection-position))
+ ((cursor) (cursor (selected-sound) (selected-channel)))
+ (else (car ms))))
+ (overlap (if decay
+ (floor (* (srate) decay))
+ 0)))
+ (apply for-each
+ (lambda (snd chn)
+ (let ((end (if (memq target '(sound cursor))
+ (- (framples snd chn) 1)
+ (if (eq? target 'selection)
+ (+ (selection-position) (selection-framples))
+ (cadr ms)))))
+ (if (= (sync snd) snc)
+ (map-channel (func (- end beg)) beg (+ end overlap 1) snd chn #f
+ (format #f "~A ~A ~A"
+ (origin target (- end beg))
+ (if (eq? target 'sound) 0 beg)
+ (and (not (eq? target 'sound)) (- (+ end 1) beg)))))))
+
+ (if (> snc 0)
+ (all-chans)
+ (list (list (selected-sound))
+ (list (selected-channel))))))))))
(define (add-target mainform target-callback truncate-callback)
@@ -106,15 +104,15 @@
(list 'sound 'selection 'marks)
(list #t #f #f)))
- (if truncate-callback
- (let ((sep (gtk_separator_new GTK_ORIENTATION_HORIZONTAL))
- (button (gtk_check_button_new_with_label "truncate at end")))
+ (when truncate-callback
+ (let ((button (gtk_check_button_new_with_label "truncate at end")))
+ (let ((sep (gtk_separator_new GTK_ORIENTATION_HORIZONTAL)))
(gtk_box_pack_start (GTK_BOX rc) sep #t #t 4)
- (gtk_widget_show sep)
- (gtk_box_pack_start (GTK_BOX rc) button #t #t 4)
- (gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON button) #t)
- (gtk_widget_show button)
- (g_signal_connect button "clicked" (lambda (w d) (truncate-callback (gtk_toggle_button_get_active (GTK_TOGGLE_BUTTON w)))) #f)))))
+ (gtk_widget_show sep))
+ (gtk_box_pack_start (GTK_BOX rc) button #t #t 4)
+ (gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON button) #t)
+ (gtk_widget_show button)
+ (g_signal_connect button "clicked" (lambda (w d) (truncate-callback (gtk_toggle_button_get_active (GTK_TOGGLE_BUTTON w)))) #f)))))
(define (effect-framples target)
(if (eq? target 'sound)
@@ -140,14 +138,15 @@
(define* (effects-squelch-channel amp gate-size snd chn no-silence)
(let ((f0 (make-moving-average gate-size))
(f1 (make-moving-average gate-size :initial-element 1.0)))
- (if no-silence
- (map-channel (lambda (y)
- (let ((val (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
- (and (not (zero? val)) val)))
- 0 #f snd chn #f (format #f "effects-squelch-channel ~A ~A" amp gate-size))
- (map-channel (lambda (y)
- (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp)))))
- 0 #f snd chn #f (format #f "effects-squelch-channel ~A ~A" amp gate-size)))))
+ (map-channel
+ (if no-silence
+ (lambda (y)
+ (let ((val (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
+ (and (not (zero? val)) val)))
+ (lambda (y)
+ (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
+ 0 #f snd chn #f
+ (format #f "effects-squelch-channel ~A ~A" amp gate-size))))
(let ((amp-menu-list ())
(amp-menu (gtk_menu_item_new_with_label "Amplitude Effects"))
@@ -175,72 +174,71 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not gain-dialog)
- (let ((initial-gain-amount 1.0)
- (sliders ()))
- (set! gain-dialog
- (make-effect-dialog
- "Gain"
-
- (lambda (w data)
- ;; Gain scales amplitude by gain amount.
- (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
- (scale-envelope (xe-envelope gain-envelope) gain-amount))))
- (if (eq? gain-target 'sound)
- (if with-env
- (env-sound with-env)
- (scale-by gain-amount))
- (if (eq? gain-target 'selection)
- (if (selection?)
+ (unless gain-dialog
+ (let ((initial-gain-amount 1.0)
+ (sliders ()))
+ (set! gain-dialog
+ (make-effect-dialog
+ "Gain"
+
+ (lambda (w data)
+ ;; Gain scales amplitude by gain amount.
+ (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
+ (scale-envelope (xe-envelope gain-envelope) gain-amount))))
+ (if (eq? gain-target 'sound)
+ (if with-env
+ (env-sound with-env)
+ (scale-by gain-amount))
+ (if (eq? gain-target 'selection)
+ (if (selection?)
+ (if with-env
+ (env-selection with-env)
+ (scale-selection-by gain-amount))
+ (snd-print "no selection"))
+ (let ((pts (plausible-mark-samples)))
+ (if pts
(if with-env
- (env-selection with-env)
- (scale-selection-by gain-amount))
- (snd-print "no selection"))
- (let ((pts (plausible-mark-samples)))
- (if pts
- (if with-env
- (env-sound with-env (car pts) (- (cadr pts) (car pts)))
- (scale-by gain-amount (car pts) (- (cadr pts) (car pts))))))))))
-
- (lambda (w data)
- (help-dialog
- "Gain"
- "Move the slider to change the gain scaling amount."))
-
- (lambda (w data)
- (set! gain-amount initial-gain-amount)
- (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) gain-amount)
- )
-
- (lambda ()
- (effect-target-ok gain-target))))
-
- (set! sliders
- (add-sliders gain-dialog
- (list (list "gain" 0.0 initial-gain-amount 5.0
- (lambda (w data)
- (set! gain-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
- 100))))
- (gtk_widget_show gain-dialog)
- (set! gain-envelope (xe-create-enved "gain"
- (gtk_dialog_get_content_area (GTK_DIALOG gain-dialog))
- #f
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG gain-dialog))
- (lambda (target)
- (set! gain-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT gain-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (env-sound with-env (car pts) (- (cadr pts) (car pts)))
+ (scale-by gain-amount (car pts) (- (cadr pts) (car pts))))))))))
+
+ (lambda (w data)
+ (help-dialog
+ "Gain"
+ "Move the slider to change the gain scaling amount."))
+
+ (lambda (w data)
+ (set! gain-amount initial-gain-amount)
+ (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) gain-amount)
+ )
+
+ (lambda ()
+ (effect-target-ok gain-target))))
+
+ (set! sliders
+ (add-sliders gain-dialog
+ (list (list "gain" 0.0 initial-gain-amount 5.0
+ (lambda (w data)
+ (set! gain-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
+ 100)))))
+ (gtk_widget_show gain-dialog)
+ (set! gain-envelope (xe-create-enved "gain"
+ (gtk_dialog_get_content_area (GTK_DIALOG gain-dialog))
+ #f
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG gain-dialog))
+ (lambda (target)
+ (set! gain-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT gain-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f))
(activate-dialog gain-dialog))
#f)
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Gain (~1,2F)" gain-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Gain (~1,2F)" gain-amount)))
amp-menu-list)))
;; -------- Normalize
@@ -253,55 +251,54 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not normalize-dialog)
- (let ((initial-normalize-amount 1.0)
- (sliders ()))
- (set! normalize-dialog
- (make-effect-dialog
- "Normalize"
-
- (lambda (w data)
- (if (eq? normalize-target 'sound)
- (scale-to normalize-amount)
- (if (eq? normalize-target 'selection)
- (if (selection?)
- (scale-selection-to normalize-amount)
- (snd-print "no selection"))
- (let ((pts (plausible-mark-samples)))
- (if pts
- (scale-to normalize-amount (car pts) (- (cadr pts) (car pts))))))))
-
- (lambda (w data)
- (help-dialog
- "Normalize"
- "Normalize scales amplitude to the normalize amount. Move the slider to change the scaling amount."))
-
- (lambda (w data)
- (set! normalize-amount initial-normalize-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) normalize-amount)
- )
-
- (lambda ()
- (effect-target-ok normalize-target))))
-
- (set! sliders
- (add-sliders normalize-dialog
- (list (list "normalize" 0.0 initial-normalize-amount 1.1
- (lambda (w data)
- (set! normalize-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG normalize-dialog))
- (lambda (target)
- (set! normalize-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT normalize-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless normalize-dialog
+ (let ((initial-normalize-amount 1.0)
+ (sliders ()))
+ (set! normalize-dialog
+ (make-effect-dialog
+ "Normalize"
+
+ (lambda (w data)
+ (if (eq? normalize-target 'sound)
+ (scale-to normalize-amount)
+ (if (eq? normalize-target 'selection)
+ (if (selection?)
+ (scale-selection-to normalize-amount)
+ (snd-print "no selection"))
+ (let ((pts (plausible-mark-samples)))
+ (if pts
+ (scale-to normalize-amount (car pts) (- (cadr pts) (car pts))))))))
+
+ (lambda (w data)
+ (help-dialog
+ "Normalize"
+ "Normalize scales amplitude to the normalize amount. Move the slider to change the scaling amount."))
+
+ (lambda (w data)
+ (set! normalize-amount initial-normalize-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) normalize-amount)
+ )
+
+ (lambda ()
+ (effect-target-ok normalize-target))))
+
+ (set! sliders
+ (add-sliders normalize-dialog
+ (list (list "normalize" 0.0 initial-normalize-amount 1.1
+ (lambda (w data)
+ (set! normalize-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG normalize-dialog))
+ (lambda (target)
+ (set! normalize-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT normalize-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog normalize-dialog))
#f)
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Normalize (~1,2F)" normalize-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Normalize (~1,2F)" normalize-amount)))
amp-menu-list)))
;; -------- Gate (gate set by gate-amount)
@@ -316,50 +313,49 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not gate-dialog)
- ;; if gate-dialog doesn't exist, create it
- (let ((initial-gate-amount 0.01)
- (sliders ()))
- (set! gate-dialog
- (make-effect-dialog
- "Gate"
-
- (lambda (w data)
- (let ((snc (sync)))
- (if (> snc 0)
- (apply map
- (lambda (snd chn)
- (if (= (sync snd) snc)
- (effects-squelch-channel (* gate-amount gate-amount) gate-size snd chn omit-silence)))
- (all-chans))
- (effects-squelch-channel (* gate-amount gate-amount) gate-size (selected-sound) (selected-channel) omit-silence))))
-
- (lambda (w data)
- (help-dialog "Gate"
- "Move the slider to change the gate intensity. Higher values gate more of the sound."))
-
- (lambda (w data)
- (set! gate-amount initial-gate-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) gate-amount)
- )))
-
- (set! sliders
- (add-sliders gate-dialog
- (list (list "gate" 0.0 initial-gate-amount 0.1
- (lambda (w data)
- (set! gate-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
- 1000))))
- ;; now add a toggle button setting omit-silence
- (let ((toggle (gtk_check_button_new_with_label "Omit silence")))
- (gtk_box_pack_start (GTK_BOX (gtk_dialog_get_content_area (GTK_DIALOG gate-dialog))) toggle #f #f 4)
- (gtk_widget_show toggle)
- (gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON toggle) omit-silence)
- (g_signal_connect toggle "clicked" (lambda (w d) (set! omit-silence (gtk_toggle_button_get_active (GTK_TOGGLE_BUTTON toggle)))) #f))))
+ (unless gate-dialog
+ ;; if gate-dialog doesn't exist, create it
+ (let ((initial-gate-amount 0.01)
+ (sliders ()))
+ (set! gate-dialog
+ (make-effect-dialog
+ "Gate"
+
+ (lambda (w data)
+ (let ((snc (sync)))
+ (if (> snc 0)
+ (apply map
+ (lambda (snd chn)
+ (if (= (sync snd) snc)
+ (effects-squelch-channel (* gate-amount gate-amount) gate-size snd chn omit-silence)))
+ (all-chans))
+ (effects-squelch-channel (* gate-amount gate-amount) gate-size (selected-sound) (selected-channel) omit-silence))))
+
+ (lambda (w data)
+ (help-dialog "Gate"
+ "Move the slider to change the gate intensity. Higher values gate more of the sound."))
+
+ (lambda (w data)
+ (set! gate-amount initial-gate-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) gate-amount)
+ )))
+
+ (set! sliders
+ (add-sliders gate-dialog
+ (list (list "gate" 0.0 initial-gate-amount 0.1
+ (lambda (w data)
+ (set! gate-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
+ 1000))))
+ ;; now add a toggle button setting omit-silence
+ (let ((toggle (gtk_check_button_new_with_label "Omit silence")))
+ (gtk_box_pack_start (GTK_BOX (gtk_dialog_get_content_area (GTK_DIALOG gate-dialog))) toggle #f #f 4)
+ (gtk_widget_show toggle)
+ (gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON toggle) omit-silence)
+ (g_signal_connect toggle "clicked" (lambda (w d) (set! omit-silence (gtk_toggle_button_get_active (GTK_TOGGLE_BUTTON toggle)))) #f))))
(activate-dialog gate-dialog))
#f)
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Gate (~1,3F)" gate-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Gate (~1,3F)" gate-amount)))
amp-menu-list)))))
;;; DELAY EFFECTS
@@ -389,7 +385,7 @@
(define* (effects-flecho-1 scaler secs input-samps-1 beg dur snd chn)
(let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
(del (make-delay (round (* secs (srate snd))))))
- (if (and (not input-samps-1) (not dur))
+ (if (not (or input-samps-1 dur))
(map-channel (lambda (inval)
(+ inval
(delay del
@@ -441,69 +437,67 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not echo-dialog)
- (let ((initial-delay-time 0.5)
- (initial-echo-amount 0.2)
- (sliders ()))
- (set! echo-dialog
- (make-effect-dialog
- "Echo"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (cutoff)
- (let ((del (make-delay (round (* delay-time (srate)))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (* echo-amount (+ (tap del) (* (env genv) inval))))))))
- echo-target
- (lambda (target input-samps)
- (format #f "effects-echo ~A ~A ~A"
- (and (not (eq? target 'sound)) input-samps)
- delay-time echo-amount))
- (and (not echo-truncate)
- (* 4 delay-time))))
-
- (lambda (w data)
- (help-dialog "Echo"
- "The sliders change the delay time and echo amount."))
-
- (lambda (w data)
- (set! delay-time initial-delay-time)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) delay-time)
- (set! echo-amount initial-echo-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) echo-amount)
- )
-
- (lambda ()
- (effect-target-ok echo-target))))
-
- (set! sliders
- (add-sliders echo-dialog
- (list (list "delay time" 0.0 initial-delay-time 2.0
- (lambda (w data)
- (set! delay-time (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders)))))
- 100)
- (list "echo amount" 0.0 initial-echo-amount 1.0
- (lambda (w data)
- (set! echo-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG echo-dialog))
- (lambda (target)
- (set! echo-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT echo-dialog) "ok-button"))
- (effect-target-ok target)))
- (lambda (truncate)
- (set! echo-truncate truncate)))))
+ (unless echo-dialog
+ (let ((initial-delay-time 0.5)
+ (initial-echo-amount 0.2)
+ (sliders ()))
+ (set! echo-dialog
+ (make-effect-dialog
+ "Echo"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (cutoff)
+ (let ((del (make-delay (round (* delay-time (srate)))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (* echo-amount (+ (tap del) (* (env genv) inval))))))))
+ echo-target
+ (lambda (target input-samps)
+ (format #f "effects-echo ~A ~A ~A"
+ (and (not (eq? target 'sound)) input-samps)
+ delay-time echo-amount))
+ (and (not echo-truncate)
+ (* 4 delay-time))))
+
+ (lambda (w data)
+ (help-dialog "Echo"
+ "The sliders change the delay time and echo amount."))
+
+ (lambda (w data)
+ (set! delay-time initial-delay-time)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) delay-time)
+ (set! echo-amount initial-echo-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) echo-amount)
+ )
+
+ (lambda ()
+ (effect-target-ok echo-target))))
+
+ (set! sliders
+ (add-sliders echo-dialog
+ (list (list "delay time" 0.0 initial-delay-time 2.0
+ (lambda (w data)
+ (set! delay-time (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders)))))
+ 100)
+ (list "echo amount" 0.0 initial-echo-amount 1.0
+ (lambda (w data)
+ (set! echo-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG echo-dialog))
+ (lambda (target)
+ (set! echo-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT echo-dialog) "ok-button"))
+ (effect-target-ok target)))
+ (lambda (truncate)
+ (set! echo-truncate truncate)))))
(activate-dialog echo-dialog))
#f)
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Echo (~1,2F ~1,2F)"
- delay-time echo-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Echo (~1,2F ~1,2F)" delay-time echo-amount)))
delay-menu-list)))
;; -------- Filtered echo
@@ -529,64 +523,62 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not flecho-dialog)
- (let ((initial-flecho-scaler 0.5)
- (initial-flecho-delay 0.9)
- (sliders ()))
- (set! flecho-dialog
- (make-effect-dialog
- "Filtered echo"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (input-samps)
- (flecho-1 flecho-scaler flecho-delay input-samps))
- flecho-target
- (lambda (target input-samps)
- (format #f "effects-flecho-1 ~A ~A ~A"
- flecho-scaler flecho-delay
- (and (not (eq? target 'sound)) input-samps)))
- (and (not flecho-truncate)
- (* 4 flecho-delay))))
-
- (lambda (w data)
- (help-dialog "Filtered echo"
- "Move the sliders to set the filter scaler and the delay time in seconds."))
-
- (lambda (w data)
- (set! flecho-scaler initial-flecho-scaler)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) flecho-scaler)
- (set! flecho-delay initial-flecho-delay)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) flecho-delay)
- )
-
- (lambda ()
- (effect-target-ok flecho-target))))
-
- (set! sliders
- (add-sliders flecho-dialog
- (list (list "filter scaler" 0.0 initial-flecho-scaler 1.0
- (lambda (w data)
- (set! flecho-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders)))))
- 100)
- (list "delay time (secs)" 0.0 initial-flecho-delay 3.0
- (lambda (w data)
- (set! flecho-delay (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG flecho-dialog))
- (lambda (target)
- (set! flecho-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT flecho-dialog) "ok-button"))
- (effect-target-ok target)))
- (lambda (truncate)
- (set! flecho-truncate truncate)))))
+ (unless flecho-dialog
+ (let ((initial-flecho-scaler 0.5)
+ (initial-flecho-delay 0.9)
+ (sliders ()))
+ (set! flecho-dialog
+ (make-effect-dialog
+ "Filtered echo"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (input-samps)
+ (flecho-1 flecho-scaler flecho-delay input-samps))
+ flecho-target
+ (lambda (target input-samps)
+ (format #f "effects-flecho-1 ~A ~A ~A"
+ flecho-scaler flecho-delay
+ (and (not (eq? target 'sound)) input-samps)))
+ (and (not flecho-truncate)
+ (* 4 flecho-delay))))
+
+ (lambda (w data)
+ (help-dialog "Filtered echo"
+ "Move the sliders to set the filter scaler and the delay time in seconds."))
+
+ (lambda (w data)
+ (set! flecho-scaler initial-flecho-scaler)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) flecho-scaler)
+ (set! flecho-delay initial-flecho-delay)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) flecho-delay)
+ )
+
+ (lambda ()
+ (effect-target-ok flecho-target))))
+
+ (set! sliders
+ (add-sliders flecho-dialog
+ (list (list "filter scaler" 0.0 initial-flecho-scaler 1.0
+ (lambda (w data)
+ (set! flecho-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders)))))
+ 100)
+ (list "delay time (secs)" 0.0 initial-flecho-delay 3.0
+ (lambda (w data)
+ (set! flecho-delay (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG flecho-dialog))
+ (lambda (target)
+ (set! flecho-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT flecho-dialog) "ok-button"))
+ (effect-target-ok target)))
+ (lambda (truncate)
+ (set! flecho-truncate truncate)))))
(activate-dialog flecho-dialog))
#f)
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Filtered echo (~1,2F ~1,2F)"
- flecho-scaler flecho-delay)))
- (change-label child new-label)))
+ (change-label child (format #f "Filtered echo (~1,2F ~1,2F)" flecho-scaler flecho-delay)))
delay-menu-list)))
;; -------- Modulated echo
@@ -616,80 +608,79 @@
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not zecho-dialog)
- (let ((initial-zecho-scaler 0.5)
- (initial-zecho-delay 0.75)
- (initial-zecho-freq 6)
- (initial-zecho-amp 10.0)
- (sliders ()))
- (set! zecho-dialog
- (make-effect-dialog
- "Modulated echo"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (input-samps)
- (zecho-1 zecho-scaler zecho-delay zecho-freq zecho-amp input-samps))
- zecho-target
- (lambda (target input-samps)
- (format #f "effects-zecho-1 ~A ~A ~A ~A ~A"
- zecho-scaler zecho-delay zecho-freq zecho-amp
- (and (not (eq? target 'sound)) input-samps)))
- (and (not zecho-truncate)
- (* 4 zecho-delay))))
-
- (lambda (w data)
- (help-dialog "Modulated echo"
- "Move the sliders to set the echo scaler, the delay time in seconds,
+ (unless zecho-dialog
+ (let ((initial-zecho-scaler 0.5)
+ (initial-zecho-delay 0.75)
+ (initial-zecho-freq 6)
+ (initial-zecho-amp 10.0)
+ (sliders ()))
+ (set! zecho-dialog
+ (make-effect-dialog
+ "Modulated echo"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (input-samps)
+ (zecho-1 zecho-scaler zecho-delay zecho-freq zecho-amp input-samps))
+ zecho-target
+ (lambda (target input-samps)
+ (format #f "effects-zecho-1 ~A ~A ~A ~A ~A"
+ zecho-scaler zecho-delay zecho-freq zecho-amp
+ (and (not (eq? target 'sound)) input-samps)))
+ (and (not zecho-truncate)
+ (* 4 zecho-delay))))
+
+ (lambda (w data)
+ (help-dialog "Modulated echo"
+ "Move the sliders to set the echo scaler, the delay time in seconds,
the modulation frequency, and the echo amplitude."))
-
- (lambda (w data)
- (set! zecho-scaler initial-zecho-scaler)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) zecho-scaler)
- (set! zecho-delay initial-zecho-delay)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) zecho-delay)
- (set! zecho-freq initial-zecho-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) zecho-freq)
- (set! zecho-amp initial-zecho-amp)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) zecho-amp)
- )
-
- (lambda ()
- (effect-target-ok zecho-target))))
-
- (set! sliders
- (add-sliders zecho-dialog
- (list (list "echo scaler" 0.0 initial-zecho-scaler 1.0
- (lambda (w data)
- (set! zecho-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "delay time (secs)" 0.0 initial-zecho-delay 3.0
- (lambda (w data)
- (set! zecho-delay (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100)
- (list "modulation frequency" 0.0 initial-zecho-freq 100.0
- (lambda (w data)
- (set! zecho-freq (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100)
- (list "modulation amplitude" 0.0 initial-zecho-amp 100.0
- (lambda (w data)
- (set! zecho-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 3)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG zecho-dialog))
- (lambda (target)
- (set! zecho-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT zecho-dialog) "ok-button"))
- (effect-target-ok target)))
- (lambda (truncate)
- (set! zecho-truncate truncate)))))
+
+ (lambda (w data)
+ (set! zecho-scaler initial-zecho-scaler)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) zecho-scaler)
+ (set! zecho-delay initial-zecho-delay)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) zecho-delay)
+ (set! zecho-freq initial-zecho-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) zecho-freq)
+ (set! zecho-amp initial-zecho-amp)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) zecho-amp)
+ )
+
+ (lambda ()
+ (effect-target-ok zecho-target))))
+
+ (set! sliders
+ (add-sliders zecho-dialog
+ (list (list "echo scaler" 0.0 initial-zecho-scaler 1.0
+ (lambda (w data)
+ (set! zecho-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "delay time (secs)" 0.0 initial-zecho-delay 3.0
+ (lambda (w data)
+ (set! zecho-delay (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100)
+ (list "modulation frequency" 0.0 initial-zecho-freq 100.0
+ (lambda (w data)
+ (set! zecho-freq (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100)
+ (list "modulation amplitude" 0.0 initial-zecho-amp 100.0
+ (lambda (w data)
+ (set! zecho-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 3)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG zecho-dialog))
+ (lambda (target)
+ (set! zecho-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT zecho-dialog) "ok-button"))
+ (effect-target-ok target)))
+ (lambda (truncate)
+ (set! zecho-truncate truncate)))))
(activate-dialog zecho-dialog))
#f)
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Modulated echo (~1,2F ~1,2F ~1,2F ~1,2F)"
- zecho-scaler zecho-delay zecho-freq zecho-amp)))
- (change-label child new-label)))
+ (change-label child (format #f "Modulated echo (~1,2F ~1,2F ~1,2F ~1,2F)"
+ zecho-scaler zecho-delay zecho-freq zecho-amp)))
delay-menu-list)))
)
@@ -764,63 +755,63 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not band-pass-dialog)
- (let ((initial-band-pass-freq 1000)
- (initial-band-pass-bw 100)
- (sliders ()))
- (set! band-pass-dialog
- (make-effect-dialog
- "Band-pass filter"
-
- (lambda (w data)
- (let ((flt (make-butter-band-pass band-pass-freq band-pass-bw)))
- (if (eq? band-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bbp ~A ~A 0 #f" band-pass-freq band-pass-bw))
- (if (eq? band-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bbp ~A ~A ~A ~A" band-pass-freq band-pass-bw bg nd)))))))
-
- (lambda (w data)
- (help-dialog "Band-pass filter"
- "Butterworth band-pass filter. Move the sliders to change the center frequency and bandwidth."))
-
- (lambda (w data)
- (set! band-pass-freq initial-band-pass-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 band-pass-freq 22050))
- (set! band-pass-bw initial-band-pass-bw)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) band-pass-bw)
- )
-
- (lambda ()
- (effect-target-ok band-pass-target))))
-
- (set! sliders
- (add-sliders band-pass-dialog
- (list (list "center frequency" 20 initial-band-pass-freq 22050
- (lambda (w data)
- (set! band-pass-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders))) 22050)))
- 1 'log)
- (list "bandwidth" 0 initial-band-pass-bw 1000
- (lambda (w data)
- (set! band-pass-bw (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
- 1))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG band-pass-dialog))
- (lambda (target)
- (set! band-pass-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT band-pass-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless band-pass-dialog
+ (let ((initial-band-pass-freq 1000)
+ (initial-band-pass-bw 100)
+ (sliders ()))
+ (set! band-pass-dialog
+ (make-effect-dialog
+ "Band-pass filter"
+
+ (lambda (w data)
+ (let ((flt (make-butter-band-pass band-pass-freq band-pass-bw)))
+ (if (eq? band-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bbp ~A ~A 0 #f" band-pass-freq band-pass-bw))
+ (if (eq? band-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bbp ~A ~A ~A ~A" band-pass-freq band-pass-bw bg nd)))))))
+
+ (lambda (w data)
+ (help-dialog "Band-pass filter"
+ "Butterworth band-pass filter. Move the sliders to change the center frequency and bandwidth."))
+
+ (lambda (w data)
+ (set! band-pass-freq initial-band-pass-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 band-pass-freq 22050))
+ (set! band-pass-bw initial-band-pass-bw)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) band-pass-bw)
+ )
+
+ (lambda ()
+ (effect-target-ok band-pass-target))))
+
+ (set! sliders
+ (add-sliders band-pass-dialog
+ (list (list "center frequency" 20 initial-band-pass-freq 22050
+ (lambda (w data)
+ (set! band-pass-freq (scale-linear->log 20
+ (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders)))
+ 22050)))
+ 1 'log)
+ (list "bandwidth" 0 initial-band-pass-bw 1000
+ (lambda (w data)
+ (set! band-pass-bw (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
+ 1))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG band-pass-dialog))
+ (lambda (target)
+ (set! band-pass-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT band-pass-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog band-pass-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Band-pass filter (~,2F ~D)"
- band-pass-freq band-pass-bw)))
- (change-label child new-label)))
+ (change-label child (format #f "Band-pass filter (~,2F ~D)" band-pass-freq band-pass-bw)))
filter-menu-list)))
;; -------- Butterworth band-reject (notch) filter
@@ -834,62 +825,61 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not notch-dialog)
- (let ((initial-notch-freq 100)
- (initial-notch-bw 100)
- (sliders ()))
- (set! notch-dialog
- (make-effect-dialog
- "Band-reject filter"
-
- (lambda (w data)
- (let ((flt (make-butter-band-reject notch-freq notch-bw)))
- (if (eq? notch-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bbr ~A ~A 0 #f" notch-freq notch-bw))
- (if (eq? notch-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bbr ~A ~A ~A ~A" notch-freq notch-bw bg nd)))))))
-
- (lambda (w data)
- (help-dialog "Band-reject filter"
- "Butterworth band-reject filter. Move the sliders to change the center frequency and bandwidth."))
-
- (lambda (w data)
- (set! notch-freq initial-notch-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 notch-freq 22050))
- (set! notch-bw initial-notch-bw)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) notch-bw)
- )
-
- (lambda ()
- (effect-target-ok notch-target))))
-
- (set! sliders
- (add-sliders notch-dialog
- (list (list "center frequency" 20 initial-notch-freq 22050
- (lambda (w data)
- (set! notch-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders))) 22050)))
- 1 'log)
- (list "bandwidth" 0 initial-notch-bw 1000
- (lambda (w data)
- (set! notch-bw (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
- 1))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG notch-dialog))
- (lambda (target)
- (set! notch-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT notch-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless notch-dialog
+ (let ((initial-notch-freq 100)
+ (initial-notch-bw 100)
+ (sliders ()))
+ (set! notch-dialog
+ (make-effect-dialog
+ "Band-reject filter"
+
+ (lambda (w data)
+ (let ((flt (make-butter-band-reject notch-freq notch-bw)))
+ (if (eq? notch-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bbr ~A ~A 0 #f" notch-freq notch-bw))
+ (if (eq? notch-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bbr ~A ~A ~A ~A" notch-freq notch-bw bg nd)))))))
+
+ (lambda (w data)
+ (help-dialog "Band-reject filter"
+ "Butterworth band-reject filter. Move the sliders to change the center frequency and bandwidth."))
+
+ (lambda (w data)
+ (set! notch-freq initial-notch-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 notch-freq 22050))
+ (set! notch-bw initial-notch-bw)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) notch-bw)
+ )
+
+ (lambda ()
+ (effect-target-ok notch-target))))
+
+ (set! sliders
+ (add-sliders notch-dialog
+ (list (list "center frequency" 20 initial-notch-freq 22050
+ (lambda (w data)
+ (set! notch-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (car sliders))) 22050)))
+ 1 'log)
+ (list "bandwidth" 0 initial-notch-bw 1000
+ (lambda (w data)
+ (set! notch-bw (gtk_adjustment_get_value (GTK_ADJUSTMENT (cadr sliders)))))
+ 1))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG notch-dialog))
+ (lambda (target)
+ (set! notch-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT notch-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog notch-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Band-reject filter (~,2F ~D)" notch-freq notch-bw)))
- (change-label child new-label)))
+ (change-label child (format #f "Band-reject filter (~,2F ~D)" notch-freq notch-bw)))
filter-menu-list)))
;; -------- Butterworth high-pass filter
@@ -902,55 +892,54 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not high-pass-dialog)
- (let ((initial-high-pass-freq 100)
- (sliders ()))
- (set! high-pass-dialog
- (make-effect-dialog
- "High-pass filter"
-
- (lambda (w data)
- (let ((flt (make-butter-high-pass high-pass-freq)))
- (if (eq? high-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bhp ~A 0 #f" high-pass-freq))
- (if (eq? high-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bhp ~A ~A ~A" high-pass-freq bg nd)))))))
-
- (lambda (w data)
- (help-dialog "High-pass filter"
- "Butterworth high-pass filter. Move the slider to change the high-pass cutoff frequency."))
-
- (lambda (w data)
- (set! high-pass-freq initial-high-pass-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 high-pass-freq 22050))
- )
-
- (lambda ()
- (effect-target-ok high-pass-target))))
-
- (set! sliders
- (add-sliders high-pass-dialog
- (list (list "high-pass cutoff frequency" 20 initial-high-pass-freq 22050
- (lambda (w data)
- (set! high-pass-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
- 1 'log))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG high-pass-dialog))
- (lambda (target)
- (set! high-pass-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT high-pass-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless high-pass-dialog
+ (let ((initial-high-pass-freq 100)
+ (sliders ()))
+ (set! high-pass-dialog
+ (make-effect-dialog
+ "High-pass filter"
+
+ (lambda (w data)
+ (let ((flt (make-butter-high-pass high-pass-freq)))
+ (if (eq? high-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bhp ~A 0 #f" high-pass-freq))
+ (if (eq? high-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bhp ~A ~A ~A" high-pass-freq bg nd)))))))
+
+ (lambda (w data)
+ (help-dialog "High-pass filter"
+ "Butterworth high-pass filter. Move the slider to change the high-pass cutoff frequency."))
+
+ (lambda (w data)
+ (set! high-pass-freq initial-high-pass-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 high-pass-freq 22050))
+ )
+
+ (lambda ()
+ (effect-target-ok high-pass-target))))
+
+ (set! sliders
+ (add-sliders high-pass-dialog
+ (list (list "high-pass cutoff frequency" 20 initial-high-pass-freq 22050
+ (lambda (w data)
+ (set! high-pass-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
+ 1 'log))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG high-pass-dialog))
+ (lambda (target)
+ (set! high-pass-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT high-pass-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog high-pass-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "High-pass filter (~,2F)" high-pass-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "High-pass filter (~,2F)" high-pass-freq)))
filter-menu-list)))
;; -------- Butterworth low-pass filter
@@ -963,55 +952,54 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not low-pass-dialog)
- (let ((initial-low-pass-freq 1000)
- (sliders ()))
- (set! low-pass-dialog
- (make-effect-dialog
- "Low-pass filter"
-
- (lambda (w data)
- (let ((flt (make-butter-low-pass low-pass-freq)))
- (if (eq? low-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-blp ~A 0 #f" low-pass-freq))
- (if (eq? low-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-blp ~A ~A ~A" low-pass-freq bg nd)))))))
-
- (lambda (w data)
- (help-dialog "Low-pass filter"
- "Butterworth low-pass filter. Move the slider to change the low-pass cutoff frequency."))
-
- (lambda (w data)
- (set! low-pass-freq initial-low-pass-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 low-pass-freq 22050))
- )
-
- (lambda ()
- (effect-target-ok low-pass-target))))
-
- (set! sliders
- (add-sliders low-pass-dialog
- (list (list "low-pass cutoff frequency" 20 initial-low-pass-freq 22050
- (lambda (w data)
- (set! low-pass-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
- 1 'log))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG low-pass-dialog))
- (lambda (target)
- (set! low-pass-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT low-pass-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless low-pass-dialog
+ (let ((initial-low-pass-freq 1000)
+ (sliders ()))
+ (sete! low-pass-dialog
+ (make-effect-dialog
+ "Low-pass filter"
+
+ (lambda (w data)
+ (let ((flt (make-butter-low-pass low-pass-freq)))
+ (if (eq? low-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-blp ~A 0 #f" low-pass-freq))
+ (if (eq? low-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-blp ~A ~A ~A" low-pass-freq bg nd)))))))
+
+ (lambda (w data)
+ (help-dialog "Low-pass filter"
+ "Butterworth low-pass filter. Move the slider to change the low-pass cutoff frequency."))
+
+ (lambda (w data)
+ (set! low-pass-freq initial-low-pass-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) (scale-log->linear 20 low-pass-freq 22050))
+ )
+
+ (lambda ()
+ (effect-target-ok low-pass-target))))
+
+ (set! sliders
+ (add-sliders low-pass-dialog
+ (list (list "low-pass cutoff frequency" 20 initial-low-pass-freq 22050
+ (lambda (w data)
+ (set! low-pass-freq (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
+ 1 'log))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG low-pass-dialog))
+ (lambda (target)
+ (set! low-pass-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT low-pass-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog low-pass-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Low-pass filter (~,2F)" low-pass-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "Low-pass filter (~,2F)" low-pass-freq)))
filter-menu-list)))
;; -------- Comb filter
@@ -1025,59 +1013,58 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not comb-dialog)
- (let ((initial-comb-scaler 0.1)
- (initial-comb-size 50)
- (sliders ()))
- (set! comb-dialog
- (make-effect-dialog
- "Comb filter"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (effects-comb-filter comb-scaler comb-size))
- comb-target
- (lambda (target samps)
- (format #f "effects-comb-filter ~A ~A" comb-scaler comb-size))
- #f))
-
- (lambda (w data)
- (help-dialog "Comb filter"
- "Move the sliders to change the comb scaler and size."))
-
- (lambda (w data)
- (set! comb-scaler initial-comb-scaler)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) comb-scaler)
- (set! comb-size initial-comb-size)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) comb-size)
- )
-
- (lambda ()
- (effect-target-ok comb-target))))
-
- (set! sliders
- (add-sliders comb-dialog
- (list (list "scaler" 0.0 initial-comb-scaler 1.0
- (lambda (w data)
- (set! comb-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "size" 0 initial-comb-size 100
- (lambda (w data)
- (set! comb-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG comb-dialog))
- (lambda (target)
- (set! comb-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT comb-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless comb-dialog
+ (let ((initial-comb-scaler 0.1)
+ (initial-comb-size 50)
+ (sliders ()))
+ (set! comb-dialog
+ (make-effect-dialog
+ "Comb filter"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (effects-comb-filter comb-scaler comb-size))
+ comb-target
+ (lambda (target samps)
+ (format #f "effects-comb-filter ~A ~A" comb-scaler comb-size))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Comb filter"
+ "Move the sliders to change the comb scaler and size."))
+
+ (lambda (w data)
+ (set! comb-scaler initial-comb-scaler)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) comb-scaler)
+ (set! comb-size initial-comb-size)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) comb-size)
+ )
+
+ (lambda ()
+ (effect-target-ok comb-target))))
+
+ (set! sliders
+ (add-sliders comb-dialog
+ (list (list "scaler" 0.0 initial-comb-scaler 1.0
+ (lambda (w data)
+ (set! comb-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "size" 0 initial-comb-size 100
+ (lambda (w data)
+ (set! comb-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG comb-dialog))
+ (lambda (target)
+ (set! comb-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT comb-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog comb-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Comb filter (~1,2F ~D)" comb-scaler comb-size)))
- (change-label child new-label)))
+ (change-label child (format #f "Comb filter (~1,2F ~D)" comb-scaler comb-size)))
filter-menu-list)))
;; -------- Comb-chord filter
@@ -1104,86 +1091,85 @@ the modulation frequency, and the echo amplitude."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not new-comb-chord-dialog)
- (let ((initial-new-comb-chord-scaler 0.95)
- (initial-new-comb-chord-size 60)
- (initial-new-comb-chord-amp 0.3)
- (initial-new-comb-chord-interval-one 0.75)
- (initial-new-comb-chord-interval-two 1.20)
- (sliders ()))
- (set! new-comb-chord-dialog
- (make-effect-dialog
- "Comb chord filter"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (new-comb-chord new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two))
- new-comb-chord-target
- (lambda (target samps)
- (format #f "effects-comb-chord ~A ~A ~A ~A ~A"
- new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two))
- #f))
-
- (lambda (w data)
- (help-dialog "Comb chord filter"
- "Creates chords by using filters at harmonically related sizes.
+ (unless new-comb-chord-dialog
+ (let ((initial-new-comb-chord-scaler 0.95)
+ (initial-new-comb-chord-size 60)
+ (initial-new-comb-chord-amp 0.3)
+ (initial-new-comb-chord-interval-one 0.75)
+ (initial-new-comb-chord-interval-two 1.20)
+ (sliders ()))
+ (set! new-comb-chord-dialog
+ (make-effect-dialog
+ "Comb chord filter"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (new-comb-chord new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two))
+ new-comb-chord-target
+ (lambda (target samps)
+ (format #f "effects-comb-chord ~A ~A ~A ~A ~A"
+ new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Comb chord filter"
+ "Creates chords by using filters at harmonically related sizes.
Move the sliders to set the comb chord parameters."))
-
- (lambda (w data)
- (set! new-comb-chord-scaler initial-new-comb-chord-scaler)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) new-comb-chord-scaler)
- (set! new-comb-chord-size initial-new-comb-chord-size)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) new-comb-chord-size)
- (set! new-comb-chord-amp initial-new-comb-chord-amp)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) new-comb-chord-amp)
- (set! new-comb-chord-interval-one initial-new-comb-chord-interval-one)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) new-comb-chord-interval-one)
- (set! new-comb-chord-interval-two initial-new-comb-chord-interval-two)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 4)) new-comb-chord-interval-two)
- )
-
- (lambda ()
- (effect-target-ok new-comb-chord-target))))
-
- (set! sliders
- (add-sliders new-comb-chord-dialog
- (list (list "chord scaler" 0.0 initial-new-comb-chord-scaler 1.0
- (lambda (w data)
- (set! new-comb-chord-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "chord size" 0 initial-new-comb-chord-size 100
- (lambda (w data)
- (set! new-comb-chord-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 1)
- (list "amplitude" 0.0 initial-new-comb-chord-amp 1.0
- (lambda (w data)
- (set! new-comb-chord-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100)
- (list "interval one" 0.0 initial-new-comb-chord-interval-one 2.0
- (lambda (w data)
- (set! new-comb-chord-interval-one (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
- 100)
- (list "interval two" 0.0 initial-new-comb-chord-interval-two 2.0
- (lambda (w data)
- (set! new-comb-chord-interval-two (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG new-comb-chord-dialog))
- (lambda (target)
- (set! new-comb-chord-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT new-comb-chord-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+
+ (lambda (w data)
+ (set! new-comb-chord-scaler initial-new-comb-chord-scaler)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) new-comb-chord-scaler)
+ (set! new-comb-chord-size initial-new-comb-chord-size)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) new-comb-chord-size)
+ (set! new-comb-chord-amp initial-new-comb-chord-amp)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) new-comb-chord-amp)
+ (set! new-comb-chord-interval-one initial-new-comb-chord-interval-one)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) new-comb-chord-interval-one)
+ (set! new-comb-chord-interval-two initial-new-comb-chord-interval-two)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 4)) new-comb-chord-interval-two)
+ )
+
+ (lambda ()
+ (effect-target-ok new-comb-chord-target))))
+
+ (set! sliders
+ (add-sliders new-comb-chord-dialog
+ (list (list "chord scaler" 0.0 initial-new-comb-chord-scaler 1.0
+ (lambda (w data)
+ (set! new-comb-chord-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "chord size" 0 initial-new-comb-chord-size 100
+ (lambda (w data)
+ (set! new-comb-chord-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 1)
+ (list "amplitude" 0.0 initial-new-comb-chord-amp 1.0
+ (lambda (w data)
+ (set! new-comb-chord-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100)
+ (list "interval one" 0.0 initial-new-comb-chord-interval-one 2.0
+ (lambda (w data)
+ (set! new-comb-chord-interval-one (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
+ 100)
+ (list "interval two" 0.0 initial-new-comb-chord-interval-two 2.0
+ (lambda (w data)
+ (set! new-comb-chord-interval-two (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG new-comb-chord-dialog))
+ (lambda (target)
+ (set! new-comb-chord-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT new-comb-chord-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog new-comb-chord-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Comb chord filter (~1,2F ~D ~1,2F ~1,2F ~1,2F)"
- new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two)))
- (change-label child new-label)))
+ (change-label child (format #f "Comb chord filter (~1,2F ~D ~1,2F ~1,2F ~1,2F)"
+ new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two)))
filter-menu-list)))
;; -------- Moog filter
@@ -1203,59 +1189,58 @@ Move the sliders to set the comb chord parameters."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not moog-dialog)
- (let ((initial-moog-cutoff-frequency 10000)
- (initial-moog-resonance 0.5)
- (sliders ()))
- (set! moog-dialog
- (make-effect-dialog
- "Moog filter"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored) (moog moog-cutoff-frequency moog-resonance))
- moog-target
- (lambda (target samps)
- (format #f "effects-moog-filter ~A ~A" moog-cutoff-frequency moog-resonance))
- #f))
-
- (lambda (w data)
- (help-dialog "Moog filter"
- "Moog-style 4-pole lowpass filter with 24db/oct rolloff and variable resonance.
+ (unless moog-dialog
+ (let ((initial-moog-cutoff-frequency 10000)
+ (initial-moog-resonance 0.5)
+ (sliders ()))
+ (set! moog-dialog
+ (make-effect-dialog
+ "Moog filter"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored) (moog moog-cutoff-frequency moog-resonance))
+ moog-target
+ (lambda (target samps)
+ (format #f "effects-moog-filter ~A ~A" moog-cutoff-frequency moog-resonance))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Moog filter"
+ "Moog-style 4-pole lowpass filter with 24db/oct rolloff and variable resonance.
Move the sliders to set the filter cutoff frequency and resonance."))
-
- (lambda (w data)
- (set! moog-cutoff-frequency initial-moog-cutoff-frequency)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) (scale-log->linear 20 moog-cutoff-frequency 22050))
- (set! moog-resonance initial-moog-resonance)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) moog-resonance)
- )
-
- (lambda ()
- (effect-target-ok moog-target))))
-
- (set! sliders
- (add-sliders moog-dialog
- (list (list "cutoff frequency" 20 initial-moog-cutoff-frequency 22050
- (lambda (w data)
- (set! moog-cutoff-frequency (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
- 1 'log)
- (list "resonance" 0.0 initial-moog-resonance 1.0
- (lambda (w data)
- (set! moog-resonance (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG moog-dialog))
- (lambda (target)
- (set! moog-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT moog-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+
+ (lambda (w data)
+ (set! moog-cutoff-frequency initial-moog-cutoff-frequency)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) (scale-log->linear 20 moog-cutoff-frequency 22050))
+ (set! moog-resonance initial-moog-resonance)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) moog-resonance)
+ )
+
+ (lambda ()
+ (effect-target-ok moog-target))))
+
+ (set! sliders
+ (add-sliders moog-dialog
+ (list (list "cutoff frequency" 20 initial-moog-cutoff-frequency 22050
+ (lambda (w data)
+ (set! moog-cutoff-frequency (scale-linear->log 20 (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0))) 22050)))
+ 1 'log)
+ (list "resonance" 0.0 initial-moog-resonance 1.0
+ (lambda (w data)
+ (set! moog-resonance (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG moog-dialog))
+ (lambda (target)
+ (set! moog-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT moog-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog moog-dialog))
#f)
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Moog filter (~,2F ~1,2F)" moog-cutoff-frequency moog-resonance)))
- (change-label child new-label)))
+ (change-label child (format #f "Moog filter (~,2F ~1,2F)" moog-cutoff-frequency moog-resonance)))
filter-menu-list)))
)
@@ -1280,53 +1265,51 @@ Move the sliders to set the filter cutoff frequency and resonance."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not src-dialog)
- (let ((initial-src-amount 0.0)
- (sliders ()))
- (set! src-dialog
- (make-effect-dialog
- "Sample rate conversion"
-
- (lambda (w data)
- (if (eq? src-target 'sound)
- (src-sound src-amount)
- (if (eq? src-target 'selection)
- (if (selection?)
- (src-selection src-amount)
- (snd-print "no selection"))
- (snd-print "can't apply src between marks yet"))))
-
- (lambda (w data)
- (help-dialog "Sample rate conversion"
- "Move the slider to change the sample rate.
+ (unless src-dialog
+ (let ((initial-src-amount 0.0)
+ (sliders ()))
+ (set! src-dialog
+ (make-effect-dialog
+ "Sample rate conversion"
+
+ (lambda (w data)
+ (if (eq? src-target 'sound)
+ (src-sound src-amount)
+ (if (eq? src-target 'selection)
+ (if (selection?)
+ (src-selection src-amount)
+ (snd-print "no selection"))
+ (snd-print "can't apply src between marks yet"))))
+
+ (lambda (w data)
+ (help-dialog "Sample rate conversion"
+ "Move the slider to change the sample rate.
Values greater than 1.0 speed up file play, negative values reverse it."))
-
- (lambda (w data)
- (set! src-amount initial-src-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) src-amount)
- )
-
- (lambda ()
- (effect-target-ok src-target))))
-
- (set! sliders
- (add-sliders src-dialog
- (list (list "sample rate" -2.0 initial-src-amount 2.0
- (lambda (w data)
- (set! src-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG src-dialog))
- (lambda (target)
- (set! src-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT src-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+
+ (lambda (w data)
+ (set! src-amount initial-src-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) src-amount))
+
+ (lambda ()
+ (effect-target-ok src-target))))
+
+ (set! sliders
+ (add-sliders src-dialog
+ (list (list "sample rate" -2.0 initial-src-amount 2.0
+ (lambda (w data)
+ (set! src-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG src-dialog))
+ (lambda (target)
+ (set! src-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT src-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f))
(activate-dialog src-dialog))
#f)
(set! freq-menu-list (cons (lambda ()
- (let ((new-label (format #f "Sample rate scaling (~1,2F)" src-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Sample rate scaling (~1,2F)" src-amount)))
freq-menu-list)))
;; -------- Time and pitch scaling by granular synthesis and sampling rate conversion
@@ -1343,90 +1326,89 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not expsrc-dialog)
- (let ((initial-time-scale 1.0)
- (initial-hop-size 0.05)
- (initial-segment-length 0.15)
- (initial-ramp-scale 0.5)
- (initial-pitch-scale 1.0)
- (sliders ()))
- (set! expsrc-dialog
- (make-effect-dialog
- "Time/pitch scaling"
-
- (lambda (w data)
- (let ((snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (speed-control snd) pitch-scale)
- (let ((new-time (* pitch-scale time-scale)))
- (if (not (= new-time 1.0))
- (begin
- (set! (expand-control? snd) #t)
- (set! (expand-control snd) new-time)
- (set! (expand-control-hop snd) hop-size)
- (set! (expand-control-length snd) segment-length)
- (set! (expand-control-ramp snd) ramp-scale))))
- (if (eq? expsrc-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? expsrc-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w data)
- (help-dialog "Time/pitch scaling"
- "Move the sliders to change the time/pitch scaling parameters."))
-
- (lambda (w data)
- (set! time-scale initial-time-scale)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) time-scale)
- (set! hop-size initial-hop-size)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) hop-size)
- (set! segment-length initial-segment-length)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) segment-length)
- (set! ramp-scale initial-ramp-scale)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) ramp-scale)
- (set! pitch-scale initial-pitch-scale)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 4)) pitch-scale)
- )
-
- (lambda ()
- (effect-target-ok expsrc-target))))
-
- (set! sliders
- (add-sliders expsrc-dialog
- (list (list "time scale" 0.0 initial-time-scale 5.0
- (lambda (w data)
- (set! time-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "hop size" 0.0 initial-hop-size 1.0
- (lambda (w data)
- (set! hop-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100)
- (list "segment length" 0.0 initial-segment-length 0.5
- (lambda (w data)
- (set! segment-length (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100)
- (list "ramp scale" 0.0 initial-ramp-scale 0.5
- (lambda (w data)
- (set! ramp-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 3)))))
- 1000)
- (list "pitch scale" 0.0 initial-pitch-scale 5.0
- (lambda (w data)
- (set! pitch-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG expsrc-dialog))
- (lambda (target)
- (set! expsrc-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT expsrc-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless expsrc-dialog
+ (let ((initial-time-scale 1.0)
+ (initial-hop-size 0.05)
+ (initial-segment-length 0.15)
+ (initial-ramp-scale 0.5)
+ (initial-pitch-scale 1.0)
+ (sliders ()))
+ (set! expsrc-dialog
+ (make-effect-dialog
+ "Time/pitch scaling"
+
+ (lambda (w data)
+ (let ((snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (speed-control snd) pitch-scale)
+ (let ((new-time (* pitch-scale time-scale)))
+ (if (not (= new-time 1.0))
+ (begin
+ (set! (expand-control? snd) #t)
+ (set! (expand-control snd) new-time)
+ (set! (expand-control-hop snd) hop-size)
+ (set! (expand-control-length snd) segment-length)
+ (set! (expand-control-ramp snd) ramp-scale))))
+ (if (eq? expsrc-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? expsrc-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w data)
+ (help-dialog "Time/pitch scaling"
+ "Move the sliders to change the time/pitch scaling parameters."))
+
+ (lambda (w data)
+ (set! time-scale initial-time-scale)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) time-scale)
+ (set! hop-size initial-hop-size)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) hop-size)
+ (set! segment-length initial-segment-length)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) segment-length)
+ (set! ramp-scale initial-ramp-scale)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 3)) ramp-scale)
+ (set! pitch-scale initial-pitch-scale)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 4)) pitch-scale)
+ )
+
+ (lambda ()
+ (effect-target-ok expsrc-target))))
+
+ (set! sliders
+ (add-sliders expsrc-dialog
+ (list (list "time scale" 0.0 initial-time-scale 5.0
+ (lambda (w data)
+ (set! time-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "hop size" 0.0 initial-hop-size 1.0
+ (lambda (w data)
+ (set! hop-size (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100)
+ (list "segment length" 0.0 initial-segment-length 0.5
+ (lambda (w data)
+ (set! segment-length (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100)
+ (list "ramp scale" 0.0 initial-ramp-scale 0.5
+ (lambda (w data)
+ (set! ramp-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 3)))))
+ 1000)
+ (list "pitch scale" 0.0 initial-pitch-scale 5.0
+ (lambda (w data)
+ (set! pitch-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 4)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG expsrc-dialog))
+ (lambda (target)
+ (set! expsrc-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT expsrc-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog expsrc-dialog))
#f)
(set! freq-menu-list (cons (lambda ()
- (let ((new-label (format #f "Time/pitch scaling (~1,2F ~1,2F)" time-scale pitch-scale)))
- (change-label child new-label)))
+ (change-label child (format #f "Time/pitch scaling (~1,2F ~1,2F)" time-scale pitch-scale)))
freq-menu-list)))
;;; -------- Time-varying sample rate conversion (resample)
@@ -1448,67 +1430,66 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not src-timevar-dialog)
- (let ((initial-src-timevar-scale 1.0)
- (sliders ()))
- (set! src-timevar-dialog
- (make-effect-dialog
- "Src-Timevar"
-
- (lambda (w data)
- (let ((env (scale-envelope (xe-envelope src-timevar-envelope)
- src-timevar-scale)))
- (if (eq? src-timevar-target 'sound)
- (src-sound env)
- (if (eq? src-timevar-target 'selection)
- (if (selection-member? (selected-sound))
- (src-selection env)
- (display "no selection"))
- (let ((pts (plausible-mark-samples)))
- (if pts
- (let* ((beg (car pts))
- (end (cadr pts))
- (len (- end beg)))
- (src-channel (make-env env :length len) beg len (selected-sound)))))))))
-
- (lambda (w data)
- (help-dialog
- "Src-Timevar"
- "Move the slider to change the src-timevar scaling amount."))
-
- (lambda (w data)
- (set! src-timevar-amount initial-src-timevar-scale)
- (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) src-timevar-scale)
- )
-
- (lambda ()
- (effect-target-ok src-timevar-target))))
-
- (set! sliders
- (add-sliders src-timevar-dialog
- (list (list "Resample factor" 0.0 initial-src-timevar-scale 10.0
- (lambda (w data)
- (set! src-timevar-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
- 100))))
- (gtk_widget_show src-timevar-dialog)
- (set! src-timevar-envelope (xe-create-enved "src-timevar"
- (gtk_dialog_get_content_area (GTK_DIALOG src-timevar-dialog))
- #f
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG src-timevar-dialog))
- (lambda (target)
- (set! src-timevar-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT src-timevar-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless src-timevar-dialog
+ (let ((initial-src-timevar-scale 1.0)
+ (sliders ()))
+ (set! src-timevar-dialog
+ (make-effect-dialog
+ "Src-Timevar"
+
+ (lambda (w data)
+ (let ((env (scale-envelope (xe-envelope src-timevar-envelope)
+ src-timevar-scale)))
+ (if (eq? src-timevar-target 'sound)
+ (src-sound env)
+ (if (eq? src-timevar-target 'selection)
+ (if (selection-member? (selected-sound))
+ (src-selection env)
+ (display "no selection"))
+ (let ((pts (plausible-mark-samples)))
+ (if pts
+ (let* ((beg (car pts))
+ (end (cadr pts))
+ (len (- end beg)))
+ (src-channel (make-env env :length len) beg len (selected-sound)))))))))
+
+ (lambda (w data)
+ (help-dialog
+ "Src-Timevar"
+ "Move the slider to change the src-timevar scaling amount."))
+
+ (lambda (w data)
+ (set! src-timevar-amount initial-src-timevar-scale)
+ (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) src-timevar-scale)
+ )
+
+ (lambda ()
+ (effect-target-ok src-timevar-target))))
+
+ (set! sliders
+ (add-sliders src-timevar-dialog
+ (list (list "Resample factor" 0.0 initial-src-timevar-scale 10.0
+ (lambda (w data)
+ (set! src-timevar-scale (gtk_adjustment_get_value (GTK_ADJUSTMENT w))))
+ 100)))))
+ (gtk_widget_show src-timevar-dialog)
+ (set! src-timevar-envelope (xe-create-enved "src-timevar"
+ (gtk_dialog_get_content_area (GTK_DIALOG src-timevar-dialog))
+ #f
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG src-timevar-dialog))
+ (lambda (target)
+ (set! src-timevar-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT src-timevar-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f))
(activate-dialog src-timevar-dialog))
#f)
(set! freq-menu-list (cons (lambda ()
- (let ((new-label "Src-Timevar"))
- (change-label child new-label)))
+ (change-label child "Src-Timevar"))
freq-menu-list)))
)
@@ -1567,62 +1548,61 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not am-effect-dialog)
- (let ((initial-am-effect-amount 100.0)
- (sliders ()))
- (set! am-effect-dialog
- (make-effect-dialog
- "Amplitude modulation"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (am-effect am-effect-amount))
- am-effect-target
- (lambda (target samps)
- (format #f "effects-am ~A ~A" am-effect-amount
- (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
- (e (and need-env (xe-envelope am-effect-envelope))))
- (and e (format #f "'~A" e)))))
- #f))
-
- (lambda (w data)
- (help-dialog "Amplitude modulation"
- "Move the slider to change the modulation amount."))
-
- (lambda (w data)
- (set! am-effect-amount initial-am-effect-amount)
- (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) am-effect-amount)
- )
-
- (lambda ()
- (effect-target-ok am-effect-target))))
-
- (set! sliders
- (add-sliders am-effect-dialog
- (list (list "amplitude modulation" 0.0 initial-am-effect-amount 1000.0
- (lambda (w data)
- (set! am-effect-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1))))
- (gtk_widget_show am-effect-dialog)
- (set! am-effect-envelope (xe-create-enved "am"
- (gtk_dialog_get_content_area (GTK_DIALOG am-effect-dialog))
- #f
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG am-effect-dialog))
- (lambda (target)
- (set! am-effect-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT am-effect-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless am-effect-dialog
+ (let ((initial-am-effect-amount 100.0)
+ (sliders ()))
+ (set! am-effect-dialog
+ (make-effect-dialog
+ "Amplitude modulation"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (am-effect am-effect-amount))
+ am-effect-target
+ (lambda (target samps)
+ (format #f "effects-am ~A ~A" am-effect-amount
+ (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (e (and need-env (xe-envelope am-effect-envelope))))
+ (and e (format #f "'~A" e)))))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Amplitude modulation"
+ "Move the slider to change the modulation amount."))
+
+ (lambda (w data)
+ (set! am-effect-amount initial-am-effect-amount)
+ (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) am-effect-amount)
+ )
+
+ (lambda ()
+ (effect-target-ok am-effect-target))))
+
+ (set! sliders
+ (add-sliders am-effect-dialog
+ (list (list "amplitude modulation" 0.0 initial-am-effect-amount 1000.0
+ (lambda (w data)
+ (set! am-effect-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1)))))
+ (gtk_widget_show am-effect-dialog)
+ (set! am-effect-envelope (xe-create-enved "am"
+ (gtk_dialog_get_content_area (GTK_DIALOG am-effect-dialog))
+ #f
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG am-effect-dialog))
+ (lambda (target)
+ (set! am-effect-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT am-effect-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f))
(activate-dialog am-effect-dialog))
#f)
(set! mod-menu-list (cons (lambda ()
- (let ((new-label (format #f "Amplitude modulation (~1,2F)" am-effect-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Amplitude modulation (~1,2F)" am-effect-amount)))
mod-menu-list)))
;; -------- Ring modulation
@@ -1651,71 +1631,68 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not rm-dialog)
- (let ((initial-rm-frequency 100)
- (initial-rm-radians 100)
- (sliders ()))
- (set! rm-dialog
- (make-effect-dialog
- "Ring modulation"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (rm-effect rm-frequency (list 0 0 1 (hz->radians rm-radians))))
- rm-target
- (lambda (target samps)
- (format #f "effects-rm ~A ~A" rm-frequency
- (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
- (e (and need-env (xe-envelope rm-envelope))))
- (and e (format #f "'~A" e)))))
- #f))
-
- (lambda (w data)
- (help-dialog "Ring modulation"
- "Move the slider to change the ring modulation parameters."))
-
- (lambda (w data)
- (set! rm-frequency initial-rm-frequency)
- (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) rm-frequency)
- (set! rm-radians initial-rm-radians)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) rm-radians)
- )
-
- (lambda ()
- (effect-target-ok rm-target))))
-
- (set! sliders
- (add-sliders rm-dialog
- (list
- (list "modulation frequency" 0 initial-rm-frequency 1000
- (lambda (w data)
- (set! rm-frequency (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1)
- (list "modulation radians" 0 initial-rm-radians 360
- (lambda (w data)
- (set! rm-radians (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 1))))
- (gtk_widget_show rm-dialog)
- (set! rm-envelope (xe-create-enved "rm frequency"
- (gtk_dialog_get_content_area (GTK_DIALOG rm-dialog))
- #f
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG rm-dialog))
- (lambda (target)
- (set! rm-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT rm-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless rm-dialog
+ (let ((initial-rm-frequency 100)
+ (initial-rm-radians 100)
+ (sliders ()))
+ (set! rm-dialog
+ (make-effect-dialog
+ "Ring modulation"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (rm-effect rm-frequency (list 0 0 1 (hz->radians rm-radians))))
+ rm-target
+ (lambda (target samps)
+ (format #f "effects-rm ~A ~A" rm-frequency
+ (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
+ (e (and need-env (xe-envelope rm-envelope))))
+ (and e (format #f "'~A" e)))))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Ring modulation"
+ "Move the slider to change the ring modulation parameters."))
+
+ (lambda (w data)
+ (set! rm-frequency initial-rm-frequency)
+ (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) rm-frequency)
+ (set! rm-radians initial-rm-radians)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) rm-radians))
+
+ (lambda ()
+ (effect-target-ok rm-target))))
+
+ (set! sliders
+ (add-sliders rm-dialog
+ (list
+ (list "modulation frequency" 0 initial-rm-frequency 1000
+ (lambda (w data)
+ (set! rm-frequency (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1)
+ (list "modulation radians" 0 initial-rm-radians 360
+ (lambda (w data)
+ (set! rm-radians (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 1)))))
+ (gtk_widget_show rm-dialog)
+ (set! rm-envelope (xe-create-enved "rm frequency"
+ (gtk_dialog_get_content_area (GTK_DIALOG rm-dialog))
+ #f
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG rm-dialog))
+ (lambda (target)
+ (set! rm-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT rm-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f))
(activate-dialog rm-dialog))
#f)
(set! mod-menu-list (cons (lambda ()
- (let ((new-label (format #f "Ring modulation (~D ~D)"
- rm-frequency rm-radians)))
- (change-label child new-label)))
+ (change-label child (format #f "Ring modulation (~D ~D)" rm-frequency rm-radians)))
mod-menu-list)))
)
@@ -1780,72 +1757,71 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(g_signal_connect child "activate"
(lambda (w d)
;; add reverb-control-decay (with ramp?) and reverb-truncate
- (if (not reverb-dialog)
- (let ((initial-reverb-amount 0.1)
- (initial-reverb-filter 0.5)
- (initial-reverb-feedback 1.09)
- (sliders ()))
- (set! reverb-dialog
- (make-effect-dialog
- "McNabb reverb"
-
- (lambda (w data)
- (let ((snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (reverb-control? snd) #t)
- (set! (reverb-control-scale snd) reverb-amount)
- (set! (reverb-control-lowpass snd) reverb-filter)
- (set! (reverb-control-feedback snd) reverb-feedback)
- (if (eq? reverb-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? reverb-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w data)
- (help-dialog "McNabb reverb"
- "Reverberator from Michael McNabb.
+ (unless reverb-dialog
+ (let ((initial-reverb-amount 0.1)
+ (initial-reverb-filter 0.5)
+ (initial-reverb-feedback 1.09)
+ (sliders ()))
+ (set! reverb-dialog
+ (make-effect-dialog
+ "McNabb reverb"
+
+ (lambda (w data)
+ (let ((snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (reverb-control? snd) #t)
+ (set! (reverb-control-scale snd) reverb-amount)
+ (set! (reverb-control-lowpass snd) reverb-filter)
+ (set! (reverb-control-feedback snd) reverb-feedback)
+ (if (eq? reverb-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? reverb-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w data)
+ (help-dialog "McNabb reverb"
+ "Reverberator from Michael McNabb.
Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Move the sliders to change the reverb parameters."))
-
- (lambda (w data)
- (set! reverb-amount initial-reverb-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) reverb-amount)
- (set! reverb-filter initial-reverb-filter)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) reverb-filter)
- (set! reverb-feedback initial-reverb-feedback)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) reverb-feedback)
- )
-
- (lambda ()
- (effect-target-ok reverb-target))))
-
- (set! sliders
- (add-sliders reverb-dialog
- (list (list "reverb amount" 0.0 initial-reverb-amount 1.0
- (lambda (w data)
- (set! reverb-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "reverb filter" 0.0 initial-reverb-filter 1.0
- (lambda (w data)
- (set! reverb-filter (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100)
- (list "reverb feedback" 0.0 initial-reverb-feedback 1.25
- (lambda (w data)
- (set! reverb-feedback (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG reverb-dialog))
- (lambda (target)
- (set! reverb-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT reverb-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+
+ (lambda (w data)
+ (set! reverb-amount initial-reverb-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) reverb-amount)
+ (set! reverb-filter initial-reverb-filter)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) reverb-filter)
+ (set! reverb-feedback initial-reverb-feedback)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) reverb-feedback)
+ )
+
+ (lambda ()
+ (effect-target-ok reverb-target))))
+
+ (set! sliders
+ (add-sliders reverb-dialog
+ (list (list "reverb amount" 0.0 initial-reverb-amount 1.0
+ (lambda (w data)
+ (set! reverb-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "reverb filter" 0.0 initial-reverb-filter 1.0
+ (lambda (w data)
+ (set! reverb-filter (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100)
+ (list "reverb feedback" 0.0 initial-reverb-feedback 1.25
+ (lambda (w data)
+ (set! reverb-feedback (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG reverb-dialog))
+ (lambda (target)
+ (set! reverb-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT reverb-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog reverb-dialog))
#f)
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "McNabb reverb (~1,2F ~1,2F ~1,2F)" reverb-amount reverb-filter reverb-feedback)))
- (change-label child new-label)))
+ (change-label child (format #f "McNabb reverb (~1,2F ~1,2F ~1,2F)" reverb-amount reverb-filter reverb-feedback)))
reverb-menu-list)))
;; -------- Chowning reverb
@@ -1861,59 +1837,58 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not jc-reverb-dialog)
- (let ((initial-jc-reverb-decay 2.0)
- (initial-jc-reverb-volume 0.1)
- (sliders ()))
- (set! jc-reverb-dialog
- (make-effect-dialog
- "Chowning reverb"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (samps) (effects-jc-reverb samps jc-reverb-volume))
- jc-reverb-target
- (lambda (target samps)
- (format #f "effects-jc-reverb-1 ~A" jc-reverb-volume))
- (and (not jc-reverb-truncate) jc-reverb-decay)))
-
- (lambda (w data)
- (help-dialog "Chowning reverb"
- "Nice reverb from John Chowning. Move the sliders to set the reverb parameters."))
-
- (lambda (w data)
- (set! jc-reverb-decay initial-jc-reverb-decay)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) jc-reverb-decay)
- (set! jc-reverb-volume initial-jc-reverb-volume)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) jc-reverb-volume)
- )
-
- (lambda ()
- (effect-target-ok jc-reverb-target))))
-
- (set! sliders
- (add-sliders jc-reverb-dialog
- (list (list "decay duration" 0.0 initial-jc-reverb-decay 10.0
- (lambda (w data)
- (set! jc-reverb-decay (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "reverb volume" 0.0 initial-jc-reverb-volume 1.0
- (lambda (w data)
- (set! jc-reverb-volume (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG jc-reverb-dialog))
- (lambda (target)
- (set! jc-reverb-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT jc-reverb-dialog) "ok-button"))
- (effect-target-ok target)))
- (lambda (truncate)
- (set! jc-reverb-truncate truncate)))))
+ (unless jc-reverb-dialog
+ (let ((initial-jc-reverb-decay 2.0)
+ (initial-jc-reverb-volume 0.1)
+ (sliders ()))
+ (set! jc-reverb-dialog
+ (make-effect-dialog
+ "Chowning reverb"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (samps) (effects-jc-reverb samps jc-reverb-volume))
+ jc-reverb-target
+ (lambda (target samps)
+ (format #f "effects-jc-reverb-1 ~A" jc-reverb-volume))
+ (and (not jc-reverb-truncate) jc-reverb-decay)))
+
+ (lambda (w data)
+ (help-dialog "Chowning reverb"
+ "Nice reverb from John Chowning. Move the sliders to set the reverb parameters."))
+
+ (lambda (w data)
+ (set! jc-reverb-decay initial-jc-reverb-decay)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) jc-reverb-decay)
+ (set! jc-reverb-volume initial-jc-reverb-volume)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) jc-reverb-volume)
+ )
+
+ (lambda ()
+ (effect-target-ok jc-reverb-target))))
+
+ (set! sliders
+ (add-sliders jc-reverb-dialog
+ (list (list "decay duration" 0.0 initial-jc-reverb-decay 10.0
+ (lambda (w data)
+ (set! jc-reverb-decay (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "reverb volume" 0.0 initial-jc-reverb-volume 1.0
+ (lambda (w data)
+ (set! jc-reverb-volume (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG jc-reverb-dialog))
+ (lambda (target)
+ (set! jc-reverb-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT jc-reverb-dialog) "ok-button"))
+ (effect-target-ok target)))
+ (lambda (truncate)
+ (set! jc-reverb-truncate truncate)))))
(activate-dialog jc-reverb-dialog))
#f)
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "Chowning reverb (~1,2F ~1,2F)" jc-reverb-decay jc-reverb-volume)))
- (change-label child new-label)))
+ (change-label child (format #f "Chowning reverb (~1,2F ~1,2F)" jc-reverb-decay jc-reverb-volume)))
reverb-menu-list)))
;; -------- Convolution
@@ -1927,54 +1902,53 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not convolve-dialog)
- (let ((initial-convolve-sound-one 0)
- (initial-convolve-sound-two 1)
- (initial-convolve-amp 0.01)
- (sliders ()))
- (set! convolve-dialog
- (make-effect-dialog
- "Convolution"
-
- (lambda (w data)
- (effects-cnv convolve-sound-one convolve-amp convolve-sound-two))
-
- (lambda (w data)
- (help-dialog "Convolution"
- "Very simple convolution. Move the sliders to set the numbers of the soundfiles
+ (unless convolve-dialog
+ (let ((initial-convolve-sound-one 0)
+ (initial-convolve-sound-two 1)
+ (initial-convolve-amp 0.01)
+ (sliders ()))
+ (set! convolve-dialog
+ (make-effect-dialog
+ "Convolution"
+
+ (lambda (w data)
+ (effects-cnv convolve-sound-one convolve-amp convolve-sound-two))
+
+ (lambda (w data)
+ (help-dialog "Convolution"
+ "Very simple convolution. Move the sliders to set the numbers of the soundfiles
to be convolved and the amount for the amplitude scaler. Output will be scaled to floating-point values, resulting
in very large (but not clipped) amplitudes. Use the Normalize amplitude effect to rescale the output.
The convolution data file typically defines a natural reverberation source, and the output from this effect
can provide very striking reverb effects. You can find convolution data files on sites listed at
http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
- (lambda (w data)
- (set! convolve-sound-one initial-convolve-sound-one)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) convolve-sound-one)
- (set! convolve-sound-two initial-convolve-sound-two)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) convolve-sound-two)
- (set! convolve-amp initial-convolve-amp)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) convolve-amp)
- )))
-
- (set! sliders
- (add-sliders convolve-dialog
- (list (list "impulse response file" 0 initial-convolve-sound-one 24
- (lambda (w data)
- (set! convolve-sound-one (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1)
- (list "sound file" 0 initial-convolve-sound-two 24
- (lambda (w data)
- (set! convolve-sound-two (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 1)
- (list "amplitude" 0.0 initial-convolve-amp 0.10
- (lambda (w data)
- (set! convolve-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 1000))))))
+ (lambda (w data)
+ (set! convolve-sound-one initial-convolve-sound-one)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) convolve-sound-one)
+ (set! convolve-sound-two initial-convolve-sound-two)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) convolve-sound-two)
+ (set! convolve-amp initial-convolve-amp)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) convolve-amp)
+ )))
+
+ (set! sliders
+ (add-sliders convolve-dialog
+ (list (list "impulse response file" 0 initial-convolve-sound-one 24
+ (lambda (w data)
+ (set! convolve-sound-one (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1)
+ (list "sound file" 0 initial-convolve-sound-two 24
+ (lambda (w data)
+ (set! convolve-sound-two (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 1)
+ (list "amplitude" 0.0 initial-convolve-amp 0.10
+ (lambda (w data)
+ (set! convolve-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 1000))))))
(activate-dialog convolve-dialog))
#f)
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "Convolution (~D ~D ~1,2F)" convolve-sound-one convolve-sound-two convolve-amp)))
- (change-label child new-label)))
+ (change-label child (format #f "Convolution (~D ~D ~1,2F)" convolve-sound-one convolve-sound-two convolve-amp)))
reverb-menu-list)))
)
@@ -2015,15 +1989,15 @@ http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
0 len snd chn #f
(format #f "effects-position-sound ~A ~A" mono-snd pos))
(let ((e1 (make-env pos :length len)))
- (if (and (number? chn) (= chn 1))
- (map-channel (lambda (y)
- (+ y (* (env e1) (read-sample reader1))))
- 0 len snd chn #f
- (format #f "effects-position-sound ~A '~A" mono-snd pos))
- (map-channel (lambda (y)
- (+ y (* (- 1.0 (env e1)) (read-sample reader1))))
- 0 len snd chn #f
- (format #f "effects-position-sound ~A '~A" mono-snd pos)))))))
+ (map-channel
+ (if (eqv? chn 1)
+ (lambda (y)
+ (+ y (* (env e1) (read-sample reader1))))
+ (lambda (y)
+ (+ y (* (- 1.0 (env e1)) (read-sample reader1)))))
+ 0 len snd chn #f
+ (format #f "effects-position-sound ~A '~A" mono-snd pos))))))
+
(define* (effects-flange amount speed time beg dur snd chn)
(let* ((ri (make-rand-interp :frequency speed :amplitude amount))
@@ -2104,62 +2078,58 @@ http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not place-sound-dialog)
- (let ((initial-mono-snd 0)
- (initial-stereo-snd 1)
- (initial-pan-pos 45)
- (sliders ()))
- (set! place-sound-dialog
- (make-effect-dialog
- "Place sound"
-
- (lambda (w data)
- (let ((e (xe-envelope place-sound-envelope)))
- (if (not (equal? e (list 0.0 1.0 1.0 1.0)))
- (place-sound mono-snd stereo-snd e)
- (place-sound mono-snd stereo-snd pan-pos))))
-
- (lambda (w data)
- (help-dialog "Place sound"
- "Mixes mono sound into stereo sound field."))
-
- (lambda (w data)
- (set! mono-snd initial-mono-snd)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) mono-snd)
- (set! stereo-snd initial-stereo-snd)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) stereo-snd)
- (set! pan-pos initial-pan-pos)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) pan-pos)
- )
-
- (lambda ()
- (effect-target-ok place-sound-target))))
-
- (set! sliders
- (add-sliders place-sound-dialog
- (list (list "mono sound" 0 initial-mono-snd 50
- (lambda (w data)
- (set! mono-snd (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1)
- (list "stereo sound" 0 initial-stereo-snd 50
- (lambda (w data)
- (set! stereo-snd (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 1)
- (list "pan position" 0 initial-pan-pos 90
- (lambda (w data)
- (set! pan-pos (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 1))))
- (gtk_widget_show place-sound-dialog)
- (set! place-sound-envelope (xe-create-enved "panning"
- (gtk_dialog_get_content_area (GTK_DIALOG place-sound-dialog))
- #f
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope place-sound-envelope) (list 0.0 1.0 1.0 1.0))))
+ (unless place-sound-dialog
+ (let ((initial-mono-snd 0)
+ (initial-stereo-snd 1)
+ (initial-pan-pos 45)
+ (sliders ()))
+ (set! place-sound-dialog
+ (make-effect-dialog
+ "Place sound"
+
+ (lambda (w data)
+ (let ((e (xe-envelope place-sound-envelope)))
+ (place-sound mono-snd stereo-snd (if (not (equal? e '(0.0 1.0 1.0 1.0))) e pan-pos))))
+
+ (lambda (w data)
+ (help-dialog "Place sound"
+ "Mixes mono sound into stereo sound field."))
+
+ (lambda (w data)
+ (set! mono-snd initial-mono-snd)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) mono-snd)
+ (set! stereo-snd initial-stereo-snd)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) stereo-snd)
+ (set! pan-pos initial-pan-pos)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) pan-pos))
+
+ (lambda ()
+ (effect-target-ok place-sound-target))))
+
+ (set! sliders
+ (add-sliders place-sound-dialog
+ (list (list "mono sound" 0 initial-mono-snd 50
+ (lambda (w data)
+ (set! mono-snd (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1)
+ (list "stereo sound" 0 initial-stereo-snd 50
+ (lambda (w data)
+ (set! stereo-snd (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 1)
+ (list "pan position" 0 initial-pan-pos 90
+ (lambda (w data)
+ (set! pan-pos (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 1)))))
+ (gtk_widget_show place-sound-dialog)
+ (set! place-sound-envelope (xe-create-enved "panning"
+ (gtk_dialog_get_content_area (GTK_DIALOG place-sound-dialog))
+ #f
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope place-sound-envelope) (list 0.0 1.0 1.0 1.0)))
(activate-dialog place-sound-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Place sound (~D ~D ~D)" mono-snd stereo-snd pan-pos)))
- (change-label child new-label)))
+ (change-label child (format #f "Place sound (~D ~D ~D)" mono-snd stereo-snd pan-pos)))
misc-menu-list)))
;; -------- Insert silence (at cursor, silence-amount in secs)
@@ -2171,36 +2141,35 @@ http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not silence-dialog)
- (let ((initial-silence-amount 1.0)
- (sliders ()))
- (set! silence-dialog
- (make-effect-dialog
- "Add silence"
-
- (lambda (w data)
- (insert-silence (cursor) (floor (* (srate) silence-amount))))
-
- (lambda (w data)
- (help-dialog "Add silence"
- "Move the slider to change the number of seconds of silence added at the cursor position."))
-
- (lambda (w data)
- (set! silence-amount initial-silence-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) silence-amount)
- )))
-
- (set! sliders
- (add-sliders silence-dialog
- (list (list "silence" 0.0 initial-silence-amount 5.0
- (lambda (w data)
- (set! silence-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100))))))
+ (unless silence-dialog
+ (let ((initial-silence-amount 1.0)
+ (sliders ()))
+ (set! silence-dialog
+ (make-effect-dialog
+ "Add silence"
+
+ (lambda (w data)
+ (insert-silence (cursor) (floor (* (srate) silence-amount))))
+
+ (lambda (w data)
+ (help-dialog "Add silence"
+ "Move the slider to change the number of seconds of silence added at the cursor position."))
+
+ (lambda (w data)
+ (set! silence-amount initial-silence-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) silence-amount)
+ )))
+
+ (set! sliders
+ (add-sliders silence-dialog
+ (list (list "silence" 0.0 initial-silence-amount 5.0
+ (lambda (w data)
+ (set! silence-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100))))))
(activate-dialog silence-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Add silence (~1,2F)" silence-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Add silence (~1,2F)" silence-amount)))
misc-menu-list)))
;;; -------- Contrast (brightness control)
@@ -2214,58 +2183,57 @@ http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not contrast-dialog)
- (let ((initial-contrast-amount 1.0)
- (sliders ()))
- (set! contrast-dialog
- (make-effect-dialog
- "Contrast enhancement"
-
- (lambda (w data)
- (let ((peak (maxamp))
- (snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (contrast-control? snd) #t)
- (set! (contrast-control snd) contrast-amount)
- (set! (contrast-control-amp snd) (/ 1.0 peak))
- (set! (amp-control snd) peak)
- (if (eq? contrast-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? contrast-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w data)
- (help-dialog "Contrast enhancement"
- "Move the slider to change the contrast intensity."))
-
- (lambda (w data)
- (set! contrast-amount initial-contrast-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) contrast-amount)
- )
-
- (lambda ()
- (effect-target-ok contrast-target))))
-
- (set! sliders
- (add-sliders contrast-dialog
- (list (list "contrast enhancement" 0.0 initial-contrast-amount 10.0
- (lambda (w data)
- (set! contrast-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG contrast-dialog))
- (lambda (target)
- (set! contrast-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT contrast-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless contrast-dialog
+ (let ((initial-contrast-amount 1.0)
+ (sliders ()))
+ (set! contrast-dialog
+ (make-effect-dialog
+ "Contrast enhancement"
+
+ (lambda (w data)
+ (let ((peak (maxamp))
+ (snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (contrast-control? snd) #t)
+ (set! (contrast-control snd) contrast-amount)
+ (set! (contrast-control-amp snd) (/ 1.0 peak))
+ (set! (amp-control snd) peak)
+ (if (eq? contrast-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? contrast-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w data)
+ (help-dialog "Contrast enhancement"
+ "Move the slider to change the contrast intensity."))
+
+ (lambda (w data)
+ (set! contrast-amount initial-contrast-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) contrast-amount)
+ )
+
+ (lambda ()
+ (effect-target-ok contrast-target))))
+
+ (set! sliders
+ (add-sliders contrast-dialog
+ (list (list "contrast enhancement" 0.0 initial-contrast-amount 10.0
+ (lambda (w data)
+ (set! contrast-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG contrast-dialog))
+ (lambda (target)
+ (set! contrast-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT contrast-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog contrast-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Contrast enhancement (~1,2F)" contrast-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Contrast enhancement (~1,2F)" contrast-amount)))
misc-menu-list)))
;; -------- Cross synthesis
@@ -2282,71 +2250,70 @@ http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not cross-synth-dialog)
- (let ((initial-cross-synth-sound 1)
- (initial-cross-synth-amp .5)
- (initial-cross-synth-fft-size 128)
- (initial-cross-synth-radius 6.0)
- (sliders ()))
- (set! cross-synth-dialog
- (make-effect-dialog
- "Cross synthesis"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (effects-cross-synthesis cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
- cross-synth-target
- (lambda (target samps)
- (format #f "effects-cross-synthesis-1 ~A ~A ~A ~A"
- cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
- #f))
-
- (lambda (w data)
- (help-dialog "Cross synthesis"
- "The sliders set the number of the soundfile to be cross-synthesized,
+ (unless cross-synth-dialog
+ (let ((initial-cross-synth-sound 1)
+ (initial-cross-synth-amp .5)
+ (initial-cross-synth-fft-size 128)
+ (initial-cross-synth-radius 6.0)
+ (sliders ()))
+ (set! cross-synth-dialog
+ (make-effect-dialog
+ "Cross synthesis"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (effects-cross-synthesis cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
+ cross-synth-target
+ (lambda (target samps)
+ (format #f "effects-cross-synthesis-1 ~A ~A ~A ~A"
+ cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Cross synthesis"
+ "The sliders set the number of the soundfile to be cross-synthesized,
the synthesis amplitude, the FFT size, and the radius value."))
-
- (lambda (w data)
- (set! cross-synth-sound initial-cross-synth-sound)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) cross-synth-sound)
- (set! cross-synth-amp initial-cross-synth-amp)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) cross-synth-amp)
- (set! cross-synth-fft-size initial-cross-synth-fft-size)
- (set! cross-synth-radius initial-cross-synth-radius)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) cross-synth-radius)
- )
-
- (lambda ()
- (effect-target-ok cross-synth-target))))
-
- (set! sliders
- (add-sliders cross-synth-dialog
- (list (list "input sound" 0 initial-cross-synth-sound 20
- (lambda (w data)
- (set! cross-synth-sound (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 1)
- (list "amplitude" 0.0 initial-cross-synth-amp 1.0
- (lambda (w data)
- (set! cross-synth-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100)
- (list "radius" 0.0 initial-cross-synth-radius 360.0
- (lambda (w data)
- (set! cross-synth-radius (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG cross-synth-dialog))
- (lambda (target)
- (set! cross-synth-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT cross-synth-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+
+ (lambda (w data)
+ (set! cross-synth-sound initial-cross-synth-sound)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 0)) cross-synth-sound)
+ (set! cross-synth-amp initial-cross-synth-amp)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 1)) cross-synth-amp)
+ (set! cross-synth-fft-size initial-cross-synth-fft-size)
+ (set! cross-synth-radius initial-cross-synth-radius)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (sliders 2)) cross-synth-radius)
+ )
+
+ (lambda ()
+ (effect-target-ok cross-synth-target))))
+
+ (set! sliders
+ (add-sliders cross-synth-dialog
+ (list (list "input sound" 0 initial-cross-synth-sound 20
+ (lambda (w data)
+ (set! cross-synth-sound (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 1)
+ (list "amplitude" 0.0 initial-cross-synth-amp 1.0
+ (lambda (w data)
+ (set! cross-synth-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100)
+ (list "radius" 0.0 initial-cross-synth-radius 360.0
+ (lambda (w data)
+ (set! cross-synth-radius (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG cross-synth-dialog))
+ (lambda (target)
+ (set! cross-synth-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT cross-synth-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog cross-synth-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Cross synthesis (~D ~1,2F ~D ~1,2F)"
- cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius)))
- (change-label child new-label)))
+ (change-label child (format #f "Cross synthesis (~D ~1,2F ~D ~1,2F)"
+ cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius)))
misc-menu-list)))
;; -------- Flange and phasing
@@ -2361,74 +2328,73 @@ the synthesis amplitude, the FFT size, and the radius value."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not flange-dialog)
- (let ((initial-flange-speed 2.0)
- (initial-flange-amount 5.0)
- (initial-flange-time 0.001)
- (sliders ()))
- (set! flange-dialog
- (make-effect-dialog
- "Flange"
-
- (lambda (w data)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (let* ((ri (make-rand-interp :frequency flange-speed :amplitude flange-amount))
- (len (round (* flange-time (srate))))
- (del (make-delay len :max-size (round (+ len flange-amount 1)))))
- (lambda (inval)
- (* .75 (+ inval
- (delay del
- inval
- (rand-interp ri)))))))
- flange-target
- (lambda (target samps)
- (format #f "effects-flange ~A ~A ~A" flange-amount flange-speed flange-time))
- #f))
-
- (lambda (w data)
- (help-dialog "Flange"
- "Move the sliders to change the flange speed, amount, and time"))
-
- (lambda (w data)
- (set! flange-speed initial-flange-speed)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) flange-speed)
- (set! flange-amount initial-flange-amount)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) flange-amount)
- (set! flange-time initial-flange-time)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) flange-time)
- )
-
- (lambda ()
- (effect-target-ok flange-target))))
-
- (set! sliders
- (add-sliders flange-dialog
- (list (list "flange speed" 0.0 initial-flange-speed 100.0
- (lambda (w data)
- (set! flange-speed (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 10)
- (list "flange amount" 0.0 initial-flange-amount 100.0
- (lambda (w data)
- (set! flange-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 10)
- ;; flange time ought to use a non-linear scale (similar to amp in control panel)
- (list "flange time" 0.0 initial-flange-time 1.0
- (lambda (w data)
- (set! flange-time (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG flange-dialog))
- (lambda (target)
- (set! flange-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT flange-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless flange-dialog
+ (let ((initial-flange-speed 2.0)
+ (initial-flange-amount 5.0)
+ (initial-flange-time 0.001)
+ (sliders ()))
+ (set! flange-dialog
+ (make-effect-dialog
+ "Flange"
+
+ (lambda (w data)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (let* ((ri (make-rand-interp :frequency flange-speed :amplitude flange-amount))
+ (len (round (* flange-time (srate))))
+ (del (make-delay len :max-size (round (+ len flange-amount 1)))))
+ (lambda (inval)
+ (* .75 (+ inval
+ (delay del
+ inval
+ (rand-interp ri)))))))
+ flange-target
+ (lambda (target samps)
+ (format #f "effects-flange ~A ~A ~A" flange-amount flange-speed flange-time))
+ #f))
+
+ (lambda (w data)
+ (help-dialog "Flange"
+ "Move the sliders to change the flange speed, amount, and time"))
+
+ (lambda (w data)
+ (set! flange-speed initial-flange-speed)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) flange-speed)
+ (set! flange-amount initial-flange-amount)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) flange-amount)
+ (set! flange-time initial-flange-time)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) flange-time)
+ )
+
+ (lambda ()
+ (effect-target-ok flange-target))))
+
+ (set! sliders
+ (add-sliders flange-dialog
+ (list (list "flange speed" 0.0 initial-flange-speed 100.0
+ (lambda (w data)
+ (set! flange-speed (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 10)
+ (list "flange amount" 0.0 initial-flange-amount 100.0
+ (lambda (w data)
+ (set! flange-amount (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 10)
+ ;; flange time ought to use a non-linear scale (similar to amp in control panel)
+ (list "flange time" 0.0 initial-flange-time 1.0
+ (lambda (w data)
+ (set! flange-time (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG flange-dialog))
+ (lambda (target)
+ (set! flange-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT flange-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog flange-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Flange (~1,2F ~1,2F ~1,3F)" flange-speed flange-amount flange-time)))
- (change-label child new-label)))
+ (change-label child (format #f "Flange (~1,2F ~1,2F ~1,3F)" flange-speed flange-amount flange-time)))
misc-menu-list)))
;; -------- Randomize phase
@@ -2440,36 +2406,35 @@ the synthesis amplitude, the FFT size, and the radius value."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not random-phase-dialog)
- (let ((initial-random-phase-amp-scaler 3.14)
- (sliders ()))
- (set! random-phase-dialog
- (make-effect-dialog
- "Randomize phase"
-
- (lambda (w data)
- (rotate-phase (lambda (x) (random random-phase-amp-scaler))))
-
- (lambda (w data)
- (help-dialog "Randomize phase"
- "Move the slider to change the randomization amplitude scaler."))
-
- (lambda (w data)
- (set! random-phase-amp-scaler initial-random-phase-amp-scaler)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) random-phase-amp-scaler)
- )))
-
- (set! sliders
- (add-sliders random-phase-dialog
- (list (list "amplitude scaler" 0.0 initial-random-phase-amp-scaler 100.0
- (lambda (w data)
- (set! random-phase-amp-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100))))))
+ (unless random-phase-dialog
+ (let ((initial-random-phase-amp-scaler 3.14)
+ (sliders ()))
+ (set! random-phase-dialog
+ (make-effect-dialog
+ "Randomize phase"
+
+ (lambda (w data)
+ (rotate-phase (lambda (x) (random random-phase-amp-scaler))))
+
+ (lambda (w data)
+ (help-dialog "Randomize phase"
+ "Move the slider to change the randomization amplitude scaler."))
+
+ (lambda (w data)
+ (set! random-phase-amp-scaler initial-random-phase-amp-scaler)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) random-phase-amp-scaler)
+ )))
+
+ (set! sliders
+ (add-sliders random-phase-dialog
+ (list (list "amplitude scaler" 0.0 initial-random-phase-amp-scaler 100.0
+ (lambda (w data)
+ (set! random-phase-amp-scaler (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100))))))
(activate-dialog random-phase-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Randomize phase (~1,2F)" random-phase-amp-scaler)))
- (change-label child new-label)))
+ (change-label child (format #f "Randomize phase (~1,2F)" random-phase-amp-scaler)))
misc-menu-list)))
;; -------- Robotize
@@ -2484,72 +2449,68 @@ the synthesis amplitude, the FFT size, and the radius value."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not robotize-dialog)
- (let ((initial-samp-rate 1.0)
- (initial-osc-amp 0.3)
- (initial-osc-freq 20)
- (sliders ()))
- (set! robotize-dialog
- (make-effect-dialog
- "Robotize"
-
- (lambda (w data)
- (let ((ms (and (eq? robotize-target 'marks)
- (plausible-mark-samples))))
- (effects-fp samp-rate osc-amp osc-freq
- (if (eq? robotize-target 'sound)
- 0
- (if (eq? robotize-target 'selection)
- (selection-position)
- (car ms)))
- (if (eq? robotize-target 'sound)
- (framples)
- (if (eq? robotize-target 'selection)
- (selection-framples)
- (- (cadr ms) (car ms)))))))
-
- (lambda (w data)
- (help-dialog "Robotize"
- "Move the sliders to set the sample rate, oscillator amplitude, and oscillator frequency."))
-
- (lambda (w data)
- (set! samp-rate initial-samp-rate)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) samp-rate)
- (set! osc-amp initial-osc-amp)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) osc-amp)
- (set! osc-freq initial-osc-freq)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) osc-freq)
- )
-
- (lambda ()
- (effect-target-ok robotize-target))))
-
- (set! sliders
- (add-sliders robotize-dialog
- (list (list "sample rate" 0.0 initial-samp-rate 2.0
- (lambda (w data)
- (set! samp-rate (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "oscillator amplitude" 0.0 initial-osc-amp 1.0
- (lambda (w data)
- (set! osc-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100)
- (list "oscillator frequency" 0.0 initial-osc-freq 60
- (lambda (w data)
- (set! osc-freq (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG robotize-dialog))
- (lambda (target)
- (set! robotize-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT robotize-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless robotize-dialog
+ (let ((initial-samp-rate 1.0)
+ (initial-osc-amp 0.3)
+ (initial-osc-freq 20)
+ (sliders ()))
+ (set! robotize-dialog
+ (make-effect-dialog
+ "Robotize"
+
+ (lambda (w data)
+ (let ((ms (and (eq? robotize-target 'marks)
+ (plausible-mark-samples))))
+ (effects-fp samp-rate osc-amp osc-freq
+ (if (eq? robotize-target 'sound)
+ (values 0
+ (framples))
+ (if (eq? robotize-target 'selection)
+ (values (selection-position)
+ (selection-framples))
+ (values (car ms)
+ (- (cadr ms) (car ms))))))))
+ (lambda (w data)
+ (help-dialog "Robotize"
+ "Move the sliders to set the sample rate, oscillator amplitude, and oscillator frequency."))
+
+ (lambda (w data)
+ (set! samp-rate initial-samp-rate)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) samp-rate)
+ (set! osc-amp initial-osc-amp)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) osc-amp)
+ (set! osc-freq initial-osc-freq)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (caddr sliders)) osc-freq)
+ )
+
+ (lambda ()
+ (effect-target-ok robotize-target))))
+
+ (set! sliders
+ (add-sliders robotize-dialog
+ (list (list "sample rate" 0.0 initial-samp-rate 2.0
+ (lambda (w data)
+ (set! samp-rate (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "oscillator amplitude" 0.0 initial-osc-amp 1.0
+ (lambda (w data)
+ (set! osc-amp (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100)
+ (list "oscillator frequency" 0.0 initial-osc-freq 60
+ (lambda (w data)
+ (set! osc-freq (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 2)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG robotize-dialog))
+ (lambda (target)
+ (set! robotize-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT robotize-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog robotize-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Robotize (~1,2F ~1,2F ~1,2F)" samp-rate osc-amp osc-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "Robotize (~1,2F ~1,2F ~1,2F)" samp-rate osc-amp osc-freq)))
misc-menu-list)))
;; -------- Rubber sound
@@ -2562,46 +2523,45 @@ the synthesis amplitude, the FFT size, and the radius value."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not rubber-dialog)
- (let ((initial-rubber-factor 1.0)
- (sliders ()))
- (set! rubber-dialog
- (make-effect-dialog
- "Rubber sound"
-
- (lambda (w data)
- (rubber-sound rubber-factor))
-
- (lambda (w data)
- (help-dialog "Rubber sound"
- "Stretches or contracts the time of a sound. Move the slider to change the stretch factor."))
-
- (lambda (w data)
- (set! rubber-factor initial-rubber-factor)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) rubber-factor)
- )
-
- (lambda ()
- (effect-target-ok rubber-target))))
-
- (set! sliders
- (add-sliders rubber-dialog
- (list (list "stretch factor" 0.0 initial-rubber-factor 5.0
- (lambda (w data)
- (set! rubber-factor (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG rubber-dialog))
- (lambda (target)
- (set! rubber-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT rubber-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless rubber-dialog
+ (let ((initial-rubber-factor 1.0)
+ (sliders ()))
+ (set! rubber-dialog
+ (make-effect-dialog
+ "Rubber sound"
+
+ (lambda (w data)
+ (rubber-sound rubber-factor))
+
+ (lambda (w data)
+ (help-dialog "Rubber sound"
+ "Stretches or contracts the time of a sound. Move the slider to change the stretch factor."))
+
+ (lambda (w data)
+ (set! rubber-factor initial-rubber-factor)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) rubber-factor)
+ )
+
+ (lambda ()
+ (effect-target-ok rubber-target))))
+
+ (set! sliders
+ (add-sliders rubber-dialog
+ (list (list "stretch factor" 0.0 initial-rubber-factor 5.0
+ (lambda (w data)
+ (set! rubber-factor (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG rubber-dialog))
+ (lambda (target)
+ (set! rubber-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT rubber-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog rubber-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Rubber sound (~1,2F)" rubber-factor)))
- (change-label child new-label)))
+ (change-label child (format #f "Rubber sound (~1,2F)" rubber-factor)))
misc-menu-list)))
;; -------- Wobble
@@ -2616,66 +2576,61 @@ the synthesis amplitude, the FFT size, and the radius value."))
(gtk_widget_show child)
(g_signal_connect child "activate"
(lambda (w d)
- (if (not wobble-dialog)
- (let ((initial-wobble-frequency 50)
- (initial-wobble-amplitude 0.5)
- (sliders ()))
- (set! wobble-dialog
- (make-effect-dialog
- "Wobble"
-
- (lambda (w data)
- (let ((ms (and (eq? wobble-target 'marks)
- (plausible-mark-samples))))
- (effects-hello-dentist
- wobble-frequency wobble-amplitude
- (if (eq? wobble-target 'sound)
- 0
- (if (eq? wobble-target 'selection)
- (selection-position)
- (car ms)))
- (if (eq? wobble-target 'sound)
- (framples)
- (if (eq? wobble-target 'selection)
- (selection-framples)
- (- (cadr ms) (car ms)))))))
-
- (lambda (w data)
- (help-dialog "Wobble"
- "Move the sliders to set the wobble frequency and amplitude."))
-
- (lambda (w data)
- (set! wobble-frequency initial-wobble-frequency)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) wobble-frequency)
- (set! wobble-amplitude initial-wobble-amplitude)
- (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) wobble-amplitude)
- )
-
- (lambda ()
- (effect-target-ok wobble-target))))
-
- (set! sliders
- (add-sliders wobble-dialog
- (list (list "wobble frequency" 0 initial-wobble-frequency 100
- (lambda (w data)
- (set! wobble-frequency (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
- 100)
- (list "wobble amplitude" 0.0 initial-wobble-amplitude 1.0
- (lambda (w data)
- (set! wobble-amplitude (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
- 100))))
- (add-target (gtk_dialog_get_content_area (GTK_DIALOG wobble-dialog))
- (lambda (target)
- (set! wobble-target target)
- (gtk_widget_set_sensitive
- (GTK_WIDGET (g_object_get_data (G_OBJECT wobble-dialog) "ok-button"))
- (effect-target-ok target)))
- #f)))
+ (unless wobble-dialog
+ (let ((initial-wobble-frequency 50)
+ (initial-wobble-amplitude 0.5)
+ (sliders ()))
+ (set! wobble-dialog
+ (make-effect-dialog
+ "Wobble"
+
+ (lambda (w data)
+ (let ((ms (and (eq? wobble-target 'marks)
+ (plausible-mark-samples))))
+ (effects-hello-dentist wobble-frequency wobble-amplitude
+ (if (eq? wobble-target 'sound)
+ (values 0
+ (framples))
+ (if (eq? wobble-target 'selection)
+ (values (selection-position)
+ (selection-framples))
+ (values (car ms)
+ (- (cadr ms) (car ms))))))))
+ (lambda (w data)
+ (help-dialog "Wobble"
+ "Move the sliders to set the wobble frequency and amplitude."))
+
+ (lambda (w data)
+ (set! wobble-frequency initial-wobble-frequency)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (car sliders)) wobble-frequency)
+ (set! wobble-amplitude initial-wobble-amplitude)
+ (gtk_adjustment_set_value (GTK_ADJUSTMENT (cadr sliders)) wobble-amplitude)
+ )
+
+ (lambda ()
+ (effect-target-ok wobble-target))))
+
+ (set! sliders
+ (add-sliders wobble-dialog
+ (list (list "wobble frequency" 0 initial-wobble-frequency 100
+ (lambda (w data)
+ (set! wobble-frequency (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 0)))))
+ 100)
+ (list "wobble amplitude" 0.0 initial-wobble-amplitude 1.0
+ (lambda (w data)
+ (set! wobble-amplitude (gtk_adjustment_get_value (GTK_ADJUSTMENT (sliders 1)))))
+ 100))))
+ (add-target (gtk_dialog_get_content_area (GTK_DIALOG wobble-dialog))
+ (lambda (target)
+ (set! wobble-target target)
+ (gtk_widget_set_sensitive
+ (GTK_WIDGET (g_object_get_data (G_OBJECT wobble-dialog) "ok-button"))
+ (effect-target-ok target)))
+ #f)))
(activate-dialog wobble-dialog))
#f)
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Wobble (~1,2F ~1,2F)" wobble-frequency wobble-amplitude)))
- (change-label child new-label)))
+ (change-label child (format #f "Wobble (~1,2F ~1,2F)" wobble-frequency wobble-amplitude)))
misc-menu-list)))
)
@@ -2687,33 +2642,32 @@ the synthesis amplitude, the FFT size, and the radius value."))
(add-to-menu effects-menu "Octave-down" (lambda () (down-oct 2)))
(add-to-menu effects-menu "Remove clicks"
(lambda ()
- (define (find-click loc)
- (let ((reader (make-sampler loc))
- (mmax (make-moving-max 10))
- (samp0 0.0)
- (samp1 0.0)
- (samp2 0.0)
- (len (framples)))
- (call-with-exit
- (lambda (return)
- (do ((ctr loc (+ ctr 1)))
- ((= ctr len) #f)
- (set! samp0 samp1)
- (set! samp1 samp2)
- (set! samp2 (next-sample reader))
- (let ((local-max (max .1 (moving-max mmax samp0))))
- (if (and (> (abs (- samp0 samp1)) local-max)
- (> (abs (- samp1 samp2)) local-max)
- (< (abs (- samp0 samp2)) (/ local-max 2)))
- (return (- ctr 1)))))))))
- (define (remove-click loc)
+ (let remove-click ((loc 0))
+ (define (find-click loc)
+ (let ((reader (make-sampler loc))
+ (mmax (make-moving-max 10))
+ (samp0 0.0000)
+ (samp1 0.0000)
+ (samp2 0.0000)
+ (len (framples)))
+ (call-with-exit
+ (lambda (return)
+ (do ((ctr loc (+ ctr 1)))
+ ((= ctr len) #f)
+ (set! samp0 samp1)
+ (set! samp1 samp2)
+ (set! samp2 (next-sample reader))
+ (let ((local-max (max 0.1 (moving-max mmax samp0))))
+ (if (and (> (abs (- samp0 samp1)) local-max)
+ (> (abs (- samp1 samp2)) local-max)
+ (< (abs (- samp0 samp2)) (/ local-max 2)))
+ (return (- ctr 1)))))))))
(let ((click (find-click loc)))
(if click
(begin
(smooth-sound (- click 2) 4)
- (remove-click (+ click 2))))))
- (remove-click 0)))
-
+ (remove-click (+ click 2))))))))
+
(define* (effects-remove-dc snd chn)
(let* ((len (framples snd chn))
(data (make-float-vector len))
diff --git a/index.html b/index.html
index 20fb562..c1ecbba 100644
--- a/index.html
+++ b/index.html
@@ -37,360 +37,361 @@
</head>
<body class="body">
<div class="topheader">Index</div>
-<!-- created 16-Oct-15 16:57 PDT -->
+<!-- created 18-Mar-16 05:58 PDT -->
<table>
- <tr><td><em class=tab><a href="s7.html#sharpreaders">*#readers*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#epsleftmargin">eps-left-margin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebandpass">make-bandpass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-xcoeffs">mus-xcoeffs</a></em></td><td></td><td><em class=tab><a href="sndclm.html#secondstosamples">seconds->samples</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#epssize">eps-size</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebandstop">make-bandstop</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ycoeff">mus-ycoeff</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectall">select-all</a></em></td></tr>
- <tr><td class="green"><div class="centered">-</div></td><td></td><td><em class=tab><a href="sndclm.html#ercos">ercos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-bess">make-bess</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ycoeffs">mus-ycoeffs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectchannel">select-channel</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#ercos?">ercos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebiquad">make-biquad</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#selectchannelhook">select-channel-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#tobytevector">->byte-vector</a></em></td><td></td><td><em class=tab><a href="s7.html#errorhook">*error-hook*</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebirds">make-birds</a></em></td><td></td><td class="green"><div class="centered">N</div></td><td></td><td><em class=tab><a href="extsnd.html#selectsound">select-sound</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#erssb">erssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-blackman">make-blackman</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#selectsoundhook">select-sound-hook</a></em></td></tr>
- <tr><td class="green"><div class="centered">A</div></td><td></td><td><em class=tab><a href="sndclm.html#erssb?">erssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-brown-noise">make-brown-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#n1cos">n1cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedchannel">selected-channel</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#evenmultiple">even-multiple</a></em></td><td></td><td><em class=tab><a href="s7.html#makebytevector">make-byte-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#n1cos?">n1cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selecteddatacolor">selected-data-color</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#abcos">abcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#evenweight">even-weight</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makedropsite">make-channel-drop-site</a></em></td><td></td><td><em class=tab><a href="extsnd.html#nameclickhook">name-click-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedgraphcolor">selected-graph-color</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#abcos?">abcos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#everysample">every-sample?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makecolor">make-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nchoosekcos">nchoosekcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedsound">selected-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#abort">abort</a></em></td><td></td><td><em class=tab><a href="extsnd.html#exit">exit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-comb">make-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nchoosekcos?">nchoosekcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selection">selection</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#absin">absin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#exithook">exit-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makecombbank">make-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos">ncos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectiontomix">selection->mix</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#absin?">absin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrol">expand-control</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-convolve">make-convolve</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos2?">ncos2?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionchans">selection-chans</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#addampcontrols">add-amp-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolbounds">expand-control-bounds</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-delay">make-delay</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos4?">ncos4?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncolor">selection-color</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addcolormap">add-colormap</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolhop">expand-control-hop</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makedifferentiator">make-differentiator</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos?">ncos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncontext">selection-context</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#adddeleteoption">add-delete-option</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontroljitter">expand-control-jitter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-env">make-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsound">new-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncreatesregion">selection-creates-region</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#adddirectorytoviewfileslist">add-directory-to-view-files-list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrollength">expand-control-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-eoddcos">make-eoddcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsounddialog">new-sound-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionframples">selection-framples</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addfilefilter">add-file-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolramp">expand-control-ramp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ercos">make-ercos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsoundhook">new-sound-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmaxamp">selection-maxamp</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addfilesorter">add-file-sorter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolp">expand-control?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-erssb">make-erssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newwidgethook">new-widget-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmaxampposition">selection-maxamp-position</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addfiletoviewfileslist">add-file-to-view-files-list</a></em></td><td></td><td><em class=tab><a href="sndscm.html#explodesf2">explode-sf2</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-fft-window">make-fft-window</a></em></td><td></td><td><em class=tab><a href="extsnd.html#nextsample">next-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmember">selection-member?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addmark">add-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#exponentially-weighted-moving-average">exponentially-weighted-moving-average</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filetoframple">make-file->frample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssb">nkssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#selectionmembers">selection-members</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#addmarkpane">add-mark-pane</a></em></td><td></td><td><em class=tab><a href="sndscm.html#expsnd">expsnd</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filetosample">make-file->sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssbinterp">nkssb-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionposition">selection-position</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addplayer">add-player</a></em></td><td></td><td><em class=tab><a href="sndscm.html#expsrc">expsrc</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filter">make-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssb?">nkssb?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#selectionrms">selection-rms</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addsoundfileextension">add-sound-file-extension</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#make-filtered-comb">make-filtered-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddcos">noddcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionsrate">selection-srate</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addsourcefileextension">add-source-file-extension</a></em></td><td></td><td class="green"><div class="centered">F</div></td><td></td><td><em class=tab><a href="sndclm.html#makefilteredcombbank">make-filtered-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddcos?">noddcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionok">selection?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addtomainmenu">add-to-main-menu</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#make-fir-coeffs">make-fir-coeffs</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddsin">noddsin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionstuff"><b>Selections</b></a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addtomenu">add-to-menu</a></em></td><td></td><td><em class=tab><a href="s7.html#featureslist">*features*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-fir-filter">make-fir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddsin?">noddsin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#setsamples">set-samples</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#addtooltip">add-tooltip</a></em></td><td></td><td><em class=tab><a href="sndscm.html#cellon">feedback fm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-firmant">make-firmant</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddssb">noddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#shortfilename">short-file-name</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#addtransform">add-transform</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fft">fft</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makefv">make-float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddssb?">noddssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showaxes">show-axes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#spectra">additive synthesis</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftcancel">fft-cancel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-flocsig">make-flocsig</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noid">noid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showcontrols">show-controls</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-sawtooth-wave">adjustable-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftedit">fft-edit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-fmssb">make-fmssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#cleandoc"><b>Noise Reduction</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#showdiskspace">show-disk-space</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-sawtooth-wave?">adjustable-sawtooth-wave?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftenvedit">fft-env-edit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-formant">make-formant</a></em></td><td></td><td><em class=tab><a href="extsnd.html#normalizechannel">normalize-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showfullduration">show-full-duration</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-square-wave">adjustable-square-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftenvinterp">fft-env-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makeformantbank">make-formant-bank</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizeenvelope">normalize-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showfullrange">show-full-range</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-square-wave?">adjustable-square-wave?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftlogfrequency">fft-log-frequency</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-frampletofile">make-frample->file</a></em></td><td></td><td><em class=tab><a href="sndclm.html#normalizepartials">normalize-partials</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showgrid">show-grid</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-triangle-wave">adjustable-triangle-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftlogmagnitude">fft-log-magnitude</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-granulate">make-granulate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizesound">normalize-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showindices">show-indices</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#adjustable-triangle-wave?">adjustable-triangle-wave?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftsmoother">fft-smoother</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makegraphdata">make-graph-data</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizedmix">normalized-mix</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showlistener">show-listener</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#afterapplycontrolshook">after-apply-controls-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftsquelch">fft-squelch</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-green-noise">make-green-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#notch">notch</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showmarks">show-marks</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#afteredithook">after-edit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftwindow">fft-window</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-green-noise-interp">make-green-noise-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchchannel">notch-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showmixwaveforms">show-mix-waveforms</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#aftergraphhook">after-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftalpha">fft-window-alpha</a></em></td><td></td><td><em class=tab><a href="s7.html#makehashtable">make-hash-table</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchselection">notch-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showselection">show-selection</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#afterlispgraphhook">after-lisp-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftbeta">fft-window-beta</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makehighpass">make-highpass</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchsound">notch-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showselectiontransform">show-selection-transform</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#afteropenhook">after-open-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftwithphases">fft-with-phases</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makehilberttransform">make-hilbert-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#notch?">notch?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showsonogramcursor">show-sonogram-cursor</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#aftersaveashook">after-save-as-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftexamples"><b>FFTs</b></a></em></td><td></td><td><em class=tab><a href="s7.html#makehook">make-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#npcos?">npcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showtransformpeaks">show-transform-peaks</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#aftersavestatehook">after-save-state-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#nbdoc">file database</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-iir-filter">make-iir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrcos">nrcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showwidget">show-widget</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#aftertransformhook">after-transform-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoarray">file->array</a></em></td><td></td><td><em class=tab><a href="s7.html#makeintvector">make-int-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrcos?">nrcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showyzero">show-y-zero</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#allchans">all-chans</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoframple">file->frample</a></em></td><td></td><td><em class=tab><a href="s7.html#makeiterator">make-iterator</a></em></td><td></td><td><em class=tab><a href="sndscm.html#nrev">nrev</a></em></td><td></td><td><em class=tab><a href="sndscm.html#silenceallmixes">silence-all-mixes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#all-pass">all-pass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoframple?">file->frample?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-izcos">make-izcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrsin">nrsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#silencemixes">silence-mixes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#allpassbank">all-pass-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetosample">file->sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j0evencos">make-j0evencos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrsin?">nrsin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sinc-train">sinc-train</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#allpassbankp">all-pass-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetosample?">file->sample?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j0j1cos">make-j0j1cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssb">nrssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sinc-train?">sinc-train?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#all-pass?">all-pass?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filename">file-name</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j2cos">make-j2cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssbinterp">nrssb-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sincwidth">sinc-width</a></em></td></tr>
- <tr><td><em class=tab><a href="grfsnd.html#sndandalsa"><b>Alsa</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericfilename"><b>file-name (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jjcos">make-jjcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssb?">nrssb?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sineenvchannel">sine-env-channel</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#ampcontrol">amp-control</a></em></td><td></td><td><em class=tab><a href="s7.html#fillb">fill!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jncos">make-jncos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxycos">nrxycos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sineramp">sine-ramp</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#ampcontrolbounds">amp-control-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericfill"><b>fill! (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jpcos">make-jpcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxycos?">nrxycos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#singerdoc">singer</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#amplitude-modulate">amplitude-modulate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fillpolygon">fill-polygon</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jycos">make-jycos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxysin">nrxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothchannel">smooth-channel</a></em></td></tr>
- <tr><td><em class=tab><a href="grfsnd.html#analyseladspa">analyse-ladspa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fillrectangle">fill-rectangle</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2cos">make-k2cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxysin?">nrxysin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothselection">smooth-selection</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#anoi">anoi</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filter">filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2sin">make-k2sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsin">nsin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothsound">smooth-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#anyenvchannel">any-env-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterchannel">filter-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2ssb">make-k2ssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsin?">nsin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothexamples"><b>Smoothing</b></a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#anyrandom">any-random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolcoeffs">filter-control-coeffs</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k3sin">make-k3sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsincos">nsincos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pins">SMS synthesis</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#applycontrols">apply-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolenvelope">filter-control-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-krksin">make-krksin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsincos?">nsincos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmarktobeat">snap-mark-to-beat</a></em></td></tr>
- <tr><td><em class=tab><a href="grfsnd.html#applyladspa">apply-ladspa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolindB">filter-control-in-dB</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-locsig">make-locsig</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nssb">nssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmarks">snap-marks</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#aritablep">aritable?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolinhz">filter-control-in-hz</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makelowpass">make-lowpass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nssb?">nssb?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmixtobeat">snap-mix-to-beat</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#arity">arity</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolorder">filter-control-order</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makemixsampler">make-mix-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1cos">nxy1cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtosample">snd->sample</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#arraytofile">array->file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterwaveformcolor">filter-control-waveform-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-move-sound">make-move-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1cos?">nxy1cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtosamplep">snd->sample?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#array-interp">array-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolp">filter-control?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-autocorrelation">make-moving-autocorrelation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1sin">nxy1sin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndcolor">snd-color</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#asoneedit">as-one-edit</a></em></td><td></td><td><em class=tab><a href="sndscm.html#filterfft">filter-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-average">make-moving-average</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1sin?">nxy1sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#snderror">snd-error</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#askaboutunsavededits">ask-about-unsaved-edits</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterselection">filter-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-fft">make-moving-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxycos">nxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#snderrorhook">snd-error-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#askbeforeoverwrite">ask-before-overwrite</a></em></td><td></td><td><em class=tab><a href="sndscm.html#filterselectionandsmooth">filter-selection-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-max">make-moving-max</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxycos?">nxycos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndfont">snd-font</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#asyfmI">asyfm-I</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtersound">filter-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-norm">make-moving-norm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxysin">nxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndgcs">snd-gcs</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#asyfmJ">asyfm-J</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filter?">filter?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-pitch">make-moving-pitch</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxysin?">nxysin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndhelp">snd-help</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#asyfm?">asyfm?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filtered-comb">filtered-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-scentroid">make-moving-scentroid</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#sndscmhooks">snd-hooks</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#asymmetric-fm">asymmetric-fm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filteredcombbank">filtered-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-spectrum">make-moving-spectrum</a></em></td><td></td><td class="green"><div class="centered">O</div></td><td></td><td><em class=tab><a href="extsnd.html#sndopenedsound">*snd-opened-sound*</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#asymmetric-fm?">asymmetric-fm?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filteredcombbankp">filtered-comb-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-n1cos">make-n1cos</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#sndprint">snd-print</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#autoresize">auto-resize</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filtered-comb?">filtered-comb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nchoosekcos">make-nchoosekcos</a></em></td><td></td><td><em class=tab><a href="s7.html#objecttostring">object->string</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndspectrum">snd-spectrum</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#autosavedoc">auto-save</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtersinsnd"><b>Filters</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ncos">make-ncos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oddmultiple">odd-multiple</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtempnam">snd-tempnam</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#autoupdate">auto-update</a></em></td><td></td><td><em class=tab><a href="extsnd.html#finddialog">find-dialog</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nkssb">make-nkssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oddweight">odd-weight</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndurl">snd-url</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#autoupdateinterval">auto-update-interval</a></em></td><td></td><td><em class=tab><a href="extsnd.html#findmark">find-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddcos">make-noddcos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#offsetchannel">offset-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndurls">snd-urls</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#autocorrelate">autocorrelate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#findmix">find-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddsin">make-noddsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#offsetsound">offset-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndversion">snd-version</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#autoload"><b>autoload</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#findsound">find-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddssb">make-noddssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole">one-pole</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndwarning">snd-warning</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#axiscolor">axis-color</a></em></td><td></td><td><em class=tab><a href="sndscm.html#finfo">finfo</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noid">make-noid</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole-all-pass">one-pole-all-pass</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndwarninghook">snd-warning-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#axisinfo">axis-info</a></em></td><td></td><td><em class=tab><a href="extsnd.html#finishprogressreport">finish-progress-report</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-notch">make-notch</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole-all-pass?">one-pole-all-pass?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sndwarp">sndwarp</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#axislabelfont">axis-label-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fir-filter">fir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrcos">make-nrcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole?">one-pole?</a></em></td><td></td><td><em class=tab><a href="s7.html#sortb">sort!</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#axisnumbersfont">axis-numbers-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fir-filter?">fir-filter?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrsin">make-nrsin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-zero">one-zero</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-locsig"><b>Sound placement</b></a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#firmant">firmant</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrssb">make-nrssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-zero?">one-zero?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundtoamp_env">sound->amp-env</a></em></td></tr>
- <tr><td class="green"><div class="centered">B</div></td><td></td><td><em class=tab><a href="sndclm.html#firmant?">firmant?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrxycos">make-nrxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openfiledialog">open-file-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundtointeger">sound->integer</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#fitselectionbetweenmarks">fit-selection-between-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrxysin">make-nrxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openfiledialogdirectory">open-file-dialog-directory</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfileextensions">sound-file-extensions</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#backgroundgradient">background-gradient</a></em></td><td></td><td><em class=tab><a href="sndscm.html#flattenpartials">flatten-partials</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nsin">make-nsin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openhook">open-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfilep">sound-file?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#badheaderhook">bad-header-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fv">float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nsincos">make-nsincos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#opennextfileindirectory">open-next-file-in-directory</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfilesindirectory">sound-files-in-directory</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#bagpipe">bagpipe</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtimes">float-vector*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nssb">make-nssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openrawsound">open-raw-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundinterp">sound-interp</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#basiccolor">basic-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvplus">float-vector+</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxy1cos">make-nxy1cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openrawsoundhook">open-raw-sound-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundloopinfo">sound-loop-info</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beatspermeasure">beats-per-measure</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtochannel">float-vector->channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxy1sin">make-nxy1sin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#opensound">open-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundproperties">sound-properties</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beatsperminute">beats-per-minute</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtolist">float-vector->list</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxycos">make-nxycos</a></em></td><td></td><td><em class=tab><a href="s7.html#openlet">openlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundproperty">sound-property</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beforeclosehook">before-close-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtostring">float-vector->string</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxysin">make-nxysin</a></em></td><td></td><td><em class=tab><a href="s7.html#openletp">openlet?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundwidgets">sound-widgets</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beforeexithook">before-exit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvabs">float-vector-abs!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-pole">make-one-pole</a></em></td><td></td><td><em class=tab><a href="extsnd.html#orientationhook">orientation-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundp">sound?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beforesaveashook">before-save-as-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvadd">float-vector-add!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-pole-all-pass">make-one-pole-all-pass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil">oscil</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfontinfo">soundfont-info</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beforesavestatehook">before-save-state-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvcopy">float-vector-copy</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-zero">make-one-zero</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil-bank">oscil-bank</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sounds">sounds</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#beforetransformhook">before-transform-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvequal">float-vector-equal?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-oscil">make-oscil</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil-bank?">oscil-bank?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundstosegmentdata">sounds->segment-data</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#besj0">bes-j0</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvfill">float-vector-fill!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-oscil-bank">make-oscil-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil?">oscil?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spectra">spectra</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#bess">bess</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvlength">float-vector-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-phase-vocoder">make-phase-vocoder</a></em></td><td></td><td><em class=tab><a href="sndclm.html#out-any">out-any</a></em></td><td></td><td><em class=tab><a href="sndscm.html#twotab">spectral interpolation</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#bess?">bess?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmax">float-vector-max</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pink-noise">make-pink-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#outbank">out-bank</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spectralpolynomial">spectral-polynomial</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">bessel filters</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmin">float-vector-min</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makepixmap">make-pixmap</a></em></td><td></td><td><em class=tab><a href="sndclm.html#outa">outa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrohop">spectro-hop</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#bigbird">bigbird</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmove">float-vector-move!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeplayer">make-player</a></em></td><td></td><td><em class=tab><a href="s7.html#outlet">outlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroxangle">spectro-x-angle</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#bignum">bignum</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmultiply">float-vector-multiply!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polyoid">make-polyoid</a></em></td><td></td><td><em class=tab><a href="sndclm.html#*output*">*output*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroxscale">spectro-x-scale</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#bignump">bignum?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvoffset">float-vector-offset!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polyshape">make-polyshape</a></em></td><td></td><td><em class=tab><a href="extsnd.html#outputcommenthook">output-comment-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroyangle">spectro-y-angle</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#binaryiodoc">binary files</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvpeak">float-vector-peak</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polywave">make-polywave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#overlayrmsenv">overlay-rms-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroyscale">spectro-y-scale</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#bindkey">bind-key</a></em></td><td></td><td><em class=tab><a href="sndscm.html#vctpolynomial">float-vector-polynomial</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pulse-train">make-pulse-train</a></em></td><td></td><td><em class=tab><a href="s7.html#owlet">owlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrozangle">spectro-z-angle</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#bird">bird</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvref">float-vector-ref</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pulsed-env">make-pulsed-env</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#spectrozscale">spectro-z-scale</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#blackman">blackman</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvreverse">float-vector-reverse!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-r2k!cos">make-r2k!cos</a></em></td><td></td><td class="green"><div class="centered">P</div></td><td></td><td><em class=tab><a href="sndclm.html#spectrum">spectrum</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#blackman4envchannel">blackman4-env-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvscale">float-vector-scale!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-r2k2cos">make-r2k2cos</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#spectrumtocoeffs">spectrum->coeffs</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#blackman?">blackman?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvset">float-vector-set!</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makeramp">make-ramp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#padchannel">pad-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrumend">spectrum-end</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#boldpeaksfont">bold-peaks-font</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvsubseq">float-vector-subseq</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rand">make-rand</a></em></td><td></td><td><em class=tab><a href="sndscm.html#padmarks">pad-marks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrumstart">spectrum-start</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#break">break</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvsubtract">float-vector-subtract!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rand-interp">make-rand-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#padsound">pad-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedcontrol">speed-control</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#brown-noise">brown-noise</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvp">float-vector?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rcos">make-rcos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#panmix">pan-mix</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedcontrolbounds">speed-control-bounds</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#brown-noise?">brown-noise?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#flocsig">flocsig</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-readin">make-readin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#panmixvct">pan-mix-float-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedstyle">speed-control-style</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">butterworth filters</a></em></td><td></td><td><em class=tab><a href="sndclm.html#flocsig?">flocsig?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeregion">make-region</a></em></td><td></td><td><em class=tab><a href="sndclm.html#partialstopolynomial">partials->polynomial</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedtones">speed-control-tones</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#bytevector">byte-vector</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereoflute">flute model</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeregionsampler">make-region-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#partialstowave">partials->wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spotfreq">spot-freq</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#bytevectorp">byte-vector?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmbell">fm-bell</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rk!cos">make-rk!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#pausing">pausing</a></em></td><td></td><td><em class=tab><a href="sndclm.html#square-wave">square-wave</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#fmdrum">fm-drum</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rk!ssb">make-rk!ssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peakenvdir">peak-env-dir</a></em></td><td></td><td><em class=tab><a href="sndclm.html#square-wave?">square-wave?</a></em></td></tr>
- <tr><td class="green"><div class="centered">C</div></td><td></td><td><em class=tab><a href="sndscm.html#fmnoise">fm-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkcos">make-rkcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peaks">peaks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#squelchupdate">squelch-update</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#fmparallelcomponent">fm-parallel-component</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkoddssb">make-rkoddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peaksfont">peaks-font</a></em></td><td></td><td><em class=tab><a href="sndscm.html#squelchvowels">squelch-vowels</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#definecfunction">c-define</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmvox">fm-talker</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rksin">make-rksin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-partialstowave">phase-partials->wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srate">srate</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cgp">c-g?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmtrumpet">fm-trumpet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkssb">make-rkssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-vocoder">phase-vocoder</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericsrate"><b>srate (generic)</b></a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#cobject">c-object?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#vdoc">fm-violin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-round-interp">make-round-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-vocoder?">phase-vocoder?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#src">src</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#cpoint">c-pointer</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmvoice">fm-voice</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rssb">make-rssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#prc95doc"><b>Physical Models</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcchannel">src-channel</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#cpointer">c-pointer?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fmssb">fmssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxycos">make-rxycos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pianodoc">piano model</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcduration">src-duration</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#callwithexit">call-with-exit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fmssb?">fmssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxyk!cos">make-rxyk!cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pink-noise">pink-noise</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcfitenvelope">src-fit-envelope</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#bagpipe">canter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#focuswidget">focus-widget</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxyk!sin">make-rxyk!sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pink-noise?">pink-noise?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcmixes">src-mixes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#cascadetocanonical">cascade->canonical</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fofins">FOF synthesis</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxysin">make-rxysin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pins">pins</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcsoundselection">src-selection</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#catch">catch</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fofins">fofins</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sampletofile">make-sample->file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#placesound">place-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcsound">src-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#cellon">cellon</a></em></td><td></td><td><em class=tab><a href="sndscm.html#foreachchild">for-each-child</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makesampler">make-sampler</a></em></td><td></td><td><em class=tab><a href="extsnd.html#play">play</a></em></td><td></td><td><em class=tab><a href="sndclm.html#src?">src?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#chaindsps">chain-dsps</a></em></td><td></td><td><em class=tab><a href="sndscm.html#foreachsoundfile">for-each-sound-file</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sawtooth-wave">make-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericplay"><b>play (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#ssb-am">ssb-am</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channeltovct">channel->vct</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fp">Forbidden Planet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makeselection">make-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playarrowsize">play-arrow-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ssb-am?">ssb-am?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channelampenvs">channel-amp-envs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#foregroundcolor">foreground-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sinc-train">make-sinc-train</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playbetweenmarks">play-between-marks</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbbank">ssb-bank</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channeldata">channel-data</a></em></td><td></td><td><em class=tab><a href="extsnd.html#forgetregion">forget-region</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makesndtosample">make-snd->sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playhook">play-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbbankenv">ssb-bank-env</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelenvelope">channel-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formant">formant</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makesoundbox">make-sound-box</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playmixes">play-mixes</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbfm">ssb-fm</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelpolynomial">channel-polynomial</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formantbank">formant-bank</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makespencerfilter">make-spencer-filter</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playoften">play-often</a></em></td><td></td><td><em class=tab><a href="sndscm.html#startdac">start-dac</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channelproperties">channel-properties</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formantbankp">formant-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-square-wave">make-square-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playregionforever">play-region-forever</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplaying">start-playing</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channelproperty">channel-property</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formant?">formant?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-src">make-src</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsine">play-sine</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplayinghook">start-playing-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelrms">channel-rms</a></em></td><td></td><td><em class=tab><a href="s7.html#format">format</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ssb-am">make-ssb-am</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsines">play-sines</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplayingselectionhook">start-playing-selection-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channelstyle">channel-style</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandforth"><b>Forth</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-table-lookup">make-table-lookup</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsyncdmarks">play-syncd-marks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startprogressreport">start-progress-report</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelsync">channel-sync</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fp">fp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-table-lookup-with-env">make-table-lookup-with-env</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playuntilcg">play-until-c-g</a></em></td><td></td><td><em class=tab><a href="extsnd.html#statusreport">status-report</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channelwidgets">channel-widgets</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fractionalfouriertransform">fractional-fourier-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-tanhsin">make-tanhsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playwithenvs">play-with-envs</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereotomono">stereo->mono</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#channels">channels</a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletofile">frample->file</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-triangle-wave">make-triangle-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playerhome">player-home</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereoflute">stereo-flute</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#genericchannels"><b>channels (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletofile?">frample->file?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-two-pole">make-two-pole</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playerQ">player?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayer">stop-player</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelsequal">channels-equal?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletoframple">frample->frample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-two-zero">make-two-zero</a></em></td><td></td><td><em class=tab><a href="extsnd.html#players">players</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplaying">stop-playing</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#channelseq">channels=?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#framples">framples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makevariabledisplay">make-variable-display</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playexamples"><b>Playing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayinghook">stop-playing-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#chans">chans</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericframples"><b>framples (generic)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#makevariablegraph">make-variable-graph</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playing">playing</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayingselectionhook">stop-playing-selection-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#charposition">char-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#freeplayer">free-player</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makevct">make-vct</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pluck">pluck</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stretchenvelope">stretch-envelope</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#chebyhka">cheby-hka</a></em></td><td></td><td><em class=tab><a href="extsnd.html#freesampler">free-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-wave-train">make-wave-train</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandladspa"><b>Plugins</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#stretchsoundviadft">stretch-sound-via-dft</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">chebyshev filters</a></em></td><td></td><td><em class=tab><a href="sndscm.html#freeverb">freeverb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-wave-train-with-env">make-wave-train-with-env</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polartorectangular">polar->rectangular</a></em></td><td></td><td><em class=tab><a href="s7.html#stringposition">string-position</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#checkmixtags">check-mix-tags</a></em></td><td></td><td><em class=tab><a href="fm.html#fmintro"><b>Frequency Modulation</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mapchannel">map-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polynomial">polynomial</a></em></td><td></td><td><em class=tab><a href="s7.html#sublet">sublet</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#chordalize">chordalize</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fullmix">fullmix</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mapsoundfiles">map-sound-files</a></em></td><td></td><td><em class=tab><a href="sndscm.html#polydoc">polynomial operations</a></em></td><td></td><td><em class=tab><a href="sndscm.html#superimposeffts">superimpose-ffts</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#chorus">chorus</a></em></td><td></td><td><em class=tab><a href="s7.html#funclet">funclet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#maracadoc">maracas</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoid">polyoid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#swapchannels">swap-channels</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#cleanchannel">clean-channel</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#marktointeger">mark->integer</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoidenv">polyoid-env</a></em></td><td></td><td><em class=tab><a href="sndscm.html#swapselectionchannels">swap-selection-channels</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#cleansound">clean-sound</a></em></td><td></td><td class="green"><div class="centered">G</div></td><td></td><td><em class=tab><a href="extsnd.html#markclickhook">mark-click-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoid?">polyoid?</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltodynamicvalue">symbol->dynamic-value</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#clearlistener">clear-listener</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#markclickinfo">mark-click-info</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyshape">polyshape</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltovalue">symbol->value</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cliphook">clip-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#gaussiandistribution">gaussian-distribution</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markcolor">mark-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyshape?">polyshape?</a></em></td><td></td><td><em class=tab><a href="s7.html#symbolaccess">symbol-access</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#clipping">clipping</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gcoff">gc-off</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markcontext">mark-context</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polywave">polywave</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltable">symbol-table</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#clmchannel">clm-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gcon">gc-on</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markdraghook">mark-drag-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polywave?">polywave?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sync">sync</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#clmexpsrc">clm-expsrc</a></em></td><td></td><td><em class=tab><a href="sndclm.html#generators"><b>Generators</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#markexplode">mark-explode</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positiontox">position->x</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericsync"><b>sync (generic)</b></a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#closehook">close-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#gensym">gensym</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markhome">mark-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positiontoy">position->y</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sync-everything">sync-everything</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#closesound">close-sound</a></em></td><td></td><td><em class=tab><a href="s7.html#gensym?">gensym?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markhook">mark-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positioncolor">position-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncmax">sync-max</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colortolist">color->list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#glgraphtops">gl-graph->ps</a></em></td><td></td><td><em class=tab><a href="sndscm.html#markloops">mark-loops</a></em></td><td></td><td><em class=tab><a href="sndscm.html#powerenv">power-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncstyle">sync-style</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colorcutoff">color-cutoff</a></em></td><td></td><td><em class=tab><a href="extsnd.html#glspectrogram">glSpectrogram</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markname">mark-name</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqw">pqw</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncdmarks">syncd-marks</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colorhook">color-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#goertzel">goertzel</a></em></td><td></td><td><em class=tab><a href="sndscm.html#marknametoid">mark-name->id</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqwvox">pqw-vox</a></em></td><td></td><td><em class=tab><a href="sndscm.html#syncdmixes">syncd-mixes</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colorinverted">color-inverted</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gotolistenerend">goto-listener-end</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markproperties">mark-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#preferencesdialog">preferences-dialog</a></em></td><td></td><td><em class=tab><a href="sndscm.html#syncup">syncup</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#colormixes">color-mixes</a></em></td><td></td><td><em class=tab><a href="sndscm.html#grani">grani</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markproperty">mark-property</a></em></td><td></td><td><em class=tab><a href="extsnd.html#previoussample">previous-sample</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colororientationdialog">color-orientation-dialog</a></em></td><td></td><td><em class=tab><a href="sndclm.html#grains"><b>Granular synthesis</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksample">mark-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#printdialog">print-dialog</a></em></td><td></td><td class="green"><div class="centered">T</div></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colorscale">color-scale</a></em></td><td></td><td><em class=tab><a href="sndclm.html#granulate">granulate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksync">mark-sync</a></em></td><td></td><td><em class=tab><a href="extsnd.html#printlength">print-length</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colorp">color?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#granulate?">granulate?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#marksynccolor">mark-sync-color</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduredocumentation">procedure-documentation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#table-lookup">table-lookup</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormap">colormap</a></em></td><td></td><td><em class=tab><a href="sndscm.html#granulatedsoundinterp">granulated-sound-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksyncmax">mark-sync-max</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresetter">procedure-setter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#table-lookup?">table-lookup?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormaptointeger">colormap->integer</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graph">graph</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marktagheight">mark-tag-height</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresignature">procedure-signature</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tanhsin">tanhsin</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormapname">colormap-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphtops">graph->ps</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marktagwidth">mark-tag-width</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresource">procedure-source</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tanhsin?">tanhsin?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormapref">colormap-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphcolor">graph-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markp">mark?</a></em></td><td></td><td><em class=tab><a href="s7.html#profile">profile</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tap">tap</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormapsize">colormap-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphcursor">graph-cursor</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markstuff"><b>Marking</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#progressreport">progress-report</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tap?">tap?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colormapp">colormap?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphdata">graph-data</a></em></td><td></td><td><em class=tab><a href="extsnd.html#emarks">marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulse-train">pulse-train</a></em></td><td></td><td><em class=tab><a href="sndscm.html#telephone">telephone</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#colors"><b>Colors</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphhook">graph-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#matchsoundfiles">match-sound-files</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulse-train?">pulse-train?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#tempdir">temp-dir</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#comb">comb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphstyle">graph-style</a></em></td><td></td><td><em class=tab><a href="sndscm.html#maxenvelope">max-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulsedenv">pulsed-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#textfocuscolor">text-focus-color</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#combbank">comb-bank</a></em></td><td></td><td><em class=tab><a href="sndscm.html#grapheq">graphic equalizer</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxregions">max-regions</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulsedenv?">pulsed-env?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#timegraphstyle">time-graph-style</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#combbankp">comb-bank?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphshorizontal">graphs-horizontal</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxfftpeaks">max-transform-peaks</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#timegraphtype">time-graph-type</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#comb?">comb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise">green-noise</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxamp">maxamp</a></em></td><td></td><td class="green"><div class="centered">R</div></td><td></td><td><em class=tab><a href="extsnd.html#timegraphp">time-graph?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#combineddatacolor">combined-data-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise-interp">green-noise-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericmaxamp"><b>maxamp (generic)</b></a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#timestosamples">times->samples</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#comment">comment</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise-interp?">green-noise-interp?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxampposition">maxamp-position</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k!cos">r2k!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#tinyfont">tiny-font</a></em></td></tr>
- <tr><td><em class=tab><a href="grfsnd.html#sndwithcm"><b>Common Music</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise?">green-noise?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxampexamples"><b>Maxamps</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k!cos?">r2k!cos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#telephone">touch-tone</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#complexify">complexify</a></em></td><td></td><td><em class=tab><a href="extsnd.html#griddensity">grid-density</a></em></td><td></td><td><em class=tab><a href="extsnd.html#menuwidgets">menu-widgets</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k2cos">r2k2cos</a></em></td><td></td><td><em class=tab><a href="s7.html#trace">trace</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#computeuniformcircularstring">compute-uniform-circular-string</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#menusdoc">menus, optional</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k2cos?">r2k2cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#trackingcursors"><b>Tracking cursors</b></a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#concatenateenvelopes">concatenate-envelopes</a></em></td><td></td><td class="green"><div class="centered">H</div></td><td></td><td><em class=tab><a href="extsnd.html#mindb">min-dB</a></em></td><td></td><td><em class=tab><a href="sndclm.html#radianstodegrees">radians->degrees</a></em></td><td></td><td><em class=tab><a href="extsnd.html#trackingcursorstyle">tracking-cursor-style</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#constantp">constant?</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mix">mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#radianstohz">radians->hz</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtointeger">transform->integer</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#continuationp">continuation?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#harmonicizer">harmonicizer</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixtovct">mix->float-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#rampchannel">ramp-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtovct">transform->vct</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#continue-frampletofile">continue-frample->file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#dht">Hartley transform</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtointeger">mix->integer</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand">rand</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformdialog">transform-dialog</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#continue-sampletofile">continue-sample->file</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtable">hash-table</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixamp">mix-amp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand-interp">rand-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformframples">transform-framples</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#contrastchannel">contrast-channel</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtablestar">hash-table*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixampenv">mix-amp-env</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand-interp?">rand-interp?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphstyle">transform-graph-style</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#contrastcontrol">contrast-control</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableentries">hash-table-entries</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixchannel">mix-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand?">rand?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphtype">transform-graph-type</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#contrastcontrolamp">contrast-control-amp</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableref">hash-table-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixclickhook">mix-click-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#random">random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphp">transform-graph?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#contrastcontrolbounds">contrast-control-bounds</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableset">hash-table-set!</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixclickinfo">mix-click-info</a></em></td><td></td><td><em class=tab><a href="sndscm.html#allrandomnumbers"><b>Random Numbers</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#normalizefft">transform-normalization</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#contrastcontrolp">contrast-control?</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtablep">hash-table?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixclicksetsamp">mix-click-sets-amp</a></em></td><td></td><td><em class=tab><a href="s7.html#randomstate">random-state</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformsample">transform-sample</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#contrast-enhancement">contrast-enhancement</a></em></td><td></td><td><em class=tab><a href="extsnd.html#headertype">header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixcolor">mix-color</a></em></td><td></td><td><em class=tab><a href="s7.html#randomstatep">random-state?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformsize">transform-size</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#contrastsound">contrast-sound</a></em></td><td></td><td><em class=tab><a href="snd.html#formats"><b>Headers and sample types</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixdialogmix">mix-dialog-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rcos">rcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtype">transform-type</a></em></td></tr>
- <tr><td><em class=tab><a href="snd.html#controls"><b>Control Panel</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#hellodentist">hello-dentist</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixdraghook">mix-drag-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rcos?">rcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformp">transform?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#controlstochannel">controls->channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#helpdialog">help-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixfiledialog">mix-file-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readhook">read-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#transposemixes">transpose-mixes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#convolution">convolution</a></em></td><td></td><td><em class=tab><a href="extsnd.html#helphook">help-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixhome">mix-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readmixsample">read-mix-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#triangle-wave">triangle-wave</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#convolvewith">convolution reverb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#hidewidget">hide-widget</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixlength">mix-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readonly">read-only</a></em></td><td></td><td><em class=tab><a href="sndclm.html#triangle-wave?">triangle-wave?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#convolve">convolve</a></em></td><td></td><td><em class=tab><a href="extsnd.html#highlightcolor">highlight-color</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixmaxamp">mix-maxamp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readregionsample">read-region-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#tubebell">tubebell</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#convolvefiles">convolve-files</a></em></td><td></td><td><em class=tab><a href="sndscm.html#hilberttransform">hilbert-transform</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixname">mix-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readsample">read-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#tubebell">tubular bell</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#convolveselectionwith">convolve-selection-with</a></em></td><td></td><td><em class=tab><a href="s7.html#hookfunctions">hook-functions</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixnametoid">mix-name->id</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readsamplewithdirection">read-sample-with-direction</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-pole">two-pole</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#convolvewith">convolve-with</a></em></td><td></td><td><em class=tab><a href="sndscm.html#hookmember">hook-member</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixposition">mix-position</a></em></td><td></td><td><em class=tab><a href="s7.html#readercond">reader-cond</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-pole?">two-pole?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#convolve?">convolve?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndhooks"><b>Hooks</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixproperties">mix-properties</a></em></td><td></td><td><em class=tab><a href="sndclm.html#readin">readin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#twotab">two-tab</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#s7copy">copy</a></em></td><td></td><td><em class=tab><a href="sndscm.html#html">html</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixproperty">mix-property</a></em></td><td></td><td><em class=tab><a href="sndclm.html#readin?">readin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-zero">two-zero</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#genericcopy"><b>copy (generic)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#htmldir">html-dir</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixregion">mix-region</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rectangulartomagnitudes">rectangular->magnitudes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-zero?">two-zero?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#copycontext">copy-context</a></em></td><td></td><td><em class=tab><a href="extsnd.html#htmlprogram">html-program</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixreleasehook">mix-release-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rectangulartopolar">rectangular->polar</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#copysampler">copy-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#hztoradians">hz->radians</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixsamplerQ">mix-sampler?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#redo">redo</a></em></td><td></td><td class="green"><div class="centered">U</div></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#copying"><b>Copying</b></a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mixselection">mix-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiontointeger">region->integer</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#correlate">correlate</a></em></td><td></td><td class="green"><div class="centered">I</div></td><td></td><td><em class=tab><a href="sndscm.html#mixsound">mix-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiontovct">region->vct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#unbindkey">unbind-key</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#coverlet">coverlet</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mixspeed">mix-speed</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionchans">region-chans</a></em></td><td></td><td><em class=tab><a href="s7.html#unboundvariablehook">*unbound-variable-hook*</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#mixdoc">cross-fade (amplitude)</a></em></td><td></td><td><em class=tab><a href="sndclm.html#iir-filter">iir-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixsync">mix-sync</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionframples">region-framples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#unclipchannel">unclip-channel</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#fadedoc">cross-fade (frequency domain)</a></em></td><td></td><td><em class=tab><a href="sndclm.html#iir-filter?">iir-filter?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixsyncmax">mix-sync-max</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiongraphstyle">region-graph-style</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undo">undo</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#crosssynthesis">cross-synthesis</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gin">in</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagheight">mix-tag-height</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionhome">region-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undoexamples"><b>Undo and Redo</b></a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#curlet">curlet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#in-any">in-any</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagwidth">mix-tag-width</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionmaxamp">region-maxamp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undohook">undo-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#currentfont">current-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ina">ina</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagy">mix-tag-y</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionmaxampposition">region-maxamp-position</a></em></td><td></td><td><em class=tab><a href="s7.html#unlet">unlet</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursor">cursor</a></em></td><td></td><td><em class=tab><a href="sndclm.html#inb">inb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixvct">mix-vct</a></em></td><td></td><td><em class=tab><a href="sndscm.html#regionplaylist">region-play-list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#unselectall">unselect-all</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorcolor">cursor-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#infodialog">info-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixwaveformheight">mix-waveform-height</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionposition">region-position</a></em></td><td></td><td><em class=tab><a href="sndscm.html#updategraphs">update-graphs</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorcontext">cursor-context</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#initladspa">init-ladspa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixp">mix?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#regionrms">region-rms</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatehook">update-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorlocationoffset">cursor-location-offset</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialbeg">initial-beg</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixes">mixes</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsample">region-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatelispgraph">update-lisp-graph</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorposition">cursor-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialdur">initial-dur</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndmixes"><b>Mixing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsamplerQ">region-sampler?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatesound">update-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorsize">cursor-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialgraphhook">initial-graph-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#monotostereo">mono->stereo</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsrate">region-srate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatetimegraph">update-time-graph</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorstyle">cursor-style</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndinitfile"><b>Initialization file</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#moogfilter">moog-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionok">region?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatetransformgraph">update-transform-graph</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorupdateinterval">cursor-update-interval</a></em></td><td></td><td><em class=tab><a href="s7.html#inlet">inlet</a></em></td><td></td><td><em class=tab><a href="s7.html#morallyequalp">morally-equal?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#eregions">regions</a></em></td><td></td><td><em class=tab><a href="sndscm.html#uponsaveyourself">upon-save-yourself</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cursorexamples"><b>Cursors</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#insertchannel">insert-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseclickhook">mouse-click-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionstuff"><b>Regions</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#sndmotifdoc">user interface extensions</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#cutlet">cutlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertfiledialog">insert-file-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousedraghook">mouse-drag-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#remembersoundstate">remember-sound-state</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="s7.html#cyclicsequences">cyclic-sequences</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertregion">insert-region</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseentergraphhook">mouse-enter-graph-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#removeclicks">remove-clicks</a></em></td><td></td><td class="green"><div class="centered">V</div></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#insertsample">insert-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseenterlabelhook">mouse-enter-label-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#removefrommenu">remove-from-menu</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td class="green"><div class="centered">D</div></td><td></td><td><em class=tab><a href="extsnd.html#insertsamples">insert-samples</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseenterlistenerhook">mouse-enter-listener-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#replacewithselection">replace-with-selection</a></em></td><td></td><td><em class=tab><a href="sndscm.html#variabledisplay">variable-display</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#insertselection">insert-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseentertexthook">mouse-enter-text-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reportmarknames">report-mark-names</a></em></td><td></td><td><em class=tab><a href="extsnd.html#variablegraphp">variable-graph?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#dacfolding">dac-combines-channels</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertsilence">insert-silence</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseleavegraphhook">mouse-leave-graph-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#requires7">require</a></em></td><td></td><td><em class=tab><a href="s7.html#varlet">varlet</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#dacsize">dac-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertsound">insert-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseleavelabelhook">mouse-leave-label-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resampleexamples"><b>Resampling</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vct">vct</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#datacolor">data-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertionexamples"><b>Insertions</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousleavelistenerhook">mouse-leave-listener-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#resetallhooks">reset-all-hooks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttimes">vct*</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#datalocation">data-location</a></em></td><td></td><td><em class=tab><a href="s7.html#intvector">int-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousleavetexthook">mouse-leave-text-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resetcontrols">reset-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctplus">vct+</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#datasize">data-size</a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorref">int-vector-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousepresshook">mouse-press-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resetlistenercursor">reset-listener-cursor</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttochannel">vct->channel</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#dbtolinear">db->linear</a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorset">int-vector-set!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-locsig">move-locsig</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reson">reson</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttolist">vct->list</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#cdebugging"><b>Debugging (C)</b></a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorp">int-vector?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#movemixes">move-mixes</a></em></td><td></td><td><em class=tab><a href="extsnd.html#restorecontrols">restore-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttostring">vct->string</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#variabledisplay"><b>Debugging (instruments)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertocolormap">integer->colormap</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-sound">move-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reverbexamples"><b>Reverb</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttovector">vct->vector</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#snderrors"><b>Debugging (Scheme)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertomark">integer->mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-sound?">move-sound?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#*reverb*">*reverb*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctabs">vct-abs!</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#defaultoutputchans">default-output-chans</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertomix">integer->mix</a></em></td><td></td><td><em class=tab><a href="sndscm.html#movesyncdmarks">move-syncd-marks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbdecay">reverb-control-decay</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctadd">vct-add!</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#defaultoutputheadertype">default-output-header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertoregion">integer->region</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-autocorrelation">moving-autocorrelation</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolfeedback">reverb-control-feedback</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctcopy">vct-copy</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#defaultoutputsampletype">default-output-sample-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertosound">integer->sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-autocorrelation?">moving-autocorrelation?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollength">reverb-control-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctequal">vct-equal?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#defaultoutputsrate">default-output-srate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertotransform">integer->transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-average">moving-average</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollengthbounds">reverb-control-length-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctfill">vct-fill!</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#defgenerator">defgenerator</a></em></td><td></td><td><em class=tab><a href="sndscm.html#integrateenvelope">integrate-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-average?">moving-average?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollowpass">reverb-control-lowpass</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctlength">vct-length</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#definestar">define*</a></em></td><td></td><td><em class=tab><a href="sndscm.html#invertfilter">invert-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-fft">moving-fft</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolscale">reverb-control-scale</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmax">vct-max</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#defineconstant">define-constant</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndswitches"><b>Invocation flags</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-fft?">moving-fft?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolscalebounds">reverb-control-scale-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmin">vct-min</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#defineenvelope">define-envelope</a></em></td><td></td><td><em class=tab><a href="s7.html#iterate">iterate</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-length">moving-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolp">reverb-control?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmove">vct-move!</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#expansion">define-expansion</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratoratend">iterator-at-end?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-max">moving-max</a></em></td><td></td><td><em class=tab><a href="s7.html#reverseb">reverse!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmultiply">vct-multiply!</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#definemacro">define-macro</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratorsequence">iterator-sequence</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-max?">moving-max?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reversebyblocks">reverse-by-blocks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctoffset">vct-offset!</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#definemacrostar">define-macro*</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratorp">iterator?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-norm">moving-norm</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reversechannel">reverse-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctpeak">vct-peak</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#defineselectionviamarks">define-selection-via-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#izcos">izcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-norm?">moving-norm?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reverseenvelope">reverse-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctref">vct-ref</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#definedp">defined?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#izcos?">izcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-pitch">moving-pitch</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverseselection">reverse-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctreverse">vct-reverse!</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#degreestoradians">degrees->radians</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#moving-pitch?">moving-pitch?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reversesound">reverse-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctscale">vct-scale!</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#delay">delay</a></em></td><td></td><td class="green"><div class="centered">J</div></td><td></td><td><em class=tab><a href="sndclm.html#moving-rms">moving-rms</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverseexamples"><b>Reversing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctset">vct-set!</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#delaychannelmixes">delay-channel-mixes</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#moving-scentroid">moving-scentroid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#revertsound">revert-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctsubseq">vct-subseq</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#delaytick">delay-tick</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0evencos">j0evencos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-scentroid?">moving-scentroid?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#rightsample">right-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctsubtract">vct-subtract!</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#delay?">delay?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0evencos?">j0evencos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-spectrum">moving-spectrum</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ring-modulate">ring-modulate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctp">vct?</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletecolormap">delete-colormap</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0j1cos">j0j1cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-spectrum?">moving-spectrum?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!cos">rk!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#Vcts"><b>Vcts</b></a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletefilefilter">delete-file-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0j1cos?">j0j1cos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-sum">moving-sum</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!cos?">rk!cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vectortovct">vector->vct</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletefilesorter">delete-file-sorter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j2cos">j2cos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mpg">mpg</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!ssb">rk!ssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesamp">view-files-amp</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletemark">delete-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j2cos?">j2cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsabuffersize">mus-alsa-buffer-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!ssb?">rk!ssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesampenv">view-files-amp-env</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletemarks">delete-marks</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandjack"><b>Jack</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsabuffers">mus-alsa-buffers</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkcos">rkcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesdialog">view-files-dialog</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletesample">delete-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#jcreverb">jc-reverb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsacapturedevice">mus-alsa-capture-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkcos?">rkcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesfiles">view-files-files</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletesamples">delete-samples</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jjcos">jjcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsadevice">mus-alsa-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkoddssb">rkoddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesselecthook">view-files-select-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletesamplesandsmooth">delete-samples-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jjcos?">jjcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsaplaybackdevice">mus-alsa-playback-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkoddssb?">rkoddssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesselectedfiles">view-files-selected-files</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deleteselection">delete-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jncos">jncos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsasquelchwarning">mus-alsa-squelch-warning</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rksin">rksin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilessort">view-files-sort</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deleteselectionandsmooth">delete-selection-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jncos?">jncos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musarrayprintlength">mus-array-print-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rksin?">rksin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesspeed">view-files-speed</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletetransform">delete-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jpcos">jpcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musbytespersample">mus-bytes-per-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkssb">rkssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesspeedstyle">view-files-speed-style</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#deletionexamples"><b>Deletions</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#jpcos?">jpcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-channel">mus-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkssb?">rkssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewmixesdialog">view-mixes-dialog</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#describehook">describe-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#justsounds">just-sounds</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-channels">mus-channels</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsgain">rms</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewregionsdialog">view-regions-dialog</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#describemark">describe-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jycos">jycos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-chebyshev-tu-sum">mus-chebyshev-tu-sum</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsgain">rms, gain, balance gens</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewsound">view-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#dht">dht</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jycos?">jycos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musclipping">mus-clipping</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsenvelope">rms-envelope</a></em></td><td></td><td><em class=tab><a href="sndscm.html#singerdoc">voice physical model</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#dialogwidgets">dialog-widgets</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#mus-close">mus-close</a></em></td><td></td><td><em class=tab><a href="s7.html#rootlet">rootlet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#voicedtounvoiced">voiced->unvoiced</a></em></td></tr>
- <tr><td><em class=tab><a href="s7.html#dilambda">dilambda</a></em></td><td></td><td class="green"><div class="centered">K</div></td><td></td><td><em class=tab><a href="sndclm.html#mus-copy">mus-copy</a></em></td><td></td><td><em class=tab><a href="sndclm.html#round-interp">round-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#volterrafilter">volterra-filter</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#disablecontrolpanel">disable-control-panel</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#mus-data">mus-data</a></em></td><td></td><td><em class=tab><a href="sndclm.html#round-interp?">round-interp?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmvox">vox</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#displaybarkfft">display-bark-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2cos">k2cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-describe">mus-describe</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssb">rssb</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#displaycorrelation">display-correlation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2cos?">k2cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#muserrorhook">mus-error-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssbinterp">rssb-interp</a></em></td><td></td><td class="green"><div class="centered">W</div></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#displaydb">display-db</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2sin">k2sin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#muserrortypetostring">mus-error-type->string</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssb?">rssb?</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#displayedits">display-edits</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2sin?">k2sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musexpandfilename">mus-expand-filename</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rubbersound">rubber-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#wave-train">wave-train</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#displayenergy">display-energy</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2ssb">k2ssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-feedback">mus-feedback</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandruby"><b>Ruby</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#wave-train?">wave-train?</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#dissolvefade">dissolve-fade</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2ssb?">k2ssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-feedforward">mus-feedforward</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxycos">rxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavelettype">wavelet-type</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#ditherchannel">dither-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k3sin">k3sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fft">mus-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxycos?">rxycos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqwvox">waveshaping voice</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#dithersound">dither-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k3sin?">k3sin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musfilebuffersize">mus-file-buffer-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!cos">rxyk!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavohop">wavo-hop</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#dolph">dolph</a></em></td><td></td><td><em class=tab><a href="sndscm.html#kalmanfilterchannel">kalman-filter-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musfileclipping">mus-file-clipping</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!cos?">rxyk!cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavotrace">wavo-trace</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#dot-product">dot-product</a></em></td><td></td><td><em class=tab><a href="extsnd.html#key">key</a></em></td><td></td><td><em class=tab><a href="sndscm.html#musfilemix">mus-file-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!sin">rxyk!sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#weighted-moving-average">weighted-moving-average</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#dotsize">dot-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#keybinding">key-binding</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-file-name">mus-file-name</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!sin?">rxyk!sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgetposition">widget-position</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#downoct">down-oct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#keypresshook">key-press-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musfloatequalfudgefactor">mus-float-equal-fudge-factor</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxysin">rxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgetsize">widget-size</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawaxes">draw-axes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#krksin">krksin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-frequency">mus-frequency</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxysin?">rxysin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgettext">widget-text</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawdot">draw-dot</a></em></td><td></td><td><em class=tab><a href="sndclm.html#krksin?">krksin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musgeneratorp">mus-generator?</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#movingwindows"><b>Window size and position</b></a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawdots">draw-dots</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#musheaderrawdefaults">mus-header-raw-defaults</a></em></td><td></td><td class="green"><div class="centered">S</div></td><td></td><td><em class=tab><a href="extsnd.html#windowheight">window-height</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawline">draw-line</a></em></td><td></td><td class="green"><div class="centered">L</div></td><td></td><td><em class=tab><a href="extsnd.html#musheadertypetostring">mus-header-type->string</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#windowsamples">window-samples</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawlines">draw-lines</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#musheadertypename">mus-header-type-name</a></em></td><td></td><td><em class=tab><a href="s7.html#s7doc"><b>s7 scheme</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowwidth">window-width</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawmarkhook">draw-mark-hook</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#ladspadescriptor">ladspa-descriptor</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-hop">mus-hop</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sample">sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowx">window-x</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawmixhook">draw-mix-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ladspadir">ladspa-dir</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-increment">mus-increment</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sampletofile">sample->file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowy">window-y</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drawstring">draw-string</a></em></td><td></td><td><em class=tab><a href="s7.html#lambdastar">lambda*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-input?">mus-input?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sampletofile?">sample->file?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withbackgroundprocesses">with-background-processes</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#drone">drone</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lbjpiano">lbj-piano</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-interp-type">mus-interp-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sampletype">sample-type</a></em></td><td></td><td><em class=tab><a href="s7.html#withbaffle">with-baffle</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#makedropsite">drop sites</a></em></td><td></td><td><em class=tab><a href="extsnd.html#leftsample">left-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-interpolate">mus-interpolate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sampleratendQ">sampler-at-end?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withfilemonitor">with-file-monitor</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#drophook">drop-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericlength"><b>length (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-length">mus-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerhome">sampler-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withgl">with-gl</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#duringopenhook">during-open-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#lettolist">let->list</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-location">mus-location</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerposition">sampler-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withinsetgraph">with-inset-graph</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="s7.html#letref">let-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musmaxmalloc">mus-max-malloc</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerQ">sampler?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withinterrupts">with-interrupts</a></em></td></tr>
- <tr><td class="green"><div class="centered">E</div></td><td></td><td><em class=tab><a href="s7.html#letset">let-set!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musmaxtablesize">mus-max-table-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplers"><b>samplers</b></a></em></td><td></td><td><em class=tab><a href="s7.html#with-let">with-let</a></em></td></tr>
- <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="s7.html#letp">let?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-name">mus-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samples">samples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withlocalhook">with-local-hook</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editlists"><b>Edit lists</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#lineartodb">linear->db</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-offset">mus-offset</a></em></td><td></td><td><em class=tab><a href="sndclm.html#samplestoseconds">samples->seconds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withmenuicons">with-menu-icons</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editfragment">edit-fragment</a></em></td><td></td><td><em class=tab><a href="sndscm.html#linearsrcchannel">linear-src-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-order">mus-order</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sashcolor">sash-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withmixtags">with-mix-tags</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editheaderdialog">edit-header-dialog</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lintdoc">lint for scheme</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musosssetbuffers">mus-oss-set-buffers</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveasdialogautocomment">save-as-dialog-auto-comment</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withpointerfocus">with-pointer-focus</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#edithook">edit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphhook">lisp-graph-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-output?">mus-output?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveasdialogsrc">save-as-dialog-src</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withrelativepanes">with-relative-panes</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editlisttofunction">edit-list->function</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphstyle">lisp-graph-style</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-phase">mus-phase</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savecontrols">save-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withsmptelabel">with-smpte-label</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editposition">edit-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphp">lisp-graph?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ramp">mus-ramp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savedir">save-dir</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withsound">with-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editproperties">edit-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listtofv">list->float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-rand-seed">mus-rand-seed</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveedithistory">save-edit-history</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withtemporaryselection">with-temporary-selection</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#editproperty">edit-property</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listtovct">list->vct</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-random">mus-random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveenvelopes">save-envelopes</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtoolbar">with-toolbar</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#edittree">edit-tree</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#listladspa">list-ladspa</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-reset">mus-reset</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savehook">save-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtooltips">with-tooltips</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#edits">edits</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerclickhook">listener-click-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-run">mus-run</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savelistener">save-listener</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtrackingcursor">with-tracking-cursor</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#edot-product">edot-product</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenercolor">listener-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussampletypetostring">mus-sample-type->string</a></em></td><td></td><td><em class=tab><a href="sndscm.html#savemarkproperties">save-mark-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withverbosecursor">with-verbose-cursor</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#effectshook">effects-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenercolorized">listener-colorized</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussampletypename">mus-sample-type-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savemarks">save-marks</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">elliptic filters</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerfont">listener-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-scaler">mus-scaler</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savemix">save-mix</a></em></td><td></td><td class="green"><div class="centered">X</div></td></tr>
- <tr><td><em class=tab><a href="grfsnd.html#emacssnd"><b>Emacs and Snd</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerprompt">listener-prompt</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundchans">mus-sound-chans</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveregion">save-region</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#env">env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerselection">listener-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcloseinput">mus-sound-close-input</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveregiondialog">save-region-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xtoposition">x->position</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#env-any">env-any</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenertextcolor">listener-text-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcloseoutput">mus-sound-close-output</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveselection">save-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xaxislabel">x-axis-label</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envchannel">env-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#littleendianp">little-endian?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcomment">mus-sound-comment</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveselectiondialog">save-selection-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xaxisstyle">x-axis-style</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envchannelwithbase">env-channel-with-base</a></em></td><td></td><td><em class=tab><a href="s7.html#loadhook">*load-hook*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussounddatalocation">mus-sound-data-location</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesound">save-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xbounds">x-bounds</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#envexptchannel">env-expt-channel</a></em></td><td></td><td><em class=tab><a href="s7.html#loadpath">*load-path*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussounddatumsize">mus-sound-datum-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesoundas">save-sound-as</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xpositionslider">x-position-slider</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#env-interp">env-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#locatezero">locate-zero</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundduration">mus-sound-duration</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesounddialog">save-sound-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xzoomslider">x-zoom-slider</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#envmixes">env-mixes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig">locsig</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundforget">mus-sound-forget</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestate">save-state</a></em></td><td></td><td><em class=tab><a href="sndscm.html#xbopen">xb-open</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envselection">env-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-ref">locsig-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundframples">mus-sound-framples</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestatefile">save-state-file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xrampchannel">xramp-channel</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envsound">env-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-reverb-ref">locsig-reverb-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundheadertype">mus-sound-header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestatehook">save-state-hook</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#envsoundinterp">env-sound-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-reverb-set!">locsig-reverb-set!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundlength">mus-sound-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveexamples"><b>Saving</b></a></em></td><td></td><td class="green"><div class="centered">Y</div></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#envsquaredchannel">env-squared-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-set!">locsig-set!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundloopinfo">mus-sound-loop-info</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sgfilter">savitzky-golay-filter</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#env?">env?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-type">locsig-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmarkinfo">mus-sound-mark-info</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sawtooth-wave">sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ytoposition">y->position</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedbase">enved-base</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig?">locsig?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmaxamp">mus-sound-maxamp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sawtooth-wave?">sawtooth-wave?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#yaxislabel">y-axis-label</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedclipping">enved-clip?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#logfreqstart">log-freq-start</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmaxampexists">mus-sound-maxamp-exists?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleby">scale-by</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ybounds">y-bounds</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#enveddialog">enved-dialog</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lpccoeffs">lpc-coeffs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundopeninput">mus-sound-open-input</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scalechannel">scale-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ypositionslider">y-position-slider</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedenvelope">enved-envelope</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lpcpredict">lpc-predict</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundopenoutput">mus-sound-open-output</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scaleenvelope">scale-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#yzoomslider">y-zoom-slider</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#filterenv">enved-filter</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundpath">mus-sound-path</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scalemixes">scale-mixes</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#filterenvorder">enved-filter-order</a></em></td><td></td><td class="green"><div class="centered">M</div></td><td></td><td><em class=tab><a href="extsnd.html#mussoundpreload">mus-sound-preload</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleselectionby">scale-selection-by</a></em></td><td></td><td class="green"><div class="centered">Z</div></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedhook">enved-hook</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundprune">mus-sound-prune</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleselectionto">scale-selection-to</a></em></td><td></td><td><em class=tab> </em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedin-dB">enved-in-dB</a></em></td><td></td><td><em class=tab><a href="s7.html#macrop">macro?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundread">mus-sound-read</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scalesound">scale-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ztransform">z-transform</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedpower">enved-power</a></em></td><td></td><td><em class=tab><a href="s7.html#macroexpand">macroexpand</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundreopenoutput">mus-sound-reopen-output</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scaletempo">scale-tempo</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zecho">zecho</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedstyle">enved-style</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mainmenu">main-menu</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundreportcache">mus-sound-report-cache</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleto">scale-to</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zeroplus">zero+</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedtarget">enved-target</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mainwidgets">main-widgets</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsampletype">mus-sound-sample-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scanchannel">scan-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zeropad">zero-pad</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedwaving">enved-wave?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-abcos">make-abcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsamples">mus-sound-samples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#dspdocscanned">scanned synthesis</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zerophase">zero-phase</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envedwaveformcolor">enved-waveform-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-absin">make-absin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundseekframple">mus-sound-seek-frample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scentroid">scentroid</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zipsound">zip-sound</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#envelopeinterp">envelope-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-sawtooth-wave">make-adjustable-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsrate">mus-sound-srate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scratch">scratch</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zipper">zipper</a></em></td></tr>
- <tr><td><em class=tab><a href="sndscm.html#envelopedmix">enveloped-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-square-wave">make-adjustable-square-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundtypespecifier">mus-sound-type-specifier</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scriptarg">script-arg</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zoomcolor">zoom-color</a></em></td></tr>
- <tr><td><em class=tab><a href="extsnd.html#envexamples"><b>Envelopes</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-triangle-wave">make-adjustable-triangle-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundwrite">mus-sound-write</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scriptargs">script-args</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zoomfocusstyle">zoom-focus-style</a></em></td></tr>
- <tr><td><em class=tab><a href="sndclm.html#eoddcos">eoddcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-all-pass">make-all-pass</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundwritedate">mus-sound-write-date</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndwithnogui"><b>Scripting</b></a></em></td><td></td>
+ <tr><td><em class=tab><a href="s7.html#sharpreaders">*#readers*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#epssize">eps-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-bess">make-bess</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#secondstosamples">seconds->samples</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#ercos">ercos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebiquad">make-biquad</a></em></td><td></td><td class="green"><div class="centered">N</div></td><td></td><td><em class=tab><a href="extsnd.html#selectall">select-all</a></em></td></tr>
+ <tr><td class="green"><div class="centered">-</div></td><td></td><td><em class=tab><a href="sndclm.html#ercos?">ercos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebirds">make-birds</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#selectchannel">select-channel</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="s7.html#errorhook">*error-hook*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-blackman">make-blackman</a></em></td><td></td><td><em class=tab><a href="sndclm.html#n1cos">n1cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectchannelhook">select-channel-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#tobytevector">->byte-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#erssb">erssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-brown-noise">make-brown-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#n1cos?">n1cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectsound">select-sound</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#erssb?">erssb?</a></em></td><td></td><td><em class=tab><a href="s7.html#makebytevector">make-byte-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#nameclickhook">name-click-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectsoundhook">select-sound-hook</a></em></td></tr>
+ <tr><td class="green"><div class="centered">A</div></td><td></td><td><em class=tab><a href="sndclm.html#evenmultiple">even-multiple</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makedropsite">make-channel-drop-site</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nchoosekcos">nchoosekcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedchannel">selected-channel</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#evenweight">even-weight</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makecolor">make-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nchoosekcos?">nchoosekcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selecteddatacolor">selected-data-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#abcos">abcos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#everysample">every-sample?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-comb">make-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos">ncos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedgraphcolor">selected-graph-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#abcos?">abcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#exit">exit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makecombbank">make-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos2?">ncos2?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectedsound">selected-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#abort">abort</a></em></td><td></td><td><em class=tab><a href="extsnd.html#exithook">exit-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-convolve">make-convolve</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos4?">ncos4?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selection">selection</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#absin">absin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrol">expand-control</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-delay">make-delay</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ncos?">ncos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectiontomix">selection->mix</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#absin?">absin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolbounds">expand-control-bounds</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makedifferentiator">make-differentiator</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsound">new-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionchans">selection-chans</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#addampcontrols">add-amp-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolhop">expand-control-hop</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-env">make-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsounddialog">new-sound-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncolor">selection-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addcolormap">add-colormap</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontroljitter">expand-control-jitter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-eoddcos">make-eoddcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newsoundhook">new-sound-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncontext">selection-context</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#adddeleteoption">add-delete-option</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrollength">expand-control-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ercos">make-ercos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#newwidgethook">new-widget-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectioncreatesregion">selection-creates-region</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#adddirectorytoviewfileslist">add-directory-to-view-files-list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolramp">expand-control-ramp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-erssb">make-erssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#nextsample">next-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionframples">selection-framples</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addfilefilter">add-file-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#expandcontrolp">expand-control?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-fft-window">make-fft-window</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssb">nkssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmaxamp">selection-maxamp</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addfilesorter">add-file-sorter</a></em></td><td></td><td><em class=tab><a href="sndscm.html#explodesf2">explode-sf2</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filetoframple">make-file->frample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssbinterp">nkssb-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmaxampposition">selection-maxamp-position</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addfiletoviewfileslist">add-file-to-view-files-list</a></em></td><td></td><td><em class=tab><a href="sndclm.html#exponentially-weighted-moving-average">exponentially-weighted-moving-average</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filetosample">make-file->sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nkssb?">nkssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionmember">selection-member?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addmark">add-mark</a></em></td><td></td><td><em class=tab><a href="sndscm.html#expsnd">expsnd</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filter">make-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddcos">noddcos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#selectionmembers">selection-members</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#addmarkpane">add-mark-pane</a></em></td><td></td><td><em class=tab><a href="sndscm.html#expsrc">expsrc</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-filtered-comb">make-filtered-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddcos?">noddcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionposition">selection-position</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addplayer">add-player</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#makefilteredcombbank">make-filtered-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddsin">noddsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#selectionrms">selection-rms</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addsoundfileextension">add-sound-file-extension</a></em></td><td></td><td class="green"><div class="centered">F</div></td><td></td><td><em class=tab><a href="sndclm.html#make-fir-coeffs">make-fir-coeffs</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddsin?">noddsin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionsrate">selection-srate</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addsourcefileextension">add-source-file-extension</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#make-fir-filter">make-fir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddssb">noddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionok">selection?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addtomainmenu">add-to-main-menu</a></em></td><td></td><td><em class=tab><a href="s7.html#featureslist">*features*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-firmant">make-firmant</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noddssb?">noddssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#selectionstuff"><b>Selections</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addtomenu">add-to-menu</a></em></td><td></td><td><em class=tab><a href="sndscm.html#cellon">feedback fm</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makefv">make-float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#noid">noid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#setsamples">set-samples</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#addtooltip">add-tooltip</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fft">fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-flocsig">make-flocsig</a></em></td><td></td><td><em class=tab><a href="sndscm.html#cleandoc"><b>Noise Reduction</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#shortfilename">short-file-name</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#addtransform">add-transform</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftcancel">fft-cancel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-fmssb">make-fmssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#normalizechannel">normalize-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showaxes">show-axes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#spectra">additive synthesis</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftedit">fft-edit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-formant">make-formant</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizeenvelope">normalize-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showcontrols">show-controls</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-sawtooth-wave">adjustable-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftenvedit">fft-env-edit</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makeformantbank">make-formant-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#normalizepartials">normalize-partials</a></em></td><td></td><td><em class=tab><a href="sndscm.html#showdiskspace">show-disk-space</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-sawtooth-wave?">adjustable-sawtooth-wave?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftenvinterp">fft-env-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-frampletofile">make-frample->file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizesound">normalize-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showfullduration">show-full-duration</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-square-wave">adjustable-square-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftlogfrequency">fft-log-frequency</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-granulate">make-granulate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#normalizedmix">normalized-mix</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showfullrange">show-full-range</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-square-wave?">adjustable-square-wave?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftlogmagnitude">fft-log-magnitude</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makegraphdata">make-graph-data</a></em></td><td></td><td><em class=tab><a href="sndclm.html#notch">notch</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showgrid">show-grid</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-triangle-wave">adjustable-triangle-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftsmoother">fft-smoother</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-green-noise">make-green-noise</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchchannel">notch-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showindices">show-indices</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#adjustable-triangle-wave?">adjustable-triangle-wave?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fftsquelch">fft-squelch</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-green-noise-interp">make-green-noise-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchselection">notch-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showlistener">show-listener</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#afterapplycontrolshook">after-apply-controls-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftwindow">fft-window</a></em></td><td></td><td><em class=tab><a href="s7.html#makehashtable">make-hash-table</a></em></td><td></td><td><em class=tab><a href="sndscm.html#notchsound">notch-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showmarks">show-marks</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#afteredithook">after-edit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftalpha">fft-window-alpha</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makehighpass">make-highpass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#notch?">notch?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showmixwaveforms">show-mix-waveforms</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#aftergraphhook">after-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftbeta">fft-window-beta</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makehilberttransform">make-hilbert-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#npcos?">npcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showselection">show-selection</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#afterlispgraphhook">after-lisp-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftwithphases">fft-with-phases</a></em></td><td></td><td><em class=tab><a href="s7.html#makehook">make-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrcos">nrcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showselectiontransform">show-selection-transform</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#afteropenhook">after-open-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fftexamples"><b>FFTs</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-iir-filter">make-iir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrcos?">nrcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showsonogramcursor">show-sonogram-cursor</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#aftersaveashook">after-save-as-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#nbdoc">file database</a></em></td><td></td><td><em class=tab><a href="s7.html#makeintvector">make-int-vector</a></em></td><td></td><td><em class=tab><a href="sndscm.html#nrev">nrev</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showtransformpeaks">show-transform-peaks</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#aftersavestatehook">after-save-state-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoarray">file->array</a></em></td><td></td><td><em class=tab><a href="s7.html#makeiterator">make-iterator</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrsin">nrsin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showwidget">show-widget</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#aftertransformhook">after-transform-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoframple">file->frample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-izcos">make-izcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrsin?">nrsin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#showyzero">show-y-zero</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#allchans">all-chans</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetoframple?">file->frample?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j0evencos">make-j0evencos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssb">nrssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#silenceallmixes">silence-all-mixes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#all-pass">all-pass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetosample">file->sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j0j1cos">make-j0j1cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssbinterp">nrssb-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#silencemixes">silence-mixes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#allpassbank">all-pass-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filetosample?">file->sample?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-j2cos">make-j2cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrssb?">nrssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sinc-train">sinc-train</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#allpassbankp">all-pass-bank?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filename">file-name</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jjcos">make-jjcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxycos">nrxycos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sinc-train?">sinc-train?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#all-pass?">all-pass?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericfilename"><b>file-name (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jncos">make-jncos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxycos?">nrxycos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sincwidth">sinc-width</a></em></td></tr>
+ <tr><td><em class=tab><a href="grfsnd.html#sndandalsa"><b>Alsa</b></a></em></td><td></td><td><em class=tab><a href="s7.html#fillb">fill!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jpcos">make-jpcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxysin">nrxysin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sineenvchannel">sine-env-channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#ampcontrol">amp-control</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericfill"><b>fill! (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-jycos">make-jycos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nrxysin?">nrxysin?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sineramp">sine-ramp</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#ampcontrolbounds">amp-control-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fillpolygon">fill-polygon</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2cos">make-k2cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsin">nsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#singerdoc">singer</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#amplitude-modulate">amplitude-modulate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fillrectangle">fill-rectangle</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2sin">make-k2sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsin?">nsin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothchannel">smooth-channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="grfsnd.html#analyseladspa">analyse-ladspa</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filter">filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k2ssb">make-k2ssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsincos">nsincos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothselection">smooth-selection</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#anoi">anoi</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterchannel">filter-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-k3sin">make-k3sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nsincos?">nsincos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothsound">smooth-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#anyenvchannel">any-env-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolcoeffs">filter-control-coeffs</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-krksin">make-krksin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nssb">nssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#smoothexamples"><b>Smoothing</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#anyrandom">any-random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolenvelope">filter-control-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-locsig">make-locsig</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nssb?">nssb?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pins">SMS synthesis</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#applycontrols">apply-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolindB">filter-control-in-dB</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makelowpass">make-lowpass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1cos">nxy1cos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmarktobeat">snap-mark-to-beat</a></em></td></tr>
+ <tr><td><em class=tab><a href="grfsnd.html#applyladspa">apply-ladspa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolinhz">filter-control-in-hz</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makemixsampler">make-mix-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1cos?">nxy1cos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmarks">snap-marks</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#aritablep">aritable?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolorder">filter-control-order</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-move-sound">make-move-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1sin">nxy1sin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#snapmixtobeat">snap-mix-to-beat</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#arity">arity</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterwaveformcolor">filter-control-waveform-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-autocorrelation">make-moving-autocorrelation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxy1sin?">nxy1sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtosample">snd->sample</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#arraytofile">array->file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtercontrolp">filter-control?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-average">make-moving-average</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxycos">nxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtosamplep">snd->sample?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#array-interp">array-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#filterfft">filter-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-fft">make-moving-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxycos?">nxycos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndcolor">snd-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#asoneedit">as-one-edit</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filterselection">filter-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-max">make-moving-max</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxysin">nxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#snderror">snd-error</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#askaboutunsavededits">ask-about-unsaved-edits</a></em></td><td></td><td><em class=tab><a href="sndscm.html#filterselectionandsmooth">filter-selection-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-norm">make-moving-norm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#nxysin?">nxysin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#snderrorhook">snd-error-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#askbeforeoverwrite">ask-before-overwrite</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtersound">filter-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-pitch">make-moving-pitch</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#sndfont">snd-font</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#asyfmI">asyfm-I</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filter?">filter?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-scentroid">make-moving-scentroid</a></em></td><td></td><td class="green"><div class="centered">O</div></td><td></td><td><em class=tab><a href="extsnd.html#sndgcs">snd-gcs</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#asyfmJ">asyfm-J</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filtered-comb">filtered-comb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-moving-spectrum">make-moving-spectrum</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#sndhelp">snd-help</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#asyfm?">asyfm?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filteredcombbank">filtered-comb-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-n1cos">make-n1cos</a></em></td><td></td><td><em class=tab><a href="s7.html#objecttostring">object->string</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sndscmhooks">snd-hooks</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#asymmetric-fm">asymmetric-fm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filteredcombbankp">filtered-comb-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nchoosekcos">make-nchoosekcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oddmultiple">odd-multiple</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndopenedsound">*snd-opened-sound*</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#asymmetric-fm?">asymmetric-fm?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#filtered-comb?">filtered-comb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ncos">make-ncos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oddweight">odd-weight</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndprint">snd-print</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#autoresize">auto-resize</a></em></td><td></td><td><em class=tab><a href="extsnd.html#filtersinsnd"><b>Filters</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nkssb">make-nkssb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#offsetchannel">offset-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndspectrum">snd-spectrum</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#autosavedoc">auto-save</a></em></td><td></td><td><em class=tab><a href="extsnd.html#finddialog">find-dialog</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddcos">make-noddcos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#offsetsound">offset-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndtempnam">snd-tempnam</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#autoupdate">auto-update</a></em></td><td></td><td><em class=tab><a href="extsnd.html#findmark">find-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddsin">make-noddsin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole">one-pole</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndurl">snd-url</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#autoupdateinterval">auto-update-interval</a></em></td><td></td><td><em class=tab><a href="sndscm.html#findmix">find-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noddssb">make-noddssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole-all-pass">one-pole-all-pass</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndurls">snd-urls</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#autocorrelate">autocorrelate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#findsound">find-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-noid">make-noid</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole-all-pass?">one-pole-all-pass?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndversion">snd-version</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#autoload"><b>autoload</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#finfo">finfo</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-notch">make-notch</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-pole?">one-pole?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndwarning">snd-warning</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#axiscolor">axis-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#finishprogressreport">finish-progress-report</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrcos">make-nrcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-zero">one-zero</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndwarninghook">snd-warning-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#axisinfo">axis-info</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fir-filter">fir-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrsin">make-nrsin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#one-zero?">one-zero?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sndwarp">sndwarp</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#axislabelfont">axis-label-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fir-filter?">fir-filter?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrssb">make-nrssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openfiledialog">open-file-dialog</a></em></td><td></td><td><em class=tab><a href="s7.html#sortb">sort!</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#axisnumbersfont">axis-numbers-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#firmant">firmant</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrxycos">make-nrxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openfiledialogdirectory">open-file-dialog-directory</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-locsig"><b>Sound placement</b></a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#firmant?">firmant?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nrxysin">make-nrxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openhook">open-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundtoamp_env">sound->amp-env</a></em></td></tr>
+ <tr><td class="green"><div class="centered">B</div></td><td></td><td><em class=tab><a href="sndscm.html#fitselectionbetweenmarks">fit-selection-between-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nsin">make-nsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#opennextfileindirectory">open-next-file-in-directory</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundtointeger">sound->integer</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#flattenpartials">flatten-partials</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nsincos">make-nsincos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openrawsound">open-raw-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfileextensions">sound-file-extensions</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#backgroundgradient">background-gradient</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fv">float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nssb">make-nssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#openrawsoundhook">open-raw-sound-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfilep">sound-file?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#badheaderhook">bad-header-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtimes">float-vector*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxy1cos">make-nxy1cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#opensound">open-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfilesindirectory">sound-files-in-directory</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#bagpipe">bagpipe</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvplus">float-vector+</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxy1sin">make-nxy1sin</a></em></td><td></td><td><em class=tab><a href="s7.html#openlet">openlet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundinterp">sound-interp</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#basiccolor">basic-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtochannel">float-vector->channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxycos">make-nxycos</a></em></td><td></td><td><em class=tab><a href="s7.html#openletp">openlet?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundloopinfo">sound-loop-info</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beatspermeasure">beats-per-measure</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtolist">float-vector->list</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-nxysin">make-nxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#orientationhook">orientation-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundproperties">sound-properties</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beatsperminute">beats-per-minute</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvtostring">float-vector->string</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-pole">make-one-pole</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil">oscil</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundproperty">sound-property</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beforeclosehook">before-close-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvabs">float-vector-abs!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-pole-all-pass">make-one-pole-all-pass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil-bank">oscil-bank</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundwidgets">sound-widgets</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beforeexithook">before-exit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvadd">float-vector-add!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-one-zero">make-one-zero</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil-bank?">oscil-bank?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundp">sound?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beforesaveashook">before-save-as-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvcopy">float-vector-copy</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-oscil">make-oscil</a></em></td><td></td><td><em class=tab><a href="sndclm.html#oscil?">oscil?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#soundfontinfo">soundfont-info</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beforesavestatehook">before-save-state-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvequal">float-vector-equal?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-oscil-bank">make-oscil-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#out-any">out-any</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sounds">sounds</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#beforetransformhook">before-transform-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvfill">float-vector-fill!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-phase-vocoder">make-phase-vocoder</a></em></td><td></td><td><em class=tab><a href="sndclm.html#outbank">out-bank</a></em></td><td></td><td><em class=tab><a href="sndscm.html#soundstosegmentdata">sounds->segment-data</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#besj0">bes-j0</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvlength">float-vector-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pink-noise">make-pink-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#outa">outa</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spectra">spectra</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#bess">bess</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmax">float-vector-max</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makepixmap">make-pixmap</a></em></td><td></td><td><em class=tab><a href="s7.html#outlet">outlet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#twotab">spectral interpolation</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#bess?">bess?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmin">float-vector-min</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeplayer">make-player</a></em></td><td></td><td><em class=tab><a href="sndclm.html#*output*">*output*</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spectralpolynomial">spectral-polynomial</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">bessel filters</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmove">float-vector-move!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polyoid">make-polyoid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#outputcommenthook">output-comment-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrohop">spectro-hop</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#bigbird">bigbird</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvmultiply">float-vector-multiply!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polyshape">make-polyshape</a></em></td><td></td><td><em class=tab><a href="sndscm.html#overlayrmsenv">overlay-rms-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroxangle">spectro-x-angle</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#bignum">bignum</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvoffset">float-vector-offset!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-polywave">make-polywave</a></em></td><td></td><td><em class=tab><a href="s7.html#owlet">owlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectroxscale">spectro-x-scale</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#bignump">bignum?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvpeak">float-vector-peak</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pulse-train">make-pulse-train</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#spectroyangle">spectro-y-angle</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#binaryiodoc">binary files</a></em></td><td></td><td><em class=tab><a href="sndscm.html#vctpolynomial">float-vector-polynomial</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-pulsed-env">make-pulsed-env</a></em></td><td></td><td class="green"><div class="centered">P</div></td><td></td><td><em class=tab><a href="extsnd.html#spectroyscale">spectro-y-scale</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#bindkey">bind-key</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvref">float-vector-ref</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-r2k!cos">make-r2k!cos</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#spectrozangle">spectro-z-angle</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#bird">bird</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvreverse">float-vector-reverse!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-r2k2cos">make-r2k2cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#padchannel">pad-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrozscale">spectro-z-scale</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#blackman">blackman</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvscale">float-vector-scale!</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makeramp">make-ramp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#padmarks">pad-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#spectrum">spectrum</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#blackman4envchannel">blackman4-env-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvset">float-vector-set!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rand">make-rand</a></em></td><td></td><td><em class=tab><a href="sndscm.html#padsound">pad-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spectrumtocoeffs">spectrum->coeffs</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#blackman?">blackman?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvsubseq">float-vector-subseq</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rand-interp">make-rand-interp</a></em></td><td></td><td><em class=tab><a href="s7.html#pairfilename">pair-filename</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrumend">spectrum-end</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#boldpeaksfont">bold-peaks-font</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvsubtract">float-vector-subtract!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rcos">make-rcos</a></em></td><td></td><td><em class=tab><a href="s7.html#pairlinenumber">pair-line-number</a></em></td><td></td><td><em class=tab><a href="extsnd.html#spectrumstart">spectrum-start</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#break">break</a></em></td><td></td><td><em class=tab><a href="extsnd.html#fvp">float-vector?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-readin">make-readin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#panmix">pan-mix</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedcontrol">speed-control</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#brown-noise">brown-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#flocsig">flocsig</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeregion">make-region</a></em></td><td></td><td><em class=tab><a href="sndscm.html#panmixvct">pan-mix-float-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedcontrolbounds">speed-control-bounds</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#brown-noise?">brown-noise?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#flocsig?">flocsig?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makeregionsampler">make-region-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#partialstopolynomial">partials->polynomial</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedstyle">speed-control-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">butterworth filters</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereoflute">flute model</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rk!cos">make-rk!cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#partialstowave">partials->wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#speedtones">speed-control-tones</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#bytevector">byte-vector</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmbell">fm-bell</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rk!ssb">make-rk!ssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#pausing">pausing</a></em></td><td></td><td><em class=tab><a href="sndscm.html#spotfreq">spot-freq</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#bytevectorp">byte-vector?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmdrum">fm-drum</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkcos">make-rkcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peakenvdir">peak-env-dir</a></em></td><td></td><td><em class=tab><a href="sndclm.html#square-wave">square-wave</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#fmnoise">fm-noise</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkoddssb">make-rkoddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peaks">peaks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#square-wave?">square-wave?</a></em></td></tr>
+ <tr><td class="green"><div class="centered">C</div></td><td></td><td><em class=tab><a href="sndscm.html#fmparallelcomponent">fm-parallel-component</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rksin">make-rksin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#peaksfont">peaks-font</a></em></td><td></td><td><em class=tab><a href="extsnd.html#squelchupdate">squelch-update</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#fmvox">fm-talker</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rkssb">make-rkssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-partialstowave">phase-partials->wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#squelchvowels">squelch-vowels</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#definecfunction">c-define</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmtrumpet">fm-trumpet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-round-interp">make-round-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-vocoder">phase-vocoder</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srate">srate</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cgp">c-g?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#vdoc">fm-violin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rssb">make-rssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#phase-vocoder?">phase-vocoder?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericsrate"><b>srate (generic)</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#cobject">c-object?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmvoice">fm-voice</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxycos">make-rxycos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#prc95doc"><b>Physical Models</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#src">src</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#cpoint">c-pointer</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fmssb">fmssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxyk!cos">make-rxyk!cos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pianodoc">piano model</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcchannel">src-channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#cpointer">c-pointer?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fmssb?">fmssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxyk!sin">make-rxyk!sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pink-noise">pink-noise</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcduration">src-duration</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#callwithexit">call-with-exit</a></em></td><td></td><td><em class=tab><a href="extsnd.html#focuswidget">focus-widget</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-rxysin">make-rxysin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pink-noise?">pink-noise?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcfitenvelope">src-fit-envelope</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#bagpipe">canter</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fofins">FOF synthesis</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sampletofile">make-sample->file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pins">pins</a></em></td><td></td><td><em class=tab><a href="sndscm.html#srcmixes">src-mixes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#cascadetocanonical">cascade->canonical</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fofins">fofins</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makesampler">make-sampler</a></em></td><td></td><td><em class=tab><a href="sndscm.html#placesound">place-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcsoundselection">src-selection</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#catch">catch</a></em></td><td></td><td><em class=tab><a href="sndscm.html#foreachchild">for-each-child</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sawtooth-wave">make-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#play">play</a></em></td><td></td><td><em class=tab><a href="extsnd.html#srcsound">src-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#cellon">cellon</a></em></td><td></td><td><em class=tab><a href="sndscm.html#foreachsoundfile">for-each-sound-file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makeselection">make-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericplay"><b>play (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#src?">src?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#chaindsps">chain-dsps</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fp">Forbidden Planet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-sinc-train">make-sinc-train</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playarrowsize">play-arrow-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ssb-am">ssb-am</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channeltovct">channel->vct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#foregroundcolor">foreground-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makesndtosample">make-snd->sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playbetweenmarks">play-between-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ssb-am?">ssb-am?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channelampenvs">channel-amp-envs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#forgetregion">forget-region</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makesoundbox">make-sound-box</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playhook">play-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbbank">ssb-bank</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channeldata">channel-data</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formant">formant</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makespencerfilter">make-spencer-filter</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playmixes">play-mixes</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbbankenv">ssb-bank-env</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelenvelope">channel-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formantbank">formant-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-square-wave">make-square-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playoften">play-often</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ssbfm">ssb-fm</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelpolynomial">channel-polynomial</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formantbankp">formant-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-src">make-src</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playregionforever">play-region-forever</a></em></td><td></td><td><em class=tab><a href="sndscm.html#startdac">start-dac</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channelproperties">channel-properties</a></em></td><td></td><td><em class=tab><a href="sndclm.html#formant?">formant?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-ssb-am">make-ssb-am</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsine">play-sine</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplaying">start-playing</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channelproperty">channel-property</a></em></td><td></td><td><em class=tab><a href="s7.html#format">format</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-table-lookup">make-table-lookup</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsines">play-sines</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplayinghook">start-playing-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelrms">channel-rms</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandforth"><b>Forth</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-table-lookup-with-env">make-table-lookup-with-env</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playsyncdmarks">play-syncd-marks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startplayingselectionhook">start-playing-selection-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channelstyle">channel-style</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fp">fp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-tanhsin">make-tanhsin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playuntilcg">play-until-c-g</a></em></td><td></td><td><em class=tab><a href="extsnd.html#startprogressreport">start-progress-report</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelsync">channel-sync</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fractionalfouriertransform">fractional-fourier-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-triangle-wave">make-triangle-wave</a></em></td><td></td><td><em class=tab><a href="sndscm.html#playwithenvs">play-with-envs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#statusreport">status-report</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channelwidgets">channel-widgets</a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletofile">frample->file</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-two-pole">make-two-pole</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playerhome">player-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stdinprompt">stdin-prompt</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#channels">channels</a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletofile?">frample->file?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-two-zero">make-two-zero</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playerQ">player?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereotomono">stereo->mono</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#genericchannels"><b>channels (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#frampletoframple">frample->frample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makevariabledisplay">make-variable-display</a></em></td><td></td><td><em class=tab><a href="extsnd.html#players">players</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stereoflute">stereo-flute</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelsequal">channels-equal?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#framples">framples</a></em></td><td></td><td><em class=tab><a href="extsnd.html#makevariablegraph">make-variable-graph</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playing">playing</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayer">stop-player</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#channelseq">channels=?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericframples"><b>framples (generic)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#makevct">make-vct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#playexamples"><b>Playing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplaying">stop-playing</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#chans">chans</a></em></td><td></td><td><em class=tab><a href="extsnd.html#freeplayer">free-player</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-wave-train">make-wave-train</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pluck">pluck</a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayinghook">stop-playing-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#charposition">char-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#freesampler">free-sampler</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-wave-train-with-env">make-wave-train-with-env</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandladspa"><b>Plugins</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#stopplayingselectionhook">stop-playing-selection-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#chebyhka">cheby-hka</a></em></td><td></td><td><em class=tab><a href="sndscm.html#freeverb">freeverb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mapchannel">map-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polartorectangular">polar->rectangular</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stretchenvelope">stretch-envelope</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">chebyshev filters</a></em></td><td></td><td><em class=tab><a href="fm.html#fmintro"><b>Frequency Modulation</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#mapsoundfiles">map-sound-files</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polynomial">polynomial</a></em></td><td></td><td><em class=tab><a href="sndscm.html#stretchsoundviadft">stretch-sound-via-dft</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#checkmixtags">check-mix-tags</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fullmix">fullmix</a></em></td><td></td><td><em class=tab><a href="sndscm.html#maracadoc">maracas</a></em></td><td></td><td><em class=tab><a href="sndscm.html#polydoc">polynomial operations</a></em></td><td></td><td><em class=tab><a href="s7.html#stringposition">string-position</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#chordalize">chordalize</a></em></td><td></td><td><em class=tab><a href="s7.html#funclet">funclet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marktointeger">mark->integer</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoid">polyoid</a></em></td><td></td><td><em class=tab><a href="s7.html#sublet">sublet</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#chorus">chorus</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#markclickhook">mark-click-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoidenv">polyoid-env</a></em></td><td></td><td><em class=tab><a href="sndscm.html#superimposeffts">superimpose-ffts</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#cleanchannel">clean-channel</a></em></td><td></td><td class="green"><div class="centered">G</div></td><td></td><td><em class=tab><a href="sndscm.html#markclickinfo">mark-click-info</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyoid?">polyoid?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#swapchannels">swap-channels</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#cleansound">clean-sound</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#markcolor">mark-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyshape">polyshape</a></em></td><td></td><td><em class=tab><a href="sndscm.html#swapselectionchannels">swap-selection-channels</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#clearlistener">clear-listener</a></em></td><td></td><td><em class=tab><a href="sndscm.html#gaussiandistribution">gaussian-distribution</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markcontext">mark-context</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polyshape?">polyshape?</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltodynamicvalue">symbol->dynamic-value</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cliphook">clip-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gcoff">gc-off</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markdraghook">mark-drag-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polywave">polywave</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltovalue">symbol->value</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#clipping">clipping</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gcon">gc-on</a></em></td><td></td><td><em class=tab><a href="sndscm.html#markexplode">mark-explode</a></em></td><td></td><td><em class=tab><a href="sndclm.html#polywave?">polywave?</a></em></td><td></td><td><em class=tab><a href="s7.html#symbolaccess">symbol-access</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#clmchannel">clm-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#generators"><b>Generators</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#markhome">mark-home</a></em></td><td></td><td><em class=tab><a href="s7.html#portfilename">port-filename</a></em></td><td></td><td><em class=tab><a href="s7.html#symboltable">symbol-table</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#clmexpsrc">clm-expsrc</a></em></td><td></td><td><em class=tab><a href="s7.html#gensym">gensym</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markhook">mark-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#portlinenumber">port-line-number</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sync">sync</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#closehook">close-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#gensym?">gensym?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#markloops">mark-loops</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positiontox">position->x</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericsync"><b>sync (generic)</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#closesound">close-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#glgraphtops">gl-graph->ps</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markname">mark-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positiontoy">position->y</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sync-everything">sync-everything</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colortolist">color->list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#glspectrogram">glSpectrogram</a></em></td><td></td><td><em class=tab><a href="sndscm.html#marknametoid">mark-name->id</a></em></td><td></td><td><em class=tab><a href="extsnd.html#positioncolor">position-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncmax">sync-max</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colorcutoff">color-cutoff</a></em></td><td></td><td><em class=tab><a href="sndscm.html#goertzel">goertzel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markproperties">mark-properties</a></em></td><td></td><td><em class=tab><a href="sndscm.html#powerenv">power-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncstyle">sync-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colorhook">color-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gotolistenerend">goto-listener-end</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markproperty">mark-property</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqw">pqw</a></em></td><td></td><td><em class=tab><a href="extsnd.html#syncdmarks">syncd-marks</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colorinverted">color-inverted</a></em></td><td></td><td><em class=tab><a href="sndscm.html#grani">grani</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksample">mark-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqwvox">pqw-vox</a></em></td><td></td><td><em class=tab><a href="sndscm.html#syncdmixes">syncd-mixes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#colormixes">color-mixes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#grains"><b>Granular synthesis</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksync">mark-sync</a></em></td><td></td><td><em class=tab><a href="extsnd.html#preferencesdialog">preferences-dialog</a></em></td><td></td><td><em class=tab><a href="sndscm.html#syncup">syncup</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colororientationdialog">color-orientation-dialog</a></em></td><td></td><td><em class=tab><a href="sndclm.html#granulate">granulate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#marksynccolor">mark-sync-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#previoussample">previous-sample</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colorscale">color-scale</a></em></td><td></td><td><em class=tab><a href="sndclm.html#granulate?">granulate?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marksyncmax">mark-sync-max</a></em></td><td></td><td><em class=tab><a href="extsnd.html#printdialog">print-dialog</a></em></td><td></td><td class="green"><div class="centered">T</div></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colorp">color?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#granulatedsoundinterp">granulated-sound-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marktagheight">mark-tag-height</a></em></td><td></td><td><em class=tab><a href="extsnd.html#printlength">print-length</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormap">colormap</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graph">graph</a></em></td><td></td><td><em class=tab><a href="extsnd.html#marktagwidth">mark-tag-width</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduredocumentation">procedure-documentation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#table-lookup">table-lookup</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormaptointeger">colormap->integer</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphtops">graph->ps</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markp">mark?</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresetter">procedure-setter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#table-lookup?">table-lookup?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormapname">colormap-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphcolor">graph-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#markstuff"><b>Marking</b></a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresignature">procedure-signature</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tanhsin">tanhsin</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormapref">colormap-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphcursor">graph-cursor</a></em></td><td></td><td><em class=tab><a href="extsnd.html#emarks">marks</a></em></td><td></td><td><em class=tab><a href="s7.html#proceduresource">procedure-source</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tanhsin?">tanhsin?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormapsize">colormap-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphdata">graph-data</a></em></td><td></td><td><em class=tab><a href="sndscm.html#matchsoundfiles">match-sound-files</a></em></td><td></td><td><em class=tab><a href="extsnd.html#progressreport">progress-report</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tap">tap</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colormapp">colormap?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphhook">graph-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#maxenvelope">max-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulse-train">pulse-train</a></em></td><td></td><td><em class=tab><a href="sndclm.html#tap?">tap?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#colors"><b>Colors</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphstyle">graph-style</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxregions">max-regions</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulse-train?">pulse-train?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#telephone">telephone</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#comb">comb</a></em></td><td></td><td><em class=tab><a href="sndscm.html#grapheq">graphic equalizer</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxfftpeaks">max-transform-peaks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulsedenv">pulsed-env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#tempdir">temp-dir</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#combbank">comb-bank</a></em></td><td></td><td><em class=tab><a href="extsnd.html#graphshorizontal">graphs-horizontal</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxamp">maxamp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#pulsedenv?">pulsed-env?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#textfocuscolor">text-focus-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#combbankp">comb-bank?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise">green-noise</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericmaxamp"><b>maxamp (generic)</b></a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#timegraphstyle">time-graph-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#comb?">comb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise-interp">green-noise-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxampposition">maxamp-position</a></em></td><td></td><td class="green"><div class="centered">R</div></td><td></td><td><em class=tab><a href="extsnd.html#timegraphtype">time-graph-type</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#combineddatacolor">combined-data-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise-interp?">green-noise-interp?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#maxampexamples"><b>Maxamps</b></a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#timegraphp">time-graph?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#comment">comment</a></em></td><td></td><td><em class=tab><a href="sndclm.html#green-noise?">green-noise?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#menuwidgets">menu-widgets</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k!cos">r2k!cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#timestosamples">times->samples</a></em></td></tr>
+ <tr><td><em class=tab><a href="grfsnd.html#sndwithcm"><b>Common Music</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#griddensity">grid-density</a></em></td><td></td><td><em class=tab><a href="sndscm.html#menusdoc">menus, optional</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k!cos?">r2k!cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#tinyfont">tiny-font</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#complexify">complexify</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mindb">min-dB</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k2cos">r2k2cos</a></em></td><td></td><td><em class=tab><a href="sndscm.html#telephone">touch-tone</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#computeuniformcircularstring">compute-uniform-circular-string</a></em></td><td></td><td class="green"><div class="centered">H</div></td><td></td><td><em class=tab><a href="extsnd.html#mix">mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#r2k2cos?">r2k2cos?</a></em></td><td></td><td><em class=tab><a href="s7.html#trace">trace</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#concatenateenvelopes">concatenate-envelopes</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#mixtovct">mix->float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#radianstodegrees">radians->degrees</a></em></td><td></td><td><em class=tab><a href="extsnd.html#trackingcursors"><b>Tracking cursors</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#constantp">constant?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#harmonicizer">harmonicizer</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtointeger">mix->integer</a></em></td><td></td><td><em class=tab><a href="sndclm.html#radianstohz">radians->hz</a></em></td><td></td><td><em class=tab><a href="extsnd.html#trackingcursorstyle">tracking-cursor-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#continuationp">continuation?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#dht">Hartley transform</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixamp">mix-amp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#rampchannel">ramp-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtointeger">transform->integer</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#continue-frampletofile">continue-frample->file</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtable">hash-table</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixampenv">mix-amp-env</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand">rand</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtovct">transform->vct</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#continue-sampletofile">continue-sample->file</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtablestar">hash-table*</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixchannel">mix-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand-interp">rand-interp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformdialog">transform-dialog</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#contrastchannel">contrast-channel</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableentries">hash-table-entries</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixclickhook">mix-click-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand-interp?">rand-interp?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformframples">transform-framples</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#contrastcontrol">contrast-control</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableref">hash-table-ref</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixclickinfo">mix-click-info</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rand?">rand?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphstyle">transform-graph-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#contrastcontrolamp">contrast-control-amp</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtableset">hash-table-set!</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixclicksetsamp">mix-click-sets-amp</a></em></td><td></td><td><em class=tab><a href="s7.html#random">random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphtype">transform-graph-type</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#contrastcontrolbounds">contrast-control-bounds</a></em></td><td></td><td><em class=tab><a href="s7.html#hashtablep">hash-table?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixcolor">mix-color</a></em></td><td></td><td><em class=tab><a href="sndscm.html#allrandomnumbers"><b>Random Numbers</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformgraphp">transform-graph?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#contrastcontrolp">contrast-control?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#headertype">header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixdialogmix">mix-dialog-mix</a></em></td><td></td><td><em class=tab><a href="s7.html#randomstate">random-state</a></em></td><td></td><td><em class=tab><a href="extsnd.html#normalizefft">transform-normalization</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#contrast-enhancement">contrast-enhancement</a></em></td><td></td><td><em class=tab><a href="snd.html#formats"><b>Headers and sample types</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixdraghook">mix-drag-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#randomstatep">random-state?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformsample">transform-sample</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#contrastsound">contrast-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#hellodentist">hello-dentist</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixfiledialog">mix-file-dialog</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rcos">rcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformsize">transform-size</a></em></td></tr>
+ <tr><td><em class=tab><a href="snd.html#controls"><b>Control Panel</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#helpdialog">help-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixhome">mix-home</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rcos?">rcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformtype">transform-type</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#controlstochannel">controls->channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#helphook">help-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixlength">mix-length</a></em></td><td></td><td><em class=tab><a href="s7.html#readerrorhook">*read-error-hook*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#transformp">transform?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#convolution">convolution</a></em></td><td></td><td><em class=tab><a href="extsnd.html#hidewidget">hide-widget</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixmaxamp">mix-maxamp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readhook">read-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#transposemixes">transpose-mixes</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#convolvewith">convolution reverb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#highlightcolor">highlight-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixname">mix-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readmixsample">read-mix-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#triangle-wave">triangle-wave</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#convolve">convolve</a></em></td><td></td><td><em class=tab><a href="sndscm.html#hilberttransform">hilbert-transform</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mixnametoid">mix-name->id</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readonly">read-only</a></em></td><td></td><td><em class=tab><a href="sndclm.html#triangle-wave?">triangle-wave?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#convolvefiles">convolve-files</a></em></td><td></td><td><em class=tab><a href="s7.html#hookfunctions">hook-functions</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixposition">mix-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readregionsample">read-region-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#tubebell">tubebell</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#convolveselectionwith">convolve-selection-with</a></em></td><td></td><td><em class=tab><a href="sndscm.html#hookmember">hook-member</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixproperties">mix-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readsample">read-sample</a></em></td><td></td><td><em class=tab><a href="sndscm.html#tubebell">tubular bell</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#convolvewith">convolve-with</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndhooks"><b>Hooks</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixproperty">mix-property</a></em></td><td></td><td><em class=tab><a href="extsnd.html#readsamplewithdirection">read-sample-with-direction</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-pole">two-pole</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#convolve?">convolve?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#html">html</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixregion">mix-region</a></em></td><td></td><td><em class=tab><a href="s7.html#readercond">reader-cond</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-pole?">two-pole?</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#s7copy">copy</a></em></td><td></td><td><em class=tab><a href="extsnd.html#htmldir">html-dir</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixreleasehook">mix-release-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#readin">readin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#twotab">two-tab</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#genericcopy"><b>copy (generic)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#htmlprogram">html-program</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixsamplerQ">mix-sampler?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#readin?">readin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-zero">two-zero</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#copycontext">copy-context</a></em></td><td></td><td><em class=tab><a href="sndclm.html#hztoradians">hz->radians</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixselection">mix-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rectangulartomagnitudes">rectangular->magnitudes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#two-zero?">two-zero?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#copysampler">copy-sampler</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#mixsound">mix-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rectangulartopolar">rectangular->polar</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#copying"><b>Copying</b></a></em></td><td></td><td class="green"><div class="centered">I</div></td><td></td><td><em class=tab><a href="extsnd.html#mixspeed">mix-speed</a></em></td><td></td><td><em class=tab><a href="extsnd.html#redo">redo</a></em></td><td></td><td class="green"><div class="centered">U</div></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#correlate">correlate</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mixsync">mix-sync</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiontointeger">region->integer</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#coverlet">coverlet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#iir-filter">iir-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixsyncmax">mix-sync-max</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiontovct">region->vct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#unbindkey">unbind-key</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#mixdoc">cross-fade (amplitude)</a></em></td><td></td><td><em class=tab><a href="sndclm.html#iir-filter?">iir-filter?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagheight">mix-tag-height</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionchans">region-chans</a></em></td><td></td><td><em class=tab><a href="s7.html#unboundvariablehook">*unbound-variable-hook*</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#fadedoc">cross-fade (frequency domain)</a></em></td><td></td><td><em class=tab><a href="extsnd.html#gin">in</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagwidth">mix-tag-width</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionframples">region-framples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#unclipchannel">unclip-channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#crosssynthesis">cross-synthesis</a></em></td><td></td><td><em class=tab><a href="sndclm.html#in-any">in-any</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixtagy">mix-tag-y</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regiongraphstyle">region-graph-style</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undo">undo</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#curlet">curlet</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ina">ina</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixvct">mix-vct</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionhome">region-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undoexamples"><b>Undo and Redo</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#currentfont">current-font</a></em></td><td></td><td><em class=tab><a href="sndclm.html#inb">inb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixwaveformheight">mix-waveform-height</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionmaxamp">region-maxamp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#undohook">undo-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursor">cursor</a></em></td><td></td><td><em class=tab><a href="extsnd.html#infodialog">info-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixp">mix?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionmaxampposition">region-maxamp-position</a></em></td><td></td><td><em class=tab><a href="s7.html#unlet">unlet</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorcolor">cursor-color</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#initladspa">init-ladspa</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mixes">mixes</a></em></td><td></td><td><em class=tab><a href="sndscm.html#regionplaylist">region-play-list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#unselectall">unselect-all</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorcontext">cursor-context</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialbeg">initial-beg</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sndmixes"><b>Mixing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionposition">region-position</a></em></td><td></td><td><em class=tab><a href="sndscm.html#updategraphs">update-graphs</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorlocationoffset">cursor-location-offset</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialdur">initial-dur</a></em></td><td></td><td><em class=tab><a href="sndscm.html#monotostereo">mono->stereo</a></em></td><td></td><td><em class=tab><a href="sndscm.html#regionrms">region-rms</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatehook">update-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorposition">cursor-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#initialgraphhook">initial-graph-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#moogfilter">moog-filter</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsample">region-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatelispgraph">update-lisp-graph</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorsize">cursor-size</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndinitfile"><b>Initialization file</b></a></em></td><td></td><td><em class=tab><a href="s7.html#morallyequalp">morally-equal?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsamplerQ">region-sampler?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatesound">update-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorstyle">cursor-style</a></em></td><td></td><td><em class=tab><a href="s7.html#inlet">inlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseclickhook">mouse-click-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionsrate">region-srate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatetimegraph">update-time-graph</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorupdateinterval">cursor-update-interval</a></em></td><td></td><td><em class=tab><a href="sndscm.html#insertchannel">insert-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousedraghook">mouse-drag-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionok">region?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#updatetransformgraph">update-transform-graph</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cursorexamples"><b>Cursors</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertfiledialog">insert-file-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseentergraphhook">mouse-enter-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#eregions">regions</a></em></td><td></td><td><em class=tab><a href="sndscm.html#uponsaveyourself">upon-save-yourself</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#cutlet">cutlet</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertregion">insert-region</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseenterlabelhook">mouse-enter-label-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#regionstuff"><b>Regions</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#sndmotifdoc">user interface extensions</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#cyclicsequences">cyclic-sequences</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertsample">insert-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseenterlistenerhook">mouse-enter-listener-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#remembersoundstate">remember-sound-state</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#insertsamples">insert-samples</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseentertexthook">mouse-enter-text-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#removeclicks">remove-clicks</a></em></td><td></td><td class="green"><div class="centered">V</div></td></tr>
+ <tr><td class="green"><div class="centered">D</div></td><td></td><td><em class=tab><a href="extsnd.html#insertselection">insert-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseleavegraphhook">mouse-leave-graph-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#removefrommenu">remove-from-menu</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#insertsilence">insert-silence</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mouseleavelabelhook">mouse-leave-label-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#replacewithselection">replace-with-selection</a></em></td><td></td><td><em class=tab><a href="sndscm.html#variabledisplay">variable-display</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#dacfolding">dac-combines-channels</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertsound">insert-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousleavelistenerhook">mouse-leave-listener-hook</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reportmarknames">report-mark-names</a></em></td><td></td><td><em class=tab><a href="extsnd.html#variablegraphp">variable-graph?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#dacsize">dac-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#insertionexamples"><b>Insertions</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousleavetexthook">mouse-leave-text-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#requires7">require</a></em></td><td></td><td><em class=tab><a href="s7.html#varlet">varlet</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#datacolor">data-color</a></em></td><td></td><td><em class=tab><a href="s7.html#intvector">int-vector</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mousepresshook">mouse-press-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resampleexamples"><b>Resampling</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vct">vct</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#datalocation">data-location</a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorref">int-vector-ref</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-locsig">move-locsig</a></em></td><td></td><td><em class=tab><a href="sndscm.html#resetallhooks">reset-all-hooks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttimes">vct*</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#datasize">data-size</a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorset">int-vector-set!</a></em></td><td></td><td><em class=tab><a href="sndscm.html#movemixes">move-mixes</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resetcontrols">reset-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctplus">vct+</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#dbtolinear">db->linear</a></em></td><td></td><td><em class=tab><a href="s7.html#intvectorp">int-vector?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-sound">move-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#resetlistenercursor">reset-listener-cursor</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttochannel">vct->channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#cdebugging"><b>Debugging (C)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertocolormap">integer->colormap</a></em></td><td></td><td><em class=tab><a href="sndclm.html#move-sound?">move-sound?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reson">reson</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttolist">vct->list</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#variabledisplay"><b>Debugging (instruments)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertomark">integer->mark</a></em></td><td></td><td><em class=tab><a href="sndscm.html#movesyncdmarks">move-syncd-marks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#restorecontrols">restore-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttostring">vct->string</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#snderrors"><b>Debugging (Scheme)</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertomix">integer->mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-autocorrelation">moving-autocorrelation</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reverbexamples"><b>Reverb</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vcttovector">vct->vector</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#defaultoutputchans">default-output-chans</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertoregion">integer->region</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-autocorrelation?">moving-autocorrelation?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#*reverb*">*reverb*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctabs">vct-abs!</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#defaultoutputheadertype">default-output-header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertosound">integer->sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-average">moving-average</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbdecay">reverb-control-decay</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctadd">vct-add!</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#defaultoutputsampletype">default-output-sample-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#integertotransform">integer->transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-average?">moving-average?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolfeedback">reverb-control-feedback</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctcopy">vct-copy</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#defaultoutputsrate">default-output-srate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#integrateenvelope">integrate-envelope</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-fft">moving-fft</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollength">reverb-control-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctequal">vct-equal?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#defgenerator">defgenerator</a></em></td><td></td><td><em class=tab><a href="sndscm.html#invertfilter">invert-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-fft?">moving-fft?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollengthbounds">reverb-control-length-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctfill">vct-fill!</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#definestar">define*</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndswitches"><b>Invocation flags</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-length">moving-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrollowpass">reverb-control-lowpass</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctlength">vct-length</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#defineconstant">define-constant</a></em></td><td></td><td><em class=tab><a href="s7.html#iterate">iterate</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-max">moving-max</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolscale">reverb-control-scale</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmax">vct-max</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#defineenvelope">define-envelope</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratoratend">iterator-at-end?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-max?">moving-max?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolscalebounds">reverb-control-scale-bounds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmin">vct-min</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#expansion">define-expansion</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratorsequence">iterator-sequence</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-norm">moving-norm</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverbcontrolp">reverb-control?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmove">vct-move!</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#definemacro">define-macro</a></em></td><td></td><td><em class=tab><a href="s7.html#iteratorp">iterator?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-norm?">moving-norm?</a></em></td><td></td><td><em class=tab><a href="s7.html#reverseb">reverse!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctmultiply">vct-multiply!</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#definemacrostar">define-macro*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#izcos">izcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-pitch">moving-pitch</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reversebyblocks">reverse-by-blocks</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctoffset">vct-offset!</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#defineselectionviamarks">define-selection-via-marks</a></em></td><td></td><td><em class=tab><a href="sndclm.html#izcos?">izcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-pitch?">moving-pitch?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reversechannel">reverse-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctpeak">vct-peak</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#definedp">defined?</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#moving-rms">moving-rms</a></em></td><td></td><td><em class=tab><a href="sndscm.html#reverseenvelope">reverse-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctref">vct-ref</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#degreestoradians">degrees->radians</a></em></td><td></td><td class="green"><div class="centered">J</div></td><td></td><td><em class=tab><a href="sndclm.html#moving-scentroid">moving-scentroid</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverseselection">reverse-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctreverse">vct-reverse!</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#delay">delay</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#moving-scentroid?">moving-scentroid?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reversesound">reverse-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctscale">vct-scale!</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#delaychannelmixes">delay-channel-mixes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0evencos">j0evencos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-spectrum">moving-spectrum</a></em></td><td></td><td><em class=tab><a href="extsnd.html#reverseexamples"><b>Reversing</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctset">vct-set!</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#delaytick">delay-tick</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0evencos?">j0evencos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-spectrum?">moving-spectrum?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#revertsound">revert-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctsubseq">vct-subseq</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#delay?">delay?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0j1cos">j0j1cos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#moving-sum">moving-sum</a></em></td><td></td><td><em class=tab><a href="extsnd.html#rightsample">right-sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctsubtract">vct-subtract!</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletecolormap">delete-colormap</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j0j1cos?">j0j1cos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#mpg">mpg</a></em></td><td></td><td><em class=tab><a href="sndclm.html#ring-modulate">ring-modulate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vctp">vct?</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletefilefilter">delete-file-filter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j2cos">j2cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsabuffersize">mus-alsa-buffer-size</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!cos">rk!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#Vcts"><b>Vcts</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletefilesorter">delete-file-sorter</a></em></td><td></td><td><em class=tab><a href="sndclm.html#j2cos?">j2cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsabuffers">mus-alsa-buffers</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!cos?">rk!cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#vectortovct">vector->vct</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletemark">delete-mark</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandjack"><b>Jack</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsacapturedevice">mus-alsa-capture-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!ssb">rk!ssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesamp">view-files-amp</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletemarks">delete-marks</a></em></td><td></td><td><em class=tab><a href="sndscm.html#jcreverb">jc-reverb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsadevice">mus-alsa-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rk!ssb?">rk!ssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesampenv">view-files-amp-env</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletesample">delete-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jjcos">jjcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsaplaybackdevice">mus-alsa-playback-device</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkcos">rkcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesdialog">view-files-dialog</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletesamples">delete-samples</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jjcos?">jjcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musalsasquelchwarning">mus-alsa-squelch-warning</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkcos?">rkcos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesfiles">view-files-files</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletesamplesandsmooth">delete-samples-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jncos">jncos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musarrayprintlength">mus-array-print-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkoddssb">rkoddssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesselecthook">view-files-select-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deleteselection">delete-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jncos?">jncos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musbytespersample">mus-bytes-per-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkoddssb?">rkoddssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesselectedfiles">view-files-selected-files</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deleteselectionandsmooth">delete-selection-and-smooth</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jpcos">jpcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-channel">mus-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rksin">rksin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilessort">view-files-sort</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletetransform">delete-transform</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jpcos?">jpcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-channels">mus-channels</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rksin?">rksin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesspeed">view-files-speed</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#deletionexamples"><b>Deletions</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#justsounds">just-sounds</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-chebyshev-tu-sum">mus-chebyshev-tu-sum</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkssb">rkssb</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewfilesspeedstyle">view-files-speed-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#describehook">describe-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jycos">jycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musclipping">mus-clipping</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rkssb?">rkssb?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewmixesdialog">view-mixes-dialog</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#describemark">describe-mark</a></em></td><td></td><td><em class=tab><a href="sndclm.html#jycos?">jycos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-close">mus-close</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsgain">rms</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewregionsdialog">view-regions-dialog</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#dht">dht</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#mus-copy">mus-copy</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsgain">rms, gain, balance gens</a></em></td><td></td><td><em class=tab><a href="extsnd.html#viewsound">view-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#dialogwidgets">dialog-widgets</a></em></td><td></td><td class="green"><div class="centered">K</div></td><td></td><td><em class=tab><a href="sndclm.html#mus-data">mus-data</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rmsenvelope">rms-envelope</a></em></td><td></td><td><em class=tab><a href="sndscm.html#singerdoc">voice physical model</a></em></td></tr>
+ <tr><td><em class=tab><a href="s7.html#dilambda">dilambda</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#mus-describe">mus-describe</a></em></td><td></td><td><em class=tab><a href="s7.html#rootlet">rootlet</a></em></td><td></td><td><em class=tab><a href="sndscm.html#voicedtounvoiced">voiced->unvoiced</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#disablecontrolpanel">disable-control-panel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2cos">k2cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#muserrorhook">mus-error-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#round-interp">round-interp</a></em></td><td></td><td><em class=tab><a href="sndscm.html#volterrafilter">volterra-filter</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#displaybarkfft">display-bark-fft</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2cos?">k2cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#muserrortypetostring">mus-error-type->string</a></em></td><td></td><td><em class=tab><a href="sndclm.html#round-interp?">round-interp?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#fmvox">vox</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#displaycorrelation">display-correlation</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2sin">k2sin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musexpandfilename">mus-expand-filename</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssb">rssb</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#displaydb">display-db</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2sin?">k2sin?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-feedback">mus-feedback</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssbinterp">rssb-interp</a></em></td><td></td><td class="green"><div class="centered">W</div></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#displayedits">display-edits</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2ssb">k2ssb</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-feedforward">mus-feedforward</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rssb?">rssb?</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#displayenergy">display-energy</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k2ssb?">k2ssb?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#fft">mus-fft</a></em></td><td></td><td><em class=tab><a href="sndscm.html#rubbersound">rubber-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#wave-train">wave-train</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#dissolvefade">dissolve-fade</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k3sin">k3sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musfilebuffersize">mus-file-buffer-size</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndandruby"><b>Ruby</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#wave-train?">wave-train?</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#ditherchannel">dither-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#k3sin?">k3sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musfileclipping">mus-file-clipping</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxycos">rxycos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavelettype">wavelet-type</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#dithersound">dither-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#kalmanfilterchannel">kalman-filter-channel</a></em></td><td></td><td><em class=tab><a href="sndscm.html#musfilemix">mus-file-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxycos?">rxycos?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#pqwvox">waveshaping voice</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#dolph">dolph</a></em></td><td></td><td><em class=tab><a href="extsnd.html#key">key</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-file-name">mus-file-name</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!cos">rxyk!cos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavohop">wavo-hop</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#dot-product">dot-product</a></em></td><td></td><td><em class=tab><a href="extsnd.html#keybinding">key-binding</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musfloatequalfudgefactor">mus-float-equal-fudge-factor</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!cos?">rxyk!cos?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#wavotrace">wavo-trace</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#dotsize">dot-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#keypresshook">key-press-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-frequency">mus-frequency</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!sin">rxyk!sin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#weighted-moving-average">weighted-moving-average</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#downoct">down-oct</a></em></td><td></td><td><em class=tab><a href="sndclm.html#krksin">krksin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#musgeneratorp">mus-generator?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxyk!sin?">rxyk!sin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgetposition">widget-position</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawaxes">draw-axes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#krksin?">krksin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musheaderrawdefaults">mus-header-raw-defaults</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxysin">rxysin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgetsize">widget-size</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawdot">draw-dot</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#musheadertypetostring">mus-header-type->string</a></em></td><td></td><td><em class=tab><a href="sndclm.html#rxysin?">rxysin?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#widgettext">widget-text</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawdots">draw-dots</a></em></td><td></td><td class="green"><div class="centered">L</div></td><td></td><td><em class=tab><a href="extsnd.html#musheadertypename">mus-header-type-name</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#movingwindows"><b>Window size and position</b></a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawline">draw-line</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#mus-hop">mus-hop</a></em></td><td></td><td class="green"><div class="centered">S</div></td><td></td><td><em class=tab><a href="extsnd.html#windowheight">window-height</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawlines">draw-lines</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#ladspadescriptor">ladspa-descriptor</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-increment">mus-increment</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndscm.html#windowsamples">window-samples</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawmarkhook">draw-mark-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ladspadir">ladspa-dir</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-input?">mus-input?</a></em></td><td></td><td><em class=tab><a href="s7.html#s7doc"><b>s7 scheme</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowwidth">window-width</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawmixhook">draw-mix-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#lambdastar">lambda*</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-interp-type">mus-interp-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sample">sample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowx">window-x</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drawstring">draw-string</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lbjpiano">lbj-piano</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-interpolate">mus-interpolate</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sampletofile">sample->file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#windowy">window-y</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#drone">drone</a></em></td><td></td><td><em class=tab><a href="extsnd.html#leftsample">left-sample</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-length">mus-length</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sampletofile?">sample->file?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withbackgroundprocesses">with-background-processes</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#makedropsite">drop sites</a></em></td><td></td><td><em class=tab><a href="extsnd.html#genericlength"><b>length (generic)</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-location">mus-location</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sampletype">sample-type</a></em></td><td></td><td><em class=tab><a href="s7.html#withbaffle">with-baffle</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#drophook">drop-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#lettolist">let->list</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musmaxmalloc">mus-max-malloc</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sampleratendQ">sampler-at-end?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withfilemonitor">with-file-monitor</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#duringopenhook">during-open-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#letref">let-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musmaxtablesize">mus-max-table-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerhome">sampler-home</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withgl">with-gl</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="s7.html#letset">let-set!</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-name">mus-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerposition">sampler-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withinsetgraph">with-inset-graph</a></em></td></tr>
+ <tr><td class="green"><div class="centered">E</div></td><td></td><td><em class=tab><a href="s7.html#letp">let?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-offset">mus-offset</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplerQ">sampler?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withinterrupts">with-interrupts</a></em></td></tr>
+ <tr><td><em class=tab> </em></td><td></td><td><em class=tab><a href="sndclm.html#lineartodb">linear->db</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-order">mus-order</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samplers"><b>samplers</b></a></em></td><td></td><td><em class=tab><a href="s7.html#with-let">with-let</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editlists"><b>Edit lists</b></a></em></td><td></td><td><em class=tab><a href="sndscm.html#linearsrcchannel">linear-src-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#musosssetbuffers">mus-oss-set-buffers</a></em></td><td></td><td><em class=tab><a href="extsnd.html#samples">samples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withlocalhook">with-local-hook</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editfragment">edit-fragment</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lintdoc">lint for scheme</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-output?">mus-output?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#samplestoseconds">samples->seconds</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withmenuicons">with-menu-icons</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editheaderdialog">edit-header-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphhook">lisp-graph-hook</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-phase">mus-phase</a></em></td><td></td><td><em class=tab><a href="extsnd.html#sashcolor">sash-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withmixtags">with-mix-tags</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#edithook">edit-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphstyle">lisp-graph-style</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ramp">mus-ramp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveasdialogautocomment">save-as-dialog-auto-comment</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withpointerfocus">with-pointer-focus</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editlisttofunction">edit-list->function</a></em></td><td></td><td><em class=tab><a href="extsnd.html#lispgraphp">lisp-graph?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-rand-seed">mus-rand-seed</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveasdialogsrc">save-as-dialog-src</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withrelativepanes">with-relative-panes</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editposition">edit-position</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listtofv">list->float-vector</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-random">mus-random</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savecontrols">save-controls</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withsmptelabel">with-smpte-label</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editproperties">edit-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listtovct">list->vct</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-reset">mus-reset</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savedir">save-dir</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withsound">with-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#editproperty">edit-property</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#listladspa">list-ladspa</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-run">mus-run</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveedithistory">save-edit-history</a></em></td><td></td><td><em class=tab><a href="sndscm.html#withtemporaryselection">with-temporary-selection</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#edittree">edit-tree</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerclickhook">listener-click-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussampletypetostring">mus-sample-type->string</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveenvelopes">save-envelopes</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtoolbar">with-toolbar</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#edits">edits</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenercolor">listener-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussampletypename">mus-sample-type-name</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savehook">save-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtooltips">with-tooltips</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#edot-product">edot-product</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenercolorized">listener-colorized</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-scaler">mus-scaler</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savelistener">save-listener</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withtrackingcursor">with-tracking-cursor</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#effectshook">effects-hook</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerfont">listener-font</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundchans">mus-sound-chans</a></em></td><td></td><td><em class=tab><a href="sndscm.html#savemarkproperties">save-mark-properties</a></em></td><td></td><td><em class=tab><a href="extsnd.html#withverbosecursor">with-verbose-cursor</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#analogfilterdoc">elliptic filters</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerprompt">listener-prompt</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcloseinput">mus-sound-close-input</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savemarks">save-marks</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="grfsnd.html#emacssnd"><b>Emacs and Snd</b></a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenerselection">listener-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcloseoutput">mus-sound-close-output</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savemix">save-mix</a></em></td><td></td><td class="green"><div class="centered">X</div></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#env">env</a></em></td><td></td><td><em class=tab><a href="extsnd.html#listenertextcolor">listener-text-color</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundcomment">mus-sound-comment</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveregion">save-region</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#env-any">env-any</a></em></td><td></td><td><em class=tab><a href="extsnd.html#littleendianp">little-endian?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussounddatalocation">mus-sound-data-location</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveregiondialog">save-region-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xtoposition">x->position</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envchannel">env-channel</a></em></td><td></td><td><em class=tab><a href="s7.html#loadhook">*load-hook*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussounddatumsize">mus-sound-datum-size</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveselection">save-selection</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xaxislabel">x-axis-label</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envchannelwithbase">env-channel-with-base</a></em></td><td></td><td><em class=tab><a href="s7.html#loadpath">*load-path*</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundduration">mus-sound-duration</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveselectiondialog">save-selection-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xaxisstyle">x-axis-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#envexptchannel">env-expt-channel</a></em></td><td></td><td><em class=tab><a href="sndscm.html#locatezero">locate-zero</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundforget">mus-sound-forget</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesound">save-sound</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xbounds">x-bounds</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#env-interp">env-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig">locsig</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundframples">mus-sound-framples</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesoundas">save-sound-as</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xpositionslider">x-position-slider</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#envmixes">env-mixes</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-ref">locsig-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundheadertype">mus-sound-header-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savesounddialog">save-sound-dialog</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xzoomslider">x-zoom-slider</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envselection">env-selection</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-reverb-ref">locsig-reverb-ref</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundlength">mus-sound-length</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestate">save-state</a></em></td><td></td><td><em class=tab><a href="sndscm.html#xbopen">xb-open</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envsound">env-sound</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-reverb-set!">locsig-reverb-set!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundloopinfo">mus-sound-loop-info</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestatefile">save-state-file</a></em></td><td></td><td><em class=tab><a href="extsnd.html#xrampchannel">xramp-channel</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#envsoundinterp">env-sound-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-set!">locsig-set!</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmarkinfo">mus-sound-mark-info</a></em></td><td></td><td><em class=tab><a href="extsnd.html#savestatehook">save-state-hook</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#envsquaredchannel">env-squared-channel</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig-type">locsig-type</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmaxamp">mus-sound-maxamp</a></em></td><td></td><td><em class=tab><a href="extsnd.html#saveexamples"><b>Saving</b></a></em></td><td></td><td class="green"><div class="centered">Y</div></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#env?">env?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#locsig?">locsig?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundmaxampexists">mus-sound-maxamp-exists?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#sgfilter">savitzky-golay-filter</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedbase">enved-base</a></em></td><td></td><td><em class=tab><a href="extsnd.html#logfreqstart">log-freq-start</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundopeninput">mus-sound-open-input</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sawtooth-wave">sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ytoposition">y->position</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedclipping">enved-clip?</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lpccoeffs">lpc-coeffs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundopenoutput">mus-sound-open-output</a></em></td><td></td><td><em class=tab><a href="sndclm.html#sawtooth-wave?">sawtooth-wave?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#yaxislabel">y-axis-label</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#enveddialog">enved-dialog</a></em></td><td></td><td><em class=tab><a href="sndscm.html#lpcpredict">lpc-predict</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundpath">mus-sound-path</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleby">scale-by</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ybounds">y-bounds</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedenvelope">enved-envelope</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundpreload">mus-sound-preload</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scalechannel">scale-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#ypositionslider">y-position-slider</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#filterenv">enved-filter</a></em></td><td></td><td class="green"><div class="centered">M</div></td><td></td><td><em class=tab><a href="extsnd.html#mussoundprune">mus-sound-prune</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scaleenvelope">scale-envelope</a></em></td><td></td><td><em class=tab><a href="extsnd.html#yzoomslider">y-zoom-slider</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#filterenvorder">enved-filter-order</a></em></td><td></td><td><em class=tab> </em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundread">mus-sound-read</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scalemixes">scale-mixes</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedhook">enved-hook</a></em></td><td></td><td><em class=tab><a href="s7.html#macrop">macro?</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundreopenoutput">mus-sound-reopen-output</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleselectionby">scale-selection-by</a></em></td><td></td><td class="green"><div class="centered">Z</div></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedin-dB">enved-in-dB</a></em></td><td></td><td><em class=tab><a href="s7.html#macroexpand">macroexpand</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundreportcache">mus-sound-report-cache</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleselectionto">scale-selection-to</a></em></td><td></td><td><em class=tab> </em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedpower">enved-power</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mainmenu">main-menu</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsampletype">mus-sound-sample-type</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scalesound">scale-sound</a></em></td><td></td><td><em class=tab><a href="sndscm.html#ztransform">z-transform</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedstyle">enved-style</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mainwidgets">main-widgets</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsamples">mus-sound-samples</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scaletempo">scale-tempo</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zecho">zecho</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedtarget">enved-target</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-abcos">make-abcos</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundseekframple">mus-sound-seek-frample</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scaleto">scale-to</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zeroplus">zero+</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedwaving">enved-wave?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-absin">make-absin</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundsrate">mus-sound-srate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scanchannel">scan-channel</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zeropad">zero-pad</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envedwaveformcolor">enved-waveform-color</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-sawtooth-wave">make-adjustable-sawtooth-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundtypespecifier">mus-sound-type-specifier</a></em></td><td></td><td><em class=tab><a href="sndscm.html#dspdocscanned">scanned synthesis</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zerophase">zero-phase</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#envelopeinterp">envelope-interp</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-square-wave">make-adjustable-square-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundwrite">mus-sound-write</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scentroid">scentroid</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zipsound">zip-sound</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndscm.html#envelopedmix">enveloped-mix</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-adjustable-triangle-wave">make-adjustable-triangle-wave</a></em></td><td></td><td><em class=tab><a href="extsnd.html#mussoundwritedate">mus-sound-write-date</a></em></td><td></td><td><em class=tab><a href="sndscm.html#scratch">scratch</a></em></td><td></td><td><em class=tab><a href="sndscm.html#zipper">zipper</a></em></td></tr>
+ <tr><td><em class=tab><a href="extsnd.html#envexamples"><b>Envelopes</b></a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-all-pass">make-all-pass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mussrate">mus-srate</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scriptarg">script-arg</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zoomcolor">zoom-color</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#eoddcos">eoddcos</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makeallpassbank">make-all-pass-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-width">mus-width</a></em></td><td></td><td><em class=tab><a href="extsnd.html#scriptargs">script-args</a></em></td><td></td><td><em class=tab><a href="extsnd.html#zoomfocusstyle">zoom-focus-style</a></em></td></tr>
+ <tr><td><em class=tab><a href="sndclm.html#eoddcos?">eoddcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-asyfm">make-asyfm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-xcoeff">mus-xcoeff</a></em></td><td></td><td><em class=tab><a href="grfsnd.html#sndwithnogui"><b>Scripting</b></a></em></td><td></td>
</tr>
- <tr><td><em class=tab><a href="sndclm.html#eoddcos?">eoddcos?</a></em></td><td></td><td><em class=tab><a href="sndclm.html#makeallpassbank">make-all-pass-bank</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mussrate">mus-srate</a></em></td><td></td><td><em class=tab><a href="sndscm.html#searchforclick">search-for-click</a></em></td><td></td>
+ <tr><td><em class=tab><a href="extsnd.html#epsbottommargin">eps-bottom-margin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-asymmetric-fm">make-asymmetric-fm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-xcoeffs">mus-xcoeffs</a></em></td><td></td><td><em class=tab><a href="sndscm.html#searchforclick">search-for-click</a></em></td><td></td>
</tr>
- <tr><td><em class=tab><a href="extsnd.html#epsbottommargin">eps-bottom-margin</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-asyfm">make-asyfm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-width">mus-width</a></em></td><td></td><td><em class=tab><a href="extsnd.html#searchprocedure">search-procedure</a></em></td><td></td>
+ <tr><td><em class=tab><a href="extsnd.html#epsfile">eps-file</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebandpass">make-bandpass</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ycoeff">mus-ycoeff</a></em></td><td></td><td><em class=tab><a href="extsnd.html#searchprocedure">search-procedure</a></em></td><td></td>
</tr>
- <tr><td><em class=tab><a href="extsnd.html#epsfile">eps-file</a></em></td><td></td><td><em class=tab><a href="sndclm.html#make-asymmetric-fm">make-asymmetric-fm</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-xcoeff">mus-xcoeff</a></em></td><td></td><td><em class=tab><a href="extsnd.html#searchexamples"><b>Searching</b></a></em></td><td></td>
+ <tr><td><em class=tab><a href="extsnd.html#epsleftmargin">eps-left-margin</a></em></td><td></td><td><em class=tab><a href="sndscm.html#makebandstop">make-bandstop</a></em></td><td></td><td><em class=tab><a href="sndclm.html#mus-ycoeffs">mus-ycoeffs</a></em></td><td></td><td><em class=tab><a href="extsnd.html#searchexamples"><b>Searching</b></a></em></td><td></td>
</tr>
</table>
diff --git a/index.scm b/index.scm
index f0c3eb6..dbb506a 100644
--- a/index.scm
+++ b/index.scm
@@ -6,44 +6,35 @@
(let ((documentation "(html arg) where arg can be a string, symbol, or procedure looks for a corresponding url
and if one is found, and the Snd documentation can be found, calls *html-program* with that url"))
(lambda (obj)
- (let ((goto-html
- (lambda (n)
- ;; look for doc on current dir, then html dir, then global dir
- ;; snd.html is what we'll search for
- (let ((dir (if (file-exists? "snd.html")
- (getcwd)
- (if (and (string? *html-dir*)
+ (let* ((goto-html
+ (lambda (n)
+ ;; look for doc on current dir, then html dir, then global dir
+ ;; snd.html is what we'll search for
+ (let ((dir (cond ((file-exists? "snd.html") (getcwd))
+ ((and (string? *html-dir*)
(file-exists? (string-append *html-dir* "/snd.html")))
- *html-dir*
- (if (file-exists? "/usr/share/doc/snd-16/snd.html")
- "/usr/share/doc/snd-16"
- (if (file-exists? "/usr/local/share/doc/snd-16/snd.html")
- "/usr/local/share/doc/snd-16"
- (if (file-exists? "/usr/doc/snd-16/snd.html")
- "/usr/doc/snd-16"
- (if (file-exists? "/usr/share/doc/snd-15/snd.html")
- "/usr/share/doc/snd-15"
- (if (file-exists? "/usr/local/share/doc/snd-15/snd.html")
- "/usr/local/share/doc/snd-15"
- (and (file-exists? "/usr/doc/snd-15/snd.html")
- "/usr/doc/snd-15"))))))))))
- (if dir
- (system (string-append *html-program* " file:" dir "/" n)))))))
-
- (let ((name (if (string? obj)
- obj
- (if (symbol? obj)
- (symbol->string obj)
- (let ((doc (and (procedure? obj)
- (procedure-documentation obj))))
- (if (and (string? doc)
- (char=? (doc 0) #\())
- (let ((pos (char-position ") " doc)))
- (and pos
- (substring doc 1 pos)))))))))
- (if (and name (string? name))
- (let ((url (snd-url name)))
- (if url
- (goto-html url)
- (snd-print (format #f "no url for ~A?" name))))
- (snd-print (format #f "no doc for ~A?" name))))))))
+ *html-dir*)
+ ((file-exists? "/usr/share/doc/snd-16/snd.html") "/usr/share/doc/snd-16")
+ ((file-exists? "/usr/local/share/doc/snd-16/snd.html") "/usr/local/share/doc/snd-16")
+ ((file-exists? "/usr/doc/snd-16/snd.html") "/usr/doc/snd-16")
+ ((file-exists? "/usr/share/doc/snd-15/snd.html") "/usr/share/doc/snd-15")
+ ((file-exists? "/usr/local/share/doc/snd-15/snd.html") "/usr/local/share/doc/snd-15")
+ (else (and (file-exists? "/usr/doc/snd-15/snd.html") "/usr/doc/snd-15")))))
+ (if dir
+ (system (string-append *html-program* " file:" dir "/" n))))))
+
+ (name (if (string? obj)
+ obj
+ (if (symbol? obj)
+ (symbol->string obj)
+ (let ((doc (and (procedure? obj)
+ (procedure-documentation obj))))
+ (if (and (string? doc)
+ (char=? (doc 0) #\())
+ (let ((pos (char-position ") " doc)))
+ (and pos
+ (substring doc 1 pos)))))))))
+ (if (string? name)
+ (cond ((snd-url name) => goto-html)
+ (else (snd-print (format #f "no url for ~A?" name))))
+ (snd-print (format #f "no doc for ~A?" name)))))))
diff --git a/jcvoi.scm b/jcvoi.scm
index 7271d69..2997d91 100644
--- a/jcvoi.scm
+++ b/jcvoi.scm
@@ -23,134 +23,131 @@
(scale-envelope env2 sc2 off2)))
(define (checkpt att dur)
- (if (or (zero? att)
- (negative? att))
+ (if (not (positive? att))
(* 100 (/ .01 dur))
(if (< att dur)
(* 100 (/ att dur))
100)))
(define (setf-aref vect a b c d val)
- (set! (vect (+ a (* 3 b) (* 3 6 c) (* 3 6 4 d))) val))
+ (set! (vect (+ a (* 3 b) (* 18 c) (* 72 d))) val))
(define (aref vect a b c d)
- (vect (+ a (* 3 b) (* 3 6 c) (* 3 6 4 d))))
+ (vect (+ a (* 3 b) (* 18 c) (* 72 d))))
(define (fillfnc)
- (if (not fnc)
- (begin
- (set! fnc (make-vector (* 3 6 4 4) ()))
- (set! vibfreqfun (make-vector 3 ()))
- (set! i3fun1 (make-vector 3 ()))
- (set! i3fun2 (make-vector 3 ()))
-
- (setf-aref fnc 1 1 1 1 (flipxy '(350 130.8 524 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
- (setf-aref fnc 1 1 1 2 (flipxy '(.3 130.8 .8 261.6 .9 392 .9 523.2 .7 784 .86 1064 .86 1568)))
- (setf-aref fnc 1 1 1 3 (flipxy '(1.4 130.8 1.4 261.6 1.0 392 .8 523.2 .5 784 .3 1064 .2 1568)))
- (setf-aref fnc 1 1 2 1 (flipxy '(1100 130.8 1100 261.6 1100 392 1200 523.2 1500 784 1800 1064 2200 1568)))
- (setf-aref fnc 1 1 2 2 (flipxy '(.1 130.8 .2 261.6 .3 392 .3 523.2 .1 784 .05 1064 .05 1568)))
- (setf-aref fnc 1 1 2 3 (flipxy '(1.0 130.8 1.0 261.6 .4 392 .4 523.2 .2 784 .2 1064 .1 1568)))
- (setf-aref fnc 1 1 3 1 (flipxy '(3450 130.8 3400 261.6 3400 392 3600 523.2 4500 784 5000 1064 5800 1568)))
- (setf-aref fnc 1 1 3 2 (flipxy '(.04 130.8 .04 261.6 .04 392 .045 523.2 .03 784 .02 1064 .02 1568)))
- (setf-aref fnc 1 1 3 3 (flipxy '(3.5 130.8 2.0 261.6 1.5 392 1.2 523.2 .8 784 .8 1064 1.0 1568)))
- (setf-aref fnc 1 2 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
- (setf-aref fnc 1 2 1 2 (flipxy '(.25 130.8 .6 261.6 .6 392 .6 523.2 .7 784 .86 1064 .86 1568)))
- (setf-aref fnc 1 2 1 3 (flipxy '(0.5 130.8 0.3 261.6 0.1 392 .05 523.2 .04 784 .03 1064 .02 1568)))
- (setf-aref fnc 1 2 2 1 (flipxy '(2900 130.8 2700 261.6 2600 392 2400 523.2 2300 784 2200 1064 2100 1568)))
- (setf-aref fnc 1 2 2 2 (flipxy '(.01 130.8 .05 261.6 .08 392 .1 523.2 .1 784 .1 1064 .05 1568)))
- (setf-aref fnc 1 2 2 3 (flipxy '(1.5 130.8 1.0 261.6 1.0 392 1.0 523.2 1.0 784 1.0 1064 .5 1568)))
- (setf-aref fnc 1 2 3 1 (flipxy '(4200 130.8 3900 261.6 3900 392 3900 523.2 3800 784 3700 1064 3600 1568)))
- (setf-aref fnc 1 2 3 2 (flipxy '(.01 130.8 .04 261.6 .03 392 .03 523.2 .03 784 .03 1064 .02 1568)))
- (setf-aref fnc 1 2 3 3 (flipxy '(1.2 130.8 .8 261.6 .8 392 .8 523.2 .8 784 .8 1064 .5 1568)))
- (setf-aref fnc 1 3 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
- (setf-aref fnc 1 3 1 2 (flipxy '(.3 130.8 .7 261.6 .8 392 .6 523.2 .7 784 .86 1064 .86 1568)))
- (setf-aref fnc 1 3 1 3 (flipxy '(0.4 130.8 0.2 261.6 0.4 392 .4 523.2 .7 784 .5 1064 .2 1568)))
- (setf-aref fnc 1 3 2 1 (flipxy '(1000 130.8 1000 261.6 1100 392 1200 523.2 1400 784 1800 1064 2200 1568)))
- (setf-aref fnc 1 3 2 2 (flipxy '(.055 130.8 .1 261.6 .15 392 .13 523.2 .1 784 .1 1064 .05 1568)))
- (setf-aref fnc 1 3 2 3 (flipxy '(0.3 130.8 0.4 261.6 0.4 392 0.4 523.2 0.3 784 0.2 1064 0.1 1568)))
- (setf-aref fnc 1 3 3 1 (flipxy '(2600 130.8 2600 261.6 3000 392 3400 523.2 4500 784 5000 1064 5800 1568)))
- (setf-aref fnc 1 3 3 2 (flipxy '(.005 130.8 .03 261.6 .04 392 .04 523.2 .02 784 .02 1064 .02 1568)))
- (setf-aref fnc 1 3 3 3 (flipxy '(1.1 130.8 1.0 261.6 1.2 392 1.2 523.2 0.8 784 0.8 1064 1.0 1568)))
- (setf-aref fnc 1 4 1 1 (flipxy '(353 130.8 530 261.6 530 392 523 523.2 784 784 1046 1064 1568 1568)))
- (setf-aref fnc 1 4 1 2 (flipxy '(.5 130.8 .8 261.6 .8 392 .6 523.2 .7 784 .86 1064 .86 1568)))
- (setf-aref fnc 1 4 1 3 (flipxy '(0.6 130.8 0.7 261.6 1.0 392 0.8 523.2 .7 784 .5 1064 .2 1568)))
- (setf-aref fnc 1 4 2 1 (flipxy '(1040 130.8 1040 261.6 1040 392 1200 523.2 1400 784 1800 1064 2200 1568)))
- (setf-aref fnc 1 4 2 2 (flipxy '(.050 130.8 .05 261.6 .1 392 .2 523.2 .1 784 .1 1064 .05 1568)))
- (setf-aref fnc 1 4 2 3 (flipxy '(0.1 130.8 0.1 261.6 0.1 392 0.4 523.2 0.3 784 0.2 1064 0.1 1568)))
- (setf-aref fnc 1 4 3 1 (flipxy '(2695 130.8 2695 261.6 2695 392 3400 523.2 4500 784 5000 1064 5800 1568)))
- (setf-aref fnc 1 4 3 2 (flipxy '( .05 130.8 .05 261.6 .04 392 .04 523.2 .02 784 .02 1064 .02 1568)))
- (setf-aref fnc 1 4 3 3 (flipxy '(1.2 130.8 1.2 261.6 1.2 392 1.2 523.2 0.8 784 0.8 1064 1.0 1568)))
- (setf-aref fnc 1 5 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
- (setf-aref fnc 1 5 1 2 (flipxy '(.4 130.8 .4 261.6 .8 392 .8 523.2 .8 784 .8 1064 .8 1568)))
- (setf-aref fnc 1 5 1 3 (flipxy '(0.1 130.8 0.1 261.6 0.1 392 0.1 523.2 .0 784 .0 1064 .0 1568)))
- (setf-aref fnc 1 5 2 1 (flipxy '( 350 130.8 524 261.6 784 392 950 523.2 1568 784 2092 1064 3136 1568)))
- (setf-aref fnc 1 5 2 2 (flipxy '(.8 130.8 .8 261.6 .4 392 .2 523.2 .1 784 .1 1064 .0 1568)))
- (setf-aref fnc 1 5 2 3 (flipxy '(0.5 130.8 0.1 261.6 0.1 392 0.1 523.2 0.0 784 0.0 1064 0.0 1568)))
- (setf-aref fnc 1 5 3 1 (flipxy '(2700 130.8 2700 261.6 2500 392 2450 523.2 2400 784 2350 1064 4500 1568)))
- (setf-aref fnc 1 5 3 2 (flipxy '( .1 130.8 .15 261.6 .15 392 .15 523.2 .15 784 .1 1064 .1 1568)))
- (setf-aref fnc 1 5 3 3 (flipxy '(2.0 130.8 1.6 261.6 1.6 392 1.6 523.2 1.6 784 1.6 1064 1.0 1568)))
- (setf-aref fnc 2 1 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
- (setf-aref fnc 2 1 1 2 (flipxy '( .3 16.5 .5 24.5 .6 32.7 .5 49.0 .47 65.41 .135 98 .2 130.8)))
- (setf-aref fnc 2 1 1 3 (flipxy '(2.4 16.5 2.0 24.5 1.8 32.7 1.6 49.0 1.5 65.41 1.2 98 .8 130.8)))
- (setf-aref fnc 2 1 2 1 (flipxy '(400 16.5 400 24.5 400 32.7 400 49.0 400 65.41 400 98 400 130.8)))
- (setf-aref fnc 2 1 2 2 (flipxy '( .2 16.5 .2 24.5 .35 32.7 .37 49.0 .4 65.41 .6 98 .8 130.8)))
- (setf-aref fnc 2 1 2 3 (flipxy '(6.0 16.5 5.0 24.5 4.0 32.7 3.0 49.0 2.7 65.41 2.2 98 1.8 130.8)))
- (setf-aref fnc 2 1 3 1 (flipxy '(2142 16.5 2142 24.5 2142 32.7 2142 49.0 2142 65.41 2142 98 2142 130.8)))
- (setf-aref fnc 2 1 3 2 (flipxy '(.02 16.5 .025 24.5 .05 32.7 .09 49.0 .13 65.41 .29 98 .4 130.8)))
- (setf-aref fnc 2 1 3 3 (flipxy '(9.0 16.5 8.0 24.5 7.2 32.7 5.5 49.0 3.9 65.41 3.0 98 1.8 130.8)))
- (setf-aref fnc 2 2 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
- (setf-aref fnc 2 2 1 2 (flipxy '( .75 16.5 .83 24.5 .91 32.7 .91 49.0 .91 65.41 .79 98 .67 130.8)))
- (setf-aref fnc 2 2 1 3 (flipxy '(2.5 16.5 2.5 24.5 2.5 32.7 2.1 49.0 1.8 65.41 1.4 98 1.0 130.8)))
- (setf-aref fnc 2 2 2 1 (flipxy '(1500 16.5 1500 24.5 1500 32.7 1500 49.0 1500 65.41 1500 98 1500 130.8)))
- (setf-aref fnc 2 2 2 2 (flipxy '( .01 16.5 .02 24.5 .02 32.7 .02 49.0 .02 65.41 .08 98 .08 130.8)))
- (setf-aref fnc 2 2 2 3 (flipxy '(1.5 16.5 1.37 24.5 1.25 32.7 1.07 49.0 0.9 65.41 0.7 98 0.5 130.8)))
- (setf-aref fnc 2 2 3 1 (flipxy '(2300 16.5 2300 24.5 2300 32.7 2325 49.0 2350 65.41 2375 98 2400 130.8)))
- (setf-aref fnc 2 2 3 2 (flipxy '(.05 16.5 .065 24.5 .70 32.7 .07 49.0 .07 65.41 .16 98 .2 130.8)))
- (setf-aref fnc 2 2 3 3 (flipxy '(11.0 16.5 10.0 24.5 10.0 32.7 7.7 49.0 5.4 65.41 3.7 98 2.0 130.8)))
- (setf-aref fnc 2 3 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
- (setf-aref fnc 2 3 1 2 (flipxy '( .75 16.5 .83 24.5 .87 32.7 .88 49.0 .90 65.41 .87 98 .85 130.8)))
- (setf-aref fnc 2 3 1 3 (flipxy '(1.4 16.5 1.4 24.5 1.4 32.7 1.4 49.0 1.4 65.41 1.4 98 1.4 130.8)))
- (setf-aref fnc 2 3 2 1 (flipxy '( 450 16.5 450 24.5 450 32.7 450 49.0 450 65.41 450 98 450 130.8)))
- (setf-aref fnc 2 3 2 2 (flipxy '( .01 16.5 .02 24.5 .08 32.7 .065 49.0 .05 65.41 .05 98 .05 130.8)))
- (setf-aref fnc 2 3 2 3 (flipxy '(3.0 16.5 2.6 24.5 2.1 32.7 1.75 49.0 1.4 65.41 1.05 98 0.7 130.8)))
- (setf-aref fnc 2 3 3 1 (flipxy '(2100 16.5 2100 24.5 2100 32.7 2125 49.0 2150 65.41 2175 98 2100 130.8)))
- (setf-aref fnc 2 3 3 2 (flipxy '(.05 16.5 .05 24.5 .05 32.7 .05 49.0 .05 65.41 .075 98 .1 130.8)))
- (setf-aref fnc 2 3 3 3 (flipxy '( 9.0 16.5 8.0 24.5 7.0 32.7 4.5 49.0 2.1 65.41 1.75 98 1.4 130.8)))
- (setf-aref fnc 2 4 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
- (setf-aref fnc 2 4 1 2 (flipxy '( .35 16.5 .40 24.5 .43 32.7 .47 49.0 .50 65.41 .57 98 .45 130.8)))
- (setf-aref fnc 2 4 1 3 (flipxy '(1.4 16.5 1.4 24.5 1.0 32.7 1.0 49.0 1.0 65.41 1.1 98 1.0 130.8)))
- (setf-aref fnc 2 4 2 1 (flipxy '( 300 16.5 300 24.5 300 32.7 300 49.0 300 65.41 300 98 300 130.8)))
- (setf-aref fnc 2 4 2 2 (flipxy '( .75 16.5 .80 24.5 .85 32.7 .90 49.0 .95 65.41 .99 98 .99 130.8)))
- (setf-aref fnc 2 4 2 3 (flipxy '(3.0 16.5 2.5 24.5 2.0 32.7 1.9 49.0 1.8 65.41 1.65 98 0.25 130.8)))
- (setf-aref fnc 2 4 3 1 (flipxy '(2200 16.5 2200 24.5 2200 32.7 2225 49.0 2250 65.41 2275 98 2300 130.8)))
- (setf-aref fnc 2 4 3 2 (flipxy '(.02 16.5 .02 24.5 .02 32.7 .035 49.0 .05 65.41 .07 98 .05 130.8)))
- (setf-aref fnc 2 4 3 3 (flipxy '( 5.0 16.5 4.0 24.5 3.0 32.7 2.8 49.0 2.6 65.41 1.9 98 1.2 130.8)))
-
- ;; (sef-(aref fnc 2 5 1 1 (flipxy '(175 16.5 262 24.5 392 32.7 523 49.0 784 65.41 1046 98 1568 130.8)))
- (setf-aref fnc 2 5 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
-
- (setf-aref fnc 2 5 1 2 (flipxy '( .40 16.5 .40 24.5 .80 32.7 .80 49.0 .80 65.41 .80 98 .80 130.8)))
- (setf-aref fnc 2 5 1 3 (flipxy '(0.1 16.5 0.1 24.5 0.1 32.7 0.1 49.0 0.0 65.41 0.0 98 0.0 130.8)))
- (setf-aref fnc 2 5 2 1 (flipxy '( 350 16.5 524 24.5 784 32.7 950 49.0 1568 65.41 2092 98 3136 130.8)))
- (setf-aref fnc 2 5 2 2 (flipxy '( .80 16.5 .80 24.5 .40 32.7 .20 49.0 .10 65.41 .10 98 .00 130.8)))
- (setf-aref fnc 2 5 2 3 (flipxy '(0.5 16.5 0.1 24.5 0.1 32.7 0.1 49.0 0.0 65.41 0.0 98 0.0 130.8)))
- (setf-aref fnc 2 5 3 1 (flipxy '(2700 16.5 2700 24.5 2500 32.7 2450 49.0 2400 65.41 2350 98 4500 130.8)))
- (setf-aref fnc 2 5 3 2 (flipxy '(.10 16.5 .15 24.5 .15 32.7 .15 49.0 .15 65.41 .10 98 .10 130.8)))
- (setf-aref fnc 2 5 3 3 (flipxy '( 2.0 16.5 1.6 24.5 1.6 32.7 1.6 49.0 1.6 65.41 1.5 98 1.0 130.8)))
-
- ;; these are vibrato frequencies functions (pitch dependent);
-
- (set! (vibfreqfun 1) (flipxy '(4.5 138.8 5 1568)))
- (set! (vibfreqfun 2) (flipxy '(4.5 16.5 5 130.8)))
-
- ;; these are index functions for cascade modulater (pitch dependent);
-
- (set! (i3fun1 1) (flipxy '(4 138.8 4 784 1 1568)))
- (set! (i3fun1 2) (flipxy '(4 16.5 4 65.41 1 130.8)))
-
- (set! (i3fun2 1) (flipxy '(.4 138.8 .1 1568)))
- (set! (i3fun2 2) (flipxy '(.4 16.5 .1 130.8)))
- )))
+ (unless fnc
+ (set! fnc (make-vector 288 ())) ; 288 = (* 3 6 4 4)
+ (set! vibfreqfun (make-vector 3 ()))
+ (set! i3fun1 (make-vector 3 ()))
+ (set! i3fun2 (make-vector 3 ()))
+
+ (setf-aref fnc 1 1 1 1 (flipxy '(350 130.8 524 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
+ (setf-aref fnc 1 1 1 2 (flipxy '(.3 130.8 .8 261.6 .9 392 .9 523.2 .7 784 .86 1064 .86 1568)))
+ (setf-aref fnc 1 1 1 3 (flipxy '(1.4 130.8 1.4 261.6 1.0 392 .8 523.2 .5 784 .3 1064 .2 1568)))
+ (setf-aref fnc 1 1 2 1 (flipxy '(1100 130.8 1100 261.6 1100 392 1200 523.2 1500 784 1800 1064 2200 1568)))
+ (setf-aref fnc 1 1 2 2 (flipxy '(.1 130.8 .2 261.6 .3 392 .3 523.2 .1 784 .05 1064 .05 1568)))
+ (setf-aref fnc 1 1 2 3 (flipxy '(1.0 130.8 1.0 261.6 .4 392 .4 523.2 .2 784 .2 1064 .1 1568)))
+ (setf-aref fnc 1 1 3 1 (flipxy '(3450 130.8 3400 261.6 3400 392 3600 523.2 4500 784 5000 1064 5800 1568)))
+ (setf-aref fnc 1 1 3 2 (flipxy '(.04 130.8 .04 261.6 .04 392 .045 523.2 .03 784 .02 1064 .02 1568)))
+ (setf-aref fnc 1 1 3 3 (flipxy '(3.5 130.8 2.0 261.6 1.5 392 1.2 523.2 .8 784 .8 1064 1.0 1568)))
+ (setf-aref fnc 1 2 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
+ (setf-aref fnc 1 2 1 2 (flipxy '(.25 130.8 .6 261.6 .6 392 .6 523.2 .7 784 .86 1064 .86 1568)))
+ (setf-aref fnc 1 2 1 3 (flipxy '(0.5 130.8 0.3 261.6 0.1 392 .05 523.2 .04 784 .03 1064 .02 1568)))
+ (setf-aref fnc 1 2 2 1 (flipxy '(2900 130.8 2700 261.6 2600 392 2400 523.2 2300 784 2200 1064 2100 1568)))
+ (setf-aref fnc 1 2 2 2 (flipxy '(.01 130.8 .05 261.6 .08 392 .1 523.2 .1 784 .1 1064 .05 1568)))
+ (setf-aref fnc 1 2 2 3 (flipxy '(1.5 130.8 1.0 261.6 1.0 392 1.0 523.2 1.0 784 1.0 1064 .5 1568)))
+ (setf-aref fnc 1 2 3 1 (flipxy '(4200 130.8 3900 261.6 3900 392 3900 523.2 3800 784 3700 1064 3600 1568)))
+ (setf-aref fnc 1 2 3 2 (flipxy '(.01 130.8 .04 261.6 .03 392 .03 523.2 .03 784 .03 1064 .02 1568)))
+ (setf-aref fnc 1 2 3 3 (flipxy '(1.2 130.8 .8 261.6 .8 392 .8 523.2 .8 784 .8 1064 .5 1568)))
+ (setf-aref fnc 1 3 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
+ (setf-aref fnc 1 3 1 2 (flipxy '(.3 130.8 .7 261.6 .8 392 .6 523.2 .7 784 .86 1064 .86 1568)))
+ (setf-aref fnc 1 3 1 3 (flipxy '(0.4 130.8 0.2 261.6 0.4 392 .4 523.2 .7 784 .5 1064 .2 1568)))
+ (setf-aref fnc 1 3 2 1 (flipxy '(1000 130.8 1000 261.6 1100 392 1200 523.2 1400 784 1800 1064 2200 1568)))
+ (setf-aref fnc 1 3 2 2 (flipxy '(.055 130.8 .1 261.6 .15 392 .13 523.2 .1 784 .1 1064 .05 1568)))
+ (setf-aref fnc 1 3 2 3 (flipxy '(0.3 130.8 0.4 261.6 0.4 392 0.4 523.2 0.3 784 0.2 1064 0.1 1568)))
+ (setf-aref fnc 1 3 3 1 (flipxy '(2600 130.8 2600 261.6 3000 392 3400 523.2 4500 784 5000 1064 5800 1568)))
+ (setf-aref fnc 1 3 3 2 (flipxy '(.005 130.8 .03 261.6 .04 392 .04 523.2 .02 784 .02 1064 .02 1568)))
+ (setf-aref fnc 1 3 3 3 (flipxy '(1.1 130.8 1.0 261.6 1.2 392 1.2 523.2 0.8 784 0.8 1064 1.0 1568)))
+ (setf-aref fnc 1 4 1 1 (flipxy '(353 130.8 530 261.6 530 392 523 523.2 784 784 1046 1064 1568 1568)))
+ (setf-aref fnc 1 4 1 2 (flipxy '(.5 130.8 .8 261.6 .8 392 .6 523.2 .7 784 .86 1064 .86 1568)))
+ (setf-aref fnc 1 4 1 3 (flipxy '(0.6 130.8 0.7 261.6 1.0 392 0.8 523.2 .7 784 .5 1064 .2 1568)))
+ (setf-aref fnc 1 4 2 1 (flipxy '(1040 130.8 1040 261.6 1040 392 1200 523.2 1400 784 1800 1064 2200 1568)))
+ (setf-aref fnc 1 4 2 2 (flipxy '(.050 130.8 .05 261.6 .1 392 .2 523.2 .1 784 .1 1064 .05 1568)))
+ (setf-aref fnc 1 4 2 3 (flipxy '(0.1 130.8 0.1 261.6 0.1 392 0.4 523.2 0.3 784 0.2 1064 0.1 1568)))
+ (setf-aref fnc 1 4 3 1 (flipxy '(2695 130.8 2695 261.6 2695 392 3400 523.2 4500 784 5000 1064 5800 1568)))
+ (setf-aref fnc 1 4 3 2 (flipxy '( .05 130.8 .05 261.6 .04 392 .04 523.2 .02 784 .02 1064 .02 1568)))
+ (setf-aref fnc 1 4 3 3 (flipxy '(1.2 130.8 1.2 261.6 1.2 392 1.2 523.2 0.8 784 0.8 1064 1.0 1568)))
+ (setf-aref fnc 1 5 1 1 (flipxy '(175 130.8 262 261.6 392 392 523 523.2 784 784 1046 1064 1568 1568)))
+ (setf-aref fnc 1 5 1 2 (flipxy '(.4 130.8 .4 261.6 .8 392 .8 523.2 .8 784 .8 1064 .8 1568)))
+ (setf-aref fnc 1 5 1 3 (flipxy '(0.1 130.8 0.1 261.6 0.1 392 0.1 523.2 .0 784 .0 1064 .0 1568)))
+ (setf-aref fnc 1 5 2 1 (flipxy '( 350 130.8 524 261.6 784 392 950 523.2 1568 784 2092 1064 3136 1568)))
+ (setf-aref fnc 1 5 2 2 (flipxy '(.8 130.8 .8 261.6 .4 392 .2 523.2 .1 784 .1 1064 .0 1568)))
+ (setf-aref fnc 1 5 2 3 (flipxy '(0.5 130.8 0.1 261.6 0.1 392 0.1 523.2 0.0 784 0.0 1064 0.0 1568)))
+ (setf-aref fnc 1 5 3 1 (flipxy '(2700 130.8 2700 261.6 2500 392 2450 523.2 2400 784 2350 1064 4500 1568)))
+ (setf-aref fnc 1 5 3 2 (flipxy '( .1 130.8 .15 261.6 .15 392 .15 523.2 .15 784 .1 1064 .1 1568)))
+ (setf-aref fnc 1 5 3 3 (flipxy '(2.0 130.8 1.6 261.6 1.6 392 1.6 523.2 1.6 784 1.6 1064 1.0 1568)))
+ (setf-aref fnc 2 1 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
+ (setf-aref fnc 2 1 1 2 (flipxy '( .3 16.5 .5 24.5 .6 32.7 .5 49.0 .47 65.41 .135 98 .2 130.8)))
+ (setf-aref fnc 2 1 1 3 (flipxy '(2.4 16.5 2.0 24.5 1.8 32.7 1.6 49.0 1.5 65.41 1.2 98 .8 130.8)))
+ (setf-aref fnc 2 1 2 1 (flipxy '(400 16.5 400 24.5 400 32.7 400 49.0 400 65.41 400 98 400 130.8)))
+ (setf-aref fnc 2 1 2 2 (flipxy '( .2 16.5 .2 24.5 .35 32.7 .37 49.0 .4 65.41 .6 98 .8 130.8)))
+ (setf-aref fnc 2 1 2 3 (flipxy '(6.0 16.5 5.0 24.5 4.0 32.7 3.0 49.0 2.7 65.41 2.2 98 1.8 130.8)))
+ (setf-aref fnc 2 1 3 1 (flipxy '(2142 16.5 2142 24.5 2142 32.7 2142 49.0 2142 65.41 2142 98 2142 130.8)))
+ (setf-aref fnc 2 1 3 2 (flipxy '(.02 16.5 .025 24.5 .05 32.7 .09 49.0 .13 65.41 .29 98 .4 130.8)))
+ (setf-aref fnc 2 1 3 3 (flipxy '(9.0 16.5 8.0 24.5 7.2 32.7 5.5 49.0 3.9 65.41 3.0 98 1.8 130.8)))
+ (setf-aref fnc 2 2 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
+ (setf-aref fnc 2 2 1 2 (flipxy '( .75 16.5 .83 24.5 .91 32.7 .91 49.0 .91 65.41 .79 98 .67 130.8)))
+ (setf-aref fnc 2 2 1 3 (flipxy '(2.5 16.5 2.5 24.5 2.5 32.7 2.1 49.0 1.8 65.41 1.4 98 1.0 130.8)))
+ (setf-aref fnc 2 2 2 1 (flipxy '(1500 16.5 1500 24.5 1500 32.7 1500 49.0 1500 65.41 1500 98 1500 130.8)))
+ (setf-aref fnc 2 2 2 2 (flipxy '( .01 16.5 .02 24.5 .02 32.7 .02 49.0 .02 65.41 .08 98 .08 130.8)))
+ (setf-aref fnc 2 2 2 3 (flipxy '(1.5 16.5 1.37 24.5 1.25 32.7 1.07 49.0 0.9 65.41 0.7 98 0.5 130.8)))
+ (setf-aref fnc 2 2 3 1 (flipxy '(2300 16.5 2300 24.5 2300 32.7 2325 49.0 2350 65.41 2375 98 2400 130.8)))
+ (setf-aref fnc 2 2 3 2 (flipxy '(.05 16.5 .065 24.5 .70 32.7 .07 49.0 .07 65.41 .16 98 .2 130.8)))
+ (setf-aref fnc 2 2 3 3 (flipxy '(11.0 16.5 10.0 24.5 10.0 32.7 7.7 49.0 5.4 65.41 3.7 98 2.0 130.8)))
+ (setf-aref fnc 2 3 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
+ (setf-aref fnc 2 3 1 2 (flipxy '( .75 16.5 .83 24.5 .87 32.7 .88 49.0 .90 65.41 .87 98 .85 130.8)))
+ (setf-aref fnc 2 3 1 3 (flipxy '(1.4 16.5 1.4 24.5 1.4 32.7 1.4 49.0 1.4 65.41 1.4 98 1.4 130.8)))
+ (setf-aref fnc 2 3 2 1 (flipxy '( 450 16.5 450 24.5 450 32.7 450 49.0 450 65.41 450 98 450 130.8)))
+ (setf-aref fnc 2 3 2 2 (flipxy '( .01 16.5 .02 24.5 .08 32.7 .065 49.0 .05 65.41 .05 98 .05 130.8)))
+ (setf-aref fnc 2 3 2 3 (flipxy '(3.0 16.5 2.6 24.5 2.1 32.7 1.75 49.0 1.4 65.41 1.05 98 0.7 130.8)))
+ (setf-aref fnc 2 3 3 1 (flipxy '(2100 16.5 2100 24.5 2100 32.7 2125 49.0 2150 65.41 2175 98 2100 130.8)))
+ (setf-aref fnc 2 3 3 2 (flipxy '(.05 16.5 .05 24.5 .05 32.7 .05 49.0 .05 65.41 .075 98 .1 130.8)))
+ (setf-aref fnc 2 3 3 3 (flipxy '( 9.0 16.5 8.0 24.5 7.0 32.7 4.5 49.0 2.1 65.41 1.75 98 1.4 130.8)))
+ (setf-aref fnc 2 4 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
+ (setf-aref fnc 2 4 1 2 (flipxy '( .35 16.5 .40 24.5 .43 32.7 .47 49.0 .50 65.41 .57 98 .45 130.8)))
+ (setf-aref fnc 2 4 1 3 (flipxy '(1.4 16.5 1.4 24.5 1.0 32.7 1.0 49.0 1.0 65.41 1.1 98 1.0 130.8)))
+ (setf-aref fnc 2 4 2 1 (flipxy '( 300 16.5 300 24.5 300 32.7 300 49.0 300 65.41 300 98 300 130.8)))
+ (setf-aref fnc 2 4 2 2 (flipxy '( .75 16.5 .80 24.5 .85 32.7 .90 49.0 .95 65.41 .99 98 .99 130.8)))
+ (setf-aref fnc 2 4 2 3 (flipxy '(3.0 16.5 2.5 24.5 2.0 32.7 1.9 49.0 1.8 65.41 1.65 98 0.25 130.8)))
+ (setf-aref fnc 2 4 3 1 (flipxy '(2200 16.5 2200 24.5 2200 32.7 2225 49.0 2250 65.41 2275 98 2300 130.8)))
+ (setf-aref fnc 2 4 3 2 (flipxy '(.02 16.5 .02 24.5 .02 32.7 .035 49.0 .05 65.41 .07 98 .05 130.8)))
+ (setf-aref fnc 2 4 3 3 (flipxy '( 5.0 16.5 4.0 24.5 3.0 32.7 2.8 49.0 2.6 65.41 1.9 98 1.2 130.8)))
+
+ ;; (sef-(aref fnc 2 5 1 1 (flipxy '(175 16.5 262 24.5 392 32.7 523 49.0 784 65.41 1046 98 1568 130.8)))
+ (setf-aref fnc 2 5 1 1 (flipxy '( 33 16.5 33 24.5 33 32.7 49 49.0 65 65.41 98 98 131 130.8)))
+
+ (setf-aref fnc 2 5 1 2 (flipxy '( .40 16.5 .40 24.5 .80 32.7 .80 49.0 .80 65.41 .80 98 .80 130.8)))
+ (setf-aref fnc 2 5 1 3 (flipxy '(0.1 16.5 0.1 24.5 0.1 32.7 0.1 49.0 0.0 65.41 0.0 98 0.0 130.8)))
+ (setf-aref fnc 2 5 2 1 (flipxy '( 350 16.5 524 24.5 784 32.7 950 49.0 1568 65.41 2092 98 3136 130.8)))
+ (setf-aref fnc 2 5 2 2 (flipxy '( .80 16.5 .80 24.5 .40 32.7 .20 49.0 .10 65.41 .10 98 .00 130.8)))
+ (setf-aref fnc 2 5 2 3 (flipxy '(0.5 16.5 0.1 24.5 0.1 32.7 0.1 49.0 0.0 65.41 0.0 98 0.0 130.8)))
+ (setf-aref fnc 2 5 3 1 (flipxy '(2700 16.5 2700 24.5 2500 32.7 2450 49.0 2400 65.41 2350 98 4500 130.8)))
+ (setf-aref fnc 2 5 3 2 (flipxy '(.10 16.5 .15 24.5 .15 32.7 .15 49.0 .15 65.41 .10 98 .10 130.8)))
+ (setf-aref fnc 2 5 3 3 (flipxy '( 2.0 16.5 1.6 24.5 1.6 32.7 1.6 49.0 1.6 65.41 1.5 98 1.0 130.8)))
+
+ ;; these are vibrato frequencies functions (pitch dependent);
+
+ (set! (vibfreqfun 1) (flipxy '(4.5 138.8 5 1568)))
+ (set! (vibfreqfun 2) (flipxy '(4.5 16.5 5 130.8)))
+
+ ;; these are index functions for cascade modulater (pitch dependent);
+
+ (set! (i3fun1 1) (flipxy '(4 138.8 4 784 1 1568)))
+ (set! (i3fun1 2) (flipxy '(4 16.5 4 65.41 1 130.8)))
+
+ (set! (i3fun2 1) (flipxy '(.4 138.8 .1 1568)))
+ (set! (i3fun2 2) (flipxy '(.4 16.5 .1 130.8)))))
(define (fncval ptr pitch)
(envelope-interp pitch ptr))
@@ -171,9 +168,7 @@
(let ((vibfreq (fncval (vibfreqfun sex) pitch))
(vibpc (* .01 (log pitch 2) (+ .15 (sqrt amp)) vibscl))
(ranpc (* .002 (log pitch 2) (- 2 (expt amp .25)) pcran))
- (skewpc (if (= sex 1)
- (* (sqrt (+ .1 (* .05 ampref (- 1568 130.8)))) skewscl)
- (* (sqrt (+ .1 (* .05 ampref (- 130.8 16.5)))) skewscl)))
+ (skewpc (* skewscl (sqrt (+ .1 (* .05 ampref (if (= sex 1) (- 1568 130.8) (- 130.8 16.5)))))))
(form1 (/ (fncval (aref fnc sex vowel 1 1) pitch) pitch))
(form2 (/ (fncval (aref fnc sex vowel 2 1) pitch) pitch))
(form3 (/ (fncval (aref fnc sex vowel 3 1) pitch) pitch)))
@@ -194,10 +189,8 @@
(formscl1 (abs (- form1 fmntfreq1)))
(formscl2 (abs (- form2 fmntfreq2)))
(formscl3 (abs (- form3 fmntfreq3)))
- (i3 (if (< pitch (/ c 2))
- (fncval (i3fun1 sex) pitch)
- (fncval (i3fun2 sex) pitch)))
- (indx0 (if (or (= vowel 3) (= vowel 4)) 0 1.5)))
+ (i3 (fncval ((if (< pitch (/ c 2)) i3fun1 i3fun2) sex) pitch))
+ (indx0 (if (memv vowel '(3 4)) 0 1.5)))
(let ((caramp1sc (* (fncval (aref fnc sex vowel 1 2) pitch) (- 1 formscl1) amp1))
(caramp2sc (* (fncval (aref fnc sex vowel 2 2) pitch) (- 1 formscl2) amp2))
(caramp3sc (* (fncval (aref fnc sex vowel 3 2) pitch) (- 1 formscl3) amp3))
diff --git a/libc.scm b/libc.scm
index 9370102..af0a32a 100644
--- a/libc.scm
+++ b/libc.scm
@@ -5,18 +5,17 @@
(provide 'libc.scm)
;; if loading from a different directory, pass that info to C
-(let ((current-file (port-filename (current-input-port))))
- (let ((directory (and (or (char=? (current-file 0) #\/)
- (char=? (current-file 0) #\~))
- (substring current-file 0 (- (length current-file) 9)))))
- (when (and directory (not (member directory *load-path*)))
- (set! *load-path* (cons directory *load-path*)))
- (with-let (rootlet)
- (require cload.scm))
- (when (and directory (not (string-position directory *cload-cflags*)))
- (set! *cload-cflags* (string-append "-I" directory " " *cload-cflags*)))))
+(let* ((current-file (port-filename (current-input-port)))
+ (directory (and (memv (current-file 0) '(#\/ #\~))
+ (substring current-file 0 (- (length current-file) 9)))))
+ (when (and directory (not (member directory *load-path*)))
+ (set! *load-path* (cons directory *load-path*)))
+ (with-let (rootlet)
+ (require cload.scm))
+ (when (and directory (not (string-position directory *cload-cflags*)))
+ (set! *cload-cflags* (string-append "-I" directory " " *cload-cflags*))))
-(if (not (defined? '*libc*))
+(unless (defined? '*libc*)
(define *libc*
(with-let (unlet)
(set! *libraries* (cons (cons "libc.scm" (curlet)) *libraries*))
diff --git a/libgsl.scm b/libgsl.scm
index 77a2b0e..0368c7e 100644
--- a/libgsl.scm
+++ b/libgsl.scm
@@ -2544,6 +2544,8 @@
(int gsl_multifit_wlinear_svd (gsl_matrix* gsl_vector* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*))
(int gsl_multifit_wlinear_usvd (gsl_matrix* gsl_vector* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*))
(int gsl_multifit_linear_est (gsl_vector* gsl_vector* gsl_matrix* double* double*))
+ (reader-cond ((>= gsl-version 2.1)
+ (double gsl_multifit_linear_rcond (gsl_multifit_linear_workspace*))))
(int gsl_multifit_linear_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector*))
(reader-cond ((>= gsl-version 1.16)
(gsl_multifit_robust_workspace* gsl_multifit_robust_alloc (gsl_multifit_robust_type* size_t size_t))
@@ -2565,31 +2567,75 @@
(int gsl_multifit_test_delta (gsl_vector* gsl_vector* double double))
(int gsl_multifit_test_gradient (gsl_vector* double))
- (reader-cond ((< gsl-version 2.0)
- (int gsl_multifit_linear_svd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_usvd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*)))
- (#t
- (int gsl_multifit_linear_svd (gsl_matrix* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_bsvd (gsl_matrix* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_solve (double gsl_matrix* gsl_vector* gsl_vector* double* double* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_applyW (gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_stdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_genform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_wgenform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_lreg (double double gsl_vector*))
- (int gsl_multifit_linear_lcurve (gsl_vector* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
- (int gsl_multifit_linear_lcorner (gsl_vector* gsl_vector* size_t*))
- (int gsl_multifit_linear_lcorner2 (gsl_vector* gsl_vector* size_t*))
- (int gsl_multifit_linear_Lk (size_t size_t gsl_matrix*))
- (int gsl_multifit_linear_Lsobolev (size_t size_t gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
- (int gsl_multifit_robust_maxiter (size_t gsl_multifit_robust_workspace*))
- (int gsl_multifit_robust_weights (gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
- (int gsl_multifit_robust_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
- (int gsl_multifit_covar_QRPT (gsl_matrix* gsl_permutation* double gsl_matrix*))))
+ (reader-cond
+ ((< gsl-version 2.0)
+ (int gsl_multifit_linear_svd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_usvd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*)))
+
+ ((= gsl-version 2.0)
+ (int gsl_multifit_linear_svd (gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_bsvd (gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_solve (double gsl_matrix* gsl_vector* gsl_vector* double* double* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_applyW (gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+
+ (int gsl_multifit_linear_stdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_genform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wgenform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_lreg (double double gsl_vector*))
+ (int gsl_multifit_linear_lcurve (gsl_vector* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_lcorner (gsl_vector* gsl_vector* size_t*))
+ (int gsl_multifit_linear_lcorner2 (gsl_vector* gsl_vector* size_t*))
+ (int gsl_multifit_linear_Lk (size_t size_t gsl_matrix*))
+ (int gsl_multifit_linear_Lsobolev (size_t size_t gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_robust_maxiter (size_t gsl_multifit_robust_workspace*))
+ (int gsl_multifit_robust_weights (gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
+ (int gsl_multifit_robust_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
+ (int gsl_multifit_covar_QRPT (gsl_matrix* gsl_permutation* double gsl_matrix*)))
+
+ (#t
+ (int gsl_multifit_linear_svd (gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_bsvd (gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_solve (double gsl_matrix* gsl_vector* gsl_vector* double* double* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_applyW (gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector*))
+ (int gsl_multifit_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_stdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix*
+ gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_genform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_wgenform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_matrix* gsl_vector*
+ gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_lreg (double double gsl_vector*))
+ (int gsl_multifit_linear_lcurve (gsl_vector* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_linear_lcorner (gsl_vector* gsl_vector* size_t*))
+ (int gsl_multifit_linear_lcorner2 (gsl_vector* gsl_vector* size_t*))
+ (int gsl_multifit_linear_Lk (size_t size_t gsl_matrix*))
+ (int gsl_multifit_linear_Lsobolev (size_t size_t gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*))
+ (int gsl_multifit_robust_maxiter (size_t gsl_multifit_robust_workspace*))
+ (int gsl_multifit_robust_weights (gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
+ (int gsl_multifit_robust_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_robust_workspace*))
+ (int gsl_multifit_covar_QRPT (gsl_matrix* gsl_permutation* double gsl_matrix*))
+
+ (gsl_multilarge_linear_workspace* gsl_multilarge_linear_alloc (gsl_multilarge_linear_type* size_t))
+ (void gsl_multilarge_linear_free (gsl_multilarge_linear_workspace*))
+ (char* gsl_multilarge_linear_name (gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_reset (gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_accumulate (gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_solve (double gsl_vector* double* double* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_rcond (double* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_lcurve (gsl_vector* gsl_vector* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_L_decomp (gsl_matrix* gsl_vector*))
+ (int gsl_multilarge_linear_wstdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_stdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multilarge_linear_workspace*))
+ (int gsl_multilarge_linear_genform2 (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multilarge_linear_workspace*))))
(gsl_multimin_fminimizer* gsl_multimin_fminimizer_alloc (gsl_multimin_fminimizer_type* size_t))
(void gsl_multimin_fminimizer_free (gsl_multimin_fminimizer*))
@@ -2917,6 +2963,8 @@
"gsl/gsl_mode.h"
"gsl/gsl_multifit.h"
"gsl/gsl_multifit_nlin.h"
+ (reader-cond ((>= gsl-version 2.1)
+ "gsl/gsl_multilarge.h"))
"gsl/gsl_multimin.h"
"gsl/gsl_multiroots.h"
"gsl/gsl_multiset.h"
diff --git a/lint.scm b/lint.scm
index 7953d00..743713b 100644
--- a/lint.scm
+++ b/lint.scm
@@ -2,77 +2,670 @@
;;;
;;; (lint "file.scm") checks file.scm for infelicities
;;; to control the kinds of checks, set the variables below.
+;;; for tests and examples, see lint-test in s7test.scm
(provide 'lint.scm)
-(require stuff.scm)
-;(require write.scm)
-
-(if (provided? 'pure-s7)
- (begin
- (define (make-polar mag ang) (complex (* mag (cos ang)) (* mag (sin ang))))
-
- (define (memq a b) (member a b eq?))
- (define (memv a b) (member a b eqv?))
- (define (assq a b) (assoc a b eq?))
- (define (assv a b) (assoc a b eqv?))
-
- (define (char-ci=? . chars) (apply char=? (map char-upcase chars)))
- (define (char-ci<=? . chars) (apply char<=? (map char-upcase chars)))
- (define (char-ci>=? . chars) (apply char>=? (map char-upcase chars)))
- (define (char-ci<? . chars) (apply char<? (map char-upcase chars)))
- (define (char-ci>? . chars) (apply char>? (map char-upcase chars)))
-
- (define (string-ci=? . strs) (apply string=? (map string-upcase strs)))
- (define (string-ci<=? . strs) (apply string<=? (map string-upcase strs)))
- (define (string-ci>=? . strs) (apply string>=? (map string-upcase strs)))
- (define (string-ci<? . strs) (apply string<? (map string-upcase strs)))
- (define (string-ci>? . strs) (apply string>? (map string-upcase strs)))
-
- (define (let->list e)
- (if (let? e)
- (reverse! (map values e))
- (error 'wrong-type-arg "let->list argument should be an environment: ~A" str)))
- ))
-
-(define *report-unused-parameters* #f)
-(define *report-unused-top-level-functions* #f)
-(define *report-multiply-defined-top-level-functions* #f) ; same name defined at top level in more than one file
-(define *report-shadowed-variables* #f)
-(define *report-minor-stuff* #t) ; now obsolete (#t)
-(define *report-doc-strings* #f) ; report old-style (CL) doc strings
-
-(define *load-file-first* #f) ; this will actually load the file, so errors will stop lint
-(define start-up-let (rootlet))
-(define *current-file* "")
-(define *top-level-objects* (make-hash-table))
-(define *lint-output-port* *stderr*)
-(format *stderr* "loading lint.scm~%")
-(set! reader-cond #f)
-(define-macro (reader-cond . clauses) `(values)) ; clobber reader-cond to avoid dumb unbound-variable errors
+(define *report-unused-parameters* #f) ; many of these are reported anyway if they are passed some non-#f value
+(define *report-unused-top-level-functions* #f) ; very common in Scheme, but #t makes the ghastly leakage of names obvious
+(define *report-shadowed-variables* #f) ; shadowed parameters, etc
+(define *report-undefined-identifiers* #f) ; names we can't account for
+(define *report-multiply-defined-top-level-functions* #f) ; top-level funcs defined in more than one file
+(define *report-nested-if* 4) ; 3 is lowest, this sets the nesting level that triggers an if->cond suggestion
+(define *report-short-branch* 12) ; controls when a lop-sided if triggers a reordering suggestion
+(define *report-one-armed-if* 90) ; if -> when/unless, can be #f/#t; if an integer, sets tree length which triggers revision (80 is too small)
+(define *report-loaded-files* #f) ; if load is encountered, include that file in the lint process
+(define *report-any-!-as-setter* #t) ; unknown funcs/macros ending in ! are treated as setters
+(define *report-function-stuff* #t) ; checks for missed function uses etc
+(define *report-doc-strings* #f) ; old-style (CL) doc strings
+(define *report-func-as-arg-arity-mismatch* #f) ; as it says... (slow, and this error almost never happens)
+(define *report-constant-expressions-in-do* #f) ; kinda dumb
+(define *report-bad-variable-names* '(l ll O)) ; bad names: '(l ll data datum new item info temp tmp val vals value foo bar baz aux dummy O var)
+(define *report-built-in-functions-used-as-variables* #f) ; string is the most common case
+
+(define *lint* #f) ; the lint let
+;; this gives other programs a way to extend or edit lint's tables: for example, the
+;; table of functions that are simple (no side effects) is (*lint* 'no-side-effect-functions)
;;; --------------------------------------------------------------------------------
-;;; for snd-test.scm
+(when (provided? 'pure-s7)
+ (define (make-polar mag ang) (complex (* mag (cos ang)) (* mag (sin ang))))
+
+ (define (char-ci=? . chars) (apply char=? (map char-upcase chars)))
+ (define (char-ci<=? . chars) (apply char<=? (map char-upcase chars)))
+ (define (char-ci>=? . chars) (apply char>=? (map char-upcase chars)))
+ (define (char-ci<? . chars) (apply char<? (map char-upcase chars)))
+ (define (char-ci>? . chars) (apply char>? (map char-upcase chars)))
+
+ (define (string-ci=? . strs) (apply string=? (map string-upcase strs)))
+ (define (string-ci<=? . strs) (apply string<=? (map string-upcase strs)))
+ (define (string-ci>=? . strs) (apply string>=? (map string-upcase strs)))
+ (define (string-ci<? . strs) (apply string<? (map string-upcase strs)))
+ (define (string-ci>? . strs) (apply string>? (map string-upcase strs)))
+
+ (define (let->list e)
+ (if (let? e)
+ (reverse! (map values e))
+ (error 'wrong-type-arg "let->list argument should be an environment: ~A" str))))
+
+
+(define *current-file* "")
+(define *lint-output-port* *stderr*)
+(define *top-level-objects* (make-hash-table))
-(set! *#readers*
- (cons (cons #\_ (lambda (str)
- (and (string=? str "__line__")
- (port-line-number))))
- *#readers*))
+(format *stderr* "loading lint.scm~%")
+(set! reader-cond #f)
+(define-macro (reader-cond . clauses) `(values)) ; clobber reader-cond to avoid (incorrect) unbound-variable errors
-(when (not (provided? 'snd))
- (define defanimal define*)
+(unless (provided? 'snd)
(define definstrument define*)
(define defgenerator define*))
+(define-macro (let*-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (with-let orig
+ ,@(map (lambda (v)
+ `(set! ,(car v) ,(cadr v)))
+ vars)
+ , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
+(define-macro (let-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars))
+ :new (#_list ,@(map cadr vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () ; this could be (with-let orig (let ,vars , at body)) but I want to handle stuff like individual vector locations
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1)))))))
+ vars)
+ (with-let orig , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
-;;; --------------------------------------------------------------------------------
+#|
+;; debugging version
+(define-expansion (lint-format str caller . args)
+ `(begin
+ (format outport "lint.scm line ~A~%" ,(port-line-number))
+ (lint-format-1 ,str ,caller , at args)))
+|#
+;;; --------------------------------------------------------------------------------
(define lint
- (let ()
+
+ (let ((no-side-effect-functions
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (hash-table-set! ht op #t))
+ '(* + - / < <= = > >=
+ abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh
+ begin boolean? byte-vector byte-vector?
+ caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
+ call-with-input-string call-with-input-file
+ c-pointer c-pointer? c-object? call-with-exit car case catch cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr
+ cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=?
+ char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric?
+ char-position char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<?
+ char=? char>=? char>? char? complex complex? cond cons constant? continuation? cos
+ cosh curlet current-error-port current-input-port current-output-port cyclic-sequences
+ defined? denominator dilambda? do dynamic-wind
+ eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt
+ float? float-vector float-vector-ref float-vector? floor for-each funclet
+ gcd gensym gensym? ; why was gensym omitted earlier?
+ hash-table hash-table* hash-table-entries hash-table-ref hash-table? help hook-functions
+ if imag-part inexact->exact inexact? infinite? inlet input-port?
+ int-vector int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char
+ integer-decode-float integer-length integer? iterator?
+ keyword->symbol keyword?
+ lambda lambda* lcm let->list length let let* let-ref let? letrec letrec* list list->string list->vector list-ref
+ list-tail list? log logand logbit? logior lognot logxor
+ macro? magnitude make-byte-vector make-float-vector make-int-vector make-hash-table make-hook make-iterator make-keyword make-list make-polar
+ make-rectangular make-shared-vector make-string make-vector map max member memq memv min modulo morally-equal?
+ nan? negative? not null? number->string number? numerator
+ object->string odd? openlet? or outlet output-port? owlet
+ pair-line-number pair-filename pair? port-closed? port-filename port-line-number positive? procedure-documentation
+ procedure-setter procedure-signature procedure-source procedure? proper-list? provided?
+ quasiquote quote quotient
+ random-state random-state->list random-state? rational? rationalize real-part real? remainder reverse rootlet round
+ s7-version sequence? sin sinh square sqrt stacktrace string string->list string->number string->symbol string-append
+ string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase string-length
+ string-position string-ref string-upcase string<=? string<? string=? string>=? string>? string?
+ sublet substring symbol symbol->dynamic-value symbol->keyword symbol->string symbol->value symbol?
+ tan tanh tree-leaves truncate
+ unless
+ values vector vector-append vector->list vector-dimensions vector-length vector-ref vector?
+ when with-baffle with-let with-input-from-file with-input-from-string with-output-to-string
+ zero?
+ #_{list} #_{apply_values} #_{append} unquote))
+ ;; do not include file-exists? or directory?
+ ;; should this include peek-char or unlet ?
+ ht))
+
+ (built-in-functions (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (hash-table-set! ht op #t))
+ '(symbol? gensym? keyword? let? openlet? iterator? constant? macro? c-pointer? c-object?
+ input-port? output-port? eof-object? integer? number? real? complex? rational? random-state?
+ char? string? list? pair? vector? float-vector? int-vector? byte-vector? hash-table?
+ continuation? procedure? dilambda? boolean? float? proper-list? sequence? null? gensym
+ symbol->string string->symbol symbol symbol->value symbol->dynamic-value symbol-access
+ make-keyword symbol->keyword keyword->symbol outlet rootlet curlet unlet sublet varlet
+ cutlet inlet owlet coverlet openlet let-ref let-set! make-iterator iterate iterator-sequence
+ iterator-at-end? provided? provide defined? c-pointer port-line-number port-filename
+ pair-line-number pair-filename port-closed? current-input-port current-output-port
+ current-error-port let->list char-ready? close-input-port close-output-port flush-output-port
+ open-input-file open-output-file open-input-string open-output-string get-output-string
+ newline write display read-char peek-char write-char write-string read-byte write-byte
+ read-line read-string read call-with-input-string call-with-input-file with-input-from-string
+ with-input-from-file call-with-output-string call-with-output-file with-output-to-string
+ with-output-to-file real-part imag-part numerator denominator even? odd? zero? positive?
+ negative? infinite? nan? complex magnitude angle rationalize abs exp log sin cos tan asin
+ acos atan sinh cosh tanh asinh acosh atanh sqrt expt floor ceiling truncate round lcm gcd
+ + - * / max min quotient remainder modulo = < > <= >= logior logxor logand lognot ash
+ random-state random inexact->exact exact->inexact integer-length make-polar make-rectangular
+ logbit? integer-decode-float exact? inexact? random-state->list number->string string->number
+ char-upcase char-downcase char->integer integer->char char-upper-case? char-lower-case?
+ char-alphabetic? char-numeric? char-whitespace? char=? char<? char>? char<=? char>=?
+ char-position string-position make-string string-ref string-set! string=? string<? string>?
+ string<=? string>=? char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? string-ci=? string-ci<?
+ string-ci>? string-ci<=? string-ci>=? string-copy string-fill! list->string string-length
+ string->list string-downcase string-upcase string-append substring string object->string
+ format cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar cdaar caddr
+ cdddr cdadr cddar caaaar caaadr caadar cadaar caaddr cadddr cadadr caddar cdaaar cdaadr
+ cdadar cddaar cdaddr cddddr cddadr cdddar assoc member list list-ref list-set! list-tail
+ make-list length copy fill! reverse reverse! sort! append assq assv memq memv vector-append
+ list->vector vector-fill! vector-length vector->list vector-ref vector-set! vector-dimensions
+ make-vector make-shared-vector vector float-vector make-float-vector float-vector-set!
+ float-vector-ref int-vector make-int-vector int-vector-set! int-vector-ref ->byte-vector
+ byte-vector make-byte-vector hash-table hash-table* make-hash-table hash-table-ref
+ hash-table-set! hash-table-entries cyclic-sequences call/cc call-with-current-continuation
+ call-with-exit load autoload eval eval-string apply for-each map dynamic-wind values
+ catch throw error procedure-documentation procedure-signature help procedure-source funclet
+ procedure-setter arity aritable? not eq? eqv? equal? morally-equal? gc s7-version emergency-exit
+ exit dilambda make-hook hook-functions stacktrace tree-leaves
+ #_{list} #_{apply_values} #_{append} unquote))
+ ht))
+
+ (makers '(gensym sublet inlet make-iterator let->list random-state random-state->list number->string
+ make-string string string-copy copy list->string string->list string-append substring object->string
+ format cons list make-list reverse append vector-append list->vector vector->list make-vector
+ make-shared-vector vector make-float-vector float-vector make-int-vector int-vector byte-vector
+ hash-table hash-table* make-hash-table make-hook #_{list} #_{append} gentemp)) ; gentemp for other schemes
+
+ (non-negative-ops (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(string-length vector-length abs magnitude denominator gcd lcm tree-leaves
+ char->integer byte-vector-ref byte-vector-set! hash-table-entries write-byte
+ char-position string-position pair-line-number port-line-number))
+ h))
+
+ (bools (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(symbol? integer? rational? real? number? complex? float? keyword? gensym? byte-vector? string? list? sequence?
+ char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? null? pair? proper-list?
+ output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer?
+ unspecified? c-object? constant?))
+ h))
+
+ (bools1 (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(symbol? integer? rational? real? number? complex? float? keyword? gensym? byte-vector? string? list? sequence?
+ char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? null? pair? proper-list?
+ output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer? c-object?
+ unspecified? exact? inexact? defined? provided? even? odd? char-whitespace? char-numeric? char-alphabetic?
+ negative? positive? zero? constant? infinite? nan? char-upper-case? char-lower-case? directory? file-exists?))
+ h))
+
+ (reversibles (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h (car op)) (cadr op)))
+ '((< >) (> <) (<= >=) (>= <=)
+ (* *) (+ +) (= =) (char=? char=?) (string=? string=?)
+ (eq? eq?) (eqv? eqv?) (equal? equal?) (morally-equal? morally-equal?)
+ (logand logand) (logxor logxor) (logior logior)
+ (max max) (min min) (lcm lcm) (gcd gcd)
+ (char<? char>?) (char>? char<?) (char<=? char>=?) (char>=? char<=?)
+ (string<? string>?) (string>? string<?) (string<=? string>=?) (string>=? string<=?)
+ (char-ci<? char-ci>?) (char-ci>? char-ci<?) (char-ci<=? char-ci>=?) (char-ci>=? char-ci<=?)
+ (string-ci<? string-ci>?) (string-ci>? string-ci<?) (string-ci<=? string-ci>=?) (string-ci>=? string-ci<=?)))
+ h))
+
+ (syntaces (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(quote if begin let let* letrec letrec* cond case or and do set! unless when
+ with-let with-baffle
+ lambda lambda* define define*
+ define-macro define-macro* define-bacro define-bacro*
+ define-constant define-expansion))
+ h))
+
+ (outport #t)
+ (linted-files ())
+ (big-constants ())
+ (equable-closures ())
+ (*e* #f)
+ (other-identifiers #f)
+ (quote-warnings 0)
+ (last-simplify-boolean-line-number -1)
+ (last-simplify-numeric-line-number -1)
+ (last-simplify-cxr-line-number -1)
+ (last-if-line-number -1)
+ (last-checker-line-number -1)
+ (last-cons-line-number -1)
+ (last-rewritten-internal-define #f)
+ (last-assoc-form #f)
+ (line-number -1)
+ (pp-left-margin 4)
+ (lint-left-margin 1))
+
+ (set! *e* (curlet))
+ (set! *lint* *e*) ; external access to (for example) the built-in-functions hash-table via (*lint* 'built-in-functions)
+
+
+ ;; -------- lint-format --------
+ (define target-line-length 80)
+
+ (define (truncated-list->string form)
+ ;; return form -> string with limits on its length
+ (let* ((str (object->string form))
+ (len (length str)))
+ (if (< len target-line-length)
+ str
+ (do ((i (- target-line-length 6) (- i 1)))
+ ((or (= i 40)
+ (char-whitespace? (str i)))
+ (string-append (substring str 0 (if (<= i 40) (- target-line-length 6) i)) "..."))))))
+
+ (define lint-pp #f) ; avoid crosstalk with other schemes' definitions of pp and pretty-print (make-var also collides)
+ (define lint-pretty-print #f)
+ (let ()
+ (require write.scm)
+ (set! lint-pp pp);
+ (set! lint-pretty-print pretty-print))
+
+ (define (lists->string f1 f2)
+ ;; same but 2 strings that may need to be lined up vertically
+ (let* ((str1 (object->string f1))
+ (len1 (length str1))
+ (str2 (object->string f2))
+ (len2 (length str2)))
+ (when (> len1 target-line-length)
+ (set! str1 (truncated-list->string f1))
+ (set! len1 (length str1)))
+ (when (> len2 target-line-length)
+ (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) pp-left-margin)
+ (set! ((funclet lint-pretty-print) '*pretty-print-length*) (- 114 pp-left-margin))
+ (set! str2 (lint-pp f2))
+ (set! len2 (length str2)))
+ (format #f (if (< (+ len1 len2) target-line-length)
+ (values "~A -> ~A" str1 str2)
+ (values "~%~NC~A ->~%~NC~A" pp-left-margin #\space str1 pp-left-margin #\space str2)))))
+
+ (define (truncated-lists->string f1 f2)
+ ;; same but 2 strings that may need to be lined up vertically and both are truncated
+ (let* ((str1 (object->string f1))
+ (len1 (length str1))
+ (str2 (object->string f2))
+ (len2 (length str2)))
+ (when (> len1 target-line-length)
+ (set! str1 (truncated-list->string f1))
+ (set! len1 (length str1)))
+ (when (> len2 target-line-length)
+ (set! str2 (truncated-list->string f2))
+ (set! len2 (length str2)))
+ (format #f (if (< (+ len1 len2) target-line-length)
+ (values "~A -> ~A" str1 str2)
+ (values "~%~NC~A ->~%~NC~A" pp-left-margin #\space str1 pp-left-margin #\space str2)))))
+
+ (define made-suggestion 0)
+
+ (define (lint-format str caller . args)
+ (let ((outstr (apply format #f
+ (string-append (if (< 0 line-number 100000)
+ "~NC~A (line ~D): "
+ "~NC~A: ")
+ str "~%")
+ lint-left-margin #\space
+ (truncated-list->string caller)
+ (if (< 0 line-number 100000)
+ (values line-number args)
+ args))))
+ (set! made-suggestion (+ made-suggestion 1))
+ (display outstr outport)
+ (if (> (length outstr) (+ target-line-length 40))
+ (newline outport))))
+
+ (define (lint-format* caller . strs)
+ (let* ((outstr (format #f
+ (if (< 0 line-number 100000)
+ "~NC~A (line ~D): "
+ "~NC~A:~A")
+ lint-left-margin #\space
+ (truncated-list->string caller)
+ (if (< 0 line-number 100000)
+ line-number
+ " ")))
+ (current-end (length outstr)))
+ (display outstr outport)
+ (for-each (lambda (s)
+ (let ((len (length s)))
+ (if (> (+ len current-end) target-line-length)
+ (begin
+ (format outport "~%~NC~A" (+ lint-left-margin 4) #\space s)
+ (set! current-end len))
+ (begin
+ (display s outport)
+ (set! current-end (+ current-end len))))))
+ strs)
+ (newline outport)))
+
+ (define (local-line-number tree)
+ (let ((tree-line (if (pair? tree) (pair-line-number tree) 0)))
+ (if (and (< 0 tree-line 100000)
+ (not (= tree-line line-number)))
+ (format #f " (line ~D)" tree-line)
+ "")))
+
+
+ ;; -------- vars --------
+ (define var-name car)
+ (define (var? v) (and (pair? v) (let? (cdr v))))
+ (define var-member assq)
+
+ (define var-ref (dilambda (lambda (v) (let-ref (cdr v) 'ref)) (lambda (v x) (let-set! (cdr v) 'ref x))))
+ (define var-set (dilambda (lambda (v) (let-ref (cdr v) 'set)) (lambda (v x) (let-set! (cdr v) 'set x))))
+ (define var-history (dilambda (lambda (v) (let-ref (cdr v) 'history)) (lambda (v x) (let-set! (cdr v) 'history x))))
+ (define var-ftype (dilambda (lambda (v) (let-ref (cdr v) 'ftype)) (lambda (v x) (let-set! (cdr v) 'ftype x))))
+ (define var-arglist (dilambda (lambda (v) (let-ref (cdr v) 'arglist)) (lambda (v x) (let-set! (cdr v) 'arglist x))))
+ (define var-definer (dilambda (lambda (v) (let-ref (cdr v) 'definer)) (lambda (v x) (let-set! (cdr v) 'definer x))))
+ (define var-leaves (dilambda (lambda (v) (let-ref (cdr v) 'leaves)) (lambda (v x) (let-set! (cdr v) 'leaves x))))
+ (define var-scope (dilambda (lambda (v) (let-ref (cdr v) 'scope)) (lambda (v x) (let-set! (cdr v) 'scope x))))
+ (define var-env (dilambda (lambda (v) (let-ref (cdr v) 'env)) (lambda (v x) (let-set! (cdr v) 'env x))))
+ (define var-decl (dilambda (lambda (v) (let-ref (cdr v) 'decl)) (lambda (v x) (let-set! (cdr v) 'decl x))))
+ (define var-match-list (dilambda (lambda (v) (let-ref (cdr v) 'match-list)) (lambda (v x) (let-set! (cdr v) 'match-list x))))
+ (define var-initial-value (lambda (v) (let-ref (cdr v) 'initial-value))) ; not settable
+
+ (define var-side-effect (dilambda (lambda (v)
+ (if (null? (let-ref (cdr v) 'side-effect))
+ (let-set! (cdr v) 'side-effect (get-side-effect v))
+ (let-ref (cdr v) 'side-effect)))
+ (lambda (v x)
+ (let-set! (cdr v) 'side-effect x))))
+
+ (define var-signature (dilambda (lambda (v)
+ (if (null? (let-ref (cdr v) 'signature))
+ (let-set! (cdr v) 'signature (get-signature v))
+ (let-ref (cdr v) 'signature)))
+ (lambda (v x)
+ (let-set! (cdr v) 'signature x))))
+
+ (define* (make-var name initial-value definer)
+ (let ((old (hash-table-ref other-identifiers name)))
+ (cons name (inlet 'initial-value initial-value
+ 'definer definer
+ 'history (if old
+ (begin
+ (hash-table-set! other-identifiers name #f)
+ (if initial-value (cons initial-value old) old))
+ (if initial-value (list initial-value) ()))
+ 'scope ()
+ 'set 0
+ 'ref (if old (length old) 0)))))
+
+
+ ;; -------- the usual list functions --------
+ (define (remove item sequence)
+ (cond ((null? sequence) ())
+ ((equal? item (car sequence)) (cdr sequence))
+ (else (cons (car sequence) (remove item (cdr sequence))))))
+
+ (define (remove-all item sequence)
+ (map (lambda (x)
+ (if (equal? x item)
+ (values)
+ x))
+ sequence))
+
+ (define (remove-if p lst)
+ (cond ((null? lst) ())
+ ((p (car lst)) (remove-if p (cdr lst)))
+ (else (cons (car lst)
+ (remove-if p (cdr lst))))))
+
+ (define (lint-remove-duplicates lst env)
+ (reverse (let rem-dup ((lst lst)
+ (nlst ()))
+ (cond ((null? lst) nlst)
+ ((and (member (car lst) nlst)
+ (not (and (pair? (car lst))
+ (side-effect? (car lst) env))))
+ (rem-dup (cdr lst) nlst))
+ (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
+
+ (define applicable? arity)
+
+ (define every?
+ (let ((documentation "(every? func sequence) returns #t if func approves of every member of sequence"))
+ (lambda (f sequence)
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (arg) (if (not (f arg)) (return #f))) sequence)
+ #t)))))
+
+ (define any?
+ (let ((documentation "(any? func sequence) returns #t if func approves of any member of sequence"))
+ (lambda (f sequence)
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (arg) (if (f arg) (return #t))) sequence)
+ #f)))))
+
+ (define collect-if
+ (let ((documentation "(collect-if type func sequence) gathers the elements of sequence that satisfy func, and returns them via type:\n\
+ (collect-if list integer? #(1.4 2/3 1 1+i 2)) -> '(1 2)"))
+ (lambda (type f sequence)
+ (apply type (map (lambda (arg) (if (f arg) arg (values))) sequence)))))
+
+ (define find-if
+ (let ((documentation "(find-if func sequence) applies func to each member of sequence.\n\
+ If func approves of one, find-if returns that member of the sequence"))
+ (lambda (f sequence)
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (arg)
+ (if (f arg)
+ (return arg)))
+ sequence)
+ #f)))))
+
+
+ ;; -------- trees --------
+ (define copy-tree
+ (let ((documentation "(copy-tree lst) returns a full copy of lst"))
+ (lambda (lis)
+ (if (pair? lis)
+ (cons (copy-tree (car lis))
+ (copy-tree (cdr lis)))
+ lis))))
+
+ (define (tree-count1 x tree count)
+ (if (eq? x tree)
+ (+ count 1)
+ (if (or (>= count 2)
+ (not (pair? tree))
+ (eq? (car tree) 'quote))
+ count
+ (tree-count1 x (car tree) (tree-count1 x (cdr tree) count)))))
+
+ (define (tree-count2 x tree count)
+ (if (eq? x tree)
+ (+ count 1)
+ (if (or (>= count 3)
+ (not (pair? tree))
+ (eq? (car tree) 'quote))
+ count
+ (tree-count2 x (car tree) (tree-count2 x (cdr tree) count)))))
+
+ (define (proper-tree? tree)
+ (or (not (pair? tree))
+ (and (proper-list? tree)
+ (every? proper-tree? (cdr tree)))))
+
+ (define (gather-symbols tree)
+ (let ((syms ()))
+ (let walk ((p tree))
+ (if (pair? p)
+ (if (symbol? (car p))
+ (if (not (eq? (car p) 'quote))
+ (for-each (lambda (a)
+ (if (symbol? a)
+ (if (not (memq a syms))
+ (set! syms (cons a syms)))
+ (if (pair? a) (walk a))))
+ (cdr p)))
+ (if (pair? (car p))
+ (begin
+ (walk (car p))
+ (walk (cdr p)))))
+ (if (and (symbol? tree)
+ (not (memq tree syms)))
+ (set! syms (cons tree syms)))))
+ syms))
+
+ (define (tree-arg-member sym tree)
+ (and (proper-list? tree)
+ (or (and (memq sym (cdr tree))
+ tree)
+ (and (pair? (car tree))
+ (tree-arg-member sym (car tree)))
+ (and (pair? (cdr tree))
+ (call-with-exit
+ (lambda (return)
+ (for-each
+ (lambda (b)
+ (cond ((and (pair? b)
+ (tree-arg-member sym b))
+ => return)))
+ (cdr tree))
+ #f))))))
+
+ (define (tree-memq sym tree)
+ (or (eq? sym tree)
+ (and (pair? tree)
+ (not (eq? (car tree) 'quote))
+ (or (eq? (car tree) sym)
+ (tree-memq sym (car tree))
+ (tree-memq sym (cdr tree))))))
+
+ (define (tree-member sym tree)
+ (and (pair? tree)
+ (or (eq? (car tree) sym)
+ (tree-member sym (car tree))
+ (tree-member sym (cdr tree)))))
+
+ (define (tree-unquoted-member sym tree)
+ (and (pair? tree)
+ (not (eq? (car tree) 'quote))
+ (or (eq? (car tree) sym)
+ (tree-unquoted-member sym (car tree))
+ (tree-unquoted-member sym (cdr tree)))))
+
+ (define (tree-car-member sym tree)
+ (and (pair? tree)
+ (or (eq? (car tree) sym)
+ (and (pair? (car tree))
+ (tree-car-member sym (car tree)))
+ (and (pair? (cdr tree))
+ (member sym (cdr tree) tree-car-member)))))
+
+ (define (tree-sym-set-member sym set tree) ; sym as arg, set as car
+ (and (pair? tree)
+ (or (memq (car tree) set)
+ (and (pair? (car tree))
+ (tree-sym-set-member sym set (car tree)))
+ (and (pair? (cdr tree))
+ (or (member sym (cdr tree))
+ (member #f (cdr tree) (lambda (a b) (tree-sym-set-member sym set b))))))))
+
+ (define (tree-set-member set tree)
+ (and (pair? tree)
+ (not (eq? (car tree) 'quote))
+ (or (memq (car tree) set)
+ (tree-set-member set (car tree))
+ (tree-set-member set (cdr tree)))))
+
+ (define (tree-table-member table tree)
+ (and (pair? tree)
+ (or (hash-table-ref table (car tree))
+ (tree-table-member table (car tree))
+ (tree-table-member table (cdr tree)))))
+
+ (define (tree-set-car-member set tree) ; set as car
+ (and (pair? tree)
+ (or (and (memq (car tree) set)
+ tree)
+ (and (pair? (car tree))
+ (tree-set-car-member set (car tree)))
+ (and (pair? (cdr tree))
+ (member #f (cdr tree) (lambda (a b) (tree-set-car-member set b)))))))
+
+ (define (maker? tree)
+ (tree-set-car-member makers tree))
+
+ (define (tree-symbol-walk tree syms)
+ (if (pair? tree)
+ (if (eq? (car tree) 'quote)
+ (if (and (pair? (cdr tree))
+ (symbol? (cadr tree))
+ (not (memq (cadr tree) (car syms))))
+ (tree-symbol-walk (cddr tree) (begin (set-car! syms (cons (cadr tree) (car syms))) syms)))
+ (if (eq? (car tree) {list})
+ (if (and (pair? (cdr tree))
+ (pair? (cadr tree))
+ (eq? (caadr tree) 'quote)
+ (symbol? (cadadr tree))
+ (not (memq (cadadr tree) (cadr syms))))
+ (tree-symbol-walk (cddr tree) (begin (list-set! syms 1 (cons (cadadr tree) (cadr syms))) syms)))
+ (begin
+ (tree-symbol-walk (car tree) syms)
+ (tree-symbol-walk (cdr tree) syms))))))
+
+
+ ;; -------- types --------
(define (any-real? lst) ; ignore 0.0 and 1.0 in this since they normally work
(and (pair? lst)
(or (and (number? (car lst))
@@ -87,2544 +680,4953 @@
(pair? (cdr x))
(pair? (cadr x))
(positive? (length (cadr x)))))
-
+
(define (quoted-null? x)
(and (pair? x)
(eq? (car x) 'quote)
(pair? (cdr x))
(null? (cadr x))))
-
+
+ (define (quoted-not? x)
+ (and (pair? x)
+ (eq? (car x) 'quote)
+ (pair? (cdr x))
+ (not (cadr x))))
+
+ (define (quoted-symbol? x)
+ (and (pair? x)
+ (eq? (car x) 'quote)
+ (pair? (cdr x))
+ (symbol? (cadr x))))
+
(define (code-constant? x)
- (and (not (symbol? x))
+ (and (or (not (symbol? x))
+ (keyword? x))
(or (not (pair? x))
- (and (eq? (car x) 'quote)
- (list? (cdr x)))))) ; was pair?
-
- (let ((no-side-effect-functions
- ;; ideally we'd be able to add functions to this list, perhaps similar to the signatures
- (let ((ht (make-hash-table)))
- (for-each
- (lambda (op)
- (hash-table-set! ht op #t))
- '(* + - / < <= = > >=
- abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh
- begin boolean=? boolean? byte-vector byte-vector?
- caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
- call-with-input-from-string call-with-input-from-file
- c-pointer c-pointer? c-object? call-with-exit car case catch cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr
- cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=?
- char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric?
- char-position char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<?
- char=? char>=? char>? char? complex complex? cond cons constant? continuation? cos
- cosh curlet current-error-port current-input-port current-output-port cyclic-sequences
- defined? denominator dilambda? do dynamic-wind
- eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt
- float? float-vector float-vector-ref float-vector? floor for-each funclet
- gcd gensym gensym?
- hash-table hash-table* hash-table-entries hash-table-ref hash-table? help hook-functions
- if imag-part inexact->exact inexact? infinite? inlet input-port?
- int-vector int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char
- integer-decode-float integer-length integer? iterator?
- keyword->symbol keyword?
- let->list lcm length let let* let-ref let? letrec letrec* list list->string list->vector list-ref
- list-tail list? log logand logbit? logior lognot logxor
- macro? magnitude make-byte-vector make-float-vector make-int-vector make-hash-table make-hook make-iterator make-keyword make-list make-polar
- make-rectangular make-shared-vector make-string make-vector map max member memq memv min modulo morally-equal?
- nan? negative? not null? number->string number? numerator
- object->string odd? openlet? or outlet output-port? owlet
- pair-line-number pair? peek-char port-closed? port-filename port-line-number positive? procedure-documentation
- procedure-setter procedure-signature procedure-source procedure? proper-list? provided?
- quasiquote quote quotient
- random-state random-state->list random-state? rational? rationalize real-part real? remainder reverse rootlet round
- s7-version sequence? sin sinh sqrt stacktrace string string->list string->number string->symbol string-append
- string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase string-length
- string-position string-ref string-upcase string<=? string<? string=? string>=? string>? string?
- sublet substring symbol symbol->dynamic-value symbol->keyword symbol->string symbol->value symbol=? symbol?
- tan tanh truncate
- unless unlet
- vector vector-append vector->list vector-dimensions vector-length vector-ref vector?
- when with-baffle with-let with-input-from-file with-input-from-string with-output-to-string
- zero?))
- ;; do not include file-exists? or directory?
- ht))
-
- (deprecated-ops '((global-environment . rootlet)
- (current-environment . curlet)
- (make-procedure-with-setter . dilambda)
- (procedure-with-setter? . dilambda?)
- (make-random-state . random-state)
- ;(make-rectangular . complex)
-
- (data-format . sample-type)
- (mus-sound-data-format . mus-sound-sample-type)
- (mus-data-format-name . mus-sample-type-name)
- (mus-data-format->string . mus-sample-type->string)))
-
- (numeric-ops (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(+ * - /
- sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh
- log exp expt sqrt make-polar complex
- imag-part real-part abs magnitude angle max min exact->inexact
- modulo remainder quotient lcm gcd
- rationalize inexact->exact random
- logior lognot logxor logand numerator denominator
- floor round truncate ceiling ash))
- h))
-
- (repeated-args-table (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(= / max min < > <= >= - quotient remainder modulo and or
- string=? string<=? string>=? string<? string>?
- char=? char<=? char>=? char<? char>?
- boolean=? symbol=?))
- h))
-
- (repeated-args-table-2 (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(= max min < > <= >= and or
- string=? string<=? string>=? string<? string>?
- char=? char<=? char>=? char<? char>?
- boolean=? symbol=?))
- h))
+ (eq? (car x) 'quote))))
+
+ (define (just-symbols? form)
+ (or (null? form)
+ (symbol? form)
+ (and (pair? form)
+ (symbol? (car form))
+ (just-symbols? (cdr form)))))
+
+ (define (list-any? f lst)
+ (if (pair? lst)
+ (or (f (car lst))
+ (list-any? f (cdr lst)))
+ (f lst)))
+
+ (define syntax?
+ (let ((syns (let ((h (make-hash-table)))
+ (for-each (lambda (x)
+ (hash-table-set! h x #t))
+ (list quote if when unless begin set! let let* letrec letrec* cond and or case do
+ lambda lambda* define define* define-macro define-macro* define-bacro define-bacro*
+ define-constant with-baffle macroexpand with-let))
+ h)))
+ (lambda (obj) ; a value, not a symbol
+ (hash-table-ref syns obj))))
- (syntaces (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(quote if begin let let* letrec letrec* cond case or and do set! unless when
- with-let with-baffle
- lambda lambda* define define*
- define-macro define-macro* define-bacro define-bacro*
- define-constant define-expansion))
- h))
-
- (format-control-char (let ((chars (make-vector 256 #f)))
- (for-each
- (lambda (c)
- (vector-set! chars (char->integer c) #t))
- '(#\A #\S #\C #\F #\E #\G #\O #\D #\B #\X #\, #\{ #\} #\@ #\P #\*
- #\a #\s #\c #\f #\e #\g #\o #\d #\b #\x #\p #\N #\n #\W #\w #\v #\V
- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
- chars))
-
- (selector-types '(#t symbol? char? boolean? integer? rational? real? complex? number?))
- (outport #t)
- (loaded-files #f)
- (globals #f)
- (*e* (curlet))
- (other-identifiers #f)
- (quote-warnings 0)
- (last-simplify-boolean-line-number -1)
- (last-simplify-numeric-line-number -1)
- (last-checker-line-number -1)
- (line-number -1))
-#|
- (define var-name (dilambda (lambda (v) (v :name)) (lambda (v x) (set! (v :name) x))))
- (define var-ref (dilambda (lambda (v) (v :ref)) (lambda (v x) (set! (v :ref) x))))
- (define var-set (dilambda (lambda (v) (v :set)) (lambda (v x) (set! (v :set) x))))
- (define var-type (dilambda (lambda (v) (v :type)) (lambda (v x) (set! (v :type) x))))
- (define var-value (dilambda (lambda (v) (v :value)) (lambda (v x) (set! (v :value) x))))
- (define* (make-var name ref set fnc typ val new)
- (inlet :var :var :name name :ref ref :set set :fnc fnc :type typ :value val :new new))
- (define (var? v) (and (let? v) (eq? (v :var) :var)))
- ;; but need var-member -- (assoc x y var-name)?
-
- ;; var-type is set in make-var in do and the various lets, so new needs closure-type? and set var-type to procedure? or macro? etc
- ;; define et al could also set the type
-|#
+
+ ;; -------- func info --------
+ (define (arg-signature fnc env)
+ (and (symbol? fnc)
+ (let ((fd (var-member fnc env)))
+ (if (var? fd)
+ (and (symbol? (var-ftype fd))
+ (var-signature fd))
+ (or (and (eq? *e* *lint*)
+ (procedure-signature fnc))
+ (let ((f (symbol->value fnc *e*)))
+ (and (procedure? f)
+ (procedure-signature f))))))))
+
+ (define (arg-arity fnc env)
+ (and (symbol? fnc)
+ (let ((fd (var-member fnc env)))
+ (if (var? fd)
+ (and (not (eq? (var-decl fd) 'error))
+ (arity (var-decl fd)))
+ (let ((f (symbol->value fnc *e*)))
+ (and (procedure? f)
+ (arity f)))))))
+
+ (define (dummy-func caller form f)
+ (catch #t
+ (lambda ()
+ (eval f))
+ (lambda args
+ (lint-format* caller
+ (string-append "in " (truncated-list->string form) ", ")
+ (apply format #f (cadr args))))))
+
+ (define (count-values body)
+ (let ((mn #f)
+ (mx #f))
+ (if (pair? body)
+ (let counter ((ignored #f) ; 'ignored is for member's benefit
+ (tree (list-ref body (- (length body) 1))))
+ (if (pair? tree)
+ (if (eq? (car tree) 'values)
+ (let ((args (- (length tree) 1)))
+ (for-each (lambda (p)
+ (if (and (pair? p) (eq? (car p) 'values))
+ (set! args (- (+ (args (length p)) 2)))))
+ (cdr tree))
+ (set! mn (min (or mn args) args))
+ (set! mx (max (or mx args) args)))
+ (begin
+ (if (pair? (car tree))
+ (counter 'values (car tree)))
+ (if (pair? (cdr tree))
+ (member #f (cdr tree) counter)))))
+ #f)) ; return #f so member doesn't quit early
+ (and mn (list mn mx))))
+
- (define var? pair?)
- (define var-member assq)
- (define var-name car)
- (define var-ref cadr)
- (define var-set caddr)
- (define (set-cadr! v val) (list-set! v 1 val))
- (define (set-caddr! v val) (list-set! v 2 val))
- (set! (procedure-setter cadr) set-cadr!)
- (set! (procedure-setter caddr) set-caddr!)
- (define var-type (dilambda (lambda (v) (list-ref v 3)) (lambda (v x) (list-set! v 3 x))))
- (define var-value (dilambda (lambda (v) (list-ref v 4)) (lambda (v x) (list-set! v 4 x))))
- ;; (define make-var (lambda* (name ref set typ val :allow-other-keys) (list name ref set typ val)))
- ;; this :allow-other-keys is protecting us from bizarre keyword uses in non-s7 code.
- (define var-new (dilambda (lambda (v) (list-ref v 5)) (lambda (v x) (list-set! v 5 x))))
-
- (define* (make-var name ref set typ val new)
- ;(if new (format *stderr* "~A: ~A~%~%" name new))
- (list name ref set typ val new))
-
- (define (return-type sym)
- (let ((f (if (symbol? sym) (symbol->value sym *e*) sym)))
- (and (procedure? f)
- (let ((sig (procedure-signature f)))
- (and (pair? sig)
- (or (eq? (car sig) 'values) ; turn it into #t for now
- (car sig))))))) ; this might be undefined in the current context (eg oscil? outside clm)
-
- (define (->type c)
- (cond ((pair? c)
- (if (symbol? (car c))
- (return-type (car c))
- (or (pair? (car c)) 'pair?)))
- ((integer? c) 'integer?)
- ((rational? c) 'rational?)
- ((real? c) 'real?)
- ((number? c) 'number?)
- ((keyword? c) 'keyword?)
- ((symbol? c) 'symbol?)
- ((byte-vector? c) 'byte-vector?)
- ((string? c) 'string?)
- ((null? c) 'null?)
- ((char? c) 'char?)
- ((boolean? c) 'boolean?)
- ((float-vector? c) 'float-vector?)
- ((int-vector? c) 'int-vector?)
- ((vector? c) 'vector?)
- ((let? c) 'let?)
- ((hash-table? c) 'hash-table?)
- ((input-port? c) 'input-port?)
- ((output-port? c) 'output-port?)
- ((iterator? c) 'iterator?)
- ((continuation? c) 'continuation?)
- ((dilambda? c) 'dilambda?)
- ((procedure? c) 'procedure?)
- ((macro? c) 'macro?)
- ((random-state? c) 'random-state?)
- ((eof-object? c) 'eof-object?)
- ((c-pointer? c) 'c-pointer?)
- (#t #t)))
+ (define (get-signature v)
+
+ (define (signer endb env)
+ (and (not (side-effect? endb env))
+ (cond ((not (pair? endb))
+ (and (not (symbol? endb))
+ (list (->lint-type endb))))
+ ((arg-signature (car endb) env)
+ => (lambda (a)
+ (and (pair? a)
+ (list (car a)))))
+ ((and (eq? (car endb) 'if)
+ (pair? (cddr endb)))
+ (let ((a1 (signer (caddr endb) env))
+ (a2 (and (pair? (cdddr endb))
+ (signer (cadddr endb) env))))
+ (if (not a2)
+ a1
+ (and (equal? a1 a2) a1))))
+ (else #f))))
- (define bools '(symbol? integer? rational? real? number? complex? float? keyword? gensym? byte-vector? string? list?
- char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? null? pair?
- output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer?))
-
- (define (compatible? type1 type2) ; we want type1, we have type2 -- is type2 ok?
- ;(format *stderr* "compatible ~S ~S~%" type1 type2)
- (or (eq? type1 type2)
- (not (symbol? type1))
- (not (symbol? type2))
- (not (memq type1 bools))
- (not (memq type2 bools))
- (case type1
- ((number? complex?) (memq type2 '(float? real? rational? integer? number? complex?)))
- ((real?) (memq type2 '(float? rational? integer? complex? number?)))
- ((float?) (memq type2 '(real? complex? number?)))
- ((rational?) (memq type2 '(integer? real? complex? number?)))
- ((integer?) (memq type2 '(real? rational? complex? number?)))
- ((vector?) (memq type2 '(float-vector? int-vector?)))
- ((float-vector? int-vector?) (eq? type2 'vector?))
- ((symbol?) (memq type2 '(gensym? keyword?)))
- ((keyword? gensym?) (eq? type2 'symbol?))
- ((list?) (memq type2 '(null? pair?)))
- ((pair? null?) (eq? type2 'list?))
- ((dilambda?) (memq type2 '(procedure? macro? iterator?)))
- ((procedure? macro?) (memq type2 '(dilambda? iterator?)))
- ((iterator?) (memq type2 '(dilambda? procedure?)))
- ((string?) (eq? type2 'byte-vector?))
- ((byte-vector?) (eq? type2 'string?))
- (else #f))))
-
- (define (any-compatible? type1 type2)
- ;; type1 and type2 can be either a list of types or a type
- (if (symbol? type1)
- (if (symbol? type2)
- (compatible? type1 type2)
- (and (pair? type2)
- (or (compatible? type1 (car type2))
- (any-compatible? type1 (cdr type2)))))
- (and (pair? type1)
- (or (compatible? (car type1) type2)
- (any-compatible? (cdr type1) type2)))))
-
- (define (subsumes? type1 type2)
- (or (eq? type1 type2)
- (case type1
- ((rational?) (eq? type2 'integer?))
- ((real?) (memq type2 '(integer? rational? float?)))
- ((complex? number?) (memq type2 '(integer? rational? float? real? complex? number?)))
- ((list?) (memq type2 '(pair? null? proper-list?)))
- ((pair?) (eq? type2 'proper-list?))
- ((vector?) (memq type2 '(float-vector? int-vector?)))
- ((symbol?) (memq type2 '(keyword? gensym?)))
- (else #f))))
-
- (define (any-checker? types arg)
- (if (and (symbol? types)
- (not (eq? types 'values)))
- ((symbol->value types *e*) arg)
- (and (pair? types)
- (or (any-checker? (car types) arg)
- (any-checker? (cdr types) arg)))))
-
- (define (never-false expr)
- (or (eq? expr #t)
- (let ((type (if (pair? expr)
- (and (hash-table-ref no-side-effect-functions (car expr))
- (return-type (car expr)))
- (->type expr))))
- (and (symbol? type)
- (not (symbol? expr))
- (not (memq type '(boolean? values)))))))
+ (let ((ftype (var-ftype v))
+ (initial-value (var-initial-value v))
+ (arglist (var-arglist v))
+ (env (var-env v)))
+
+ (let ((body (and (memq ftype '(define define* lambda lambda* let))
+ (cddr initial-value))))
+
+ (and (pair? body)
+ (let ((sig (signer (list-ref body (- (length body) 1)) env)))
+ (if (not (pair? sig))
+ (set! sig (list #t)))
+
+ (when (and (proper-list? arglist)
+ (not (any? keyword? arglist)))
+ (for-each
+ (lambda (arg) ; new function's parameter
+ (set! sig (cons #t sig))
+ ;; (if (pair? arg) (set! arg (car arg)))
+ ;; causes trouble when tree-count1 sees keyword args in s7test.scm
+ (if (= (tree-count1 arg body 0) 1)
+ (let ((p (tree-arg-member arg body)))
+ (when (pair? p)
+ (let ((f (car p))
+ (m (memq arg (cdr p))))
+ (if (pair? m)
+ (let ((fsig (arg-signature f env)))
+ (if (pair? fsig)
+ (let* ((loc (- (length p) (length m)))
+ (chk (catch #t (lambda () (fsig loc)) (lambda args #f))))
+ (if (and (symbol? chk) ; it defaults to #t
+ (not (memq chk '(integer:any? integer:real?))))
+ (set-car! sig chk)))))))))))
+ arglist))
+ (and (any? (lambda (a) (not (eq? a #t))) sig)
+ (reverse sig)))))))
+
+ (define (args->proper-list args)
+ (cond ((symbol? args) (list args))
+ ((not (pair? args)) args)
+ ((pair? (car args)) (cons (caar args) (args->proper-list (cdr args))))
+ (else (cons (car args) (args->proper-list (cdr args))))))
+
+ (define (out-vars func-name arglist body) ; t367 has tests
+ (let ((ref ())
+ (set ()))
+ (let var-walk ((tree body)
+ (e (cons func-name arglist)))
+ (define (var-walk-body tree e)
+ (when (pair? tree)
+ (for-each (lambda (p) (set! e (var-walk p e))) tree)))
+ (define (shadowed v)
+ (if (and (or (memq v e) (memq v ref))
+ (not (memq v set)))
+ (set! set (cons v set)))
+ v)
+ (if (symbol? tree)
+ (if (not (or (memq tree e) (memq tree ref) (defined? tree (rootlet))))
+ (set! ref (cons tree ref)))
+ (when (pair? tree)
+ (if (not (pair? (cdr tree)))
+ (var-walk (car tree) e)
+ (case (car tree)
+ ((set! vector-set! list-set! hash-table-set! float-vector-set! int-vector-set!
+ string-set! let-set! fill! string-fill! list-fill! vector-fill!
+ reverse! sort! set-car! set-cdr!)
+ (let ((sym (if (symbol? (cadr tree))
+ (cadr tree)
+ (if (pair? (cadr tree)) (caadr tree)))))
+ (if (not (or (memq sym e) (memq sym set)))
+ (set! set (cons sym set)))
+ (var-walk (cddr tree) e)))
+
+ ((let letrec)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (let* ((named (symbol? (cadr tree)))
+ (vars (if named
+ (list (shadowed (cadr tree)))
+ ())))
+ (for-each (lambda (v)
+ (when (and (pair? v)
+ (pair? (cdr v)))
+ (var-walk (cadr v) e)
+ (set! vars (cons (shadowed (car v)) vars))))
+ (if named (caddr tree) (cadr tree)))
+ (var-walk-body (if named (cdddr tree) (cddr tree)) (append vars e)))))
+
+ ((case)
+ (when (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (for-each (lambda (c)
+ (when (pair? c)
+ (var-walk (cdr c) e)))
+ (cddr tree))))
+
+ ((quote) #f)
+ ((let* letrec*)
+ (let* ((named (symbol? (cadr tree)))
+ (vars (if named (list (cadr tree)) ())))
+ (for-each (lambda (v)
+ (when (and (pair? v)
+ (pair? (cdr v)))
+ (var-walk (cadr v) (append vars e))
+ (set! vars (cons (shadowed (car v)) vars))))
+ (if named (caddr tree) (cadr tree)))
+ (var-walk-body (if named (cdddr tree) (cddr tree)) (append vars e))))
+
+ ((do)
+ (let ((vars ()))
+ (when (pair? (cadr tree))
+ (for-each (lambda (v)
+ (when (and (pair? v)
+ (pair? (cdr v)))
+ (var-walk (cadr v) e)
+ (set! vars (cons (shadowed (car v)) vars))))
+ (cadr tree))
+ (for-each (lambda (v)
+ (if (and (pair? v)
+ (pair? (cdr v))
+ (pair? (cddr v)))
+ (var-walk (caddr v) (append vars e))))
+ (cadr tree)))
+ (when (pair? (cddr tree))
+ (var-walk (caddr tree) (append vars e))
+ (var-walk-body (cdddr tree) (append vars e)))))
+
+ ((lambda lambda*)
+ (var-walk-body (cddr tree) (append (args->proper-list (cadr tree)) e)))
+
+ ((define* define-macro define-macro* define-bacro define-bacro*)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (begin
+ (set! e (cons (caadr tree) e))
+ (var-walk-body (cddr tree) (append (args->proper-list (cdadr tree)) e)))))
+
+ ((define define-constant)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (if (symbol? (cadr tree))
+ (begin
+ (var-walk (caddr tree) e)
+ (set! e (cons (cadr tree) e)))
+ (begin
+ (set! e (cons (caadr tree) e))
+ (var-walk-body (cddr tree) (append (args->proper-list (cdadr tree)) e))))))
+ (else
+ (var-walk (car tree) e)
+ (var-walk (cdr tree) e))))))
+ e)
+ (list ref set)))
+
+ (define (get-side-effect v)
+ (let ((ftype (var-ftype v)))
+ (or (not (memq ftype '(define define* lambda lambda*)))
+ (let ((body (cddr (var-initial-value v)))
+ (env (var-env v))
+ (args (cons (var-name v) (args->proper-list (var-arglist v)))))
+ (let ((outvars (append (cadr (out-vars (var-name v) args body)) args)))
+ (any? (lambda (f)
+ (side-effect-with-vars? f env outvars))
+ body))))))
+
+ (define* (make-fvar name ftype arglist decl initial-value env)
+ (let* ((old (hash-table-ref other-identifiers name))
+ (new (cons name
+ (inlet 'signature ()
+ 'side-effect ()
+ 'allow-other-keys (and (pair? arglist)
+ (memq ftype '(define* define-macro* define-bacro* defmacro*))
+ (eq? (last-par arglist) :allow-other-keys))
+ 'scope ()
+ 'env env
+ 'initial-value initial-value
+ 'values (and (pair? initial-value) (count-values (cddr initial-value)))
+ 'leaves #f
+ 'match-list #f
+ 'decl decl
+ 'arglist arglist
+ 'ftype ftype
+ 'history (if old
+ (begin
+ (hash-table-set! other-identifiers name #f)
+ (if initial-value (cons initial-value old) old))
+ (if initial-value (list initial-value) ()))
+ 'set 0
+ 'ref (if old (length old) 0)))))
- (define (never-true expr)
- (or (not expr)
- (and (pair? expr)
- (eq? (car expr) 'not)
- (let ((f (never-false (cadr expr))))
- ;(format *stderr* "f: ~S~%" f)
- f))))
-
- ;; --------------------------------------------------------------------------------
-
- (define (truncated-list->string form)
- ;; return form -> string with limits on its length
- (let* ((str (object->string form))
- (len (length str)))
- (if (< len 8)
- (format #f " ~A" str)
- (if (<= len 80)
- (format #f "~% ~A" str)
- (do ((i 77 (- i 1)))
- ((or (= i 40)
- (char-whitespace? (str i)))
- (format #f "~% ~A..." (substring str 0 (if (<= i 40) 77 i)))))))))
-
- (define (lists->string f1 f2)
- ;; same but 2 strings that may need to be lined up vertically
- (let* ((str1 (object->string f1))
- (len1 (length str1))
- (str2 (object->string f2))
- (len2 (length str2)))
- (if (< (+ len1 len2) 40)
- (format #f "~A -> ~A" str1 str2)
- (if (< (+ len1 len2) 80)
- (format #f "~% ~A -> ~A" str1 str2)
- (format #f "~% ~A ->~% ~A" str1 str2)))))
-
- (define (lint-format str name . args)
- (if (and (positive? line-number)
- (< line-number 100000))
- (apply format outport (string-append " ~A (line ~D): " str "~%") name line-number args)
- (apply format outport (string-append " ~A: " str "~%") name args)))
+ (when (and *report-function-stuff*
+ (not (eq? name :lambda))
+ (memq ftype '(define lambda define* lambda*))
+ (pair? (caddr initial-value)))
+ (hash-table-set! equable-closures (caaddr initial-value)
+ (cons new (or (hash-table-ref equable-closures (caaddr initial-value)) ()))))
+ new))
+
+ (define (return-type sym e)
+ (let ((sig (arg-signature sym e)))
+ (and (pair? sig)
+ (or (eq? (car sig) 'values) ; turn it into #t for now
+ (car sig))))) ; this might be undefined in the current context (eg oscil? outside clm)
+
+ (define (any-macro? f env)
+ (or (memq f '(call-with-values let-values define-values let*-values cond-expand require quasiquote multiple-value-bind reader-cond))
+ (let ((fd (var-member f env)))
+ (and (var? fd)
+ (memq (var-ftype fd) '(define-macro define-macro* define-expansion define-bacro define-bacro* defmacro defmacro* define-syntax))))))
+
+ (define ->simple-type
+ (let ((markers (list (cons :call/exit 'continuation?)
+ (cons :call/cc 'continuation?)
+ (cons :lambda 'procedure?))))
+ (lambda (c)
+ (cond ((pair? c) 'pair?)
+ ((integer? c) 'integer?)
+ ((rational? c) 'rational?)
+ ((real? c) 'real?)
+ ((number? c) 'number?)
+ ((keyword? c)
+ (cond ((assq c markers) => cdr)
+ (else 'keyword?)))
+ ((byte-vector? c) 'byte-vector?)
+ ((string? c) 'string?)
+ ((null? c) 'null?)
+ ((char? c) 'char?)
+ ((boolean? c) 'boolean?)
+ ((float-vector? c) 'float-vector?)
+ ((int-vector? c) 'int-vector?)
+ ((vector? c) 'vector?)
+ ((let? c) 'let?)
+ ((hash-table? c) 'hash-table?)
+ ((input-port? c) 'input-port?)
+ ((output-port? c) 'output-port?)
+ ((iterator? c) 'iterator?)
+ ((continuation? c) 'continuation?)
+ ((dilambda? c) 'dilambda?)
+ ((procedure? c) 'procedure?)
+ ((macro? c) 'macro?)
+ ((random-state? c) 'random-state?)
+ ((c-pointer? c) 'c-pointer?)
+ ((c-object? c) 'c-object?)
+ ((eof-object? c) 'eof-object?)
+ ((syntax? c) 'syntax?)
+ ((eq? c #<unspecified>) 'unspecified?)
+ (#t #t)))))
+
+ (define (define->type c)
+ (and (pair? c)
+ (case (car c)
+ ((define)
+ (if (and (pair? (cdr c))
+ (pair? (cadr c)))
+ 'procedure?
+ (and (pair? (cddr c))
+ (->lint-type (caddr c)))))
+ ((define* lambda lambda* case-lambda) 'procedure?)
+ ((dilambda) 'dilambda?)
+ ((define-macro define-macro* define-bacro define-bacro* defmacro defmacro* define-expansion) 'macro?)
+ ((:call/cc :call/exit) 'continuation?)
+ (else #t))))
+
+ (define (->lint-type c)
+ (cond ((not (pair? c)) (->simple-type c))
+ ((not (symbol? (car c))) (or (pair? (car c)) 'pair?))
+ ((not (eq? (car c) 'quote)) (or (return-type (car c) ()) (define->type c)))
+ ((symbol? (cadr c)) 'symbol?)
+ (else (->simple-type (cadr c))))) ; don't look for return type!
+
+ (define (compatible? type1 type2) ; we want type1, we have type2 -- is type2 ok?
+ (or (eq? type1 type2)
+ (not (symbol? type1))
+ (not (symbol? type2))
+ (not (hash-table-ref bools1 type1))
+ (not (hash-table-ref bools1 type2))
+ (case type1
+ ((number? complex?) (memq type2 '(float? real? rational? integer? number? complex? exact? inexact? zero? negative? positive? even? odd? infinite? nan?)))
+ ((real?) (memq type2 '(float? rational? integer? complex? number? exact? inexact? zero? negative? positive? even? odd? infinite? nan?)))
+ ((zero?) (memq type2 '(float? real? rational? integer? number? complex? exact? inexact? even?)))
+ ((negative? positive?) (memq type2 '(float? real? rational? integer? complex? number? exact? inexact? even? odd? infinite? nan?)))
+ ((float?) (memq type2 '(real? complex? number? inexact? zero? negative? positive? infinite? nan?)))
+ ((rational?) (memq type2 '(integer? real? complex? number? exact? zero? negative? positive? even? odd?)))
+ ((integer?) (memq type2 '(real? rational? complex? number? exact? even? odd? zero? negative? positive?)))
+ ((odd? even?) (memq type2 '(real? rational? complex? number? exact? integer? zero? negative? positive?)))
+ ((exact?) (memq type2 '(real? rational? complex? number? integer? zero? negative? positive?)))
+ ((inexact?) (memq type2 '(real? number? complex? float? zero? negative? positive? infinite? nan?)))
+ ((infinite? nan?) (memq type2 '(real? number? complex? positive? negative? inexact? float?)))
+ ((vector?) (memq type2 '(float-vector? int-vector? sequence?)))
+ ((float-vector? int-vector?) (memq type2 '(vector? sequence?)))
+ ((sequence?) (memq type2 '(list? pair? null? proper-list? vector? float-vector? int-vector? byte-vector?
+ string? let? hash-table? c-object? iterator? procedure?))) ; procedure? for extended iterator
+ ((symbol? constant?) (memq type2 '(gensym? keyword? defined? provided? constant?)))
+ ((keyword? gensym? defined? provided?) (eq? type2 'symbol?))
+ ((list?) (memq type2 '(null? pair? proper-list? sequence?)))
+ ((proper-list?) (memq type2 '(null? pair? list? sequence?)))
+ ((pair? null?) (memq type2 '(list? proper-list? sequence?)))
+ ((dilambda?) (memq type2 '(procedure? macro? iterator?)))
+ ((procedure?) (memq type2 '(dilambda? iterator? macro? sequence?)))
+ ((macro?) (memq type2 '(dilambda? iterator? procedure?)))
+ ((iterator?) (memq type2 '(dilambda? procedure? sequence?)))
+ ((string?) (memq type2 '(byte-vector? sequence? directory? file-exists?)))
+ ((hash-table? let? c-object?)
+ (eq? type2 'sequence?))
+ ((byte-vector? directory? file-exists?)
+ (memq type2 '(string? sequence?)))
+ ((input-port? output-port?)
+ (eq? type2 'boolean?))
+ ((char? char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?)
+ (memq type2 '(char? char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?)))
+ (else #f))))
+
+ (define (any-compatible? type1 type2)
+ ;; type1 and type2 can be either a list of types or a type
+ (if (symbol? type1)
+ (if (symbol? type2)
+ (compatible? type1 type2)
+ (and (pair? type2)
+ (or (compatible? type1 (car type2))
+ (any-compatible? type1 (cdr type2)))))
+ (and (pair? type1)
+ (or (compatible? (car type1) type2)
+ (any-compatible? (cdr type1) type2)))))
+
+ (define (subsumes? type1 type2)
+ (or (eq? type1 type2)
+ (case type1
+ ((integer?) (memq type2 '(even? odd?)))
+ ((rational?) (memq type2 '(integer? exact? odd? even?)))
+ ((exact?) (memq type2 '(integer? rational?)))
+ ((real?) (memq type2 '(integer? rational? float? negative? positive? zero? odd? even?)))
+ ((complex? number?) (memq type2 '(integer? rational? float? real? complex? number? negative? positive? zero?
+ even? odd? exact? inexact? nan? infinite?)))
+ ((list?) (memq type2 '(pair? null? proper-list?)))
+ ((proper-list?) (eq? type2 'null?))
+ ((vector?) (memq type2 '(float-vector? int-vector?)))
+ ((symbol?) (memq type2 '(keyword? gensym? defined? provided? constant?)))
+ ((sequence?) (memq type2 '(list? pair? null? proper-list? vector? float-vector? int-vector? byte-vector?
+ string? let? hash-table? c-object? directory? file-exists?)))
+ ((char?) (memq type2 '(char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?)))
+ (else #f))))
+
+ (define (never-false expr)
+ (or (eq? expr #t)
+ (let ((type (if (pair? expr)
+ (and (hash-table-ref no-side-effect-functions (car expr))
+ (return-type (car expr) ()))
+ (->lint-type expr))))
+ (and (symbol? type)
+ (not (symbol? expr))
+ (not (memq type '(boolean? values)))))))
+
+ (define (never-true expr)
+ (or (not expr)
+ (and (pair? expr)
+ (eq? (car expr) 'not)
+ (pair? (cdr expr))
+ (never-false (cadr expr)))))
+
+ (define (side-effect-with-vars? form env vars)
+ ;; could evaluation of form have any side effects (like IO etc)
- (define (side-effect? form env)
- ;; could evaluation of form have any side effects (like IO etc)
-
- (if (and (proper-list? form) ; we don't want dotted lists or () here
- (not (null? form)))
- ;; can't optimize ((...)...) because the car might eval to a function
- (or (and (not (hash-table-ref no-side-effect-functions (car form))) ; if func is not in that list, make no assumptions about it
- (or (not (eq? (car form) 'format)) ; (format #f ...)
- (cadr form)))
- (case (car form)
- ((set! define define* define-macro define-macro* define-bacro define-bacro* define-constant define-expansion) #t)
-
- ((quote) #f)
-
- ((case)
- (or (not (pair? (cdr form)))
- (side-effect? (cadr form) env) ; the selector
- (letrec ((case-effect? (lambda (f e)
- (and (pair? f)
- (or (not (pair? (car f)))
- (any? (lambda (ff) (side-effect? ff e)) (cdar f))
- (case-effect? (cdr f) e))))))
- (case-effect? (cddr form) env))))
-
- ((cond)
- (letrec ((cond-effect? (lambda (f e)
- (and (pair? f)
- (or (any? (lambda (ff) (side-effect? ff e)) (car f))
- (cond-effect? (cdr f) e))))))
- (or (not (pair? (cadr form)))
- (cond-effect? (cdr form) env))))
-
- ((let let* letrec letrec*)
- (letrec ((let-effect? (lambda (f e)
- (and (pair? f)
- (or (not (pair? (car f)))
- (not (pair? (cdar f))) ; an error, reported elsewhere: (let ((x)) x)
- (side-effect? (cadar f) e)
- (let-effect? (cdr f) e))))))
- (if (symbol? (cadr form))
- (or (let-effect? (caddr form) env)
- (any? (lambda (ff) (side-effect? ff env)) (cdddr form)))
- (or (let-effect? (cadr form) env)
- (any? (lambda (ff) (side-effect? ff env)) (cddr form))))))
+ (if (or (not (proper-list? form)) ; we don't want dotted lists or () here
+ (null? form))
+
+ (and (symbol? form)
+ (let ((e (var-member form env)))
+ (if (var? e)
+ (and (symbol? (var-ftype e))
+ (var-side-effect e))
+ (and (not (hash-table-ref no-side-effect-functions form))
+ (procedure? (symbol->value form *e*))))))
+
+ ;; can't optimize ((...)...) because the car might eval to a function
+ (or (and (not (hash-table-ref no-side-effect-functions (car form)))
+ ;; if it's not in the no-side-effect table and ...
- ((do)
- (letrec ((do-effect? (lambda (f e)
- (and (pair? f)
- (or (not (pair? (car f)))
- (not (pair? (cdar f)))
- (side-effect? (cadar f) e)
- (and (pair? (cddar f))
- (side-effect? (caddar f) e))
- (do-effect? (cdr f) e))))))
- (or (< (length form) 3)
- (not (list? (cadr form)))
- (not (list? (caddr form)))
- (do-effect? (cadr form) env)
- (any? (lambda (ff) (side-effect? ff env)) (caddr form))
- (any? (lambda (ff) (side-effect? ff env)) (cdddr form)))))
-
- ;; ((lambda lambda*) (any? (lambda (ff) (side-effect? ff env)) (cddr form))) ; this is trickier than it looks
+ (let ((e (var-member (car form) env)))
+ (or (not (var? e))
+ (not (symbol? (var-ftype e)))
+ (var-side-effect e)))
+ ;; it's either not known to be a local function, or it has side-effects, and...
+
+ (or (not (eq? (car form) 'format)) ; (format #f ...)
+ (not (pair? (cdr form))) ; (format)!
+ (cadr form))
+
+ (or (null? vars)
+ (not (memq (car form) '(set!
+ ;vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! string-set! let-set!
+ ;fill! string-fill! list-fill! vector-fill!
+ ;reverse! sort!
+ define define* define-macro define-macro* define-bacro define-bacro*)))))
+ ;; it's not the common (format #f ...) special case, then...(goto case below)
+ ;; else return #t: side-effects are possible -- this is too hard to read
+
+ (case (car form)
- (else
- (or (any? (lambda (f) (side-effect? f env)) (cdr form)) ; any subform has a side-effect
- (let ((sig (procedure-signature (car form)))) ; sig has func arg and it is not known safe
- (and sig
- (memq 'procedure? (cdr sig))
- (call-with-exit
- (lambda (return)
- (for-each
- (lambda (sg arg)
- (when (eq? sg 'procedure?)
- (if (or (not (symbol? arg))
- (not (hash-table-ref no-side-effect-functions arg)))
- (return #t))))
- (cdr sig) (cdr form))
- #f))))))))
-
- (and (symbol? form)
- (not (hash-table-ref no-side-effect-functions form))
- (let ((e (or (var-member form env) (hash-table-ref globals form))))
- (and (var? e)
- (let? (var-new e)))))))
-
-
- (define (just-constants? form env)
- ;; can we probably evaluate form given just built-in stuff?
- (or (and (constant? form)
- (not (pair? form))
- (not (vector? form)))
- (and (pair? form)
- (or (and (symbol? (car form))
- (hash-table-ref no-side-effect-functions (car form))
- (not (hash-table-ref globals (car form)))
- (not (var-member (car form) env))) ; e.g. exp declared locally as a list
- (and (constant? (car form))
- (not (pair? (car form)))
- (not (vector? (car form)))))
- (just-constants? (cdr form) env))))
+ ((define-constant define-expansion) #t)
-
- (define (equal-ignoring-constants? a b)
- (or (morally-equal? a b)
- (and (symbol? a)
- (constant? a)
- (morally-equal? (symbol->value a) b))
- (and (symbol? b)
- (constant? b)
- (morally-equal? (symbol->value b) a))
- (and (pair? a)
- (pair? b)
- (equal-ignoring-constants? (car a) (car b))
- (equal-ignoring-constants? (cdr a) (cdr b)))))
+ ((define define* define-macro define-macro* define-bacro define-bacro*)
+ (null? vars))
+ ((set!
+ ;vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! string-set! let-set!
+ ;fill! string-fill! list-fill! vector-fill!
+ ;reverse! sort!
+ )
+ (or (not (pair? (cdr form)))
+ (not (symbol? (cadr form)))
+ (memq (cadr form) vars)))
+
+ ((quote) #f)
+
+ ((case)
+ (or (not (pair? (cdr form)))
+ (side-effect-with-vars? (cadr form) env vars) ; the selector
+ (let case-effect? ((f (cddr form)))
+ (and (pair? f)
+ (or (not (pair? (car f)))
+ (any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cdar f))
+ (case-effect? (cdr f)))))))
+
+ ((cond)
+ (or (not (pair? (cadr form)))
+ (let cond-effect? ((f (cdr form))
+ (e env))
+ (and (pair? f)
+ (or (and (pair? (car f))
+ (any? (lambda (ff) (side-effect-with-vars? ff e vars)) (car f)))
+ (cond-effect? (cdr f) e))))))
+
+ ((let let* letrec letrec*)
+ ;; here if the var value involves a member of vars, we have to add it to vars
+ (or (< (length form) 3)
+ (let ((syms (cadr form))
+ (body (cddr form)))
+ (when (symbol? (cadr form))
+ (set! syms (caddr form))
+ (set! body (cdddr form)))
+ (if (and (pair? vars)
+ (pair? syms))
+ (for-each (lambda (sym)
+ (when (and (pair? sym)
+ (pair? (cdr sym))
+ (tree-set-member vars (cdr sym)))
+ (set! vars (cons (car sym) vars))))
+ syms))
+ (or (let let-effect? ((f syms) (e env) (v vars))
+ (and (pair? f)
+ (or (not (pair? (car f)))
+ (not (pair? (cdar f))) ; an error, reported elsewhere: (let ((x)) x)
+ (side-effect-with-vars? (cadar f) e v)
+ (let-effect? (cdr f) e v))))
+ (any? (lambda (ff) (side-effect-with-vars? ff env vars)) body)))))
+
+ ((do)
+ (or (< (length form) 3)
+ (not (list? (cadr form)))
+ (not (list? (caddr form)))
+ (let do-effect? ((f (cadr form)) (e env))
+ (and (pair? f)
+ (or (not (pair? (car f)))
+ (not (pair? (cdar f)))
+ (side-effect-with-vars? (cadar f) e vars)
+ (and (pair? (cddar f))
+ (side-effect-with-vars? (caddar f) e vars))
+ (do-effect? (cdr f) e))))
+ (any? (lambda (ff) (side-effect-with-vars? ff env vars)) (caddr form))
+ (any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cdddr form))))
+
+ ;; ((lambda lambda*) (any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cddr form))) ; this is trickier than it looks
+
+ (else
+ (or (any? (lambda (f) (side-effect-with-vars? f env vars)) (cdr form)) ; any subform has a side-effect
+ (let ((sig (procedure-signature (car form)))) ; sig has func arg and it is not known safe
+ (and sig
+ (memq 'procedure? (cdr sig))
+ (call-with-exit
+ (lambda (return)
+ (for-each
+ (lambda (sg arg)
+ (when (and (eq? sg 'procedure?)
+ (not (and (symbol? arg)
+ (hash-table-ref no-side-effect-functions arg))))
+ (return #t)))
+ (cdr sig) (cdr form))
+ #f))))))))))
+
+
+ (define (side-effect? form env)
+ (side-effect-with-vars? form env ()))
+
+ (define (just-constants? form env)
+ ;; can we probably evaluate form given just built-in stuff?
+ ;; watch out here -- this is used later by 'if, so (defined 'hiho) should not be evalled to #f!
+ (if (not (pair? form))
+ (constant? form)
+ (and (symbol? (car form))
+ (hash-table-ref no-side-effect-functions (car form))
+ (not (var-member (car form) env)) ; e.g. exp declared locally as a list
+ (every? (lambda (p) (just-constants? p env)) (cdr form)))))
+
+ (define (equal-ignoring-constants? a b)
+ (or (morally-equal? a b)
+ (and (symbol? a)
+ (constant? a)
+ (morally-equal? (symbol->value a) b))
+ (and (symbol? b)
+ (constant? b)
+ (morally-equal? (symbol->value b) a))
+ (and (pair? a)
+ (pair? b)
+ (equal-ignoring-constants? (car a) (car b))
+ (equal-ignoring-constants? (cdr a) (cdr b)))))
+
+
+ (define (repeated-member? lst env)
+ (and (pair? lst)
+ (or (and (not (and (pair? (car lst))
+ (side-effect? (car lst) env)))
+ (pair? (cdr lst))
+ (member (car lst) (cdr lst)))
+ (repeated-member? (cdr lst) env))))
+
+ (define (update-scope v caller env)
+ (unless (or (memq caller (var-scope v))
+ (assq caller (var-scope v)))
+ (let ((cv (var-member caller env)))
+ (set! (var-scope v)
+ (cons (if (and (var? cv)
+ (memq (var-ftype cv) '(define lambda define* lambda*))) ; named-let does not define ftype
+ caller
+ (cons caller env))
+ (var-scope v))))))
+
+ (define (set-ref name caller form env)
+ ;; if name is in env, set its "I've been referenced" flag
+ (let ((data (var-member name env)))
+ (if (var? data)
+ (begin
+ (set! (var-ref data) (+ (var-ref data) 1))
+ (update-scope data caller env)
+ (if (and form (not (memq form (var-history data))))
+ (set! (var-history data) (cons form (var-history data)))))))
+ env)
+
+
+ (define (set-set name caller form env)
+ (let ((data (var-member name env)))
+ (when (var? data)
+ (set! (var-set data) (+ (var-set data) 1))
+ (update-scope data caller env)
+ (if (not (memq form (var-history data)))
+ (set! (var-history data) (cons form (var-history data))))
+ (set! (var-signature data) #f)
+ (set! (var-ftype data) #f))))
+
+
+ (define (proper-list lst)
+ ;; return lst as a proper list
+ (if (not (pair? lst))
+ lst
+ (cons (car lst)
+ (if (pair? (cdr lst))
+ (proper-list (cdr lst))
+ (if (null? (cdr lst))
+ ()
+ (list (cdr lst)))))))
+
+ (define (keywords lst)
+ (let ((count 0))
+ (do ((p lst (cdr p)))
+ ((null? p) count)
+ (if (keyword? (car p))
+ (set! count (+ count 1))))))
+ ;(count-if keyword? lst))
+
+ (define (eqv-selector clause)
+ (if (pair? clause)
+ (case (car clause)
+ ((memq memv member)
+ (and (= (length clause) 3)
+ (cadr clause)))
+ ((eq? eqv? = equal? char=? char-ci=? string=? string-ci=?)
+ (and (= (length clause) 3)
+ (if (code-constant? (cadr clause))
+ (caddr clause)
+ (cadr clause))))
+ ((or)
+ (and (pair? (cdr clause))
+ (eqv-selector (cadr clause))))
+ ((not null? eof-object? zero? boolean?)
+ (and (pair? (cdr clause))
+ (cadr clause)))
+ (else #f))
+ (memq clause '(else #t))))
+
+ (define (->eqf x)
+ (case x
+ ((char?) '(eqv? char=?))
+ ((integer? rational? real? number? complex?) '(eqv? =))
+ ((symbol? keyword? boolean? null? procedure? syntax? macro?)'(eq? eq?))
+ ((string? byte-vector?) '(equal? string=?))
+ ((pair? vector? float-vector? int-vector? hash-table?) '(equal? equal?))
+ (else
+ (if (and (pair? x)
+ (pair? (cdr x))
+ (null? (cddr x))
+ (or (and (memq 'boolean? x)
+ (or (memq 'real? x) (memq 'number? x) (memq 'integer? x)))
+ (and (memq 'eof-object? x)
+ (or (memq 'char? x) (memq 'integer? x)))))
+ '(eqv? eqv?)
+ '(#t #t)))))
+
+ (define (eqf selector env)
+ (cond ((symbol? selector)
+
+ (if (and (not (var-member selector env))
+ (or (hash-table-ref built-in-functions selector)
+ (hash-table-ref syntaces selector)))
+ '(eq? eq?)
+ '(#t #t))
+ )
+
+ ((not (pair? selector)) (->eqf (->lint-type selector)))
+ ((eq? (car selector) 'quote)
+ (cond ((or (symbol? (cadr selector))
+ (memq (cadr selector) '(#f #t #<unspecified> #<undefined> #<eof> ())))
+ '(eq? eq?))
+ ((char? (cadr selector)) '(eqv? char=?))
+ ((string? (cadr selector)) '(equal? string=?))
+ ((number? (cadr selector)) '(eqv? =))
+ (else '(equal? equal?))))
+ ((and (eq? (car selector) 'list)
+ (null? (cdr selector)))
+ '(eq? eq?))
+ ((symbol? (car selector))
+ (let ((sig (arg-signature (car selector) env)))
+ (if (pair? sig)
+ (->eqf (car sig))
+ '(#t #t))))
+ (else '(#t #t))))
+
+ (define (unquoted x)
+ (if (and (pair? x)
+ (eq? (car x) 'quote))
+ (cadr x)
+ x))
+
+ (define (distribute-quote x)
+ (map (lambda (item)
+ (if (or (symbol? item)
+ (pair? item))
+ `(quote ,item)
+ item))
+ x))
+
+ (define (focus-str str focus)
+ (let ((len (length str)))
+ (if (< len 40)
+ str
+ (let ((pos (string-position focus str))
+ (focus-len (length focus)))
+ (if (not pos)
+ str
+ (if (<= pos 20)
+ (string-append (substring str 0 (min 60 (- len 1) (+ focus-len pos 20))) " ...")
+ (string-append "... " (substring str (- pos 20) (min (- len 1) (+ focus-len pos 20))) " ...")))))))
+
+ (define (check-star-parameters f args env)
+ (if (list-any? (lambda (k) (memq k '(:key :optional))) args)
+ (let ((kw (if (memq :key args) :key :optional)))
+ (format outport "~NC~A: ~A is no longer accepted: ~A~%" lint-left-margin #\space f kw
+ (focus-str (object->string args) (symbol->string kw)))))
- (define (just-symbols? form)
- (or (null? form)
- (symbol? form)
- (and (pair? form)
- (symbol? (car form))
- (just-symbols? (cdr form)))))
-
- (define (list-any? f lst)
- (if (pair? lst)
- (or (f (car lst))
- (list-any? f (cdr lst)))
- (f lst)))
-
- (define (reversible? func)
- (memq func '(* + = char=? string=? eq? eqv? equal? morally-equal? logand logxor logior max min lcm gcd
- < > <= >=
- char<? char>? char<=? char>=?
- string<? string>? string<=? string>=?
- char-ci<? char-ci>? char-ci<=? char-ci>=?
- string-ci<? string-ci>? string-ci<=? string-ci>=?)))
-
- (define (reversed func)
- (case func
- ((<) '>) ((>) '<) ((<=) '>=) ((>=) '<=)
- ((* + = char=? string=? eq? eqv? equal? morally-equal? logand logxor logior max min lcm gcd) func)
- ((char<?) 'char>?) ((char>?) 'char<?) ((char<=?) 'char>=?) ((char>=?) 'char<=?)
- ((string<?) 'string>?) ((string>?) 'string<?) ((string<=?) 'string>=?) ((string>=?) 'string<=?)
- ((char-ci<?) 'char-ci>?) ((char-ci>?) 'char-ci<?) ((char-ci<=?) 'char-ci>=?) ((char-ci>=?) 'char-ci<=?)
- ((string-ci<?) 'string-ci>?) ((string-ci>?) 'string-ci<?) ((string-ci<=?) 'string-ci>=?) ((string-ci>=?) 'string-ci<=?)
- (else #f)))
+ (if (member 'pi args (lambda (a b) (or (eq? b 'pi) (and (pair? b) (eq? (car b) 'pi)))))
+ (format outport "~NC~A: parameter can't be a constant: ~A~%" lint-left-margin #\space f
+ (focus-str (object->string args) "pi")))
- (define (repeated-member? lst env)
- (and (pair? lst)
- (or (and (or (not (pair? (car lst)))
- (and (not (side-effect? (car lst) env))
- (not (eq? (caar lst) 'random))))
- (pair? (cdr lst))
- (member (car lst) (cdr lst)))
- (repeated-member? (cdr lst) env))))
+ (let ((r (memq :rest args)))
+ (when (pair? r)
+ (if (not (pair? (cdr r)))
+ (format outport "~NC~A: :rest parameter needs a name: ~A~%" lint-left-margin #\space f args)
+ (if (pair? (cadr r))
+ (format outport "~NC~A: :rest parameter can't specify a default value: ~A~%" lint-left-margin #\space f args)))))
- (define (check-args name head form checkers env max-arity)
- ;; check for obvious argument type problems
- ;; name = overall caller, head = current caller, checkers = proc or list of procs for checking args
-
- (define (prettify-arg-number argn)
- (if (or (not (= argn 1))
- (pair? (cddr form)))
- (format #f "~D " argn)
- ""))
-
- (define (check-checker checker at-end)
- (if (eq? checker 'integer:real?)
- (if at-end 'real? 'integer?)
- (if (eq? checker 'integer:any?)
- (or at-end 'integer?)
- checker)))
-
- (let ((arg-number 1))
+ (let ((a (memq :allow-other-keys args)))
+ (if (and (pair? a)
+ (pair? (cdr a)))
+ (format outport "~NC~A: :allow-other-keys should be at the end of the parameter list: ~A~%" lint-left-margin #\space f
+ (focus-str (object->string args) ":allow-other-keys"))))
+
+ (for-each (lambda (p)
+ (if (and (pair? p)
+ (pair? (cdr p)))
+ (lint-walk f (cadr p) env)))
+ args))
+
+ (define (checked-eval form)
+ (and (not (infinite? (length form)))
+ (catch #t
+ (lambda ()
+ (eval (copy form :readable)))
+ (lambda args
+ #t)))) ; just ignore errors in this context
+
+ (define (return-type-ok? type ret)
+ (or (eq? type ret)
+ (and (pair? ret)
+ (memq type ret))))
+
+
+ (define relsub
+ (let ((relops '((< <= > number?) (<= < >= number?) (> >= < number?) (>= > <= number?)
+ (char<? char<=? char>? char?) (char<=? char<? char>=? char?) ; these never happen
+ (char>? char>=? char<? char?) (char>=? char>? char<=? char?)
+ (string<? string<=? string>? string?) (string<=? string<? string>=? string?)
+ (string>? string>=? string<? string?) (string>=? string>? string<=? string?))))
+ (lambda (A B rel-op env)
(call-with-exit
- (lambda (done)
- (for-each
- (lambda (arg)
- (let ((checker (check-checker (if (list? checkers) (car checkers) checkers) (= arg-number (length (cdr form))))))
- ;(format *stderr* "check-arg ~A check ~S via ~S~%" head arg checker)
- (when (or (pair? checker)
- (symbol? checker)) ; otherwise ignore type check on this argument (#t -> anything goes)
- (if (pair? arg) ; arg is expr -- try to guess its type
- (if (eq? (car arg) 'quote) ; '1 -> 1
-
- ;; arg is quoted expression
- (if (not (any-compatible? checker (if (pair? (cadr arg)) 'list? (->type (cadr arg)))))
- (lint-format "~A's argument ~Ashould be a~A ~A: ~S: ~A"
- name head
- (prettify-arg-number arg-number)
- (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
- checker arg
- (truncated-list->string form)))
-
- ;; arg is an evaluated expression
- (let ((op (return-type (car arg))))
- ;; checker is arg-type, op is expression type (can also be a pair)
- (unless (memq op '(#t #f values))
-
- (if (or (not (any-compatible? checker op))
- (and (just-constants? arg env) ; try to eval the arg
- (catch #t
- (lambda ()
- (not (any-checker? checker (eval arg))))
- (lambda ignore-catch-error-args
- #f))))
- (lint-format "~A's argument ~Ashould be a~A ~A: ~S: ~A"
- name head
- (prettify-arg-number arg-number)
- (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
- checker arg
- (truncated-list->string form))))))
- ;; arg is not a pair
- (if (and (not (symbol? arg))
- (not (any-checker? checker arg)))
- (lint-format "~A's argument ~Ashould be a~A ~A: ~S: ~A"
- name head
- (prettify-arg-number arg-number)
- (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
- checker arg
- (truncated-list->string form)))))
-
- (if (list? checkers)
- (if (null? (cdr checkers))
- (done)
- (set! checkers (cdr checkers))))
- (set! arg-number (+ arg-number 1))
- (if (> arg-number max-arity) (done))))
- (cdr form))))))
-
-
- (define (set-ref? name env)
- ;; if name is in env, set its "I've been referenced" flag
- (let ((data (or (var-member name env) (hash-table-ref globals name))))
- (when (var? data)
- (set! (var-ref data) #t)))
- env)
+ (lambda (return)
+ (when (and (pair? A)
+ (pair? B)
+ (= (length A) (length B) 3))
+ (let ((Adata (assq (car A) relops))
+ (Bdata (assq (car B) relops)))
+ (when (and Adata Bdata)
+ (let ((op1 (car A))
+ (op2 (car B))
+ (A1 (cadr A))
+ (A2 (caddr A))
+ (B1 (cadr B))
+ (B2 (caddr B)))
+ (let ((x (if (and (not (number? A1))
+ (member A1 B))
+ A1
+ (and (not (number? A2))
+ (member A2 B)
+ A2))))
+ (when x
+ (let ((c1 (if (eq? x A1) A2 A1))
+ (c2 (if (eq? x B1) B2 B1))
+ (type (cadddr Adata)))
+ (if (or (side-effect? c1 env)
+ (side-effect? c2 env)
+ (side-effect? x env))
+ (return 'ok))
+ (if (eq? x A2) (set! op1 (caddr Adata)))
+ (if (eq? x B2) (set! op2 (caddr Bdata)))
+
+ (let ((typer #f)
+ (gtes #f)
+ (gts #f)
+ (eqop #f))
+ (case type
+ ((number?)
+ (set! typer number?)
+ (set! gtes '(>= <=))
+ (set! gts '(< >))
+ (set! eqop '=))
+ ((char?)
+ (set! typer char?)
+ (set! gtes '(char>=? char<=?))
+ (set! gts '(char<? char>?))
+ (set! eqop 'char=?))
+ ((string?)
+ (set! typer string?)
+ (set! gtes '(string>=? string<=?))
+ (set! gts '(string<? string>?))
+ (set! eqop 'string=?)))
+
+ (case rel-op
+ ((and)
+ (cond ((equal? c1 c2)
+ (cond ((eq? op1 op2)
+ (return `(,op1 ,x ,c1)))
+
+ ((eq? op2 (cadr (assq op1 relops)))
+ (if (memq op2 gtes)
+ (return `(,op1 ,x ,c1))
+ (return `(,op2 ,x ,c1))))
+
+ ((and (memq op1 gtes)
+ (memq op2 gtes))
+ (return `(,eqop ,x ,c1)))
+
+ (else (return #f))))
+
+ ((and (typer c1)
+ (typer c2))
+ (cond ((or (eq? op1 op2)
+ (eq? op2 (cadr (assq op1 relops))))
+ (if ((symbol->value op1) c1 c2)
+ (return `(,op1 ,x ,c1))
+ (return `(,op2 ,x ,c2))))
+ ((eq? op1 (caddr (assq op2 relops)))
+ (if ((symbol->value op1) c2 c1)
+ (return `(,op1 ,c2 ,x ,c1))
+ (if (memq op1 gts)
+ (return #f))))
+ ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
+ ((symbol->value op1) c1 c2))
+ (return #f))))))
+
+ ((or)
+ (cond ((equal? c1 c2)
+ (cond ((eq? op1 op2)
+ (return `(,op1 ,x ,c1)))
+
+ ((eq? op2 (cadr (assq op1 relops)))
+ (if (memq op2 gtes)
+ (return `(,op2 ,x ,c1))
+ (return `(,op1 ,x ,c1))))
+
+ ((and (memq op1 gts)
+ (memq op2 gts))
+ (return `(not (,eqop ,x ,c1))))
+
+ (else (return #t))))
+
+ ((and (typer c1)
+ (typer c2))
+ (cond ((or (eq? op1 op2)
+ (eq? op2 (cadr (assq op1 relops))))
+ (if ((symbol->value op1) c1 c2)
+ (return `(,op2 ,x ,c2))
+ (return `(,op1 ,x ,c1))))
+ ((eq? op1 (caddr (assq op2 relops)))
+ (if ((symbol->value op1) c2 c1)
+ (return #t))
+ (return `(not (,(cadr (assq op1 relops)) ,c1 ,x ,c2))))
+ ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
+ ((symbol->value op1) c2 c1))
+ (return #t)))))))))))))))
+ 'ok)))))
+
+
+ (define simplify-boolean
+ (let ((notables (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h (car op)) (cadr op)))
+ '((< >=) (> <=) (<= >) (>= <)
+ (char<? char>=?) (char>? char<=?) (char<=? char>?) (char>=? char<?)
+ (string<? string>=?) (string>? string<=?) (string<=? string>?) (string>=? string<?)
+ (char-ci<? char-ci>=?) (char-ci>? char-ci<=?) (char-ci<=? char-ci>?) (char-ci>=? char-ci<?)
+ (string-ci<? string-ci>=?) (string-ci>? string-ci<=?) (string-ci<=? string-ci>?) (string-ci>=? string-ci<?)
+ (odd? even?) (even? odd?) (exact? inexact?) (inexact? exact?)))
+ h)))
+ (lambda (in-form true false env)
- (define (set-set? name new-val env)
- ;; TODO: if (set! func val) need to either clear func info or fix it up
-
- (let ((data (or (var-member name env) (hash-table-ref globals name))))
- (when (var? data)
- (set! (var-value data) new-val)
- (set! (var-new data) #f) ; a stopgap
- (set! (var-set data) #t))))
+ (define (classify e)
+ (if (not (just-constants? e env))
+ e
+ (catch #t
+ (lambda ()
+ (let ((val (eval e)))
+ (if (boolean? val)
+ val
+ e)))
+ (lambda ignore e))))
- (define (proper-list lst)
- ;; return lst as a proper list
- (if (pair? lst)
- (cons (car lst)
- (if (pair? (cdr lst))
- (proper-list (cdr lst))
- (if (null? (cdr lst))
- ()
- (list (cdr lst)))))
- lst))
-
+ (define (contradictory? ands)
+ (let ((vars ()))
+ (call-with-exit
+ (lambda (return)
+ (do ((b ands (cdr b)))
+ ((null? b) #f)
+ (if (and (pair? b)
+ (pair? (car b))
+ (pair? (cdar b)))
+ (let ((func (caar b))
+ (args (cdar b)))
+
+ (if (memq func '(eq? eqv? equal?))
+ (if (and (symbol? (car args))
+ (code-constant? (cadr args)))
+ (set! func (->lint-type (cadr args)))
+ (if (and (symbol? (cadr args))
+ (code-constant? (car args)))
+ (set! func (->lint-type (car args))))))
+
+ (if (symbol? func)
+ (for-each
+ (lambda (arg)
+ (if (symbol? arg)
+ (let ((type (assq arg vars)))
+ (if (not type)
+ (set! vars (cons (cons arg func) vars))
+ (if (not (compatible? (cdr type) func))
+ (return #t))))))
+ args)))))))))
- (define (keywords lst)
- (let ((count 0))
- (do ((p lst (cdr p)))
- ((null? p) count)
- (if (keyword? (car p))
- (set! count (+ count 1))))))
- ;(count-if keyword? lst))
+ (define (and-redundant? arg1 arg2)
+ (let ((type1 (car arg1))
+ (type2 (car arg2)))
+ (and (symbol? type1)
+ (symbol? type2)
+ (hash-table-ref bools1 type1)
+ (or (hash-table-ref bools1 type2) ; return #f if not (obviously) redundant, else return which of the two to keep
+ (memq type2 '(= char=? string=? not eq?)))
+ (if (eq? type1 type2)
+ type1
+ (case type1
+ ((number? complex?)
+ (case type2
+ ((float? real? rational? integer?) type2)
+ ((number? complex?) type1)
+ ((=) (let ((x (if (number? (caddr arg2))
+ (caddr arg2)
+ (cadr arg2))))
+ (and (number? x)
+ (if (= x (floor x)) 'memv 'eqv?))))
+ (else #f)))
+
+ ((real?)
+ (case type2
+ ((float? rational? integer?) type2)
+ ((number? complex?) type1)
+ ((=) (let ((x (if (real? (caddr arg2))
+ (caddr arg2)
+ (cadr arg2))))
+ (and (real? x)
+ (if (= x (floor x)) 'memv 'eqv?))))
+ (else #f)))
+
+ ((float?)
+ (and (memq type2 '(real? complex? number? inexact?)) type1))
+
+ ((rational?)
+ (case type2
+ ((integer?) type2)
+ ((real? complex? number? exact?) type1)
+ ((=)
+ (and (or (rational? (caddr arg2))
+ (rational? (cadr arg2)))
+ 'eqv?))
+ (else #f)))
+
+ ((integer?)
+ (case type2
+ ((real? rational? complex? number? exact?) type1)
+ ((=)
+ (and (or (integer? (caddr arg2))
+ (integer? (cadr arg2)))
+ 'eqv?))
+ (else #f)))
+
+ ((exact?)
+ (and (memq type2 '(rational? integer?)) type2))
+
+ ((even? odd?)
+ (and (memq type2 '(integer? rational? real? complex? number?)) type1)) ; not zero? -> 0.0
+
+ ((zero?)
+ (and (memq type2 '(complex? number? real?)) type1))
+
+ ((negative? positive?)
+ (and (eq? type2 'real?) type1))
+
+ ((inexact?)
+ (and (eq? type2 'float?) type2))
+
+ ((infinite? nan?)
+ (and (memq type2 '(number? complex? inexact?)) type1))
+
+ ((vector?)
+ (and (memq type2 '(float-vector? int-vector?)) type2))
+
+ ((float-vector? int-vector?)
+ (and (eq? type2 'vector?) type1))
+
+ ((symbol?)
+ (case type2
+ ((keyword? gensym? constant?) type2)
+ ((eq?)
+ (and (or (quoted-symbol? (cadr arg2))
+ (quoted-symbol? (caddr arg2)))
+ 'eq?))
+ (else #f)))
+
+ ((keyword?)
+ (case type2
+ ((symbol? constant?) type1)
+ ((eq?)
+ (and (or (keyword? (cadr arg2))
+ (keyword? (caddr arg2)))
+ 'eq?))
+ (else #f)))
+
+ ((gensym? defined? provided? constant?)
+ (and (eq? type2 'symbol?) type1))
+
+ ((boolean?)
+ (and (or (eq? type2 'not)
+ (and (eq? type2 'eq?)
+ (or (boolean? (cadr arg2))
+ (boolean? (caddr arg2)))))
+
+ type2))
+
+ ((list?)
+ (and (memq type2 '(null? pair? proper-list?)) type2))
+
+ ((null?)
+ (and (memq type2 '(list? proper-list?)) type1))
+
+ ((pair?)
+ (and (eq? type2 'list?) type1))
+
+ ((proper-list?)
+ (and (eq? type2 'null?) type2))
+
+ ((string?)
+ (case type2
+ ((byte-vector?) type2)
+ ((string=?)
+ (and (or (eq? (->lint-type (cadr arg2)) 'string?)
+ (eq? (->lint-type (caddr arg2)) 'string?))
+ 'equal?))
+ (else #f)))
+
+ ((char?)
+ (and (eq? type2 'char=?)
+ (or (eq? (->lint-type (cadr arg2)) 'char?)
+ (eq? (->lint-type (caddr arg2)) 'char?))
+ 'eqv?))
+
+ ((char-numeric? char-whitespace? char-alphabetic? char-upper-case? char-lower-case?)
+ (and (eq? type2 'char?) type1))
+
+ ((byte-vector? directory? file-exists?)
+ (and (eq? type2 'string?) type1))
+
+ (else #f))))))
+
+ (define (and-redundants env . args)
+ (let ((locals ())
+ (diffs #f))
+ (do ((p args (cdr p)))
+ ((or (null? p)
+ (not (and (pair? (car p))
+ (pair? (cdar p))
+ (hash-table-ref bools1 (caar p)))))
+ (and (null? p)
+ (pair? locals)
+ (or diffs
+ (any? (lambda (a) (pair? (cddr a))) locals))
+ (let ((keepers ()))
+ (for-each (lambda (a)
+ (cond ((null? (cddr a))
+ (set! keepers (cons (cadr a) keepers)))
+
+ ((null? (cdddr a))
+ (let ((res (apply and-redundant? (reverse (cdr a)))))
+ (if res
+ (begin
+ (set! keepers (cons (if (eq? res (caadr a)) (cadr a) (caddr a)) keepers))
+ (set! diffs #t))
+ (set! keepers (cons (cadr a) (cons (caddr a) keepers))))))
+
+ (else
+ (let ((ar (reverse (cdr a))))
+ (let ((res1 (and-redundant? (car ar) (cadr ar))) ; if res1 either 1 or 2 is out
+ (res2 (and-redundant? (cadr ar) (caddr ar))) ; if res2 either 2 or 3 is out
+ (res3 (and-redundant? (car ar) (caddr ar)))) ; if res3 either 1 or 3 is out
+ ;; only in numbers can 3 actually be reducible
+ (if (not (or res1 res2 res3))
+ (set! keepers (append (cdr a) keepers))
+ (begin
+ (set! diffs #t)
+ (if (and (or (not res1)
+ (eq? res1 (caar ar)))
+ (or (not res3)
+ (eq? res3 (caar ar))))
+ (set! keepers (cons (car ar) keepers)))
+ (if (and (or (not res1)
+ (eq? res1 (caadr ar)))
+ (or (not res2)
+ (eq? res2 (caadr ar))))
+ (set! keepers (cons (cadr ar) keepers)))
+ (if (and (or (not res2)
+ (eq? res2 (car (caddr ar))))
+ (or (not res3)
+ (eq? res3 (car (caddr ar)))))
+ (set! keepers (cons (caddr ar) keepers)))
+ (if (pair? (cdddr ar))
+ (set! keepers (append (reverse (cdddr ar)) keepers))))))))))
+ (reverse locals))
+ (and diffs (reverse keepers)))))
+ (let* ((bool (car p))
+ (local (assoc (cadr bool) locals)))
+ (if (pair? local)
+ (if (member bool (cdr local))
+ (set! diffs #t)
+ (set-cdr! local (cons bool (cdr local))))
+ (set! locals (cons (list (cadr bool) bool) locals)))))))
- (define (check-star-parameters name args)
- (if (list-any? (lambda (k) (memq k '(:key :optional))) args)
- (lint-format ":optional and key are no longer accepted: ~A" name args))
- (let ((r (memq :rest args)))
- (if (and (pair? r)
- (null? (cdr r)))
- (lint-format ":rest parameter needs a name: ~A" name args)))
- (let ((a (memq :allow-other-keys args)))
- (if (and (pair? a)
- (pair? (cdr a)))
- (lint-format ":allow-other-keys should be at the end of the parameter list: ~A" name args))))
-
- (define (tree-member sym tree)
- (and (pair? tree)
- (or (eq? (car tree) sym)
- (and (pair? (car tree))
- (tree-member sym (car tree)))
- (tree-member sym (cdr tree)))))
- (define (tree-car-member sym tree)
- (and (pair? tree)
- (or (eq? (car tree) sym)
- (and (pair? (car tree))
- (tree-car-member sym (car tree)))
- (and (pair? (cdr tree))
- (member sym (cdr tree) tree-car-member)))))
+ (define (and-not-redundant arg1 arg2)
+ (let ((type1 (car arg1)) ; (? ...)
+ (type2 (caadr arg2))) ; (not (? ...))
+ (and (symbol? type1)
+ (symbol? type2)
+ (or (hash-table-ref bools1 type1)
+ (memq type1 '(= char=? string=?)))
+ (hash-table-ref bools1 type2)
+ (if (eq? type1 type2) ; (and (?) (not (?))) -> #f
+ 'contradictory
+ (case type1
+ ((pair?)
+ (case type2
+ ((list?) 'contradictory)
+ ((proper-list?) #f)
+ (else arg1)))
+
+ ((null?)
+ (if (eq? type2 'list?)
+ 'contradictory
+ arg1))
+
+ ((list?)
+ (case type2
+ ((pair?) 'null?)
+ ((null?) 'pair?)
+ ((proper-list?) #f)
+ (else arg1)))
+
+ ((proper-list?)
+ (case type2
+ ((list? pair?) 'contradictory)
+ ((null?) #f)
+ (else arg1)))
+
+ ((symbol?)
+ (and (not (memq type2 '(keyword? gensym? constant?)))
+ arg1))
+
+ ((constant?)
+ (and (eq? type2 'symbol?)
+ 'contradictory))
+
+ ((char=?)
+ (if (eq? type2 'char?)
+ 'contradictory
+ (and (or (char? (cadr arg1))
+ (char? (caddr arg1)))
+ `(eqv? ,@(cdr arg1))))) ; arg2 might be (not (eof-object?...))
+
+ ((real?)
+ (case type2
+ ((rational? exact?) `(float? ,@(cdr arg1)))
+ ((inexact?) `(rational? ,@(cdr arg1)))
+ ((complex? number?) 'contradictory)
+ ((negative? positive? even? odd? zero? integer?) #f)
+ (else arg1)))
+
+ ((integer?)
+ (case type2
+ ((real? complex? number? rational? exact?) 'contradictory)
+ ((float? inexact? infinite? nan?) arg1)
+ (else #f)))
+
+ ((rational?)
+ (case type2
+ ((real? complex? number? exact?) 'contradictory)
+ ((float? inexact? infinite? nan?) arg1)
+ (else #f)))
+
+ ((complex? number?)
+ (and (memq type2 '(complex? number?))
+ 'contradictory))
+
+ ((float?)
+ (case type2
+ ((real? complex? number? inexact?) 'contradictory)
+ ((rational? integer? exact?) arg1)
+ (else #f)))
+
+ ((exact?)
+ (case type2
+ ((rational?) 'contradictory)
+ ((inexact? infinite? nan?) arg1)
+ (else #f)))
+
+ ((even? odd?)
+ (case type2
+ ((integer? exact? rational? real? number? complex?) 'contradictory)
+ ((infinite? nan?) arg1)
+ (else #f)))
+
+ ((zero? negative? positive?)
+ (and (memq type2 '(complex? number? real?))
+ 'contradictory))
+
+ ((infinite? nan?)
+ (case type2
+ ((number? complex? inexact?) 'contradictory)
+ ((integer? rational? exact? even? odd?) arg1)
+ (else #f)))
+
+ ((char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?)
+ (and (eq? type2 'char?)
+ 'contradictory))
+
+ ((directory? file-exists?)
+ (and (memq type2 '(string? sequence?))
+ 'contradictory))
+
+ (else
+ ;; none of the rest happen
+ #f))))))
- (define (remove item sequence)
- (let ((got-it #f))
- (map (lambda (x)
- (if (and (not got-it)
- (equal? x item))
- (begin
- (set! got-it #t)
- (values))
- x))
- sequence)))
+ (define (or-not-redundant arg1 arg2)
+ (let ((type1 (car arg1)) ; (? ...)
+ (type2 (caadr arg2))) ; (not (? ...))
+ (and (symbol? type1)
+ (symbol? type2)
+ (or (hash-table-ref bools type1)
+ (memq type1 '(= char=? string=?)))
+ (hash-table-ref bools type2)
+ (if (eq? type1 type2) ; (or (?) (not (?))) -> #t
+ 'fatuous
+ (case type1
+ ((null?)
+ (case type2
+ ((list?) ; not proper-list? here
+ `(not (pair? ,(cadr arg1))))
+ ((proper-list?) #f)
+ (else arg2)))
+ ((eof-object?)
+ arg2) ; not keyword? here because (or (not (symbol? x)) (keyword? x)) is not reducible to (not (symbol? x))
+ ((string?)
+ (and (not (eq? type2 'byte-vector?)) arg2))
+ (else #f))))))
- (define (remove-all item sequence)
- (map (lambda (x)
- (if (equal? x item)
- (values)
- x))
- sequence))
+ (define (bsimp x) ; quick check for common easy cases
+ (set! last-simplify-boolean-line-number line-number)
+ (if (not (and (pair? x)
+ (pair? (cdr x))))
+ x
+ (case (car x)
+ ((and) (and (cadr x) ; (and #f ...) -> #f
+ x))
+ ((or) (if (and (cadr x) ; (or #t ...) -> #t
+ (code-constant? (cadr x)))
+ (cadr x)
+ x))
+ (else
+ (if (not (and (= (length x) 2)
+ (pair? (cadr x))
+ (symbol? (caadr x))))
+ x
+ (let ((rt (if (eq? (caadr x) 'quote)
+ (->simple-type (cadadr x))
+ (return-type (caadr x) env)))
+ (head (car x)))
+ (or (and (subsumes? head rt) #t) ; don't return the memq list!
+ (and (or (memq rt '(#t #f values))
+ (any-compatible? head rt))
+ (case head
+ ((null?) (if (eq? (caadr x) 'list)
+ (null? (cdadr x))
+ x))
+ ((pair?) (if (eq? (caadr x) 'list)
+ (pair? (cdadr x))
+ x))
+ ((negative?) (and (not (hash-table-ref non-negative-ops (caadr x)))
+ x))
+ (else x))))))))))
- (define (remove-if p l)
- (cond ((null? l) ())
- ((p (car l)) (remove-if p (cdr l)))
- (else (cons (car l)
- (remove-if p (cdr l))))))
-
- (define (checked-eval form)
- (catch #t
- (lambda ()
- (eval (copy-tree form)))
- (lambda args
- #t))) ; just ignore errors in this context
-
- (define (return-type-ok? type ret)
- (or (eq? type ret)
- (and (pair? ret)
- (memq type ret))))
-
-
- (define (simplify-boolean in-form true false env)
- ;; (or)->#f, (or x) -> x, (or x ... from here on we know x is #f), (or x #t...) -> (or x #t), any constant expr can be collapsed
- ;; (or ... (or ...) ...) -> or of all, (or ... #f ...) toss the #f
- ;; similarly for and
- ;; (or ... (not (and ...))) -> (or ... (not x) [from here we know x is true] (not y)...)
- ;; (or ... (not (and x1 x2 ...))) -> (or ... (not x1) (not x2)...), but is that simpler?
-
- ;; (or x1 x2 x1) -> (or x1 x2)
- ;; (and x1 x2 x1) -> (and x2 x1)
-
- (define (bsimp uform)
- ;; find and remove any expressions that have no effect on the outcome
- (if (or (not (pair? uform))
- (not (memq (car uform) '(and or not)))
- (side-effect? uform env))
- uform
-
- (let ((vars ())
- (associated-exprs ())
- (ctr 0))
-
- (define (tree-remove-all x lst)
- (cond ((null? lst) ())
- ((equal? (car lst) x) (tree-remove-all x (cdr lst)))
- ((pair? (car lst)) (cons (tree-remove-all x (car lst)) (tree-remove-all x (cdr lst))))
- (else (cons (car lst) (tree-remove-all x (cdr lst))))))
-
- (define (canonical-tree lst)
- (let ((data (assoc lst associated-exprs)))
- (if data
- (cdr data)
- (if (pair? lst)
- (cons (canonical-tree (car lst))
- (canonical-tree (cdr lst)))
- lst))))
+ (define (bcomp x) ; not so quick...
+ (cond ((not (pair? x))
+ x)
+
+ ((eq? (car x) 'and)
+ (call-with-exit
+ (lambda (return)
+ (let ((newx (list 'and)))
+ (do ((p (cdr x) (cdr p))
+ (sidex newx)
+ (endx newx))
+ ((null? p) newx)
+ (let ((next (car p)))
+ (if (or (not next) ; #f in and -> end of expr
+ (member next false))
+ (if (eq? sidex newx) ; no side-effects
+ (return #f)
+ (begin
+ (set-cdr! endx (list #f))
+ (return newx)))
+ (if (or (code-constant? next) ; (and ... true-expr ...)
+ (member next sidex) ; if a member, and no side-effects since, it must be true
+ (member next true))
+ (if (and (null? (cdr p))
+ (not (equal? next (car endx))))
+ (set-cdr! endx (list next)))
+ (begin
+ (set-cdr! endx (list next))
+ (set! endx (cdr endx))
+ (if (side-effect? next env)
+ (set! sidex endx)))))))))))
- (define (expand expr)
- (define (car-rassoc val lst)
- (and (pair? lst)
- (if (equal? (cdar lst) val)
- (car lst)
- (car-rassoc val (cdr lst)))))
- (let ((data (car-rassoc expr associated-exprs)))
- (if data
- (copy (car data))
- (if (pair? expr)
- (cons (expand (car expr))
- (expand (cdr expr)))
- expr))))
+ ((not (eq? (car x) 'or))
+ x)
+
+ (else
+ (call-with-exit
+ (lambda (return)
+ (let ((newx (list 'or)))
+ (do ((p (cdr x) (cdr p))
+ (sidex newx)
+ (endx newx))
+ ((null? p) newx)
+ (let ((next (car p)))
+ (if (or (and next ; (or ... #t ...)
+ (code-constant? next))
+ (member next true))
+ (begin
+ (set-cdr! endx (list next))
+ (return newx)) ; we're done since this is true
+ (if (or (not next)
+ (member next sidex) ; so its false in some way
+ (member next false))
+ (if (and (null? (cdr p))
+ (not (equal? next (car endx))))
+ (set-cdr! endx (list next)))
+ (begin
+ (set-cdr! endx (list next))
+ (set! endx (cdr endx))
+ (if (side-effect? next env)
+ (set! sidex endx)))))))))))))
+
+ (define (gather-or-eqf-elements eqfnc sym vals)
+ (let* ((func (case eqfnc
+ ((eq?) 'memq)
+ ((eqv? char=?) 'memv)
+ (else 'member)))
+ (equals (if (and (eq? func 'member)
+ (not (eq? eqfnc 'equal?)))
+ (list eqfnc)
+ ()))
+ (elements (lint-remove-duplicates (map (lambda (v)
+ (if (pair? v) ; quoted case
+ (cadr v) ; so unquote for quoted list below
+ v))
+ vals)
+ env)))
+ (cond ((null? (cdr elements))
+ `(,eqfnc ,sym , at elements))
- (define (bool-walk form func)
- (if (and (pair? form)
- (memq (car form) '(and or not)))
- (for-each
- (lambda (e)
- (bool-walk e func))
- (cdr form))
- (func form)))
+ ((and (eq? eqfnc 'char=?)
+ (= (length elements) 2)
+ (char-ci=? (car elements) (cadr elements)))
+ `(char-ci=? ,sym ,(car elements)))
- (bool-walk uform (lambda (val)
- (if (and (or (pair? val)
- (symbol? val))
- (not (assoc val associated-exprs))
- (not (memq val '(and or not)))) ; (not not)
- (let ((new-var (string->symbol (format #f "bool-~D" ctr))))
- (set! vars (cons new-var vars))
- (set! associated-exprs (cons (cons val new-var) associated-exprs))
- (set! ctr (+ ctr 1))))))
+ ((and (eq? eqfnc 'string=?)
+ (= (length elements) 2)
+ (string-ci=? (car elements) (cadr elements)))
+ `(string-ci=? ,sym ,(car elements)))
- (if (or (null? vars)
- (> (length vars) 8))
- uform
- (let ((len (length vars)))
- (let ((vsize (expt 2 len))) ; 2^n possible cases
- (let ((v (make-vector vsize))
- (vals ())
- (nonf (make-vector len))
- (cur 0)
- (ctr 0)
- (form (canonical-tree uform)))
- ;; (and (real? mag) (real? ang)) -> (and bool-0 bool-1)
- ;; (not off) -> (not bool-0)
- ;; (or din (sqrt 2.0)) -> (or bool-0 bool-1)
-
- (for-each
- (lambda (var)
- (do ((i cur (+ i 1)))
- ((not (tree-member i form)) ; tree-member uses eq? (should use = for this?)
- (set! cur (+ i 1))
- (vector-set! nonf ctr i)
- (set! ctr (+ ctr 1)))))
- vars)
-
- (catch #t
- (lambda ()
- (let ((new-func (apply lambda vars form ())))
- (do ((ctr 0 (+ ctr 1)))
- ((= ctr vsize))
- (vector-set! v ctr (apply new-func (let ((args ()))
- (do ((i 0 (+ i 1)))
- ((= i len) (reverse args))
- (set! args (cons (and (logbit? ctr i)
- (vector-ref nonf i))
- args))))))
- (if (not (member (vector-ref v ctr) vals))
- (set! vals (cons (vector-ref v ctr) vals))))))
- (lambda args 'error))
-
- (if (= (length vals) 1)
- (car vals)
- (let ((none-vars ())
- (pos -1))
- (for-each
- (lambda (var)
- (set! pos (+ pos 1))
- (call-with-exit
- (lambda (return)
- (do ((ctr 0 (+ ctr 1)))
- ((= ctr vsize)
- (set! none-vars (cons var none-vars)))
- (if (and (not (logbit? ctr pos))
- (not (equal? (vector-ref v ctr) (vector-ref v (logior ctr (ash 1 pos))))))
- (return #f))))))
- vars)
-
- (if (pair? none-vars)
- (begin
- (for-each
- (lambda (nv)
- (set! form (tree-remove-all nv form)))
- none-vars)
- (expand form))
- uform))))))))))
-
- (define (true? e)
- (or (member e true)
- (and (pair? e)
- (= (length e) 2)
- (or (member e true
- (lambda (a b)
- ;; if a follows b, and b is true, do we know already know that a?
- ;; (and (< x1 12) (real? x1) (= x1 1)) -> (and (< x1 12) (= x1 1))
- (and (pair? b)
- (or (and (= (length b) 2)
- (equal? (cadr a) (cadr b))
- (case (car a)
- ((complex?) (memq (car b) '(number? real? rational? integer? even? odd?
- positive? negative? zero? exact? inexact?)))
- ((number?) (memq (car b) '(complex? real? rational? integer? even? odd?
- positive? negative? zero? exact? inexact?)))
- ((real?) (memq (car b) '(rational? integer? even? odd? positive? negative? exact? inexact?)))
- ((rational?) (memq (car b) '(integer? even? odd?)))
- ((integer?) (memq (car b) '(even? odd?)))
- (else #f)))
- (and (> (length b) 2)
- (member (cadr a) (cdr b))
- (case (car a)
- ((complex? number?) (eq? (car b) '=))
- ((real?) (memq (car b) '(< > <= >=)))
- (else #f)))))))
- (and (pair? (cadr e))
- (memq (car e) bools)
- (memq (return-type (caadr e)) bools)
- (subsumes? (car e) (return-type (caadr e))))))))
-
- (define (false? e)
-
- (define (bad-arg-match a b)
-
- ;; these accept only the given type and can return a boolean (so their value in a boolean expression is not known in advance)
- (define (number-op? x) (memq x '(= < > <= >= even? odd? positive? negative? zero?)))
- (define (char-op? x) (memq x '(char=? char<? char<=? char>? char>=? char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
- char-alphabetic? char-numeric? char-whitespace? char-lower-case? char-upper-case?)))
- (define (list-op? x) (memq x '(caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr
- cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar
- cddddr cdddr cddr cdr list-ref)))
- (define (string-op? x) (memq x '(string=? string<? string<=? string>? string>=? string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?)))
-
- (case a
- ((complex? number? real? rational? integer?)
- (or (char-op? b) ; that is, if these are false, then a non-number was accepted
- (list-op? b) ; earlier as a valid argument, so it can't be a number
- (string-op? b))) ; (or (char=? x1 #\a) (complex? x1) x1) -> (or (char=? x1 #\a) x1)
- ((char?)
- (or (number-op? b)
- (list-op? b)
- (string-op? b)))
- ((string?)
- (or (char-op? b)
- (list-op? b)
- (number-op? b)))
- ((list?)
- (or (char-op? b)
- (number-op? b)
- (string-op? b)))
- ((boolean? procedure? symbol? continuation? let?)
- (or (char-op? b)
- (number-op? b)
- (list-op? b)
- (string-op? b)))
- (else #f)))
-
- (or (member e false)
- (and (pair? e)
- (= (length e) 2)
- (or (member e false (lambda (a b)
- (and (pair? b)
- (>= (length b) 2)
- (member (cadr a) (cdr b))
- (bad-arg-match (car a) (car b)))))
- (member e true (lambda (a b)
- (and (pair? b)
- (>= (length b) 2)
- (member (cadr a) (cdr b))
- (bad-arg-match (car a) (car b)))))
- (and (pair? (cadr e))
- (memq (car e) bools)
- (memq (return-type (caadr e)) bools)
- (not (any-compatible? (car e) (return-type (caadr e)))))))))
-
- (define (contradictory? ands)
- (let ((vars ()))
- (call-with-exit
- (lambda (return)
- (do ((b ands (cdr b)))
- ((null? b) #f)
- (if (and (pair? b)
- (pair? (car b))
- (pair? (cdar b)))
- (let* ((func (caar b))
- (arg-type func)
- (args (cdar b)))
- (if (symbol? arg-type)
- (for-each
- (lambda (arg)
- (if (symbol? arg)
- (let ((type (assq arg vars)))
- (if (not type)
- (set! vars (cons (cons arg arg-type) vars))
- (if (not (compatible? (cdr type) arg-type))
- (return #t))))))
- args)))))))))
-
- (define (and-redundant? type1 type2)
- (if (or (not (symbol? type1))
- (not (symbol? type2))
- (not (memq type1 bools))
- (not (memq type2 bools)))
- #f ; return #f if not (obviously) redundant, else return which of the two to keep
- (if (eq? type1 type2)
- type1
- (case type1
- ((number? complex?) (or (and (memq type2 '(float? real? rational? integer?)) type2)
- (and (memq type2 '(number? complex?)) type1)))
- ((real?) (or (and (memq type2 '(float? rational? integer?)) type2)
- (and (memq type2 '(number? complex?)) type1)))
- ((float?) (and (memq type2 '(real? complex? number?)) type1))
- ((rational?) (or (and (eq? type2 'integer?) type2)
- (and (memq type2 '(real? complex? number?)) type1)))
- ((integer?) (and (memq type2 '(real? rational? complex? number?)) type1))
- ((vector?) (and (memq type2 '(float-vector? int-vector?)) type2))
- ((float-vector? int-vector?) (and (eq? type2 'vector?) type1))
- ((symbol?) (and (memq type2 '(keyword? gensym?)) type2))
- ((keyword? gensym?) (and (eq? type2 'symbol?) type1))
- ((list?) (and (memq type2 '(null? pair?)) type2))
- ((pair? null?) (and (eq? type2 'list?) type1))
- ((string?) (and (eq? type2 'byte-vector?) type2))
- ((byte-vector?) (and (eq? type2 'string?) type1))
- (else #f)))))
-
- (define (classify e)
- ;; do we already know that e is true or false?
- ;; some cases subsume others: if we know (integer? x) is true, (complex? x) is also true
- (if (true? e)
- #t ; the simple boolean is passed back which will either be dropped or will stop the outer expr build
- (if (false? e)
- #f
- ;; eval of a constant expression here is tricky -- for example, (sqrt 2) should not be turned into 1.414...
- (if (just-constants? e env)
- (catch #t
- (lambda ()
- (let ((val (eval e)))
- (if (boolean? val)
- val
- e)))
- (lambda ignore e))
- e))))
-
- (define (store e value and/or)
- ;; we can't make any assumptions about the expression if it might have side effects
- ;; for example (or (= (oscil o) 0.0) (= (oscil o) 0.0)) can't be reduced
-
- (if (or (not (pair? e))
- (not (side-effect? e env)))
- (let ((its-true (if (eq? and/or 'or)
- (eq? value #t) ; or, so it's false if unknown
- value)))
- (if its-true
- (set! true (cons e true))
- (set! false (cons e false))))))
-
- (let ((form (bsimp in-form)))
- ;(format *stderr* "form: ~S~%" form)
- (if (or (not (pair? form))
- (not (memq (car form) '(or and not))))
- (classify form)
- (let ((len (length form)))
+ ((member elements '((#t #f) (#f #t)))
+ `(boolean? ,sym)) ; zero? doesn't happen
- (case (car form)
-
- ((not)
- (if (= len 2)
- (let* ((arg (cadr form))
- (val (if (and (pair? arg)
- (memq (car arg) '(and or not)))
- (classify (simplify-boolean arg true false env))
- (classify arg))))
- ;(format *stderr* "val ~S, arg: ~S~%" val arg)
- (if (boolean? val)
- (not val)
- (if (or (code-constant? arg)
- (and (pair? arg)
- (symbol? (car arg))
- (hash-table-ref no-side-effect-functions (car arg))
- (not (hash-table-ref globals (car arg)))
- (let ((ret (return-type (car arg))))
- (and (or (symbol? ret) (pair? ret))
- (not (return-type-ok? 'boolean? ret))))
- (not (var-member (car arg) env))))
- #f
- (if (and (pair? arg) ; (not (not ...)) -> ...
- (pair? (cdr arg))
- (eq? (car arg) 'not))
- (cadr arg)
- (if (not (equal? val arg))
- `(not ,val)
- (if (and (pair? arg)
- (<= (length arg) 3)) ; avoid (<= 0 i 12) and such
- (case (car arg)
- ((<) `(>= ,@(cdr arg))) ; (not (< ...)) -> (>= ...)
- ((>) `(<= ,@(cdr arg)))
- ((<=) (if (morally-equal? (caddr arg) 0.0) `(positive? ,(cadr arg)) `(> ,@(cdr arg))))
- ((>=) (if (morally-equal? (caddr arg) 0.0) `(negative? ,(cadr arg)) `(< ,@(cdr arg))))
- ((char<?) `(char>=? ,@(cdr arg)))
- ((char>?) `(char<=? ,@(cdr arg)))
- ((char<=?) `(char>? ,@(cdr arg)))
- ((char>=?) `(char<? ,@(cdr arg)))
- ((char-ci<?) `(char-ci>=? ,@(cdr arg)))
- ((char-ci>?) `(char-ci<=? ,@(cdr arg)))
- ((char-ci<=?) `(char-ci>? ,@(cdr arg)))
- ((char-ci>=?) `(char-ci<? ,@(cdr arg)))
- ((string<?) `(string>=? ,@(cdr arg)))
- ((string>?) `(string<=? ,@(cdr arg)))
- ((string<=?) `(string>? ,@(cdr arg)))
- ((string>=?) `(string<? ,@(cdr arg)))
- ((string-ci<?) `(string-ci>=? ,@(cdr arg)))
- ((string-ci>?) `(string-ci<=? ,@(cdr arg)))
- ((string-ci<=?) `(string-ci>? ,@(cdr arg)))
- ((string-ci>=?) `(string-ci<? ,@(cdr arg)))
- ((odd?) `(even? ,@(cdr arg)))
- ((even?) `(odd? ,@(cdr arg)))
- ((exact?) `(inexact? ,@(cdr arg)))
- ((inexact?) `(exact? ,@(cdr arg)))
- ;; ((null?) `(pair? ,@(cdr arg)))
- ;; this is not quite right
- ;; char-upper-case? and lower are not switchable here
-
- ;; if stuff loaded, (not (every? ...)) => any? and so on
-
- ((zero?) ; (not (zero? (logand p (ash 1 i)))) -> (logbit? p i)
- (let ((zarg (cadr arg))) ; (logand...)
- (if (and (pair? zarg)
- (eq? (car zarg) 'logand)
- (pair? (cddr zarg))
- (pair? (caddr zarg))
- (eq? (caaddr zarg) 'ash)
- (eqv? (cadr (caddr zarg)) 1))
- `(logbit? ,(cadr zarg) ,(caddr (caddr zarg)))
- form)))
-
- (else form))
- form))))))
- form))
+ (else
+ `(,func ,sym ',(reverse elements) , at equals)))))
+
+
+ ;; start of simplify-boolean code
+ ;; this is not really simplify boolean as in boolean algebra because in scheme there are many unequal truths, but only one falsehood
+ ;; 'and and 'or are not boolean operators in a sense
+
+ (and (not (or (member in-form false)
+ (and (pair? in-form)
+ (eq? (car in-form) 'not)
+ (pair? (cdr in-form)) ; (not)!
+ (member (cadr in-form) true))))
+ (or (and (member in-form true) #t)
+ (and (pair? in-form)
+ (eq? (car in-form) 'not)
+ (pair? (cdr in-form))
+ (member (cadr in-form) false)
+ #t)
+
+ (if (not (pair? in-form))
+ in-form
+ (let ((form (bcomp (bsimp in-form))))
+ (if (not (and (pair? form)
+ (memq (car form) '(or and not))))
+ (classify form)
+ (let ((len (length form)))
+ (let ((op (case (car form)
+ ((or) 'and)
+ ((and) 'or)
+ (else #f))))
+ (if (and op
+ (>= len 3)
+ (every? (lambda (p)
+ (and (pair? p)
+ (pair? (cdr p))
+ (pair? (cddr p))
+ (eq? (car p) op)))
+ (cdr form)))
+ (let ((first (cadadr form)))
+ (if (every? (lambda (p)
+ (equal? (cadr p) first))
+ (cddr form))
+ (set! form `(,op ,first (,(car form) ,@(map (lambda (p)
+ (if (null? (cdddr p))
+ (caddr p)
+ `(,op ,@(cddr p))))
+ (cdr form)))))
+ (if (null? (cdddr (cadr form)))
+ (let ((last (caddr (cadr form))))
+ (if (every? (lambda (p)
+ (and (null? (cdddr p))
+ (equal? (caddr p) last)))
+ (cddr form))
+ (set! form `(,op (,(car form) ,@(map cadr (cdr form))) ,last)))))))))
+ ;; (or (and A B) (and A C)) -> (and A (or B C))
+ ;; (or (and A B) (and C B)) -> (and (or A C) B)
+ ;; (and (or A B) (or A C)) -> (or A (and B C))
+ ;; (and (or A B) (or C B)) -> (or (and A C) B)
- ((or)
- (and (> len 1)
- (let ((arg1 (cadr form)))
- (if (= len 2)
- (if (code-constant? arg1)
- arg1
- (classify arg1))
- (if (true? arg1) ; no need to check anything else
- #t ; side-effect? here is a nightmare
- (let* ((arg2 (caddr form))
- (t1 (and (= len 3)
- (pair? arg1)
- (pair? arg2)
- (pair? (cdr arg1))
- (pair? (cdr arg2))
- (equal? (cadr arg1) (cadr arg2))
- (not (side-effect? arg1 env))
- (and-redundant? (car arg1) (car arg2)))))
+ (case (car form)
+ ;; --------------------------------
+ ((not)
+ (if (not (= len 2))
+ form
+ (let* ((arg (cadr form))
+ (val (if (and (pair? arg)
+ (memq (car arg) '(and or not)))
+ (classify (simplify-boolean arg true false env))
+ (classify arg)))
+ (arg-op (and (pair? arg)
+ (car arg))))
+
+ (cond ((boolean? val)
+ (not val))
+
+ ((or (code-constant? arg)
+ (and (pair? arg)
+ (symbol? arg-op)
+ (hash-table-ref no-side-effect-functions arg-op)
+ (let ((ret (return-type arg-op env)))
+ (and (or (symbol? ret) (pair? ret))
+ (not (return-type-ok? 'boolean? ret))))
+ (not (var-member arg-op env))))
+ #f)
+
+ ((and (pair? arg) ; (not (not ...)) -> ...
+ (pair? (cdr arg)) ; this is usually internally generated, so the message about (and x #t) is in special-cases below
+ (eq? arg-op 'not))
+ (cadr arg))
+
+ ((and (pair? arg) ; (not (or|and x (not y)...)) -> (and|or (not x) y ...)
+ (memq arg-op '(and or))
+ (pair? (cdr arg))
+ (any? (lambda (p)
+ (and (pair? p)
+ (eq? (car p) 'not)))
+ (cdr arg)))
+ (let ((rel (if (eq? arg-op 'or) 'and 'or)))
+ `(,rel ,@(map (lambda (p)
+ (if (and (pair? p)
+ (eq? (car p) 'not))
+ (cadr p)
+ (simplify-boolean `(not ,p) () () env)))
+ (cdr arg)))))
+
+ ((not (equal? val arg))
+ `(not ,val))
+
+ ((and (pair? arg)
+ (<= (length arg) 3)) ; avoid (<= 0 i 12) and such
+ (case arg-op
+ ((< > <= >= odd? even? exact? inexact?char<? char>? char<=? char>=? string<? string>? string<=? string>=?
+ char-ci<? char-ci>? char-ci<=? char-ci>=? string-ci<? string-ci>? string-ci<=? string-ci>=?)
+ `(,(hash-table-ref notables arg-op) ,@(cdr arg)))
+
+ ;; null? is not quite right because (not (null? 3)) -> #t
+ ;; char-upper-case? and lower are not switchable here
+
+ ((zero?) ; (not (zero? (logand p 2^n | (ash 1 i)))) -> (logbit? p i)
+ (let ((zarg (cadr arg))) ; (logand...)
+ (if (not (and (pair? zarg)
+ (eq? (car zarg) 'logand)
+ (pair? (cdr zarg))
+ (pair? (cddr zarg))
+ (null? (cdddr zarg))))
+ form
+ (let ((arg1 (cadr zarg))
+ (arg2 (caddr zarg))) ; these are never reversed
+ (or (and (pair? arg2)
+ (pair? (cdr arg2))
+ (eq? (car arg2) 'ash)
+ (eqv? (cadr arg2) 1)
+ `(logbit? ,arg1 ,(caddr arg2)))
+ (and (integer? arg2)
+ (positive? arg2)
+ (zero? (logand arg2 (- arg2 1))) ; it's a power of 2
+ `(logbit? ,arg1 ,(floor (log arg2 2)))) ; floor for freeBSD?
+ form)))))
+
+ (else form)))
+
+ (else form)))))
+ ;; --------------------------------
+ ((or)
+ (case len
+ ((1) #f)
+ ((2) (if (code-constant? (cadr form)) (cadr form) (classify (cadr form))))
+ (else
+ (call-with-exit
+ (lambda (return)
+ (when (= len 3)
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+
+ (if (and (pair? arg2) ; (or A (and ... A ...)) -> A
+ (eq? (car arg2) 'and)
+ (member arg1 (cdr arg2))
+ (not (side-effect? arg2 env)))
+ (return arg1))
+ (if (and (pair? arg1) ; (or (and ... A) A) -> A
+ (eq? (car arg1) 'and)
+ (equal? arg2 (list-ref arg1 (- (length arg1) 1)))
+ (not (side-effect? arg1 env)))
+ (return arg2))
+
+ (if (and (pair? arg2) ; (or A (and (not A) B)) -> (or A B)
+ (eq? (car arg2) 'and)
+ (pair? (cadr arg2))
+ (eq? (caadr arg2) 'not)
+ (equal? arg1 (cadadr arg2)))
+ (return `(or ,arg1 ,@(cddr arg2))))
+
+ (when (and (pair? arg1)
+ (pair? arg2))
+
+ (if (and (eq? (car arg1) 'not) ; (or (not A) (and A B)) -> (or (not A) B) -- this stuff actually happens!
+ (eq? (car arg2) 'and)
+ (equal? (cadr arg1) (cadr arg2)))
+ (return `(or ,arg1 ,@(cddr arg2))))
+
+ (when (and (eq? (car arg1) 'and)
+ (eq? (car arg2) 'and)
+ (= 3 (length arg1) (length arg2))
+ ;; (not (side-effect? arg1 env)) ; maybe??
+ (or (equal? (cadr arg1) `(not ,(cadr arg2)))
+ (equal? `(not ,(cadr arg1)) (cadr arg2)))
+ (not (equal? (caddr arg1) `(not ,(caddr arg2))))
+ (not (equal? `(not ,(caddr arg1)) (caddr arg2))))
+ ;; kinda dumb, but common: (or (and A B) (and (not A) C)) -> (if A B C)
+ ;; the other side: (and (or A B) (or (not A) C)) -> (if A C (and B #t)), but it never happens
+ (lint-format "perhaps ~A" 'or
+ (lists->string form
+ (if (and (pair? (cadr arg1))
+ (eq? (caadr arg1) 'not))
+ `(if ,(cadr arg2) ,(caddr arg2) ,(caddr arg1))
+ `(if ,(cadr arg1) ,(caddr arg1) ,(caddr arg2))))))
+ (let ((t1 (and (pair? (cdr arg1))
+ (pair? (cdr arg2))
+ (or (equal? (cadr arg1) (cadr arg2))
+ (and (pair? (cddr arg2))
+ (null? (cdddr arg2))
+ (equal? (cadr arg1) (caddr arg2))))
+ (not (side-effect? arg1 env))
+ (and-redundant? arg1 arg2))))
(if t1
- (if (eq? t1 (car arg1))
- arg2
- arg1)
- (let ((sf #f))
- (if (and (every? (lambda (p)
- (and (pair? p)
- (pair? (cdr p))
- (eq? (car p) 'not)))
- (cdr form))
- (let ()
- (set! sf (simplify-boolean `(not (and ,@(map cadr (cdr form)))) true false env))
- (or (not (pair? sf))
- (not (eq? (car sf) 'not))
- (not (pair? (cadr sf)))
- (not (eq? (caadr sf) 'and)))))
- sf
- ;; if all clauses are (eq-func x y) where one of x/y is a symbol|simple-expr repeated throughout
- ;; and the y is a code-constant, or -> memq and friends. This could also handle cadr|caddr reversed.
-
- ;; (or (pair? x) (null? x)) -> (list? x)
-
- (let ((sym #f)
- (eqf #f))
- (if (every? (lambda (p)
- (and (pair? p)
- (if (not eqf)
- (and (memq (car p) '(eq? eqv? equal? char=? string=? = char-ci=? string-ci=?))
- (set! eqf (car p)))
- (eq? eqf (car p)))
- (if (not sym)
- (and (not (side-effect? (cadr p) env))
- (set! sym (cadr p)))
- (equal? sym (cadr p)))
- (code-constant? (caddr p))))
- (cdr form))
- (let* ((vals (map caddr (cdr form)))
- (func (case eqf
- ((eq?) 'memq)
- ((eqv? char=?) 'memv)
- ((=) (if (every? rational? vals) 'memv 'member))
- (else 'member)))
- (equals (if (and (eq? func 'member)
- (not (eq? eqf 'equal?)))
- (list eqf)
- ()))
- (elements (map (lambda (v) (if (pair? v) (cadr v) v)) vals)))
- (if (and (eq? eqf 'char=?)
- (= (length elements) 2)
- (char-ci=? (car elements) (cadr elements)))
- `(char-ci=? ,sym ,(car elements))
- (if (and (eq? eqf 'string=?)
- (= (length elements) 2)
- (string-ci=? (car elements) (cadr elements)))
- `(string-ci=? ,sym ,(car elements))
- `(,func ,sym ',(map (lambda (v) (if (pair? v) (cadr v) v)) vals) , at equals))))
-
- (let ((new-form ()))
- (do ((exprs (cdr form) (cdr exprs)))
- ((null? exprs)
- (if (null? new-form)
- #f
- (if (null? (cdr new-form))
- (car new-form)
- `(or ,@(reverse new-form)))))
- (let* ((e (car exprs))
- (val (classify e)))
-
- (if (and (pair? val)
- (memq (car val) '(and or not)))
- (set! val (classify (set! e (simplify-boolean e true false env)))))
-
- (if val ; #f in or is ignored
- (if (or (eq? val #t) ; #t or any non-#f constant in or ends the expression
- (code-constant? val))
- (begin
- (if (null? new-form) ; (or x1 123) -> value of x1 first
- (set! new-form (list val)) ;was `(,val))
- (set! new-form (cons val new-form))) ;was (append `(,val) new-form))) ; reversed when returned
- (set! exprs '(#t)))
-
- ;; (or x1 x2 x1) -> (or x1 x2) is ok because if we get to x2, x1 is #f, so trailing x1 would still be #f
-
- (if (and (pair? e) ; (or ...) -> splice into current
- (eq? (car e) 'or))
- (set! exprs (append e (cdr exprs))) ; we'll skip the 'or in do step
- (begin ; else add it to our new expression with value #f
- (store e val 'or)
- (if (not (memq val new-form))
- (set! new-form (cons val new-form)))))))))))))))))))))
-
- ((and)
- (or (= len 1)
- (let ((arg1 (cadr form)))
- (if (= len 2)
- (classify arg1)
- (and (not (contradictory? (cdr form)))
- (let* ((arg2 (caddr form))
- (t1 (and (= len 3)
- (pair? arg1)
- (pair? arg2)
- (pair? (cdr arg1))
- (pair? (cdr arg2))
- (equal? (cadr arg1) (cadr arg2))
- (not (side-effect? arg1 env))
- (and-redundant? (car arg1) (car arg2))))) ; (and (integer? x) (number? x)) -> (integer? x)
- (if t1
- (if (eq? t1 (car arg1))
- arg1
- arg2)
- (let ((new-form ()))
-
- (if (and (= len 3)
- (not (side-effect? arg1 env))
- (equal? arg1 arg2)) ; (and x x) -> x
- arg1
-
- ;; (and (= ...)...) for more than 2 args?
- ;; (and (< x y z) (< z w)) -> (< x y z w) ?
- ;; (and (< x y) (< y z) (< z w)) -> (< x y z w)
-
- (if (and (= len 3)
- (pair? arg1)
- (pair? arg2)
- (reversible? (car arg1))
- (null? (cdddr arg1))
- (pair? (cdr arg2))
- (pair? (cddr arg2))
- (null? (cdddr arg2))
- (not (side-effect? arg2 env)) ; arg1 is hit in any case
- (or (eq? (car arg1) (car arg2))
- (let ((rf (reversed (car arg2))))
- (and (eq? (car arg1) rf)
- (set! arg2 (append (list rf) (reverse (cdr arg2)))))))
- (or (eq? (caddr arg1) (cadr arg2))
- (eq? (cadr arg1) (caddr arg2))
- (and (memq (car arg1) '(= char=? string=? char-ci=? string-ci=?))
- (or (eq? (cadr arg1) (cadr arg2))
- (eq? (caddr arg1) (caddr arg2))))))
- (if (eq? (caddr arg1) (cadr arg2))
- `(,(car arg1) ,(cadr arg1) ,(cadr arg2) ,(caddr arg2))
- (if (eq? (cadr arg1) (caddr arg2))
- `(,(car arg1) ,(cadr arg2) ,(cadr arg1) ,(caddr arg1))
- (if (eq? (cadr arg1) (cadr arg2))
- `(,(car arg1) ,(cadr arg1) ,(caddr arg1) ,(caddr arg2))
- `(,(car arg1) ,(cadr arg1) ,(caddr arg1) ,(cadr arg2)))))
-
- (do ((exprs (cdr form) (cdr exprs)))
- ((null? exprs)
- (if (null? new-form)
- #t ; (and) -> #t
- (let* ((nform (reverse new-form))
- (newer-form (map (lambda (x cdr-x)
- (if (and x (code-constant? x))
- (values)
- x))
- nform (cdr nform))))
- (if (null? newer-form)
- (car new-form)
- `(and , at newer-form ,(car new-form))))))
-
- (let* ((e (car exprs))
- (val (classify e)))
+ (return (if (eq? t1 (car arg1)) arg2 arg1))))
+
+ ;; if all clauses are (eq-func x y) where one of x/y is a symbol|simple-expr repeated throughout
+ ;; and the y is a code-constant, or -> memq and friends.
+ ;; This could also handle cadr|caddr reversed, but it apparently never happens.
+ (if (and (or (and (eq? (car arg2) '=)
+ (memq (car arg1) '(< > <= >=)))
+ (and (eq? (car arg1) '=)
+ (memq (car arg2) '(< > <= >=))))
+ (= (length arg1) 3)
+ (equal? (cdr arg1) (cdr arg2)))
+ (return `(,(if (or (memq (car arg1) '(< <=))
+ (memq (car arg2) '(< <=)))
+ '<= '>=)
+ ,@(cdr arg1))))
+
+ ;; this makes some of the code above redundant
+ (let ((rel (relsub arg1 arg2 'or env)))
+ (if (or (boolean? rel)
+ (pair? rel))
+ (return rel)))
+
+ ;; (or (pair? x) (null? x)) -> (list? x)
+ (if (and (memq (car arg1) '(null? pair?))
+ (memq (car arg2) '(null? pair?))
+ (not (eq? (car arg1) (car arg2)))
+ (equal? (cadr arg1) (cadr arg2)))
+ (return `(list? ,(cadr arg1))))
+
+ (if (and (eq? (car arg1) 'zero?) ; (or (zero? x) (positive? x)) -> (not (negative? x)) -- other cases don't happen
+ (memq (car arg2) '(positive? negative?))
+ (equal? (cadr arg1) (cadr arg2)))
+ (return `(not (,(if (eq? (car arg2) 'positive?) 'negative? 'positive?) ,(cadr arg1)))))
+
+ ;; (or (and A B) (and (not A) (not B))) -> (eq? (not A) (not B))
+ ;; more accurately (if A B (not B)), but every case I've seen is just boolean
+ ;; perhaps also (or (not (or A B)) (not (or (not A) (not B)))), but it never happens
+ (let ((a1 (cadr form))
+ (a2 (caddr form)))
+ (and (pair? a1)
+ (pair? a2)
+ (eq? (car a1) 'and)
+ (eq? (car a2) 'and)
+ (= (length a1) 3)
+ (= (length a2) 3)
+ (let ((A (if (and (pair? (cadr a1)) (eq? (caadr a1) 'not)) (cadadr a1) (cadr a1)))
+ (B (if (and (pair? (caddr a1)) (eq? (caaddr a1) 'not)) (cadr (caddr a1)) (caddr a1))))
+ (if (or (equal? form `(or (and ,A ,B) (and (not ,A) (not ,B))))
+ (equal? form `(or (and (not ,A) (not ,B)) (and ,A ,B))))
+ (return `(eq? (not ,A) (not ,B))))
+ (if (or (equal? form `(or (and ,A (not ,B)) (and (not ,A) ,B)))
+ (equal? form `(or (and (not ,A) ,B) (and ,A (not ,B)))))
+ (return `(not (eq? (not ,A) (not ,B))))))))
+
+ (when (and (pair? (cdr arg1))
+ (pair? (cdr arg2))
+ (not (eq? (car arg1) (car arg2))))
+ (when (subsumes? (car arg1) (car arg2))
+ (return arg1))
+
+ (if (eq? (car arg1) 'not)
+ (let ((temp arg1))
+ (set! arg1 arg2)
+ (set! arg2 temp)))
+ (if (and (eq? (car arg2) 'not)
+ (pair? (cadr arg2))
+ (pair? (cdadr arg2))
+ (not (eq? (caadr arg2) 'let?))
+ (or (equal? (cadr arg1) (cadadr arg2))
+ (and (pair? (cddr arg1))
+ (equal? (caddr arg1) (cadadr arg2))))
+ (eq? (return-type (car arg1) env) 'boolean?)
+ (eq? (return-type (caadr arg2) env) 'boolean?))
+ (let ((t2 (or-not-redundant arg1 arg2)))
+ (when t2
+ (if (eq? t2 'fatuous)
+ (return #t)
+ (if (pair? t2)
+ (return t2)))))))
+
+ ;; (or (if a c d) (if b c d)) -> (if (or a b) c d) never happens, sad to say
+ ;; or + if + if does happen but not in this easily optimized form
+ ))) ; len = 3
+
+ (let ((nots 0)
+ (revers 0))
+ (if (every? (lambda (a) ; (and (not (pair? x)) (not (null? x))) -> (not (list? x))
+ (and (pair? a)
+ (if (eq? (car a) 'not)
+ (set! nots (+ nots 1))
+ (and (hash-table-ref notables (car a))
+ (set! revers (+ revers 1))))))
+ (cdr form))
+ (if (zero? revers)
+ (let ((sf (simplify-boolean `(and ,@(map cadr (cdr form))) true false env)))
+ (return (simplify-boolean `(not ,sf) () () env)))
+ (if (> nots revers)
+ (let ((nf (simplify-boolean `(and ,@(map (lambda (p)
+ (if (eq? (car p) 'not)
+ (cadr p)
+ `(,(hash-table-ref notables (car p)) ,@(cdr p))))
+ (cdr form)))
+ true false env)))
+ (return (simplify-boolean `(not ,nf) () () env)))))))
+
+ (let ((sym #f)
+ (eqfnc #f)
+ (vals ())
+ (start #f))
+
+ (define (constant-arg p)
+ (if (code-constant? (cadr p))
+ (set! vals (cons (cadr p) vals))
+ (and (code-constant? (caddr p))
+ (set! vals (cons (caddr p) vals)))))
+
+ (define (upgrade-eqf)
+ (set! eqfnc (if (memq eqfnc '(string=? string-ci=? = equal?))
+ 'equal?
+ (if (memq eqfnc '(#f eq?)) 'eq? 'eqv?))))
+
+ (do ((fp (cdr form) (cdr fp)))
+ ((null? fp))
+ (let ((p (and (pair? fp)
+ (car fp))))
+ (if (and (pair? p)
+ (if (not sym)
+ (set! sym (eqv-selector p))
+ (equal? sym (eqv-selector p)))
+ (or (not (memq eqfnc '(char-ci=? string-ci=? =)))
+ (memq (car p) '(char-ci=? string-ci=? =)))
+
+ ;; = can't share: (equal? 1 1.0) -> #f, so (or (not x) (= x 1)) can't be simplified
+ ;; except via member+morally-equal? but that brings in float-epsilon and NaN differences.
+ ;; We could add both: 1 1.0 as in cond?
+ ;;
+ ;; another problem: using memx below means the returned value of the expression
+ ;; may not match the original (#t -> '(...)), so perhaps we should add a one-time
+ ;; warning about this, and wrap it in (pair? (mem...)) as an example.
+ ;;
+ ;; and another thing... the original might be broken: (eq? x #(1)) where equal?
+ ;; is more sensible, but that also changes the behavior of the expression:
+ ;; (memq x '(#(1))) may be #f (or #t!) when (member x '(#(1))) is '(#(1)).
+ ;;
+ ;; I think I'll try to turn out a more-or-less working expression, but warn about it.
+
+ (case (car p)
+ ((string=? equal?)
+ (set! eqfnc (if (or (not eqfnc)
+ (eq? eqfnc (car p)))
+ (car p)
+ 'equal?))
+ (and (= (length p) 3)
+ (constant-arg p)))
+
+ ((char=?)
+ (if (memq eqfnc '(#f char=?))
+ (set! eqfnc 'char=?)
+ (if (not (eq? eqfnc 'equal?))
+ (set! eqfnc 'eqv?)))
+ (and (= (length p) 3)
+ (constant-arg p)))
+
+ ((eq? eqv?)
+ (let ((leqf (car (->eqf (->lint-type (if (code-constant? (cadr p)) (cadr p) (caddr p)))))))
+ (cond ((not eqfnc)
+ (set! eqfnc leqf))
+
+ ((or (memq leqf '(#t equal?))
+ (not (eq? eqfnc leqf)))
+ (set! eqfnc 'equal?))
- (if (and (pair? val)
- (memq (car val) '(and or not)))
- (set! val (classify (set! e (simplify-boolean e () false env)))))
+ ((memq eqfnc '(#f eq?))
+ (set! eqfnc leqf))))
+ (and (= (length p) 3)
+ (constant-arg p)))
+
+ ((char-ci=? string-ci=? =)
+ (and (or (not eqfnc)
+ (eq? eqfnc (car p)))
+ (set! eqfnc (car p))
+ (= (length p) 3)
+ (constant-arg p)))
+
+ ((eof-object?)
+ (upgrade-eqf)
+ (set! vals (cons #<eof> vals)))
+
+ ((not)
+ (upgrade-eqf)
+ (set! vals (cons #f vals)))
+
+ ((boolean?)
+ (upgrade-eqf)
+ (set! vals (cons #f (cons #t vals))))
+
+ ((zero?)
+ (if (memq eqfnc '(#f eq?)) (set! eqfnc 'eqv?))
+ (set! vals (cons 0 (cons 0.0 vals))))
+
+ ((null?)
+ (upgrade-eqf)
+ (set! vals (cons () vals)))
+
+ ((memq memv member)
+ (cond ((eq? (car p) 'member)
+ (set! eqfnc 'equal?))
+
+ ((eq? (car p) 'memv)
+ (set! eqfnc (if (eq? eqfnc 'string=?) 'equal? 'eqv?)))
+
+ ((not eqfnc)
+ (set! eqfnc 'eq?)))
+ (and (= (length p) 3)
+ (pair? (caddr p))
+ (eq? 'quote (caaddr p))
+ (pair? (cadr (caddr p)))
+ (set! vals (append (cadr (caddr p)) vals))))
+
+ (else #f)))
+ (begin
+ (if (not start)
+ (set! start fp)
+ (if (null? (cdr fp))
+ (if (eq? start (cdr form))
+ (return (gather-or-eqf-elements eqfnc sym vals))
+ (return `(or ,@(copy (cdr form) (make-list (let loop ((g (cdr form)) (len 0))
+ (if (eq? g start)
+ len
+ (loop (cdr g) (+ len 1))))))
+ ,(gather-or-eqf-elements eqfnc sym vals)))))))
+
+ (when start
+ (if (eq? fp (cdr start))
+ (begin
+ (set! sym #f)
+ (set! eqfnc #f)
+ (set! vals ())
+ (set! start #f))
+ ;; here we have possible header stuff + more than one match + trailing stuff
+ (let ((trailer (if (not (and (pair? fp)
+ (pair? (cdr fp))))
+ fp
+ (let ((nfp (simplify-boolean `(or , at fp) () () env)))
+ (if (and (pair? nfp)
+ (eq? (car nfp) 'or))
+ (cdr nfp)
+ (list nfp))))))
+ (if (eq? start (cdr form))
+ (return `(or ,(gather-or-eqf-elements eqfnc sym vals)
+ , at trailer))
+ (return `(or ,@(copy (cdr form) (make-list (let loop ((g (cdr form)) (len 0))
+ (if (eq? g start)
+ len
+ (loop (cdr g) (+ len 1))))))
+ ,(gather-or-eqf-elements eqfnc sym vals)
+ , at trailer)))))))))
+
+ (let ((selector #f) ; (or (and (eq?...)...)....) -> (case ....)
+ (keys ()))
+ (do ((fp (cdr form) (cdr fp)))
+ ((or (null? fp)
+ (let ((p (and (pair? fp)
+ (car fp))))
+ (not (and (pair? p)
+ (eq? (car p) 'and)
+ (pair? (cdr p))
+ (pair? (cadr p))
+ (pair? (cdadr p))
+ (or selector
+ (set! selector (cadadr p)))
+ (let ((expr (cadr p)))
+ (case (car expr)
+ ((null?)
+ (and (equal? selector (cadr expr))
+ (not (memq () keys))
+ (set! keys (cons () keys))))
+ ;; we have to make sure no keys are repeated:
+ ;; (or (and (eq? x 'a) (< y 1)) (and (eq? x 'a) (< y 2)))
+ ;; this rewrite has become much trickier than expected...
+
+ ((boolean?)
+ (and (equal? selector (cadr expr))
+ (not (memq #f keys))
+ (not (memq #t keys))
+ (set! keys (cons #f (cons #t keys)))))
+
+ ((eof-object?)
+ (and (equal? selector (cadr expr))
+ (not (memq #<eof> keys))
+ (set! keys (cons #<eof> keys))))
+
+ ((zero?)
+ (and (equal? selector (cadr expr))
+ (not (memv 0 keys))
+ (not (memv 0.0 keys))
+ (set! keys (cons 0.0 (cons 0 keys)))))
+
+ ((memq memv)
+ (and (equal? selector (cadr expr))
+ (pair? (cddr expr))
+ (pair? (caddr expr))
+ (eq? (caaddr expr) 'quote)
+ (pair? (cadr (caddr expr)))
+ (not (any? (lambda (g)
+ (memv g keys))
+ (cadr (caddr expr))))
+ (set! keys (append (cadr (caddr expr)) keys))))
+
+ ((eq? eqv? char=?)
+ (and (pair? (cddr expr))
+ (null? (cdddr expr))
+ (or (and (equal? selector (cadr expr))
+ (code-constant? (caddr expr))
+ (not (memv (unquoted (caddr expr)) keys))
+ (set! keys (cons (unquoted (caddr expr)) keys)))
+ (and (equal? selector (caddr expr))
+ (code-constant? (cadr expr))
+ (not (memv (unquoted (cadr expr)) keys))
+ (set! keys (cons (unquoted (cadr expr)) keys))))))
+
+ ((not)
+ ;; no hits here for last+not eq(etc)+no collision in keys
+ (and (equal? selector (cadr expr))
+ (not (memq #f keys))
+ (set! keys (cons #f keys))))
+
+ (else #f)))))))
+ (if (null? fp)
+ (return `(case ,selector
+ ,@(map (lambda (p)
+ (let ((expr (cadr p))
+ (result (if (null? (cdddr p))
+ (caddr p)
+ `(and ,@(cddr p)))))
+ `(,(case (car expr)
+ ((eq? eqv? char=?)
+ (if (equal? selector (cadr expr))
+ (list (unquoted (caddr expr)))
+ (list (unquoted (cadr expr)))))
+ ((memq memv) (unquoted (caddr expr)))
+ ((null?) (list ()))
+ ((eof-object?) (list #<eof>))
+ ((zero?) (list 0 0.0))
+ ((not) (list #f))
+ ((boolean?) (list #t #f)))
+ ,result)))
+ (cdr form))
+ (else #f)))))))
+
+ (let ((new-form ())
+ (retry #f))
+ (do ((exprs (cdr form) (cdr exprs)))
+ ((null? exprs)
+ (return (and (pair? new-form)
+ (if (null? (cdr new-form))
+ (car new-form)
+ (if retry
+ (simplify-boolean `(or ,@(reverse new-form)) () () env)
+ `(or ,@(reverse new-form)))))))
+ (let ((val (classify (car exprs)))
+ (old-form new-form))
+ (if (and (pair? val)
+ (memq (car val) '(and or not)))
+ (set! val (classify (simplify-boolean val true false env))))
+
+ (if (not (or retry
+ (equal? val (car exprs))))
+ (set! retry #t))
+
+ (if val ; #f in or is ignored
+ (cond ((or (eq? val #t) ; #t or any non-#f constant in or ends the expression
+ (code-constant? val))
+ (set! new-form (if (null? new-form) ; (or x1 123) -> value of x1 first
+ (list val)
+ (cons val new-form)))
+ ;; reversed when returned
+ (set! exprs '(#t)))
+
+ ((and (pair? val) ; (or ...) -> splice into current
+ (eq? (car val) 'or))
+ (set! exprs (append val (cdr exprs)))) ; we'll skip the 'or in do step
+
+ ((not (or (memq val new-form)
+ (and (pair? val) ; and redundant tests
+ (hash-table-ref bools1 (car val))
+ (any? (lambda (p)
+ (and (pair? p)
+ (subsumes? (car p) (car val))
+ (equal? (cadr val) (cadr p))))
+ new-form))))
+ (set! new-form (cons val new-form)))))
+
+ (if (and (not (eq? new-form old-form))
+ (pair? (cdr new-form)))
+ (let ((rel (relsub (car new-form) (cadr new-form) 'or env)))
+ (if (or (boolean? rel)
+ (pair? rel))
+ (set! new-form (cons rel (cddr new-form)))))))))))))))
+
+ ;; --------------------------------
+ ((and)
+ (case len
+ ((1) #t)
+ ((2) (classify (cadr form)))
+ (else
+ (and (not (contradictory? (cdr form)))
+ (call-with-exit
+ (lambda (return)
+ (when (= len 3)
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (if (and (pair? arg2) ; (and A (or A ...)) -> A
+ (eq? (car arg2) 'or)
+ (equal? arg1 (cadr arg2))
+ (not (side-effect? arg2 env)))
+ (return arg1))
+ (if (and (pair? arg1) ; (and (or ... A ...) A) -> A
+ (eq? (car arg1) 'or)
+ (member arg2 (cdr arg1))
+ (not (side-effect? arg1 env)))
+ (return arg2))
+ ;; the and equivalent of (or (not A) (and A B)) never happens
+
+ (when (and (symbol? arg1) ; (and x (pair? x)) -> (pair? x)
+ (pair? arg2)
+ (pair? (cdr arg2))
+ (eq? arg1 (cadr arg2)))
+ (if (eq? (car arg2) 'not)
+ (return #f))
+ (if (not (or (memq (car arg2) '(and or not list cons vector))
+ (side-effect? arg2 env)))
+ (let ((v (var-member arg1 env)))
+ (if (not (and (var? v)
+ (pair? (var-history v))
+ (member #f (var-history v)
+ (lambda (a b)
+ (and (pair? b)
+ (memq (car b) '(char-position string-position format string->number
+ assoc assq assv memq memv member)))))))
+ (let* ((sig (arg-signature (car arg2) env))
+ (arg-type (and (pair? sig)
+ (pair? (cdr sig))
+ (symbol? (cadr sig)))))
+ (if arg-type
+ (format outport "~NCin ~A, perhaps change ~S to ~S~%"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ `(and ,arg1 ...)
+ `(and (,(cadr sig) ,arg1) ...)))))))
+
+ (if (hash-table-ref bools1 (car arg2))
+ (return arg2)))
+
+ (if (and (not (side-effect? arg1 env))
+ (equal? arg1 arg2)) ; (and x x) -> x
+ (return arg1))
+
+ (when (and (pair? arg1)
+ (pair? arg2)
+ (pair? (cdr arg1))
+ (pair? (cdr arg2)))
+
+ (let ((t1 (and (or (equal? (cadr arg1) (cadr arg2))
+ (and (pair? (cddr arg2))
+ (null? (cdddr arg2))
+ (equal? (cadr arg1) (caddr arg2))))
+ (not (side-effect? arg1 env))
+ (and-redundant? arg1 arg2)))) ; (and (integer? x) (number? x)) -> (integer? x)
+ (if t1
+ (return (cond
+ ((memq t1 '(eq? eqv? equal?))
+ `(,t1 ,@(cdr arg2)))
- ;; (and x1 x2 x1) is not reducible
- ;; the final thing has to remain at the end, but can be deleted earlier if it can't short-circuit the evaluation,
- ;; but if there are expressions following the first x1, we can't be sure that it is not
- ;; protecting them:
- ;; (and false-or-0 (display (list-ref lst false-or-0)) false-or-0)
- ;; so I'll not try to optimize that case. But (and x x) is optimizable.
+ ((eq? t1 'memv)
+ (let ((x (if (equal? (cadr arg1) (cadr arg2)) (caddr arg2) (cadr arg2))))
+ (if (rational? x)
+ `(memv ,(cadr arg1) '(,x ,(* 1.0 x)))
+ `(memv ,(cadr arg1) '(,(floor x) ,x)))))
- (if (eq? val #t)
- (if (null? (cdr exprs)) ; (and x y #t) should not remove the #t
- (if (or (and (pair? e)
- (eq? (return-type (car e)) 'boolean?))
- (eq? e #t))
- (set! new-form (cons val new-form))
- (if (or (null? new-form)
- (not (equal? e (car new-form))))
- (set! new-form (cons e new-form))))
- (if (and (not (eq? e #t))
- (or (null? new-form)
- (not (member e new-form))))
- (set! new-form (cons e new-form))))
-
- (if (not val) ; #f in 'and' ends the expression
- (begin
- (if (or (null? new-form)
- (just-symbols? new-form))
- (set! new-form '(#f))
- (set! new-form (cons #f new-form))) ;was (append '(#f) new-form)))
- (set! exprs '(#f)))
- (if (and (pair? e) ; if (and ...) splice into current
- (eq? (car e) 'and))
- (set! exprs (append e (cdr exprs)))
- (if (not (and (pair? e) ; (and ... (or ... 123) ...) -> splice out or
- (pair? (cdr exprs))
- (eq? (car e) 'or)
- (> (length e) 2)
- (let ((last (list-ref e (- (length e) 1))))
- (and last ; (or ... #f)
- (code-constant? last)))))
- (begin ; else add it to our new expression with value #t
- (store e val 'and)
- (if (or (not (pair? new-form))
- (not (eq? val (car new-form))))
- (set! new-form (cons val new-form)))))))))))))))))))))))))
-
- (define (splice-if f lst)
- (cond ((null? lst) ())
- ((pair? lst)
- (if (and (pair? (car lst))
- (f (caar lst)))
- (append (splice-if f (cdar lst)) (splice-if f (cdr lst)))
- (cons (car lst) (splice-if f (cdr lst)))))
- (#t lst)))
-
-
- (define (simplify-numerics form env)
- ;; this returns a form, possibly the original simplified
- (let ((real-result? (lambda (op) (memq op '(imag-part real-part abs magnitude angle max min exact->inexact
- modulo remainder quotient lcm gcd))))
- (rational-result? (lambda (op) (memq op '(rationalize inexact->exact))))
- (integer-result? (lambda (op) (memq op '(logior lognot logxor logand numerator denominator
- floor round truncate ceiling ash)))))
-
- (define (inverse-op op)
- (case op
- ((sin) 'asin) ((cos) 'acos) ((tan) 'atan) ((asin) 'sin) ((acos) 'cos) ((atan) 'tan)
- ((sinh) 'asinh) ((cosh) 'acosh) ((tanh) 'atanh) ((asinh) 'sinh) ((acosh) 'cosh) ((atanh) 'tanh)
- ((log) exp) ((exp) log)))
-
-
- (define (remove-duplicates lst)
- (letrec ((rem-dup
- (lambda (lst nlst)
- (cond ((null? lst) nlst)
- ((and (member (car lst) nlst)
- (or (not (pair? (car lst)))
- (not (eq? (caar lst) 'random)))) ; this problem applies to anything that calls random, mus-random etc
- (rem-dup (cdr lst) nlst))
- (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
- (reverse (rem-dup lst ()))))
-
- (define (just-rationals? form)
- (or (null? form)
- (rational? form)
- (and (pair? form)
- (rational? (car form))
- (just-rationals? (cdr form)))))
-
- (define (just-reals? form)
- (or (null? form)
- (real? form)
- (and (pair? form)
- (real? (car form))
- (just-reals? (cdr form)))))
-
- (define (just-integers? form)
- (or (null? form)
- (integer? form)
- (and (pair? form)
- (integer? (car form))
- (just-integers? (cdr form)))))
-
- (define (simplify-arg x)
- (if (or (not (pair? x)) ; constants and the like look dumb if simplified
- (hash-table-ref globals (car x))
- (not (hash-table-ref no-side-effect-functions (car x)))
- (var-member (car x) env))
- x
- (let ((f (simplify-numerics x env)))
- (if (and (pair? f)
- (just-rationals? f))
- (catch #t
- (lambda ()
- (eval f))
- (lambda ignore f))
- f))))
-
- (let* ((args (map simplify-arg (cdr form)))
- (len (length args)))
-
- (case (car form)
- ((+)
- (case len
- ((0) 0)
- ((1) (car args))
- (else
- (let ((val (remove-all 0 (splice-if (lambda (x) (eq? x '+)) args))))
- (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
- (let ((rats (collect-if list rational? val)))
- (if (> (length rats) 1)
- (let ((y (apply + rats)))
- (if (zero? y)
- (set! val (collect-if list (lambda (x) (not (number? x))) val))
- (set! val (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
- (case (length val)
- ((0) 0)
- ((1) (car val)) ; (+ x) -> x
- (else `(+ , at val))))))) ; other obvious simplifications never happen
-
- ((*)
- (case len
- ((0) 1)
- ((1) (car args))
- (else
- (let ((val (remove-all 1 (splice-if (lambda (x) (eq? x '*)) args))))
- (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
- (let ((rats (collect-if list rational? val)))
- (if (> (length rats) 1)
- (let ((y (apply * rats)))
- (if (= y 1)
- (set! val (collect-if list (lambda (x) (not (number? x))) val))
- (set! val (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
- (case (length val)
- ((0) 1)
- ((1) (car val)) ; (* x) -> x
- (else
- (if (just-rationals? val)
- (apply * val)
- (if (memv 0 val) ; (* x 0 2) -> 0
- 0
- (if (= (length val) 2)
- (if (memv -1 val)
- `(- ,@(remove -1 val)) ; (* -1 x) -> (- x)
- (if (and (pair? (car val))
- (pair? (cadr val))
- (= (length (car val)) 3)
- (equal? (cdar val) (cdadr val))
- (or (and (eq? (caar val) 'gcd) (eq? (caadr val) 'lcm))
- (and (eq? (caar val) 'lcm) (eq? (caadr val) 'gcd))))
- `(abs (* ,@(cdar val))) ; (* (gcd a b) (lcm a b)) -> (abs (* a b)) but only if 2 args?
- `(* , at val)))
- `(* , at val))))))))))
-
- ((-)
- (case len
- ((0) form)
- ((1) ; negate
- (if (number? (car args))
- (- (car args))
- (if (not (list? (car args)))
- `(- , at args)
- (case (length (car args))
- ((2) (if (eq? (caar args) '-)
- (cadar args) ; (- (- x)) -> x
- `(- , at args)))
- ((3) (if (eq? (caar args) '-)
- `(- ,(caddar args) ,(cadar args)) ; (- (- x y)) -> (- y x)
- `(- , at args)))
- (else `(- , at args))))))
- ((2)
- (if (just-rationals? args)
- (apply - args)
- (if (eqv? (car args) 0)
- `(- ,(cadr args)) ; (- 0 x) -> (- x)
- (if (eqv? (cadr args) 0)
- (car args) ; (- x 0) -> x
- (if (equal? (car args) (cadr args))
- 0 ; (- x x)
- (if (and (pair? (car args))
- (eq? (caar args) '-)
- (> (length (car args)) 2))
- `(- ,@(cdar args) ,(cadr args)) ; (- (- x y) z) -> (- x y z) but leave (- (- x) ...)
- `(- , at args)))))))
- (else
- (let ((val (remove-all 0 (splice-if (lambda (x) (eq? x '+)) (cdr args)))))
- (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
- (let ((rats (collect-if list rational? val)))
- (if (> (length rats) 1)
- (let ((y (apply + rats)))
- (if (zero? y)
- (set! val (collect-if list (lambda (x) (not (number? x))) val))
- (set! val (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
- (set! val (cons (car args) val))
- (let ((first-arg (car args))
- (nargs (cdr val)))
+ ((eq? t1 (car arg1)) arg1)
+ (else arg2)))))
+
+ (when (and (hash-table-ref reversibles (car arg1))
+ (pair? (cddr arg1))
+ (null? (cdddr arg1))
+ (pair? (cddr arg2))
+ (null? (cdddr arg2))
+ (not (side-effect? arg2 env)) ; arg1 is hit in any case
+ (or (eq? (car arg1) (car arg2)) ; either ops are equal or
+ (let ((rf (hash-table-ref reversibles (car arg2)))) ; try reversed op for arg2
+ (and (eq? (car arg1) rf)
+ (set! arg2 (cons rf (reverse (cdr arg2)))))))
+ (or (equal? (caddr arg1) (cadr arg2)) ; (and (op x y) (op y z))
+ (equal? (cadr arg1) (caddr arg2)) ; (and (op x y) (op z x))
+ (and (memq (car arg1) '(= char=? string=? char-ci=? string-ci=?))
+ (or (equal? (cadr arg1) (cadr arg2))
+ (equal? (caddr arg1) (caddr arg2))))))
+ (let ((op1 (car arg1))
+ (arg1-1 (cadr arg1))
+ (arg1-2 (caddr arg1))
+ (arg2-1 (cadr arg2))
+ (arg2-2 (caddr arg2)))
+ (return
+ (cond ((equal? arg1-2 arg2-1) ; (and (op x y) (op y z)) -> (op x y z)
+ (if (equal? arg1-1 arg2-2)
+ (if (memq op1 '(= char=? string=? char-ci=? string-ci=?))
+ arg1
+ (and (memq op1 '(<= >= char<=? char>=? string<=? string>=?
+ char-ci<=? char-ci>=? string-ci<=? string-ci>=?))
+ `(,(case op1
+ ((>= <=) '=)
+ ((char<= char>=) 'char=?)
+ ((char-ci<= char-ci>=) 'char-ci=?)
+ ((string<= string>=) 'string=?)
+ ((string-ci<= string-ci>=) 'string-ci=?))
+ ,@(cdr arg1))))
+ (and (or (not (code-constant? arg1-1))
+ (not (code-constant? arg2-2))
+ ((symbol->value op1) arg1-1 arg2-2))
+ `(,op1 ,arg1-1 ,arg2-1 ,arg2-2))))
+
+ ((equal? arg1-1 arg2-2) ; (and (op x y) (op z x)) -> (op z x y)
+ (if (equal? arg1-2 arg2-1)
+ (and (memq op1 '(= char=? string=? char-ci=? string-ci=?))
+ arg1)
+ (and (or (not (code-constant? arg2-1))
+ (not (code-constant? arg1-2))
+ ((symbol->value op1) arg2-1 arg1-2))
+ `(,op1 ,arg2-1 ,arg1-1 ,arg1-2))))
+
+ ;; here we're restricted to equalities and we know arg1 != arg2
+ ((equal? arg1-1 arg2-1) ; (and (op x y) (op x z)) -> (op x y z)
+ (if (and (code-constant? arg1-2)
+ (code-constant? arg2-2))
+ (and ((symbol->value op1) arg1-2 arg2-2)
+ arg1)
+ `(,op1 ,arg1-1 ,arg1-2 ,arg2-2)))
+
+ ;; equalities again
+ ((and (code-constant? arg1-1)
+ (code-constant? arg2-1))
+ (and ((symbol->value op1) arg1-1 arg2-1)
+ arg1))
+
+ (else `(,op1 ,arg1-1 ,arg1-2 ,arg2-1))))))
+
+ ;; check some special cases
+ (when (and (or (equal? (cadr arg1) (cadr arg2))
+ (and (pair? (cddr arg2))
+ (null? (cdddr arg2))
+ (equal? (cadr arg1) (caddr arg2))))
+ (hash-table-ref bools1 (car arg1)))
+
+ (when (or (eq? (car arg1) 'zero?) ; perhaps rational? and integer? here -- not many hits
+ (eq? (car arg2) 'zero?))
+ (if (or (memq (car arg1) '(integer? rational? exact?))
+ (memq (car arg2) '(integer? rational? exact?)))
+ (return `(eqv? ,(cadr arg1) 0)))
+ (if (or (eq? (car arg1) 'inexact?)
+ (eq? (car arg2) 'inexact?))
+ (return `(eqv? ,(cadr arg1) 0.0))))
+
+ (when (memq (car arg2) '(< = > <= >= char-ci>=? char-ci<? char-ready? char<? char-ci=? char>?
+ char<=? char-ci>? char-ci<=? char>=? char=? string-ci<=? string=?
+ string-ci>=? string<? string-ci<? string-ci=? string-ci>? string>=? string<=? string>?
+ eqv? equal? eq? morally-equal?))
+
+ (when (and (eq? (car arg1) 'symbol?)
+ (memq (car arg2) '(eq? eqv? equal?))
+ (or (quoted-symbol? (cadr arg2))
+ (quoted-symbol? (caddr arg2))))
+ (return `(eq? ,@(cdr arg2))))
+
+ (when (and (eq? (car arg1) 'positive?)
+ (eq? (car arg2) '<)
+ (eq? (cadr arg1) (cadr arg2)))
+ (return `(< 0 ,(cadr arg1) ,(caddr arg2))))))
+
+ ;; this makes some of the code above redundant
+ (let ((rel (relsub arg1 arg2 'and env)))
+ (if (or (boolean? rel)
+ (pair? rel))
+ (return rel)))
+
+ ;; (and ... (not...))
+ (unless (eq? (car arg1) (car arg2))
+ (if (eq? (car arg1) 'not)
+ (let ((temp arg1))
+ (set! arg1 arg2)
+ (set! arg2 temp)))
+ (if (and (eq? (car arg2) 'not)
+ (pair? (cadr arg2))
+ (pair? (cdadr arg2))
+ (not (eq? (caadr arg2) 'let?))
+ (or (equal? (cadr arg1) (cadadr arg2))
+ (and (pair? (cddr arg1))
+ (equal? (caddr arg1) (cadadr arg2))))
+ (eq? (return-type (car arg1) env) 'boolean?)
+ (eq? (return-type (caadr arg2) env) 'boolean?))
+ (let ((t2 (and-not-redundant arg1 arg2)))
+ (when t2
+ (cond ((eq? t2 'contradictory) (return #f))
+ ((symbol? t2) (return `(,t2 ,@(cdr arg1))))
+ ((pair? t2) (return t2)))))))
+
+ (if (hash-table-ref bools (car arg1))
+ (let ((p (member (cadr arg1) (cdr arg2))))
+ (when p
+ (let ((sig (arg-signature (car arg2) env))
+ (pos (- (length arg2) (length p))))
+ (when (pair? sig)
+ (let ((arg-type (and (> (length sig) pos)
+ (list-ref sig pos))))
+ (unless (compatible? (car arg1) arg-type)
+ (let ((ln (and (positive? line-number)
+ (< line-number 100000)
+ line-number)))
+ (format outport "~NCin ~A~A, ~A is ~A, but ~A wants ~A"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ (if ln (format #f " (line ~D)" ln) "")
+ (cadr arg1)
+ (prettify-checker-unq (car arg1))
+ (car arg2)
+ (prettify-checker arg-type))))))))))
+
+ (when (and (eq? (car arg1) 'equal?) ; (and (equal? (car a1) (car a2)) (equal? (cdr a1) (cdr a2))) -> (equal? a1 a2)
+ (eq? (car arg2) 'equal?)
+ (pair? (cadr arg1))
+ (pair? (caddr arg1))
+ (pair? (cadr arg2))
+ (pair? (caddr arg2))
+ (eq? (caadr arg1) (caaddr arg1)))
+ (cond ((assq (caadr arg1)
+ '((car cdr #t)
+ (caar cdar car) (cadr cddr cdr)
+ (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar)
+ (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar)
+ (caaddr cdaddr caddr) (cadaar cddaar cdaar) (cadadr cddadr cdadr) (caddar cdddar cddar)))
+ => (lambda (x)
+ (if (and (eq? (caadr arg2) (cadr x))
+ (eq? (caaddr arg2) (cadr x))
+ (equal? (cadadr arg1) (cadadr arg2))
+ (equal? (cadr (caddr arg1)) (cadr (caddr arg2))))
+ (return (if (symbol? (caddr x))
+ `(equal? (,(caddr x) ,(cadadr arg1)) (,(caddr x) ,(cadr (caddr arg1))))
+ `(equal? ,(cadadr arg1) ,(cadr (caddr arg1))))))))))
+ )))
+
+ ;; len > 3 or nothing was caught above
+ (let ((nots 0)
+ (revers 0))
+ (if (every? (lambda (a) ; (and (not (pair? x)) (not (null? x))) -> (not (list? x))
+ (and (pair? a)
+ (if (eq? (car a) 'not)
+ (set! nots (+ nots 1))
+ (and (hash-table-ref notables (car a))
+ (set! revers (+ revers 1))))))
+ (cdr form))
+ (if (zero? revers)
+ (let ((nf (simplify-boolean `(or ,@(map cadr (cdr form))) () () env)))
+ (return (simplify-boolean `(not ,nf) () () env)))
+ (if (> nots revers)
+ (let ((nf (simplify-boolean `(or ,@(map (lambda (p)
+ (if (eq? (car p) 'not)
+ (cadr p)
+ `(,(hash-table-ref notables (car p)) ,@(cdr p))))
+ (cdr form)))
+ () () env)))
+ (return (simplify-boolean `(not ,nf) () () env)))))))
+
+ (if (every? (lambda (a)
+ (and (pair? a)
+ (eq? (car a) 'zero?)))
+ (cdr form))
+ (return `(= 0 ,@(map cadr (cdr form)))))
+
+ (let ((diff (apply and-redundants env (cdr form))))
+ (when diff
+ (if (null? (cdr diff))
+ (return (car diff)))
+ (return `(and , at diff))))
+ ;; now there are redundancies below (see subsumes?) but they assumed the tests were side-by-side
+
+ (let ((new-form ())
+ (retry #f))
+
+ (do ((exprs (cdr form) (cdr exprs)))
+ ((null? exprs)
+ (or (null? new-form) ; (and) -> #t
+ (let* ((nform (reverse new-form))
+ (newer-form (map (lambda (x cdr-x)
+ (if (and x (code-constant? x))
+ (values)
+ x))
+ nform (cdr nform))))
+ (return
+ (cond ((null? newer-form)
+ (car new-form))
+
+ ((and (eq? (car new-form) #t) ; trailing #t is dumb if next-to-last is boolean func
+ (pair? (cdr new-form))
+ (pair? (cadr new-form))
+ (symbol? (caadr new-form))
+ (eq? (return-type (caadr new-form) env) 'boolean?))
+ (if (null? (cdr newer-form))
+ (car newer-form)
+ `(and , at newer-form)))
+
+ (retry
+ (simplify-boolean `(and , at newer-form ,(car new-form)) () () env))
+
+ (else `(and , at newer-form ,(car new-form))))))))
+
+ (let* ((e (car exprs))
+ (val (classify e))
+ (old-form new-form))
+ (if (and (pair? val)
+ (memq (car val) '(and or not)))
+ (set! val (classify (set! e (simplify-boolean val () false env)))))
+
+ (if (not (or retry
+ (equal? e (car exprs))))
+ (set! retry #t))
+
+ ;; (and x1 x2 x1) is not reducible
+ ;; the final thing has to remain at the end, but can be deleted earlier if it can't short-circuit the evaluation,
+ ;; but if there are expressions following the first x1, we can't be sure that it is not
+ ;; protecting them:
+ ;; (and false-or-0 (display (list-ref lst false-or-0)) false-or-0)
+ ;; so I'll not try to optimize that case. But (and x x) is optimizable.
+
+ (cond ((eq? val #t)
+ (if (null? (cdr exprs)) ; (and x y #t) should not remove the #t
+ (if (or (and (pair? e)
+ (eq? (return-type (car e) env) 'boolean?))
+ (eq? e #t))
+ (set! new-form (cons val new-form))
+ (if (or (null? new-form)
+ (not (equal? e (car new-form))))
+ (set! new-form (cons e new-form))))
+ (if (and (not (eq? e #t))
+ (or (null? new-form)
+ (not (member e new-form))))
+ (set! new-form (cons e new-form)))))
+
+ ((not val) ; #f in 'and' ends the expression
+ (set! new-form (if (or (null? new-form)
+ (just-symbols? new-form))
+ '(#f)
+ (cons #f new-form))) ;was (append '(#f) new-form)))
+ (set! exprs '(#f)))
+
+ ((and (pair? e) ; if (and ...) splice into current
+ (eq? (car e) 'and))
+ (set! exprs (append e (cdr exprs))))
+
+ ((not (and (pair? e) ; (and ... (or ... 123) ...) -> splice out or
+ (pair? (cdr exprs))
+ (eq? (car e) 'or)
+ (pair? (cdr e))
+ (pair? (cddr e))
+ (cond ((list-ref e (- (length e) 1)) => code-constant?) ; (or ... #f)
+ (else #f))))
+ (if (not (and (pair? new-form)
+ (or (eq? val (car new-form)) ; omit repeated tests
+ (and (pair? val) ; and redundant tests
+ (hash-table-ref bools1 (car val))
+ (any? (lambda (p)
+ (and (pair? p)
+ (subsumes? (car val) (car p))
+ (equal? (cadr val) (cadr p))))
+ new-form)))))
+ (set! new-form (cons val new-form)))))
+
+ (if (and (not (eq? new-form old-form))
+ (pair? (cdr new-form)))
+ (let ((rel (relsub (car new-form) (cadr new-form) 'and env)))
+ ;; rel #f should halt everything as above, and it looks ugly in the output,
+ ;; but it never happens in real code
+ (if (or (pair? rel)
+ (boolean? rel))
+ (set! new-form (cons rel (cddr new-form)))))))))))))))))))))))))
+
+ (define (splice-if f lst)
+ (cond ((null? lst) ())
+ ((not (pair? lst)) lst)
+ ((and (pair? (car lst))
+ (f (caar lst)))
+ (append (splice-if f (cdar lst))
+ (splice-if f (cdr lst))))
+ (else (cons (car lst)
+ (splice-if f (cdr lst))))))
+
+ (define (simplify-numerics form env)
+ ;; this returns a form, possibly the original simplified
+ (let ((real-result? (lambda (op) (memq op '(imag-part real-part abs magnitude angle max min exact->inexact inexact
+ modulo remainder quotient lcm gcd))))
+ (rational-result? (lambda (op) (memq op '(rationalize inexact->exact exact))))
+ (integer-result? (lambda (op) (memq op '(logior lognot logxor logand numerator denominator floor round truncate ceiling ash)))))
+
+ (define (inverse-op op)
+ (case op
+ ((sin) 'asin) ((cos) 'acos) ((tan) 'atan) ((asin) 'sin) ((acos) 'cos) ((atan) 'tan)
+ ((sinh) 'asinh) ((cosh) 'acosh) ((tanh) 'atanh) ((asinh) 'sinh) ((acosh) 'cosh) ((atanh) 'tanh)
+ ((log) 'exp) ((exp) 'log)))
+
+ (define (just-rationals? form)
+ (or (null? form)
+ (rational? form)
+ (and (pair? form)
+ (rational? (car form))
+ (just-rationals? (cdr form)))))
+
+ (define (just-reals? form)
+ (or (null? form)
+ (real? form)
+ (and (pair? form)
+ (real? (car form))
+ (just-reals? (cdr form)))))
+
+ (define (just-integers? form)
+ (or (null? form)
+ (integer? form)
+ (and (pair? form)
+ (integer? (car form))
+ (just-integers? (cdr form)))))
+
+ (define (simplify-arg x)
+ (if (or (null? x) ; constants and the like look dumb if simplified
+ (not (proper-list? x))
+ (not (hash-table-ref no-side-effect-functions (car x)))
+ (var-member (car x) env))
+ x
+ (let ((f (simplify-numerics x env)))
+ (if (and (pair? f)
+ (just-rationals? f))
+ (catch #t
+ (lambda ()
+ (eval f))
+ (lambda ignore f))
+ f))))
+
+ (let* ((args (map simplify-arg (cdr form)))
+ (len (length args)))
+ (case (car form)
+
+ ((+)
+ (case len
+ ((0) 0)
+ ((1) (car args))
+ (else
+ (let ((val (remove-all 0 (splice-if (lambda (x) (eq? x '+)) args))))
+ (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
+ (let ((rats (collect-if list rational? val)))
+ (if (and (pair? rats)
+ (pair? (cdr rats)))
+ (let ((y (apply + rats)))
+ (set! val (if (zero? y)
+ (collect-if list (lambda (x) (not (number? x))) val)
+ (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
+
+ (if (any? (lambda (p) ; collect all + and - vals -> (- (+ ...) ...)
+ (and (pair? p)
+ (eq? (car p) '-)))
+ val)
+ (let ((plus ())
+ (minus ())
+ (c 0))
+ (for-each (lambda (p)
+ (if (not (and (pair? p)
+ (eq? (car p) '-)))
+ (if (rational? p)
+ (set! c (+ c p))
+ (set! plus (cons p plus)))
+ (if (null? (cddr p))
+ (if (rational? (cadr p))
+ (set! c (- c (cadr p)))
+ (set! minus (cons (cadr p) minus)))
+ (begin
+ (if (rational? (cadr p))
+ (set! c (+ c (cadr p)))
+ (set! plus (cons (cadr p) plus)))
+ (do ((p1 (cddr p) (cdr p1)))
+ ((null? p1))
+ (if (rational? (car p1))
+ (set! c (- c (car p1)))
+ (set! minus (cons (car p1) minus))))))))
+ val)
+ (simplify-numerics `(- (+ ,@(reverse plus) ,@(if (positive? c) (list c) ()))
+ ,@(reverse minus) ,@(if (negative? c) (list (abs c)) ()))
+ env))
+
+ (case (length val)
+ ((0) 0)
+ ((1) (car val)) ; (+ x) -> x
+ ((2)
+ (let ((arg1 (car val))
+ (arg2 (cadr val)))
+ (cond ((and (real? arg2) ; (+ x -1) -> (- x 1)
+ (negative? arg2)
+ (not (number? arg1)))
+ `(- ,arg1 ,(abs arg2)))
+
+ ((and (real? arg1) ; (+ -1 x) -> (- x 1)
+ (negative? arg1)
+ (not (number? arg2)))
+ `(- ,arg2 ,(abs arg1)))
+
+ ((and (pair? arg1)
+ (eq? (car arg1) '*) ; (+ (* a b) (* a c)) -> (* a (+ b c))
+ (pair? arg2)
+ (eq? (car arg2) '*)
+ (any? (lambda (a)
+ (member a (cdr arg2)))
+ (cdr arg1)))
+ (let ((times ())
+ (pluses ())
+ (rset (cdr arg2)))
+ (do ((p (cdr arg1) (cdr p)))
+ ((null? p)
+ ;(format *stderr* "~%pluses: ~A, times: ~A, rset: ~A~%" pluses times rset)
+ ;; times won't be () because we checked above for a match
+ ;; if pluses is (), arg1 is completely included in arg2
+ ;; if rset is (), arg2 is included in arg1
+ (simplify-numerics `(* ,@(reverse times)
+ (+ (* ,@(reverse (if (pair? pluses) pluses (list (if (null? pluses) 1 pluses)))))
+ (* , at rset)))
+ env))
+ (if (member (car p) rset)
+ (begin
+ (set! times (cons (car p) times))
+ (set! rset (remove (car p) rset)))
+ (set! pluses (cons (car p) pluses))))))
+
+ ((and (pair? arg1) (eq? (car arg1) '/) ; (+ (/ a b) (/ c b)) -> (/ (+ a c) b)
+ (pair? arg2) (eq? (car arg2) '/)
+ (pair? (cddr arg1)) (pair? (cddr arg2))
+ (equal? (cddr arg1) (cddr arg2)))
+ `(/ (+ ,(cadr arg1) ,(cadr arg2)) ,@(cddr arg1)))
+
+ (else `(+ , at val)))))
+ (else
+ `(+ , at val))))))))
+
+ ((*)
+ (case len
+ ((0) 1)
+ ((1) (car args))
+ (else
+ (let ((val (remove-all 1 (splice-if (lambda (x) (eq? x '*)) args))))
+ (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
+ (let ((rats (collect-if list rational? val)))
+ (if (and (pair? rats)
+ (pair? (cdr rats)))
+ (let ((y (apply * rats)))
+ (set! val (if (= y 1)
+ (collect-if list (lambda (x) (not (number? x))) val)
+ (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
+ (case (length val)
+ ((0) 1)
+ ((1) (car val)) ; (* x) -> x
+ ((2)
+ (let ((arg1 (car val))
+ (arg2 (cadr val)))
+
+ (cond ((just-rationals? val)
+ (let ((new-val (apply * val))) ; huge numbers here are less readable
+ (if (< (abs new-val) 1000000)
+ new-val
+ `(* , at val))))
+
+ ((memv 0 val) ; (* x 0) -> 0
+ 0)
+ ((memv -1 val)
+ `(- ,@(remove -1 val))) ; (* -1 x) -> (- x)
+
+ ((and (pair? arg1)
+ (pair? arg2))
+ (cond ((and (eq? (car arg1) '-) ; (* (- x) (- y)) -> (* x y)
+ (null? (cddr arg1))
+ (eq? (car arg2) '-)
+ (null? (cddr arg2)))
+ `(* ,(cadr arg1) ,(cadr arg2)))
+
+ ((and (pair? arg1) ; (* (/ x) (/ y)) -> (/ (* x y)) etc
+ (pair? arg2)
+ (eq? (car arg1) '/)
+ (eq? (car arg2) '/))
+ (if (null? (cddr arg1))
+ (if (null? (cddr arg2))
+ `(/ (* ,(cadr arg1) ,(cadr arg2)))
+ (if (equal? (cadr arg1) (cadr arg2))
+ `(/ ,(caddr arg2))
+ (simplify-numerics `(/ ,(cadr arg2) (* ,(cadr arg1) ,(caddr arg2))) env)))
+ (if (null? (cddr arg2))
+ (if (equal? (cadr arg1) (cadr arg2))
+ `(/ ,(caddr arg1))
+ (simplify-numerics `(/ ,(cadr arg1) (* ,(caddr arg1) ,(cadr arg2))) env))
+ (simplify-numerics `(/ (* ,(cadr arg1) ,(cadr arg2)) (* ,@(cddr arg1) ,@(cddr arg2))) env))))
+
+ ((and (= (length arg1) 3)
+ (equal? (cdr arg1) (cdr arg2))
+ (case (car arg1)
+ ((gcd) (eq? (car arg2) 'lcm))
+ ((lcm) (eq? (car arg2) 'gcd))
+ (else #f)))
+ `(abs (* ,@(cdr arg1)))) ; (* (gcd a b) (lcm a b)) -> (abs (* a b)) but only if 2 args?
+
+ ((and (eq? (car arg1) 'exp) ; (* (exp a) (exp b)) -> (exp (+ a b))
+ (eq? (car arg2) 'exp))
+ `(exp (+ ,(cadr arg1) ,(cadr arg2))))
+
+ (else `(* , at val))))
+
+ ((and (pair? arg1) ; (* (inexact->exact x) 2.0) -> (* x 2.0)
+ (memq (car arg1) '(exact->inexact inexact))
+ (number? arg2)
+ (not (rational? arg2)))
+ `(* ,(cadr arg1) ,arg2))
+
+ ((and (pair? arg2) ; (* 2.0 (inexact x)) -> (* 2.0 x)
+ (memq (car arg2) '(exact->inexact inexact))
+ (number? arg1)
+ (not (rational? arg1)))
+ `(* ,arg1 ,(cadr arg2)))
+
+ ((and (number? arg1) ; (* 2 (random 3.0)) -> (random 6.0)
+ (pair? arg2)
+ (eq? (car arg2) 'random)
+ (number? (cadr arg2))
+ (not (rational? (cadr arg2))))
+ `(random ,(* arg1 (cadr arg2))))
+
+ (else `(* , at val)))))
+ (else
+ (cond ((just-rationals? val)
+ (let ((new-val (apply * val))) ; huge numbers here are less readable
+ (if (< (abs new-val) 1000000)
+ new-val
+ `(* , at val))))
+
+ ((memv 0 val) ; (* x 0 2) -> 0
+ 0)
+
+ ((memv -1 val)
+ `(- (* ,@(remove -1 val)))) ; (* -1 x y) -> (- (* x y))
+
+ ((any? (lambda (p) ; collect * and / vals -> (/ (* ...) ...)
+ (and (pair? p)
+ (eq? (car p) '/)))
+ val)
+ (let ((mul ())
+ (div ()))
+ (for-each (lambda (p)
+ (if (not (and (pair? p)
+ (eq? (car p) '/)))
+ (set! mul (cons p mul))
+ (if (null? (cddr p))
+ (set! div (cons (cadr p) div))
+ (begin
+ (set! mul (cons (cadr p) mul))
+ (set! div (append (cddr p) div))))))
+ val)
+ (simplify-numerics `(/ (* ,@(reverse mul)) ,@(reverse div)) env)))
+
+ (else `(* , at val)))))))))
+
+ ((-)
+ (case len
+ ((0) form)
+ ((1) ; negate
+ (if (number? (car args))
+ (- (car args))
+ (if (not (list? (car args)))
+ `(- , at args)
+ (case (length (car args))
+ ((2) (if (eq? (caar args) '-)
+ (cadar args) ; (- (- x)) -> x
+ `(- , at args)))
+ ((3) (if (eq? (caar args) '-)
+ `(- ,(caddar args) ,(cadar args)) ; (- (- x y)) -> (- y x)
+ `(- , at args)))
+ (else `(- , at args))))))
+ ((2)
+ (let ((arg1 (car args))
+ (arg2 (cadr args)))
+ (cond ((just-rationals? args) (apply - args)) ; (- 3 2) -> 1
+
+ ((eqv? arg1 0) `(- ,arg2)) ; (- 0 x) -> (- x)
+
+ ((eqv? arg2 0) arg1) ; (- x 0) -> x
+
+ ((equal? arg1 arg2) 0) ; (- x x) -> 0
+
+ ((and (pair? arg2)
+ (eq? (car arg2) '-)
+ (pair? (cdr arg2)))
+ (if (null? (cddr arg2))
+ `(+ ,arg1 ,(cadr arg2)) ; (- x (- y)) -> (+ x y)
+ (simplify-numerics `(- (+ ,arg1 ,@(cddr arg2)) ,(cadr arg2)) env))) ; (- x (- y z)) -> (- (+ x z) y)
+
+ ((and (pair? arg2) ; (- x (+ y z)) -> (- x y z)
+ (eq? (car arg2) '+))
+ (simplify-numerics `(- ,arg1 ,@(cdr arg2)) env))
+
+ ((and (pair? arg1) ; (- (- x y) z) -> (- x y z)
+ (eq? (car arg1) '-))
+ (if (> (length arg1) 2)
+ `(- ,@(cdr arg1) ,arg2)
+ (simplify-numerics `(- (+ ,(cadr arg1) ,arg2)) env))) ; (- (- x) y) -> (- (+ x y))
+
+ ((and (pair? arg2) ; (- x (truncate x)) -> (remainder x 1)
+ (eq? (car arg2) 'truncate)
+ (equal? arg1 (cadr arg2)))
+ `(remainder ,arg1 1))
+
+ ((and (real? arg2) ; (- x -1) -> (+ x 1)
+ (negative? arg2)
+ (not (number? arg1)))
+ `(+ ,arg1 ,(abs arg2)))
+
+ (else `(- , at args)))))
+ (else
+ (if (just-rationals? args)
+ (apply - args)
+ (let ((val (remove-all 0 (splice-if (lambda (x) (eq? x '+)) (cdr args)))))
+ (if (every? (lambda (x) (or (not (number? x)) (rational? x))) val)
+ (let ((rats (collect-if list rational? val)))
+ (if (and (pair? rats)
+ (pair? (cdr rats)))
+ (let ((y (apply + rats)))
+ (set! val (if (zero? y)
+ (collect-if list (lambda (x) (not (number? x))) val)
+ (cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
+ (set! val (cons (car args) val))
+ (let ((first-arg (car args))
+ (nargs (cdr val)))
(if (member first-arg nargs)
(begin
(set! nargs (remove first-arg nargs)) ; remove once
(set! first-arg 0)))
- (if (null? nargs)
- first-arg ; (- x 0 0 0)?
- (if (and (eqv? first-arg 0)
- (= (length nargs) 1))
- (if (number? (car nargs))
- (- (car nargs))
- `(- ,(car nargs))) ; (- 0 0 0 x)?
- `(- ,@(cons first-arg nargs)))))))))
-
- ((/)
- (case len
- ((0) form)
- ((1) ; invert
- (if (number? (car args))
- (if (zero? (car args))
- `(/ ,(car args))
- (/ (car args)))
- (if (pair? (car args))
- (if (and (= (length (car args)) 2)
- (eq? (caar args) '/))
- (cadar args)
- `(/ , at args))
- `(/ , at args))))
- ((2)
- (if (and (just-rationals? args)
- (not (zero? (cadr args))))
- (apply / args) ; including (/ 0 12) -> 0
- (let ((arg1 (car args))
- (arg2 (cadr args)))
- (if (eqv? arg1 1) ; (/ 1 x) -> (/ x)
- `(/ ,arg2)
- (if (eqv? arg2 1)
- arg1 ; (/ x 1) -> x
- (if (and (pair? arg1) ; (/ (log x) (log y)) -> (log x y)
- (= (length arg1) 2)
- (pair? arg2)
- (= (length arg2) 2)
- (eq? (car arg1) 'log)
- (eq? (car arg2) 'log))
- `(log ,(cadr arg1) ,(cadr arg2))
- (if (and (pair? arg1)
- (eq? (car arg1) '/)
- (pair? arg2)
- (eq? '/ (car arg2)))
- (let ((a1 (if (null? (cddr arg1)) `(/ 1 ,(cadr arg1)) arg1))
- (a2 (if (null? (cddr arg2)) `(/ 1 ,(cadr arg2)) arg2)))
- (simplify-numerics `(/ (* ,(cadr a1) ,@(cddr a2)) (* ,@(cddr a1) ,(cadr a2))) env))
- `(/ , at args))))))))
-
- (else
- (if (and (just-rationals? args)
- (not (memv 0 (cdr args)))
- (not (memv 0.0 (cdr args))))
- (apply / args)
- (let ((nargs ; (/ x a (* b 1 c) d) -> (/ x a b c d) but not short cases
- (remove-all 1 (splice-if (lambda (x) (eq? x '*)) (cdr args)))))
- (if (null? nargs) ; (/ x 1 1) -> x
- (car args)
- `(/ ,@(cons (car args) nargs))))))))
-
- ((sin cos asin acos sinh cosh tanh asinh acosh atanh exp)
- (if (= len 1)
- (if (and (pair? (car args))
- (= (length (car args)) 2)
- (eq? (caar args) (inverse-op (car form))))
- (cadar args)
- (if (eqv? (car args) 0)
- (case (car form)
- ((sin asin sinh asinh tanh atanh) 0)
- ((exp cos cosh) 1)
- (else `(,(car form) , at args)))
- (if (and (eq? (car form) 'cos)
- (pair? (car args))
- (eq? (caar args) '-)
- (null? (cddar args)))
- `(cos ,(cadar args))
- (if (eq? (car args) 'pi)
- (case (car form)
- ((sin) 0.0)
- ((cos) 1.0)
- (else `(,(car form) , at args)))
- (if (eqv? (car args) 0.0)
- (apply (symbol->value (car form)) '(0.0))
- (if (and (eq? (car form) 'exp) ; (exp (* a (log b))) -> (expt b a)
- (pair? (car args))
- (eq? (caar args) '*))
- (let ((targ (cdar args)))
- (if (= (length targ) 2)
- (if (and (pair? (car targ))
- (eq? (caar targ) 'log)
- (pair? (cdar targ))
- (null? (cddar targ)))
- `(expt ,(cadar targ) ,(cadr targ))
- (if (and (pair? (cadr targ))
- (eq? (caadr targ) 'log)
- (pair? (cdadr targ))
- (null? (cddadr targ)))
- `(expt ,(cadadr targ) ,(car targ))
- `(,(car form) , at args)))
- `(,(car form) , at args)))
- `(,(car form) , at args)))))))
- `(,(car form) , at args)))
-
- ((log)
- (if (pair? args)
- (if (eqv? (car args) 1)
- 0
- (if (and (= len 1)
- (pair? (car args))
- (= (length (car args)) 2)
- (eq? (caar args) 'exp))
- (cadar args)
- (if (and (= len 2)
- (equal? (car args) (cadr args)))
- (if (integer? (car args))
- 1
- 1.0)
- `(log , at args))))
- form))
-
- ((sqrt)
- (if (pair? args)
- (if (and (rational? (car args))
- (= (car args) (* (sqrt (car args)) (sqrt (car args)))))
- (sqrt (car args)) ; don't collapse (sqrt (* a a)), a=-1 for example
- `(sqrt , at args))
- form))
-
- ((floor round ceiling truncate)
- (if (= len 1)
- (if (number? (car args))
- (catch #t (lambda ()
- (apply (symbol->value (car form)) args))
- (lambda any
- `(,(car form) , at args)))
- (if (and (pair? (car args))
- (integer-result? (caar args)))
- (car args)
- `(,(car form) , at args)))
- form))
-
- ((abs magnitude)
- (if (= len 1)
- (if (and (pair? (car args))
- (memq (caar args) '(abs magnitude denominator)))
- (car args)
- (if (rational? (car args))
- (abs (car args))
- (if (and (pair? (car args)) ; (abs (modulo x 2)) -> (modulo x 2)
- (eq? (caar args) 'modulo)
- (= (length (car args)) 3)
- (number? (caddar args))
- (positive? (caddar args)))
- (car args)
- (if (and (pair? (car args)) ; (abs (- x)) -> (abs x)
- (eq? (caar args) '-)
- (pair? (cdar args))
- (null? (cddar args)))
- `(,(car form) ,(cadar args))
- `(,(car form) , at args)))))
- form))
-
- ((imag-part)
- (if (= len 1)
- (if (or (real? (car args))
- (and (pair? (car args))
- (real-result? (caar args))))
- 0.0
- `(imag-part , at args))
- form))
-
- ((real-part)
- (if (= len 1)
- (if (or (real? (car args))
- (and (pair? (car args))
- (real-result? (caar args))))
- (car args)
- `(real-part , at args))
- form))
-
- ((denominator)
- (if (= len 1)
- (if (or (integer? (car args))
- (and (pair? (car args))
- (integer-result? (caar args))))
- 1
- `(denominator ,(car args)))
- form))
-
- ((numerator)
- (if (= len 1)
- (if (or (integer? (car args))
- (and (pair? (car args))
- (integer-result? (caar args))))
- (car args)
- (if (rational? (car args))
- (numerator (car args))
- `(numerator ,(car args))))
- form))
-
- ((random)
- (if (and (= len 1)
- (number? (car args)))
- (if (and (integer? (car args))
- (= (car args) 0))
- 0
- (if (morally-equal? (car args) 0.0)
- 0.0
- `(random , at args)))
- `(random , at args)))
- ;; what about (* 2.0 (random 1.0)) and the like?
- ;; this is trickier than it appears: (* 2.0 (random 3)) etc
-
- ((complex)
- (if (and (= len 2)
- (morally-equal? (cadr args) 0.0)) ; morally so that 0 matches
- (car args)
- `(complex , at args)))
+ (cond ((null? nargs) first-arg) ; (- x 0 0 0)?
+
+ ((eqv? first-arg 0)
+ (if (null? (cdr nargs))
+ (if (number? (car nargs))
+ (- (car nargs))
+ `(- ,(car nargs))) ; (- 0 0 0 x)?
+ `(- (+ , at nargs)))) ; (- 0 z y) -> (- (+ x y))
+
+ ((not (and (pair? (car args))
+ (eq? (caar args) '-)))
+ `(- ,@(cons first-arg nargs)))
+
+ ((> (length (car args)) 2)
+ (simplify-numerics `(- ,@(cdar args) ,@(cdr args)) env))
+
+ (else (simplify-numerics `(- (+ ,(cadar args) ,@(cdr args))) env)))))))))
+
+ ((/)
+ (case len
+ ((0) form)
+ ((1) ; invert
+ (if (number? (car args))
+ (if (zero? (car args))
+ `(/ ,(car args))
+ (/ (car args)))
+ (if (and (pair? (car args)) ; (/ (/ x)) -> x
+ (= (length (car args)) 2)
+ (eq? (caar args) '/))
+ (cadar args)
+ `(/ , at args))))
+ ((2)
+ (if (and (just-rationals? args)
+ (not (zero? (cadr args))))
+ (apply / args) ; including (/ 0 12) -> 0
+ (let ((arg1 (car args))
+ (arg2 (cadr args)))
+ (cond ((eqv? arg1 1) ; (/ 1 x) -> (/ x)
+ `(/ ,arg2))
+
+ ((eqv? arg2 1) ; (/ x 1) -> x
+ arg1)
+
+ ((and (pair? arg1) ; (/ (/ a b) c) -> (/ a b c)
+ (eq? (car arg1) '/)
+ (pair? (cddr arg1))
+ (not (and (pair? arg2)
+ (eq? (car arg2) '/))))
+ `(/ ,(cadr arg1) ,@(cddr arg1) ,arg2))
+
+ ((and (pair? arg1) ; (/ (/ a) (/ b)) -> (/ b a)??
+ (eq? (car arg1) '/)
+ (pair? arg2)
+ (eq? '/ (car arg2)))
+ (let ((a1 (if (null? (cddr arg1)) `(/ 1 ,(cadr arg1)) arg1))
+ (a2 (if (null? (cddr arg2)) `(/ 1 ,(cadr arg2)) arg2)))
+ (simplify-numerics `(/ (* ,(cadr a1) ,@(cddr a2)) (* ,@(cddr a1) ,(cadr a2))) env)))
+
+ ((and (pair? arg2)
+ (eq? (car arg2) '*)
+ (not (side-effect? arg1 env))
+ (member arg1 (cdr arg2)))
+ (let ((n (remove arg1 (cdr arg2))))
+ (if (and (pair? n) (null? (cdr n)))
+ `(/ , at n) ; (/ x (* y x)) -> (/ y)
+ `(/ 1 , at n)))) ; (/ x (* y x z)) -> (/ 1 y z)
+
+ ((and (pair? arg2) ; (/ c (/ a b)) -> (/ (* c b) a)
+ (eq? (car arg2) '/))
+ (cond ((null? (cddr arg2))
+ `(* ,arg1 ,(cadr arg2))) ; ignoring divide by zero here (/ x (/ y)) -> (* x y)
+ ((eqv? (cadr arg2) 1)
+ `(* ,arg1 ,@(cddr arg2))) ; (/ x (/ 1 y z)) -> (* x y z) -- these never actually happen
+ ((not (pair? (cddr arg2)))
+ `(/ , at args)) ; no idea...
+ ((and (rational? arg1)
+ (rational? (cadr arg2))
+ (null? (cdddr arg2)))
+ (let ((val (/ arg1 (cadr arg2))))
+ (if (= val 1)
+ (caddr arg2)
+ (if (= val -1)
+ `(- ,(caddr arg2))
+ `(* ,val ,(caddr arg2))))))
+ (else `(/ (* ,arg1 ,@(cddr arg2)) ,(cadr arg2)))))
+#|
+ ;; can't decide about this -- result usually looks cruddy
+ ((and (pair? arg2) ; (/ x (* y z)) -> (/ x y z)
+ (eq? (car arg2) '*))
+ `(/ ,arg1 ,@(cdr arg2)))
+|#
+ ((and (pair? arg1) ; (/ (log x) (log y)) -> (log x y)
+ (pair? arg2)
+ (= (length arg1) (length arg2) 2)
+ (eq? (car arg1) 'log)
+ (eq? (car arg2) 'log)) ; other possibilities here don't happen
+ `(log ,(cadr arg1) ,(cadr arg2)))
+
+ ((and (pair? arg1) ; (/ (inexact x) 2.0) -> (/ x 2.0)
+ (memq (car arg1) '(exact->inexact inexact))
+ (number? arg2)
+ (not (rational? arg2)))
+ `(/ ,(cadr arg1) ,arg2))
+
+ ((and (pair? arg2) ; (/ 2.0 (inexact x)) -> (/ 2.0 x)
+ (memq (car arg2) '(exact->inexact inexact))
+ (number? arg1)
+ (not (rational? arg1)))
+ `(/ ,arg1 ,(cadr arg2)))
+
+ ((and (pair? arg1) ; (/ (- x) (- y)) -> (/ x y)
+ (pair? arg2)
+ (eq? (car arg1) '-)
+ (eq? (car arg2) '-)
+ (= (length arg1) (length arg2) 2))
+ `(/ ,(cadr arg1) ,(cadr arg2)))
+
+ (else `(/ , at args))))))
- ((rationalize lognot ash modulo remainder quotient)
- (if (just-rationals? args)
- (catch #t ; catch needed here for things like (ash 2 64)
- (lambda ()
- (apply (symbol->value (car form)) args))
- (lambda ignore
- `(,(car form) , at args))) ; use this form to pick up possible arg changes
- `(,(car form) , at args)))
-
- ((expt)
- (if (= len 2)
- (if (and (eqv? (car args) 0)
- (not (eqv? (cadr args) 0)))
- 0
- (if (and (eqv? (cadr args) 0)
- (not (eqv? (car args) 0)))
- 1
- (if (eqv? (car args) 1)
- 1
- (if (eqv? (cadr args) 1)
- (car args)
- (if (eqv? (cadr args) -1)
- `(/ ,(car args))
- (if (just-rationals? args)
- (catch #t
- (lambda ()
- (let ((val (apply expt args)))
- (if (integer? val)
- val
- `(expt , at args))))
- (lambda args
- `(expt , at args)))
- `(expt , at args)))))))
- form))
-
- ((angle)
- (if (pair? args)
- (if (eqv? (car args) -1)
- 'pi
- (if (or (morally-equal? (car args) 0.0)
- (eq? (car args) 'pi))
- 0.0
- `(angle , at args)))
- form))
-
- ((atan)
- (if (and (= len 1)
- (pair? (car args))
- (= (length (car args)) 3)
- (eq? (caar args) '/))
- `(atan ,@(cdar args))
- `(atan , at args)))
-
- ((inexact->exact)
- (if (= len 1)
- (if (or (rational? (car args))
- (and (pair? (car args))
- (or (rational-result? (caar args))
- (integer-result? (caar args)))))
- (car args)
- (if (number? (car args))
- (catch #t (lambda () (inexact->exact (car args))) (lambda any `(inexact->exact , at args)))
- `(inexact->exact , at args)))
- form))
-
- ((logior)
- (set! args (remove-duplicates (remove-all 0 (splice-if (lambda (x) (eq? x 'logior)) args))))
- (if (every? (lambda (x) (or (not (number? x)) (integer? x))) args)
- (let ((rats (collect-if list integer? args)))
- (if (> (length rats) 1)
- (let ((y (apply logior rats)))
- (if (zero? y)
- (set! args (collect-if list (lambda (x) (not (number? x))) args))
- (set! args (cons y (collect-if list (lambda (x) (not (number? x))) args))))))))
- (if (null? args) ; (logior) -> 0
- 0
- (if (null? (cdr args)) ; (logior x) -> x
- (car args)
- (if (memv -1 args)
- -1
- (if (just-integers? args)
- (apply logior args)
- `(logior , at args))))))
-
- ((logand)
- (set! args (remove-duplicates (remove-all -1 (splice-if (lambda (x) (eq? x 'logand)) args))))
- (if (every? (lambda (x) (or (not (number? x)) (integer? x))) args)
- (let ((rats (collect-if list integer? args)))
- (if (> (length rats) 1)
- (let ((y (apply logand rats)))
- (if (= y -1)
- (set! args (collect-if list (lambda (x) (not (number? x))) args))
- (set! args (cons y (collect-if list (lambda (x) (not (number? x))) args))))))))
- (if (null? args)
- -1
- (if (null? (cdr args)) ; (logand x) -> x
- (car args)
- (if (memv 0 args)
- 0
- (if (just-integers? args)
- (apply logand args)
- `(logand , at args))))))
- ;; (logand 1 (logior 2 x)) -> (logand 1 x)?
- ;; (logand 1 (logior 1 x)) -> 1
- ;; (logand 3 (logior 1 x))?
- ;; similarly for (logior...(logand...))
-
- ((logxor)
- (set! args (splice-if (lambda (x) (eq? x 'logxor)) args)) ; is this correct??
- (if (null? args)
- 0
- (if (null? (cdr args)) ; (logxor x) -> x??
- (car args)
- (if (just-integers? args)
- (apply logxor args)
- (if (and (= len 2)
- (equal? (car args) (cadr args)))
- 0
- `(logxor , at args))))))
+ (else
+ (if (and (just-rationals? args)
+ (not (memv 0 (cdr args)))
+ (not (memv 0.0 (cdr args))))
+ (apply / args)
+ (let ((nargs ; (/ x a (* b 1 c) d) -> (/ x a b c d)
+ (remove-all 1 (splice-if (lambda (x) (eq? x '*)) (cdr args)))))
+ (if (null? nargs) ; (/ x 1 1) -> x
+ (car args)
+ (if (and (member (car args) (cdr args))
+ (not (side-effect? (car args) env)))
+ (let ((n (remove (car args) (cdr args))))
+ (if (null? (cdr n))
+ `(/ , at n) ; (/ x y x) -> (/ y)
+ `(/ 1 , at n))) ; (/ x y x z) -> (/ 1 y z)
+ `(/ ,@(cons (car args) nargs)))))))))
+
+ ((sin cos tan asin acos sinh cosh tanh asinh acosh atanh exp)
+ (cond ((not (= len 1))
+ `(,(car form) , at args))
+ ((and (pair? (car args)) ; (sin (asin x)) -> x
+ (= (length (car args)) 2)
+ (eq? (caar args) (inverse-op (car form))))
+ (cadar args))
+ ((eqv? (car args) 0) ; (sin 0) -> 0
+ (case (car form)
+ ((sin asin sinh asinh tan tanh atanh) 0)
+ ((exp cos cosh) 1)
+ (else `(,(car form) , at args))))
+ ((and (eq? (car form) 'cos) ; (cos (- x)) -> (cos x)
+ (pair? (car args))
+ (eq? (caar args) '-)
+ (null? (cddar args)))
+ `(cos ,(cadar args)))
+ ((eq? (car args) 'pi) ; (sin pi) -> 0.0
+ (case (car form)
+ ((sin tan) 0.0)
+ ((cos) 1.0)
+ (else `(,(car form) , at args))))
+ ((eqv? (car args) 0.0) ; (sin 0.0) -> 0.0
+ ((symbol->value (car form)) 0.0))
+ ((and (eq? (car form) 'acos) ; (acos -1) -> pi
+ (eqv? (car args) -1))
+ 'pi)
+ ((and (eq? (car form) 'exp) ; (exp (* a (log b))) -> (expt b a)
+ (pair? (car args))
+ (eq? (caar args) '*))
+ (let ((targ (cdar args)))
+ (cond ((not (= (length targ) 2))
+ `(,(car form) , at args))
+ ((and (pair? (car targ))
+ (eq? (caar targ) 'log)
+ (pair? (cdar targ))
+ (null? (cddar targ)))
+ `(expt ,(cadar targ) ,(cadr targ)))
+ ((and (pair? (cadr targ))
+ (eq? (caadr targ) 'log)
+ (pair? (cdadr targ))
+ (null? (cddadr targ)))
+ `(expt ,(cadadr targ) ,(car targ)))
+ (else `(,(car form) , at args)))))
+ (else `(,(car form) , at args))))
+
+ ((log)
+ (cond ((not (pair? args)) form)
+ ((eqv? (car args) 1) 0) ; (log 1 ...) -> 0
+ ((and (= len 1) ; (log (exp x)) -> x
+ (pair? (car args))
+ (= (length (car args)) 2)
+ (eq? (caar args) 'exp))
+ (cadar args))
+ ((not (and (= len 2) ; (log x x) -> 1.0
+ (equal? (car args) (cadr args))))
+ `(log , at args))
+ ((integer? (car args)) 1)
+ (else 1.0)))
+
+ ((sqrt)
+ (if (not (pair? args))
+ form
+ (if (and (rational? (car args))
+ (rational? (sqrt (car args)))
+ (= (car args) (* (sqrt (car args)) (sqrt (car args)))))
+ (sqrt (car args)) ; don't collapse (sqrt (* a a)), a=-1 for example, or -1-i -> 1+i whereas 1-i -> 1-i etc
+ `(sqrt , at args))))
+
+ ((floor round ceiling truncate)
+ (cond ((not (= len 1))
+ form)
+
+ ((number? (car args))
+ (catch #t
+ (lambda () (apply (symbol->value (car form)) args))
+ (lambda any `(,(car form) , at args))))
+
+ ((not (pair? (car args)))
+ `(,(car form) , at args))
+
+ ((or (integer-result? (caar args))
+ (and (eq? (caar args) 'random)
+ (integer? (cadar args))))
+ (car args))
+
+ ((memq (caar args) '(inexact->exact exact))
+ `(,(car form) ,(cadar args)))
+
+ ((memq (caar args) '(* + / -)) ; maybe extend this list
+ `(,(car form) (,(caar args) ,@(map (lambda (p)
+ (if (and (pair? p)
+ (memq (car p) '(inexact->exact exact)))
+ (cadr p)
+ p))
+ (cdar args)))))
+ ((and (eq? (caar args) 'random)
+ (eq? (car form) 'floor)
+ (float? (cadar args))
+ (= (floor (cadar args)) (cadar args)))
+ `(random ,(floor (cadar args))))
+
+ (else `(,(car form) , at args))))
+
+ ((abs magnitude)
+ (cond ((not (= len 1))
+ form)
+ ((and (pair? (car args)) ; (abs (abs x)) -> (abs x)
+ (hash-table-ref non-negative-ops (caar args)))
+ (car args))
+ ((rational? (car args))
+ (abs (car args)))
+ ((and (pair? (car args)) ; (abs (modulo x 2)) -> (modulo x 2)
+ (memq (caar args) '(modulo random))
+ (= (length (car args)) 3)
+ (number? (caddar args))
+ (positive? (caddar args)))
+ (car args))
+ ((and (pair? (car args)) ; (abs (- x)) -> (abs x)
+ (eq? (caar args) '-)
+ (pair? (cdar args))
+ (null? (cddar args)))
+ `(,(car form) ,(cadar args)))
+ (else `(,(car form) , at args))))
+
+ ((imag-part)
+ (if (not (= len 1))
+ form
+ (if (or (real? (car args))
+ (and (pair? (car args))
+ (real-result? (caar args))))
+ 0.0
+ `(imag-part , at args))))
+
+ ((real-part)
+ (if (not (= len 1))
+ form
+ (if (or (real? (car args))
+ (and (pair? (car args))
+ (real-result? (caar args))))
+ (car args)
+ `(real-part , at args))))
+
+ ((denominator)
+ (if (not (= len 1))
+ form
+ (if (or (integer? (car args))
+ (and (pair? (car args))
+ (integer-result? (caar args))))
+ 1
+ `(denominator ,(car args)))))
+
+ ((numerator)
+ (cond ((not (= len 1))
+ form)
+ ((or (integer? (car args))
+ (and (pair? (car args))
+ (integer-result? (caar args))))
+ (car args))
+ ((rational? (car args))
+ (numerator (car args)))
+ (else `(numerator ,(car args)))))
+
+ ((random)
+ (cond ((not (and (= len 1)
+ (number? (car args))))
+ `(random , at args))
+ ((eqv? (car args) 0)
+ 0)
+ ((morally-equal? (car args) 0.0)
+ 0.0)
+ (else `(random , at args))))
+
+ ((complex make-rectangular)
+ (if (and (= len 2)
+ (morally-equal? (cadr args) 0.0)) ; morally so that 0 matches
+ (car args)
+ `(complex , at args)))
+
+ ((make-polar)
+ (if (and (= len 2)
+ (morally-equal? (cadr args) 0.0))
+ (car args)
+ `(make-polar , at args)))
+
+ ((rationalize lognot ash modulo remainder quotient)
+ (cond ((just-rationals? args)
+ (catch #t ; catch needed here for things like (ash 2 64)
+ (lambda ()
+ (apply (symbol->value (car form)) args))
+ (lambda ignore
+ `(,(car form) , at args)))) ; use this form to pick up possible arg changes
- ((gcd)
- (set! args (remove-duplicates (splice-if (lambda (x) (eq? x 'gcd)) args)))
- (if (null? args)
- 0
- ;; here and in lcm, if just 1 arg -> (abs arg)
- (if (memv 1 args)
- 1
- (if (just-integers? args)
- (catch #t ; maybe (gcd -9223372036854775808 -9223372036854775808)
- (lambda ()
- (apply gcd args))
- (lambda ignore
- `(gcd , at args)))
- (if (null? (cdr args))
- `(abs ,(car args))
- (if (eqv? (car args) 0)
- `(abs ,(cadr args))
- (if (eqv? (cadr args) 0)
- `(abs ,(car args))
- `(gcd , at args))))))))
-
- ((lcm)
- (set! args (remove-duplicates (splice-if (lambda (x) (eq? x 'lcm)) args)))
- (if (null? args)
- 1
- (if (memv 0 args)
- 0
- (if (just-integers? args)
- (catch #t
- (lambda ()
- (apply lcm args))
- (lambda ignore
- `(lcm , at args)))
- (if (null? (cdr args))
- `(abs ,(car args))
- `(lcm , at args))))))
-
- ((max min)
- (if (pair? args)
- (begin
- (set! args (remove-duplicates (splice-if (lambda (x) (eq? x (car form))) args)))
- (if (= len 1)
- (car args)
- (if (just-reals? args)
- (apply (symbol->value (car form)) args)
- (let ((nums (collect-if list number? args))
- (other (if (eq? (car form) 'min) 'max 'min)))
- (if (and (pair? nums)
- (just-reals? nums)) ; non-real case checked elsewhere (later)
- (let ((relop (if (eq? (car form) 'min) >= <=)))
- (if (> (length nums) 1)
- (set! nums (list (apply (symbol->value (car form)) nums))))
- (let ((new-args (append nums (collect-if list (lambda (x) (not (number? x))) args))))
- (let ((c1 (car nums)))
- (set! new-args (collect-if list (lambda (x)
- (or (not (pair? x))
- (<= (length x) 2)
- (not (eq? (car x) other))
- (let ((c2 (find-if number? (cdr x))))
- (or (not c2)
- (relop c1 c2)))))
- new-args)))
- (if (< (length new-args) (length args))
- (set! args new-args)))))
- ;; if (max c1 (min c2 . args1) . args2) where (>= c1 c2) -> (max c1 . args2)
- ;; if (min c1 (max c2 . args1) . args2) where (<= c1 c2) -> (min c1 . args2)
-
- ;; there are more such cases: (max x (min x 3)) -> x and (min x (max x c)) -> x
- ;; (max a b) is (- (min (- a) (- b))), but that doesn't help here -- the "-" gets in our way
- (if (null? (cdr args)) ; (max (min x 3) (min x 3)) -> (max (min x 3)) -> (min x 3)
- (car args)
- (if (and (null? (cddr args)) ; (max|min x (min|max x ...) -> x
- (or (and (pair? (car args))
- (eq? (caar args) other)
- (symbol? (cadr args)) ; actually this is probably not needed, but I want to avoid (random ...)
- ;; perhaps instead use not min/max
- (member (cadr args) (car args)))
- (and (pair? (cadr args))
- (eq? (caadr args) other)
- (symbol? (car args))
- (member (car args) (cadr args)))))
- ((if (pair? (car args)) cadr car) args)
- `(,(car form) , at args)))))))
- form))
-
- (else `(,(car form) , at args))))))
-
-
- (define (->eqf x)
- (case x
- ((char?) '(eqv? char=?))
- ((integer? rational? real? number? complex?) '(eqv? =))
- ((symbol? keyword? boolean?)'(eq? eq?))
- ((string? byte-vector?) '(equal? string=?))
- ((null?) '(eq? null?))
- ((pair? vector? float-vector? int-vector? hash-table?) '(equal? equal))
- (else '(#t #t))))
-
- (define (eqf selector)
- (if (symbol? selector)
- '(#t #t)
- (if (not (pair? selector))
- (->eqf (->type selector))
- (if (eq? (car selector) 'quote)
- (if (symbol? (cadr selector))
- '(eq? eq?)
- (if (null? (cadr selector))
- '(eq? null?)
- (if (char? (cadr selector))
- '(eqv? char=?)
- '(equal? equal?))))
- (if (symbol? (car selector))
- (->eqf (return-type (car selector)))
- '(#t #t))))))
-
+ ((and (eq? (car form) 'ash) ; (ash x 0) -> x
+ (= len 2) ; length of args
+ (eqv? (cadr args) 0))
+ (car args))
+
+ ((case (car form)
+ ((quotient) ; (quotient (remainder x y) y) -> 0
+ (and (= len 2)
+ (pair? (car args))
+ (eq? (caar args) 'remainder)
+ (= (length (car args)) 3)
+ (eqv? (caddar args) (cadr args))))
+ ((ash modulo) ; (modulo 0 x) -> 0
+ (and (= len 2) (eqv? (car args) 0)))
+ (else #f))
+ 0)
+
+ ((and (eq? (car form) 'modulo) ; (modulo (abs x) y) -> (modulo x y)
+ (= len 2)
+ (pair? (car args))
+ (eq? (caar args) 'abs))
+ `(modulo ,(cadar args) ,(cadr args)))
+
+ (else `(,(car form) , at args))))
+
+ ((expt)
+ (cond ((not (= len 2))
+ form)
+ ((and (eqv? (car args) 0) ; (expt 0 x) -> 0
+ (not (eqv? (cadr args) 0)))
+ 0)
+ ((or (and (eqv? (cadr args) 0) ; (expt x 0) -> 1
+ (not (eqv? (car args) 0)))
+ (eqv? (car args) 1)) ; (expt 1 x) -> 1
+ 1)
+ ((eqv? (cadr args) 1) ; (expt x 1) -> x
+ (car args))
+ ((eqv? (cadr args) -1) ; (expt x -1) -> (/ x)
+ `(/ ,(car args)))
+ ((just-rationals? args) ; (expt 2 3) -> 8
+ (catch #t
+ (lambda ()
+ (let ((val (apply expt args)))
+ (if (and (integer? val)
+ (< (abs val) 1000000))
+ val
+ `(expt , at args))))
+ (lambda args
+ `(expt , at args))))
+ (else `(expt , at args))))
- (define (check-special-cases name head form env)
-
- (case head
-
- ((memq assq memv assv member assoc)
- (define (list-one? p)
- (and (pair? p)
- (pair? (cdr p))
- (null? (cddr p))
- (or (and (eq? (car p) 'list)
- cadr)
- (and (eq? (car p) 'quote)
- (pair? (cadr p))
- (null? (cdadr p))
- (if (symbol? (caadr p))
- (lambda (x) (list 'quote (caadr x)))
- caadr)))))
-
- (if (= (length form) 4)
- (let ((func (list-ref form 3)))
- (if (symbol? func)
- (let ((sig (procedure-signature (symbol->value func))))
+
+ ((angle)
+ (cond ((not (pair? args)) form)
+ ((eqv? (car args) -1) 'pi)
+ ((or (morally-equal? (car args) 0.0)
+ (eq? (car args) 'pi))
+ 0.0)
+ (else `(angle , at args))))
+
+ ((atan)
+ (cond ((and (= len 1) ; (atan (x y)) -> (atan x y)
+ (pair? (car args))
+ (= (length (car args)) 3)
+ (eq? (caar args) '/))
+ `(atan ,@(cdar args)))
+ ((and (= len 2) ; (atan 0 -1) -> pi
+ (eqv? (car args) 0)
+ (eqv? (cadr args) -1))
+ 'pi)
+ (else `(atan , at args))))
+
+ ((inexact->exact exact)
+ (cond ((not (= len 1))
+ form)
+ ((or (rational? (car args))
+ (and (pair? (car args))
+ (or (rational-result? (caar args))
+ (integer-result? (caar args))
+ (and (eq? (caar args) 'random)
+ (rational? (cadar args))))))
+ (car args))
+ ((number? (car args))
+ (catch #t (lambda () (inexact->exact (car args))) (lambda any `(,(car form) , at args))))
+ (else `(,(car form) , at args))))
+
+ ((exact->inexact inexact)
+ (if (not (= len 1))
+ form
+ (if (memv (car args) '(0 0.0))
+ 0.0
+ ;; not (inexact (random 3)) -> (random 3.0) because results are different
+ `(,(car form) , at args))))
+
+ ((logior)
+ (set! args (lint-remove-duplicates (remove-all 0 (splice-if (lambda (x) (eq? x 'logior)) args)) env))
+ (if (every? (lambda (x) (or (not (number? x)) (integer? x))) args)
+ (let ((rats (collect-if list integer? args)))
+ (if (and (pair? rats)
+ (pair? (cdr rats)))
+ (let ((y (apply logior rats)))
+ (set! args (if (zero? y)
+ (collect-if list (lambda (x) (not (number? x))) args)
+ (cons y (collect-if list (lambda (x) (not (number? x))) args))))))))
+ (cond ((null? args) 0) ; (logior) -> 0
+ ((null? (cdr args)) (car args)) ; (logior x) -> x
+ ((memv -1 args) -1) ; (logior ... -1 ...) -> -1
+ ((just-integers? args) (apply logior args))
+ (else `(logior , at args))))
+
+ ((logand)
+ (set! args (lint-remove-duplicates (remove-all -1 (splice-if (lambda (x) (eq? x 'logand)) args)) env))
+ (if (every? (lambda (x) (or (not (number? x)) (integer? x))) args)
+ (let ((rats (collect-if list integer? args)))
+ (if (and (pair? rats)
+ (pair? (cdr rats)))
+ (let ((y (apply logand rats)))
+ (set! args (if (= y -1)
+ (collect-if list (lambda (x) (not (number? x))) args)
+ (cons y (collect-if list (lambda (x) (not (number? x))) args))))))))
+ (cond ((null? args) -1)
+ ((null? (cdr args)) (car args)) ; (logand x) -> x
+ ((memv 0 args) 0)
+ ((just-integers? args) (apply logand args))
+ (else `(logand , at args))))
+
+ ;; (logand 1 (logior 2 x)) -> (logand 1 x)?
+ ;; (logand 1 (logior 1 x)) -> 1
+ ;; (logand 3 (logior 1 x))?
+ ;; similarly for (logior...(logand...))
+
+ ((logxor)
+ (set! args (splice-if (lambda (x) (eq? x 'logxor)) args)) ; is this correct??
+ (cond ((null? args) 0) ; (logxor) -> 0
+ ((null? (cdr args)) (car args)) ; (logxor x) -> x??
+ ((just-integers? args) (apply logxor args)) ; (logxor 1 2) -> 3
+ ((and (= len 2) (equal? (car args) (cadr args))) 0) ; (logxor x x) -> 0
+ (else `(logxor , at args)))) ; (logxor x (logxor y z)) -> (logxor x y z)
+
+ ((gcd)
+ (set! args (lint-remove-duplicates (splice-if (lambda (x) (eq? x 'gcd)) args) env))
+ (cond ((null? args) 0)
+ ((memv 1 args) 1)
+ ((just-integers? args)
+ (catch #t ; maybe (gcd -9223372036854775808 -9223372036854775808)
+ (lambda ()
+ (apply gcd args))
+ (lambda ignore
+ `(gcd , at args))))
+ ((null? (cdr args)) `(abs ,(car args)))
+ ((eqv? (car args) 0) `(abs ,(cadr args)))
+ ((eqv? (cadr args) 0) `(abs ,(car args)))
+ (else `(gcd , at args))))
+
+ ((lcm)
+ (set! args (lint-remove-duplicates (splice-if (lambda (x) (eq? x 'lcm)) args) env))
+ (cond ((null? args) 1) ; (lcm) -> 1
+ ((memv 0 args) 0) ; (lcm ... 0 ...) -> 0
+ ((just-integers? args) ; (lcm 3 4) -> 12
+ (catch #t
+ (lambda ()
+ (apply lcm args))
+ (lambda ignore
+ `(lcm , at args))))
+ ((null? (cdr args)) ; (lcm x) -> (abs x)
+ `(abs ,(car args)))
+ (else `(lcm , at args))))
+
+ ((max min)
+ (if (not (pair? args))
+ form
+ (begin
+ (set! args (lint-remove-duplicates (splice-if (lambda (x) (eq? x (car form))) args) env))
+ (if (= len 1)
+ (car args)
+ (if (just-reals? args)
+ (apply (symbol->value (car form)) args)
+ (let ((nums (collect-if list number? args))
+ (other (if (eq? (car form) 'min) 'max 'min)))
+ (if (and (pair? nums)
+ (just-reals? nums)) ; non-real case checked elsewhere (later)
+ (let ((relop (if (eq? (car form) 'min) >= <=)))
+ (if (pair? (cdr nums))
+ (set! nums (list (apply (symbol->value (car form)) nums))))
+ (let ((new-args (append nums (collect-if list (lambda (x) (not (number? x))) args))))
+ (let ((c1 (car nums)))
+ (set! new-args (collect-if list (lambda (x)
+ (or (not (pair? x))
+ (<= (length x) 2)
+ (not (eq? (car x) other))
+ (let ((c2 (find-if number? (cdr x))))
+ (or (not c2)
+ (relop c1 c2)))))
+ new-args)))
+ (if (< (length new-args) (length args))
+ (set! args new-args)))))
+
+ ;; if (max c1 (min c2 . args1) . args2) where (> c1 c2) -> (max c1 . args2), if = -> c1
+ ;; if (min c1 (max c2 . args1) . args2) where (< c1 c2) -> (min c1 . args2), if = -> c1
+ ;; and if (max 4 x (min x 4)) -- is it (max x 4)?
+ ;; (max a b) is (- (min (- a) (- b))), but that doesn't help here -- the "-" gets in our way
+ ;; (min (- a) (- b)) -> (- (max a b))?
+ ;; (+ a (max|min b c)) = (max|min (+ a b) (+ a c)))
+
+ (if (null? (cdr args)) ; (max (min x 3) (min x 3)) -> (max (min x 3)) -> (min x 3)
+ (car args)
+ (if (and (null? (cddr args)) ; (max|min x (min|max x ...) -> x
+ (or (and (pair? (car args))
+ (eq? (caar args) other)
+ (member (cadr args) (car args))
+ (not (side-effect? (cadr args) env)))
+ (and (pair? (cadr args))
+ (eq? (caadr args) other)
+ (member (car args) (cadr args))
+ (not (side-effect? (car args) env)))))
+ ((if (pair? (car args)) cadr car) args)
+ `(,(car form) , at args)))))))))
+ (else
+ `(,(car form) , at args))))))
+
+
+ (define (check-char-cmp caller op form)
+ (if (and (any? (lambda (x)
+ (and (pair? x)
+ (eq? (car x) 'char->integer)))
+ (cdr form))
+ (every? (lambda (x)
+ (or (and (integer? x)
+ (<= 0 x 255))
+ (and (pair? x)
+ (eq? (car x) 'char->integer))))
+ (cdr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,(case op ((=) 'char=?) ((>) 'char>?) ((<) 'char<?) ((>=) 'char>=?) (else 'char<=?))
+ ,@(map (lambda (arg)
+ (if (integer? arg)
+ (integer->char arg)
+ (cadr arg)))
+ (cdr form)))))))
+
+ (define (write-port expr) ; ()=not specified (*stdout*), #f=something is wrong (not enough args)
+ (and (pair? expr)
+ (if (eq? (car expr) 'newline)
+ (if (pair? (cdr expr))
+ (cadr expr)
+ ())
+ (and (pair? (cdr expr))
+ (if (pair? (cddr expr))
+ (caddr expr)
+ ())))))
+
+ (define (display->format d)
+ (case (car d)
+ ((newline) "~%")
+
+ ((display)
+ (let* ((arg (cadr d))
+ (arg-arg (and (pair? arg)
+ (pair? (cdr arg))
+ (cadr arg))))
+ (cond ((string? arg)
+ arg)
+
+ ((char? arg)
+ (string arg))
+
+ ((and (pair? arg)
+ (eq? (car arg) 'number->string)
+ (= (length arg) 3))
+ (case (caddr arg)
+ ((2) (values "~B" arg-arg))
+ ((8) (values "~O" arg-arg))
+ ((10) (values "~D" arg-arg))
+ ((16) (values "~X" arg-arg))
+ (else (values "~A" arg))))
+
+ ((not (and (pair? arg)
+ (eq? (car arg) 'string-append)))
+ (values "~A" arg))
+
+ ((null? (cddr arg))
+ (if (string? arg-arg)
+ arg-arg
+ (values "~A" arg-arg)))
+
+ ((not (null? (cdddr arg)))
+ (values "~A" arg))
+
+ ((string? arg-arg)
+ (values (string-append arg-arg "~A") (caddr arg)))
+
+ ((string? (caddr arg))
+ (values (string-append "~A" (caddr arg)) arg-arg))
+
+ (else (values "~A" arg)))))
+
+ ((write)
+ ;; very few special cases actually happen here, unlike display above
+ (if (string? (cadr d))
+ (string-append "\"" (cadr d) "\"")
+ (if (char? (cadr d))
+ (string (cadr d))
+ (values "~S" (cadr d)))))
+
+ ((write-char)
+ (if (char? (cadr d))
+ (string (cadr d))
+ (values "~C" (cadr d))))
+
+ ((write-string) ; same as display but with possible start|end indices
+ (let ((indices (and (pair? (cddr d)) ; port
+ (pair? (cdddr d))
+ (cdddr d))))
+ (if (string? (cadr d))
+ (if (not indices)
+ (cadr d)
+ (if (and (integer? (car indices))
+ (or (null? (cdr indices))
+ (and (pair? indices)
+ (integer? (cadr indices)))))
+ (apply substring (cadr d) indices)
+ (values "~A" `(substring ,(cadr d) , at indices))))
+ (values "~A" (if indices `(substring ,(cadr d) , at indices) (cadr d))))))))
+
+ (define (identity? x) ; (lambda (x) x), or (define (x) x) -> procedure-source
+ (and (pair? x)
+ (eq? (car x) 'lambda)
+ (pair? (cdr x))
+ (pair? (cadr x))
+ (null? (cdadr x))
+ (pair? (cddr x))
+ (null? (cdddr x))
+ (eq? (caddr x) (caadr x))))
+
+ (define (cdr-count c)
+ (case c ((cdr) 1) ((cddr) 2) ((cdddr) 3) (else 4)))
+
+ (define (simple-lambda? x)
+ (and (pair? x)
+ (eq? (car x) 'lambda)
+ (pair? (cdr x))
+ (pair? (cadr x))
+ (null? (cdadr x))
+ (pair? (cddr x))
+ (null? (cdddr x))
+ (= (tree-count1 (caadr x) (caddr x) 0) 1)))
+
+ (define (less-simple-lambda? x)
+ (and (pair? x)
+ (eq? (car x) 'lambda)
+ (pair? (cdr x))
+ (pair? (cadr x))
+ (null? (cdadr x))
+ (pair? (cddr x))
+ (= (tree-count1 (caadr x) (cddr x) 0) 1)))
+
+ (define (tree-subst new old tree)
+ (cond ((equal? old tree)
+ new)
+
+ ((not (pair? tree))
+ tree)
+
+ ((eq? (car tree) 'quote)
+ (copy-tree tree))
+
+ (else (cons (tree-subst new old (car tree))
+ (tree-subst new old (cdr tree))))))
+
+
+ (define* (find-unique-name f1 f2 (i 1))
+ (let ((sym (string->symbol (format #f "_~D_" i))))
+ (if (not (or (eq? sym f1)
+ (eq? sym f2)
+ (tree-member sym f1)
+ (tree-member sym f2)))
+ sym
+ (find-unique-name f1 f2 (+ i 1)))))
+
+ (define (unrelop caller head form) ; assume len=3
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (if (memv arg2 '(0 0.0)) ; (< (- x y) 0) -> (< x y), need both 0 and 0.0 because (eqv? 0 0.0) is #f
+ (if (and (pair? arg1)
+ (eq? (car arg1) '-)
+ (= (length arg1) 3))
+ (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadr arg1) ,(caddr arg1)))))
+ (if (and (memv arg1 '(0 0.0)) ; (< 0 (- x y)) -> (> x y)
+ (pair? arg2)
+ (eq? (car arg2) '-)
+ (= (length arg2) 3))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(hash-table-ref reversibles head) ,(cadr arg2) ,(caddr arg2))))))))
+
+ (define (check-start-and-end caller head form ff env)
+ (if (or (and (integer? (car form))
+ (integer? (cadr form))
+ (apply >= form))
+ (and (equal? (car form) (cadr form))
+ (not (side-effect? (car form) env))))
+ (lint-format "these ~A indices make no sense: ~A" caller head ff)))
+
+ (define (other-case c)
+ (if (char-upper-case? c)
+ (char-downcase c)
+ (char-upcase c)))
+
+ (define (check-boolean-affinity caller form env)
+ ;; does built-in boolean func's arg make sense
+ (if (and (= (length form) 2)
+ (not (symbol? (cadr form)))
+ (not (= line-number last-simplify-boolean-line-number)))
+ (let ((expr (simplify-boolean form () () env)))
+ (if (not (equal? expr form))
+ (lint-format "perhaps ~A" caller (lists->string form expr)))
+ (if (and (pair? (cadr form))
+ (symbol? (caadr form)))
+ (let ((rt (if (eq? (caadr form) 'quote)
+ (->simple-type (cadadr form))
+ (return-type (caadr form) env)))
+ (head (car form)))
+ (if (subsumes? head rt)
+ (lint-format "~A is always #t" caller (truncated-list->string form))
+ (if (not (or (memq rt '(#t #f values))
+ (any-compatible? head rt)))
+ (lint-format "~A is always #f" caller (truncated-list->string form)))))))))
+
+ (define (combine-cxrs form)
+ (let ((cxr? (lambda (s)
+ (and (pair? (cdr s))
+ (pair? (cadr s))
+ (memq (caadr s) '(car cdr cadr cddr cdar cdddr cddddr))))))
+ (and (cxr? form)
+ (let* ((arg1 (cadr form))
+ (arg2 (and arg1 (cxr? arg1) (cadr arg1)))
+ (arg3 (and arg2 (cxr? arg2) (cadr arg2)))
+ (innards (lambda (c)
+ (case c
+ ((car) "a") ((cdr) "d") ((caar) "aa") ((cadr) "ad") ((cddr) "dd") ((cdar) "da")
+ ((caaar) "aaa") ((caadr) "aad") ((caddr) "add") ((cdddr) "ddd")
+ ((cdaar) "daa") ((cddar) "dda") ((cdadr) "dad") ((cadar) "ada")
+ ((cddddr) "dddd") ((cadddr) "addd")))))
+ (values (string-append (innards (car form))
+ (innards (car arg1))
+ (if arg2 (innards (car arg2)) "")
+ (if arg3 (innards (car arg3)) ""))
+ (cadr (or arg3 arg2 arg1)))))))
+
+ (define (mv-range producer env)
+ (if (symbol? producer)
+ (let ((v (var-member producer env)))
+ (and (var? v)
+ (pair? ((cdr v) 'values))
+ ((cdr v) 'values)))
+ (and (pair? producer)
+ (if (memq (car producer) '(lambda lambda*))
+ (count-values (cddr producer))
+ (if (eq? (car producer) 'values)
+ (let ((len (- (length producer) 1)))
+ (for-each
+ (lambda (p)
+ (if (and (pair? p) (eq? (car p) 'values))
+ (set! len (- (+ len (length p)) 2))))
+ (cdr producer))
+ (list len len))
+ (mv-range (car producer) env))))))
+
+ (define (eval-constant-expression caller form)
+ (if (every? code-constant? (cdr form))
+ (catch #t
+ (lambda ()
+ (let ((val (eval (copy form :readable))))
+ (lint-format "perhaps ~A" caller (lists->string form val))))
+ (lambda args
+ #t))))
+
+
+ (define (check-special-cases caller head form env)
+ ;; here curlet won't change (leaving aside additions via define)
+ ;; keyword head here if args to func/macro that we don't know about
+
+ (case head
+
+ ;; ----------------
+ ((memq assq memv assv member assoc)
+
+ (define (list-one? p)
+ (and (pair? p)
+ (pair? (cdr p))
+ (null? (cddr p))
+ (case (car p)
+ ((list) cadr)
+ ((quote)
+ (and (pair? (cadr p))
+ (null? (cdadr p))
+ (if (symbol? (caadr p))
+ (lambda (x)
+ (list 'quote (caadr x)))
+ caadr)))
+ (else #f))))
+
+ (when (= (length form) 4)
+ (let ((func (list-ref form 3)))
+ (if (symbol? func)
+ (if (memq func '(eq? eqv? equal?)) ; (member x y eq?) -> (memq x y)
+ (let ((op (if (eq? head 'member)
+ (case func ((eq?) 'memq) ((eqv?) 'memv) (else 'member))
+ (case func ((eq?) 'assq) ((eqv?) 'assv) (else 'assoc)))))
+ (lint-format "perhaps ~A" caller (lists->string form `(,op ,(cadr form) ,(caddr form)))))
+ (let ((sig (procedure-signature (symbol->value func)))) ; arg-signature here is too cranky
(if (and sig
(not (eq? (car sig) 'boolean?)))
- (lint-format "~A is a questionable ~A function" name func head)))
- (if (and (pair? func)
- (= (length func) 3)
- (eq? (car func) 'lambda)
- (pair? (cadr func))
- (pair? (caddr func)))
- (if (not (member (length (cadr func)) '(2 -1)))
- (lint-format "~A equality function (optional 3rd arg) should take two arguments" name head)
- (if (eq? head 'member)
- (let ((eq (caddr func))
- (args (cadr func)))
- (if (and (memq (car eq) '(eq? eqv? equal?))
- (eq? (car args) (cadr eq))
- (pair? (caddr eq))
- (eq? (car (caddr eq)) 'car)
- (pair? (cdr (caddr eq)))
- (pair? (cdr args))
- (eq? (cadr args) (cadr (caddr eq))))
- (lint-format "member might perhaps be ~A"
- name
- (if (or (eq? func 'eq?)
- (eq? (car (caddr func)) 'eq?))
- 'assq
- (if (eq? (car (caddr func)) 'eqv?)
- 'assv
- 'assoc))))))))))
-
- (when (= (length form) 3)
- (let ((selector (cadr form))
- (items (caddr form)))
- (let ((current-eqf (case head ((memq assq) 'eq?) ((memv assv) 'eqv?) (else 'equal?)))
- (selector-eqf (eqf selector))
- (one-item (and (memq head '(memq memv member)) (list-one? (caddr form)))))
- ;; one-item assoc doesn't simplify cleanly
+ (lint-format "~A is a questionable ~A function" caller func head))))
+ ;; func not a symbol
+ (if (and (pair? func)
+ (= (length func) 3)
+ (eq? (car func) 'lambda)
+ (pair? (cadr func))
+ (pair? (caddr func)))
+ (if (not (memv (length (cadr func)) '(2 -1)))
+ (lint-format "~A equality function (optional third arg) should take two arguments" caller head)
+ (if (eq? head 'member)
+ (let ((eq (caddr func))
+ (args (cadr func)))
+ (if (and (memq (car eq) '(eq? eqv? equal?))
+ (eq? (car args) (cadr eq))
+ (pair? (caddr eq))
+ (eq? (car (caddr eq)) 'car)
+ (pair? (cdr (caddr eq)))
+ (pair? (cdr args))
+ (eq? (cadr args) (cadr (caddr eq))))
+ (lint-format "member might perhaps be ~A"
+ caller
+ (if (or (eq? func 'eq?)
+ (eq? (car (caddr func)) 'eq?))
+ 'assq
+ (if (eq? (car (caddr func)) 'eqv?)
+ 'assv
+ 'assoc)))))))))))
+
+ (when (= (length form) 3)
+ (let ((selector (cadr form))
+ (items (caddr form)))
+
+ (let ((current-eqf (case head ((memq assq) 'eq?) ((memv assv) 'eqv?) (else 'equal?)))
+ (selector-eqf (eqf selector env))
+ (one-item (and (memq head '(memq memv member)) (list-one? items))))
+ ;; one-item assoc doesn't simplify cleanly
+
+ (if one-item
+ (let* ((target (one-item items))
+ (iter-eqf (eqf target env)))
+ (if (or (symbol? target)
+ (and (pair? target)
+ (not (eq? (car target) 'quote))))
+ (set! target (list 'quote target)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(cadr iter-eqf) ,selector ,target))))
+
+ ;; not one-item
+ (letrec ((duplicates? (lambda (lst fnc)
+ (and (pair? lst)
+ (or (fnc (car lst) (cdr lst))
+ (duplicates? (cdr lst) fnc)))))
+ (duplicate-constants? (lambda (lst fnc)
+ (and (pair? lst)
+ (or (and (constant? (car lst))
+ (fnc (car lst) (cdr lst)))
+ (duplicate-constants? (cdr lst) fnc))))))
+ (if (and (pair? items)
+ (or (eq? (car items) 'list)
+ (and (eq? (car items) 'quote)
+ (pair? (cadr items)))))
+ (let ((baddy #f))
+ (catch #t
+ (lambda ()
+ (set! baddy (if (eq? (car items) 'list)
+ (duplicate-constants? (cdr items) (symbol->value head))
+ (duplicates? (cadr items) (symbol->value head)))))
+ (lambda args #f))
+ (if (pair? baddy)
+ (lint-format "duplicated entry ~S in ~A" caller (car baddy) items))))
- (if one-item
- (let* ((target (one-item items))
- (iter-eqf (eqf target)))
- (lint-format "perhaps ~A" name
- (if (or (symbol? target)
- (and (pair? target)
- (not (eq? (car target) 'quote))))
- (lists->string form `(,(cadr iter-eqf) ,selector ',target))
- (lists->string form `(,(cadr iter-eqf) ,selector ,target)))))
-
- (letrec ((duplicates? (lambda (lst fnc)
- (and (pair? lst)
- (or (fnc (car lst) (cdr lst))
- (duplicates? (cdr lst) fnc)))))
- (duplicate-constants? (lambda (lst fnc)
- (and (pair? lst)
- (or (and (constant? (car lst))
- (fnc (car lst) (cdr lst)))
- (duplicate-constants? (cdr lst) fnc))))))
- (if (and (pair? items)
- (or (eq? (car items) 'list)
- (and (eq? (car items) 'quote)
- (pair? (cadr items)))))
- (let ((baddy #f))
- (catch #t
- (lambda ()
- (if (eq? (car items) 'list) ; TODO: restrict to constants?
- (set! baddy (duplicate-constants? (cdr items) (symbol->value head)))
- (set! baddy (duplicates? (cadr items) (symbol->value head)))))
- (lambda args #f))
- (if (pair? baddy)
- (lint-format "duplicated entry ~S in ~A" name (car baddy) items))))
-
- (if (and (symbol? (car selector-eqf))
- (not (eq? (car selector-eqf) current-eqf)))
- (lint-format "~A: perhaps ~A -> ~A" name form head
- (if (memq head '(memq memv member))
- (case (car selector-eqf) ((eq?) 'memq) ((eqv?) 'memv) ((equal?) 'member))
- (case (car selector-eqf) ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc))))))))
-
- (when (and (memq head '(memq memv))
- (pair? items)
- (eq? (car items) 'quote)
- (pair? (cadr items)))
- (let ((bad (find-if (lambda (x)
- (not (or (symbol? x)
- (char? x)
- (number? x)
- (procedure? x) ; (memq abs '(1 #_abs 2)) !
- (memq x '(#f #t () #<unspecified> #<undefined> #<eof>)))))
- (cadr items))))
- (if bad
- (if (pair? bad)
- (if (eq? (car bad) 'quote)
- (lint-format "stray quote? ~A" name form)
- (if (eq? (car bad) 'unquote)
- (lint-format "stray comma? ~A" name form)
- (lint-format "pointless list member: ~S in ~A" name bad form)))
- (lint-format "pointless list member: ~S in ~A" name bad form)))))))))
-
- ((if)
- (let ((len (length form)))
- (if (> len 4)
- (lint-format "if has too many clauses: ~A" name form)
- (if (< len 3)
- (lint-format "if has too few clauses: ~A" name form)
- (let ((test (cadr form))
- (true (caddr form))
- (false (if (= len 4) (cadddr form) 'no-false)))
-
- (if (never-false test)
- (lint-format "if test is never false: ~A" name form)
- (if (and (never-true test) true) ; complain about (if #f #f) later
- (lint-format "if test is never true: ~A" name form)))
-
- (let ((expr (simplify-boolean test () () env)))
- ;(format *stderr* "expr simplified: ~S~%" expr)
-
- (if (not (side-effect? test env))
- (if (or (equal? test true) (equal? expr true))
- (lint-format "perhaps ~A" name
- (lists->string form
- (if (eq? false 'no-false)
- (simplify-boolean `(or ,expr #<unspecified>) () () env)
- (simplify-boolean `(or ,expr ,false) () () env))))
- (if (or (equal? test false) (equal? expr false))
- (lint-format "perhaps ~A" name
- (lists->string form (simplify-boolean `(and ,expr ,true) () () env))))))
-
- (if (pair? false)
- (begin
- (if (and (eq? (car false) 'if)
- (pair? (cdr false))
- (pair? (cadr false))
- (eq? (caadr false) 'not)
- (or (equal? test (cadr (cadr false))) (equal? expr (cadr (cadr false))))
- (not (side-effect? test env)))
- (lint-format "pointless repetition of if test: ~A" name (lists->string form `(if ,expr ,true ,(caddr false)))))
-
- (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr)
- (equal? true (caddr false)))
- (let ((test1 (simplify-boolean `(or ,expr ,(cadr false)) () () env)))
- (lint-format "perhaps ~A" name (lists->string form `(if ,test1 ,true ,@(cdddr false))))))
-
- (if (and (pair? true) ; (if expr (set! var #t | #f) (set! var #f | #t)) -> (set! var expr|(not expr))??
- (eq? (car true) 'set!)
- (eq? (car false) 'set!)
- (eq? (cadr true) (cadr false))
- (boolean? (caddr true))
- (boolean? (caddr false))
- (not (eq? (caddr true) (caddr false))))
- (lint-format "perhaps ~A"
- name
- (lists->string form
- (if (caddr true)
- `(set! ,(cadr true) ,expr)
- `(set! ,(cadr true) (not ,expr)))))))
- (if (eq? false 'no-false) ; no false branch
- (begin
- (if (and (pair? test) ; (if (pair? lst) (for-each f lst)) -> (for-each f lst)
- (eq? (car test) 'pair?)
- (pair? true)
- (memq (car true) '(map for-each))
- (eq? (cadr test) (caddr true)))
- (lint-format "perhaps ~A" name (lists->string form true)))
-
- (if (and (pair? true) ; (if test0 (if test1 expr)) -> (if (and test0 test1) expr) (else #<unspecified>)
- (eq? (car true) 'if)
- (null? (cdddr true)))
- (let ((test1 (simplify-boolean `(and ,expr ,(cadr true)) () () env)))
- (lint-format "perhaps ~A" name (lists->string form `(if ,test1 ,(caddr true)))))))))
-
- (if (eq? expr #t)
- (lint-format "perhaps ~A" name (lists->string form true))
- (if (not expr)
- (if (eq? false 'no-false)
- (if true ; (if #f x) as a kludgey #<unspecified>
- (lint-format "perhaps ~A" name (lists->string form #<unspecified>)))
- (lint-format "perhaps ~A" name (lists->string form false)))
- (if (not (equal? true false))
- (if (boolean? true)
- (if (boolean? false) ; ! (if expr #t #f) turned into something less verbose
- (lint-format "perhaps ~A" name
- (lists->string form (if true
- expr
- (simplify-boolean `(not ,expr) () () env))))
- (lint-format "perhaps ~A" name
- (lists->string form (if true
- (if (eq? false 'no-false)
- expr
- (simplify-boolean `(or ,expr ,false) () () env))
- (simplify-boolean
- (if (eq? false 'no-false)
- `(not ,expr)
- `(and (not ,expr) ,false))
- () () env)))))
- (if (boolean? false)
- (lint-format "perhaps ~A" name
- (lists->string form (simplify-boolean
- (if false
- (if (and (pair? expr) (eq? (car expr) 'not))
- `(or ,(cadr expr) ,true)
- `(or (not ,expr) ,true))
- `(and ,expr ,true))
- () () env)))))
- (if (= len 4)
- (if (not (side-effect? test env))
- (lint-format "if is not needed here: ~A" name (lists->string form true))
- (lint-format "if is not needed here: ~A" name (lists->string form `(begin ,expr ,true))))))))))))))
-
- ((car cdr
- caar cadr cddr cdar
- caaar caadr caddr cdddr cdaar cddar cadar cdadr
- cadddr cddddr)
- (let ((cxr? (lambda (s)
- (and (pair? (cdr s))
- (pair? (cadr s))
- (memq (caadr s) '(car cdr cadr cddr cdar cdddr cddddr))))))
- (if (and (not (= line-number last-simplify-boolean-line-number))
- (cxr? form))
- (let* ((arg1 (cadr form))
- (arg2 (and arg1 (cxr? arg1) (cadr arg1)))
- (arg3 (and arg2 (cxr? arg2) (cadr arg2))))
- (set! last-simplify-boolean-line-number line-number)
- (let* ((innards (lambda (c) (case c ((car) "a") ((cdr) "d") ((caar) "aa") ((cadr) "ad") ((cddr) "dd") ((cdar) "da")
- ((caaar) "aaa") ((caadr) "aad") ((caddr) "add") ((cdddr) "ddd")
- ((cdaar) "daa") ((cddar) "dda") ((cdadr) "dad") ((cadar) "ada")
- ((cddddr) "dddd") ((cadddr) "addd"))))
- (cxr (string-append (innards (car form))
- (innards (car arg1))
- (if arg2 (innards (car arg2)) "")
- (if arg3 (innards (car arg3)) ""))))
- (if (< (length cxr) 5)
- (lint-format "perhaps ~A" name (lists->string form `(,(string->symbol (string-append "c" cxr "r")) ,(cadr (or arg3 arg2 arg1)))))
- ;; if it's car|cdr followed by cdr's, use list-ref|tail
- (if (not (char-position #\a cxr))
- (lint-format "perhaps ~A" name (lists->string form `(list-tail ,(cadr (or arg3 arg2 arg1)) ,(length cxr))))
- (if (not (char-position #\a (substring cxr 1)))
- (lint-format "perhaps ~A" name (lists->string form `(list-ref ,(cadr (or arg3 arg2 arg1)) ,(- (length cxr) 1))))
- (set! last-simplify-boolean-line-number -1))))))))
+ (if (and (symbol? (car selector-eqf))
+ (not (eq? (car selector-eqf) current-eqf)))
+ (lint-format "~A: perhaps ~A -> ~A" caller (truncated-list->string form) head
+ (if (memq head '(memq memv member))
+ (case (car selector-eqf) ((eq?) 'memq) ((eqv?) 'memv) ((equal?) 'member))
+ (case (car selector-eqf) ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc)))))
+
+ (if (and (pair? items)
+ (eq? (car items) 'list)
+ (every? code-constant? (cdr items)))
+ (lint-format "perhaps ~A -> '~A" caller (truncated-list->string items)
+ (truncated-list->string (map unquoted (cdr items)))))
+
+ (when (pair? items)
+ (let ((memx (memq head '(memq memv member))))
+ (case (car items)
+ ((map)
+ (when (and memx (= (length items) 3))
+ (let ((mapf (cadr items))
+ (map-items (caddr items)))
+ (cond ((eq? mapf 'car)
+ (lint-format "perhaps use assoc: ~A" caller
+ (lists->string form `(,(case current-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc))
+ ,selector ,map-items))))
+ ((eq? selector #t)
+ (if (eq? mapf 'null?)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(memq () ,map-items)))
+ (let ((b (if (eq? mapf 'b) 'c 'b)))
+ (lint-format "perhaps avoid 'map: ~A" caller
+ (lists->string form `(member #t ,map-items (lambda (a ,b) (,mapf ,b))))))))
+
+ ((and (pair? selector)
+ (eq? (car selector) 'string->symbol) ; this could be extended, but it doesn't happen
+ (eq? mapf 'string->symbol)
+ (not (and (pair? map-items)
+ (eq? (car map-items) 'quote))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(member ,(cadr selector) ,map-items string=?))))
+ (else
+ (let ((b (if (eq? mapf 'b) 'c 'b))) ; a below can't collide because eqf won't return 'a
+ (lint-format "perhaps avoid 'map: ~A" caller
+ (lists->string form `(member ,selector ,map-items
+ (lambda (a ,b) (,current-eqf a (,mapf ,b))))))))))))
+ ((cons)
+ (if (not (pair? selector))
+ (lint-format "perhaps avoid 'cons: ~A" caller
+ (lists->string form `(or (,current-eqf ,selector ,(cadr items))
+ (,head ,selector ,(caddr items)))))))
+ ((append)
+ (if (and (not (pair? selector))
+ (= (length items) 3)
+ (pair? (cadr items))
+ (eq? (caadr items) 'list)
+ (null? (cddadr items)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(or (,current-eqf ,selector ,(cadadr items))
+ (,head ,selector ,(caddr items)))))))))))))
+
+ (when (and (eq? (->lint-type (cadr form)) 'char?)
+ (pair? (caddr form))
+ (eq? (caaddr form) 'string->list)
+ (null? (cdddr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char-position ,(cadr form) ,@(cdaddr form)))))
+
+ (when (and (memq head '(memq memv))
+ (pair? items)
+ (eq? (car items) 'quote)
+ (pair? (cadr items)))
+ (if (> (length items) 20)
+ (lint-format "perhaps use a hash-table here, rather than ~A" caller (truncated-list->string form)))
+
+ (let ((bad (find-if (lambda (x)
+ (not (or (symbol? x)
+ (char? x)
+ (number? x)
+ (procedure? x) ; (memq abs '(1 #_abs 2)) !
+ (memq x '(#f #t () #<unspecified> #<undefined> #<eof>)))))
+ (cadr items))))
+ (if bad
+ (lint-format (cond ((not (pair? bad))
+ (values "pointless list member: ~S in ~A" caller bad))
+ ((eq? (car bad) 'quote)
+ (values "stray quote? ~A" caller))
+ ((eq? (car bad) 'unquote)
+ (values "stray comma? ~A" caller))
+ (else (values "pointless list member: ~S in ~A" caller bad)))
+ form)))))))
+
+ ;; ----------------
+ ((car cdr
+ caar cadr cddr cdar
+ caaar caadr caddr cdddr cdaar cddar cadar cdadr
+ cadddr cddddr)
+ ;; caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar
+
+ (if (not (= line-number last-simplify-cxr-line-number))
+ ((lambda* (cxr arg)
+ (when cxr
+ (set! last-simplify-cxr-line-number line-number)
+ (cond ((< (length cxr) 5)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(string->symbol (string-append "c" cxr "r")) ,arg))))
+
+ ;; if it's car|cdr followed by cdr's, use list-ref|tail
+ ((not (char-position #\a cxr))
+ (lint-format "perhaps ~A" caller (lists->string form `(list-tail ,arg ,(length cxr)))))
+
+ ((not (char-position #\a (substring cxr 1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,arg ,(- (length cxr) 1)))))
+
+ (else (set! last-simplify-cxr-line-number -1)))))
+ (combine-cxrs form)))
+
+ (when (pair? (cadr form))
+ (when (eq? head 'car)
+ (if (eq? (caadr form) 'list-tail) ; (car (list-tail x y)) -> (list-ref x y)
+ (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,(cadadr form) ,(caddr (cadr form)))))
+ (if (and (memq (caadr form) '(memq memv member assq assv assoc))
+ (pair? (cdadr form))) ; (car (memq...))
+ (lint-format "~A is ~A, or an error" caller (truncated-list->string form) (cadadr form)))))
(if (and (memq head '(car cdr))
- (pair? (cadr form))
- (eq? (car (cadr form)) 'cons))
- (lint-format "(~A~A) is the same as~A"
- name head
+ (eq? (caadr form) 'cons))
+ (lint-format "(~A~A) is the same as ~A"
+ caller head
(truncated-list->string (cadr form))
(if (eq? head 'car)
(truncated-list->string (cadadr form))
- (truncated-list->string (caddr (cadr form)))))))
-
- ((and or not)
- (if (not (= line-number last-simplify-boolean-line-number))
- (let ((val (simplify-boolean form () () env)))
- (set! last-simplify-boolean-line-number line-number)
- (if (not (equal? form val))
- (lint-format "perhaps ~A" name (lists->string form val))))))
-
- ((=)
- (if (and (> (length form) 2)
+ (truncated-list->string (caddr (cadr form))))))
+
+ (when (memq head '(car cadr caddr cadddr))
+ (if (memq (caadr form) '(string->list vector->list)) ; (car (string->list x)) -> (string-ref x 0)
+ (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? (caadr form) 'string->list) 'string-ref 'vector-ref)
+ ,(cadadr form)
+ ,(case head ((car) 0) ((cadr) 1) ((caddr) 2) (else 3)))))
+ (if (and (memq (caadr form) '(reverse reverse!))
+ (symbol? (cadadr form)))
+ (lint-format "perhaps ~A" caller ; (car (reverse x)) -> (list-ref x (- (length x) 1))
+ (lists->string form `(list-ref ,(cadadr form)
+ (- (length ,(cadadr form))
+ ,(case head ((car) 1) ((cadr) 2) ((caddr) 3) (else 4)))))))))))
+
+ ;; ----------------
+ ((set-car!)
+ (when (= (length form) 3)
+ (let ((target (cadr form)))
+ (if (pair? target)
+ (case (car target)
+
+ ((list-tail) ; (set-car! (list-tail x y) z) -> (list-set! x y z)
+ (lint-format "perhaps ~A" caller (lists->string form `(list-set! ,(cadr target) ,(caddr target) ,(caddr form)))))
+
+ ((cdr cddr cdddr cddddr)
+ (set! last-simplify-cxr-line-number line-number)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? (cadr target))
+ (memq (caadr target) '(cdr cddr cdddr cddddr)))
+ ;; (set-car! (cdr (cddr x)) y) -> (list-set! x 3 y)
+ `(list-set! ,(cadadr target)
+ ,(+ (cdr-count (car target)) (cdr-count (caadr target)))
+ ,(caddr form))
+ ;; (set-car! (cdr x) y) -> (list-set! x 1 y)
+ `(list-set! ,(cadr target)
+ ,(cdr-count (car target))
+ ,(caddr form)))))))))))
+ ;; ----------------
+ ((not)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'not))
+ (lint-format "if you want a boolean, (not (not ~A)) -> (and ~A #t)" 'paranoia
+ (truncated-list->string (cadadr form))
+ (truncated-list->string (cadadr form))))
+ (if (not (= line-number last-simplify-boolean-line-number))
+ (let ((val (simplify-boolean form () () env)))
+ (set! last-simplify-boolean-line-number line-number)
+ (if (not (equal? form val))
+ (lint-format "perhaps ~A" caller (lists->string form val))))))
+
+ ((or and)
+ (if (not (= line-number last-simplify-boolean-line-number))
+ (let ((val (simplify-boolean form () () env)))
+ (set! last-simplify-boolean-line-number line-number)
+ (if (not (equal? form val))
+ (lint-format "perhaps ~A" caller (lists->string form val)))))
+ (if (pair? (cdr form))
+ (do ((p (cdr form) (cdr p)))
+ ((null? (cdr p)))
+ (if (and (pair? (car p))
+ (eq? (caar p) 'if)
+ (= (length (car p)) 3))
+ (lint-format "one-armed if might cause confusion here: ~A" caller form)))))
+
+ ;; ----------------
+ ((=)
+ (let ((len (length form)))
+ (if (and (> len 2)
(any-real? (cdr form)))
- (lint-format "= can be troublesome with floats: ~A" name (truncated-list->string form)))
+ (lint-format "= can be troublesome with floats: ~A" caller (truncated-list->string form)))
+
(let ((cleared-form (cons = (remove-if (lambda (x) (not (number? x))) (cdr form)))))
(if (and (> (length cleared-form) 2)
(not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" name (truncated-list->string form))))
- (when (and (= (length form) 3)
- (eqv? (caddr form) 0))
- (let ((arg (cadr form)))
- (when (and (pair? arg)
- (eq? (car arg) '-)
- (= (length arg) 3))
- (lint-format "perhaps ~A" name (lists->string form `(= ,(cadr arg) ,(caddr arg))))))))
-
- ((< > <= >=) ; '= handled above
- (let ((cleared-form (cons (car form) ; keep operator
- (remove-if (lambda (x)
- (not (number? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" name (truncated-list->string form))))
- (when (and (= (length form) 3)
- (eqv? (caddr form) 0))
- (let ((arg (cadr form)))
- (if (and (pair? arg)
- (eq? (car arg) '-)
- (= (length arg) 3))
- (lint-format "perhaps ~A" name (lists->string form `(,(car form) ,(cadr arg) ,(caddr arg))))))))
- ;; could change (> x 0) to (positive? x) and so on, but the former is clear and ubiquitous
-
- ((char<? char>? char<=? char>=? char=?
- char-ci<? char-ci>? char-ci<=? char-ci>=? char-ci=?)
- (let ((cleared-form (cons (car form) ; keep operator
- (remove-if (lambda (x)
- (not (char? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" name (truncated-list->string form)))))
-
- ((string<? string>? string<=? string>=? string=?
- string-ci<? string-ci>? string-ci<=? string-ci>=? string-ci=?)
- (let ((cleared-form (cons (car form) ; keep operator
- (remove-if (lambda (x)
- (not (string? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" name (truncated-list->string form)))))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (when (= len 3)
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (let ((var (or (and (memv arg1 '(0 1))
+ (pair? arg2)
+ (eq? (car arg2) 'length)
+ (cadr arg2))
+ (and (memv arg2 '(0 1))
+ (pair? arg1)
+ (eq? (car arg1) 'length)
+ (cadr arg1)))))
+ (if var
+ (if (or (eqv? arg1 0)
+ (eqv? arg2 0))
+ (lint-format "perhaps (assuming ~A is a list), ~A" caller var
+ (lists->string form `(null? ,var)))
+ (if (symbol? var)
+ (lint-format "perhaps (assuming ~A is a list), ~A" caller var
+ (lists->string form `(and (pair? ,var) (null? (cdr ,var))))))))))
+ (unrelop caller '= form))
+ (check-char-cmp caller head form)))
+
+ ;; ----------------
+ ((< > <= >=) ; '= handled above
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (number? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (if (= (length form) 3)
+ (unrelop caller head form)
+ (when (> (length form) 3)
+ (if (and (memq head '(< >))
+ (repeated-member? (cdr form) env))
+ (lint-format "perhaps ~A" caller (truncated-lists->string form #f))
+ (if (and (memq head '(<= >=))
+ (repeated-member? (cdr form) env))
+ (let ((last-arg (cadr form))
+ (new-args (list (cadr form))))
+ (do ((lst (cddr form) (cdr lst)))
+ ((null? lst)
+ (if (repeated-member? new-args env)
+ (lint-format "perhaps ~A" caller (truncated-lists->string form `(= ,@(lint-remove-duplicates (reverse new-args) env))))
+ (if (< (length new-args) (length (cdr form)))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string form (or (null? (cdr new-args))
+ `(= ,@(reverse new-args))))))))
+ (unless (equal? (car lst) last-arg)
+ (set! last-arg (car lst))
+ (set! new-args (cons last-arg new-args)))))))))
+
+ (when (= (length form) 3)
+ (cond ((and (eqv? (cadr form) 0)
+ (eq? head '>)
+ (pair? (caddr form))
+ (hash-table-ref non-negative-ops (caaddr form)))
+ (lint-format "~A can't be negative: ~A" caller (caaddr form) (truncated-list->string form)))
+
+ ((and (eqv? (caddr form) 0)
+ (eq? head '<)
+ (pair? (cadr form))
+ (hash-table-ref non-negative-ops (caadr form)))
+ (lint-format "~A can't be negative: ~A" caller (caadr form) (truncated-list->string form)))
+
+ ((and (pair? (cadr form))
+ (eq? (caadr form) 'length))
+ (let ((arg (cadadr form)))
+ (when (symbol? arg)
+ (if (eqv? (caddr form) 0)
+ (lint-format "perhaps~A ~A" caller
+ (if (eq? head '<) "" (format #f " (assuming ~A is a proper list)," arg))
+ (lists->string form
+ (case head
+ ((<) `(and (pair? ,arg) (not (proper-list? ,arg))))
+ ((<=) `(null? ,arg))
+ ((>) `(pair? ,arg))
+ ((>=) `(list? ,arg)))))
+ (if (and (eqv? (caddr form) 1)
+ (not (eq? head '>)))
+ (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
+ (lists->string form
+ (case head
+ ((<) `(null? ,arg))
+ ((<=) `(or (null? ,arg) (null? (cdr ,arg))))
+ ((>) `(and (pair? ,arg) (pair? (cdr ,arg))))
+ ((>=) `(pair? ,arg))))))))))
+ ((and (pair? (caddr form))
+ (eq? (caaddr form) 'length))
+ (let ((arg (cadr (caddr form))))
+ (when (symbol? arg)
+ (if (eqv? (cadr form) 0)
+ (lint-format "perhaps~A ~A" caller
+ (if (eq? head '>) "" (format #f " (assuming ~A is a proper list)," arg))
+ (lists->string form
+ (case head
+ ((<) `(pair? ,arg))
+ ((<=) `(list? ,arg))
+ ((>) `(and (pair? ,arg) (not (proper-list? ,arg))))
+ ((>=) `(null? ,arg)))))
+ (if (and (eqv? (cadr form) 1)
+ (not (eq? head '<)))
+ (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
+ (lists->string form
+ (case head
+ ((<) `(and (pair? ,arg) (pair? (cdr ,arg))))
+ ((<=) `(pair? ,arg))
+ ((>) `(null? ,arg))
+ ((>=) `(or (null? ,arg) (null? (cdr ,arg))))))))))))))
+ (check-char-cmp caller head form))
+ ;; could change (> x 0) to (positive? x) and so on, but the former is clear and ubiquitous
+
+ ;; ----------------
+ ((char<? char>? char<=? char>=? char=? char-ci<? char-ci>? char-ci<=? char-ci>=? char-ci=?)
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (char? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+ (if (and (eq? head 'char-ci=?) ; (char-ci=? x #\return)
+ (pair? (cdr form))
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (or (and (char? (cadr form))
+ (char=? (cadr form) (other-case (cadr form))))
+ (and (char? (caddr form))
+ (char=? (caddr form) (other-case (caddr form))))))
+ (lint-format "char-ci=? could be char=? here: ~A" caller form)))
+
+ ;; ----------------
+ ((string<? string>? string<=? string>=? string=? string-ci<? string-ci>? string-ci<=? string-ci>=? string-ci=?)
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (string? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (if (every? (lambda (a)
+ (or (and (string? a)
+ (= (length a) 1))
+ (and (pair? a)
+ (eq? (car a) 'string))))
+ (cdr form))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,(string->symbol (string-append "char" (substring (symbol->string head) 6)))
+ ,@(map (lambda (a)
+ (if (string? a)
+ (string-ref a 0)
+ (cadr a)))
+ (cdr form)))))))
+ ;; ----------------
+ ((length)
+ (when (pair? (cdr form))
+ (if (pair? (cadr form))
+ (let ((arg (cadr form)))
+ (case (car arg)
+ ((string->list vector->list)
+ (if (null? (cddr arg)) ; string->list has start:end etc
+ (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg))))
+ (if (pair? (cdddr arg))
+ (if (and (integer? (cadddr arg))
+ (integer? (caddr arg)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (max 0 (- (cadddr arg) (caddr arg))))
+ (lint-format "perhaps ~A" caller (lists->string form `(- ,(cadddr arg) ,(caddr arg)))))
+ (lint-format "perhaps ~A" caller (lists->string form `(- (length ,(cadr arg)) ,(caddr arg)))))))
+ ((reverse reverse! list->vector list->string let->list)
+ (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg)))))
+ ((cons)
+ (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(caddr arg)) 1))))
+ ((make-list)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
+ ((list)
+ (lint-format "perhaps ~A" caller (lists->string form (- (length arg) 1))))
+ ((append)
+ (if (= (length arg) 3)
+ (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(cadr arg)) (length ,(caddr arg)))))))
+ ((quote)
+ (if (list? (cadr arg))
+ (lint-format "perhaps ~A" caller (lists->string form (length (cadr arg))))))))
+ ;; not pair cadr
+ (if (code-constant? (cadr form))
+ (lint-format "perhaps ~A -> ~A" caller
+ (truncated-list->string form)
+ (length (if (and (pair? (cadr form))
+ (eq? (caadr form) 'quote))
+ (cadadr form)
+ (cadr form))))))))
+ ;; ----------------
+ ((zero? positive? negative?)
+ (when (pair? (cdr form))
+ (let ((arg (cadr form)))
+ (when (pair? arg)
+
+ (if (and (eq? head 'negative?)
+ (hash-table-ref non-negative-ops (car arg)))
+ (lint-format "~A can't be negative: ~A" caller head (truncated-list->string form)))
+
+ (case (car arg)
+ ((-)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((op '((zero? = zero?) (positive? > negative?) (negative? < positive?))))
+ (if (null? (cddr arg))
+ `(,(caddr (assq head op)) ,(cadr arg))
+ (if (null? (cdddr arg))
+ `(,(cadr (assq head op)) ,(cadr arg) ,(caddr arg))
+ `(,(cadr (assq head op)) ,(cadr arg) (+ ,@(cddr arg)))))))))
+ ((denominator)
+ (if (eq? head 'zero)
+ (lint-format "denominator can't be zero: ~A" caller form)))
+
+ ((length)
+ (if (eq? head 'zero?)
+ (lint-format "perhaps (assuming ~A is list) use null? instead of length: ~A" caller (cadr arg)
+ (lists->string form `(null? ,(cadr arg)))))))))))
+ ;; (zero? (logand...)) is nearly always preceded by not and handled elsewhere
+
+ ;; ----------------
+ ((/)
+ (when (pair? (cdr form))
+ (if (and (null? (cddr form))
+ (number? (cadr form))
+ (zero? (cadr form)))
+ (lint-format "attempt to invert zero: ~A" caller (truncated-list->string form))
+ (if (and (pair? (cddr form))
+ (memv 0 (cddr form)))
+ (lint-format "attempt to divide by 0: ~A" caller (truncated-list->string form))))))
+
+ ;; ----------------
+ ((copy)
+ (cond ((and (pair? (cdr form))
+ (or (number? (cadr form))
+ (boolean? (cadr form))
+ (char? (cadr form))
+ (and (pair? (cadr form))
+ (memq (caadr form) '(copy string-copy))) ; or any maker?
+ (and (pair? (cddr form))
+ (equal? (cadr form) (caddr form)))))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form)))
+
+ ((and (pair? (cdr form))
+ (equal? (cadr form) '(owlet)))
+ (lint-format "~A could be (owlet): owlet is copied internally" caller form))
+
+ ((= (length form) 5)
+ (check-start-and-end caller head (cdddr form) form env))))
+
+ ;; ----------------
+ ((string-copy)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(copy string-copy string make-string string-upcase string-downcase
+ string-append list->string symbol->string number->string)))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))))
+
+ ;; ----------------
+ ((string)
+ (if (every? (lambda (x)
+ (and (char? x)
+ (char<=? #\space x #\~))) ; #\0xx chars here look dumb
+ (cdr form))
+ (lint-format "~A could be ~S" caller (truncated-list->string form) (apply string (cdr form)))))
+
+ ;; ----------------
+ ((string?)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(format number->string)))
+ (if (eq? (caadr form) 'format)
+ (lint-format "format returns either #f or a string, so ~A" caller (lists->string form (cadr form)))
+ (lint-format "number->string always returns a string, so ~A" caller (lists->string form #t)))
+ (check-boolean-affinity caller form env)))
+
+ ((number?)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'string->number))
+ (lint-format "string->number returns either #f or a number, so ~A" caller (lists->string form (cadr form)))
+ (check-boolean-affinity caller form env)))
+
+ ((symbol? rational? real? complex? float? keyword? gensym? byte-vector? proper-list?
+ char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? c-object?
+ output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer?)
+ (check-boolean-affinity caller form env))
+
+ ((pair? list?)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(memq memv member assq assv assoc procedure-signature)))
+ (lint-format "~A returns either #f or a pair, so ~A" caller (caadr form)
+ (lists->string form (cadr form)))))
+
+ ((integer?)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(char-position string-position)))
+ (lint-format "~A returns either #f or an integer, so ~A" caller (caadr form)
+ (lists->string form (cadr form)))))
+
+ ((null?)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(vector->list string->list let->list)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(zero? (length ,(cadadr form)))))))
+
+ ;; ----------------
+ ((string-ref)
+ (when (and (= (length form) 3)
+ (pair? (cadr form)))
+ (let ((target (cadr form)))
+ (case (car target)
+ ((substring)
+ (if (= (length target) 3)
+ (lint-format "perhaps ~A" caller (lists->string form `(string-ref ,(cadr target) (+ ,(caddr form) ,(caddr target)))))))
+ ((symbol->string)
+ (if (and (integer? (caddr form))
+ (pair? (cadr target))
+ (eq? (caadr target) 'quote)
+ (symbol? (cadadr target)))
+ (lint-format "perhaps ~A" caller (lists->string form (string-ref (symbol->string (cadadr target)) (caddr form))))))
+ ((make-string)
+ (if (and (integer? (cadr target))
+ (integer? (caddr form))
+ (> (cadr target) (caddr form)))
+ (lint-format "perhaps ~A" caller (lists->string form (if (= (length target) 3) (caddr target) #\space)))))))))
+
+ ;; ----------------
+ ((vector-ref list-ref hash-table-ref let-ref int-vector-ref float-vector-ref)
+ (unless (= line-number last-checker-line-number)
+ (when (= (length form) 3)
+ (let ((seq (cadr form)))
+ (when (pair? seq)
+ (if (and (memq (car seq) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
+ (= (length seq) 3)) ; (vector-ref (vector-ref x i) j) -> (x i j)
+ (let ((seq1 (cadr seq))) ; x
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? seq1) ; (vector-ref (vector-ref (vector-ref x i) j) k) -> (x i j k)
+ (memq (car seq1) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
+ (= (length seq1) 3))
+ `(,(cadr seq1) ,(caddr seq1) ,(caddr seq) ,(caddr form))
+ `(,seq1 ,(caddr seq) ,(caddr form))))))
+ (if (memq (car seq) '(make-vector make-list vector list
+ make-float-vector make-int-vector float-vector int-vector
+ make-hash-table hash-table hash-table*
+ inlet))
+ (lint-format "this doesn't make much sense: ~A" caller form)))
+ (if (and (eq? head 'list-ref)
+ (eq? (car seq) 'quote)
+ (proper-list? (cadr seq)))
+ (lint-format "perhaps use a vector: ~A" caller
+ (lists->string form `(vector-ref ,(apply vector (cadr seq)) ,(caddr form))))))))
+ (set! last-checker-line-number line-number)))
+
+ ;; ----------------
+ ((vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! string-set! let-set!)
+ (when (= (length form) 4)
+ (let ((target (cadr form))
+ (index (caddr form))
+ (val (cadddr form)))
- ((call-with-exit)
- (let ((return (and (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) 'lambda)
- (pair? (cdadr form))
- (pair? (cadadr form))
- (car (cadadr form)))))
- (if (symbol? return)
- (let ((body (cddadr form)))
- (if (not (tree-member return body))
- (lint-format "exit-function appears to be unused: ~A" name (truncated-list->string form)))))))
-
- ((call-with-input-string call-with-input-file call-with-output-file)
- ;; call-with-output-string func is the first arg, not second, but these checks get no hits
- (let ((port (and (pair? (cdr form))
- (pair? (cddr form))
- (pair? (caddr form))
- (eq? (caaddr form) 'lambda)
- (pair? (cdaddr form))
- (pair? (cadr (caddr form)))
- (car (cadr (caddr form))))))
- (if (symbol? port)
- (let ((body (cddr (caddr form))))
- (if (not (tree-member port body))
- (lint-format "port appears to be unused: ~A" name (truncated-list->string form)))))))
-
- ((/)
- (if (pair? (cdr form))
- (if (and (null? (cddr form))
- (number? (cadr form))
- (zero? (cadr form)))
- (lint-format "attempt to invert zero: ~A" name (truncated-list->string form))
- (if (and (pair? (cddr form))
- (memv 0 (cddr form)))
- (lint-format "attempt to divide by 0: ~A" name (truncated-list->string form))))))
-
- ((copy)
- (if (and (pair? (cdr form))
- (or (number? (cadr form))
- (boolean? (cadr form))
- (char? (cadr form))
- (and (pair? (cadr form))
- (memq (caadr form) '(copy string-copy)))))
- (lint-format "~A could be ~A" name form (cadr form))
- (if (and (pair? (cdr form)) (equal? (cadr form) '(owlet)))
- (lint-format "~A could be (owlet): owlet is copied internally" name form))))
-
- ((string-copy)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(copy string-copy)))
- (lint-format "~A could be ~A" name form (cadr form))))
-
- ((string)
- (if (every? (lambda (x) (and (char? x) (not (member x '(#\null #\newline #\escape))))) (cdr form)) ;#\linefeed -> #\newline in reader
- (lint-format "~A could be ~S" name form (apply string (cdr form)))))
-
- ((string? number?)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) (if (eq? head 'string?) 'number->string 'string->number)))
- (lint-format "perhaps ~A" name (lists->string form (cadr form)))))
-
- ((vector-ref list-ref hash-table-ref let-ref int-vector-ref float-vector-ref)
- (unless (= line-number last-checker-line-number)
- (if (= (length form) 3)
- (let ((seq (cadr form)))
- (if (and (pair? seq)
- (eq? (car seq) head) ; perhaps instead: (memq (car seq) '(vector-ref list-ref hash-table-ref let-ref))
- (= (length seq) 3))
- (let ((seq1 (cadr seq)))
- (if (and (pair? seq1)
- (eq? (car seq1) head)
- (= (length seq1) 3))
- (lint-format "perhaps ~A" name (lists->string form `(,(cadr seq1) ,(caddr seq1) ,(caddr seq) ,(caddr form))))
- (lint-format "perhaps ~A" name (lists->string form `(,seq1 ,(caddr seq) ,(caddr form)))))))))
- (set! last-checker-line-number line-number)))
-
- ((vector-set! list-set! hash-table-set! float-vector-set! int-vector-set!)
- (if (= (length form) 4)
- (let ((target (cadr form))
- (index (caddr form))
- (val (cadddr form)))
- (if (and (pair? val)
- (= (length val) 3)
- (eq? target (cadr val))
- (equal? index (caddr val))
- (memq (car val) '(vector-ref list-ref hash-table-ref float-vector-ref int-vector-ref)))
- (lint-format "redundant?: ~A" name (truncated-list->string form))
- (if (and (pair? target)
- (memq (car target) '(vector-ref list-ref hash-table-ref float-vector-ref int-vector-ref)))
- (lint-format "perhaps ~A" name (lists->string form `(set! (,@(cdr target) ,index) ,val)))
- (if (or (code-constant? (cadr form))
- (and (pair? (cadr form))
- (memq (caadr form) '(make-vector vector make-string string make-list list append cons vector-append copy))))
- (lint-format "perhaps ~A" name (lists->string form val))))))))
-
- ((object->string)
- (if (pair? (cdr form))
- (if (and (pair? (cadr form))
- (eq? (caadr form) 'object->string))
- (lint-format "~A could be ~A" name form (cadr form))
- (if (and (pair? (cddr form))
- (not (pair? (caddr form)))
- (or (not (symbol? (caddr form))) (keyword? (caddr form)))
- (not (memq (caddr form) '(#f #t :readable))))
- (lint-format "bad second argument: ~A" name (caddr form))))))
-
- ((display)
- (if (and (= (length form) 2)
- (pair? (cadr form))
- (eq? (caadr form) 'format)
- (not (cadadr form)))
- (lint-format "~A could be ~A" name form `(format #t ,@(cddadr form)))))
-
- ((make-vector)
- (if (and (= (length form) 4)
- (code-constant? (caddr form))
- (not (real? (caddr form)))
- (eq? (cadddr form) #t))
- (lint-format "~A won't create an homogenous vector" name form)))
-
- ((reverse list->vector vector->list list->string string->list symbol->string string->symbol number->string)
- ;; not string->number -- no point in copying a number and it's caught below
- (let ((inverses '((reverse . reverse)
- (list->vector . vector->list)
- (vector->list . list->vector)
- (symbol->string . string->symbol)
- (string->symbol . symbol->string)
- (list->string . string->list)
- (string->list . list->string)
- (number->string . string->number))))
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (pair? (cdadr form))
- (eq? (caadr form) (let ((p (assq head inverses))) (and (pair? p) (cdr p)))))
- (lint-format "~A could be (copy ~A)" name form (cadadr form)))))
-
- ((char->integer integer->char symbol->keyword keyword->symbol string->number)
- (let ((inverses '((char->integer . integer->char)
- (integer->char . char->integer)
- (symbol->keyword . keyword->symbol)
- (keyword->symbol . symbol->keyword)
- (string->number . number->string))))
- (if (and (pair? (cdr form))
+ (cond ((and (pair? val) ; (vector-set! x 0 (vector-ref x 0))
+ (= (length val) 3)
+ (eq? target (cadr val))
+ (equal? index (caddr val))
+ (memq (car val) '(vector-ref list-ref hash-table-ref string-ref let-ref float-vector-ref int-vector-ref)))
+ (lint-format "redundant ~A: ~A" caller head (truncated-list->string form)))
+
+ ((and (pair? target) ; (vector-set! (vector-ref x 0) 1 2) -- vector within vector
+ (not (eq? head 'string-set!))
+ (memq (car target) '(vector-ref list-ref hash-table-ref let-ref float-vector-ref int-vector-ref)))
+ (lint-format "perhaps ~A" caller (lists->string form `(set! (,@(cdr target) ,index) ,val))))
+
+ ((and (pair? target) ; (vector-set! (make-vector 3) 1 1) -- does this ever happen?
+ (memq (car target) '(make-vector vector make-string string make-list list append cons vector-append copy inlet sublet)))
+ (lint-format "~A is simply discarded; perhaps ~A" caller
+ (truncated-list->string target)
+ (lists->string form val)))
+
+ ((code-constant? target) ; (vector-set! #(0 1 2) 1 3)??
+ (lint-format "~A is a constant that is discarded; perhaps ~A" caller target (lists->string form val)))))))
+
+ ;; ----------------
+ ((object->string)
+ (when (pair? (cdr form))
+ (if (and (pair? (cadr form))
+ (eq? (caadr form) 'object->string))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))
+ (if (pair? (cddr form))
+ (let ((arg2 (caddr form)))
+ (if (or (and (keyword? arg2)
+ (not (eq? arg2 :readable)))
+ (and (code-constant? arg2)
+ (not (boolean? arg2))))
+ (lint-format "bad second argument: ~A" caller arg2)))))))
+
+ ;; ----------------
+ ((display)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (let ((arg (cadr form))
+ (port (if (pair? (cddr form))
+ (caddr form)
+ ())))
+ (cond ((and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg)))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
+
+ ((and (eq? (car arg) 'format)
+ (pair? (cdr arg))
+ (not (cadr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(format ,port ,@(cddr arg)))))
+
+ ((and (eq? (car arg) 'apply)
+ (pair? (cdr arg))
+ (eq? (cadr arg) 'format)
+ (pair? (cddr arg))
+ (not (caddr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(apply format ,port ,@(cdddr arg)))))))))
+
+ ;; ----------------
+ ((make-vector make-int-vector make-float-vector)
+ ;; type of initial value is checked elsewhere
+ (if (and (= (length form) 4)
+ (eq? head 'make-vector)
+ (code-constant? (caddr form))
+ (not (real? (caddr form)))
+ (eq? (cadddr form) #t))
+ (lint-format "~A won't create an homogeneous vector" caller form))
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form #()))))
+
+ ;; ----------------
+ ((make-string make-byte-vector)
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form "")))) ; #u8() but (equal? #u8() "") -> #t so lint combines these clauses!
+
+ ;; ----------------
+ ((make-list)
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form ()))))
+
+ ;; ----------------
+ ((reverse reverse! list->vector vector->list list->string string->list symbol->string string->symbol number->string)
+ ;; not string->number -- no point in copying a number and it's caught below
+
+ (let ((inverses '((reverse . reverse)
+ (reverse! . reverse!)
+ (list->vector . vector->list)
+ (vector->list . list->vector)
+ (symbol->string . string->symbol)
+ (string->symbol . symbol->string)
+ (list->string . string->list)
+ (string->list . list->string)
+ (number->string . string->number))))
+ (when (and (pair? (cdr form))
(pair? (cadr form))
- (pair? (cdadr form))
- (eq? (caadr form) (let ((p (assq head inverses))) (and (pair? p) (cdr p)))))
- (lint-format "~A could be ~A" name form (cadadr form)))))
-
- ((string-append)
- (if (not (= line-number last-checker-line-number))
- (let ((args (remove-all "" (splice-if (lambda (x) (eq? x 'string-append)) (cdr form)))))
- (if (null? args)
- (lint-format "perhaps ~A" name (lists->string form ""))
- (if (null? (cdr args))
- (lint-format "perhaps ~A, or use copy" name (lists->string form (car args)))
- (if (every? string? args)
- (lint-format "perhaps ~A" name (lists->string form (apply string-append args)))
- (if (not (equal? args (cdr form)))
- (lint-format "perhaps ~A" name (lists->string form `(string-append , at args)))))))
- (set! last-checker-line-number line-number))))
-
- ((vector-append)
- (if (not (= line-number last-checker-line-number))
- (let ((args (remove-all #() (splice-if (lambda (x) (eq? x 'vector-append)) (cdr form)))))
- (if (null? args)
- (lint-format "perhaps ~A" name (lists->string form #()))
- (if (null? (cdr args))
- (lint-format "perhaps ~A" name (lists->string form (car args)))
- (if (every? vector? args)
- (lint-format "perhaps ~A" name (lists->string form (apply vector-append args)))
- (if (not (equal? args (cdr form)))
- (lint-format "perhaps ~A" name (lists->string form `(vector-append , at args)))))))
- (set! last-checker-line-number line-number))))
-
- ((cons)
- (if (and (= (length form) 3)
- (pair? (caddr form))
- (eq? (caaddr form) 'list))
- (lint-format "perhaps ~A" name (lists->string form `(list ,(cadr form) ,@(cdaddr form))))))
-
- ((append)
- (unless (= line-number last-checker-line-number)
- (set! last-checker-line-number line-number)
- (letrec ((splice-append (lambda (lst)
- (cond ((null? lst) ())
- ((pair? lst)
- (if (and (pair? (car lst))
- (eq? (caar lst) 'append))
- (if (null? (cdar lst))
- (cons () (splice-append (cdr lst)))
- (append (splice-append (cdar lst)) (splice-append (cdr lst))))
- (cons (car lst) (splice-append (cdr lst)))))
- (#t lst)))))
- (let ((new-args (splice-append (cdr form)))) ; (append '(1) (append '(2) '(3))) -> (append '(1) '(2) '(3))
- (let ((len1 (length new-args)))
-
- (define (distribute-quote x)
- (map (lambda (item)
- (if (or (symbol? item)
- (pair? item))
- `(quote ,item)
- item))
- x))
-
- (define (append->list . items)
- (let ((lst (list 'list)))
- (for-each (lambda (item)
- (set! lst (append lst (if (eq? (car item) 'list)
- (cdr item)
- (distribute-quote (cadr item))))))
- items)
- lst))
+ (pair? (cdadr form)))
+ (let ((inv-op (assq head inverses))
+ (arg (cadr form))
+ (arg-of-arg (cadadr form))
+ (func-of-arg (caadr form)))
+ (if (pair? inv-op) (set! inv-op (cdr inv-op)))
+
+ (cond ((eq? func-of-arg inv-op) ; (vector->list (list->vector x)) -> x
+ (if (eq? head 'string->symbol)
+ (lint-format "perhaps ~A" caller (lists->string form arg-of-arg))
+ (lint-format "~A could be (copy ~S)" caller form arg-of-arg)))
+
+ ((and (eq? head 'list->string) ; (list->string (vector->list x)) -> (copy x (make-string (length x)))
+ (eq? func-of-arg 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-string (length ,arg-of-arg))))))
+
+ ((and (eq? head 'list->string) ; (list->string (make-list x y)) -> (make-string x y)
+ (eq? func-of-arg 'make-list))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-string ,@(cdr arg)))))
+
+ ((and (eq? head 'list->vector) ; (list->vector (make-list ...)) -> (make-vector ...)
+ (eq? func-of-arg 'make-list))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-vector ,@(cdr arg)))))
+
+ ((and (eq? head 'list->vector) ; (list->vector (string->list x)) -> (copy x (make-vector (length x)))
+ (eq? func-of-arg 'string->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-vector (length ,arg-of-arg))))))
+
+ ((and (eq? head 'vector->list) ; (vector->list (make-vector ...)) -> (make-list ...)
+ (eq? func-of-arg 'make-vector))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-list ,@(cdr arg)))))
+
+ ((and (memq func-of-arg '(reverse reverse! copy))
+ (pair? (cadr arg)) ; (list->string (reverse (string->list x))) -> (reverse x)
+ (eq? (caadr arg) inv-op))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? func-of-arg 'reverse!) 'reverse func-of-arg) ,(cadadr arg)))))
+
+ ((and (pair? (cadr arg))
+ (memq func-of-arg '(cdr cddr cdddr cddddr list-tail))
+ (case head
+ ((list->string) (eq? (caadr arg) 'string->list))
+ ((list->vector) (eq? (caadr arg) 'vector->list))
+ (else #f)))
+ (let ((len-diff (if (eq? func-of-arg 'list-tail)
+ (caddr arg)
+ (cdr-count func-of-arg))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if (eq? head 'list->string)
+ `(substring ,(cadadr arg) ,len-diff)
+ `(copy ,(cadadr arg) (make-vector (- (length ,(cadadr arg)) ,len-diff))))))))
+
+ ((and (memq head '(list->vector list->string))
+ (eq? func-of-arg 'sort!)
+ (pair? (cadr arg))
+ (eq? (caadr arg) (if (eq? head 'list->vector) 'vector->list 'string->list)))
+ (lint-format "perhaps ~A" caller (lists->string form `(sort! ,(cadadr arg) ,(caddr arg)))))
+
+ ((and (memq head '(list->vector list->string))
+ (or (memq func-of-arg '(list cons))
+ (quoted-undotted-pair? arg)))
+ (let ((maker (if (eq? head 'list->vector) 'vector 'string)))
+ (cond ((eq? func-of-arg 'list)
+ (if (var-member maker env)
+ (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
+ (lint-format "perhaps ~A" caller (lists->string form `(,maker ,@(cdr arg))))))
+ ((eq? func-of-arg 'cons)
+ (if (or (null? (caddr arg))
+ (quoted-null? (caddr arg)))
+ (if (var-member maker env)
+ (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
+ (lint-format "perhaps ~A" caller (lists->string form `(,maker ,(cadr arg)))))))
+ ((or (null? (cddr form))
+ (and (integer? (caddr form))
+ (or (null? (cdddr form))
+ (integer? (cadddr form)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (apply (if (eq? head 'list->vector) vector string) (cadr arg))))))))
+
+ ((and (eq? head 'list->string) ; (list->string (reverse x)) -> (reverse (apply string x))
+ (memq func-of-arg '(reverse reverse!)))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply string ,arg-of-arg)))))
+
+ ((and (memq head '(string->list vector->list))
+ (= (length form) 4))
+ (check-start-and-end caller head (cddr form) form env))
+
+ ((and (eq? head 'symbol->string) ; (string->symbol "constant-string") never happens, but the reverse does?
+ (quoted-symbol? arg))
+ (lint-format "perhaps ~A" caller (lists->string form (apply symbol->string (cdadr form)))))
+
+ ((and (pair? arg-of-arg) ; (op (reverse (inv-op x))) -> (reverse x)
+ (eq? func-of-arg 'reverse)
+ (eq? inv-op (car arg-of-arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse ,(cadr arg-of-arg)))))))))
+
+ (when (and (pair? (cdr form))
+ (not (pair? (cadr form))))
+ (let ((arg (cadr form)))
+ (if (and (eq? head 'string->list)
+ (string? arg)
+ (or (null? (cddr form))
+ (and (integer? (caddr form))
+ (or (null? (cdddr form))
+ (integer? (cadddr form))))))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (apply string->list (cdr form))))))
+
+ (when (and (memq head '(vector->list string->list))
+ (pair? (cddr form))
+ (pair? (cdddr form))
+ (equal? (caddr form) (cadddr form)))
+ (lint-format "leaving aside errors, ~A is ()" caller (truncated-list->string form)))
+
+ (when (and (memq head '(reverse reverse!))
+ (pair? (cdr form))
+ (pair? (cadr form)))
+ (let ((arg (cadr form)))
+ (if (and (memq (car arg) '(cdr list-tail)) ; (reverse (cdr (reverse lst))) = all but last of lst -> copy to len-1
+ (pair? (cadr arg))
+ (memq (caadr arg) '(reverse reverse!))
+ (symbol? (cadadr arg)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(copy ,(cadadr arg) (make-list (- (length ,(cadadr arg)) ,(if (eq? (car arg) 'cdr) 1 (caddr arg))))))))
+
+ (if (and (eq? (car arg) 'append) ; (reverse (append (reverse b) res)) = (append (reverse res) b)
+ (pair? (cadr arg))
+ (eq? (caadr arg) 'reverse)
+ (pair? (cddr arg))
+ (null? (cdddr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append (reverse ,(caddr arg)) ,(cadadr arg)))))
+
+ (if (and (eq? (car arg) 'cons) ; (reverse (cons x (reverse lst))) -- adds x to end -- (append lst (list x))
+ (pair? (caddr arg))
+ (memq (car (caddr arg)) '(reverse reverse!)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append ,(cadr (caddr arg)) (list ,(cadr arg)))))))))
+
+ ;; ----------------
+ ((char->integer integer->char symbol->keyword keyword->symbol string->number)
+ (let ((inverses '((char->integer . integer->char)
+ (integer->char . char->integer)
+ (symbol->keyword . keyword->symbol)
+ (keyword->symbol . symbol->keyword)
+ (string->number . number->string))))
+ (cond ((and (pair? (cdr form))
+ (pair? (cadr form))
+ (pair? (cdadr form))
+ (eq? (caadr form) (cond ((assq head inverses) => cdr))))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadadr form)))
+
+ ((and (eq? head 'integer->char)
+ (pair? (cdr form))
+ (integer? (cadr form))
+ (or (<= 32 (cadr form) 127)
+ (memv (cadr form) '(0 7 8 9 10 13 27))))
+ (lint-format "perhaps ~A -> ~W" caller (truncated-list->string form) (integer->char (cadr form))))
+
+ ((and (eq? head 'symbol->keyword)
+ (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'string->symbol))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-keyword ,(cadadr form))))))))
+
+ ;; ----------------
+ ((string-append)
+ (unless (= line-number last-checker-line-number)
+ (let ((args (remove-all "" (splice-if (lambda (x) (eq? x 'string-append)) (cdr form)))))
+ (if (member 'string args (lambda (a b) (and (pair? b) (eq? (car b) a))))
+ (let ((nargs ())) ; look for (string...) (string...) in the arg list and combine
+ (do ((p args (cdr p)))
+ ((null? p)
+ (set! args (reverse nargs)))
+ (if (and (pair? (car p))
+ (pair? (cadr p))
+ (eq? (caar p) 'string)
+ (eq? (caadr p) 'string))
+ (begin
+ (set! nargs (cons `(string ,@(cdar p) ,@(cdadr p)) nargs))
+ (set! p (cdr p)))
+ (set! nargs (cons (car p) nargs))))))
+ (cond ((null? args) ; (string-append) -> ""
+ (lint-format "perhaps ~A" caller (lists->string form "")))
+ ((null? (cdr args)) ; (string-append a) -> a
+ (if (not (tree-memq 'values (cdr form)))
+ (lint-format "perhaps ~A, or use copy" caller (lists->string form (car args)))))
+ ((every? string? args) ; (string-append "a" "b") -> "ab"
+ (lint-format "perhaps ~A" caller (lists->string form (apply string-append args))))
+ ((every? (lambda (a) ; (string-append "a" (string #\b)) -> "ab"
+ (or (string? a)
+ (and (pair? a)
+ (eq? (car a) 'string)
+ (char? (cadr a)))))
+ args)
+ (catch #t
+ (lambda ()
+ (let ((val (eval `(string-append , at args))))
+ (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
+ (lambda args #f)))
+ ((not (equal? args (cdr form)))
+ (lint-format "perhaps ~A" caller (lists->string form `(string-append , at args)))))
+ (set! last-checker-line-number line-number))))
+
+ ;; ----------------
+ ((vector-append)
+ (unless (= line-number last-checker-line-number)
+ (let ((args (remove-all #() (splice-if (lambda (x) (eq? x 'vector-append)) (cdr form)))))
+ (cond ((null? args)
+ (lint-format "perhaps ~A" caller (lists->string form #())))
+ ((null? (cdr args))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,(car args)))))
+ ((every? vector? args)
+ (lint-format "perhaps ~A" caller (lists->string form (apply vector-append args))))
+ ((not (equal? args (cdr form)))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector-append , at args)))))
+ (set! last-checker-line-number line-number))))
+
+ ;; ----------------
+ ((cons)
+ (when (and (= (length form) 3)
+ (not (= last-cons-line-number line-number)))
+ (cond ((and (pair? (caddr form))
+ (eq? (caaddr form) 'list)) ; (cons x (list ...)) -> (list x ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form) ,@(cdaddr form)))))
+
+ ((or (null? (caddr form)) ; (cons x '()) -> (list x)
+ (quoted-null? (caddr form)))
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form)))))
+
+ ((and (pair? (cadr form)) ; (cons (car x) (cdr x)) -> (copy x)
+ (pair? (caddr form))
+ (let ((x (assq (caadr form)
+ '((car cdr #t)
+ (caar cdar car) (cadr cddr cdr)
+ (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar)
+ (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar)
+ (caaddr cdaddr caddr) (cadaar cddaar cdaar) (cadadr cddadr cdadr) (caddar cdddar cddar)))))
+ (and x
+ (eq? (cadr x) (caaddr form))
+ (caddr x))))
+ => (lambda (cfunc)
+ (if (and cfunc
+ (equal? (cadadr form) (cadr (caddr form)))
+ (not (side-effect? (cadadr form) env)))
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (symbol? cfunc)
+ `(copy (,cfunc ,(cadadr form)))
+ `(copy ,(cadadr form))))))))
+
+ ((and (pair? (caddr form)) ; (cons a (cons b (cons ...))) -> (list a b ...), input ending in nil of course
+ (eq? (caaddr form) 'cons))
+ (let loop ((args (list (cadr form))) (chain (caddr form)))
+ (if (and (pair? chain)
+ (eq? (car chain) 'cons)
+ (pair? (cdr chain))
+ (pair? (cddr chain)))
+ (if (or (null? (caddr chain))
+ (quoted-null? (caddr chain)))
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,(cadr chain))))
+ (set! last-cons-line-number line-number))
+ (if (pair? (caddr chain))
+ (if (eq? (caaddr chain) 'cons)
+ (loop (cons (cadr chain) args) (caddr chain))
+ (if (eq? (caaddr chain) 'list)
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,(cadr chain) ,@(cdaddr chain))))
+ (set! last-cons-line-number line-number))))))))))))
+
+ ;; ----------------
+ ((append)
+ (unless (= line-number last-checker-line-number)
+ (set! last-checker-line-number line-number)
+ (letrec ((splice-append (lambda (lst)
+ (cond ((null? lst)
+ ())
+ ((not (pair? lst))
+ lst)
+ ((and (pair? (car lst))
+ (eq? (caar lst) 'append))
+ (if (null? (cdar lst))
+ (if (null? (cdr lst)) ; (append) at end -> () to keep copy intact?
+ (list ())
+ (splice-append (cdr lst)))
+ (append (splice-append (cdar lst)) (splice-append (cdr lst)))))
+ ((or (null? (cdr lst))
+ (not (or (null? (car lst))
+ (quoted-null? (car lst))
+ (and (pair? (car lst))
+ (eq? (caar lst) 'list)
+ (null? (cdar lst))))))
+ (cons (car lst) (splice-append (cdr lst))))
+ (else (splice-append (cdr lst)))))))
+
+ (let ((new-args (splice-append (cdr form)))) ; (append '(1) (append '(2) '(3))) -> (append '(1) '(2) '(3))
+ (let ((len1 (length new-args))
+ (suggestion made-suggestion))
+ (if (and (> len1 2)
+ (null? (list-ref new-args (- len1 1)))
+ (pair? (list-ref new-args (- len1 2)))
+ (memq (car (list-ref new-args (- len1 2))) '(list cons append map string->list vector->list make-list)))
+ (set-cdr! (list-tail new-args (- len1 2)) ()))
+
+ (define (append->list . items)
+ (let ((lst (list 'list)))
+ (for-each
+ (lambda (item)
+ (set! lst (append lst (if (eq? (car item) 'list)
+ (cdr item)
+ (distribute-quote (cadr item))))))
+ items)
+ lst))
+
+ (case len1
+ ((0) ; (append) -> ()
+ (lint-format "perhaps ~A" caller (lists->string form ())))
+ ((1) ; (append x) -> x
+ (lint-format "perhaps ~A" caller (lists->string form (car new-args))))
+ ((2) ; (append (list x) ()) -> (list x)
+ (let ((arg2 (cadr new-args))
+ (arg1 (car new-args)))
+ (cond ((or (null? arg2)
+ (quoted-null? arg2)
+ (equal? arg2 '(list))) ; (append x ()) -> (copy x)
+ (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,arg1))))
+
+ ((null? arg1) ; (append () x) -> x
+ (lint-format "perhaps ~A" caller (lists->string form arg2)))
+
+ ((not (pair? arg1)))
+
+ ((and (pair? arg2) ; (append (list x y) '(z)) -> (list x y 'z)
+ (or (eq? (car arg1) 'list)
+ (quoted-undotted-pair? arg1))
+ (or (eq? (car arg2) 'list)
+ (quoted-undotted-pair? arg2)))
+ (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))
- (case len1
- ((0) ; (append) -> ()
- (lint-format "perhaps ~A" name (lists->string form ())))
- ((1) ; (append x) -> x
- (lint-format "perhaps ~A" name (lists->string form (car new-args))))
- ((2)
- (if (or (null? (cadr new-args)) ; (append (list x) ()) -> (list x)
- (quoted-null? (cadr new-args))
- (equal? (cadr new-args) '(list)))
- (lint-format "perhaps clearer: ~A" name (lists->string form `(copy ,(car new-args))))
- (if (null? (car new-args)) ; (append () x) -> x
- (lint-format "perhaps ~A" name (lists->string form (cadr new-args)))
- (if (and (pair? (car new-args)) ; (append (list x y) '(z)) -> (list x y 'z)
- (or (eq? (caar new-args) 'list)
- (quoted-undotted-pair? (car new-args)))
- (pair? (cadr new-args))
- (or (eq? (caadr new-args) 'list)
- (quoted-undotted-pair? (cadr new-args))))
- (lint-format "perhaps ~A" name (lists->string form (apply append->list new-args)))
- (if (not (equal? (cdr form) new-args))
- (lint-format "perhaps ~A" name (lists->string form `(append , at new-args))))))))
- (else
- (if (every? (lambda (item)
- (and (pair? item)
- (or (eq? (car item) 'list)
- (quoted-undotted-pair? item))))
- new-args)
- (lint-format "perhaps ~A" name (lists->string form (apply append->list new-args)))
- (if (not (equal? (cdr form) new-args))
- (lint-format "perhaps ~A" name (lists->string form `(append , at new-args))))))))))))
-
- ((apply)
- (let ((function? (lambda (f)
- (or (and (symbol? f)
- (let ((func (symbol->value f *e*)))
- (or (procedure? func)
- (let ((e (or (var-member f env) (hash-table-ref globals f))))
- (and (var? e)
- (let? (var-new e))
- (memq ((var-new e) 'type) '(define define* lambda lambda*)))))))
- (and (pair? f)
- (memq (car f) '(lambda lambda*)))))))
-
- (if (and (pair? (cdr form))
- (not (symbol? (cadr form)))
- (not (applicable? (cadr form))))
- (lint-format "~S is not applicable: ~A" name (cadr form) (truncated-list->string form))
- (let ((len (length form)))
- (when (> len 2)
- (if (and (not (list? (form (- len 1))))
- (code-constant? (form (- len 1))))
- (lint-format "last argument should be a list: ~A" name (truncated-list->string form))
- (if (and (= len 3)
- (pair? (caddr form))
- (eq? (caaddr form) 'list)
- ;; macros are different here
- (function? (cadr form)))
- (lint-format "perhaps ~A" name (lists->string form `(,(cadr form) ,@(cdaddr form))))
- (if (and (or (not (every? code-constant? (cddr form)))
- (catch #t
- (lambda ()
- (let ((val (eval form)))
- (lint-format "perhaps ~A -> ~S" name form val)
- #t))
- (lambda args #f)))
- (symbol? (cadr form)))
- (let ((func (symbol->value (cadr form) *e*)))
- (if (procedure? func)
- (let ((ary (arity func)))
- (if (and (pair? ary)
- (> (- (length (cddr form)) 1) (cdr ary))) ; last apply arg might be var=()
- (lint-format "too many arguments for ~A: ~A" name (cadr form) form)))))))))))))
-
- ((format snd-display)
- (if (< (length form) 3)
- (begin
- (if (< (length form) 2)
- (lint-format "~A has too few arguments: ~A" name head (truncated-list->string form))
- (if (and (pair? (cadr form))
- (eq? (caadr form) 'format))
- (lint-format "redundant format: ~A" name (truncated-list->string form))
- (if (and (code-constant? (cadr form))
- (not (string? (cadr form))))
- (lint-format "format with one argument takes a string: ~A" name (truncated-list->string form)))))
- env)
- (let ((control-string (if (string? (cadr form)) (cadr form) (caddr form)))
- (args (if (string? (cadr form)) (cddr form) (cdddr form))))
+ ((and (eq? (car arg1) 'list) ; (append (list x) y) -> (cons x y)
+ (pair? (cdr arg1))
+ (null? (cddr arg1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr arg1) ,arg2))))
+
+ ((and (eq? (car arg1) 'vector->list)
+ (pair? arg2)
+ (eq? (car arg2) 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector->list (append ,(cadr arg1) ,(cadr arg2))))))
+
+ ((not (equal? (cdr form) new-args))
+ (lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))
+ (else
+ (if (every? (lambda (item)
+ (and (pair? item)
+ (or (eq? (car item) 'list)
+ (quoted-undotted-pair? item))))
+ new-args)
+ (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))))
- (define (count-directives str name form)
- (let ((curlys 0)
- (dirs 0)
- (pos (char-position #\~ str)))
- (if pos
+ (if (and (= made-suggestion suggestion)
+ (not (equal? (cdr form) new-args)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))))
+
+ ;; ----------------
+ ((apply)
+ (when (pair? (cdr form))
+ (let ((len (length form))
+ (suggestion made-suggestion))
+ (if (= len 2)
+ (lint-format "perhaps ~A" caller (lists->string form (list (cadr form))))
+ (if (not (or (<= len 2) ; it might be (apply)...
+ (symbol? (cadr form))
+ (applicable? (cadr form))))
+ (lint-format "~S is not applicable: ~A" caller (cadr form) (truncated-list->string form))
+ (let ((happy #f)
+ (f (cadr form)))
+ (unless (or (<= len 2)
+ (any-macro? f env)
+ (eq? f 'macroexpand)) ; handled specially (syntactic, not a macro)
+
+ (when (and (symbol? f)
+ (not (var-member f env)))
+ (let ((func (symbol->value f *e*)))
+ (if (procedure? func)
+ (let ((ary (arity func)))
+ (if (and (pair? ary)
+ (> (- (length form) 3) (cdr ary))) ; last apply arg might be var=()
+ (lint-format "too many arguments for ~A: ~A" caller f form))))))
+
+ (let ((last-arg (form (- len 1))))
+ (if (and (not (list? last-arg))
+ (code-constant? last-arg))
+ (lint-format "last argument should be a list: ~A" caller (truncated-list->string form))
+ (if (= len 3)
+ (let ((args (caddr form)))
+ (if (identity? f) ; (apply (lambda (x) x) y) -> (car y)
+ (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
+ (lists->string form `(car ,args)))
+ (if (simple-lambda? f) ; (apply (lambda (x) (f x)) y) -> (f (car y))
+ (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
+ (lists->string form (tree-subst (list 'car args) (caadr f) (caddr f))))))
+
+ (cond ((eq? f 'list) ; (apply list x) -> x?
+ (lint-format "perhaps ~A" caller (lists->string form args)))
+
+ ((or (null? args) ; (apply f ()) -> (f)
+ (quoted-null? args))
+ (lint-format "perhaps ~A" caller (lists->string form (list f))))
+
+ ((not (pair? args)))
+
+ ((eq? (car args) 'list) ; (apply f (list a b)) -> (f a b)
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(cdr args)))))
+
+ ((and (eq? (car args) 'quote) ; (apply eq? '(a b)) -> (eq? 'a 'b)
+ (= suggestion made-suggestion))
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(distribute-quote (cadr args))))))
+
+ ((eq? (car args) 'cons) ; (apply f (cons a b)) -> (apply f a b)
+ (lint-format "perhaps ~A" caller (lists->string form `(apply ,f ,@(cdr args)))))
+
+ ((and (memq f '(string vector int-vector float-vector))
+ (memq (car args) '(reverse reverse!))) ; (apply vector (reverse x)) -> (reverse (apply vector x))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply ,f ,(cadr args))))))
+
+ ((and (eq? f 'string-append) ; (apply string-append (map ...))
+ (eq? (car args) 'map))
+ (if (eq? (cadr args) 'symbol->string)
+ (lint-format "perhaps ~A" caller ; (apply string-append (map symbol->string ...))
+ (lists->string form `(format #f "~{~A~}" ,(caddr args))))
+ (if (simple-lambda? (cadr args))
+ (let ((body (caddr (cadr args))))
+ (if (and (pair? body)
+ (eq? (car body) 'string-append)
+ (= (length body) 3)
+ (or (and (string? (cadr body))
+ (eq? (caddr body) (caadr (cadr args))))
+ (and (string? (caddr body))
+ (eq? (cadr body) (caadr (cadr args))))))
+ (let ((str (string-append "~{"
+ (if (string? (cadr body)) (cadr body) "~A")
+ (if (string? (caddr body)) (caddr body) "~A")
+ "~}")))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(format #f ,str ,(caddr args))))))))))
+
+ ((and (eq? f 'append) ; (apply append (map vector->list args)) -> (vector->list (apply append args))
+ (eq? (car args) 'map)
+ (eq? (cadr args) 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector->list (apply append ,@(cddr args))))))
+
+ ((and (eq? (car args) 'append) ; (apply f (append (list ...)...)) -> (apply f ... ...)
+ (pair? (cadr args))
+ (eq? (caadr args) 'list))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(apply ,f ,@(cdadr args)
+ ,(if (null? (cddr args)) ()
+ (if (null? (cdddr args)) (caddr args)
+ `(append ,@(cddr args))))))))))
+ (begin ; len > 3
+ (when (and (pair? last-arg)
+ (eq? (car last-arg) 'list) ; (apply f y z (list a b)) -> (f y z a b)
+ (not (hash-table-ref syntaces f))) ; also not any-macro I presume
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,@(copy (cdr form) (make-list (- len 2)))
+ ,@(cdr last-arg)))))
+
+ ;; can't cleanly go from (apply write o p) to (write o (car p)) since p can be ()
+
+ (when (and (not happy)
+ (not (memq f '(define define* define-macro define-macro* define-bacro define-bacro* lambda lambda*)))
+ (or (null? last-arg)
+ (quoted-null? last-arg))) ; (apply f ... ()) -> (f ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(copy (cddr form) (make-list (- len 3))))))))))))))))))
+
+ ;; ----------------
+ ((format snd-display)
+ (if (< (length form) 3)
+ (begin
+ (cond ((< (length form) 2)
+ (lint-format "~A has too few arguments: ~A" caller head (truncated-list->string form)))
+ ((and (pair? (cadr form))
+ (eq? (caadr form) 'format))
+ (lint-format "redundant format: ~A" caller (truncated-list->string form)))
+ ((and (code-constant? (cadr form))
+ (not (string? (cadr form))))
+ (lint-format "format with one argument takes a string: ~A" caller (truncated-list->string form)))
+ ((and (not (cadr form))
+ (string? (caddr form)))
+ (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
+ env)
+
+ (let ((control-string (if (string? (cadr form)) (cadr form) (caddr form)))
+ (args (if (string? (cadr form)) (cddr form) (cdddr form))))
+
+ (define count-directives
+ (let ((format-control-char (let ((chars (make-vector 256 #f)))
+ (for-each
+ (lambda (c)
+ (vector-set! chars (char->integer c) #t))
+ '(#\A #\S #\C #\F #\E #\G #\O #\D #\B #\X #\P #\N #\W #\, #\{ #\} #\* #\@
+ #\a #\s #\c #\f #\e #\g #\o #\d #\b #\x #\p #\n #\w
+ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ chars)))
+ (lambda (str caller form)
+ (let ((curlys 0)
+ (dirs 0)
+ (pos (char-position #\~ str)))
+ (when pos
(let ((len (length str))
(tilde-time #t))
(do ((i (+ pos 1) (+ i 1)))
@@ -2632,43 +5634,41 @@
(let ((c (string-ref str i)))
(if tilde-time
(begin
- (if (and (= curlys 0)
- (not (memq c '(#\~ #\T #\t #\& #\% #\^ #\| #\newline #\}))) ; ~* consumes an arg
- (not (call-with-exit
- (lambda (return)
- (do ((k i (+ k 1)))
- ((= k len) #f)
- ;; this can be confused by pad chars in ~T
- (if (and (not (char-numeric? (string-ref str k)))
- (not (char=? (string-ref str k) #\,)))
- (return (char-ci=? (string-ref str k) #\t))))))))
- (begin
- ;; the possibilities are endless, so I'll stick to the simplest
- (if (not (vector-ref format-control-char (char->integer c)))
- (lint-format "unrecognized format directive: ~C in ~S, ~S" name c str form))
- (set! dirs (+ dirs 1))
-
- ;; ~n so try to figure out how many args are needed (this is not complete)
- (when (char-ci=? c #\n)
- (let ((j (+ i 1)))
- (if (>= j len)
- (lint-format "missing format directive: ~S" name str)
- (begin
- ;; if ,n -- add another, if then not T, add another
- (if (char=? (string-ref str j) #\,)
- (if (>= (+ j 1) len)
- (lint-format "missing format directive: ~S" name str)
- (if (char-ci=? (string-ref str (+ j 1)) #\n)
- (begin
- (set! dirs (+ dirs 1))
- (set! j (+ j 2)))
- (if (char-numeric? (string-ref str (+ j 1)))
- (set! j (+ j 2))
- (set! j (+ j 1))))))
- (if (>= j len)
- (lint-format "missing format directive: ~S" name str)
- (if (not (char-ci=? (string-ref str j) #\t))
- (set! dirs (+ dirs 1))))))))))
+ (when (and (= curlys 0)
+ (not (memq c '(#\~ #\T #\t #\& #\% #\^ #\| #\newline #\}))) ; ~* consumes an arg
+ (not (call-with-exit
+ (lambda (return)
+ (do ((k i (+ k 1)))
+ ((= k len) #f)
+ ;; this can be confused by pad chars in ~T
+ (if (not (or (char-numeric? (string-ref str k))
+ (char=? (string-ref str k) #\,)))
+ (return (char-ci=? (string-ref str k) #\t))))))))
+ ;; the possibilities are endless, so I'll stick to the simplest
+ (if (not (vector-ref format-control-char (char->integer c)))
+ (lint-format "unrecognized format directive: ~C in ~S, ~S" caller c str form))
+ (set! dirs (+ dirs 1))
+
+ ;; ~n so try to figure out how many args are needed (this is not complete)
+ (when (char-ci=? c #\n)
+ (let ((j (+ i 1)))
+ (if (>= j len)
+ (lint-format "missing format directive: ~S" caller str)
+ (begin
+ ;; if ,n -- add another, if then not T, add another
+ (if (char=? (string-ref str j) #\,)
+ (cond ((>= (+ j 1) len)
+ (lint-format "missing format directive: ~S" caller str))
+ ((char-ci=? (string-ref str (+ j 1)) #\n)
+ (set! dirs (+ dirs 1))
+ (set! j (+ j 2)))
+ ((char-numeric? (string-ref str (+ j 1)))
+ (set! j (+ j 2)))
+ (else (set! j (+ j 1)))))
+ (if (>= j len)
+ (lint-format "missing format directive: ~S" caller str)
+ (if (not (char-ci=? (string-ref str j) #\t))
+ (set! dirs (+ dirs 1)))))))))
(set! tilde-time #f)
(case c
@@ -2676,7 +5676,13 @@
((#\}) (set! curlys (- curlys 1)))
((#\^ #\|)
(if (zero? curlys)
- (lint-format "~A has ~C outside ~~{~~}?" name str c)))))
+ (lint-format "~A has ~~~C outside ~~{~~}?" caller str c))))
+ (if (and (< (+ i 2) len)
+ (member (substring str i (+ i 3)) '("%~&" "^~^" "|~|" "&~&" "\n~\n") string=?))
+ (lint-format "~A in ~A could be ~A" caller
+ (substring str (- i 1) (+ i 3))
+ str
+ (substring str (- i 1) (+ i 1)))))
(begin
(set! pos (char-position #\~ str i))
(if pos
@@ -2686,269 +5692,1351 @@
(set! i len))))))
(if tilde-time
- (lint-format "~A control string ends in tilde: ~A" name head (truncated-list->string form)))))
-
- (if (not (= curlys 0))
- (lint-format "~A has ~D unmatched ~A~A: ~A"
- name head
- (abs curlys)
- (if (positive? curlys) "{" "}")
- (if (> curlys 1) "s" "")
- (truncated-list->string form)))
- dirs))
-
- (if (not (string? control-string))
- (if (not (proper-list? args))
- (lint-format "~S looks suspicious" name form))
- (let ((ndirs (count-directives control-string name form))
- (nargs (if (or (null? args) (pair? args)) (length args) 0)))
- (if (not (= ndirs nargs))
- (lint-format "~A has ~A arguments: ~A"
- name head
- (if (> ndirs nargs) "too few" "too many")
- (truncated-list->string form))
- (if (and (not (cadr form))
- (zero? ndirs)
- (not (char-position #\~ control-string)))
- (lint-format "~A could be ~S, (format is a no-op here)" name form (caddr form)))))))))
-
- ((sort!)
- (if (= (length form) 3)
- (let ((func (caddr form)))
- (if (memq func '(= eq? eqv? equal? string=? char=? string-ci=? char-ci=?))
- (lint-format "sort! with ~A may hang: ~A" name func (truncated-list->string form))
- (if (symbol? func)
- (let ((sig (procedure-signature (symbol->value func))))
- (if (and sig
- (not (eq? (car sig) 'boolean?)))
- (lint-format "~A is a questionable sort! function" name func))))))))
-
- ((substring)
- (if (every? code-constant? (cdr form))
- (catch #t
- (lambda ()
- (let ((val (eval form)))
- (lint-format "perhaps ~A -> ~S" name form val)))
- (lambda (type info)
- (lint-format "~A -> ~A~%" name form (apply format #f info))))
+ (lint-format "~A control string ends in tilde: ~A" caller head (truncated-list->string form)))))
+
+ (if (not (= curlys 0))
+ (lint-format "~A has ~D unmatched ~A~A: ~A"
+ caller head
+ (abs curlys)
+ (if (positive? curlys) "{" "}")
+ (if (> curlys 1) "s" "")
+ (truncated-list->string form)))
+ dirs))))
+
+ (when (and (eq? head 'format)
+ (string? (cadr form)))
+ (lint-format "please include the port argument to format, perhaps ~A" caller `(format () ,@(cdr form))))
+
+ (if (any? (lambda (arg)
+ (and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg))))
+ (cdr form))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
- (let ((str (cadr form)))
- (if (and (pair? str)
- (eq? (car str) 'substring)
- (pair? (cddr form))
- (null? (cdddr form))
- (null? (cdddr str)))
- (if (and (integer? (caddr form))
- (integer? (caddr str)))
- (lint-format "perhaps ~A" name
- (lists->string form `(substring ,(cadr str) ,(+ (caddr str) (caddr form)))))
- (lint-format "perhaps ~A" name
- (lists->string form `(substring ,(cadr str) (+ ,(caddr str) ,(caddr form)))))))
- ;; end indices are complicated -- since this rarely happens, not worth the trouble
- (if (and (integer? (caddr form))
- (zero? (caddr form))
- (null? (cdddr form)))
- (lint-format "perhaps clearer: ~A" name (lists->string form `(copy ,str)))))))
-
- ((list-tail)
- (if (= (length form) 3)
+ (if (not (string? control-string))
+ (if (not (proper-list? args))
+ (lint-format "~S looks suspicious" caller form))
+ (let ((ndirs (count-directives control-string caller form))
+ (nargs (if (list? args) (length args) 0)))
+ (let ((pos (char-position #\null control-string)))
+ (if (and pos (< pos (length control-string)))
+ (lint-format "#\\null in a format control string will confuse both lint and format: ~S in ~A" caller control-string form)))
+ (if (not (or (= ndirs nargs)
+ (tree-memq 'values form)))
+ (lint-format "~A has ~A arguments: ~A"
+ caller head
+ (if (> ndirs nargs) "too few" "too many")
+ (truncated-list->string form))
+ (if (and (not (cadr form))
+ (zero? ndirs)
+ (not (char-position #\~ control-string)))
+ (lint-format "~A could be ~S, (format is a no-op here)" caller (truncated-list->string form) (caddr form))))))
+
+ (when (pair? args)
+ (for-each
+ (lambda (a)
+ (if (pair? a)
+ (case (car a)
+ ((number->string)
+ (if (null? (cddr a))
+ (lint-format "format arg ~A could be ~A" caller a (cadr a))
+ (if (and (pair? (cddr a))
+ (integer? (caddr a))
+ (memv (caddr a) '(2 8 10 16)))
+ (if (= (caddr a) 10)
+ (lint-format "format arg ~A could be ~A" caller a (cadr a))
+ (lint-format "format arg ~A could use the format directive ~~~A and change the argument to ~A" caller a
+ (case (caddr a) ((2) "B") ((8) "O") (else "X"))
+ (cadr a))))))
+
+ ((symbol->string)
+ (lint-format "format arg ~A could be ~A" caller a (cadr a)))
+
+ ((make-string)
+ (lint-format "format arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller a
+ (cadr a) (if (char? (caddr a)) (format #f "~W" (caddr a)) (caddr a))))
+
+ ((string-append)
+ (lint-format "format appends strings, so ~A seems wasteful" caller a)))))
+ args)))))
+
+ ;; ----------------
+ ((error)
+ (if (any? (lambda (arg)
+ (and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg))))
+ (cdr form))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form))))
+
+ ;; ----------------
+ ((sort!)
+ (if (= (length form) 3)
+ (let ((func (caddr form)))
+ (if (memq func '(= eq? eqv? equal? string=? char=? string-ci=? char-ci=?))
+ (lint-format "sort! with ~A may hang: ~A" caller func (truncated-list->string form))
+ (if (symbol? func)
+ (let ((sig (procedure-signature (symbol->value func))))
+ (if (and (pair? sig)
+ (not (eq? (car sig) 'boolean?)))
+ (lint-format "~A is a questionable sort! function" caller func))))))))
+
+ ;; ----------------
+ ((substring)
+ (if (every? code-constant? (cdr form))
+ (catch #t
+ (lambda ()
+ (let ((val (eval form)))
+ (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
+ (lambda (type info)
+ (lint-format "~A -> ~A" caller (truncated-list->string form) (apply format #f info))))
+
+ (let ((str (cadr form)))
+ (if (and (pair? str)
+ (eq? (car str) 'substring)
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (null? (cdddr str)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (integer? (caddr form))
+ (integer? (caddr str)))
+ `(substring ,(cadr str) ,(+ (caddr str) (caddr form)))
+ `(substring ,(cadr str) (+ ,(caddr str) ,(caddr form)))))))
+ ;; end indices are complicated -- since this rarely happens, not worth the trouble
(if (and (integer? (caddr form))
- (zero? (caddr form)))
- (lint-format "perhaps ~A" name (lists->string form (cadr form)))
- (if (and (pair? (cadr form))
- (eq? (caadr form) 'list-tail))
- (if (and (integer? (caddr form))
- (integer? (caddr (cadr form))))
- (lint-format "perhaps ~A" name
- (lists->string form `(list-tail ,(cadadr form) ,(+ (caddr (cadr form)) (caddr form)))))
- (lint-format "perhaps ~A" name
- (lists->string form `(list-tail ,(cadadr form) (+ ,(caddr (cadr form)) ,(caddr form))))))))))
-
- ((eq?)
- (if (< (length form) 3)
- (lint-format "eq? needs 2 arguments: ~A" name (truncated-list->string form))
- (let ((arg1 (cadr form))
- (arg2 (caddr form)))
- (let ((eq1 (eqf arg1))
- (eq2 (eqf arg2)))
- (if (or (eq? (car eq1) 'equal?)
- (eq? (car eq2) 'equal?))
- (lint-format "eq? should be equal? in ~S" name form)
- (if (or (eq? (car eq1) 'eqv?)
- (eq? (car eq2) 'eqv?))
- (lint-format "eq? should be eqv? in ~S" name form))))
-
- (let ((expr 'unset)) ; (eq? e #f) or (eq? #f e) -> (not e)
- (if (not arg1)
- (set! expr (simplify-boolean `(not ,arg2) () () env))
- (if (not arg2)
- (set! expr (simplify-boolean `(not ,arg1) () () env))
- (if (and (or (null? arg1)
- (quoted-null? arg1))
- (not (code-constant? arg2)))
- (set! expr `(null? ,arg2))
- (if (and (or (null? arg2)
- (quoted-null? arg2))
- (not (code-constant? arg1)))
- (set! expr `(null? ,arg1))
- (if (and (eq? arg1 #t)
- (pair? arg2)
- (eq? (return-type (car arg2)) 'boolean?))
- (set! expr arg2)
- (if (and (eq? arg2 #t)
- (pair? arg1)
- (eq? (return-type (car arg1)) 'boolean?))
- (set! expr arg1)))))))
- (if (not (eq? expr 'unset))
- (lint-format "perhaps ~A" name (lists->string form expr)))))))
-
- ((eqv? equal? morally-equal?)
- (if (< (length form) 3)
- (lint-format "~A needs 2 arguments: ~A" name head (truncated-list->string form))
- (let ((arg1 (cadr form))
- (arg2 (caddr form)))
- (let ((eq1 (eqf arg1))
- (eq2 (eqf arg2)))
- (if (or (eq? (car eq1) 'equal?)
- (eq? (car eq2) 'equal?))
- (if (not (memq head '(equal? morally-equal?)))
- (lint-format "~A should be equal? in ~S" name head form))
- (if (or (eq? (car eq1) 'eqv?)
- (eq? (car eq2) 'eqv?))
- (if (and (not (eq? head 'eqv?))
- (or (not (eq? head 'morally-equal?))
- (and (or (not (number? arg1))
- (rational? arg1)) ; here we have float-equal-epsilon
- (or (not (number? arg2))
- (rational? arg2)))))
- (lint-format "~A ~A be eqv? in ~S" name head (if (eq? head 'eq?) "should" "could") form))
- (if (or (eq? (car eq1) 'eq?)
- (eq? (car eq2) 'eq?))
- (if (or (not arg1) (not arg2))
- (lint-format "~A could be not: ~A" name head
- (lists->string form `(not ,(or arg1 arg2))))
- (if (or (null? arg1) (null? arg2)
- (quoted-null? arg1) (quoted-null? arg2))
- (lint-format "~A could be null?: ~A" name head
- (lists->string form
- (if (or (null? arg1) (quoted-null? arg1))
- `(null? ,arg2)
- `(null? ,arg1))))
- (if (not (eq? head 'eq?))
- (lint-format "~A could be eq? in ~S" name head form)))))))))))
-
- ((map for-each)
- (let* ((len (length form))
- (args (- len 2)))
- (if (< len 3)
- (lint-format "~A missing argument~A in: ~A"
- name head
- (if (= len 2) "" "s")
- (truncated-list->string form))
- (let ((func (cadr form))
- (ary #f))
- (if (and (symbol? func)
- (defined? func)
- (procedure? (symbol->value func *e*)))
+ (zero? (caddr form))
+ (null? (cdddr form)))
+ (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,str))))
+ (if (and (pair? (cdddr form))
+ (equal? (caddr form) (cadddr form)))
+ (lint-format "leaving aside errors, ~A is \"\"" caller form)))))
+
+ ;; ----------------
+ ((list-tail)
+ (if (= (length form) 3)
+ (if (eqv? (caddr form) 0)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr form)))
+ (if (and (pair? (cadr form))
+ (eq? (caadr form) 'list-tail))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (integer? (caddr form))
+ (integer? (caddr (cadr form))))
+ `(list-tail ,(cadadr form) ,(+ (caddr (cadr form)) (caddr form)))
+ `(list-tail ,(cadadr form) (+ ,(caddr (cadr form)) ,(caddr form))))))))))
+ ;; ----------------
+ ((eq?)
+ (if (< (length form) 3)
+ (lint-format "eq? needs 2 arguments: ~A" caller (truncated-list->string form))
+ (let* ((arg1 (cadr form))
+ (arg2 (caddr form))
+ (eq1 (eqf arg1 env))
+ (eq2 (eqf arg2 env))
+ (specific-op (and (eq? (cadr eq1) (cadr eq2))
+ (not (memq (cadr eq1) '(eqv? equal?)))
+ (cadr eq1))))
+
+ (eval-constant-expression caller form)
+
+ (if (or (eq? (car eq1) 'equal?)
+ (eq? (car eq2) 'equal?))
+ (lint-format "eq? should be equal?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)
+ (if (or (eq? (car eq1) 'eqv?)
+ (eq? (car eq2) 'eqv?))
+ (lint-format "eq? should be eqv?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)))
+
+ (let ((expr 'unset))
+ (cond ((or (not arg1) ; (eq? #f x) -> (not x)
+ (quoted-not? arg1))
+ (set! expr (simplify-boolean `(not ,arg2) () () env)))
+ ((or (not arg2) ; (eq? x #f) -> (not x)
+ (quoted-not? arg2))
+ (set! expr (simplify-boolean `(not ,arg1) () () env)))
+ ((and (or (null? arg1) ; (eq? () x) -> (null? x)
+ (quoted-null? arg1))
+ (not (code-constant? arg2)))
+ (set! expr (or (equal? arg2 '(list)) ; (eq? () (list)) -> #t
+ `(null? ,arg2))))
+ ((and (or (null? arg2) ; (eq? x ()) -> (null? x)
+ (quoted-null? arg2))
+ (not (code-constant? arg1)))
+ (set! expr (or (equal? arg1 '(list))
+ `(null? ,arg1))))
+ ((and (eq? arg1 #t) ; (eq? #t <boolean-expr>) -> boolean-expr
+ (pair? arg2)
+ (eq? (return-type (car arg2) env) 'boolean?))
+ (set! expr arg2))
+ ((and (eq? arg2 #t) ; ; (eq? <boolean-expr> #t) -> boolean-expr
+ (pair? arg1)
+ (eq? (return-type (car arg1) env) 'boolean?))
+ (set! expr arg1)))
+ (if (not (eq? expr 'unset))
+ (lint-format "perhaps ~A" caller (lists->string form expr)))))))
+
+ ;; ----------------
+ ((eqv? equal? morally-equal?)
+ (if (< (length form) 3)
+ (lint-format "~A needs 2 arguments: ~A" caller head (truncated-list->string form))
+ (let* ((arg1 (cadr form))
+ (arg2 (caddr form))
+ (eq1 (eqf arg1 env))
+ (eq2 (eqf arg2 env))
+ (specific-op (and (eq? (cadr eq1) (cadr eq2))
+ (not (memq (cadr eq1) '(eq? eqv? equal?)))
+ (cadr eq1))))
+
+ (eval-constant-expression caller form)
+
+ (cond ((or (eq? (car eq1) 'equal?)
+ (eq? (car eq2) 'equal?))
+ (if (memq head '(equal? morally-equal?))
+ (if specific-op
+ (lint-format "~A could be ~A in ~S" caller head specific-op form))
+ (lint-format "~A should be equal?~A in ~S" caller head
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form)))
+
+ ((or (eq? (car eq1) 'eqv?)
+ (eq? (car eq2) 'eqv?))
+ (if (memq head '(eqv? morally-equal?))
+ (if specific-op
+ (lint-format "~A could be ~A in ~S" caller head specific-op form))
+ (lint-format "~A ~A be eqv?~A in ~S" caller head
+ (if (eq? head 'eq?) "should" "could")
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form)))
+
+ ((not (or (eq? (car eq1) 'eq?)
+ (eq? (car eq2) 'eq?))))
+
+ ((not (and arg1 arg2))
+ (lint-format "~A could be not: ~A" caller head (lists->string form `(not ,(or arg1 arg2)))))
+
+ ((or (null? arg1)
+ (null? arg2)
+ (quoted-null? arg1) (quoted-null? arg2))
+ (lint-format "~A could be null?: ~A" caller head
+ (lists->string form
+ (if (or (null? arg1) (quoted-null? arg1))
+ `(null? ,arg2)
+ `(null? ,arg1)))))
+ ((not (eq? head 'eq?))
+ (lint-format "~A could be eq?~A in ~S" caller head
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form))))))
+
+ ;; ----------------
+ ((map for-each)
+ (let* ((len (length form))
+ (args (- len 2)))
+ (if (< len 3)
+ (lint-format "~A missing argument~A in: ~A"
+ caller head
+ (if (= len 2) "" "s")
+ (truncated-list->string form))
+ (let ((func (cadr form))
+ (ary #f))
+ (if (and (symbol? func)
+ ;(defined? func)
+ (procedure? (symbol->value func *e*)))
+ (begin
(set! ary (arity (symbol->value func *e*)))
-
- (if (and (pair? func)
- (memq (car func) '(lambda lambda*))
- (pair? (cadr func)))
- (let ((arglen (length (cadr func))))
- (if (eq? (car func) 'lambda)
- (if (negative? arglen)
- (set! ary (cons (abs arglen) 512000))
- (set! ary (cons arglen arglen)))
- (if (or (negative? arglen)
- (memq :rest (cadr func)))
- (set! ary (cons 0 512000))
- (set! ary (cons 0 arglen)))))))
+ (if (and (eq? head 'map)
+ (hash-table-ref no-side-effect-functions func)
+ (= len 3)
+ (pair? (caddr form))
+ (or (eq? (caaddr form) 'quote)
+ (and (eq? (caaddr form) 'list)
+ (every? code-constant? (cdaddr form)))))
+ (catch #t
+ (lambda ()
+ (let ((val (eval form)))
+ (lint-format "perhaps ~A" caller (lists->string form (list 'quote val)))))
+ (lambda args #f))))
+
+ (if (and (pair? func)
+ (memq (car func) '(lambda lambda*))
+ (pair? (cadr func)))
+ (let ((arglen (length (cadr func))))
+ (set! ary (if (eq? (car func) 'lambda)
+ (if (negative? arglen)
+ (cons (abs arglen) 512000)
+ (cons arglen arglen))
+ (cons 0 (if (or (negative? arglen)
+ (memq :rest (cadr func)))
+ 512000 arglen)))))))
+ (if (pair? ary)
+ (if (< args (car ary))
+ (lint-format "~A has too few arguments in: ~A"
+ caller head
+ (truncated-list->string form))
+ (if (> args (cdr ary))
+ (lint-format "~A has too many arguments in: ~A"
+ caller head
+ (truncated-list->string form)))))
+ (for-each
+ (lambda (obj)
+ (if (and (pair? obj)
+ (memq (car obj) '(vector->list string->list let->list)))
+ (lint-format* caller
+ (truncated-list->string obj)
+ " could be simplified to: "
+ (truncated-list->string (cadr obj))
+ (string-append " ; (" (symbol->string head) " accepts non-list sequences)"))))
+ (cddr form))
+
+ (when (eq? head 'map)
+ (when (and (memq func '(char-downcase char-upcase))
+ (pair? (caddr form))
+ (eq? (caaddr form) 'string->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(string->list (,(if (eq? func 'char-upcase) 'string-upcase 'string-downcase)
+ ,(cadr (caddr form)))))))
+ (when (identity? func) ; to check f here as var is more work
+ (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
+
+ (let ((arg1 (caddr form)))
+ (when (and (pair? arg1)
+ (memq (car arg1) '(cdr cddr cdddr cddddr list-tail))
+ (pair? (cdr arg1))
+ (pair? (cadr arg1))
+ (memq (caadr arg1) '(string->list vector->list)))
+ (let ((string-case (eq? (caadr arg1) 'string->list))
+ (len-diff (if (eq? (car arg1) 'list-tail)
+ (caddr arg1)
+ (cdr-count (car arg1)))))
+ (lint-format "~A accepts ~A arguments, so perhaps ~A" caller head
+ (if string-case 'string 'vector)
+ (lists->string arg1 (if string-case
+ `(substring ,(cadadr arg1) ,len-diff)
+ `(make-shared-vector ,(cadadr arg1) (- (length ,(cadadr arg1)) ,len-diff) ,len-diff)))))))
+ (when (and (eq? head 'for-each)
+ (pair? (cadr form))
+ (eq? (caadr form) 'lambda)
+ (pair? (cdadr form))
+ (not (any? (lambda (x) (side-effect? x env)) (cddadr form))))
+ (lint-format "pointless for-each: ~A" caller (truncated-list->string form)))
+
+ (when (= args 1)
+ (let ((seq (caddr form)))
+
+ (when (pair? seq)
+ (case (car seq)
+ ((cons)
+ (if (and (pair? (cdr seq))
+ (pair? (cddr seq)))
+ (if (or (null? (caddr seq))
+ (quoted-null? (caddr seq)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? head 'map)
+ `(list (,(cadr form) ,(cadr seq)))
+ `(,(cadr form) ,(cadr seq)))))
+ (if (code-constant? (caddr seq))
+ (lint-format "~A will ignore ~S in ~A" caller head (caddr seq) seq)))))
+ ((list)
+ (if (and (pair? (cdr seq))
+ (null? (cddr seq)))
+ (let* ((list-arg (cadr seq))
+ (sig (and (pair? list-arg)
+ (arg-signature seq env))))
+ (if (not (or (and (pair? sig)
+ (pair? (car sig))
+ (memq 'values (car sig)))
+ (tree-memq 'values list-arg)))
+ (lint-format "~Aperhaps ~A" caller
+ (if (or sig
+ (not (pair? list-arg)))
+ ""
+ (format #f "assuming ~A does not return multiple values, " list-arg))
+ (lists->string form
+ (if (eq? head 'map)
+ `(list (,(cadr form) ,list-arg))
+ `(,(cadr form) ,list-arg))))))))
+ ((map)
+ (when (= (length seq) 3)
+ ;; a toss-up -- probably faster to combine funcs here, and easier to read?
+ ;; but only if first arg is only used once in first func, and everything is simple (one-line or symbol)
+ (let* ((seq-func (cadr seq))
+ (arg-name (find-unique-name func seq-func)))
+
+ (if (symbol? func)
+ (if (symbol? seq-func)
+ ;; (map f (map g h)) -> (map (lambda (x) (f (g x))) h) -- dubious...
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ (,func (,seq-func ,arg-name)))
+ ,(caddr seq))))
+ (if (simple-lambda? seq-func)
+ ;; (map f (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ (,func ,(tree-subst arg-name (caadr seq-func) (caddr seq-func))))
+ ,(caddr seq))))))
+ (if (less-simple-lambda? func)
+ (if (symbol? seq-func)
+ ;; (map (lambda (x) (f x)) (map g h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ ,@(tree-subst (list seq-func arg-name) (caadr func) (cddr func)))
+ ,(caddr seq))))
+ (if (simple-lambda? seq-func)
+ ;; (map (lambda (x) (f x)) (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ ,@(tree-subst (tree-subst arg-name (caadr seq-func) (caddr seq-func))
+ (caadr func) (cddr func)))
+ ,(caddr seq)))))))))))))
+ ;; repetitive code...
+ (when (eq? head 'for-each) ; args = 1 above
+ (let ((func (cadr form)))
+ (if (memq func '(display write newline write-char write-string))
+ (lint-format "perhaps ~A" caller
+ (if (and (pair? seq)
+ (memq (car seq) '(list quote)))
+ (let ((op (if (eq? func 'write) "~S" "~A"))
+ (len (- (length seq) 1)))
+ (lists->string form `(format () ,(do ((i 0 (+ i 1))
+ (str ""))
+ ((= i len) str)
+ (set! str (string-append str op)))
+ ,@(cdr seq))))
+ (let ((op (if (eq? func 'write) "~{~S~}" "~{~A~}")))
+ (lists->string form `(format () ,op ,seq)))))
+ (when (and (pair? func)
+ (eq? (car func) 'lambda))
+ (let* ((body (cddr func))
+ (op (write-port (car body)))
+ (larg (and (pair? (cadr func))
+ (caadr func))))
+ (when (and (symbol? larg)
+ (null? (cdadr func)) ; just one arg (one sequence to for-each) for now
+ (every? (lambda (x)
+ (and (pair? x)
+ (memq (car x) '(display write newline write-char write-string))
+ (or (eq? (car x) 'newline)
+ (eq? (cadr x) larg)
+ (string? (cadr x))
+ (eqv? (cadr x) #\space)
+ (and (pair? (cadr x))
+ (pair? (cdadr x))
+ (eq? (caadr x) 'number->string)
+ (eq? (cadadr x) larg)))
+ (eq? (write-port x) op)))
+ body))
+ ;; (for-each (lambda (x) (display x) (write-char #\space)) msg)
+ ;; (for-each (lambda (elt) (display elt)) lst)
+ (let ((ctrl-string "")
+ (arg-ctr 0))
+
+ (define* (gather-format str (arg :unset))
+ (set! ctrl-string (string-append ctrl-string str)))
+
+ (for-each
+ (lambda (d)
+ (if (or (memq larg d)
+ (and (pair? (cdr d))
+ (pair? (cadr d))
+ (memq larg (cadr d))))
+ (set! arg-ctr (+ arg-ctr 1)))
+ (gather-format (display->format d)))
+ body)
+
+ (when (= arg-ctr 1)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(format ,op ,(string-append "~{" ctrl-string "~}") ,seq))))))))
+ )))))))))
+
+ ;; ----------------
+ ((magnitude)
+ (if (and (= (length form) 2)
+ (memq (->lint-type (cadr form)) '(integer? rational? real?)))
+ (lint-format "perhaps use abs here: ~A" caller form)))
+
+ ;; ----------------
+ ((open-input-file open-output-file)
+ (if (and (pair? (cdr form))
+ (pair? (cddr form))
+ (string? (caddr form))
+ (not (memv (string-ref (caddr form) 0) '(#\r #\w #\a)))) ; b + then e m c x if gcc
+ (lint-format "unexpected mode: ~A" caller form)))
+
+ ;; ----------------
+ ((values)
+ (if (member 'values (cdr form) (lambda (a b)
+ (and (pair? b)
+ (eq? (car b) 'values))))
+ (lint-format "perhaps ~A" caller (lists->string form `(values ,@(splice-if (lambda (x) (eq? x 'values)) (cdr form)))))
+ (if (= (length form) 2)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr form))))))
+
+ ;; ----------------
+ ((call-with-values) ; (call/values p c) -> (c (p))
+ (when (= (length form) 3)
+ (let ((producer (cadr form))
+ (consumer (caddr form)))
+ (let* ((produced-values (mv-range producer env))
+ (consumed-values (and produced-values
+ (or (and (symbol? consumer)
+ (arg-arity consumer env))
+ (and (pair? consumer)
+ (eq? (car consumer) 'lambda)
+ (pair? (cadr consumer))
+ (let ((len (length (cadr consumer))))
+ (if (negative? len)
+ (cons (abs len) (cdr (arity +))) ; 536870912 = MAX_ARITY in s7.c
+ (cons len len))))))))
+ (if (and consumed-values
+ (or (> (car consumed-values) (car produced-values))
+ (< (cdr consumed-values) (cadr produced-values))))
+ (let ((clen ((if (> (car consumed-values) (car produced-values)) car cdr) consumed-values)))
+ (lint-format "call-with-values consumer ~A wants ~D value~P, but producer ~A returns ~A"
+ caller
+ (truncated-list->string consumer)
+ clen clen
+ (truncated-list->string producer)
+ ((if (> (car consumed-values) (car produced-values)) car cadr) produced-values)))))
+
+ (cond ((not (pair? producer))
+ (if (and (symbol? producer)
+ (not (memq (return-type producer ()) '(#t #f values))))
+ (lint-format "~A does not return multiple values" caller producer)
+ (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer))))))
- (if (pair? ary)
- (if (< args (car ary))
- (lint-format "~A has too few arguments in: ~A"
- name head
- (truncated-list->string form))
- (if (> args (cdr ary))
- (lint-format "~A has too many arguments in: ~A"
- name head
- (truncated-list->string form)))))
+ ((not (eq? (car producer) 'lambda))
+ (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))
- (for-each
- (lambda (obj)
- (if (and (pair? obj)
- (memq (car obj) '(vector->list string->list let->list)))
- (lint-format "~A could be simplified to: ~A ; (~A accepts non-list sequences)"
- name
- (truncated-list->string obj)
- (truncated-list->string (cadr obj))
- head)))
- (cddr form))))))
-
- ((magnitude)
- (if (and (= (length form) 2)
- (memq (->type (cadr form)) '(integer? rational? real?)))
- (lint-format "perhaps use abs here: ~A" name form)))
-
- ((null eq eqv equal) ; (null (cdr...))
- (if (not (var-member head env))
- (lint-format "misspelled '~A? in ~A?" name head form)))
+ ((pair? (cadr producer))
+ (lint-format "~A requires too many arguments" caller (truncated-list->string producer)))
+
+ ((symbol? (cadr producer))
+ (lint-format "~A's parameter ~A will always be ()" caller (truncated-list->string producer) (cadr producer)))
+
+ ((and (pair? (cddr producer))
+ (null? (cdddr producer)))
+ (let ((body (caddr producer)))
+ (if (or (code-constant? body)
+ (and (pair? body)
+ (symbol? (car body))
+ (not (memq (return-type (car body) ()) '(#t #f values)))))
+ (lint-format "~A does not return multiple values" caller body)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? body)
+ (eq? (car body) 'values))
+ `(,consumer ,@(cdr body))
+ `(,consumer ,body)))))))
+
+ (else (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))))))
+
+ ;; ----------------
+ ((multiple-value-bind)
+ (when (= (length form) 4)
+ (let ((vars (cadr form))
+ (producer (caddr form))
+ (body (cdddr form)))
+
+ (if (null? vars)
+ (lint-format "this multiple-value-bind is pointless; perhaps ~A" caller
+ (lists->string form
+ (if (side-effect? producer env)
+ `(begin ,producer , at body)
+ (if (null? (cdr body))
+ (car body)
+ `(begin , at body)))))
+
+ (if (not (symbol? vars)) ; else any number of values is ok
+ (let ((vals (mv-range producer env))
+ (args (length vars)))
+ (if (and vals
+ (or (< args (car vals))
+ (> args (cadr vals))))
+ (lint-format "multiple-value-bind wants ~D values, but ~A returns ~A"
+ caller args
+ (truncated-list->string producer)
+ (if (< args (car vals)) (car vals) (cadr vals))))
+
+ (if (and (pair? producer)
+ (symbol? (car producer))
+ (not (memq (return-type (car producer) ()) '(#t #f values))))
+ (lint-format "~A does not return multiple values" caller (car producer))
+ (if (and (null? (cdr body))
+ (pair? (car body))
+ (equal? vars (cdar body))
+ (defined? (caar body))
+ (equal? (arity (symbol->value (caar body))) (cons args args)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(caar body) ,producer)))))))))))
+
+ ;; ----------------
+ ((let-values)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (if (null? (cdadr form)) ; just one set of vars
+ (let ((call (caadr form)))
+ (if (and (pair? call)
+ (pair? (cdr call)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `((lambda ,(car call)
+ ,@(cddr form))
+ ,(cadr call))))))
+ (if (every? pair? (cadr form))
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form
+ `(with-let
+ (apply sublet (curlet)
+ (list ,@(map (lambda (v)
+ `((lambda ,(car v)
+ (values ,@(map (lambda (name)
+ (values (symbol->keyword name) name))
+ (args->proper-list (car v)))))
+ ,(cadr v)))
+ (cadr form))))
+ ,@(cddr form))))))))
+
+ ;; ----------------
+ ((let*-values)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let loop ((var-data (cadr form)))
+ (let ((v (car var-data)))
+ (if (and (pair? (car v)) ; just one var
+ (null? (cdar v)))
+ (if (null? (cdr var-data))
+ `(let ((,(caar v) ,(cadr v))) ,@(cddr form))
+ `(let ((,(caar v) ,(cadr v))) ,(loop (cdr var-data))))
+ (if (null? (cdr var-data))
+ `((lambda ,(car v) ,@(cddr form)) ,(cadr v))
+ `((lambda ,(car v) ,(loop (cdr var-data))) ,(cadr v))))))))))
+ ((define-values)
+ (when (pair? (cdr form))
+ (if (null? (cadr form))
+ (lint-format "~A is pointless" caller (truncated-list->string form))
+ (when (pair? (cddr form))
+ (lint-format "perhaps ~A" caller
+ (cond ((symbol? (cadr form))
+ (lists->string form `(define ,(cadr form) (list ,(caddr form)))))
+
+ ((and (pair? (cadr form))
+ (null? (cdadr form)))
+ (lists->string form `(define ,(caadr form) ,(caddr form))))
+
+ (else
+ (let-temporarily ((target-line-length 120))
+ (truncated-lists->string form
+ `(varlet (curlet)
+ ((lambda ,(cadr form)
+ (curlet))
+ ,(caddr form))))))))))))
+ ;; ----------------
+ ((eval)
+ (when (= (length form) 2)
+ (let ((arg (cadr form)))
+ (cond ((not (pair? arg))
+ (if (not (symbol? arg))
+ (lint-format "this eval is pointless; perhaps ~A" caller (lists->string form arg))))
+
+ ((eq? (car arg) 'quote)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
+
+ ((eq? (car arg) 'string->symbol)
+ (lint-format "perhaps ~A" caller (lists->string form (string->symbol (cadr arg)))))
+
+ ((and (eq? (car arg) 'with-input-from-string)
+ (pair? (cdr arg))
+ (pair? (cddr arg))
+ (eq? (caddr arg) 'read))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(eval-string ,(cadr arg)))))
+
+ ((and (eq? (car arg) 'read)
+ (= (length arg) 2)
+ (pair? (cadr arg))
+ (eq? (caadr arg) 'open-input-string))
+ (lint-format "perhaps ~A" caller (lists->string form `(eval-string ,(cadadr arg)))))))))
+
+ ;; ----------------
+ ((fill! string-fill! list-fill! vector-fill!)
+ (if (= (length form) 5)
+ (check-start-and-end caller head (cdddr form) form env)))
+
+ ;; ----------------
+ ((write-string)
+ (if (= (length form) 4)
+ (check-start-and-end caller head (cddr form) form env)))
+
+ ;; ----------------
+ ((string-length)
+ (if (and (= (length form) 2)
+ (string? (cadr form)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (string-length (cadr form)))))
+
+ ;; ----------------
+ ((vector-length)
+ (if (and (= (length form) 2)
+ (vector? (cadr form)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (vector-length (cadr form)))))
+
+ ;; ----------------
+ ((dynamic-wind)
+ (when (= (length form) 4)
+ (let ((init (cadr form))
+ (body (caddr form))
+ (end (cadddr form))
+ (empty 0))
+ ;; (equal? init end) as a mistake doesn't seem to happen
+
+ (when (and (pair? init)
+ (eq? (car init) 'lambda))
+ (if (not (null? (cadr init)))
+ (lint-format "dynamic-wind init function should be a thunk: ~A" caller init))
+ (if (pair? (cddr init))
+ (let ((last-expr (list-ref init (- (length init) 1))))
+ (if (not (pair? last-expr))
+ (if (null? (cdddr init))
+ (set! empty 1))
+ (unless (side-effect? last-expr env)
+ (if (null? (cdddr init))
+ (set! empty 1))
+ (lint-format "this could be omitted: ~A in ~A" caller last-expr init))))))
+
+ (if (and (pair? body)
+ (eq? (car body) 'lambda))
+ (if (not (null? (cadr body)))
+ (lint-format "dynamic-wind body function should be a thunk: ~A" caller body))
+ (set! empty 3)) ; don't try to access body below
+
+ (when (and (pair? end)
+ (eq? (car end) 'lambda))
+ (if (not (null? (cadr end)))
+ (lint-format "dynamic-wind end function should be a thunk: ~A" caller end))
+ (if (pair? (cddr end))
+ (let ((last-expr (list-ref end (- (length end) 1))))
+ (if (not (pair? last-expr))
+ (if (null? (cdddr end))
+ (set! empty (+ empty 1)))
+ (unless (side-effect? last-expr env) ; or if no side-effects in any (also in init)
+ (if (null? (cdddr end))
+ (set! empty (+ empty 1)))
+ (lint-format "this could be omitted: ~A in ~A" caller last-expr end)))
+ (if (= empty 2)
+ (lint-format "this dynamic-wind is pointless, ~A" caller
+ (lists->string form (if (null? (cdddr body)) (caddr body) `(begin ,@(cddr body))))))))))))
+
+ ;; ----------------
+ ((*s7*)
+ (if (= (length form) 2)
+ (let ((arg (cadr form)))
+ (if (and (pair? arg)
+ (eq? (car arg) 'quote)
+ (symbol? (cadr arg))
+ (not (memq (cadr arg)
+ '(print-length safety cpu-time heap-size free-heap-size gc-freed max-string-length max-list-length
+ max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length
+ gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults
+ max-stack-size stack catches exits float-format-precision bignum-precision default-rationalize-error
+ default-random-state morally-equal-float-epsilon hash-table-float-epsilon undefined-identifier-warnings
+ gc-stats symbol-table-locked? c-objects history-size profile-info))))
+ (lint-format "unknown *s7* field: ~A" caller arg)))))
+
+ ((throw)
+ (if (pair? (cdr form))
+ (let* ((tag (cadr form))
+ (eq (eqf tag env)))
+ (if (not (member eq '((eq? eq?) (#t #t))))
+ (lint-format "~A tag ~S is unreliable (catch uses eq? to match tags)" caller head tag)))))
+
+ ((make-hash-table)
+ (if (= (length form) 3)
+ (let ((func (caddr form)))
+ (if (and (symbol? func)
+ (not (memq func '(eq? eqv? equal? morally-equal? char=? char-ci=? string=? string-ci=? =))))
+ (lint-format "make-hash-table function, ~A, is not a hash function" caller func)))))
+
+ ((null eq eqv equal) ; (null (cdr...))
+ (if (not (var-member head env))
+ (lint-format "misspelled '~A? in ~A?" caller head form)))
+
+ ((interaction-environment the-environment) (lint-format "~A is probably curlet in s7" caller head))
+ ((system-global-environment user-initial-environment) (lint-format "~A is probably rootlet in s7" caller head))
+; ((environment?) (lint-format "environment? is let? in s7" caller))
+; ((environment-set!) (lint-format "environment-set! is let-set! in s7" caller))
+; ((environment-ref) (lint-format "environment-ref is let-ref in s7" caller))
+ ((unquote-splicing) (lint-format "unquote-splicing is probably (apply values ...) in s7" caller))
+
+ ((bitwise-and bitwise-ior bitwise-not bitwise-xor)
+ (if (not (var-member head env))
+ (lint-format "~A is ~A in s7" caller head
+ (cdr (assq head '((bitwise-and . logand) (bitwise-ior . logior) (bitwise-xor . logxor) (bitwise-not . lognot)))))))
+
+ ((push!) ; not predefined
+ (if (= (length form) 3)
+ (set-set (caddr form) caller form env)))
+
+ ((pop!) ; also not predefined
+ (if (= (length form) 2)
+ (set-set (cadr form) caller form env)))
+
+ ((receive) ; this definition comes from Guile
+ (if (and (> (length form) 3)
+ (not (var-member 'receive env)))
+ (check-special-cases caller 'call-with-values
+ `(call-with-values
+ (lambda () ,(caddr form))
+ (lambda ,(cadr form) ,@(cdddr form)))
+ env)))
+ ((and-let*)
+ (when (and (> (length form) 2)
+ (not (var-member head env)))
+ (let loop ((bindings (cadr form)))
+ (cond ((pair? bindings)
+ (if (binding-ok? caller head (car bindings) env #f)
+ (loop (cdr bindings))))
+ ((not (null? bindings))
+ (lint-format "~A variable list is not a proper list? ~S" caller head bindings))
+ ((and (pair? (cadr form)) ; (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs))
+ (null? (cdadr form))
+ (pair? (cddr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (null? (cdddr form))
+ (pair? (caddr form))
+ (pair? (cdaddr form))
+ (null? (cddr (caddr form)))
+ (eq? (caaadr form) (cadr (caddr form))))
+ `(cond (,(cadar (cadr form)) => ,(caaddr form)))
+ `(cond (,(cadar (cadr form)) => (lambda (,(caaadr form)) ,@(cddr form))))))))))))
+ )) ; end check-special-cases
+
+ (define (prettify-checker-unq op)
+ (if (pair? op)
+ (string-append (prettify-checker-unq (car op)) " or " (prettify-checker-unq (cadr op)))
+ (case op
+ ((rational?) "rational")
+ ((real?) "real")
+ ((complex?) "complex")
+ ((null?) "null")
+ ((length) "a sequence")
+ ((unspecified?) "untyped")
+ (else
+ (let ((op-name (symbol->string op)))
+ (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ")
+ (substring op-name 0 (- (length op-name) 1))))))))
+
+ (define (prettify-checker op)
+ (if (pair? op)
+ (string-append (prettify-checker-unq (car op)) " or " (prettify-checker (cadr op)))
+ (let ((op-name (symbol->string op)))
+ (case op
+ ((rational? real? complex? null?) op-name)
+ ((unspecified?) "untyped")
+ (else (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ") op-name))))))
+
+ (define (unused-parameter? x) #t)
+ (define (unused-set-parameter? x) #t)
- ((open-input-file open-output-file)
- (if (and (pair? (cdr form))
- (pair? (cddr form))
- (string? (caddr form))
- (not (memv (string-ref (caddr form) 0) '(#\r #\w #\a)))) ; b + then e m c x if gcc
- (lint-format "unexpected mode: ~A" name form)))
-
- ((catch)
- ;; catch tag is tricky -- it is evaluated, then eq? matches at error time, so we need
- ;; to catch constants that can't be eq?
- (if (= (length form) 4)
- (let ((tag (cadr form)))
- (if (or (and (not (pair? tag))
- (or (number? tag) (char? tag) (length tag)))
- (and (pair? tag)
- (eq? (car tag) 'quote)
- (or (not (pair? (cdr tag)))
- (length (cadr tag)))))
- (lint-format "catch tag ~S is unreliable (catch uses eq? to match tags)" name (cadr form))))))
-
- ((load) ; pick up the top level declarations
- (if (>= (length form) 2)
- (scan form)))
-
- ((*s7*)
- (if (= (length form) 2)
- (let ((arg (cadr form)))
- (if (and (pair? arg)
- (eq? (car arg) 'quote)
- (symbol? (cadr arg))
- (not (memq (cadr arg)
- '(print-length safety cpu-time heap-size free-heap-size gc-freed max-string-length max-list-length
- max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length
- gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults
- max-stack-size catches exits float-format-precision bignum-precision default-rationalize-error
- default-random-state morally-equal-float-epsilon hash-table-float-epsilon undefined-identifier-warnings
- gc-stats symbol-table-locked?))))
- (lint-format "unknown *s7* field: ~A" name (cadr form))))))
-
- )) ; end check-special-cases
+
+ (define (check-args caller head form checkers env max-arity)
+ ;; check for obvious argument type problems
+ ;; caller = overall caller, head = current caller, checkers = proc or list of procs for checking args
+ (define (every-compatible? type1 type2)
+ (if (symbol? type1)
+ (if (symbol? type2)
+ (compatible? type1 type2)
+ (and (pair? type2) ; here everything has to match
+ (compatible? type1 (car type2))
+ (every-compatible? type1 (cdr type2))))
+ (and (pair? type1) ; here any match is good
+ (or (compatible? (car type1) type2)
+ (any-compatible? (cdr type1) type2)))))
+
+ (define (check-checker checker at-end)
+ (if (eq? checker 'integer:real?)
+ (if at-end 'real? 'integer?)
+ (if (eq? checker 'integer:any?)
+ (or at-end 'integer?)
+ checker)))
+
+ (define (any-checker? types arg)
+ (if (and (symbol? types)
+ (not (eq? types 'values)))
+ ((symbol->value types *e*) arg)
+ (and (pair? types)
+ (or (any-checker? (car types) arg)
+ (any-checker? (cdr types) arg)))))
+
+ (define (report-arg-trouble caller form head arg-number checker arg uop)
+ (define (prettify-arg-number argn)
+ (if (or (not (= argn 1))
+ (pair? (cddr form)))
+ (format #f "~D " argn)
+ ""))
+ (let ((op (if (and (eq? checker 'real?)
+ (eq? uop 'number?))
+ 'complex?
+ uop)))
+ (if (and (or arg (not (eq? checker 'output-port?)))
+ (not (and (eq? checker 'string?)
+ (pair? arg)
+ (eq? (car arg) 'format))) ; don't try to untangle the format non-string case
+ (not (and (pair? arg)
+ (eq? (car arg) 'length)))) ; same for length
+ (if (and (pair? op)
+ (member checker op any-compatible?))
+ (if (not (var-member :catch env))
+ (lint-format* caller
+ (string-append "in " (truncated-list->string form) ", ")
+ (string-append (symbol->string head) "'s argument " (prettify-arg-number arg-number))
+ (string-append "should be " (prettify-checker-unq checker) ", ")
+ (string-append "but " (truncated-list->string arg) " might also be "
+ (object->string (car (remove-if (lambda (o) (any-compatible? checker o)) op))))))
+ (lint-format* caller
+ (string-append "in " (truncated-list->string form) ", ")
+ (string-append (symbol->string head) "'s argument " (prettify-arg-number arg-number))
+ (string-append "should be " (prettify-checker-unq checker) ", ")
+ (string-append "but " (truncated-list->string arg) " is " (prettify-checker op)))))))
+
+ (when *report-func-as-arg-arity-mismatch*
+ (let ((v (var-member head env)))
+ (when (and (var? v)
+ (memq (var-ftype v) '(define define* lambda lambda*))
+ (zero? (var-set v)) ; perhaps this needs to wait for report-usage?
+ (pair? (var-arglist v)))
+ (let ((source (var-initial-value v)))
+ (when (and (pair? source)
+ (pair? (cdr source))
+ (pair? (cddr source)))
+ (let ((vhead (cddr source))
+ (head-arglist (var-arglist v))
+ (arg-number 1))
+
+ (when (pair? vhead)
+ (for-each
+ (lambda (arg)
+ ;; only check func if head is var-member and has procedure-source (var-[initial-]value?)
+ ;; and arg has known arity, and check only if arg(par) is car, not (for example) cadr of apply
+
+ (let ((ari (if (symbol? arg)
+ (arg-arity arg env)
+ (and (pair? arg)
+ (eq? (car arg) 'lambda)
+ (let ((len (length (cadr arg))))
+ (and (integer? len)
+ (cons (abs len)
+ (if (negative? len) 500000 len)))))))
+ (par (and (> (length head-arglist) (- arg-number 1))
+ (list-ref head-arglist (- arg-number 1)))))
+ (when (and (symbol? par)
+ (pair? ari)
+ (or (> (car ari) 0)
+ (< (cdr ari) 20)))
+
+ ;; fwalk below needs to be smart about tree walking so that
+ ;; it does not confuse (c) in (lambda (c)...) with a call on the function c.
+ ;; check only if current parameter name is not shadowed
+
+ (let fwalk ((sym par) (tree vhead))
+ (when (pair? tree)
+ (if (eq? (car tree) sym)
+ (let ((args (- (length tree) 1)))
+ (if (> (car ari) args)
+ (lint-format "~A's parameter ~A is passed ~A and called ~A, but ~A needs ~A argument~P" caller
+ head par
+ (truncated-list->string arg)
+ (truncated-list->string tree)
+ (truncated-list->string arg)
+ (car ari) (car ari))
+ (if (> args (cdr ari))
+ (lint-format "~A's parameter ~A is passed ~A and called ~A, but ~A takes only ~A argument~P" caller
+ head par
+ (truncated-list->string arg)
+ (truncated-list->string tree)
+ (truncated-list->string arg)
+ (cdr ari) (cdr ari)))))
+ (case (car tree)
+ ((let let*)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (let ((vs (if (symbol? (cadr tree)) (caddr tree) (cadr tree))))
+ (if (not (any? (lambda (a) (or (not (pair? a)) (eq? sym (car a)))) vs))
+ (fwalk sym (if (symbol? (cadr tree)) (cdddr tree) (cddr tree)))))))
+
+ ((do letrec letrec*)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree))
+ (not (any? (lambda (a) (or (not (pair? a)) (eq? sym (car a)))) (cadr tree))))
+ (fwalk sym (cddr tree))))
+
+ ((lambda lambda*)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree))
+ (not (any? (lambda (a) (eq? sym a)) (args->proper-list (cadr tree)))))
+ (fwalk sym (cddr tree))))
+
+ ((define define-constant)
+ (if (and (not (eq? sym (cadr tree)))
+ (pair? (cadr tree))
+ (not (any? (lambda (a) (eq? sym a)) (args->proper-list (cdadr tree)))))
+ (fwalk sym (cddr tree))))
+
+ ((define* define-macro define-macro* define-expansion define-bacro define-bacro*)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree))
+ (not (any? (lambda (a) (eq? sym a)) (args->proper-list (cdadr tree)))))
+ (fwalk sym (cddr tree))))
+
+ ((quote) #f)
+
+ ((case)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree)))
+ (for-each (lambda (c) (fwalk sym (cdr c))) (cddr tree))))
+
+ (else
+ (if (pair? (car tree))
+ (fwalk sym (car tree)))
+ (if (pair? (cdr tree))
+ (for-each (lambda (p) (fwalk sym p)) (cdr tree))))))))))
+
+ (set! arg-number (+ arg-number 1)))
+ (cdr form)))))))))
- (define (check-call name head form env)
- (let ((fdata (or (var-member head env) (hash-table-ref globals head))))
- ;(format *stderr* "~A call: ~A~%" form fdata)
- (if (var? fdata)
- ;; a local var
- (if (let? (var-new fdata))
- (let ((type ((var-new fdata) 'type))
- (args ((var-new fdata) 'arglist))
- (ary (and (not (eq? ((var-new fdata) 'decl) 'error))
- (arity ((var-new fdata) 'decl)))))
- ;(format *stderr* "~A ~S~%" ary (object->string ((var-new fdata) 'decl) :readable))
- (if (pair? ary)
+ (when (pair? checkers)
+ (let ((arg-number 1)
+ (flen (- (length form) 1)))
+ (call-with-exit
+ (lambda (done)
+ (for-each
+ (lambda (arg)
+ (let ((checker (check-checker (if (pair? checkers) (car checkers) checkers) (= arg-number flen))))
+ ;; check-checker only fixes up :at-end cases
+ (define (check-arg expr)
+ (unless (symbol? expr)
+ (let ((op (->lint-type expr)))
+ (if (not (or (memq op '(#f #t values))
+ (every-compatible? checker op)))
+ (report-arg-trouble caller form head arg-number checker expr op)))))
+
+ ;; special case checker?
+ (if (and (symbol? checker)
+ (not (memq checker '(unused-parameter? unused-set-parameter?)))
+ (not (hash-table-ref built-in-functions checker)))
+ (let ((chk (symbol->value checker)))
+ (if (and (procedure? chk)
+ (equal? (arity chk) '(2 . 2)))
+ (catch #t
+ (lambda ()
+ (let ((res (chk form arg-number)))
+ (set! checker #t)
+ (if (symbol? res)
+ (set! checker res)
+ (if (string? res)
+ (lint-format "~A's argument, ~A, should be ~A" caller head arg res)))))
+ (lambda (type info)
+ (set! checker #t))))))
+
+ (if (and (pair? arg)
+ (pair? (car arg)))
+ (let ((rtn (return-type (caar arg) env)))
+ (if (memq rtn '(boolean? real? integer? rational? number? complex? float? pair? keyword? symbol? null? char?))
+ (lint-format* caller
+ (string-append (symbol->string head) "'s argument ")
+ (string-append (truncated-list->string arg) " looks odd: ")
+ (string-append (object->string (caar arg)) " returns " (symbol->string rtn))
+ " which is not applicable"))))
+
+ (when (or (pair? checker)
+ (symbol? checker)) ; otherwise ignore type check on this argument (#t -> anything goes)
+ (if arg
+ (if (eq? checker 'unused-parameter?)
+ (lint-format* caller
+ (string-append (symbol->string head) "'s parameter " (number->string arg-number))
+ " is not used, but a value is passed: "
+ (truncated-list->string arg))
+ (if (eq? checker 'unused-set-parameter?)
+ (lint-format* caller
+ (string-append (symbol->string head) "'s parameter " (number->string arg-number))
+ "'s value is not used, but a value is passed: "
+ (truncated-list->string arg)))))
+ (if (not (pair? arg))
+ (let ((val (cond ((not (symbol? arg))
+ arg)
+ ((constant? arg)
+ (symbol->value arg))
+ ((and (hash-table-ref built-in-functions arg)
+ (not (var-member :with-let env))
+ (not (var-member arg env)))
+ (symbol->value arg *e*))
+ (else arg))))
+ (if (not (or (symbol? val)
+ (any-checker? checker val)))
+ (let ((op (->lint-type val)))
+ (unless (memq op '(#f #t values))
+ (report-arg-trouble caller form head arg-number checker arg op)))))
+
+ (case (car arg)
+ ((quote) ; '1 -> 1
+ (let ((op (if (pair? (cadr arg)) 'list? (->lint-type (cadr arg)))))
+ ;; arg is quoted expression
+ (if (not (or (memq op '(#f #t values))
+ (every-compatible? checker op)))
+ (report-arg-trouble caller form head arg-number checker arg op))))
+
+ ;; arg is an expression
+ ((begin let let* letrec letrec* with-let)
+ (check-arg (and (pair? (cdr arg))
+ (list-ref arg (- (length arg) 1)))))
+
+ ((if)
+ (if (and (pair? (cdr arg))
+ (pair? (cddr arg)))
+ (let ((t (caddr arg))
+ (f (if (pair? (cdddr arg)) (cadddr arg))))
+ (check-arg t)
+ (when (and f (not (symbol? f)))
+ (check-arg f)))))
+
+ ((dynamic-wind catch)
+ (if (= (length arg) 4)
+ (let ((f (caddr arg)))
+ (if (and (pair? f)
+ (eq? (car f) 'lambda))
+ (let ((len (length f)))
+ (if (> len 2)
+ (check-arg (list-ref f (- len 1)))))))))
+
+ ((do)
+ (if (and (pair? (cdr arg))
+ (pair? (cddr arg)))
+ (let ((end+res (caddr arg)))
+ (check-arg (if (pair? (cdr end+res))
+ (list-ref (cdr end+res) (- (length end+res) 2))
+ ())))))
+
+ ((case)
+ (for-each
+ (lambda (clause)
+ (if (and (pair? clause)
+ (pair? (cdr clause))
+ (not (eq? (cadr clause) '=>)))
+ (check-arg (list-ref clause (- (length clause) 1)))))
+ (cddr arg)))
+
+ ((cond)
+ (for-each
+ (lambda (clause)
+ (if (pair? clause)
+ (if (pair? (cdr clause))
+ (if (not (eq? (cadr clause) '=>))
+ (check-arg (list-ref clause (- (length clause) 1))))
+ (check-arg (car clause)))))
+ (cdr arg)))
+
+ ((call/cc call-with-exit call-with-current-continuation)
+ ;; find func in body (as car of list), check its arg as return value
+ (when (and (pair? (cdr arg))
+ (pair? (cadr arg))
+ (eq? (caadr arg) 'lambda))
+ (let ((f (cadr arg)))
+ (when (and (pair? (cdr f))
+ (pair? (cadr f))
+ (symbol? (caadr f))
+ (null? (cdadr f)))
+ (define c-walk
+ (let ((rtn (caadr f)))
+ (lambda (tree)
+ (if (pair? tree)
+ (if (eq? (car tree) rtn)
+ (check-arg (if (null? (cdr tree)) () (cadr tree)))
+ (begin
+ (c-walk (car tree))
+ (for-each (lambda (x) (if (pair? x) (c-walk x))) (cdr tree))))))))
+ (for-each c-walk (cddr f))))))
+
+ ((values)
+ (when (positive? (length arg))
+ (cond ((null? (cdr arg)) ; #<unspecified>
+ (if (not (any-checker? checker #<unspecified>))
+ (report-arg-trouble caller form head arg-number checker arg 'unspecified?)))
+ ((null? (cddr arg))
+ (check-arg (cadr arg)))
+ (else
+ (for-each
+ (lambda (expr rest)
+ (check-arg expr)
+ (set! arg-number (+ arg-number 1))
+ (if (> arg-number max-arity) (done))
+ (if (list? checkers)
+ (if (null? (cdr checkers))
+ (done)
+ (set! checkers (cdr checkers)))))
+ (cdr arg) (cddr arg))
+ (check-arg (list-ref arg (- (length arg) 1)))))))
+
+ (else
+ (let ((op (return-type (car arg) env)))
+ (let ((v (var-member (car arg) env)))
+ (if (and (var? v)
+ (not (memq form (var-history v))))
+ (set! (var-history v) (cons form (var-history v)))))
+
+ ;; checker is arg-type, op is expression type (can also be a pair)
+ (if (and (not (memq op '(#f #t values)))
+ (not (memq checker '(unused-parameter? unused-set-parameter?)))
+ (or (not (every-compatible? checker op))
+ (and (just-constants? arg env) ; try to eval the arg
+ (catch #t
+ (lambda ()
+ (not (any-checker? checker (eval arg))))
+ (lambda ignore-catch-error-args
+ #f)))))
+ (report-arg-trouble caller form head arg-number checker arg op)))))))
+
+ (if (list? checkers)
+ (if (null? (cdr checkers))
+ (done)
+ (set! checkers (cdr checkers)))
+ (if (memq checker '(unused-parameter? unused-set-parameter?))
+ (set! checker #t)))
+ (set! arg-number (+ arg-number 1))
+ (if (> arg-number max-arity) (done))))
+ (cdr form)))))))
+
+
+ (define check-unordered-exprs
+ (let ((changers (let ((h (make-hash-table)))
+ (for-each (lambda (s)
+ (hash-table-set! h s #t))
+ '(set!
+ read read-byte read-char read-line read-string
+ write write-byte write-char write-string format display newline
+ reverse! set-cdr! sort! string-fill! vector-fill! fill!
+ emergency-exit exit error throw))
+ h)))
+ (lambda (caller form vals env)
+ (define (report-trouble)
+ (lint-format* caller
+ (string-append "order of evaluation of " (object->string (car form)) "'s ")
+ (string-append (if (memq (car form) '(let letrec do)) "bindings" "arguments") " is unspecified, ")
+ (string-append "so " (truncated-list->string form) " is trouble")))
+ (let ((reads ())
+ (writes ())
+ (jumps ()))
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (p)
+ (when (and (pair? p)
+ (not (var-member (car p) env))
+ (hash-table-ref changers (car p)))
+ (if (pair? jumps)
+ (return (report-trouble)))
+
+ (case (car p)
+
+ ((read read-char read-line read-byte)
+ (if (null? (cdr p))
+ (if (memq () reads)
+ (return (report-trouble))
+ (set! reads (cons () reads)))
+ (if (memq (cadr p) reads)
+ (return (report-trouble))
+ (set! reads (cons (cadr p) reads)))))
+
+ ((read-string)
+ (if (or (null? (cdr p))
+ (null? (cddr p)))
+ (if (memq () reads)
+ (return (report-trouble))
+ (set! reads (cons () reads)))
+ (if (memq (caddr p) reads)
+ (return (report-trouble))
+ (set! reads (cons (caddr p) reads)))))
+
+ ((display write write-char write-string write-byte)
+ (if (null? (cddr p))
+ (if (memq () writes)
+ (return (report-trouble))
+ (set! writes (cons () writes)))
+ (if (memq (caddr p) writes)
+ (return (report-trouble))
+ (set! writes (cons (caddr p) writes)))))
+
+ ((newline)
+ (if (null? (cdr p))
+ (if (memq () writes)
+ (return (report-trouble))
+ (set! writes (cons () writes)))
+ (if (memq (cadr p) writes)
+ (return (report-trouble))
+ (set! writes (cons (cadr p) writes)))))
+
+ ((format)
+ (if (and (pair? (cdr p))
+ (not (string? (cadr p)))
+ (cadr p)) ; i.e. not #f
+ (if (memq (cadr p) writes)
+ (return (report-trouble))
+ (set! writes (cons (cadr p) writes)))))
+
+ ((fill! string-fill! vector-fill! reverse! sort! set! set-cdr!)
+ ;; here there's trouble if cadr used anywhere -- but we need to check for shadowing
+ (if (any? (lambda (np)
+ (and (not (eq? np p))
+ (tree-memq (cadr p) np)))
+ vals)
+ (return (report-trouble))))
+
+ ((throw error exit emergency-exit)
+ (if (or (pair? reads) ; jumps already checked above
+ (pair? writes))
+ (return (report-trouble))
+ (set! jumps (cons p jumps)))))))
+ vals)))))))
+
+ (define check-call
+ (let ((repeated-args-table (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(= / max min < > <= >= - quotient remainder modulo rationalize and or
+ string=? string<=? string>=? string<? string>? string-ci=? string-ci<=? string-ci>=? string-ci<? string-ci>?
+ char=? char<=? char>=? char<? char>? char-ci=? char-ci<=? char-ci>=? char-ci<? char-ci>?
+ boolean=? symbol=?))
+ h))
+ (repeated-args-table-2 (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(= max min < > <= >= and or
+ string=? string<=? string>=? string<? string>? string-ci=? string-ci<=? string-ci>=? string-ci<? string-ci>?
+ char=? char<=? char>=? char<? char>? char-ci=? char-ci<=? char-ci>=? char-ci<? char-ci>?
+ boolean=? symbol=?))
+ h)))
+ (lambda (caller head form env)
+ (let ((data (var-member head env)))
+
+ (if (and (pair? (cdr form))
+ (pair? (cddr form))
+ (or (hash-table-ref built-in-functions head)
+ (let ((v (var-member head env)))
+ (and (var? v)
+ (memq (var-ftype v) '(define define* lambda lambda*))))))
+ (check-unordered-exprs caller form (cdr form) env))
+
+ (if (var? data)
+ (let ((fdata (cdr data)))
+ ;; a local var
+ (when (symbol? (fdata 'ftype))
+ (let ((args (fdata 'arglist))
+ (ary (and (not (eq? (fdata 'decl) 'error))
+ (arity (fdata 'decl))))
+ (sig (var-signature data)))
+ (when (pair? ary)
(let ((req (car ary))
(opt (cdr ary))
(pargs (if (pair? args)
@@ -2956,60 +7044,154 @@
(if (symbol? args)
(list args)
()))))
- (let ((call-args (length (cdr form))))
+ (let ((call-args (- (length form) 1)))
(if (< call-args req)
- (lint-format "~A needs ~D argument~A: ~A"
- name head
- req (if (> req 1) "s" "")
- (truncated-list->string form))
- (if (> (- call-args (keywords (cdr form))) opt)
- (lint-format "~A has too many arguments: ~A" name head (truncated-list->string form)))))
- (if (and (memq type '(define* lambda*))
- (pair? args)
- (not (memq :allow-other-keys args)))
-
+ (begin
+ (for-each (lambda (p)
+ (if (pair? p)
+ (let ((v (var-member (car p) env)))
+ (if (var? v)
+ (let ((vals (let-ref (cdr v) 'values)))
+ (if (pair? vals)
+ (set! call-args (+ call-args -1 (cadr vals)))))))))
+ (cdr form))
+ (if (and (< call-args req)
+ (not (tree-memq 'values (cdr form))))
+ (lint-format "~A needs ~D argument~A: ~A"
+ caller head
+ req (if (> req 1) "s" "")
+ (truncated-list->string form))))
+ (if (> (- call-args (keywords (cdr form))) opt) ; multiple-values can make this worse, (values)=nothing doesn't apply here
+ (lint-format "~A has too many arguments: ~A" caller head (truncated-list->string form)))))
+
+ (unless (fdata 'allow-other-keys)
+ (let ((last-was-key #f)
+ (have-keys 0)
+ (warned #f)
+ (rest (if (and (pair? form) (pair? (cdr form))) (cddr form) ())))
(for-each
(lambda (arg)
(if (and (keyword? arg)
- (not (member (keyword->symbol arg) pargs
- (lambda (a b)
- (if (pair? b)
- (eq? a (car b))
- (eq? a b))))))
- (lint-format "~A keyword argument ~A (in ~S) does not match any argument in ~S" name head arg form pargs)))
- (cdr form)))))))
- ;; not local var
- (when (symbol? head)
- (let ((head-value (symbol->value head *e*))) ; head might be "arity"!
- (when (or (procedure? head-value)
- (macro? head-value))
- ;; check arg number
- (let* ((args (length (cdr form)))
- (ary (arity head-value))
- (min-arity (car ary))
- (max-arity (cdr ary)))
- (if (< args min-arity)
- (lint-format "~A needs ~A~D argument~A: ~A"
- name head
- (if (= min-arity max-arity) "" "at least ")
- min-arity
- (if (> min-arity 1) "s" "")
- (truncated-list->string form))
- (if (and (not (procedure-setter head-value))
- (> (- args (keywords (cdr form))) max-arity))
- (lint-format "~A has too many arguments: ~A" name head (truncated-list->string form))))
- (if (and (procedure? head-value)
- (pair? (cdr form))) ; there are args (the not-enough-args case is checked above)
+ (not last-was-key)) ; keyarg might have key value
+ (begin
+ (set! have-keys (+ have-keys 1))
+ (if (not (member (keyword->symbol arg) pargs
+ (lambda (a b)
+ (eq? a (if (pair? b) (car b) b)))))
+ (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller
+ head arg (truncated-list->string form) pargs))
+ (if (memq arg rest)
+ (lint-format "~W is repeated in ~A" caller arg (cdr form)))
+ (set! last-was-key #t))
+ (begin
+ (when (and (positive? have-keys)
+ (not last-was-key)
+ (not warned))
+ (set! warned #t)
+ (lint-format "non-keyword argument ~A follows previous keyword~P" caller arg have-keys))
+ (set! last-was-key #f)))
+ (if (pair? rest)
+ (set! rest (cdr rest))))
+ (cdr form))))
+
+ (check-args caller head form (if (pair? sig) (cdr sig) ()) env opt)
+
+ ;; for a complete var-history, we could run through the args here even if no type info
+ ;; also if var passed to macro -- what to do?
+
+ ;; look for problematic macro expansion
+ (when (memq (fdata 'ftype) '(define-macro define-macro* defmacro defmacro*))
+
+ (unless (list? (fdata 'macro-ops))
+ (let ((syms (list () ())))
+ (tree-symbol-walk (if (memq (fdata 'ftype) '(define-macro define-macro*))
+ (cddr (fdata 'initial-value))
+ (cdddr (fdata 'initial-value)))
+ syms)
+ (varlet fdata 'macro-locals (car syms) 'macro-ops (cadr syms))))
+
+ (when (or (pair? (fdata 'macro-locals))
+ (pair? (fdata 'macro-ops)))
+ (let ((bad-locals ())
+ (bad-quoted-locals ())
+ (bad-ops ()))
+ (for-each
+ (lambda (local)
+ (if (tree-unquoted-member local (cdr form))
+ (set! bad-locals (cons local bad-locals))))
+ (fdata 'macro-locals))
+ (when (null? bad-locals)
+ (for-each
+ (lambda (local)
+ (if (tree-member local (cdr form))
+ (set! bad-quoted-locals (cons local bad-quoted-locals))))
+ (fdata 'macro-locals)))
+ (for-each
+ (lambda (op)
+ (let ((curf (var-member op env))
+ (oldf (var-member op (fdata 'env))))
+ (if (and (not (eq? curf oldf))
+ (or (pair? (fdata 'env))
+ (defined? op (rootlet))))
+ (set! bad-ops (cons op bad-ops)))))
+ (fdata 'macro-ops))
+
+ (when (or (pair? bad-locals)
+ (pair? bad-quoted-locals)
+ ;; (define-macro (mac8 b) `(let ((a 12)) (+ (symbol->value ,b) a)))
+ ;; (let ((a 1)) (mac8 'a))
+ ;; far-fetched!
+ (pair? bad-ops))
+ (lint-format "possible problematic macro expansion:~% ~A ~A collide with subsequently defined ~A~A~A"
+ caller
+ (truncated-list->string form)
+ (if (or (pair? bad-locals)
+ (pair? bad-ops))
+ "may"
+ "could conceivably")
+ (if (pair? bad-locals)
+ (format #f "~{'~A~^, ~}" bad-locals)
+ (if (pair? bad-quoted-locals)
+ (format #f "~{'~A~^, ~}" bad-quoted-locals)
+ ""))
+ (if (and (pair? bad-locals) (pair? bad-ops)) ", " "")
+ (if (pair? bad-ops)
+ (format #f "~{~A~^, ~}" bad-ops)
+ ""))))))
+ )))))
+ ;; not local var
+ (when (symbol? head)
+ (let ((head-value (symbol->value head *e*))) ; head might be "arity"!
+ (when (or (procedure? head-value)
+ (macro? head-value))
+ ;; check arg number
+ (let* ((args (- (length form) 1))
+ (ary (arity head-value))
+ (min-arity (car ary))
+ (max-arity (cdr ary)))
+ (if (< args min-arity)
+ (lint-format "~A needs ~A~D argument~A: ~A"
+ caller head
+ (if (= min-arity max-arity) "" "at least ")
+ min-arity
+ (if (> min-arity 1) "s" "")
+ (truncated-list->string form))
+ (if (and (not (procedure-setter head-value))
+ (> (- args (keywords (cdr form))) max-arity))
+ (lint-format "~A has too many arguments: ~A" caller head (truncated-list->string form))))
+
+ (when (and (procedure? head-value)
+ (pair? (cdr form))) ; there are args (the not-enough-args case is checked above)
(if (zero? max-arity)
- (lint-format "too many arguments: ~A" name (truncated-list->string form))
+ (lint-format "too many arguments: ~A" caller (truncated-list->string form))
(begin
(for-each (lambda (arg)
(if (pair? arg)
(if (negative? (length arg))
- (lint-format "missing quote? ~A in ~A" name arg form)
+ (lint-format "missing quote? ~A in ~A" caller arg form)
(if (eq? (car arg) 'unquote)
- (lint-format "stray comma? ~A in ~A" name arg form)))))
+ (lint-format "stray comma? ~A in ~A" caller arg form)))))
(cdr form))
;; if keywords, check that they are acceptable
@@ -3025,10 +7207,9 @@
(not (eq? arg :rest))
(not (member arg decls
(lambda (a b)
- (if (pair? b)
- (eq? (keyword->symbol a) (car b))
- (eq? (keyword->symbol a) b))))))
- (lint-format "~A keyword argument ~A (in ~S) does not match any argument in ~S" name head arg form decls)))
+ (eq? (keyword->symbol a) (if (pair? b) (car b) b))))))
+ (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller
+ head arg (truncated-list->string form) decls)))
(cdr form))))))
;; we've already checked for head in the current env above
@@ -3037,20 +7218,20 @@
(hash-table-ref repeated-args-table head)))
(repeated-member? (cdr form) env))
(lint-format "this looks odd: ~A"
- name
+ caller
;; sigh (= a a) could be used to check for non-finite numbers, I suppose,
;; and (/ 0 0) might be deliberate (as in gmp)
;; also (min (random x) (random x)) is not pointless
(truncated-list->string form))
(if (and (hash-table-ref repeated-args-table-2 head)
(repeated-member? (cdr form) env))
- (lint-format "it looks odd to have repeated arguments in~A" name (truncated-list->string form))))
-
+ (lint-format "it looks odd to have repeated arguments in ~A" caller (truncated-list->string form))))
+
(when (memq head '(eq? eqv?))
(define (repeated-member-with-not? lst env)
(and (pair? lst)
- (or (and (or (not (pair? (car lst)))
- (not (side-effect? (car lst) env)))
+ (or (and (not (and (pair? (car lst))
+ (side-effect? (car lst) env)))
(or (member (list 'not (car lst)) (cdr lst))
(and (pair? (car lst))
(eq? (caar lst) 'not)
@@ -3058,1631 +7239,6522 @@
(member (cadar lst) (cdr lst)))))
(repeated-member-with-not? (cdr lst) env))))
(if (repeated-member-with-not? (cdr form) env)
- (lint-format "this looks odd: ~A" name (truncated-list->string form))))
-
- ;; now try to check arg types
- (let ((func (symbol->value head *e*)))
- (let ((arg-data (let ((sig (procedure-signature func)))
- (and (pair? sig)
- (cdr sig)))))
- ;; (format *stderr* "arg-data: ~A~%" arg-data)
- (if (and arg-data
- (or (not (pair? arg-data))
- (not (eq? (car arg-data) #t))
- (not (infinite? (length arg-data)))))
- (check-args name head form arg-data env max-arity))))))))))))))
-
- (define (get-generator form name head) ; defgenerator funcs
+ (lint-format "this looks odd: ~A" caller (truncated-list->string form))))
+
+ ;; now try to check arg types
+ (let* ((func (symbol->value head *e*))
+ (arg-data (let ((sig (procedure-signature func)))
+ (and (pair? sig)
+ (cdr sig)))))
+ (if (pair? arg-data)
+ (check-args caller head form arg-data env max-arity))
+ )))))))))))))
+
+ (define (get-generator caller form env)
+ (when (pair? (cdr form))
(let ((name (if (pair? (cadr form))
(caadr form)
(cadr form))))
- ;; auto-define make-name, name?
- (let ((make-name (string->symbol (string-append "make-" (symbol->string name))))
- (name? (string->symbol (string-append (symbol->string name) "?"))))
-
- (hash-table-set! globals make-name (make-var make-name))
- (hash-table-set! globals name? (make-var name?)))))
-
-
- (define (load-walk form)
- ;; check form for top-level declarations, if load seen, and we haven't seen that file, load it
- (let ((head (car form)))
- (case head
- ((begin)
- (load-walk (cdr form)))
-
- ((define-constant define-envelope)
- (hash-table-set! globals (cadr form) (make-var (cadr form) :val (and (pair? (cddr form)) (caddr form)))))
-
- ((defmacro defmacro*)
- (hash-table-set! globals (cadr form) (make-var (cadr form)
- :new (inlet :type head
- :decl (eval (list head '_ (caddr form) #f))
- :signature #f
- :side-effect #t
- :arglist (caddr form)
- :definition form
- :location #__line__))))
- ((define)
- (let ((name (cadr form)))
- (if (pair? name)
- (let ((fname (car name)))
- (if (symbol? fname)
- (if (keyword? fname)
- (lint-format "keywords are constants ~A" name form)
- (hash-table-set! globals fname
- (make-var fname
- :new (inlet :type 'define
- :decl (eval (list 'define (cons '_ (cdadr form)) #f))
- :signature #f
- :side-effect #t
- :arglist (cdr name)
- :definition form
- :location #__line__))))
-
- (lint-format "what is this? ~A" name form)))
- (hash-table-set! globals name (make-var name :val (and (pair? (cddr form)) (caddr form)))))))
-
- ((define* define-expansion define-macro define-macro* define-bacro define-bacro* definstrument defanimal)
- (hash-table-set! globals (caadr form) (make-var (caadr form)
- :new (inlet :type head
- :decl (eval (list head (cons '_ (cdadr form)) #f))
- :signature #f
- :side-effect #t
- :arglist (cdadr form)
- :definition form
- :location #__line__))))
-
- ((defgenerator)
- (get-generator form 'defgenerator head))
-
- ((if)
- (if (pair? (cddr form))
- (if (pair? (cdddr form))
- (begin
- (load-walk (cadddr form))
- (load-walk (caddr form)))
- (load-walk (caddr form)))))
-
- ((load)
- (if (>= (length form) 2)
- (scan form))))))
-
-
- (define (scan form)
+
+ (if (and (pair? (cadr form))
+ (pair? (cdadr form)))
+ (lint-walk caller (cdadr form) env))
+
+ (let ((gen? (string->symbol (string-append (symbol->string name) "?")))
+ (gen-make (string->symbol (string-append "make-" (symbol->string name)))))
+ (list (make-fvar :name gen?
+ :ftype 'define
+ :decl (dummy-func 'define `(define (,gen? x) (let? x)) '(define (_ x) #f))
+ :initial-value `(define (,gen? x) (let? x))
+ :arglist (list 'x)
+ :env env)
+ (make-fvar :name gen-make
+ :ftype 'define*
+ :decl (dummy-func 'define* `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x)) '(define (_ . x) #f))
+ :initial-value `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x))
+ :arglist (list :rest 'x :allow-other-keys)
+ :env env))))))
+
+ (define (last-par x)
+ (let ((len (length x)))
+ (and (positive? len)
+ (x (- len 1)))))
+
+ (define (binding-ok? caller head binding env second-pass)
+ ;; check let-style variable binding for various syntactic problems
+ (cond (second-pass
+ (and (pair? binding)
+ (symbol? (car binding))
+ ;(not (keyword? (car binding)))
+ (not (constant? (car binding)))
+ (pair? (cdr binding))
+ (or (null? (cddr binding))
+ (and (eq? head 'do)
+ (pair? (cddr binding)) ; (do ((i 0 . 1))...)
+ (null? (cdddr binding))))))
+
+ ((not (pair? binding)) (lint-format "~A binding is not a list? ~S" caller head binding) #f)
+ ((not (symbol? (car binding))) (lint-format "~A variable is not a symbol? ~S" caller head binding) #f)
+ ((keyword? (car binding)) (lint-format "~A variable is a keyword? ~S" caller head binding) #f)
+ ((constant? (car binding)) (lint-format "can't bind a constant: ~S" caller binding) #f)
+ ((not (pair? (cdr binding)))
+ (lint-format (if (null? (cdr binding))
+ "~A variable value is missing? ~S"
+ "~A binding is an improper list? ~S")
+ caller head binding)
+ #f)
+ ((and (pair? (cddr binding))
+ (or (not (eq? head 'do))
+ (pair? (cdddr binding))))
+ (lint-format "~A binding is messed up: ~A" caller head binding)
+ #f)
+ (else
+ (if (and *report-shadowed-variables*
+ (var-member (car binding) env))
+ (lint-format "~A variable ~A in ~S shadows an earlier declaration" caller head (car binding) binding))
+ #t)))
+
+ (define (env-difference name e1 e2 lst)
+ (if (or (null? e1)
+ (null? e2)
+ (eq? (car e1) (car e2)))
+ (reverse lst)
+ (env-difference name (cdr e1) e2
+ (if (eq? name (var-name (car e1)))
+ lst
+ (cons (car e1) lst)))))
+
+ (define (report-usage caller head vars env)
+ ;; report unused or set-but-unreferenced variables, then look at the overall history
+
+ (define (all-types-agree v)
+ (let ((base-type (->lint-type (var-initial-value v)))
+ (vname (var-name v)))
+ (and (every? (lambda (p)
+ (or (not (and (pair? p)
+ (eq? (car p) 'set!)
+ (eq? vname (cadr p))))
+ (let ((nt (->lint-type (caddr p))))
+ (or (subsumes? base-type nt)
+ (and (subsumes? nt base-type)
+ (set! base-type nt))
+ (and (memq nt '(pair? null? proper-list?))
+ (memq base-type '(pair? null? proper-list?))
+ (set! base-type 'list?))))))
+ (var-history v))
+ base-type)))
+
+ (define (indirect-set? vname func arg1)
+ (case func
+ ((set-car! set-cdr! vector-set! list-set! string-set!)
+ (eq? arg1 vname))
+ ((set!)
+ (and (pair? arg1)
+ (eq? (car arg1) vname)))
+ (else #f)))
- (define (find-file file paths)
- (and (pair? paths)
- (catch #t
- (lambda ()
- (open-input-file (string-append (car paths) "/" file)))
- (lambda args
- (find-file file (cdr paths))))))
+ (define (bad-variable-name-numbered vname bad-names)
+ (let ((str (symbol->string vname)))
+ (let loop ((bads bad-names))
+ (and (pair? bads)
+ (let* ((badstr (symbol->string (car bads)))
+ (pos (string-position badstr str)))
+ (or (and (eqv? pos 0)
+ (string->number (substring str (length badstr))))
+ (loop (cdr bads))))))))
+
- (let ((file (cadr form)))
- (if (and (string? file)
- (not (member file loaded-files)))
- (let ((fp (catch #t
- (lambda ()
- (open-input-file file))
- (lambda args
- (or (find-file file *load-path*)
- (and (format outport " can't load ~S~%" file) #f))))))
- (if (input-port? fp)
- (begin
- (set! loaded-files (cons file loaded-files))
- ;(format outport " (scanning ~S)~%" file)
- (do ((form (read fp) (read fp)))
- ((eof-object? form))
- (if (and (pair? form)
- (pair? (cdr form)))
- (load-walk form)))
- (close-input-port fp)))))))
-
-
- (define (binding-ok? name head binding env second-pass)
- ;; check let-style variable binding for various syntactic problems
- (if second-pass
- (and (pair? binding)
- (symbol? (car binding))
- ;(not (keyword? (car binding)))
- (not (constant? (car binding)))
- (pair? (cdr binding))
- (or (null? (cddr binding))
- (and (eq? head 'do)
- (pair? (cddr binding)) ; (do ((i 0 . 1))...)
- (null? (cdddr binding)))))
-
- (cond ((not (pair? binding)) (lint-format "~A binding is not a list? ~S" name head binding) #f)
- ((not (symbol? (car binding))) (lint-format "~A variable is not a symbol? ~S" name head binding) #f)
- ((keyword? (car binding)) (lint-format "~A variable is a keyword? ~S" name head binding) #f)
- ((constant? (car binding)) (lint-format "can't bind a constant: ~S" name binding) #f)
- ((not (pair? (cdr binding)))
- (if (null? (cdr binding))
- (lint-format "~A variable value is missing? ~S" name head binding)
- (lint-format "~A binding is an improper list? ~S" name head binding))
- #f)
- ((or (not (pair? (cdr binding)))
- (and (pair? (cddr binding))
- (or (not (eq? head 'do))
- (pair? (cdddr binding)))))
- (lint-format "~A binding is messed up: ~A" name head binding)
- #f)
- (else
- (if (and *report-shadowed-variables*
- (or (hash-table-ref globals (car binding))
- (var-member (car binding) env)))
- (lint-format "~A variable ~A in ~S shadows an earlier declaration" name head (car binding) binding))
- #t))))
-
-
- (define (env-difference name e1 e2 lst)
- (if (or (null? e1)
- (null? e2)
- (eq? (car e1) (car e2)))
- lst
- (env-difference name (cdr e1) e2
- (if (eq? name (var-name (car e1)))
- lst
- (cons (car e1) lst)))))
-
-
- (define (report-usage name type head vars)
- ;; report unused or set-but-unreferenced variables
- (if (and (not (eq? head 'begin)) ; begin can redefine = set a variable
+ (when (and (not (eq? head 'begin)) ; begin can redefine = set a variable
(pair? vars)
(proper-list? vars))
- (do ((cur vars (cdr cur))
- (rst (cdr vars) (cdr rst)))
- ((null? rst))
- (let ((repeat (var-member (var-name (car cur)) rst)))
- ;; not globals here because the same name might be used as a global
- (if repeat
- (lint-format "~A ~A ~A is declared twice" name head type (var-name (car cur)))))))
-
- (let ((set ())
- (unused ()))
- (for-each
- (lambda (arg)
- (if (hash-table-ref syntaces (var-name arg))
- (lint-format "~A ~A named ~A is asking for trouble" name head type (var-name arg))
- (if (not (symbol? (var-name arg)))
- (lint-format "bad ~A ~A name: ~S" name head type (var-name arg))))
- (if (and (not (var-ref arg))
- (not (hash-table-ref other-identifiers (var-name arg))))
- (if (var-set arg)
- (set! set (cons (var-name arg) set))
- (if (not (memq (var-name arg) '(documentation signature iterator?)))
- (set! unused (cons (var-name arg) unused))))))
- vars)
-
- (if (pair? set)
- (lint-format "~A ~A~A ~{~A~^, ~} set, but not used"
- name head type (if (> (length set) 1) "s" "") (reverse set)))
- (if (pair? unused)
- (lint-format "~A ~A~A ~{~A~^, ~} not used"
- name head type (if (> (length unused) 1) "s" "") (reverse unused)))))
+ (do ((cur vars (cdr cur))
+ (rst (cdr vars) (cdr rst)))
+ ((null? rst))
+ (let ((vn (var-name (car cur))))
+ (if (not (eq? vn :lambda))
+ (let ((repeat (var-member vn rst)))
+ (when repeat
+ (let ((type (if (eq? (var-definer repeat) 'parameter) 'parameter 'variable)))
+ (if (eq? (var-definer (car cur)) 'define)
+ (lint-format "~A ~A ~A is redefined ~A" caller head type vn
+ (if (equal? head "")
+ (if (not (tree-memq vn (var-initial-value (car cur))))
+ "at the top level."
+ (format #f "at the top level. Perhaps use set! instead: ~A"
+ (truncated-list->string `(set! ,vn ,(var-initial-value (car cur))))))
+ (format #f "in the ~A body. Perhaps use set! instead: ~A"
+ head (truncated-list->string `(set! ,vn ,(var-initial-value (car cur)))))))
+ (lint-format "~A ~A ~A is declared twice" caller
+ head type vn)))))))))
+ (let ((old-line-number line-number))
+
+ (for-each
+ (lambda (local-var)
+ (let ((vname (var-name local-var))
+ (otype (if (eq? (var-definer local-var) 'parameter) 'parameter 'variable)))
+
+ ;; translate to dilambda fixing arg if necessary and mention generic set!
+ (let ((init (var-initial-value local-var)))
+ (when (and (pair? init)
+ (eq? (car init) 'define)
+ (pair? (cadr init)))
+ (let* ((vstr (symbol->string vname))
+ (len (length vstr)))
+ (when (> len 4)
+ (let ((setv #f)
+ (newv #f))
+ (if (string=? (substring vstr 0 4) "get-")
+ (let ((sv (string->symbol (string-append "set-" (substring vstr 4)))))
+ (set! setv (or (var-member sv vars)
+ (var-member sv env)))
+ (set! newv (string->symbol (substring vstr 4))))
+ (if (string=? (substring vstr (- len 4)) "-ref")
+ (let ((sv (string->symbol (string-append (substring vstr 0 (- len 4)) "-set!"))))
+ (set! setv (or (var-member sv vars)
+ (var-member sv env)))
+ (set! newv (string->symbol (substring vstr 0 (- len 4)))))
+ (let ((pos (string-position "-get-" vstr)))
+ (when pos ; this doesn't happen very often, others: Get-, -ref-, -set!- are very rare
+ (let ((sv (string->symbol (let ((s (copy vstr))) (set! (s (+ pos 1)) #\s) s))))
+ (set! setv (or (var-member sv vars)
+ (var-member sv env)))
+ (set! newv (string->symbol (string-append (substring vstr 0 pos)
+ (substring vstr (+ pos 4)))))))))) ; +4 to include #\-
+ (when (and setv
+ (not (var-member newv vars))
+ (not (var-member newv env)))
+ (let ((getter init)
+ (setter (var-initial-value setv)))
+ (when (and (pair? setter)
+ (eq? (car setter) 'define)
+ (pair? (cadr setter)))
+ (let ((getargs (cdadr getter))
+ (setargs (cdadr setter)))
+ (unless (null? setargs)
+ (if (or (eq? newv getargs)
+ (and (pair? getargs)
+ (memq newv getargs)))
+ (let ((unique (find-unique-name getter newv)))
+ (set! getter (tree-subst unique newv getter))
+ (set! getargs (cdadr getter))))
+ (if (or (eq? newv setargs)
+ (and (pair? setargs)
+ (memq newv setargs)))
+ (let ((unique (find-unique-name setter newv)))
+ (set! setter (tree-subst unique newv setter))
+ (set! setargs (cdadr setter))))
+ (let ((getdots (if (null? getargs) "" " ..."))
+ (setdots (if (or (not (pair? setargs)) (null? (cdr setargs))) "" " ..."))
+ (setvalue (and (proper-list? setargs)
+ (list-ref setargs (- (length setargs) 1)))))
+ (if setvalue
+ (format outport "~NC~A: perhaps use dilambda and generalized set! for ~A and ~A:~%~
+ ~NCreplace (~A~A) with (~A~A) and (~A~A ~A) with (set! (~A~A) ~A)~%~
+ ~NC~A~%"
+ lint-left-margin #\space
+ caller
+ vname (var-name setv)
+ lint-left-margin #\space
+ vname getdots newv getdots
+ (var-name setv) setdots setvalue
+ newv setdots setvalue
+ lint-left-margin #\space
+ (lint-pp `(define ,newv (dilambda
+ (lambda ,getargs ,@(cddr getter))
+ (lambda ,setargs ,@(cddr setter))))))))))))))))))
+ ;; bad variable names
+ (cond ((hash-table-ref syntaces vname)
+ (lint-format "~A ~A named ~A is asking for trouble" caller head otype vname))
+
+ ((eq? vname 'l)
+ (lint-format "\"l\" is a really bad variable name" caller))
+
+ ((and *report-built-in-functions-used-as-variables*
+ (hash-table-ref built-in-functions vname))
+ (lint-format "~A ~A named ~A is asking for trouble" caller
+ (if (and (pair? (var-scope local-var))
+ (null? (cdr (var-scope local-var)))
+ (symbol? (car (var-scope local-var))))
+ (car (var-scope local-var))
+ head)
+ otype vname))
+
+ ((and (symbol? vname)
+ (pair? *report-bad-variable-names*)
+ (or (memq vname *report-bad-variable-names*)
+ (bad-variable-name-numbered vname *report-bad-variable-names*)))
+ (lint-format "surely there's a better name for this variable than ~A" caller vname)))
+
+ (unless (eq? vname :lambda)
+ (if (and (eq? otype 'variable)
+ (or *report-unused-top-level-functions*
+ (not (eq? caller top-level:))))
+ (let ((scope (var-scope local-var))) ; might be #<undefined>?
+ (if (pair? scope) (set! scope (remove vname scope)))
+
+ (when (and (pair? scope)
+ (null? (cdr scope))
+ (symbol? (car scope))
+ (not (var-member (car scope) (let search ((e env))
+ (if (null? e)
+ env
+ (if (eq? (caar e) vname)
+ e
+ (search (cdr e))))))))
+ (format outport "~NC~A~A is ~A only in ~A~%"
+ lint-left-margin #\space
+ (if (eq? caller top-level:)
+ "top-level: "
+ "")
+ vname
+ (if (memq (var-ftype local-var) '(define lambda define* lambda*)) "called" "used")
+ (car scope)))))
+
+ (if (and (eq? (var-ftype local-var) 'define-expansion)
+ (not (eq? caller top-level:)))
+ (format outport "~NCdefine-expansion for ~A is not at the top-level, so it is ignored~%"
+ lint-left-margin #\space
+ vname))
+
+ (when (and *report-function-stuff*
+ (memq (var-ftype local-var) '(define lambda define* lambda*))
+ (pair? (caddr (var-initial-value local-var))))
+ (let ((cur (hash-table-ref equable-closures (caaddr (var-initial-value local-var)))))
+ (if (pair? cur)
+ (hash-table-set! equable-closures (caaddr (var-initial-value local-var)) (remove local-var cur)))))
+
+ ;; redundant vars are hard to find -- tons of false positives
+
+ (if (zero? (var-ref local-var))
+
+ (when (and (or (not (equal? head ""))
+ *report-unused-top-level-functions*)
+ (or *report-unused-parameters*
+ (not (eq? otype 'parameter))))
+ (if (positive? (var-set local-var))
+ (let ((sets (map (lambda (call)
+ (if (and (pair? call)
+ (not (eq? (var-definer local-var) 'do))
+ (eq? (car call) 'set!)
+ (eq? (cadr call) vname))
+ call
+ (values)))
+ (var-history local-var))))
+ (if (pair? sets)
+ (if (null? (cdr sets))
+ (lint-format "~A set, but not used: ~A" caller
+ vname (truncated-list->string (car sets)))
+ (lint-format "~A set, but not used: ~{~S~^ ~}" caller
+ vname sets))
+ (lint-format "~A set, but not used: ~A from ~A" caller
+ vname (truncated-list->string (var-initial-value local-var)) (var-definer local-var))))
+
+ ;; not ref'd or set
+ (if (not (memq vname '(documentation signature iterator? defanimal)))
+ (let ((val (if (pair? (var-history local-var)) (car (var-history local-var)) (var-initial-value local-var)))
+ (def (var-definer local-var)))
+ (let-temporarily ((line-number (if (eq? caller top-level:) -1 line-number)))
+ (if (symbol? def)
+ (if (eq? otype 'parameter)
+ (lint-format "~A not used" caller vname)
+ (lint-format* caller
+ (string-append (object->string vname) " not used, initially: ")
+ (string-append (truncated-list->string val) " from " (symbol->string def))))
+ (lint-format* caller
+ (string-append (object->string vname) " not used, value: ")
+ (truncated-list->string val))))))))
+ ;; not zero var-ref
+ (let ((arg-type #f))
+
+ (when (and (not (memq (var-definer local-var) '(parameter named-let named-let*)))
+ (pair? (var-history local-var))
+ (or (zero? (var-set local-var))
+ (set! arg-type (all-types-agree local-var))))
+ (let ((vtype (or arg-type ; this can't be #f unless no sets so despite appearances there's no contention here
+ (->lint-type (var-initial-value local-var))))
+ (lit? (code-constant? (var-initial-value local-var))))
+
+ (do ((clause (var-history local-var) (cdr clause)))
+ ((null? (cdr clause))) ; ignore the initial value which depends on a different env
+ (let ((call (car clause)))
+ (set! line-number (if (pair? call) (pair-line-number call) 0))
+
+ (when (pair? call)
+ (let ((func (car call))
+ (call-arg1 (and (pair? (cdr call)) (cadr call))))
+
+ ;; check for assignments into constants
+ (if (and lit?
+ (indirect-set? vname func call-arg1))
+ (lint-format "~A's value, ~A, is a literal constant, so this set! is trouble: ~A" caller
+ vname (var-initial-value local-var) (truncated-list->string call)))
+
+ (when (and (symbol? vtype)
+ (not (eq? caller top-level:))
+ (not (memq vtype '(boolean? #t values)))
+ (memq func '(if when unless)) ; look for (if x ...) where x is never #f, this happens a dozen or so times
+ (or (eq? (cadr call) vname)
+ (and (pair? (cadr call))
+ (eq? (caadr call) 'not)
+ (eq? (cadadr call) vname))))
+ (lint-format "~A is never #f, so ~A is ~A" caller vname call
+ (if (eq? vname (cadr call))
+ (case func
+ ((if) (caddr call))
+ ((when) (if (pair? (cdddr call)) `(begin ,@(cddr call)) (caddr call)))
+ ((unless) #<unspecified>))
+ (case func
+ ((if) (if (pair? (cdddr call)) (cadddr call)))
+ ((when) #<unspecified>)
+ ((unless) (if (pair? (cdddr call)) `(begin ,@(cddr call)) (caddr call)))))))
+
+ ;; check for incorrect types in function calls
+ (when (and (symbol? vtype)
+ (not (memq vtype '(boolean? null?)))) ; null? here avoids problems with macros that call set!
+ (let ((p (memq vname (cdr call))))
+ (when (pair? p)
+ (let ((sig (arg-signature func env))
+ (pos (- (length call) (length p))))
+ (when (and (pair? sig)
+ (< pos (length sig)))
+ (let ((desired-type (list-ref sig pos)))
+ (if (not (compatible? vtype desired-type))
+ (lint-format "~A is ~A, but ~A in ~A wants ~A" caller
+ vname (prettify-checker-unq vtype)
+ func (truncated-list->string call)
+ (prettify-checker desired-type))))))))
+
+ (let ((suggest made-suggestion))
+ ;; check for pointless vtype checks
+ (when (and (hash-table-ref bools func)
+ (not (eq? vname func)))
+
+ (when (or (eq? vtype func)
+ (and (compatible? vtype func)
+ (not (subsumes? vtype func))))
+ (lint-format "~A is ~A, so ~A is #t" caller vname (prettify-checker-unq vtype) call))
+
+ (unless (compatible? vtype func)
+ (lint-format "~A is ~A, so ~A is #f" caller vname (prettify-checker-unq vtype) call)))
+
+ (case func
+ ;; need a way to mark exported variables so they won't be checked in this process
+ ;; case can happen here, but it never seems to trigger a type error
+ ((eq? eqv? equal?)
+ ;; (and (pair? x) (eq? x #\a)) etc
+ (when (or (and (code-constant? call-arg1)
+ (not (compatible? vtype (->lint-type call-arg1))))
+ (and (code-constant? (caddr call))
+ (not (compatible? vtype (->lint-type (caddr call))))))
+ (lint-format "~A is ~A, so ~A is #f" caller vname (prettify-checker-unq vtype) call)))
+
+ ((and or)
+ (when (let amidst? ((lst call))
+ (and (pair? lst)
+ (pair? (cdr lst))
+ (or (eq? (car lst) vname)
+ (amidst? (cdr lst))))) ; don't clobber possible trailing vname (returned by expression)
+ (lint-format "~A is ~A, so ~A~%" caller ; (let ((x 1)) (and x (< x 1))) -> (< x 1)
+ vname (prettify-checker-unq vtype)
+ (lists->string call
+ (simplify-boolean (remove vname call) () () vars)))))
+ ((not)
+ (if (eq? vname (cadr call))
+ (lint-format "~A is ~A, so ~A" caller
+ vname (prettify-checker-unq vtype)
+ (lists->string call #f))))
+
+ ((/) (if (and (number? (var-initial-value local-var))
+ (zero? (var-initial-value local-var))
+ (zero? (var-set local-var))
+ (memq vname (cddr call)))
+ (lint-format "~A is ~A, so ~A is an error" caller
+ vname (var-initial-value local-var)
+ call))))
+
+ ;; the usual eqx confusion
+ (when (and (= suggest made-suggestion)
+ (memq vtype '(char? number? integer? real? float? rational? complex?)))
+ (if (memq func '(eq? equal?))
+ (lint-format "~A is ~A, so ~A ~A be eqv? in ~A" caller
+ vname (prettify-checker-unq vtype) func
+ (if (eq? func 'eq?) "should" "could")
+ call))
+ ;; check other boolean exprs
+ (when (and (zero? (var-set local-var))
+ (number? (var-initial-value local-var))
+ (eq? vname call-arg1)
+ (null? (cddr call))
+ (hash-table-ref bools1 func))
+ (let ((val (catch #t
+ (lambda ()
+ ((symbol->value func (rootlet)) (var-initial-value local-var)))
+ (lambda args
+ 'error))))
+ (if (boolean? val)
+ (lint-format "~A is ~A, so ~A is ~A" caller vname (var-initial-value local-var) call val))))))
+
+ ;; implicit index checks -- these are easily fooled by macros
+ (when (and (memq vtype '(vector? float-vector? int-vector? string? list? byte-vector?))
+ (pair? (cdr call)))
+ (when (eq? func vname)
+ (let ((init (var-initial-value local-var)))
+ (if (not (compatible? 'integer? (->lint-type call-arg1)))
+ (lint-format "~A is ~A, but the index ~A is ~A" caller
+ vname (prettify-checker-unq vtype)
+ call-arg1 (prettify-checker (->lint-type call-arg1))))
+
+ (if (integer? call-arg1)
+ (if (negative? call-arg1)
+ (lint-format "~A's index ~A is negative" caller vname call-arg1)
+ (if (zero? (var-set local-var))
+ (let ((lim (cond ((code-constant? init)
+ (length init))
+
+ ((memq (car init) '(vector float-vector int-vector string list byte-vector))
+ (- (length init) 1))
+
+ (else
+ (and (pair? (cdr init))
+ (integer? (cadr init))
+ (memq (car init) '(make-vector make-float-vector make-int-vector
+ make-string make-list make-byte-vector))
+ (cadr init))))))
+ (if (and lim (>= call-arg1 lim))
+ (lint-format "~A has length ~A, but index is ~A" caller vname lim call-arg1))))))))
+
+ (when (eq? func 'implicit-set)
+ ;; ref is already checked in other history entries
+ (let ((ref-type (case vtype
+ ((float-vector?) 'real?) ; not 'float? because ints are ok here
+ ((int-vector? byte-vector?) 'integer)
+ ((string?) 'char?)
+ (else #f))))
+ (if ref-type
+ (let ((val-type (->lint-type (caddr call))))
+ (if (not (compatible? val-type ref-type))
+ (lint-format "~A wants ~A, but the value in ~A is ~A" caller
+ vname (prettify-checker-unq ref-type)
+ `(set! ,@(cdr call))
+ (prettify-checker val-type)))))
+ )))))
+ ))) ; do loop through clauses
+
+ ;; check for duplicated calls involving local-var
+ (when (and (> (var-ref local-var) 8)
+ (zero? (var-set local-var))
+ (eq? (var-ftype local-var) #<undefined>))
+ (let ((h (make-hash-table)))
+ (for-each (lambda (call)
+ (if (and (pair? call)
+ (not (eq? (car call) vname)) ; ignore functions for now
+ (not (side-effect? call env)))
+ (hash-table-set! h call (+ 1 (or (hash-table-ref h call) 0)))))
+ (var-history local-var))
+ (let ((repeats ()))
+ (for-each (lambda (call)
+ (if (and (> (cdr call) 5)
+ (not (memq (caar call) '(make-vector make-float-vector)))
+ (or (null? (cddar call))
+ (every? (lambda (p)
+ (or (not (symbol? p))
+ (eq? p vname)))
+ (cdar call))))
+ (set! repeats (cons (string-append (truncated-list->string (car call)) " occurs ")
+ (cons (string-append (object->string (cdr call)) " times"
+ (if (pair? repeats)
+ ", "
+ ""))
+ repeats)))))
+ h)
+ (if (pair? repeats)
+ (apply lint-format*
+ caller
+ (string-append (object->string vname) " is not set, but ")
+ repeats)))))
+
+ ;; check for function parameters whose values never change and are not just symbols
+ (when (and (> (var-ref local-var) 3)
+ (zero? (var-set local-var))
+ (memq (var-ftype local-var) '(define lambda))
+ (pair? (var-arglist local-var))
+ (let loop ((calls (var-history local-var))) ; if func passed as arg, ignore it
+ (or (null? calls)
+ (null? (cdr calls))
+ (and (pair? (car calls))
+ (not (memq (var-name local-var) (cdar calls)))
+ (loop (cdr calls))))))
+ (let ((pars (map list (proper-list (var-arglist local-var)))))
+ (do ((clauses (var-history local-var) (cdr clauses)))
+ ((null? (cdr clauses))) ; ignore the initial value
+ (if (and (pair? (car clauses))
+ (eq? (caar clauses) (var-name local-var)))
+ (for-each (lambda (arg par)
+ (if (not (member arg (cdr par)))
+ (set-cdr! par (cons arg (cdr par)))))
+ (cdar clauses)
+ pars)))
+ (for-each (lambda (p)
+ (if (and (pair? (cdr p))
+ (null? (cddr p))
+ (not (symbol? (cadr p))))
+ (lint-format "~A's '~A parameter is always ~S (~D calls)" caller
+ (var-name local-var) (car p) (cadr p) (var-ref local-var))))
+ pars)))
+ )))) ; end (if zero var-ref)
+
+ ;; vars with multiple incompatible ascertainable types don't happen much and obvious type errors are extremely rare
+ )))
+ vars)
+ (set! line-number old-line-number)))
+
+
+ ;; ----------------------------------------
+ ;; preloading built-in definitions, and looking for them here found less than a dozen (list-ref, list-tail, and boolean?)
+
+ (define (code-equal? p1 p2 matches e1 e2)
+
+ (define (match-vars r1 r2 mat)
+ (and (pair? r1)
+ (pair? r2)
+ (pair? (cdr r1))
+ (pair? (cdr r2))
+ (if (and (pair? (cadr r1))
+ (pair? (cadr r2))
+ (memq (caadr r1) '(let let* letrec letrec* do lambda lambda*
+ define define-constant define-macro define-bacro define-expansion
+ define* define-macro* define-bacro*)))
+ (code-equal? (cadr r1) (cadr r2) mat e1 e2)
+ (structures-equal? (cadr r1) (cadr r2) mat e1 e2))
+ (cons (car r1) (car r2))))
+
+ (let ((f1 (car p1))
+ (f2 (car p2)))
+ (and (eq? f1 f2)
+ (let ((rest1 (cdr p1))
+ (rest2 (cdr p2)))
+ (and (pair? rest1)
+ (pair? rest2)
+ (call-with-exit
+ (lambda (return)
+ (case f1
+ ((let)
+ (let ((name ()))
+ (if (symbol? (car rest1)) ; named let -- match funcs too
+ (if (symbol? (car rest2))
+ (begin
+ (set! name (list (cons (car rest1) (car rest2))))
+ (set! rest1 (cdr rest1))
+ (set! rest2 (cdr rest2)))
+ (return #f))
+ (if (symbol? (car rest2))
+ (return #f)))
+ (and (= (length (car rest1)) (length (car rest2)))
+ (structures-equal? (cdr rest1) (cdr rest2) ; refs in values are to outer matches
+ (append (map (lambda (var1 var2)
+ (or (match-vars var1 var2 matches)
+ (return #f)))
+ (car rest1)
+ (car rest2))
+ name ; append will splice out nil
+ matches)
+ e1 e2))))
+ ((let*) ; refs move with the vars
+ (and (= (length (car rest1)) (length (car rest2)))
+ (let ((new-matches matches))
+ (for-each (lambda (var1 var2)
+ (cond ((match-vars var1 var2 new-matches) =>
+ (lambda (v)
+ (set! new-matches (cons v new-matches))))
+ (else (return #f))))
+ (car rest1)
+ (car rest2))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2))))
+
+ ((do) ; matches at init are outer, but at step are inner
+ (and (= (length (car rest1)) (length (car rest2)))
+ (let ((new-matches matches))
+ (for-each (lambda (var1 var2)
+ (cond ((match-vars var1 var2 matches) =>
+ (lambda (v)
+ (set! new-matches (cons v new-matches))))
+ (else (return #f))))
+ (car rest1)
+ (car rest2))
+ (for-each (lambda (var1 var2)
+ (unless (structures-equal? (cddr var1) (cddr var2) new-matches e1 e2)
+ (return #f)))
+ (car rest1)
+ (car rest2))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2))))
+
+ ((letrec letrec*) ; ??? refs are local I think
+ (and (= (length (car rest1)) (length (car rest2)))
+ (let ((new-matches (append (map (lambda (var1 var2)
+ (cons (car var1) (car var2)))
+ (car rest1)
+ (car rest2))
+ matches)))
+ (for-each (lambda (var1 var2)
+ (unless (structures-equal? (cadr var1) (cadr var2) new-matches e1 e2)
+ (return #f)))
+ (car rest1)
+ (car rest2))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2))))
+
+ ((lambda)
+ (if (symbol? (car rest1))
+ (and (symbol? (car rest2))
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (cons (cons (car rest1) (car rest2)) matches) e1 e2))
+ (and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)
+ e1 e2))))
+ ((define define-constant define-macro define-bacro define-expansion)
+ (if (symbol? (car rest1))
+ (and (symbol? (car rest2))
+ (let ((new-matches (cons (cons (car rest1) (car rest2)) matches)))
+ (and (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)
+ new-matches)))
+ (and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)
+ e1 e2)
+ (cons (cons (caar rest1) (caar rest2)) matches))))
+ ;; for define we add the new name to matches before walking the body (shadow is immediate),
+ ;; but then the new name is added to matches and returned (see below)
+
+ ((lambda*)
+ (if (symbol? (car rest1))
+ (and (symbol? (car rest2))
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (cons (cons (car rest1) (car rest2)) matches)
+ e1 e2))
+ (and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (append (map (lambda (a b)
+ (if (or (pair? a) ; if default, both must have the same value
+ (pair? b))
+ (if (not (and (pair? a)
+ (pair? b)
+ (equal? (cadr a) (cadr b))))
+ (return #f)
+ (cons (car a) (car b)))
+ (cons a b)))
+ (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)
+ e1 e2))))
+
+ ((define* define-macro* define-bacro*)
+ (if (symbol? (car rest1))
+ (and (symbol? (car rest2))
+ (let ((new-matches (cons (cons (car rest1) (car rest2)) matches)))
+ (and (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)
+ new-matches)))
+ (and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
+ (structures-equal? (cdr rest1) (cdr rest2)
+ (append (map (lambda (a b)
+ (if (or (pair? a) ; if default, both must have the same value
+ (pair? b))
+ (if (not (and (pair? a)
+ (pair? b)
+ (equal? (cadr a) (cadr b))))
+ (return #f)
+ (cons (car a) (car b)))
+ (cons a b)))
+ (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)
+ e1 e2)
+ (cons (cons (caar rest1) (caar rest2)) matches))))
+
+ (else #f))))))))) ; can't happen I hope
+
+ (define (structures-equal? p1 p2 matches e1 e2)
+ (if (pair? p1)
+ (and (pair? p2)
+ (if (eq? (car p1) 'quote)
+ (and (eq? (car p2) 'quote)
+ (equal? (cdr p1) (cdr p2)))
+ (and (cond ((not (and (pair? (car p1))
+ (pair? (car p2))))
+ (structures-equal? (car p1) (car p2) matches e1 e2))
+
+ ((memq (caar p1) '(let let* letrec letrec* do lambda lambda*))
+ (code-equal? (car p1) (car p2) matches e1 e2))
+
+ ((memq (caar p1) '(define define-constant define-macro define-bacro define-expansion define* define-macro* define-bacro*))
+ (let ((mat (code-equal? (car p1) (car p2) matches e1 e2)))
+ (and (pair? mat)
+ (set! matches mat))))
+
+ ;; this ignores possible reversible equivalence (i.e. (< x 0) is the same as (> 0 x)
+ ;; (structures-equal? (car p1) (car p2) matches e1 e2)))
+
+ ;; check for reversible equivalence
+ ;; half-humorous problem: infinite loop here switching back and forth!
+ ;; so I guess we have to check cdar by hand
+ ;; we could also check for not+notable here, but lint will complain
+ ;; about that elsewhere, causing this check to be ignored.
+ (else (or (structures-equal? (car p1) (car p2) matches e1 e2)
+ (and (eq? (hash-table-ref reversibles (caar p1)) (caar p2))
+ (not (any? (lambda (p) (side-effect? p e1)) (cdar p1))) ; (+ (oscil g) (oscil g x)) is not reversible!
+ (do ((a (cdar p1) (cdr a))
+ (b (reverse (cdar p2)) (cdr b)))
+ ((or (null? a)
+ (null? b)
+ (not (structures-equal? a b matches e1 e2)))
+ (and (null? a)
+ (null? b))))))))
+ (structures-equal? (cdr p1) (cdr p2) matches e1 e2))))
+ (let ((match (assq p1 matches)))
+ (if match
+ (or (and (eq? (cdr match) :unset)
+ (set-cdr! match p2))
+ (equal? (cdr match) p2))
+ (if (symbol? p1)
+ (and (eq? p1 p2)
+ (or (eq? e1 e2)
+ (eq? (assq p1 e1) (assq p2 e2))))
+ (equal? p1 p2))))))
+
+
+ ;; code-equal? and structures-equal? called in function-match and each other
+
+ (define (function-match caller form env)
+
+ (define func-min-cutoff 6)
+ (define func-max-cutoff 120)
+
+ (define (proper-list* lst)
+ ;; return lst as a proper list (might have defaults, keywords etc)
+ (if (or (not (pair? lst))
+ (eq? (car lst) :allow-other-keys))
+ ()
+ (if (eq? (car lst) :rest)
+ (cdr lst)
+ (cons (if (pair? (car lst)) (caar lst) (car lst))
+ (if (pair? (cdr lst))
+ (proper-list* (cdr lst))
+ (if (null? (cdr lst))
+ ()
+ (list (cdr lst))))))))
- (define (lint-walk-body name head body env)
- ;; walk a body (a list of forms, the value of the last of which might be returned)
+ (let ((leaves (tree-leaves form)))
- (if (not (proper-list? body))
- (lint-format "stray dot? ~A" name (truncated-list->string body))
+ (when (<= func-min-cutoff leaves func-max-cutoff)
+ (let ((new-form (if (pair? (car form)) form (list form)))
+ (name-args #f)
+ (name-args-len :unset)
+ (e2 ()))
- (let ((prev-f #f)
- (prev-fs #f)
- (prev-len 0)
- (f-len 0)
- (block-fs #f)
- (dpy-f #f)
- (dpy-start #f)
- (len (length body)))
- (if (eq? head 'do) (set! len (+ len 1))) ; last form in do body is not returned
-
- (do ((fs body (cdr fs))
- (ctr 0 (+ ctr 1)))
- ((not (pair? fs)))
- (let ((f (car fs)))
-
- (if (pair? f)
- (begin
- (set! f-len (length f))
- (if (eq? (car f) 'begin)
- (lint-format "redundant begin: ~A" name (truncated-list->string f))))
- (set! f-len 0))
+ (let ((v (var-member caller env)))
+ (when (and (var? v)
+ (memq (var-ftype v) '(define lambda define* lambda*))
+ (or (eq? form (cddr (var-initial-value v))) ; only check args if this is the complete body
+ (and (null? (cdddr (var-initial-value v)))
+ (eq? form (caddr (var-initial-value v))))))
+ (set! e2 (var-env v))
+ (if (symbol? (var-arglist v))
+ (begin
+ (set! name-args-len #f)
+ (set! name-args (list (var-arglist v))))
+ (begin
+ (set! name-args-len (length (var-arglist v)))
+ (set! name-args (map (lambda (arg)
+ (if (symbol? arg)
+ arg
+ (values)))
+ (proper-list* (var-arglist v))))))))
+
+ (define find-code-match
+ (let ((e1 ())
+ (cutoff (max func-min-cutoff (- leaves 12))))
+ (lambda (v)
+ (and (not (eq? (var-name v) :lambda))
+ (memq (var-ftype v) '(define lambda define* lambda*))
+ (not (eq? caller (var-name v)))
+ (let ((body (cddr (var-initial-value v)))
+ (args (var-arglist v)))
+ (set! e1 (var-env v))
+
+ (let ((args-len (length args)))
+ (when (or (eq? name-args-len :unset)
+ (equal? args-len name-args-len)
+ (and (integer? args-len)
+ (integer? name-args-len)
+ (not (negative? (* args-len name-args-len)))))
+
+ (unless (var-leaves v)
+ (set! (var-leaves v) (tree-leaves body))
+ (set! (var-match-list v) (if (symbol? args)
+ (list (cons args :unset))
+ (map (lambda (arg)
+ (if (symbol? arg)
+ (cons arg :unset)
+ (values)))
+ (proper-list* args)))))
+
+ ;; var-leaves is size of func (v) body
+ ;; leaves is size of form which we want to match with func
+ ;; func-min-cutoff avoids millions of uninteresting matches
+
+ (and (<= cutoff (var-leaves v) leaves)
+ (let ((match-list (do ((p (var-match-list v) (cdr p)))
+ ((null? p)
+ (var-match-list v))
+ (set-cdr! (car p) :unset))))
+ (and (structures-equal? body new-form
+ (cons (cons (var-name v) caller) match-list) e1 e2)
+ ;; if the functions are recursive, we also need those names matched, hence the extra entry
+ ;; but we treat match-list below as just the args, so add the func names at the call,
+ ;; but this can be fooled if we're playing games with eq? basically -- the function
+ ;; names should only match if used as functions.
+
+ (not (member :unset match-list (lambda (a b) (eq? (cdr b) :unset))))
+ (let ((new-args (map cdr match-list)))
+ (if (and (equal? new-args name-args)
+ (equal? args-len name-args-len))
+ (lint-format "~A could be ~A" caller caller `(define ,caller ,(var-name v)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(var-name v) , at new-args))))
+ #t)))))))))))
+
+ (do ((vs (or (hash-table-ref equable-closures (caar new-form)) ()) (cdr vs)))
+ ;; instead of hashing on car as above, hash on composite of cars+base statements
+ ((or (null? vs)
+ (find-code-match (car vs)))))))))
+
- (if (and (= f-len prev-len 3)
+ (define (unbegin x)
+ (if (and (pair? x)
+ (eq? (car x) 'begin))
+ (cdr x)
+ (list x)))
+
+ (define (check-returns caller f env)
+ (if (not (or (side-effect? f env)
+ (eq? f '=>)))
+ (lint-format "this could be omitted: ~A" caller (truncated-list->string f))
+ (when (pair? f)
+ (case (car f)
+ ((if)
+ (when (and (pair? (cdr f))
+ (pair? (cddr f)))
+ (let ((true (caddr f))
+ (false (if (pair? (cdddr f)) (cadddr f) 'no-false)))
+ (let ((true-ok (side-effect? true env))
+ (false-ok (or (eq? false 'no-false)
+ (side-effect? false env))))
+ (if true-ok
+ (if (pair? true)
+ (check-returns caller true env))
+ (lint-format "this branch is pointless~A: ~A in ~A" caller
+ (local-line-number true)
+ (truncated-list->string true)
+ (truncated-list->string f)))
+ (if false-ok
+ (if (pair? false)
+ (check-returns caller false env))
+ (lint-format "this branch is pointless~A: ~A in ~A" caller
+ (local-line-number false)
+ (truncated-list->string false)
+ (truncated-list->string f)))))))
+ ((cond case)
+ ;; here all but last result exprs are already checked
+ ;; redundant begin can confuse this, but presumably we'll complain about that elsewhere
+ (for-each (lambda (c)
+ (if (and (pair? c)
+ (pair? (cdr c))
+ (not (memq '=> (cdr c))))
+ (let ((last-expr (list-ref (cdr c) (- (length c) 2))))
+ (if (side-effect? last-expr env)
+ (if (pair? last-expr)
+ (check-returns caller last-expr env))
+ (if (eq? (car f) 'case) ; here some sort of return is required (sigh)
+ (if (null? (cddr c)) ; just the return value
+ (if (not (memq last-expr '(#f #t ())))
+ (lint-format "this could be simply #f: ~A in ~A" caller
+ (truncated-list->string last-expr)
+ (truncated-list->string c)))
+ (lint-format "this could be omitted: ~A in ~A" caller
+ (truncated-list->string last-expr)
+ (truncated-list->string c)))
+ (lint-format "this is pointless: ~A in ~A" caller
+ (truncated-list->string last-expr)
+ (truncated-list->string c)))))))
+ (if (eq? (car f) 'cond) (cdr f) (cddr f))))
+
+ ((let let*)
+ (if (and (pair? (cdr f))
+ (not (symbol? (cadr f)))
+ (pair? (cddr f)))
+ (let ((last-expr (list-ref (cddr f) (- (length f) 3))))
+ (if (side-effect? last-expr env)
+ (if (pair? last-expr)
+ (check-returns caller last-expr env))
+ (lint-format "this is pointless~A: ~A in ~A" caller
+ (local-line-number last-expr)
+ (truncated-list->string last-expr)
+ (truncated-list->string f))))))
+
+ ((letrec letrec* with-let unless when begin with-baffle)
+ (if (and (pair? (cdr f))
+ (pair? (cddr f)))
+ (let ((last-expr (list-ref (cddr f) (- (length f) 3))))
+ (if (side-effect? last-expr env)
+ (if (pair? last-expr)
+ (check-returns caller last-expr env))
+ (lint-format "this is pointless~A: ~A in ~A" caller
+ (local-line-number last-expr)
+ (truncated-list->string last-expr)
+ (truncated-list->string f))))))
+ ((do)
+ (let ((returned (if (and (pair? (cdr f))
+ (pair? (cddr f)))
+ (let ((end+res (caddr f)))
+ (if (pair? (cdr end+res))
+ (list-ref (cdr end+res) (- (length end+res) 2)))))))
+ (if (or (eq? returned #<unspecified>)
+ (and (pair? returned)
+ (side-effect? returned env)))
+ (if (pair? returned)
+ (check-returns caller returned env))
+ (lint-format "~A: result ~A~A is not used" caller
+ (truncated-list->string f)
+ (truncated-list->string returned)
+ (local-line-number returned)))))
+ ((call-with-exit)
+ (if (and (pair? (cdr f))
+ (pair? (cadr f))
+ (eq? (caadr f) 'lambda)
+ (pair? (cdadr f))
+ (pair? (cadadr f)))
+ (let ((return (car (cadadr f))))
+ (let walk ((tree (cddadr f)))
+ (if (pair? tree)
+ (if (eq? (car tree) return)
+ (if (and (pair? (cdr tree))
+ (or (not (boolean? (cadr tree)))
+ (pair? (cddr tree))))
+ (lint-format "th~A call-with-exit return value~A will be ignored: ~A" caller
+ (if (pair? (cddr tree))
+ (values "ese" "s")
+ (values "is" ""))
+ tree))
+ (for-each walk tree)))))))
+
+ ((map)
+ (if (pair? (cdr f))
+ (lint-format "map could be for-each: ~A" caller (truncated-list->string `(for-each ,@(cdr f))))))
+
+ ((reverse!)
+ (if (pair? (cdr f))
+ (lint-format "~A might leave ~A in an undefined state; perhaps ~A" caller (car f) (cadr f)
+ `(set! ,(cadr f) ,f))))
+
+ ((format)
+ (if (and (pair? (cdr f))
+ (eq? (cadr f) #t))
+ (lint-format "perhaps use () with format since the string value is discarded:~% ~A"
+ caller `(format () ,@(cddr f)))))))))
+
+ (define lint-current-form #f)
+ (define lint-mid-form #f)
+
+ (define (escape? form env)
+ (and (pair? form)
+ (let ((v (var-member (car form) env)))
+ (if (var? v)
+ (memq (var-definer v) '(call/cc call-with-current-continuation call-with-exit))
+ (memq (car form) '(error throw))))))
+
+ (define (lint-walk-body caller head body env)
+
+ (when (and (pair? body) ; define->named let, but this is only ok in a "closed" situation, not (begin (define...)) for example
+ (pair? (car body))
+ (not (eq? last-rewritten-internal-define (car body))) ; we already rewrote this
+ (pair? (cdr body))
+ (pair? (cadr body))
+ (memq (caar body) '(define define*))
+ (pair? (cdar body))
+ (pair? (cadar body)))
+ (let ((fname (caadar body))
+ (fargs (cdadar body))
+ (fbody (cddar body)))
+ (when (and (symbol? fname)
+ (proper-list? fargs)
+ (= (tree-count1 fname (cdr body) 0) 1)
+ (not (any? keyword? fargs)))
+ (let ((call (find-call fname (cdr body))))
+ (when (pair? call)
+ (let ((new-args (if (eq? (caar body) 'define)
+ (map list fargs (cdr call))
+ (let loop ((pars fargs)
+ (vals (cdr call))
+ (args ()))
+ (if (null? pars)
+ (reverse args)
+ (loop (cdr pars)
+ (if (pair? vals)
+ (values (cdr vals)
+ (cons (list (if (pair? (car pars)) (caar pars) (car pars)) (car vals)) args))
+ (values ()
+ (cons (if (pair? (car pars)) (car pars) (list (car pars) #f)) args))))))))
+ (new-let (if (eq? (caar body) 'define) 'let 'let*)))
+ (if (and (pair? fbody)
+ (pair? (cdr fbody))
+ (string? (car fbody)))
+ (set! fbody (cdr fbody)))
+ (lint-format "perhaps ~A" caller
+ (lists->string `(... , at body)
+ (if (= (tree-count2 fname body 0) 2)
+ (if (null? fargs)
+ (if (null? (cdr fbody))
+ `(... ,@(tree-subst (car fbody) call (cdr body)))
+ `(... ,@(tree-subst `(let () , at fbody) call (cdr body))))
+ `(... ,@(tree-subst `(let ,new-args , at fbody) call (cdr body))))
+ `(... ,@(tree-subst `(,new-let ,fname ,new-args , at fbody) call (cdr body))))))))))))
+
+ ;; definer as last in body is rare outside let-syntax, and tricky -- only one clear optimizable case found
+ (lint-walk-open-body caller head body env))
+
+ (define (lint-walk-open-body caller head body env)
+ ;; walk a body (a list of forms, the value of the last of which might be returned)
+
+ (if (not (proper-list? body))
+ (lint-format "stray dot? ~A" caller (truncated-list->string body))
+
+ (let ((prev-f #f)
+ (old-current-form lint-current-form)
+ (old-mid-form lint-mid-form)
+ (prev-len 0)
+ (f-len 0)
+ (repeats 0)
+ (start-repeats body)
+ (repeat-arg 0)
+ (dpy-f #f)
+ (dpy-start #f)
+ (len (length body)))
+ (if (eq? head 'do) (set! len (+ len 1))) ; last form in do body is not returned
+
+ (when (and (pair? body)
+ *report-function-stuff*
+ (not (null? (cdr body))))
+ (function-match caller body env))
+
+ (do ((fs body (cdr fs))
+ (ctr 0 (+ ctr 1)))
+ ((not (pair? fs)))
+ (let ((f (car fs)))
+
+ (when (and (pair? prev-f) ; (if A ...) (if A ...) -> (when A ...) or equivalents
+ (pair? f)
+ (eq? (car f) 'if)
+ (eq? (car prev-f) 'if)
+ (pair? (cdr f))
+ (pair? (cdr prev-f)))
+ ;; cond/case occasionally are repeated, but almost never in a way we can combine
+
+ (define (tree-change-member set tree)
+ (and (pair? tree)
+ (not (eq? (car tree) 'quote))
+ (or (and (eq? (car tree) 'set!)
+ (memq (cadr tree) set))
+ (tree-change-member set (car tree))
+ (tree-change-member set (cdr tree)))))
+
+ (if (and (equal? (cadr f) (cadr prev-f))
+ (not (side-effect? (cadr f) env))
+ (not (tree-change-member (gather-symbols (cadr prev-f)) (cddr prev-f))))
+ (lint-format "perhaps ~A" caller
+ (lists->string `(... ,prev-f ,f ...)
+ (if (and (null? (cdddr prev-f))
+ (null? (cdddr f)))
+ (if (and (pair? (cadr f))
+ (eq? (caadr f) 'not))
+ `(... (unless ,(cadadr f)
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f))) ...)
+ `(... (when ,(cadr f)
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f))) ...))
+ `(... (if ,(cadr f)
+ (begin
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f)))
+ (begin
+ ,@(if (pair? (cdddr prev-f)) (unbegin (cadddr prev-f)) ())
+ ,@(if (pair? (cdddr f)) (unbegin (cadddr f)) ())))
+ ...))))
+ (if (and (pair? (cadr f)) ; (if A B C) (if (and D A) F) -> (if A (begin B (if D F)) C)
+ (eq? (caadr f) 'and)
+ (member (cadr prev-f) (cdadr f))
+ (not (side-effect? (cadr f) env))
+ (not (tree-change-member (gather-symbols (cadr prev-f)) (cddr prev-f))))
+ (lint-format "perhaps ~A" caller
+ (let ((new-test (remove (cadr prev-f) (cadr f))))
+ (lists->string `(... ,prev-f ,f ...)
+ `(... (if ,(cadr prev-f)
+ (begin
+ ,(caddr prev-f)
+ (if ,(if (pair? (cddr new-test))
+ new-test
+ (cadr new-test))
+ ,@(cddr f)))
+ ,@(cdddr prev-f)) ...)))))))
+ ;; --------
+ ;; check for repeated calls, but only one arg currently can change (more args = confusing separation in code)
+ (let ((feq (and (pair? prev-f)
+ (pair? f)
+ (eq? (car f) (car prev-f))
+ (or (equal? (cdr f) (cdr prev-f))
+ (do ((fp (cdr f) (cdr fp))
+ (pp (cdr prev-f) (cdr pp))
+ (i 1 (+ i 1)))
+ ((or (and (null? pp)
+ (null? fp))
+ (not (pair? pp))
+ (not (pair? fp))
+ (if (= i repeat-arg) ; ignore the arg that's known to be changing
+ (side-effect? (car pp) env)
+ (and (not (equal? (car pp) (car fp)))
+ (or (positive? repeat-arg)
+ (and (set! repeat-arg i) ; call this one the changer
+ #f)))))
+ (and (null? pp)
+ (null? fp))))))))
+ (if feq
+ (set! repeats (+ repeats 1)))
+ (when (or (not feq)
+ (= ctr (- len 1))) ; this assumes we're not returning the last value?
+ (when (and (> repeats 2)
+ (not (hash-table-ref syntaces (car prev-f)))) ; macros should be ok here if args are constants
+ (let ((fs-end (if (not feq) fs (cdr fs))))
+
+ (if (zero? repeat-arg) ; simple case -- all exprs are identical
+ (let ((step 'i))
+ (if (tree-member step prev-f)
+ (set! step (find-unique-name prev-f #f)))
+ (lint-format "perhaps ~A... ->~%~NC(do ((~A 0 (+ ~A 1))) ((= ~A ~D)) ~A)" caller
+ (truncated-list->string prev-f)
+ pp-left-margin #\space
+ step step step (+ repeats 1)
+ prev-f))
+
+ (let ((args ())
+ (constants? #t)
+ (func-name (car prev-f))
+ (new-arg (if (tree-member 'arg prev-f)
+ (find-unique-name prev-f #f)
+ 'arg)))
+ (do ((p start-repeats (cdr p)))
+ ((eq? p fs-end))
+ (set! args (cons (list-ref (car p) repeat-arg) args))
+ (set! constants? (and constants? (code-constant? (car args)))))
+
+ (let ((func (if (and (= repeat-arg 1)
+ (null? (cddar start-repeats)))
+ func-name
+ `(lambda (,new-arg)
+ ,(let ((call (copy prev-f)))
+ (list-set! call repeat-arg new-arg)
+ call)))))
+ (if constants?
+ (lint-format "perhaps ~A... ->~%~NC(for-each ~S '(~{~S~^ ~}))" caller
+ (truncated-list->string (car start-repeats))
+ pp-left-margin #\space
+ func
+ (map unquoted (reverse args)))
+ (let ((v (var-member func-name env)))
+ (if (or (and (var? v)
+ (memq (var-ftype v) '(define define* lambda lambda*)))
+ (procedure? (symbol->value func-name *e*)))
+ (lint-format "perhaps ~A... ->~%~NC(for-each ~S (vector ~{~S~^ ~}))" caller
+ ;; vector rather than list because it is easier on the GC (list copies in s7)
+ (truncated-list->string (car start-repeats))
+ pp-left-margin #\space
+ func
+ (reverse args))
+ (if (not (or (var? v)
+ (macro? (symbol->value func-name *e*))))
+ (lint-format "assuming ~A is not a macro, perhaps ~A" caller
+ func-name
+ (lists->string (list '... (car start-repeats) '...)
+ `(for-each ,func (vector ,@(reverse args))))))))))))))
+ (set! repeats 0)
+ (set! repeat-arg 0)
+ (set! start-repeats fs)))
+ ;; --------
+
+ (if (pair? f)
+ (begin
+ (set! f-len (length f))
+ (if (eq? (car f) 'begin)
+ (lint-format "redundant begin: ~A" caller (truncated-list->string f))))
+ (begin
+ (set-ref f caller f env)
+ (set! f-len 0)))
+
+ (when (and (= f-len prev-len 3)
(eq? (car f) 'set!)
- (eq? (car prev-f) 'set!)
- (eq? (cadr f) (cadr prev-f)))
- (let ((arg1 (caddr prev-f))
- (arg2 (caddr f)))
- (if (or (not (pair? arg2))
- (not (tree-member (cadr f) arg2)))
- (if (and (not (side-effect? arg1 env))
- (not (side-effect? arg2 env)))
- (lint-format "this could be omitted: ~A" name prev-f))
- (if (and (pair? arg1)
- (pair? arg2)
- (eq? (car arg1) 'cons)
- (eq? (car arg2) 'cons)
- (eq? (cadr f) (caddr arg2))
- (not (eq? (cadr f) (cadr arg2))))
- (lint-format "perhaps ~A ~A -> ~A" name
- prev-f f
- `(set! ,(cadr f) (cons ,(cadr arg2) (cons ,@(cdr arg1)))))))))
-
- (let ((repeated-if (and (= f-len prev-len 3)
- (eq? (car f) 'if)
- (eq? (car prev-f) 'if)
- (equal? (cadr f) (cadr prev-f))))
- (combine #f))
- (if (not repeated-if)
- (if block-fs
- (if (not (eq? (cdr block-fs) prev-fs))
- (set! combine prev-f)
- (set! block-fs #f)))
- (if block-fs
- (set! combine (and (null? (cdr fs)) f))
- (set! block-fs prev-fs)))
+ (eq? (car prev-f) 'set!))
+ (let ((arg1 (caddr prev-f))
+ (arg2 (caddr f)))
+ (if (eq? (cadr f) (cadr prev-f))
+ (cond ((not (and (pair? arg2) ; (set! x 0) (set! x 1) -> "this could be omitted: (set! x 0)"
+ (tree-unquoted-member (cadr f) arg2)))
+ (if (not (or (side-effect? arg1 env)
+ (side-effect? arg2 env)))
+ (lint-format "this could be omitted: ~A" caller prev-f)))
+
+ ((and (pair? arg1) ; (set! x (cons 1 z)) (set! x (cons 2 x)) -> (set! x (cons 2 (cons 1 z)))
+ (pair? arg2)
+ (eq? (car arg1) 'cons)
+ (eq? (car arg2) 'cons)
+ (eq? (cadr f) (caddr arg2))
+ (not (eq? (cadr f) (cadr arg2))))
+ (lint-format "perhaps ~A ~A -> ~A" caller
+ prev-f f
+ `(set! ,(cadr f) (cons ,(cadr arg2) (cons ,@(cdr arg1))))))
+
+ ((and (= (tree-count1 (cadr f) arg2 0) 1) ; (set! x y) (set! x (+ x 1)) -> (set! x (+ y 1))
+ (or (not (pair? arg1))
+ (< (tree-leaves arg1) 5)))
+ (lint-format "perhaps ~A ~A ->~%~NC~A" caller
+ prev-f f pp-left-margin #\space
+ (object->string `(set! ,(cadr f) ,(tree-subst arg1 (cadr f) arg2))))))
+
+ (if (and (symbol? (cadr prev-f)) ; (set! x (A)) (set! y (A)) -> (set! x (A)) (set! y x)
+ (pair? arg1) ; maybe more trouble than it's worth
+ (equal? arg1 arg2)
+ (not (eq? (car arg1) 'quote))
+ (hash-table-ref no-side-effect-functions (car arg1))
+ (not (tree-unquoted-member (cadr prev-f) arg1))
+ (not (side-effect? arg1 env))
+ (not (maker? arg1)))
+ (lint-format "perhaps ~A" caller (lists->string f `(set! ,(cadr f) ,(cadr prev-f))))))))
+
+ (if (< ctr (- len 1))
+ (begin ; f is not the last form, so its value is ignored
+ (if (and (escape? f env)
+ (pair? (cdr fs)) ; do special case
+ (every? (lambda (arg)
+ (not (and (symbol? arg)
+ (let ((v (var-member arg env)))
+ (and (var? v)
+ (eq? (var-initial-value v) :call/cc))))))
+ (cdr f)))
+ (if (= ctr (- len 2))
+ (lint-format "~A make this pointless: ~A" caller
+ (truncated-list->string f)
+ (truncated-list->string (cadr fs)))
+ (lint-format "~A makes the rest of the body unreachable: ~A" caller
+ (truncated-list->string f)
+ (truncated-list->string (list '... (cadr fs) '...)))))
+
+ (check-returns caller f env))
- (when combine
- (if (not (side-effect? (caadr block-fs) env))
- (lint-format "perhaps combine repeated if's: ~A ... ~A -> (when ~A ~A ... ~A)" name
- (car block-fs) combine
- (cadr combine) (caddar block-fs) (caddr combine)))
- (set! block-fs #f)))
-
- (if (< ctr (- len 1))
- ;; f is not the last form, so its value is ignored
- (begin
- (if (and (pair? f)
- (eq? (car f) 'map))
- (lint-format "map could be for-each: ~A" name (truncated-list->string f)))
- (if (not (side-effect? f env))
- (lint-format "this could be omitted: ~A" name (truncated-list->string f))))
+ ;; here f is the last form in the body
+ (when (and (pair? prev-f)
+ (pair? (cdr prev-f)))
+
+ (case (car prev-f)
+ ((display write write-char write-byte)
+ (if (and (equal? f (cadr prev-f))
+ (not (side-effect? f env)))
+ (lint-format "~A returns its first argument, so this could be omitted: ~A" caller
+ (car prev-f) (truncated-list->string f))))
- ;; here f is the last form in the body
- (when (and (pair? prev-f)
- (pair? (cdr prev-f))
- (pair? (cddr prev-f))) ; (set! ((L 1) 2)) an error, but lint should keep going
- (if (and (eq? (car prev-f) 'set!)
- (or (and (equal? (caddr prev-f) f) ; (begin ... (set! x (...)) (...))
- (not (side-effect? f env)))
- (and (symbol? f) ; (begin ... (set! x ...) x)
- (eq? f (cadr prev-f)))))
- (lint-format "this could be omitted: ~A" name (truncated-list->string f)))
- (if (and (pair? f)
- (pair? (cdr f))
- (pair? (cddr f))
- (eq? (cadr prev-f) (cadr f))
- (or (and (eq? (car prev-f) 'vector-set!)
- (eq? (car f) 'vector-ref))
- (and (eq? (car prev-f) 'list-set!)
- (eq? (car f) 'list-ref)))
- (equal? (caddr f) (caddr prev-f))
- (pair? (cdddr prev-f))
- (not (pair? (cddddr prev-f)))
- (not (pair? (cdddr f)))
- (not (side-effect? (caddr f) env)))
- (lint-format "this could be omitted: ~A" name (truncated-list->string f)))))
-
- (let ((dpy-case (and (pair? f)
- (memq (car f) '(display write newline write-char write-string))))) ; flush-output-port?
- (define (out-port expr) ; ()=not specified (*stdout*), #f=something is wrong (not enough args)
- (if (eq? (car expr) 'newline)
- (if (pair? (cdr expr))
- (cadr expr)
- ())
- (and (pair? (cdr expr))
- (if (pair? (cddr expr))
- (caddr expr)
- ()))))
- (when (and dpy-case
- (not dpy-start))
- (set! dpy-f fs)
- (set! dpy-start ctr))
- ;(format *stderr* "~A ~A ~A ~A~%" f ctr dpy-start len)
- (when (and dpy-start
- (> (- ctr dpy-start) (if dpy-case 1 2))
- (or (= ctr (- len 1))
- (not dpy-case)))
- ;; display sequence starts at dpy-start, goes to ctr (prev-f) unless not dpy-case
- (let ((ctrl-string "")
- (args ())
- (dctr 0)
- (dpy-last (if (not dpy-case) prev-f f))
- (op (out-port (car dpy-f)))
- (exprs (make-list (if dpy-case (- ctr dpy-start -1) (- ctr dpy-start)) ())))
- ;(format *stderr* "~A: ~A ~A ~A ~A~%" body dpy-case dpy-start ctr dpy-last)
- (call-with-exit
- (lambda (done)
- (for-each
- (lambda (d)
- (if (not (equal? (out-port d) op))
- (begin
- (lint-format "unexpected port change: ~A -> ~A in ~A~%" name op (out-port d) d) ; ??
- (done)))
- (list-set! exprs dctr d)
- (set! dctr (+ dctr 1))
- (case (car d)
- ((display)
- (if (string? (cadr d))
- (set! ctrl-string (string-append ctrl-string (cadr d)))
- (begin
- (set! ctrl-string (string-append ctrl-string "~A"))
- (set! args (cons (cadr d) args)))))
- ((write)
- (if (string? (cadr d))
- (set! ctrl-string (string-append ctrl-string "\"" (cadr d) "\""))
- (begin
- (set! ctrl-string (string-append ctrl-string "~S"))
- (set! args (cons (cadr d) args)))))
- ((write-char)
- (if (char? (cadr d))
- (set! ctrl-string (string-append ctrl-string (string (cadr d))))
- (begin
- (set! ctrl-string (string-append ctrl-string "~C"))
- (set! args (cons (cadr d) args)))))
- ((write-string) ; same as display but with possible start|end indices
- (let ((indices (and (pair? (cddr d)) ; port
- (pair? (cdddr d))
- (cdddr d))))
- (if (string? (cadr d))
- (if indices
- (if (and (integer? (car indices))
- (or (null? (cdr indices))
- (and (pair? indices)
- (integer? (cadr indices)))))
- (set! ctrl-string (string-append ctrl-string (apply substring (cadr d) indices)))
- (begin
- (set! ctrl-string (string-append ctrl-string "~A"))
- (set! args (cons `(substring ,(cadr d) , at indices) args))))
- (set! ctrl-string (string-append ctrl-string (cadr d))))
- (begin
- (set! ctrl-string (string-append ctrl-string "~A"))
- (if indices
- (set! args (cons `(substring ,(cadr d) , at indices) args))
- (set! args (cons (cadr d) args)))))))
- ((newline)
- (set! ctrl-string (string-append ctrl-string "~%"))))
-
- (when (eq? d dpy-last) ; op can be null => send to (current-output-port), return #f or #<unspecified>
- (lint-format "perhaps ~A" name (lists->string exprs `(format ,op ,ctrl-string ,@(reverse args))))
- (done)))
- dpy-f))))
- (set! dpy-start #f))
- (unless dpy-case (set! dpy-start #f)))
+ ((vector-set! float-vector-set! int-vector-set! byte-vector-set!
+ string-set! list-set! hash-table-set! let-set! set-car! set-cdr!)
+ (if (equal? f (list-ref prev-f (- (length prev-f) 1)))
+ (lint-format "~A returns the new value, so this could be omitted: ~A" caller
+ (car prev-f) (truncated-list->string f)))
+ (if (and (pair? f)
+ (pair? (cdr f))
+ (eq? (cadr prev-f) (cadr f))
+ (not (code-constant? (cadr f)))
+ (case (car prev-f)
+ ((vector-set! float-vector-set! int-vector-set!)
+ (memq (car f) '(vector-ref float-vector-ref int-vector-ref)))
+ ((list-set!)
+ (eq? (car f) 'list-ref))
+ ((string-set!)
+ (eq? (car f) 'string-ref))
+ ((set-car!)
+ (eq? (car f) 'car))
+ ((set-cdr!)
+ (eq? (car f) 'cdr))
+ (else #f))
+ (or (memq (car f) '(car cdr)) ; no indices
+ (and (pair? (cddr f)) ; for the others check that indices match
+ (equal? (caddr f) (caddr prev-f))
+ (pair? (cdddr prev-f))
+ (not (pair? (cddddr prev-f)))
+ (not (pair? (cdddr f)))
+ (not (side-effect? (caddr f) env)))))
+ (lint-format "~A returns the new value, so this could be omitted: ~A" caller
+ (car prev-f) (truncated-list->string f))))
+
+ ((copy)
+ (if (or (and (null? (cddr prev-f))
+ (equal? (cadr prev-f) f))
+ (and (pair? (cddr prev-f))
+ (null? (cdddr prev-f))
+ (equal? (caddr prev-f) f)))
+ (lint-format "~A returns the new value, so ~A could be omitted" caller
+ (truncated-list->string prev-f)
+ (truncated-list->string f))))
+
+ ((set! define define* define-macro define-constant define-macro*
+ defmacro defmacro* define-expansion define-bacro define-bacro*)
+ (when (and (pair? (cddr prev-f)) ; (set! ((L 1) 2)) an error, but lint should keep going
+ (or (and (equal? (caddr prev-f) f) ; (begin ... (set! x (...)) (...))
+ (not (side-effect? f env)))
+ (and (symbol? f) ; (begin ... (set! x ...) x)
+ (eq? f (cadr prev-f))) ; also (begin ... (define x ...) x)
+ (and (not (eq? (car prev-f) 'set!))
+ (pair? (cadr prev-f)) ; (begin ... (define (x...)...) x)
+ (eq? f (caadr prev-f)))))
+ (lint-format "~A returns the new value, so this could be omitted: ~A" caller
+ (car prev-f) (truncated-list->string f)))))))
+
+ ;; needs f fs prev-f dpy-f dpy-start ctr len
+ ;; trap lint-format
+ (let ((dpy-case (and (pair? f)
+ (memq (car f) '(display write newline write-char write-string))))) ; flush-output-port?
+ (when (and dpy-case
+ (not dpy-start))
+ (set! dpy-f fs)
+ (set! dpy-start ctr))
+ (when (and dpy-start
+ (> (- ctr dpy-start) (if dpy-case 1 2))
+ (or (= ctr (- len 1))
+ (not dpy-case)))
+ ;; display sequence starts at dpy-start, goes to ctr (prev-f) unless not dpy-case
+ (let ((ctrl-string "")
+ (args ())
+ (dctr 0)
+ (dpy-last (if (not dpy-case) prev-f f))
+ (op (write-port (car dpy-f)))
+ (exprs (make-list (if dpy-case (- ctr dpy-start -1) (- ctr dpy-start)) ())))
+
+ (define* (gather-format str (arg :unset))
+ (set! ctrl-string (string-append ctrl-string str))
+ (unless (eq? arg :unset) (set! args (cons arg args))))
+
+ (call-with-exit
+ (lambda (done)
+ (for-each
+ (lambda (d)
+ (if (not (equal? (write-port d) op))
+ (begin
+ (lint-format "unexpected port change: ~A -> ~A in ~A" caller op (write-port d) d) ; ??
+ (done)))
+ (list-set! exprs dctr d)
+ (set! dctr (+ dctr 1))
+ (gather-format (display->format d))
+ (when (eq? d dpy-last) ; op can be null => send to (current-output-port), return #f or #<unspecified>
+ (lint-format "perhaps ~A" caller (lists->string `(... , at exprs)
+ `(format ,op ,ctrl-string ,@(reverse args))))
+ (done)))
+ dpy-f))))
+ (set! dpy-start #f))
+ (unless dpy-case (set! dpy-start #f)))
+
+ (if (and (pair? f)
+ (memq head '(defmacro defmacro* define-macro define-macro* define-bacro define-bacro*))
+ (tree-member 'unquote f))
+ (lint-format "~A probably has too many unquotes: ~A" caller head (truncated-list->string f)))
+
+ (set! prev-f f)
+ (set! prev-len f-len)
+
+ (set! lint-current-form f)
+ (if (= ctr (- len 1))
+ (set! env (lint-walk caller f env))
+ (begin
+ (set! lint-mid-form f)
+ (let ((e (lint-walk caller f env)))
+ (if (and (pair? e)
+ (not (eq? (var-name (car e)) :lambda)))
+ (set! env e)))))
+ (set! lint-current-form #f)
+ (set! lint-mid-form #f)
+
+ ;; need to put off this ref tick until we have a var for it (lint-walk above)
+ (when (and (= ctr (- len 1))
+ (pair? f)
+ (pair? (cdr f)))
+ (if (and (pair? (cadr f))
+ (memq (car f) '(define define* define-macro define-constant define-macro* define-expansion define-bacro define-bacro*)))
+ (set-ref (caadr f) caller #f env)
+ (if (memq (car f) '(defmacro defmacro*))
+ (set-ref (cadr f) caller #f env))))
+ ))
+ (set! lint-mid-form old-mid-form)
+ (set! lint-current-form old-current-form)))
+ env)
+
+
+ (define (lint-walk-function-body definer function-name args body env)
+ ;; walk function body, with possible doc string at the start
+ (when (and (pair? body)
+ (pair? (cdr body))
+ (string? (car body)))
+ (if *report-doc-strings*
+ (lint-format "old-style doc string: ~S, in s7 use 'documentation:~%~NC~A" function-name
+ (car body) (+ lint-left-margin 4) #\space
+ (lint-pp `(define ,function-name
+ (let ((documentation ,(car body)))
+ (,(if (eq? definer 'define) 'lambda
+ (if (eq? definer 'define*) 'lambda*
+ definer))
+ ,args
+ ,@(cdr body)))))))
+ (set! body (cdr body))) ; ignore old-style doc-string
+ (lint-walk-body function-name definer body env))
+
+ (define (lint-walk-function definer function-name args body form env)
+ ;; check out function arguments (adding them to the current env), then walk its body
+ ;; first check for (define (hi...) (ho...)) where ho has no opt args (and try to ignore possible string constant doc string)
+
+ (when (eq? definer 'define)
+ (let ((bval (if (and (pair? body)
+ (string? (car body)))
+ (cdr body) ; strip away the (old-style) documentation string
+ body)))
+
+ (when (and (pair? bval) ; not (define (hi a) . 1)!
+ (pair? (car bval))
+ (null? (cdr bval))
+ (symbol? (caar bval))) ; not (define (hi) ((if #f + abs) 0))
+
+ (cond ((equal? args (cdar bval))
+ (let* ((cval (caar bval))
+ (p (symbol->value cval *e*))
+ (ary (arity p)))
+ (if (or (procedure? p)
+ (let ((e (var-member cval env) ))
+ (and e
+ (var? e)
+ (symbol? (var-ftype e))
+ (let ((def (var-initial-value e))
+ (e-args (var-arglist e)))
+ (and
+ (pair? def)
+ (memq (var-ftype e) '(define lambda))
+ (or (and (null? args)
+ (null? e-args))
+ (and (symbol? args)
+ (symbol? e-args))
+ (and (pair? args)
+ (pair? e-args)
+ (= (length args) (length e-args)))))))))
+ (lint-format "~A~A could be (define ~A ~A)" function-name
+ (if (and (procedure? p)
+ (not (= (car ary) (cdr ary)))
+ (not (= (length args) (cdr ary))))
+ (format #f "leaving aside ~A's optional arg~P, " cval (- (cdr ary) (length args)))
+ "")
+ function-name function-name cval))))
+
+ ;; (equal? args (reverse (cdar bval))) rarely happens, and never with a reversible op
- (if (and (pair? f)
- (memq head '(defmacro defmacro* define-macro define-macro* define-bacro define-bacro*))
- (tree-member 'unquote f))
- (lint-format "~A probably has too many unquotes: ~A" name head (truncated-list->string f)))
+ ((and (or (symbol? args)
+ (and (pair? args)
+ (negative? (length args))))
+ (eq? (caar bval) 'apply)
+ (pair? (cdar bval))
+ (symbol? (cadar bval))
+ (not (memq (cadar bval) '(and or)))
+ (pair? (cddar bval))
+ (or (and (eq? args (caddar bval))
+ (null? (cdddar bval)))
+ (and (pair? args)
+ (equal? (cddar bval) (proper-list args)))))
+ (lint-format "~A could be (define ~A ~A)" function-name function-name function-name (cadar bval)))
- (set! prev-f f)
- (set! prev-fs fs)
- (set! prev-len f-len)
- (set! env (lint-walk name f env))))))
- env)
-
-
- (define (lint-walk-function-body name head args arg-data body env)
- ;; walk function body, with possible doc string at the start
- (when (and (pair? body)
- (pair? (cdr body))
- (string? (car body)))
- (if *report-doc-strings*
- (lint-format "old-style doc string: ~S~%" name (car body)))
- (set! body (cdr body))) ; ignore old-style doc-string
- (lint-walk-body name head body env)
- env)
-
+ ((and (memq (caar bval) '(car cdr caar cadr cddr cdar caaar caadr caddr cdddr cdaar cddar cadar cdadr cadddr cddddr))
+ (pair? (cadar bval)))
+ ((lambda* (cr arg)
+ (and cr
+ (< (length cr) 5)
+ (pair? args)
+ (null? (cdr args))
+ (eq? (car args) arg)
+ (let ((f (string->symbol (string-append "c" cr "r"))))
+ (if (eq? f function-name)
+ (lint-format "this redefinition of ~A is pointless (use (with-let (unlet)...) or #_~A)" definer function-name function-name)
+ (lint-format "~A could be (define ~A ~A)" function-name function-name function-name f)))))
+ (combine-cxrs (car bval))))
+
+ ((not (and (memq (caar bval) '(list-ref list-tail))
+ (pair? (cdar bval))
+ (pair? (cddar bval))
+ (pair? args)
+ (eq? (car args) (cadar bval))
+ (null? (cdr args)))))
+
+ ((eq? (caar bval) 'list-ref)
+ (case (caddar bval)
+ ((0) (lint-format "~A could be (define ~A car)" function-name function-name function-name))
+ ((1) (lint-format "~A could be (define ~A cadr)" function-name function-name function-name))
+ ((2) (lint-format "~A could be (define ~A caddr)" function-name function-name function-name))
+ ((3) (lint-format "~A could be (define ~A cadddr)" function-name function-name function-name))))
+
+ (else
+ (case (caddar bval)
+ ((1) (lint-format "~A could be (define ~A cdr)" function-name function-name function-name))
+ ((2) (lint-format "~A could be (define ~A cddr)" function-name function-name function-name))
+ ((3) (lint-format "~A could be (define ~A cdddr)" function-name function-name function-name))
+ ((4) (lint-format "~A could be (define ~A cddddr)" function-name function-name function-name))))))))
- (define (lint-walk-function head name args val form env)
- ;(format *stderr* "function: ~A ~A ~A ~A~%" head name args val)
-
- ;; check out function arguments (adding them to the current env), then walk its body, (name == function name, val == body)
- ;; first check for (define (hi...) (ho...)) where ho has no opt args (and try to ignore possible string constant doc string)
-
- (if (eq? head 'define)
- (let ((bval (if (and (pair? val)
- (string? (car val)))
- (cdr val) ; strip away the (old-style) documentation string
- val)))
- (if (and (pair? bval) ; not (define (hi a) . 1)!
- (pair? (car bval))
- (null? (cdr bval))
- (symbol? (caar bval))) ; not (define (hi) ((if #f + abs) 0))
- (if (equal? args (cdar bval))
- (let* ((cval (caar bval))
- (p (symbol->value cval *e*))
- (ary (arity p)))
- (if (or (and (procedure? p)
- (or (= (car ary) (cdr ary))
- (= (length args) (cdr ary))))
- (let ((e (or (var-member cval env)
- (hash-table-ref globals cval))))
- (and e
- (var? e)
- (let? (var-new e))
- (let ((def ((var-new e) 'definition))
- (e-args ((var-new e) 'arglist)))
- (and
- (pair? def)
- (eq? ((var-new e) 'type) 'define)
- (or (and (null? args)
- (null? e-args))
- (and (symbol? args)
- (symbol? e-args))
- (and (pair? args)
- (pair? e-args)
- (= (length args) (length e-args)))))))))
- (lint-format "~A could be (define ~A ~A)" name name name cval)))
- (if (and (eq? (caar bval) 'list-ref)
- (pair? (cdar bval))
- (pair? (cddar bval))
- (eq? (car args) (cadar bval))
- (null? (cdr args)))
- (case (caddar bval)
- ((0) (lint-format "~A could be (define ~A car)" name name name))
- ((1) (lint-format "~A could be (define ~A cadr)" name name name))
- ((2) (lint-format "~A could be (define ~A caddr)" name name name))
- ((3) (lint-format "~A could be (define ~A cadddr)" name name name))))))))
-
- (let ((ldata (and (symbol? name)
- (make-var (if (not (memq head '(lambda lambda*))) name '[anonymous])
- :new (inlet :type head
- :decl (catch #t
- (lambda ()
- (case head
- ((lambda)
- (eval (list head (cadr form) #f)))
- ((lambda*)
- (eval (list head (copy (cadr form)) #f))) ; eval can remove :allow-other-keys!
- ((define*)
- (eval (list head (cons '_ (copy (cdadr form))) #f)))
- ((defmacro defmacro*)
- (eval (list head '_ (caddr form) #f)))
- ((define-constant)
- (eval (list 'define (cons '_ (cdadr form)) #f)))
- (else
- (eval (list head (cons '_ (cdadr form)) #f)))))
- (lambda args
- 'error))
- :signature #f
- :side-effect #t
- :arglist (if (memq head '(defmacro defmacro*))
- (caddr form)
- (if (memq head '(lambda lambda*))
- (cadr form)
- (cdadr form)))
- :definition form
- :location #__line__)))))
-
- (if (null? args)
- (begin
- (if (memq head '(define* lambda* defmacro* define-macro* define-bacro*))
- (lint-format "~A could be ~A"
- name head
- (symbol (substring (symbol->string head) 0 (- (length (symbol->string head)) 1)))))
- (lint-walk-function-body name head args () val env)
- (if ldata
- (append (list ldata) env)
- env))
+ (let ((fvar (and (symbol? function-name)
+ (make-fvar :name (if (not (memq definer '(lambda lambda*))) function-name :lambda)
+ :ftype definer
+ :initial-value form
+ :env env
+ :arglist (if (memq definer '(lambda lambda*))
+ (cadr form)
+ (if (memq definer '(defmacro defmacro*))
+ (caddr form)
+ (cdadr form)))))))
+ (when fvar
+ (let ((fvar-let (cdr fvar)))
+ (set! (fvar-let 'decl)
+ (catch #t
+ (lambda ()
+ (case definer
+ ((lambda)
+ (set! (fvar-let 'allow-other-keys) #t)
+ (eval (list definer (cadr form) #f)))
+
+ ((lambda*)
+ (set! (fvar-let 'allow-other-keys) (eq? (last-par (cadr form)) :allow-other-keys))
+ (eval (list definer (copy (cadr form)) #f))) ; eval can remove :allow-other-keys!
+
+ ((define*)
+ (set! (fvar-let 'allow-other-keys) (eq? (last-par (cdadr form)) :allow-other-keys))
+ (eval (list definer (cons '_ (copy (cdadr form))) #f)))
+
+ ((defmacro defmacro*)
+ (set! (fvar-let 'allow-other-keys) (or (not (eq? definer 'defmacro*))
+ (eq? (last-par (caddr form)) :allow-other-keys)))
+ (eval (list definer '_ (caddr form) #f)))
+
+ ((define-constant)
+ (set! (fvar-let 'allow-other-keys) #t)
+ (eval (list 'define (cons '_ (cdadr form)) #f)))
+
+ (else
+ (set! (fvar-let 'allow-other-keys) (or (not (memq definer '(define-macro* define-bacro*)))
+ (eq? (last-par (cdadr form)) :allow-other-keys)))
+ (eval (list definer (cons '_ (cdadr form)) #f)))))
+ (lambda args
+ 'error)))))
+
+ (if (null? args)
+ (begin
+ (if (memq definer '(define* lambda* defmacro* define-macro* define-bacro*))
+ (lint-format "~A could be ~A"
+ function-name definer
+ (symbol (substring (symbol->string definer) 0 (- (length (symbol->string definer)) 1)))))
+ (let ((cur-env (if fvar (cons fvar env) env)))
+ (let* ((e (lint-walk-function-body definer function-name args body cur-env))
+ (nvars (and (not (eq? e cur-env))
+ (env-difference function-name e cur-env ()))))
+ (if (pair? nvars)
+ (report-usage function-name definer nvars cur-env)))
+ cur-env))
- (if (or (symbol? args)
- (pair? args))
- (let ((arg-data (if (symbol? args) ; this is getting arg names to add to the environment
- (list (make-var args))
- (map
- (lambda (arg)
- (if (symbol? arg)
- (if (memq arg '(:rest :allow-other-keys))
- (values) ; map omits this entry
- (make-var arg))
- (if (or (not (pair? arg))
- (not (= (length arg) 2))
- (not (memq head '(define* lambda* defmacro* define-macro* define-bacro* definstrument))))
- (begin
- (lint-format "strange parameter for ~A: ~S" name head arg)
- (values))
- (begin
- (if (not (cadr arg))
- (lint-format "the default argument value is #f in ~A ~A" name head arg))
- (make-var (car arg))))))
- (proper-list args)))))
+ (if (not (or (symbol? args)
+ (pair? args)))
+ (begin
+ (lint-format "strange ~A parameter list ~A" function-name definer args)
+ env)
+ (let ((args-as-vars (if (symbol? args) ; this is getting arg names to add to the environment
+ (list (make-var :name args :definer 'parameter))
+ (map
+ (lambda (arg)
+ (if (symbol? arg)
+ (if (memq arg '(:rest :allow-other-keys))
+ (values) ; omit :rest and :allow-other-keys
+ (make-var :name arg :definer 'parameter))
+ (if (not (and (pair? arg)
+ (= (length arg) 2)
+ (memq definer '(define* lambda* defmacro* define-macro* define-bacro* definstrument))))
+ (begin
+ (lint-format "strange parameter for ~A: ~S" function-name definer arg)
+ (values))
+ (begin
+ (if (not (cadr arg))
+ (lint-format "the default argument value is #f in ~A ~A" function-name definer arg))
+ (make-var :name (car arg) :definer 'parameter)))))
+ (proper-list args)))))
- (lint-walk-function-body name head args arg-data val (append arg-data (if ldata (append (list ldata) env) env)))
- (if *report-unused-parameters*
- (report-usage name 'parameter head arg-data))
- (if ldata
- (append (list ldata) env)
- env))
+ (let* ((cur-env (append args-as-vars (if fvar (cons fvar env) env)))
+ (e (lint-walk-function-body definer function-name args body cur-env))
+ (nvars (and (not (eq? e cur-env))
+ (env-difference function-name e cur-env ()))))
+ (report-usage function-name definer (append (or nvars ()) args-as-vars) cur-env))
+
+ (when (and (var? fvar)
+ (memq definer '(define lambda define-macro)))
+ ;; look for unused parameters that are passed a value other than #f
+ (let ((set ())
+ (unused ()))
+ (for-each
+ (lambda (arg-var)
+ (if (zero? (var-ref arg-var))
+ (if (positive? (var-set arg-var))
+ (set! set (cons (var-name arg-var) set))
+ (if (not (memq (var-name arg-var) '(documentation signature iterator?)))
+ (set! unused (cons (var-name arg-var) unused))))))
+ args-as-vars)
+ (when (or (pair? set)
+ (pair? unused))
+ (let ((proper-args (args->proper-list args)))
+ (let ((sig (var-signature fvar))
+ (len (+ (length proper-args) 1)))
+ (if (not sig)
+ (set! sig (make-list len #t))
+ (if (< (length sig) len)
+ (set! sig (copy sig (make-list len #t)))))
+ (let ((siglist (cdr sig)))
+ (for-each
+ (lambda (arg)
+ (if (memq arg unused)
+ (set-car! siglist 'unused-parameter?)
+ (if (memq arg set)
+ (set-car! siglist 'unused-set-parameter?)))
+ (set! siglist (cdr siglist)))
+ proper-args))
+ (set! (var-signature fvar) sig))))))
+ (if fvar
+ (cons fvar env)
+ env))))))
+
+
+ (define (check-bool-cond caller form c1 c2 env)
+ ;; (cond (x #f) (#t #t)) -> (not x)
+ ;; c1/c2 = possibly combined, so in (cond (x #t) (y #t) (else #f)), c1: ((or x y) #t), so -> (or x y)
+ (and (pair? c1)
+ (= (length c1) 2)
+ (pair? c2)
+ (pair? (cdr c2))
+ (memq (car c2) '(#t else))
+ (or (and (boolean? (cadr c1))
+ (or (and (null? (cddr c2))
+ (boolean? (cadr c2))
+ (not (equal? (cadr c1) (cadr c2))) ; handled elsewhere
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if (eq? (cadr c1) #t)
+ (car c1)
+ (simplify-boolean `(not ,(car c1)) () () env)))))
+ (and (not (cadr c1)) ; (cond (x #f) (else y)) -> (and (not x) y)
+ (let ((cc1 (simplify-boolean `(not ,(car c1)) () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cddr c2))
+ `(and ,cc1 ,(cadr c2))
+ `(and ,cc1 (begin ,@(cdr c2))))))))
+ (and (pair? (car c1)) ; (cond ((null? x) #t) (else y)) -> (or (null? x) y)
+ (eq? (return-type (caar c1) env) 'boolean?)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cddr c2))
+ `(or ,(car c1) ,(cadr c2))
+ `(or ,(car c1) (begin ,@(cdr c2)))))))))
+ (and (boolean? (cadr c2))
+ (null? (cddr c2))
+ (not (equal? (cadr c1) (cadr c2)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (cadr c2)
+ `(or (not ,(car c1)) ,(cadr c1))
+ (if (and (pair? (car c1))
+ (eq? (caar c1) 'and))
+ (append (car c1) (cdr c1))
+ `(and , at c1)))))))))
+
+ (define (case-branch test eqv-select exprs)
+ (case (car test)
+ ((eq? eqv? = equal? char=?)
+ (if (equal? eqv-select (cadr test))
+ `((,(unquoted (caddr test))) , at exprs)
+ `((,(unquoted (cadr test))) , at exprs)))
+
+ ((memq memv member)
+ `(,(unquoted (caddr test)) , at exprs))
+
+ ((not)
+ `((#f) , at exprs))
+
+ ((null?)
+ `((()) , at exprs))
+
+ ((eof-object?)
+ `((#<eof>) , at exprs))
+
+ ((zero?)
+ `((0 0.0) , at exprs))
+
+ ((boolean?)
+ `((#t #f) , at exprs))
+
+ ((char-ci=?)
+ (if (equal? eqv-select (cadr test))
+ `(,(list (caddr test) (other-case (caddr test))) , at exprs)
+ `(,(list (cadr test) (other-case (cadr test))) , at exprs)))
+
+ (else
+ `(,(map (lambda (p)
+ (case (car p)
+ ((eq? eqv? = equal? char=?)
+ (unquoted (if (equal? eqv-select (cadr p)) (caddr p) (cadr p))))
+ ((memq memv member) (apply values (caddr p)))
+ ((not) #f)
+ ((null?) ())
+ ((eof-object?) #<eof>)
+ ((zero?) (values 0 0.0))
+ ((boolean?) (values #t #f))
+ ((char-ci=?)
+ (if (equal? eqv-select (cadr p))
+ (values (caddr p) (other-case (caddr p)))
+ (values (cadr p) (other-case (cadr p)))))
+ (else (error "oops"))))
+ (cdr test))
+ , at exprs))))
+
+ (define (cond->case eqv-select new-clauses)
+ `(case ,eqv-select
+ ,@(map (lambda (clause)
+ (let ((test (car clause))
+ (exprs (cdr clause)))
+ (if (null? exprs) ; cond returns the test result if no explicit results
+ (set! exprs (list #t))) ; but all tests here return a boolean, and we win only if #t?? (memx is an exception)
+ (if (memq test '(else #t))
+ `(else , at exprs)
+ (case-branch test eqv-select exprs))))
+ new-clauses)))
+
+ (define (eqv-code-constant? x)
+ (or (number? x)
+ (char? x)
+ (and (pair? x)
+ (eq? (car x) 'quote)
+ (or (symbol? (cadr x))
+ (and (not (pair? (cadr x)))
+ (eqv-code-constant? (cadr x)))))
+ (memq x '(#t #f () #<unspecified> #<undefined> #<eof>))))
+
+ (define (cond-eqv? clause eqv-select or-ok)
+ (if (not (pair? clause))
+ (memq clause '(else #t))
+ ;; it's eqv-able either directly or via memq/memv, or via (or ... eqv-able clauses)
+ ;; all clauses involve the same (eventual case) selector
+ (case (car clause)
+ ((eq? eqv? = equal? char=? char-ci=?)
+ (if (eqv-code-constant? (cadr clause))
+ (equal? eqv-select (caddr clause))
+ (and (eqv-code-constant? (caddr clause))
+ (equal? eqv-select (cadr clause)))))
+
+ ((memq memv member)
+ (and (equal? eqv-select (cadr clause))
+ (pair? (caddr clause))
+ (eq? (caaddr clause) 'quote)
+ (or (not (eq? (car clause) 'member))
+ (every? (lambda (x)
+ (or (number? x)
+ (char? x)
+ (symbol? x)
+ (memq x '(#t #f () #<unspecified> #<undefined> #<eof>))))
+ (cdr (caddr clause))))))
+ ((or)
+ (and or-ok
+ (every? (lambda (p)
+ (cond-eqv? p eqv-select #f))
+ (cdr clause))))
+
+ ((not null? eof-object? zero? boolean?)
+ (equal? eqv-select (cadr clause)))
+
+ (else #f))))
+
+ (define (find-constant-exprs caller vars body)
+ (if (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion)
+ body)
+ ()
+ (let* ((vs (out-vars caller vars body))
+ (refs (remove-if (lambda (v)
+ (or (assq v vars) ; vars = do-loop steppers
+ (memq v (cadr vs)))) ; (cadr vs) = sets
+ (car vs)))
+ ;; refs are the external variables accessed in the do-loop body
+ ;; that are not set or shadowed or changed (vector-set! etc)
+ (constant-exprs ()))
+
+ (let expr-walk ((tree body))
+ (when (pair? tree)
+ (if (let all-ok? ((tree tree))
+ (if (symbol? tree)
+ (memq tree refs)
+ (or (not (pair? tree))
+ (eq? (car tree) 'quote)
+ (and (hash-table-ref no-side-effect-functions (car tree))
+ (or (not (hash-table-ref syntaces (car tree)))
+ (memq (car tree) '(if begin cond or and unless when)))
+ (not (memq (car tree) makers))
+ (list? (cdr tree))
+ (every? all-ok? (cdr tree))))))
+ (if (not (or (eq? (car tree) 'quote) (member tree constant-exprs)))
+ (set! constant-exprs (cons tree constant-exprs)))
+ (begin
+ (if (pair? (car tree))
+ (expr-walk (car tree)))
+ (when (pair? (cdr tree))
+ (let ((f (cdr tree)))
+ (case (car f)
+ ((case)
+ (when (and (pair? (cdr f))
+ (pair? (cddr f)))
+ (expr-walk (cadr f))
+ (for-each (lambda (c)
+ (expr-walk (cdr c)))
+ (cddr f))))
+ ((letrec letrec*)
+ (when (pair? (cddr f))
+ (for-each (lambda (c)
+ (if (and (pair? c)
+ (pair? (cdr c)))
+ (expr-walk (cadr c))))
+ (cadr f))
+ (expr-walk (cddr f))))
+ ((let let*)
+ (when (pair? (cddr f))
+ (if (symbol? (cadr f))
+ (set! f (cdr f)))
+ (for-each (lambda (c)
+ (if (and (pair? c)
+ (pair? (cdr c)))
+ (expr-walk (cadr c))))
+ (cadr f))
+ (expr-walk (cddr f))))
+ ((do)
+ (when (and (list? (cadr f))
+ (list? (cddr f))
+ (pair? (cdddr f)))
+ (for-each (lambda (c)
+ (if (pair? (cddr c))
+ (expr-walk (caddr c))))
+ (cadr f))
+ (expr-walk (cdddr f))))
+ (else (for-each expr-walk f)))))))))
+ (when (pair? constant-exprs)
+ (set! constant-exprs (remove-if (lambda (p)
+ (or (null? (cdr p))
+ (and (null? (cddr p))
+ (memq (car p) '(not -))
+ (symbol? (cadr p)))
+ (tree-unquoted-member 'port-line-number p)))
+ constant-exprs)))
+ constant-exprs)))
+
+ (define (find-let-constant-exprs caller form vars body)
+ (let ((zv (map (lambda (v)
+ (if (and (zero? (var-set v))
+ (not (tree-unquoted-member (var-name v) (var-initial-value v))))
+ v
+ (values)))
+ vars)))
+ (when (pair? zv)
+ (let ((constant-exprs (find-constant-exprs 'let (map (lambda (v)
+ (if (positive? (var-set v))
+ (var-name v)
+ (values)))
+ vars)
+ body)))
+ (when (pair? constant-exprs)
+ (let ((vals (map (lambda (v)
+ (cons (var-initial-value v) (var-name v)))
+ zv)))
+ (for-each (lambda (expr)
+ (cond ((or (assoc expr vals)
+ (and (pair? expr)
+ (hash-table-ref reversibles (car expr))
+ (= 3 (length expr))
+ (assoc (list (hash-table-ref reversibles (car expr)) (caddr expr) (cadr expr)) vals)))
+ => (lambda (ev)
+ (lint-format* caller
+ (string-append (object->string (car ev)) " is " (object->string (cdr ev)) " in ")
+ (truncated-list->string form))))))
+ constant-exprs)))))))
+
+ (define (find-call sym body)
+ (call-with-exit
+ (lambda (return)
+ (let tree-call ((tree body))
+ (if (and (pair? tree)
+ (not (eq? (car tree) 'quote)))
+ (begin
+ (if (eq? (car tree) sym)
+ (return tree))
+ (if (memq (car tree) '(let let* letrec letrec* do lambda lambda* define))
+ (return #f)) ; possible shadowing -- not worth the infinite effort to corroborate
+ (if (pair? (car tree))
+ (tree-call (car tree)))
+ (if (pair? (cdr tree))
+ (do ((p (cdr tree) (cdr p)))
+ ((not (pair? p)) #f)
+ (tree-call (car p))))))))))
+
+ (define (partition-form start len)
+ (let ((ps (make-vector len))
+ (qs (make-vector len)))
+ (do ((i 0 (+ i 1))
+ (p start (cdr p)))
+ ((= i len))
+ (set! (ps i) (cadar p))
+ (set! (qs i) (reverse (cadar p))))
+
+ (let* ((header-len (length (ps 0)))
+ (trailer-len header-len)
+ (result-min-len header-len))
+ (do ((i 1 (+ i 1)))
+ ((= i len))
+ (set! result-min-len (min result-min-len (length (ps i))))
+ (do ((k 1 (+ k 1))
+ (p (cdr (ps i)) (cdr p))
+ (f (cdr (ps 0)) (cdr f)))
+ ((or (= k header-len)
+ (not (pair? p))
+ (not (equal? (car p) (car f))))
+ (set! header-len k)))
+ (do ((k 0 (+ k 1))
+ (q (qs i) (cdr q))
+ (f (qs 0) (cdr f)))
+ ((or (= k trailer-len)
+ (not (pair? q))
+ (not (equal? (car q) (car f))))
+ (set! trailer-len k))))
+
+ (if (= result-min-len header-len)
+ (begin
+ (set! header-len (- header-len 1))
+ (set! trailer-len 0)))
+ (if (<= result-min-len (+ header-len trailer-len))
+ (set! trailer-len (- result-min-len header-len 1)))
+
+ (values header-len trailer-len result-min-len))))
+
+ (define (one-call-and-dots body) ; body is unchanged here, so it's not interesting
+ (if (null? (cdr body))
+ body
+ (list (car body) '...)))
+
+ (define (replace-redundant-named-let caller form outer-name outer-args inner)
+ (if (proper-list? outer-args) ; can be null
+ (let ((inner-name (cadr inner))
+ (inner-args (caddr inner))
+ (inner-body (cdddr inner)))
+ (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (pair? a))
+ (not (pair? (car a)))
+ (and (not (eq? (car p) (caar a)))
+ (tree-memq (car p) inner-body)))
+ ;; args can be reversed, but rarely match as symbols
+ (if (and (null? p)
+ (or (null? a)
+ (and (null? (cdr a))
+ (code-constant? (cadar a)))))
+ (let* ((args-match (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (eq? (car p) (caar a)))
+ (not (eq? (caar a) (cadar a))))
+ (null? p))))
+ (args-aligned (and (not args-match)
+ (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (eq? (car p) (cadar a))))
+ (null? p))))))
+ (if (or args-match args-aligned)
+ (let ((definer (if (null? a) 'define 'define*))
+ (extras (if (and (pair? a)
+ (quoted-null? (cadar a)))
+ (list (list (caar a) ()))
+ a)))
+ (lint-format "~A ~A" caller
+ (if (null? a) "perhaps" "a toss-up -- perhaps")
+ (lists->string form
+ `(,definer (,outer-name
+ ,@(if args-match
+ outer-args
+ (do ((result ())
+ (p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((null? p)
+ (reverse result))
+ (set! result (cons (caar a) result))))
+ , at extras)
+ ,@(tree-subst outer-name inner-name inner-body)))))))))))))
+
+ (define lint-walk
+ (let ((deprecated-ops '((global-environment . rootlet)
+ (current-environment . curlet)
+ (make-procedure-with-setter . dilambda)
+ (procedure-with-setter? . dilambda?)
+ (make-random-state . random-state)
+ ;;(make-rectangular . complex)
+ (data-format . sample-type)
+ (mus-sound-frames . mus-sound-framples)
+ (mus-sound-data-format . mus-sound-sample-type)
+ (mus-data-format-name . mus-sample-type-name)
+ (mus-data-format->string . mus-sample-type->string)))
+
+ (numeric-ops (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(+ * - /
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh
+ log exp expt sqrt make-polar complex
+ imag-part real-part abs magnitude angle max min exact->inexact
+ modulo remainder quotient lcm gcd
+ rationalize inexact->exact random
+ logior lognot logxor logand numerator denominator
+ floor round truncate ceiling ash))
+ h))
+
+ (binders (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(let let* letrec letrec* do
+ lambda lambda* define define*
+ call/cc call-with-current-continuation
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
+ load eval eval-string require))
+ h))
+
+ (lint-let-reduction-factor 3) ; maybe make this a global switch -- the higher this number, the fewer let-reduction suggestions
+ (selector-types '(#t symbol? char? boolean? integer? rational? real? complex? number? null? eof-object?)))
+
+ (lambda (caller form env)
+
+ ;; walk a form, here curlet can change
+ ;; (format *stderr* "lint-walk ~A~%" form)
+
+ (if (symbol? form)
+ (begin
+ (if (memq form '(+i -i))
+ (format outport "~NC~A is not a number in s7~%" lint-left-margin #\space form))
+ (set-ref form caller #f env)) ; returns env
+ (if (not (pair? form))
+ (begin
+ (if (vector? form)
+ (let ((happy #t))
+ (for-each
+ (lambda (x)
+ (when (and (pair? x)
+ (eq? (car x) 'unquote))
+ (lint-walk caller (cadr x) env) ; register refs
+ (set! happy #f)))
+ form)
+ (if (not happy) ; these are used exactly 4 times (in a test suite!) in 2 million lines of open source scheme code
+ (lint-format "quasiquoted vectors are not supported: ~A" caller form))))
+ env)
+ (let ((head (car form)))
+
+ (set! line-number (pair-line-number form))
+
+ (when *report-function-stuff*
+ (function-match caller form env))
- (begin
- (lint-format "strange ~A parameter list ~A" name head args)
- env)))))
-
-
- (define (lint-walk name form env)
- ;; walk a form
- ;(format *stderr* "walk ~A, env: ~A~%~%" form env)
+ (case head
+
+ ;; ---------------- define ----------------
+ ((define define* define-constant
+ define-macro define-macro* define-bacro define-bacro* define-expansion
+ definstrument defanimal define-envelope ; for clm
+ define-public define-inlinable define-integrable define^) ; these give more informative names in Guile and scmutils (MIT-scheme)
+
+ (if (< (length form) 2)
+ (begin
+ (lint-format "~S makes no sense" caller form)
+ env)
+ (let ((sym (cadr form))
+ (val (cddr form)))
+ (if (symbol? sym)
+ (begin
- (if (symbol? form)
- (set-ref? form env) ; returns env
-
- (if (pair? form)
- (let ((head (car form)))
+ (cond ((keyword? sym) ; (define :x 1)
+ (lint-format "keywords are constants ~A" caller sym))
+
+ ((and (eq? sym 'pi) ; (define pi (atan 0 -1))
+ (member (car val) '((atan 0 -1)
+ (acos -1)
+ (* 2 (acos 0))
+ (* 4 (atan 1))
+ (* 4 (atan 1 1)))))
+ (lint-format "~A is one of its many names, but pi a predefined constant in s7" caller (car val)))
+
+ ((constant? sym) ; (define most-positive-fixnum 432)
+ (lint-format "~A is a constant in s7: ~A" caller sym form))
+
+ ((let ((v (var-member sym env)))
+ (and (var? v)
+ (eq? (var-definer v) 'define-constant)
+ (not (equal? (caddr form) (var-initial-value v)))))
+ (let ((v (var-member sym env)))
+ (lint-format "~A in ~A is already a constant, defined ~A~A" caller sym
+ (truncated-list->string form)
+ (if (and (pair? (var-initial-value v))
+ (positive? (pair-line-number (var-initial-value v))))
+ (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
+ "")
+ (truncated-list->string (var-initial-value v))))))
+
+ (if (memq head '(define define-constant define-envelope
+ define-public define-inlinable define-integrable define^))
+ (let ((len (length form)))
+ (if (not (= len 3))
+ (lint-format "~A has ~A value~A?"
+ caller (truncated-list->string form)
+ (if (< len 3)
+ (values "no" "")
+ (values "too many" "s")))))
+ (lint-format "~A is messed up" caller (truncated-list->string form)))
+
+ ;; can we see simple macros that should be functions? (any macro without ,@)
+ ;; yes, but it almost never happens -- (lambda (x) ({list} 'car x))
+ ;; from (define-macro (cr x) `(car ,x)) -> (define cr car)
+
+ (if (and (pair? val)
+ (null? (cdr val))
+ (equal? sym (car val)))
+ (lint-format "this ~A is either not needed, or is an error: ~A" caller head (truncated-list->string form)))
+
+ (if (not (pair? val))
+ (cons (make-var :name sym :initial-value val :definer head) env)
+ (let ((e (lint-walk (if (and (pair? (car val))
+ (eq? (caar val) 'letrec))
+ 'define sym)
+ (car val) env)))
+ (if (or (not (pair? e))
+ (eq? e env)
+ (not (eq? (var-name (car e)) :lambda))) ; (define x (lambda ...))
+ (cons (make-var :name sym :initial-value (car val) :definer head) env)
+ (begin
+ (set! (var-name (car e)) sym)
+
+ (let ((val (caddr form)))
+ (when (and (pair? val)
+ (eq? (car val) 'lambda) ; (define sym (lambda args (let name...))), let here happens rarely
+ (proper-list? (cadr val))
+ (pair? (caddr val))
+ (null? (cdddr val))
+ (eq? (caaddr val) 'let)
+ (symbol? (cadr (caddr val))))
+ (replace-redundant-named-let caller form sym (cadr val) (caddr val))))
+
+ ;; (define x (letrec ((y (lambda...))) (lambda (...) (y...)))) -> (define (x...)...)
+ (let* ((let-form (caddr form))
+ (var (and (pair? (cadr let-form))
+ (null? (cdadr let-form)) ; just one var in let/rec
+ (caadr let-form))))
+ ;; let-form here can be (lambda...) or (let|letrec ... lambda)
+ (when (and (pair? var)
+ (symbol? (car var))
+ (pair? (cddr let-form))
+ (pair? (caddr let-form))
+ (null? (cdddr let-form)) ; just one form in the let/rec
+ (pair? (cdr var))
+ (pair? (cadr var))
+ (pair? (cdadr var))
+ (eq? (caadr var) 'lambda) ; var is lambda
+ (proper-list? (cadadr var))) ; it has no rest arg
+ (let ((body (caddr let-form)))
+ (when (and (eq? (car body) 'lambda) ; let/rec body is lambda calling var
+ (proper-list? (cadr body)) ; rest args are a headache
+ (pair? (caddr body))) ; (lambda (...) (...) where car is letrec func name
+ (if (eq? (caaddr body) (car var))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(define (,sym ,@(cadr body))
+ (let ,(car var)
+ ,(map list (cadadr var) (cdaddr body))
+ ,@(cddadr var)))))
+ (let ((call (find-call (car var) (caddr body))))
+ (when (and (pair? call) ; inner lambda body is (...some-expr...(sym...) ...)
+ (= (tree-count1 (car var) (caddr body) 0) 1))
+ (let ((new-call `(let ,(car var)
+ ,(map list (cadadr var) (cdr call))
+ ,@(cddadr var))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(define (,sym ,@(cadr body))
+ ,(tree-subst new-call call
+ (caddr body)))))))))))))
+ (when (and *report-function-stuff*
+ (pair? (caddr (var-initial-value (car e)))))
+ (hash-table-set! equable-closures (caaddr (var-initial-value (car e)))
+ (cons (car e) (or (hash-table-ref equable-closures (caaddr (var-initial-value (car e)))) ()))))
+ e))))) ; symbol? sym
+
+ ;; not (symbol? sym)
+ (if (and (pair? sym) ; cadr form
+ (pair? val) ; cddr form
+ (not (pair? (car sym)))) ; pair would indicate a curried func or something equally stupid
+ (let ((outer-args (cdr sym))
+ (outer-name (car sym)))
+
+ (when (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (pair? (cadar val)))
+ (let ((inner-vars (cadar val)))
+ (do ((p outer-args (cdr p)))
+ ((not (pair? p)))
+ (cond ((assq (car p) inner-vars) =>
+ (lambda (v)
+ (if (eq? (cadr v) (car p))
+ (lint-format "in ~A this let binding is pointless: ~A" caller
+ (truncated-list->string form)
+ v))))))))
+
+ ;; define + redundant named-let -- sometimes rewrites to define*
+ (when (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (symbol? (cadar val))
+ (null? (cdr val)))
+ (replace-redundant-named-let caller form outer-name outer-args (car val)))
+
+ ;; perhaps this block should be on a *report-* switch --
+ ;; it translates some internal defines into named lets
+ ;; (or just normal lets, etc)
+ ;; this is not redundant given the walk-body translations because here
+ ;; we have the outer parameters and can check those against the inner ones
+ ;; leading (sometimes) to much nicer rewrites.
+ (when (and (pair? (car val))
+ (eq? (caar val) 'define)
+ (pair? (cdr val))
+ (pair? (cadar val))) ; inner define (name ...)
+ (let ((inner-name (caadar val))
+ (inner-args (cdadar val))
+ (inner-body (cddar val))
+ (outer-body (cdddr form)))
+ (when (and (symbol? inner-name)
+ (proper-list? inner-args)
+ (pair? (car outer-body))
+ (= (tree-count1 inner-name outer-body 0) 1))
+ (let ((call (find-call inner-name outer-body)))
+ (when (pair? call)
+ (set! last-rewritten-internal-define (car val))
+ (let ((new-call (if (tree-memq inner-name inner-body)
+ (if (and (null? inner-args)
+ (null? outer-args))
+ (if (null? (cdr inner-body))
+ (car (tree-subst outer-name inner-name inner-body))
+ `(begin ,@(tree-subst outer-name inner-name inner-body)))
+ `(let ,inner-name
+ ,(if (null? inner-args) () (map list inner-args (cdr call)))
+ , at inner-body))
+ (if (or (null? inner-args)
+ (and (equal? inner-args outer-args)
+ (equal? inner-args (cdr call))))
+ (if (null? (cdr inner-body))
+ (car (tree-subst outer-name inner-name inner-body))
+ `(begin ,@(tree-subst outer-name inner-name inner-body)))
+ `(let ,(map list inner-args (cdr call))
+ , at inner-body)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,head ,sym
+ ,@(let ((p (tree-subst new-call call outer-body)))
+ (if (and (pair? p)
+ (pair? (car p))
+ (eq? (caar p) 'begin))
+ (cdar p)
+ p)))))))))))
+
+ (when (pair? outer-args)
+ (if (repeated-member? (proper-list outer-args) env)
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string sym)))
+
+ (cond ((memq head '(define* define-macro* define-bacro*))
+ (check-star-parameters outer-name outer-args env))
+ ((list-any? keyword? outer-args)
+ (lint-format "~A parameter can't be a keyword: ~A" caller outer-name sym))
+ ((memq 'pi outer-args)
+ (lint-format "~A parameter can't be a constant: ~A" caller outer-name sym)))
+
+ ;; look for built-in names used as parameter names and used as functions internally(!)
+ ;; this requires a tree walker to ignore (for example) (let loop ((string string))...)
+ (for-each (lambda (p)
+ (let ((par (if (pair? p) (car p) p)))
+ (when (or (hash-table-ref built-in-functions par)
+ (hash-table-ref syntaces par))
+ (let ((call (call-with-exit
+ (lambda (return)
+ (let loop ((tree (cddr form)))
+ (if (pair? tree)
+ (if (eq? (car tree) par)
+ (return tree)
+ (case (car tree)
+ ((quote) #f)
+ ((let let*)
+ (if (pair? (cdr tree))
+ (if (symbol? (cadr tree))
+ (if (not (tree-memq par (caddr tree)))
+ (loop (cdddr tree)))
+ (if (not (tree-memq par (cadr tree)))
+ (loop (cddr tree))))))
+ ((letrec letrec*)
+ (if (and (pair? (cdr tree))
+ (not (tree-memq par (cadr tree))))
+ (loop (cddr tree))))
+ ((do)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree))
+ (not (tree-memq par (cadr tree))))
+ (loop (cdddr tree))))
+ (else
+ (if (pair? (cdr tree))
+ (for-each loop (cdr tree)))
+ (if (pair? (car tree))
+ (loop (car tree))))))))))))
+ (if (and (pair? call)
+ (pair? (cdr call))
+ (not (eq? par (cadr call))))
+ (lint-format* caller
+ (string-append (object->string outer-name) "'s parameter " (symbol->string par))
+ (string-append " is called " (truncated-list->string call))
+ ": find a less confusing parameter name!"))))))
+ outer-args))
+
+ (when (and (eq? head 'define-macro)
+ (null? outer-args)
+ (null? (cdr val))
+ (code-constant? (car val)))
+ (lint-format "perhaps ~A" caller (lists->string form `(define ,outer-name ,(car val)))))
+
+ (if (and (eq? head 'definstrument)
+ (string? (car val)))
+ (set! val (cdr val)))
+
+ (if (keyword? outer-name)
+ (begin
+ (lint-format "keywords are constants ~A" caller outer-name)
+ env)
+ (lint-walk-function head outer-name outer-args val form env)))
+
+ (begin
+ (lint-format "strange form: ~A" head (truncated-list->string form))
+ (when (and (pair? sym)
+ (pair? (car sym)))
+ (let ((outer-args (cdr sym))
+ (outer-name (if (eq? head 'define*) (remove :optional (car sym)) (car sym))))
+ (if (symbol? (car outer-name))
+ ;; perhaps a curried definition -- as a public service, we'll rewrite the dumb thing
+ (begin
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,outer-name
+ (lambda ,outer-args
+ ,@(cddr form)))))
+ (lint-walk-function head (car outer-name) (cdr outer-name) val form env)) ;val=(cddr form) I think
+ (when (pair? (car outer-name))
+ (if (symbol? (caar outer-name))
+ (begin
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,(car outer-name)
+ (lambda ,(cdr outer-name)
+ (lambda ,outer-args
+ ,@(cddr form))))))
+ (lint-walk-function head (caar outer-name) (cdar outer-name) val form env))
+ (when (and (pair? (caar outer-name))
+ (symbol? (caaar outer-name)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,(caar outer-name)
+ (lambda ,(cdar outer-name)
+ (lambda ,(cdr outer-name)
+ (lambda ,outer-args
+ ,@(cddr form)))))))
+ (lint-walk-function head (caaar outer-name) (cdaar outer-name) val form env)))))))
+ env))))))
+
+ ;; ---------------- lambda ----------------
+ ((lambda lambda*)
+ (let ((len (length form)))
+ (if (< len 3)
+ (begin
+ (lint-format "~A is messed up in ~A" caller head (truncated-list->string form))
+ env)
+ (let ((args (cadr form)))
+ (when (list? args)
+ (let ((arglen (length args)))
+ (if (null? args)
+ (if (eq? head 'lambda*) ; (lambda* ()...) -> (lambda () ...)
+ (lint-format "lambda* could be :lambda ~A" caller form))
+ (begin ; args is a pair ; (lambda (a a) ...)
+
+ (let ((val (cddr form)))
+ (if (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (pair? (cadar val)))
+ (let ((inner-vars (cadar val)))
+ (do ((p (cadr form) (cdr p)))
+ ((not (pair? p)))
+ (cond ((assq (car p) inner-vars) =>
+ (lambda (v)
+ (if (eq? (cadr v) (car p))
+ (lint-format "in ~A this let binding is pointless: ~A" caller
+ (truncated-list->string form)
+ v)))))))))
+
+ (if (repeated-member? (proper-list args) env)
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args)))
+ (if (eq? head 'lambda*) ; (lambda* (a :b) ...)
+ (check-star-parameters head args env)
+ (if (list-any? keyword? args) ; (lambda (:key) ...)
+ (lint-format "lambda arglist can't handle keywords (use lambda*)" caller)))))
+
+ (when (and (eq? head 'lambda) ; (lambda () (f)) -> f, (lambda (a b) (f a b)) -> f
+ (not (eq? caller 'case-lambda))
+ (= len 3)
+ (>= arglen 0)) ; not a dotted list
+ (let ((body (caddr form)))
+ (when (and (pair? body)
+ (symbol? (car body))
+ (not (memq (car body) '(and or))))
+ (cond ((equal? args (cdr body))
+ (lint-format "perhaps ~A" caller (lists->string form (car body))))
+
+ ((equal? (reverse args) (cdr body))
+ (let ((rf (hash-table-ref reversibles (car body))))
+ (if rf (lint-format "perhaps ~A" caller (lists->string form rf)))))
+
+ ((and (= arglen 1)
+ (memq (car body) '(car cdr caar cadr cddr cdar caaar caadr caddr
+ cdddr cdaar cddar cadar cdadr cadddr cddddr)))
+ ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
+ (and cr
+ (< (length cr) 5)
+ (eq? (car args) arg)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (string->symbol (string-append "c" cr "r"))))))
+ (combine-cxrs body)))))))))
+
+ (if (and (or (symbol? args) ; (lambda args (apply f args)) -> f
+ (and (pair? args) ; (lambda #\a ...) !
+ (negative? (length args))))
+ (eq? head 'lambda)
+ (not (eq? caller 'case-lambda))
+ (= len 3))
+ (let ((body (caddr form)))
+ (if (and (pair? body)
+ (eq? (car body) 'apply)
+ (pair? (cdr body))
+ (symbol? (cadr body))
+ (not (memq (cadr body) '(and or)))
+ (pair? (cddr body))
+ (or (eq? args (caddr body))
+ (and (pair? args)
+ (equal? (cddr body) (proper-list args)))))
+ (lint-format "perhaps ~A" caller (lists->string form (cadr body))))))
+
+#|
+ (let ((args1 (args->proper-list args)))
+ (when (and (pair? (cddr form))
+ (pair? (caddr form))
+ (null? (cdddr form))
+ (eq? (caaddr form) 'let)
+ (pair? (cadr (caddr form))))
+ (for-each (lambda (v)
+ (if (and (pair? v)
+ (pair? (cdr v))
+ (pair? (cadr v))
+ (not (tree-set-member args1 (cadr v)))
+ (memq (caadr v) '(make-vector vector make-string string make-list list)))
+ (varlet -- yow)))
+ ;; perhaps: cons onto a list passed as another arg to lint-walk-function which walks the body
+ ;; and calls report-usage, so at that point we can look at the watched vars. If any are
+ ;; not set in any way (and come from list string vector), they can simply be moved to
+ ;; the closure. If set, (and from make-*) they can be reinitialized via fill. But,
+ ;; we need the fill value -- maybe restrict to large cases? Any unset vals could be
+ ;; moved, perhaps removing the need for the let. And for let* et al, they can represent
+ ;; the closure too. So (lambda (x) (let ((y (sqrt 2))) (* x y))) -> (let ((y (sqrt 2))) (lambda (x) (* x y)))
+ ;; Maybe larger savings from define, but worth a look anyway. Especially wasteful in recursive func.
+ ;; even local lets could be moved out -- how to maintain locality?
+ (cadr (caddr form))))
+|#
+
+ (lint-walk-function head caller args (cddr form) form env)
+ ;env -- not this -- return the lambda+old env via lint-walk-function
+ ))))
- (define (defmacro-case)
- ;; ---------------- defmacro ----------------
- (if (or (< (length form) 4)
- (not (symbol? (cadr form))))
- (lint-format "~A declaration is messed up: ~A" name head (truncated-list->string form))
- (let ((sym (cadr form))
- (args (caddr form))
- (body (cdddr form)))
- (if (and (pair? args)
- (repeated-member? args env))
- (lint-format "~A parameter is repeated: ~A" name head (truncated-list->string args)))
- (lint-walk-function head sym args body form env))))
+ ;; ---------------- set! ----------------
+ ((set!)
+ (if (not (= (length form) 3))
+ (begin
+ (lint-format "set! has too ~A arguments: ~S" caller (if (> (length form) 3) "many" "few") form)
+ env)
+ (let ((settee (cadr form))
+ (setval (caddr form)))
+ (let ((result (lint-walk caller setval env)))
+ (if (symbol? settee)
+ (if (constant? settee)
+ (lint-format "can't set! ~A (it is a constant)" caller (truncated-list->string form))
+ (let ((v (var-member settee env)))
+ (if (and (var? v)
+ (eq? (var-definer v) 'define-constant))
+ (lint-format "can't set! ~A in ~A (it is a constant: ~A~A)" caller settee
+ (truncated-list->string form)
+ (if (and (pair? (var-initial-value v))
+ (positive? (pair-line-number (var-initial-value v))))
+ (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
+ "")
+ (truncated-list->string (var-initial-value v))))))
+ (if (not (pair? settee))
+ (lint-format "can't set! ~A" caller (truncated-list->string form))
+ (begin
+ (if (memq (car settee) '(vector-ref list-ref string-ref hash-table-ref))
+ (lint-format "~A as target of set!~A" caller (car settee) (truncated-list->string form)))
+ (lint-walk caller settee env) ; this counts as a reference since it's by reference so to speak
+
+ ;; try type check (dilambda signatures)
+ (when (symbol? (car settee))
+ (let ((f (symbol->value (car settee) *e*)))
+ (when (dilambda? f)
+ (let ((sig (procedure-signature (procedure-setter f)))
+ (settee-len (length settee)))
+ (when (and (pair? sig)
+ (positive? settee-len)
+ (pair? (list-tail sig settee-len)))
+ (let ((checker (list-ref sig settee-len))
+ (arg-type (->lint-type setval)))
+ (when (and (symbol? checker)
+ (not (compatible? checker arg-type)))
+ (lint-format "~A: new value should be a~A ~A: ~S: ~A"
+ caller (car settee)
+ (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
+ checker arg-type
+ (truncated-list->string form)))))))))
+ (set! settee (do ((sym (car settee) (car sym)))
+ ((not (pair? sym)) sym))))))
+
+ (if (symbol? (cadr form)) ; see do directly above -- sets settee so we have to go back to (cadr form)
+ (set-set (cadr form) caller form env)
+ (if (and (pair? (cadr form))
+ (symbol? settee))
+ (set-ref settee caller `(implicit-set ,@(cdr form)) env)))
+
+ (if (equal? (cadr form) setval) ; not settee here!
+ (lint-format "pointless set! ~A" caller (truncated-list->string form)))
+
+ result))))
- (define (define-case)
- ;; ---------------- define ----------------
- (if (< (length form) 2)
- (begin
- (lint-format "~S makes no sense" name form)
- env)
- (let ((sym (cadr form))
- (val (cddr form)))
-
- (if (symbol? sym)
- (begin
- ;(set! env (cons (list (make-var sym :typ (->type val))) env))
-
- (if (keyword? sym)
- (lint-format "keywords are constants ~A" name sym))
-
- (if (memq head '(define define-constant define-envelope))
- (let ((len (length form)))
- (if (not (= len 3))
- (lint-format "~S has ~A value~A?"
- name form
- (if (< len 3) "no" "too many")
- (if (< len 3) "" "s"))))
- (lint-format "~A is messed up" name (truncated-list->string form)))
-
- (if (and (pair? val)
- (null? (cdr val))
- (equal? sym (car val)))
- (lint-format "this ~A is either not needed, or is an error: ~A" name head (truncated-list->string form)))
-
- (if (pair? (cddr form))
- (let ((e (lint-walk sym (caddr form) env)))
- (if (and (pair? e)
- (eq? (var-name (car e)) '[anonymous])) ; (define x (lambda ...)) but it misses closures
- (set! (var-name (car e)) sym)
- (append (list (make-var sym)) env)))
- (append (list (make-var sym)) env)))
-
- ;; not (symbol? sym)
- (if (and (pair? sym)
- (not (pair? (car sym))))
- (begin
- (when (pair? (cdr sym))
- (if (repeated-member? (proper-list (cdr sym)) env)
- (lint-format "~A parameter is repeated: ~A" name head (truncated-list->string sym)))
- (if (memq head '(define* define-macro* define-bacro*))
- (check-star-parameters name (cdr sym))
- (if (list-any? keyword? (cdr sym))
- (lint-format "~A arglist can't handle keywords" name head))))
-
- (if (and (eq? head 'definstrument)
- (string? (car val)))
- (set! val (cdr val)))
-
- (if (keyword? (car sym))
- (begin
- (lint-format "keywords are constants ~A" name (car sym))
- env)
- (lint-walk-function head (car sym) (cdr sym) val form env)))
-
- (begin
- (lint-format "strange form: ~S" head form)
- env))))))
+ ;; ---------------- quote ----------------
+ ((quote)
+ (let ((len (length form)))
+ (if (negative? len)
+ (lint-format "stray dot in quote's arguments? ~S" caller form)
+ (if (not (= len 2))
+ (lint-format "quote has too ~A arguments: ~S" caller (if (> len 2) "many" "few") form)
+ (let ((arg (cadr form)))
+ (if (pair? arg)
+ (if (> (length arg) 8)
+ (hash-table-set! big-constants arg (+ 1 (or (hash-table-ref big-constants arg) 0))))
+ (unless (or (>= quote-warnings 20)
+ (and (symbol? arg)
+ (not (keyword? arg))))
+ (set! quote-warnings (+ quote-warnings 1))
+ (lint-format "quote is not needed here: ~A~A" caller
+ (truncated-list->string form)
+ (if (= quote-warnings 20) "; will ignore this error henceforth." ""))))))))
+ env)
- (define (generator-case)
- ;; ---------------- defgenerator ----------------
- (get-generator form name head)
- env)
+ ;; ---------------- if ----------------
+ ((if)
+ (let ((len (length form)))
+ (if (> len 4)
+ (lint-format "if has too many clauses: ~A" caller (truncated-list->string form))
+ (if (< len 3)
+ (lint-format "if has too few clauses: ~A" caller (truncated-list->string form))
+ (let ((test (cadr form))
+ (true (caddr form))
+ (false (if (= len 4) (cadddr form) 'no-false))
+ (expr (simplify-boolean (cadr form) () () env))
+ (suggestion made-suggestion))
+
+ (if (eq? false #<unspecified>)
+ (lint-format "this #<unspecified> is redundant: ~A" caller form))
+
+ (when (and (pair? true)
+ (pair? false)
+ (not (memq (car true) (list 'quote {list})))
+ (not (any-macro? (car true) env))
+ (or (not (hash-table-ref syntaces (car true)))
+ (memq (car true) '(set! and or begin)))
+ (pair? (cdr true)))
+
+ (define (tree-subst-eq new old tree)
+ ;; tree-subst above substitutes every occurence of 'old with 'new, so we check
+ ;; in advance that 'old only occurs once in the tree (via tree-count1). Here
+ ;; 'old may occur any number of times, but we only want to change it once,
+ ;; so we keep the actual pointer to it and use eq?.
+ (cond ((eq? old tree)
+ (cons new (cdr tree)))
+ ((not (pair? tree))
+ tree)
+ ((eq? (car tree) 'quote)
+ (copy-tree tree))
+ (else (cons (tree-subst-eq new old (car tree))
+ (tree-subst-eq new old (cdr tree))))))
+
+ (let ((diff (let differ-in-one ((p true)
+ (q false))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-one (cdr p) (cdr q))
+ (and (not (pair? (car p)))
+ (not (pair? (car q)))
+ (equal? (cdr p) (cdr q))
+ (list p (list (car p) (car q)))))))))
+ (if (pair? diff)
+ (if (not (or (equal? (car true) (caadr diff)) ; (if z (+ x y) (- x y))?
+ (and (eq? (car true) 'set!) ; (if x (set! y w) (set! z w))
+ (equal? (caar diff) (cadr true)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (cond ((and (eq? (caadr diff) #t)
+ (not (cadadr diff)))
+ ;; (if x (set! y #t) (set! y #f)) -> (set! y x)
+ (tree-subst-eq test (car diff) true))
+
+ ((and (not (caadr diff))
+ (eq? (cadadr diff) #t))
+ ;; (if x (set! y #f) (set! y #t)) -> (set! y (not x))
+ (tree-subst-eq (simplify-boolean `(not ,expr) () () env)
+ (car diff) true))
+
+ ((equal? (caadr diff) test)
+ ;; (if x (set! y x) (set! y 21)) -> (set! y (or x 21))
+ (tree-subst-eq (simplify-boolean `(or ,@(cadr diff)) () () env)
+ (car diff) true))
+
+ (else
+ ;; (if x (set! y z) (set! y w)) -> (set! y (if x z w))
+ ;; true op moved out, if expr moved in
+ ;; (if A (and B C) (and B D)) -> (and B (if A C D))
+ ;; here differ-in-one means that preceding/trailing stuff must match exactly
+ (tree-subst-eq `(if ,expr ,@(cadr diff)) (car diff) true))))))
+
+ ;; next look for one-seq difference
+ ;; not sure about this -- in simple cases it looks good
+ ;; some cases are trying to remove a test from a loop, so our suggestion will be unwelcome
+
+ (let ((seqdiff (let differ-in-one-seq ((p true)
+ (q false)
+ (c 0))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-one-seq (cdr p) (cdr q) (+ c 1))
+ (and (> c 1)
+ (equal? (cdr p) (cdr q))
+ (list p (list (car p) (car q)))))))))
+ ;; (if x (set! y 1) (set! y (+ x 1))) -> (set! y (if x 1 (+ x 1)))
+ (if (pair? seqdiff)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst-eq `(if ,expr ,@(cadr seqdiff)) (car seqdiff) true)))
+
+ ;; differ-in-trailers can (sometimes) take advantage of values
+ (let ((enddiff (let differ-in-trailers ((p true)
+ (q false)
+ (c 0))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-trailers (cdr p) (cdr q) (+ c 1))
+ (and (> c 1)
+ (let ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values)))
+ (list p
+ (if (null? (cdr p)) (car p) `(,op , at p))
+ (if (null? (cdr q)) (car q) `(,op , at q))))))))))
+
+ ;; (if A (+ B C E) (+ B D)) -> (+ B (if A (+ C E) D))
+ ;; if p/q null, don't change because for example
+ ;; (if A (or B C) (or B C D F)) can't be (or B C (if A ...))
+ ;; but if this were not and/or, it could be (+ B (if A C (values C D F)))
+ (if (pair? enddiff)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst `((if ,expr ,@(cdr enddiff))) (car enddiff) true)))
+
+ ;; differ-in-headers looks for equal trailers
+ ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C)
+ ;; these are not always (read: almost never) an improvement
+ (when (and (eq? (car true) (car false))
+ (not (eq? (car true) 'values))
+ (or (not (eq? (car true) 'set!))
+ (equal? (cadr true) (cadr false))))
+ (let ((headdiff (let differ-in-headers ((p (cdr true))
+ (q (cdr false))
+ (c 0)
+ (rp ())
+ (rq ()))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? p q)
+ (and (> c 0) ; once case is handled elsewhere?
+ (list p (reverse rp) (reverse rq)))
+ (differ-in-headers (cdr p) (cdr q)
+ (+ c 1)
+ (cons (car p) rp) (cons (car q) rq)))))))
+ (when (pair? headdiff)
+ (let* ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values))
+ (tp (if (null? (cdadr headdiff)) (caadr headdiff) `(,op ,@(cadr headdiff))))
+ (tq (if (null? (cdaddr headdiff)) (caaddr headdiff) `(,op ,@(caddr headdiff)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(car true) (if ,expr ,tp ,tq) ,@(car headdiff)))))))))))))))
+
+ (unless (= last-if-line-number line-number)
+ (do ((iff form (cadddr iff))
+ (iffs 0 (+ iffs 1)))
+ ((not (and (<= iffs 2)
+ (pair? iff)
+ (= (length iff) 4)
+ (eq? (car iff) 'if)))
+ (when (or (> iffs 2)
+ (and (= iffs 2)
+ (pair? iff)
+ (= (length iff) 3)
+ (eq? (car iff) 'if)))
+ (set! last-if-line-number line-number)
+ (lint-format "perhaps use cond: ~A" caller
+ (lists->string form
+ `(cond ,@(do ((iff form (cadddr iff))
+ (clauses ()))
+ ((not (and (pair? iff)
+ (= (length iff) 4)
+ (eq? (car iff) 'if)))
+ (append (reverse clauses)
+ (if (and (pair? iff)
+ (= (length iff) 3)
+ (eq? (car iff) 'if))
+ `((,(cadr iff) ,@(unbegin (caddr iff))))
+ `((else ,@(unbegin iff))))))
+ (set! clauses (cons (cons (cadr iff) (unbegin (caddr iff))) clauses))))))))))
+
+ (if (never-false test)
+ (lint-format "if test is never false: ~A" caller (truncated-list->string form))
+ (if (and (never-true test) true) ; complain about (if #f #f) later
+ (lint-format "if test is never true: ~A" caller (truncated-list->string form))))
+
+ (unless (side-effect? test env)
+ (cond ((or (equal? test true) ; (if x x y) -> (or x y)
+ (equal? expr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean (if (eq? false 'no-false)
+ `(or ,expr #<unspecified>)
+ `(or ,expr ,false))
+ () () env))))
+ ((or (equal? test `(not ,true)) ; (if x (not x) y) -> (and (not x) y)
+ (equal? `(not ,test) true)) ; (if (not x) x y) -> (and x y)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean (if (eq? false 'no-false)
+ `(and ,true #<unspecified>)
+ `(and ,true ,false))
+ () () env))))
+ ((or (equal? test false) ; (if x y x) -> (and x y)
+ (equal? expr false))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean `(and ,expr ,true) () () env))))
+
+ ((or (equal? `(not ,test) false) ; (if x y (not x)) -> (or (not x) y)
+ (equal? test `(not ,false))) ; (if (not x) y x) -> (or x y)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean `(or ,false ,true) () () env))))))
+
+ (when (= len 4)
+ (when (and (pair? true)
+ (eq? (car true) 'if))
+ (if (= (length true) 4)
+ (begin
+ (if (equal? expr (simplify-boolean `(not ,(cadr true)) () () env))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,(cadddr true) ,false))))
+ (if (equal? expr (cadr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,(caddr true) ,false))))
+ (if (equal? false (cadddr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean
+ (if (not false)
+ `(and ,expr ,(cadr true) ,(caddr true))
+ `(if (and ,expr ,(cadr true)) ,(caddr true) ,false))
+ () () env)))
+ (if (equal? false (caddr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean
+ (if (not false)
+ `(and ,expr (not ,(cadr true)) ,(cadddr true))
+ `(if (and ,expr (not ,(cadr true))) ,(cadddr true) ,false))
+ () () env)))))
+
+ ;; (if a (if b d e) (if c d e)) -> (if (if a b c) d e)? reversed does not happen.
+ ;; (if a (if b d) (if c d)) -> (if (if a b c) d)
+ ;; (if a (if b d e) (if (not b) d e)) -> (if (eq? (not a) (not b)) d e)
+ (if (and (pair? false)
+ (eq? (car false) 'if)
+ (= (length false) 4)
+ (not (equal? (cadr true) (cadr false)))
+ (equal? (cddr true) (cddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? (cadr true))
+ (eq? (caadr true) 'not)
+ (equal? (cadadr true) (cadr false)))
+ `(if (not (eq? (not ,expr) ,(cadr true)))
+ ,@(cddr true))
+ (if (and (pair? (cadr false))
+ (eq? (caadr false) 'not)
+ (equal? (cadr true) (cadadr false)))
+ `(if (eq? (not ,expr) ,(cadr false))
+ ,@(cddr true))
+ `(if (if ,expr ,(cadr true) ,(cadr false)) ,@(cddr true))))))))
+
+ (begin
+ (if (equal? expr (simplify-boolean `(not ,(cadr true)) () () env))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if (not ,expr) ,false))))
+ (if (equal? expr (cadr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,(caddr true) ,false))))
+ (if (equal? false (caddr true)) ; (if a (if b A) A)
+ (lint-format "perhaps ~A" caller
+ (let ((nexpr (simplify-boolean `(or (not ,expr) ,(cadr true)) () () env)))
+ (lists->string form `(if ,nexpr ,false))))))))
+
+ (when (pair? false)
+ (case (car false)
+ ((cond) ; (if a A (cond...)) -> (cond (a A) ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(cond (,expr ,true) ,@(cdr false)))))
+
+ ((if)
+ (when (= (length false) 4)
+ (if (equal? true (caddr false))
+ (lint-format "perhaps ~A" caller
+ (if (and (pair? (cadddr false))
+ (eq? (car (cadddr false)) 'if)
+ (equal? true (caddr (cadddr false))))
+ (lists->string form
+ (let ((nexpr (simplify-boolean
+ `(or ,expr ,(cadr false) ,(cadr (cadddr false)))
+ () () env)))
+ `(if ,nexpr ,true ,@(cdddr (cadddr false)))))
+ (if true
+ (let ((nexpr (simplify-boolean `(or ,expr ,(cadr false)) () () env)))
+ (lists->string form `(if ,nexpr ,true ,(cadddr false))))
+ (lists->string form
+ (simplify-boolean
+ `(and (not (or ,expr ,(cadr false))) ,(cadddr false))
+ () () env)))))
+ (if (equal? true (cadddr false))
+ (lint-format "perhaps ~A" caller
+ (if true
+ (let ((nexpr (simplify-boolean `(or ,expr (not ,(cadr false))) () () env)))
+ (lists->string form `(if ,nexpr ,true ,(caddr false))))
+ (lists->string form
+ (simplify-boolean
+ `(and (not (or ,expr (not ,(cadr false)))) ,(caddr false))
+ () () env)))))))
+ (if (and (pair? true)
+ (eq? (car true) 'if)
+ (= (length true) 3)
+ (= (length false) 3)
+ (equal? (cddr true) (cddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if (if ,expr ,(cadr true) ,(cadr false)) ,@(cddr true))))))
+
+
+ ((map) ; (if (null? x) () (map abs x)) -> (map abs x)
+ (if (and (pair? test)
+ (eq? (car test) 'null?)
+ (or (null? true)
+ (equal? true (cadr test)))
+ (equal? (cadr test) (caddr false))
+ (or (null? (cdddr false))
+ (not (side-effect? (cdddr false) env))))
+ (lint-format "perhaps ~A" caller (lists->string form false))))
+
+ ((case)
+ (if (and (pair? expr)
+ (cond-eqv? expr (cadr false) #t))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(case ,(cadr false)
+ ,(case-branch expr (cadr false) (list true))
+ ,@(cddr false))))))))
+ ) ; (= len 4)
+
+ (if (pair? false)
+ (begin
+ (if (and (eq? (car false) 'if) ; (if x 3 (if (not x) 4)) -> (if x 3 4)
+ (pair? (cdr false))
+ (not (side-effect? test env)))
+ (if (or (equal? test (cadr false))
+ (equal? expr (cadr false)))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,@(cdddr false))))
+ (if (and (pair? (cadr false))
+ (eq? (caadr false) 'not)
+ (or (equal? test (cadadr false))
+ (equal? expr (cadadr false))))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,(caddr false)))))))
+
+ (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr)
+ (null? (cdddr false)) ; other case is dealt with above
+ (equal? true (caddr false)))
+ (let ((test1 (simplify-boolean `(or ,expr ,(cadr false)) () () env)))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,true ,@(cdddr false)))))))
+
+ (when (and (eq? false 'no-false) ; no false branch
+ (pair? true))
+ (if (pair? test)
+ (let ((test-op (car test))
+ (true-op (car true)))
+ ;; the min+max case is seldom hit, and takes about 50 lines
+ (if (and (memq test-op '(< > <= >=)) ; (if (< x y) (set! x y) -> (set! x (max x y))
+ (eq? true-op 'set!)
+ (null? (cdddr test))
+ (memq (cadr true) test)
+ (member (caddr true) test))
+ (let* ((target (cadr true))
+ (f (if (eq? target (if (memq test-op '(< <=))
+ (cadr test)
+ (caddr test)))
+ 'max 'min)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(set! ,target (,f ,@(cdr true)))))))))
+
+ (if (eq? (car true) 'if) ; (if test0 (if test1 expr)) -> (if (and test0 test1) expr)
+ (cond ((null? (cdddr true))
+ (let ((test1 (simplify-boolean `(and ,expr ,(cadr true)) () () env)))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,(caddr true))))))
+
+ ((equal? expr (cadr true))
+ (lint-format "perhaps ~A" caller (lists->string form true)))
+
+ ((equal? (cadr true) `(not ,expr))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (cadddr true)))))
+
+ (if (memq (car true) '(when unless)) ; (if test0 (when test1 expr...)) -> (when (and test0 test1) expr...)
+ (let ((test1 (simplify-boolean (if (eq? (car true) 'when)
+ `(and ,expr ,(cadr true))
+ `(and ,expr (not ,(cadr true))))
+ () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? test1)
+ (eq? (car test1) 'not))
+ `(unless ,(cadr test1) ,@(cddr true))
+ `(when ,test1 ,@(cddr true))))))))))
+
+ (if (and (pair? test)
+ (memq (car test) '(< <= > >= =)) ; (if (< x y) x y) -> (min x y)
+ (null? (cdddr test))
+ (member false test)
+ (member true test))
+ (if (eq? (car test) '=) ; (if (= x y) y x) -> y [this never happens]
+ (lint-format "perhaps ~A" caller (lists->string form false))
+ (let ((f (if (equal? (cadr test) (if (memq (car test) '(< <=)) true false))
+ 'min 'max)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,true ,false))))))
+
+ (cond ((eq? expr #t)
+ (lint-format "perhaps ~A" caller (lists->string form true)))
+
+ ((not expr)
+ (if (eq? false 'no-false)
+ (if true ; (if #f x) as a kludgey #<unspecified>
+ (lint-format "perhaps ~A" caller (lists->string form #<unspecified>)))
+ (lint-format "perhaps ~A" caller (lists->string form false))))
+
+ ((not (equal? true false))
+ (if (boolean? true)
+ (if (boolean? false) ; ! (if expr #t #f) turned into something less verbose
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if true
+ expr
+ (simplify-boolean `(not ,expr) () () env))))
+ (when (= suggestion made-suggestion)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if true
+ (if (eq? false 'no-false)
+ expr
+ (simplify-boolean `(or ,expr ,false) () () env))
+ (simplify-boolean
+ (if (eq? false 'no-false)
+ `(not ,expr)
+ `(and (not ,expr) ,false))
+ () () env))))))
+ (if (and (boolean? false)
+ (= suggestion made-suggestion))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean
+ (if false
+ (if (and (pair? expr) (eq? (car expr) 'not))
+ `(or ,(cadr expr) ,true)
+ `(or (not ,expr) ,true))
+ `(and ,expr ,true))
+ () () env))))))
+ ((= len 4)
+ (lint-format "if is not needed here: ~A" caller
+ (lists->string form (if (not (side-effect? test env))
+ true
+ `(begin ,expr ,true))))))
+
+ (when (and (= suggestion made-suggestion)
+ (not (equal? expr test))) ; make sure the boolean simplification gets reported
+ (lint-format "perhaps ~A" caller (lists->string test expr)))
+
+ (if (and (pair? test)
+ (pair? true)
+ (pair? (cdr true))
+ (null? (cddr true))
+ (or (equal? test (cadr true))
+ (equal? expr (cadr true))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? false 'no-false)
+ `(cond (,expr => ,(car true)))
+ `(cond (,expr => ,(car true)) (else ,false))))))
+
+ (when (and (pair? true)
+ (pair? false)
+ (eq? (car true) 'if)
+ (eq? (car false) 'if)
+ (= (length true) (length false) 4)
+ (equal? (cadr true) (cadr false)))
+ (if (and (equal? (caddr true) (cadddr false)) ; (if A (if B a b) (if B b a)) -> (if (eq? (not A) (not B)) a b)
+ (equal? (cadddr true) (caddr false)))
+ (let* ((switch #f)
+ (a (if (and (pair? expr)
+ (eq? (car expr) 'not))
+ (begin (set! switch #t) expr)
+ (simplify-boolean `(not ,expr) () () env)))
+ (b (if (and (pair? (cadr true))
+ (eq? (caadr true) 'not))
+ (begin (set! switch (not switch)) (cadr true))
+ (simplify-boolean `(not ,(cadr true)) () () env))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if switch
+ `(if (eq? ,a ,b) ,(caddr false) ,(caddr true))
+ `(if (eq? ,a ,b) ,(caddr true) ,(caddr false))))))
+ (unless (or (side-effect? expr env)
+ (equal? (cddr true) (cddr false))) ; handled elsewhere
+ (if (equal? (caddr true) (caddr false)) ; (if A (if B a b) (if B a c)) -> (if B a (if A b c))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if ,(cadr true) ,(caddr true)
+ (if ,expr ,(cadddr true) ,(cadddr false)))))
+ (if (equal? (cadddr true) (cadddr false)) ; (if A (if B a b) (if B c b)) -> (if B (if A a c) b)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if ,(cadr true)
+ (if ,expr ,(caddr true) ,(caddr false))
+ ,(cadddr true)))))))))
+
+ (when (and (symbol? test) ; (if x (map f x)) -- very common
+ (pair? true)
+ (pair? (cdr true)))
+ (if (and (memq (car true) '(map for-each))
+ (pair? (cddr true))
+ (eq? test (caddr true)))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string form `(if (sequence? ,expr) ,@(cddr form))))
+ (if (and (eq? test (cadr true))
+ (not (eq? form last-assoc-form)) ; why isn't this redundant?
+ (hash-table-ref built-in-functions (car true)))
+ (let ((sig (procedure-signature (car true))))
+ (if (and (pair? sig)
+ (symbol? (cadr sig))
+ (not (memq (cadr sig) '(boolean? input-port? output-port?)))
+ (not (and (var-member test env)
+ (tree-set-car-member '(assoc assv assq) (var-history (var-member test env))))))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string form `(if (,(cadr sig) ,expr) ,@(cddr form)))))))))
+ ;; the parallel if-not case does not happen
+
+ ;; --------
+ (when (and (= suggestion made-suggestion)
+ (not (= line-number last-if-line-number)))
+ ;; unravel complicated if-then-else nestings into a single cond, if possible.
+ ;;
+ ;; The (> new-len *report-nested-if*) below can mean (nearly) all nested ifs are turned into conds.
+ ;; For a long time I thought the if form was easier to read, but now
+ ;; I like cond better. But cond also has serious readability issues:
+ ;; it needs to be clearer where the test separates from the result,
+ ;; and in a stack of these clauses, it's hard to see anything at all.
+ ;; Maybe a different color for the test than the result?
+ ;;
+ ;; Also, the check for tree-leaves being hugely different is taken
+ ;; from C -- I think it is easier to read a large if statement if
+ ;; the shortest clause is at the start -- especially in a nested if where
+ ;; it can be nearly impossible to see which dangling one-liner matches
+ ;; which if (this even in emacs because it unmarks or doesn't remark the matching
+ ;; paren as you're trying to scroll up to it).
+ ;;
+ ;; the cond form is not always an improvement:
+ ;; (if A (if B (if C a b) (if C c d)) (if B (if C e f) (if C g h)))
+ ;; (cond (A (cond (B (cond (C a) (else b))) ... oh forget it ...))))
+ ;; perhaps: (case (+ (if A 4 0) (if B 2 0) (if C 1 0)) ((#b000)...))!
+ ;; how often (and how deeply nested) does this happen? -- not very, but nesting can be ridiculous.
+ ;; and this assumes all tests are always hit
+
+ (define (swap-clauses form)
+ (if (not (pair? (cdddr form)))
+ form
+ (let ((expr (cadr form))
+ (true (caddr form))
+ (false (cadddr form)))
+
+ (let ((true-n (tree-leaves true))
+ (false-n (if (not (pair? false))
+ 1
+ (tree-leaves false))))
+
+ (if (< false-n (/ true-n 4))
+ (let ((new-expr (simplify-boolean `(not ,expr) () () env)))
+ (if (and (pair? true)
+ (eq? (car true) 'if))
+ (set! true (swap-clauses true)))
+ (if (and (pair? true)
+ (eq? (car true) 'cond))
+ `(cond (,new-expr ,@(unbegin false))
+ ,@(cdr true))
+ `(cond (,new-expr ,@(unbegin false))
+ (else ,@(unbegin true)))))
+ (begin
+ (if (and (pair? false)
+ (eq? (car false) 'if))
+ (set! false (swap-clauses false)))
+
+ (if (and (pair? false)
+ (eq? (car false) 'cond))
+ `(cond (,expr ,@(unbegin true))
+ ,@(cdr false))
+ `(cond (,expr ,@(unbegin true))
+ (else ,@(unbegin false))))))))))
+
+ (let ((new-if (swap-clauses form)))
+ (if (eq? (car new-if) 'cond)
+ (if (> (length new-if) *report-nested-if*)
+ (begin
+ (set! last-if-line-number line-number)
+ (lint-format "perhaps ~A" caller (lists->string form new-if)))
+
+ (if (= len 4) ; unneccessary?
+ (let ((true-len (tree-leaves (caddr form))))
+ (if (and (> true-len *report-short-branch*)
+ (< (tree-leaves (cadddr form)) (/ true-len *report-short-branch*)))
+ (let ((new-expr (simplify-boolean `(not ,(cadr form)) () () env)))
+ (lint-format "perhaps place the much shorter branch first~A: ~A" caller
+ (local-line-number (cadr form))
+ (truncated-lists->string form `(if ,new-expr ,false ,true))))))))))
+ ;; --------
+
+ (if (and (= len 4) ; move repeated test to top, if no inner false branches
+ (pair? true) ; (if A (if B C) (if B D)) -> (if B (if A C D))
+ (pair? false)
+ (eq? (car true) 'if)
+ (eq? (car false) 'if)
+ (equal? (cadr true) (cadr false))
+ (null? (cdddr true))
+ (null? (cdddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,(cadr (caddr form))
+ (if ,expr
+ ,(caddr (caddr form))
+ ,(caddr (cadddr form)))))))
+
+ (when (and (= len 4) ; move repeated start/end statements out of the if
+ (pair? true)
+ (pair? false)
+ (eq? (car true) 'begin)
+ (eq? (car false) 'begin))
+ (let ((true-len (length true))
+ (false-len (length false)))
+ (when (and (> true-len 2)
+ (> false-len 2))
+ (let ((start (if (and (equal? (cadr true) (cadr false))
+ (not (side-effect? expr env))) ; expr might affect start, so we can't pull it ahead
+ (list (cadr true))
+ ()))
+ (end (if (equal? (list-ref true (- true-len 1))
+ (list-ref false (- false-len 1)))
+ (list (list-ref true (- true-len 1)))
+ ())))
+ (when (or (pair? start)
+ (pair? end))
+ (let ((new-true (cdr true))
+ (new-false (cdr false)))
+ (when (pair? end)
+ (set! new-true (copy new-true (make-list (- true-len 2))))
+ (set! new-false (copy new-false (make-list (- false-len 2)))))
+ (when (pair? start)
+ (set! new-true (cdr new-true))
+ (set! new-false (cdr new-false)))
+ (set! new-true (if (null? (cdr new-true))
+ (car new-true)
+ (cons 'begin new-true)))
+ (set! new-false (if (null? (cdr new-false))
+ (car new-false)
+ (cons 'begin new-false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(begin , at start
+ (if ,expr ,new-true ,new-false)
+ , at end)))))))))
+
+ (if (and (= suggestion made-suggestion) ; (if (not a) A B) -> (if a B A)
+ (not (= line-number last-if-line-number))
+ (= len 4)
+ (pair? expr)
+ (eq? (car expr) 'not)
+ (> (tree-leaves true) (tree-leaves false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,(cadr expr) ,false ,true))))
+
+ ;; this happens occasionally -- scarcely worth this much code! (gather copied vars outside the if)
+ ;; TODO: this should check that the gathered code does not affect the original test
+ (when (and (= len 4)
+ (pair? true)
+ (pair? false)
+ (eq? (car true) 'let)
+ (eq? (car false) 'let)
+ (pair? (cadr true))
+ (pair? (cadr false)))
+ (let ((true-vars (map car (cadr true)))
+ (false-vars (map car (cadr false)))
+ (shared-vars ()))
+ (for-each (lambda (v)
+ (if (and (memq v false-vars)
+ (equal? (cadr (assq v (cadr true)))
+ (cadr (assq v (cadr false)))))
+ (set! shared-vars (cons v shared-vars))))
+ true-vars)
+ (when (pair? shared-vars)
+ ;; now remake true/false lets (maybe nil) without shared-vars
+ (let ((ntv ())
+ (nfv ())
+ (sv ()))
+ (for-each (lambda (v)
+ (if (memq (car v) shared-vars)
+ (set! sv (cons v sv))
+ (set! ntv (cons v ntv))))
+ (cadr true))
+ (set! ntv (if (or (pair? ntv)
+ (pair? (cdddr true))) ; even define is safe here because outer let blocks it just as inner let used to
+ `(let (,@(reverse ntv)) ,@(cddr true))
+ (caddr true)))
+ (for-each (lambda (v)
+ (if (not (memq (car v) shared-vars))
+ (set! nfv (cons v nfv))))
+ (cadr false))
+ (set! nfv (if (or (pair? nfv)
+ (pair? (cdddr false)))
+ `(let (,@(reverse nfv)) ,@(cddr false))
+ (caddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(let (,@(reverse sv)) (if ,expr ,ntv ,nfv)))))))))
+
+ (if (and *report-one-armed-if*
+ (eq? false 'no-false)
+ (or (not (integer? *report-one-armed-if*))
+ (> (tree-leaves true) *report-one-armed-if*)))
+ (lint-format "~A~A~A perhaps ~A" caller
+ (if (integer? *report-one-armed-if*)
+ "this one-armed if is too big"
+ "")
+ (local-line-number test)
+ (if (integer? *report-one-armed-if*) ";" "")
+ (truncated-lists->string
+ form (if (and (pair? expr)
+ (eq? (car expr) 'not))
+ `(unless ,(cadr expr) ,@(unbegin true))
+ `(when ,expr ,@(unbegin true))))))
+
+ (if (symbol? expr)
+ (set-ref expr caller form env)
+ (lint-walk caller expr env))
+ (set! env (lint-walk caller true env))
+ (if (= len 4) (set! env (lint-walk caller false env))))))
+ env))
- (define (lambda-case)
- ;; ---------------- lambda ----------------
- ;; the lambda case includes stuff like call/cc?
- (let ((len (length form)))
- (if (< len 3)
- (begin
- (lint-format "~A is messed up in ~A" name head (truncated-list->string form))
- env)
- (let ((args (cadr form)))
-
- (if (list? args)
- (let ((arglen (length args)))
- (if (null? args)
- (if (eq? head 'lambda*) ; (lambda* ()...) -> (lambda () ...)
- (lint-format "lambda* could be lambda: ~A" name form))
- (begin ; args is a pair ; (lambda (a a) ...)
- (if (repeated-member? (proper-list args) env)
- (lint-format "~A parameter is repeated: ~A" name head (truncated-list->string args)))
- (if (eq? head 'lambda*) ; (lambda* (a :b) ...)
- (check-star-parameters name args)
- (if (list-any? keyword? args) ; (lambda (:key) ...)
- (lint-format "lambda arglist can't handle keywords (use lambda*)" name)))))
-
- (if (and (eq? head 'lambda) ; (lambda () (f)) -> f, (lambda (a b) (f a b)) -> f
- (= len 3)
- (>= arglen 0)) ; not a dotted list
- (let ((body (caddr form)))
- (when (and (pair? body)
- (symbol? (car body)))
- (if (equal? args (cdr body))
- (lint-format "perhaps ~A" name (lists->string form (car body)))
- (if (equal? (reverse args) (cdr body))
- (let ((rf (reversed (car body))))
- (if rf (lint-format "perhaps ~A" name (lists->string form rf))))))))))
-
- (if (and (symbol? args) ; (lambda args (apply f args)) -> f
- (eq? head 'lambda)
- (= len 3))
- (let ((body (caddr form)))
- (if (and (pair? body)
- (= (length body) 3)
- (eq? (car body) 'apply)
- (symbol? (cadr body))
- (eq? args (caddr body)))
- (lint-format "perhaps ~A" name (lists->string form (cadr body)))))))
-
- (lint-walk-function head name args (cddr form) form env)
- env))))
+ ;; -------- when, unless --------
+ ((when unless)
+ (if (< (length form) 3)
+ (begin
+ (lint-format "~A is messed up: ~A" caller head (truncated-list->string form))
+ env)
+ (let ((test (cadr form)))
+ (if (and (pair? test)
+ (eq? (car test) 'not))
+ (lint-format "perhaps ~A -> ~A"
+ caller
+ (truncated-list->string form)
+ (truncated-list->string `(,(if (eq? head 'when) 'unless 'when)
+ ,(cadr test)
+ ,@(cddr form)))))
+ (if (never-false test)
+ (lint-format "~A test is never false: ~A" caller head form)
+ (if (never-true test)
+ (lint-format "~A test is never true: ~A" caller head form)))
+
+ (if (symbol? test)
+ (set-ref test caller form env)
+ (if (pair? test)
+ (lint-walk caller test env)))
+
+ (if (and (pair? (cddr form)) ; (when t1 (if t2 A)) -> (when (and t1 t2) A)
+ (null? (cdddr form))
+ (pair? (caddr form)))
+ (let ((body (caddr form)))
+ (if (or (memq (car body) '(when unless))
+ (and (eq? (car body) 'if)
+ (pair? (cdr body))
+ (pair? (cddr body))
+ (null? (cdddr body))))
+ (let* ((inner-test (if (eq? (car body) 'unless)
+ `(not ,(cadr body))
+ (cadr body)))
+ (outer-test (if (eq? head 'unless)
+ `(not ,test)
+ test))
+ (new-test (simplify-boolean `(and ,outer-test ,inner-test) () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? new-test)
+ (eq? (car new-test) 'not))
+ `(unless ,(cadr new-test) ,@(cddr body))
+ `(when ,new-test ,@(cddr body)))))))))
+ (lint-walk-open-body caller head (cddr form) env))))
- (define (set-case)
- ;; ---------------- set! ----------------
- (if (not (= (length form) 3))
- (begin
- (lint-format "set! has too ~A arguments: ~S" name (if (> (length form) 3) "many" "few") form)
- env)
- (let ((settee (cadr form))
- (setval (caddr form)))
- (let ((result (lint-walk name setval env)))
- ;(format *stderr* "result: ~A, env: ~A~%" result env)
- (if (symbol? settee)
- (if (constant? settee)
- (lint-format "can't set! ~A (it is a constant)" name (truncated-list->string form)))
- (if (pair? settee)
+ ;; ---------------- cond ----------------
+ ((cond)
+ (let ((ctr 0)
+ (suggest made-suggestion)
+ (len (- (length form) 1)))
+ (if (negative? len)
+ (lint-format "cond is messed up: ~A" caller (truncated-list->string form))
+ (let ((exprs ())
+ (result :unset)
+ (has-else #f)
+ (has-combinations #f)
+ (simplifications ())
+ (prev-clause #f)
+ (all-eqv #t)
+ (eqv-select #f))
+
+ ;; (cond (A (and B C)) (else (and B D))) et al never happens
+ ;; ----------------
+ ;; if regular cond + else
+ ;; scan all return blocks
+ ;; if all one form, and either header or trailer always match,
+ ;; rewrite as header + cond|if + trailer
+ ;; given values and the presence of else, every possibility is covered
+ ;; at least (car result) has to match across all
+ (when (and (> len 1) ; (cond (else ...)) is handled elsewhere
+ (pair? (cdr form))
+ (pair? (cadr form))
+ (not (tree-set-member '(unquote #_{list}) form)))
+ (let ((first-clause (cadr form))
+ (else-clause (list-ref form len)))
+ (when (and (pair? (cdr first-clause))
+ (null? (cddr first-clause))
+ (pair? (cadr first-clause))
+ (pair? else-clause)
+ (memq (car else-clause) '(#t else))
+ (pair? (cdr else-clause))
+ (pair? (cadr else-clause))
+ (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
+ (escape? (cadr else-clause) env)))
+ (let ((first-result (cadr first-clause))
+ (first-func (caadr first-clause))
+ (else-error (escape? (cadr else-clause) env)))
+ (when (and (pair? (cdr first-result))
+ (not (eq? first-func 'values))
+ (or (not (hash-table-ref syntaces first-func))
+ (eq? first-func 'set!))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (pair? (cdadr c))
+ (or (equal? first-func (caadr c))
+ (and (eq? c else-clause)
+ else-error))))
+ (cddr form)))
+ ((lambda (header-len trailer-len result-min-len)
+ (when (and (or (not (eq? first-func 'set!))
+ (> header-len 1))
+ (or (not (eq? first-func '/))
+ (> header-len 1)
+ (> trailer-len 0)))
+ (let ((header (copy first-result (make-list header-len)))
+ (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
+ (if (= len 2)
+ (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
+ (lint-format "perhaps ~A" caller
+ (let ((else-result (cadr else-clause)))
+ (let ((first-mid-len (- (length first-result) header-len trailer-len))
+ (else-mid-len (- (length else-result) header-len trailer-len)))
+ (let ((fmid (if (= first-mid-len 1)
+ (list-ref first-result header-len)
+ `(values ,@(copy first-result (make-list first-mid-len) header-len))))
+ (emid (if else-error
+ else-result
+ (if (= else-mid-len 1)
+ (list-ref else-result header-len)
+ `(values ,@(copy else-result (make-list else-mid-len) header-len))))))
+ (lists->string form `(, at header (if ,(car first-clause) ,fmid ,emid) , at trailer)))))))
+ ;; len > 2 so use cond in the revision
+ (let ((middle (map (lambda (c)
+ (let ((test (car c))
+ (result (cadr c)))
+ (let ((mid-len (- (length result) header-len trailer-len)))
+ (if (and else-error
+ (eq? c else-clause))
+ else-clause
+ `(,test ,(if (= mid-len 1)
+ (list-ref result header-len)
+ `(values ,@(copy result (make-list mid-len) header-len))))))))
+ (cdr form))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(, at header (cond , at middle) , at trailer))))))))
+ (partition-form (cdr form) (if else-error (- len 1) len))))))))
+ ;; ----------------
+
+ (let ((falses ())
+ (trues ()))
+ (for-each
+ (lambda (clause)
+ (set! ctr (+ ctr 1))
+ (if (not (pair? clause))
+ (begin
+ (set! all-eqv #f)
+ (set! has-combinations #f)
+ (lint-format "cond clause ~A in ~A is not a pair?" caller clause (truncated-list->string form)))
(begin
- (if (memq (car settee) '(vector-ref list-ref string-ref hash-table-ref))
- (lint-format "~A as target of set!~A" name (car settee) (truncated-list->string form)))
- (lint-walk name settee env) ; this counts as a reference since it's by reference so to speak
- ;; try type check (dilambda signatures)
- (when (symbol? (car settee))
- (let ((f (symbol->value (car settee) *e*)))
- (when (dilambda? f)
- (let ((sig (procedure-signature (procedure-setter f)))
- (settee-len (length settee)))
- (when (and (pair? sig)
- (positive? settee-len)
- (pair? (list-tail sig settee-len)))
- (let ((checker (list-ref sig settee-len))
- (arg-type (->type setval)))
- (when (and (not (eq? 'symbol? arg-type))
- (symbol? checker)
- (not (compatible? checker arg-type)))
- (lint-format "~A: new value should be a~A ~A: ~S: ~A"
- name (car settee)
- (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
- checker arg-type
- (truncated-list->string form)))))))))
+ (when all-eqv
+ (unless eqv-select
+ (set! eqv-select (eqv-selector (car clause))))
+ (set! all-eqv (and eqv-select
+ (not (and (pair? (cdr clause))
+ (eq? (cadr clause) '=>))) ; case sends selector, but cond sends test result
+ (cond-eqv? (car clause) eqv-select #t))))
- (set! settee (do ((sym (car settee) (car sym)))
- ((not (pair? sym)) sym))))
- (lint-format "can't set! ~A" name (truncated-list->string form))))
-
- (when (symbol? settee) ; see do above
- (set-set? settee setval env))
- (if (equal? (cadr form) (caddr form)) ; not settee and setval here!
- (lint-format "pointless set!~A" name (truncated-list->string form)))
-
- result))))
-
- (define (quote-case)
- ;; ---------------- quote ----------------
- (let ((len (length form)))
- (if (negative? len)
- (lint-format "stray dot in quote's arguments? ~S" name form)
- (if (not (= len 2))
- (lint-format "quote has too ~A arguments: ~S"
- name
- (if (> (length form) 2) "many" "few")
- form)
- (if (and (< quote-warnings 20)
- (or (number? (cadr form))
- (boolean? (cadr form))
- (string? (cadr form))
- (vector? (cadr form))
- (null? (cadr form))
- (memq (cadr form) '(#<unspecified> #<undefined> #<eof>))))
- (begin
- (set! quote-warnings (+ quote-warnings 1))
- (lint-format "quote is not needed here: ~A~A"
- name (truncated-list->string form)
- (if (= quote-warnings 20) "; will ignore this error henceforth." "")))))))
- env)
+ (if (and prev-clause
+ (not has-combinations)
+ (> len 2)
+ (equal? (cdr clause) (cdr prev-clause)))
+ (if (memq (car clause) '(else #t)) ; (cond ... (x z) (else z)) -> (cond ... (else z))
+ (unless (side-effect? (car prev-clause) env)
+ (lint-format* caller
+ "this clause could be omitted: "
+ (truncated-list->string prev-clause)))
+ (set! has-combinations #t))) ; handle these later
+ (set! prev-clause clause)
+
+ (let ((expr (simplify-boolean (car clause) trues falses env))
+ (test (car clause))
+ (sequel (cdr clause)))
+ (if (not (equal? expr test))
+ (set! simplifications (cons (cons clause expr) simplifications)))
+
+ (cond ((memq test '(else #t))
+ (set! has-else #t)
+
+ (if (and (pair? sequel)
+ (eq? (car sequel) #<unspecified>))
+ (lint-format "this #<unspecified> is redundant: ~A" caller clause))
+
+ (if (and (pair? sequel) ; (cond (a A) (else (cond ...))) -> (cond (a A) ...)
+ (pair? (car sequel)) ; similarly for if, when, and unless
+ (null? (cdr sequel)))
+ (case (caar sequel)
+ ((cond)
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form (append (copy form (make-list ctr))
+ (cdar sequel)))))
+ ((if)
+ (let ((if-expr (car sequel)))
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form
+ (append (copy form (make-list ctr))
+ (if (= (length if-expr) 3)
+ (list (cdr if-expr))
+ `((,(cadr if-expr) ,@(unbegin (caddr if-expr)))
+ (else ,@(unbegin (cadddr if-expr))))))))))
+ ((when unless)
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form
+ (append (copy form (make-list ctr))
+ (if (eq? (caar sequel) 'when)
+ `((,(cadar sequel) ,@(cddar sequel)))
+ `(((not ,(cadar sequel)) ,@(cddar sequel)))))))))))
+ ((and (equal? test ''else)
+ (= ctr len))
+ (lint-format "odd cond clause test: is 'else supposed to be else? ~A" caller
+ (truncated-list->string clause)))
+
+ ((and (eq? test 't)
+ (= ctr len)
+ (not (var-member 't env)))
+ (lint-format "odd cond clause test: is t supposed to be #t? ~A" caller
+ (truncated-list->string clause))))
+
+ (if (never-false expr)
+ (if (not (= ctr len))
+ (lint-format "cond test ~A is never false: ~A" caller (car clause) (truncated-list->string form))
+ (if (not (or (memq expr '(#t else))
+ (side-effect? test env)))
+ (lint-format "cond last test could be #t: ~A" caller form)))
+ (if (never-true expr)
+ (lint-format "cond test ~A is never true: ~A" caller (car clause) (truncated-list->string form))))
+
+ (unless (side-effect? test env)
+ (if (and (not (memq test '(else #t)))
+ (pair? sequel)
+ (null? (cdr sequel)))
+ (cond ((equal? test (car sequel))
+ (lint-format "no need to repeat the test: ~A" caller (lists->string clause (list test))))
+
+ ((and (pair? (car sequel))
+ (pair? (cdar sequel))
+ (null? (cddar sequel))
+ (equal? test (cadar sequel)))
+ (lint-format "perhaps use => here: ~A" caller
+ (lists->string clause (list test '=> (caar sequel)))))
+
+ ((and (eq? (car sequel) #t)
+ (pair? test)
+ (not (memq (car test) '(or and)))
+ (eq? (return-type (car test) env) 'boolean?))
+ (lint-format "this #t could be omitted: ~A" caller (truncated-list->string clause)))))
+ (if (member test exprs)
+ (lint-format "cond test repeated: ~A" caller (truncated-list->string clause))
+ (set! exprs (cons test exprs))))
+
+ (if (boolean? expr)
+ (if (not expr)
+ (lint-format "cond test is always false: ~A" caller (truncated-list->string clause))
+ (if (not (= ctr len))
+ (lint-format "cond #t clause is not the last: ~A" caller (truncated-list->string form))))
+ (if (eq? test 'else)
+ (if (not (= ctr len))
+ (lint-format "cond else clause is not the last: ~A" caller (truncated-list->string form)))
+ (lint-walk caller test env)))
+
+ (if (and (symbol? expr)
+ (not (var-member expr env))
+ (procedure? (symbol->value expr *e*)))
+ (lint-format "strange cond test: ~A in ~A is a procedure" caller expr clause))
+
+ (if (eq? result :unset)
+ (set! result sequel)
+ (if (not (equal? result sequel))
+ (set! result :unequal)))
+
+ (cond ((not (pair? sequel))
+ (if (not (null? sequel)) ; (not (null?...)) here is correct -- we're looking for stray dots
+ (lint-format "cond clause is messed up: ~A" caller (truncated-list->string clause))))
+
+ ((not (eq? (car sequel) '=>))
+ (lint-walk-open-body caller head sequel env))
+
+ ((or (not (pair? (cdr sequel)))
+ (pair? (cddr sequel)))
+ (lint-format "cond => target is messed up: ~A" caller (truncated-list->string clause)))
+
+ (else (let ((f (cadr sequel)))
+ (if (symbol? f)
+ (let ((val (symbol->value f *e*)))
+ (when (procedure? val)
+ (if (not (aritable? val 1)) ; here values might be in test expr
+ (lint-format "=> target (~A) may be unhappy: ~A" caller f clause))
+ (let ((sig (procedure-signature val)))
+ (if (and (pair? sig)
+ (pair? (cdr sig)))
+ (let ((from-type (->lint-type expr))
+ (to-type (cadr sig)))
+ (if (not (or (memq from-type '(#f #t values))
+ (memq to-type '(#f #t values))
+ (any-compatible? to-type from-type)))
+ (lint-format "in ~A, ~A returns a ~A, but ~A expects ~A" caller
+ (truncated-list->string clause)
+ expr (prettify-checker-unq from-type)
+ f to-type)))))))
+ (if (and (pair? f)
+ (eq? (car f) 'lambda)
+ (pair? (cdr f))
+ (pair? (cadr f))
+ (not (= (length (cadr f)) 1)))
+ (lint-format "=> target (~A) may be unhappy: ~A" caller f clause)))
+ (lint-walk caller f env))))
+
+ (if (side-effect? expr env)
+ (begin
+ (set! falses ())
+ (set! trues ())
+ (set! result :unequal))
+ (begin
+ (if (not (member expr falses))
+ (set! falses (cons expr falses)))
+ (if (and (pair? expr)
+ (eq? (car expr) 'not)
+ (not (member (cadr expr) trues)))
+ (set! trues (cons (cadr expr) trues)))
+ (if (and (pair? expr)
+ (eq? (car expr) 'or))
+ (for-each (lambda (p)
+ (if (not (member p falses))
+ (set! falses (cons p falses))))
+ (cdr expr)))))))))
+ (cdr form))) ; for-each clause
+
+ (if has-else
+ (if (pair? result) ; all result clauses are the same (and not implicit)
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (null? (cdr result))
+ (car result)
+ `(begin , at result)))))
+ (let* ((last-clause (and (> len 1)
+ (list-ref form len)))
+ (clen (and (pair? last-clause)
+ (length last-clause)))
+ (last-res (and (number? clen)
+ (> clen 1)
+ (list-ref last-clause (- clen 1)))))
+ (if (and (pair? last-res)
+ (memq (car last-res) '(#t else)))
+ (lint-format "perhaps cond else clause is misplaced: ~A in ~A" caller last-res last-clause))))
+
+ (if (and (= len 2)
+ (not (check-bool-cond caller form (cadr form) (caddr form) env))
+ (pair? (cadr form)) ; (cond 1 2)!
+ (pair? (caddr form))
+ (equal? (simplify-boolean (caadr form) () () env)
+ (simplify-boolean `(not ,(caaddr form)) () () env)))
+ (lint-format "perhaps ~A" caller ; (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z))
+ (lists->string form `(cond ,(cadr form) (else ,@(cdaddr form))))))
+
+ (when has-combinations
+ (let ((new-clauses ())
+ (current-clauses ()))
+ (do ((clauses (cdr form) (cdr clauses)))
+ ((null? clauses)
+ (let ((len (length new-clauses)))
+ (if (not (and (= len 2) ; i.e. don't go to check-bool-cond
+ (check-bool-cond caller form (cadr new-clauses) (car new-clauses) env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form
+ (if all-eqv
+ (cond->case eqv-select (reverse new-clauses))
+ (if (and (= len 2) ; (cond (A) (B) (else C)) -> (or A B C)
+ (pair? (car new-clauses))
+ (memq (caar new-clauses) '(else #t))
+ (pair? (cadr new-clauses))
+ (pair? (caadr new-clauses))
+ (eq? (caaadr new-clauses) 'or)
+ (null? (cdadr new-clauses)))
+ (if (null? (cddar new-clauses))
+ `(or ,@(cdaadr new-clauses) ,(cadar new-clauses))
+ `(or ,@(cdaadr new-clauses) (begin ,@(cdar new-clauses))))
+ `(cond ,@(reverse new-clauses)))))))
+ (set! simplifications ())
+ (set! all-eqv #f)))
+
+ (let* ((clause (car clauses))
+ (result (cdr clause))) ; can be null in which case the test is the result
+ (cond ((and (pair? simplifications)
+ (assq clause simplifications))
+ => (lambda (e)
+ (set! clause (cons (cdr e) result)))))
+ (if (and (pair? (cdr clauses))
+ (equal? result (cdadr clauses)))
+ (set! current-clauses (cons clause current-clauses))
+ (if (pair? current-clauses)
+ (begin
+ (set! current-clauses (cons clause current-clauses))
+ (set! new-clauses (cons
+ (cons (simplify-boolean `(or ,@(map car (reverse current-clauses))) () () env)
+ result)
+ new-clauses))
+ (set! current-clauses ()))
+ (set! new-clauses (cons clause new-clauses))))))))
+
+ (when (and all-eqv
+ (> len (if has-else 2 1))) ; (cond (x y)) -- kinda dumb, but (if x y) isn't much shorter
+ (lint-format "perhaps use case instead of cond: ~A" caller
+ (lists->string form (cond->case eqv-select (cdr form)))))
+
+ (if (and (= len 2)
+ has-else
+ (null? (cdadr form)))
+ (let ((else-clause (if (null? (cddr (caddr form)))
+ (cadr (caddr form))
+ `(begin ,@(cdr (caddr form))))))
+ (lint-format "perhaps ~A" caller (lists->string form `(or ,(caadr form) ,else-clause)))))
+
+ ;; --------
+ (unless (or has-combinations all-eqv)
+ ;; look for repeated ((op x c1) c2) -> ((assoc x '((c1 . c2)...)) => cdr) anywhere in the clause list
+ (let ((nc ())
+ (op #f)
+ (c #f)
+ (start #f)
+ (changed #f))
+
+ (define (car-with-expr cls)
+ (cond ((and (pair? simplifications)
+ (assq cls simplifications))
+ => (lambda (e)
+ (set! changed #t)
+ (cons (cdr e) (cdr cls))))
+ (else cls)))
+
+ (define (start-search clauses test)
+ (if (code-constant? (cadr test))
+ (if (memq (car test) '(= string=? string-ci=? eq? eqv? equal? char=? char-ci=?))
+ (set! c caddr))
+ (if (code-constant? (caddr test))
+ (set! c cadr)))
+ (if c
+ (begin
+ (set! start clauses)
+ (set! op (car test)))
+ (set! nc (cons (car-with-expr (car clauses)) nc))))
+
+ (do ((clauses (cdr form) (cdr clauses)))
+ ((or (null? clauses)
+ (not (pair? (car clauses))))
+ (if (and changed
+ (null? clauses))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(cond ,@(reverse nc))))))
+ (let* ((test (caar clauses))
+ (result (cdar clauses))
+ (ok-but-at-end #f)
+ (looks-ok (and (pair? test)
+ (pair? (cdr test))
+ (pair? (cddr test))
+ (null? (cdddr test))
+ (pair? result)
+ (null? (cdr result))
+ (not (symbol? (car result)))
+ (or (not (pair? (car result))) ; quoted lists look bad in this context
+ (and (eq? (caar result) 'quote)
+ (not (pair? (cadar result))))))))
+ (if (not start)
+ (if (and looks-ok
+ (not (null? (cdr clauses))))
+ (start-search clauses test)
+ (set! nc (cons (car-with-expr (car clauses)) nc)))
+
+ (when (or (not looks-ok)
+ (not (eq? (car test) op))
+ (not (equal? (c test) (c (caar start))))
+ (not (code-constant? ((if (eq? c cadr) caddr cadr) test)))
+ (set! ok-but-at-end (null? (cdr clauses))))
+
+ (if (eq? (cdr start) clauses) ; only one item in the block, or two but it's just two at the end
+ (begin
+ (set! nc (cons (car start) nc))
+ (if (and looks-ok
+ (not (null? (cdr clauses))))
+ (start-search clauses test)
+ (begin
+ (set! start #f)
+ (set! nc (cons (car-with-expr (car clauses)) nc)))))
+
+ ;; multiple hits -- can we combine them?
+ (let ((alist ())
+ (cc (if (eq? c cadr) caddr cadr)))
+ (set! changed #t)
+ (do ((sc start (cdr sc)))
+ ((if ok-but-at-end
+ (null? sc)
+ (eq? sc clauses))
+ (case op
+ ((eq?)
+ (set! nc (cons `((assq ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
+
+ ((eqv? char=?)
+ (set! nc (cons `((assv ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
+
+ ((equal?)
+ (set! nc (cons `((assoc ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
+
+ ((string=?)
+ ;; this is probably faster than assoc + string=?, but it creates symbols
+ (let ((nlst (map (lambda (c)
+ (cons (string->symbol (car c)) (cdr c)))
+ alist)))
+ (set! nc (cons `((assq (string->symbol ,(c (caar start))) ',(reverse nlst)) => cdr) nc))))
+
+ (else
+ (set! nc (cons `((assoc ,(c (caar start)) ',(reverse alist) ,op) => cdr) nc)))))
+
+ (set! alist (cons (cons (unquoted (cc (caar sc))) (unquoted (cadar sc))) alist)))
+
+ (if (and looks-ok
+ (not (null? (cdr clauses))))
+ (start-search clauses test)
+ (begin
+ (set! start #f)
+ (set! nc (cons (car-with-expr (car clauses)) nc))))))))))))
+ ;; --------
+
+ (when (pair? (cadr form))
+ (if (= len 1)
+ (let ((clause (cadr form))) ; (cond (a)) -> a, (cond (a b)) -> (if a b) etc
+ (if (null? (cdr clause))
+ (lint-format "perhaps ~A" caller (lists->string form (car clause)))
+ (if (and (not (eq? (cadr clause) '=>))
+ (or (pair? (cddr clause))
+ (= suggest made-suggestion)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cddr clause))
+ `(if ,(car clause) ,(cadr clause))
+ (if (and (pair? (car clause))
+ (eq? (caar clause) 'not))
+ `(unless ,@(cdar clause) ,@(cdr clause))
+ `(when ,(car clause) ,@(cdr clause)))))))))
+ (when has-else ; len > 1 here
+ (let ((last-clause (list-ref form (- len 1)))) ; not the else branch! -- just before it.
+ (when (and (= len 3)
+ (equal? (cdadr form) (cdr (list-ref form len)))
+ (pair? (cdaddr form))
+ (not (eq? (cadr (caddr form)) '=>)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((A (caadr form))
+ (a (cdadr form))
+ (B (caaddr form))
+ (b (cdaddr form)))
+ (let ((nexpr (simplify-boolean `(or ,A (not ,B)) () () env)))
+ (cond ((not (and (null? (cdr a))
+ (null? (cdr b))))
+ `(cond (,nexpr , at a) (else , at b)))
+
+ ((eq? (car a) #t)
+ (if (not (car b))
+ nexpr
+ (simplify-boolean `(or ,nexpr ,(car b)) () () env)))
+
+ ((car a)
+ `(if ,nexpr ,(car a) ,(car b)))
+
+ ((eq? (car b) #t)
+ (simplify-boolean `(not ,nexpr) () () env))
+
+ (else (simplify-boolean `(and (not ,nexpr) ,(car b)) () () env))))))))
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (if (and (pair? arg1)
+ (pair? arg2)
+ (pair? (car arg1))
+ (eq? (caar arg1) 'and)
+ (pair? (cdr arg1))
+ (null? (cddr arg1))
+ (pair? (cdr arg2))
+ (null? (cddr arg2))
+ (member (car arg2) (cdar arg1))
+ (= (length (cdar arg1)) 2))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond (,(car arg2)
+ (if ,(if (equal? (car arg2) (cadar arg1)) (caddar arg1) (cadar arg1))
+ ,(cadr arg1)
+ ,(cadr arg2)))
+ ,@(cdddr form)))))
+
+ (if (and (= len 2) ; (cond ((not A) B) (else C)) -> (if A C B)
+ (pair? arg1)
+ (pair? (car arg1))
+ (eq? (caar arg1) 'not)
+ (pair? (cdr arg2))
+ (> (tree-leaves (cdr arg1)) (tree-leaves (cdr arg2))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (null? (cddr arg1))
+ (null? (cddr arg2)))
+ `(if ,(cadar arg1) ,(cadr arg2) ,(cadr arg1))
+ `(cond (,(cadar arg1) ,@(cdr arg2)) (else ,@(cdr arg1))))))))
+
+
+ (if (and (pair? last-clause) ; (cond ... ((or ...)) (else ...)) -> (cond ... (else (or ... ...)))
+ (pair? (car last-clause))
+ (null? (cdr last-clause))
+ (eq? (caar last-clause) 'or))
+ (let* ((e (list-ref form len))
+ (else-clause (if (null? (cddr e))
+ (cadr e)
+ `(begin ,@(cdr e)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list (- len 2)))
+
+ (else (or ,@(cdar last-clause) ,else-clause))))))))))
+
+ (let ((last-clause (list-ref form (if has-else (- len 1) len)))) ; not the else branch! -- just before it.
+ (if (and (pair? last-clause) ; (cond ... (A (cond ...)) (else B)) -> (cond ... ((not A) B) ...)
+ (pair? (cdr last-clause))
+ (null? (cddr last-clause))
+ (pair? (cadr last-clause))
+ (memq (caadr last-clause) '(if cond)))
+ (let ((new-test (simplify-boolean `(not ,(car last-clause)) () () env))
+ (new-result (if has-else
+ (cdr (list-ref form len))
+ (if (eq? form lint-mid-form)
+ ()
+ (list #<unspecified>)))))
+ (if (eq? (caadr last-clause) 'cond)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
+ (,new-test , at new-result)
+ ,@(cdadr last-clause))))
+ (if (= (length (cadr last-clause)) 4)
+ (let ((if-form (cadr last-clause)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
+ (,new-test , at new-result)
+ (,(cadr if-form) ,@(unbegin (caddr if-form)))
+ (else ,@(unbegin (cadddr if-form))))))))))
+ (when (> len 2) ; rewrite nested conds as one cond
+ (let ((lim (if has-else (- len 2) len))
+ (tlen (tree-leaves form)))
+ (when (< tlen 200)
+ (set! tlen (/ tlen 4))
+ (do ((i 0 (+ i 1))
+ (k (+ lim 1) (- k 1))
+ (p (cdr form) (cdr p)))
+ ((or (not (pair? p))
+ (= i lim)))
+ (let ((nc (car p)))
+ (if (and (pair? nc)
+ (pair? (cdr nc))
+ (null? (cddr nc))
+ (pair? (cadr nc))
+ (eq? (caadr nc) 'cond)
+ (>= (length (cdadr nc)) (* 2 k))
+ (> (tree-leaves nc) tlen))
+ (let ((new-test (simplify-boolean `(not ,(car nc)) () () env))
+ (new-result (if (and has-else
+ (= i (- lim 1))
+ (null? (cddadr p))
+ (null? (cddr (caddr p))))
+ `(if ,(caadr p) ,(cadadr p) ,(cadr (caddr p)))
+ `(cond ,@(cdr p)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list i))
+ (,new-test ,new-result)
+ ,@(cdadr nc))))))))))))))))
+ env))
- (define (cond-case)
- ;; ---------------- cond ----------------
- (let ((ctr 0)
- (len (- (length form) 1)))
- (if (negative? len)
- (lint-format "cond is messed up: ~A" name (truncated-list->string form))
- (let ((exprs ())
- (result :unset)
- (has-else #f)
- (has-combinations #f)
- (falses ())
- (prev-clause #f))
- (for-each
- (lambda (clause)
- (set! ctr (+ ctr 1))
+ ;; ---------------- case ----------------
+ ((case)
+ ;; here the keys are not evaluated, so we might have a list like (letrec define ...)
+ ;; also unlike cond, only 'else marks a default branch (not #t)
+
+ (if (< (length form) 3)
+ (lint-format "case is messed up: ~A" caller (truncated-list->string form))
+ (let ((sel-type #t)
+ (selector (cadr form))
+ (suggest made-suggestion))
+
+ ;; ----------------
+ ;; if regular case + else -- just like cond above
+ (let ((len (- (length form) 2))) ; number of clauses
+ (when (and (> len 1) ; (case x (else ...)) is handled elsewhere
+ (pair? (cdr form))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (not (tree-set-member '(unquote #_{list}) form)))
+ (let ((first-clause (caddr form))
+ (else-clause (list-ref form (+ len 1))))
+ (when (and (pair? (cdr first-clause))
+ (null? (cddr first-clause))
+ (pair? (cadr first-clause))
+ (pair? else-clause)
+ (eq? (car else-clause) 'else)
+ (pair? (cdr else-clause))
+ (pair? (cadr else-clause))
+ (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
+ (escape? (cadr else-clause) env)))
+ (let ((first-result (cadr first-clause))
+ (first-func (caadr first-clause))
+ (else-error (escape? (cadr else-clause) env)))
+ (when (and (pair? (cdr first-result))
+ (not (eq? first-func 'values))
+ (or (not (hash-table-ref syntaces first-func))
+ (eq? first-func 'set!))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (pair? (cdadr c))
+ (or (equal? first-func (caadr c))
+ (and (eq? c else-clause)
+ else-error))))
+ (cdddr form)))
+
+ ((lambda (header-len trailer-len result-mid-len)
+ (when (and (or (not (eq? first-func 'set!))
+ (> header-len 1))
+ (or (not (eq? first-func '/))
+ (> header-len 1)
+ (> trailer-len 0)))
+ (let ((header (copy first-result (make-list header-len)))
+ (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
+ (if (= len 2)
+ (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
+ (lint-format "perhaps ~A" caller
+ (let ((else-result (cadr else-clause)))
+ (let ((first-mid-len (- (length first-result) header-len trailer-len))
+ (else-mid-len (- (length else-result) header-len trailer-len)))
+ (let* ((fmid (if (= first-mid-len 1)
+ (list-ref first-result header-len)
+ `(values ,@(copy first-result (make-list first-mid-len) header-len))))
+ (emid (if else-error
+ else-result
+ (if (= else-mid-len 1)
+ (list-ref else-result header-len)
+ `(values ,@(copy else-result (make-list else-mid-len) header-len)))))
+ (middle (if (= (length (car first-clause)) 1)
+ `(eqv? ,(cadr form) ,(caar first-clause))
+ `(memv ,(cadr form) ',(car first-clause)))))
+ (lists->string form `(, at header (if ,middle ,fmid ,emid) , at trailer)))))))
+ ;; len > 2 so use case in the revision
+ (let ((middle (map (lambda (c)
+ (let ((test (car c))
+ (result (cadr c)))
+ (let ((mid-len (- (length result) header-len trailer-len)))
+ (if (and else-error
+ (eq? c else-clause))
+ else-clause
+ `(,test ,(if (= mid-len 1)
+ (list-ref result header-len)
+ `(values ,@(copy result (make-list mid-len) header-len))))))))
+ (cddr form))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(, at header (case ,(cadr form) , at middle) , at trailer))))))))
+ (partition-form (cddr form) (if else-error (- len 1) len)))))))))
+ ;; ----------------
+
+ (when (= suggest made-suggestion)
+ (let ((clauses (cddr form))) ; (case x ((a) #t) (else #f)) -> (eq? x 'a) -- this stuff actually happens!
+ (if (null? (cdr clauses))
+ (let ((clause (car clauses)))
+ (when (and (pair? clause)
+ (pair? (car clause))
+ (pair? (cdr clause)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((test (cond ((pair? (cdar clause))
+ `(memv ,(cadr form) ',(car clause)))
+ ((and (symbol? (caar clause))
+ (not (keyword? (caar clause))))
+ `(eq? ,(cadr form) ',(caar clause)))
+ ((or (keyword? (caar clause))
+ (null? (caar clause)))
+ `(eq? ,(cadr form) ,(caar clause)))
+ ((not (boolean? (caar clause)))
+ `(eqv? ,(cadr form) ,(caar clause)))
+ ((caar clause)
+ (cadr form))
+ (else `(not ,(cadr form)))))
+ (op (if (and (pair? (cdr clause))
+ (pair? (cddr clause)))
+ 'when 'if)))
+ `(,op ,test ,@(cdr clause)))))))
+ (when (and (null? (cddr clauses))
+ (pair? (car clauses))
+ (pair? (cadr clauses))
+ (eq? (caadr clauses) 'else)
+ (pair? (cdar clauses))
+ (pair? (cdadr clauses))
+ (null? (cddar clauses))
+ (null? (cddadr clauses))
+ (not (equal? (cadadr clauses) (cadar clauses))))
+ (let* ((akey (null? (cdaar clauses)))
+ (keylist (if akey (caaar clauses) (caar clauses)))
+ (quoted (or (not akey) (symbol? keylist)))
+ (op (if (every? symbol? (caar clauses))
+ (if akey 'eq? 'memq)
+ (if akey 'eqv? 'memv))))
+ ;; can't use '= or 'char=? here because the selector may return anything
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (cond ((and (memq (cadar clauses) '(#f #t))
+ (memq (cadadr clauses) '(#f #t)))
+ (if (cadadr clauses)
+ (if quoted
+ `(not (,op ,selector ',keylist))
+ `(not (,op ,selector ,keylist)))
+ (if quoted
+ `(,op ,selector ',keylist)
+ `(,op ,selector ,keylist))))
+ ((not (cadadr clauses)) ; (else #f) happens a few times
+ (simplify-boolean
+ (if quoted
+ `(and (,op ,selector ',keylist) ,(cadar clauses))
+ `(and (,op ,selector ,keylist) ,(cadar clauses)))
+ () () env))
+ (quoted
+ `(if (,op ,selector ',keylist) ,(cadar clauses) ,(cadadr clauses)))
+ (else `(if (,op ,selector ,keylist) ,(cadar clauses) ,(cadadr clauses)))))))))))
+
+ (if (and (not (pair? selector))
+ (constant? selector))
+ (lint-format "case selector is a constant: ~A" caller (truncated-list->string form)))
+ (if (symbol? selector)
+ (set-ref selector caller form env)
+ (lint-walk caller selector env))
+ (if (and (pair? selector)
+ (symbol? (car selector)))
+ (begin
+ (set! sel-type (return-type (car selector) env))
+ (if (and (symbol? sel-type)
+ (not (memq sel-type selector-types)))
+ (lint-format "case selector may not work with eqv: ~A" caller (truncated-list->string selector)))))
+
+ (let ((all-keys ())
+ (all-exprs ())
+ (ctr 0)
+ (result :unset)
+ (exprs-repeated #f)
+ (else-foldable #f)
+ (has-else #f)
+ (len (length (cddr form))))
+ (for-each
+ (lambda (clause)
+ (set! ctr (+ ctr 1))
+ (if (not (pair? clause))
+ (lint-format "case clause should be a list: ~A" caller (truncated-list->string clause))
+ (let ((keys (car clause))
+ (exprs (cdr clause)))
+ (if (null? exprs)
+ (lint-format "clause result is missing: ~A" caller clause))
+ (if (eq? result :unset)
+ (set! result exprs)
+ (if (not (equal? result exprs))
+ (set! result :unequal)))
+ (if (member exprs all-exprs)
+ (set! exprs-repeated exprs)
+ (set! all-exprs (cons exprs all-exprs)))
+ (if (and (pair? exprs)
+ (null? (cdr exprs))
+ (pair? (car exprs))
+ (pair? (cdar exprs))
+ (null? (cddar exprs))
+ (equal? selector (cadar exprs)))
+ (lint-format "perhaps use => here: ~A" caller
+ (lists->string clause (list keys '=> (caar exprs)))))
+ (if (pair? keys)
+ (if (not (proper-list? keys))
+ (lint-format (if (null? keys)
+ "null case key list: ~A"
+ "stray dot in case case key list: ~A")
+ caller (truncated-list->string clause))
+ (for-each
+ (lambda (key)
+ (if (or (vector? key)
+ (string? key)
+ (pair? key)
+ (hash-table? key))
+ (lint-format "case key ~S in ~S is unlikely to work (case uses eqv?)" caller key clause))
+ (if (member key all-keys)
+ (lint-format "repeated case key ~S in ~S" caller key clause)
+ (set! all-keys (cons key all-keys)))
+ ;; unintentional quote here, as in (case x ('a b)...) never happens and
+ ;; is hard to distinguish from (case x ((quote a) b)...) which happens a lot
+ (if (not (compatible? sel-type (->lint-type key)))
+ (lint-format "case key ~S in ~S is pointless" caller key clause)))
+ keys))
+ (if (not (eq? keys 'else))
+ (lint-format "bad case key ~S in ~S" caller keys clause)
+ (begin
+ (set! has-else clause)
+ ;; exprs: (res) or if case, ((case ...)...)
+ (if (not (= ctr len))
+ (lint-format "case else clause is not the last: ~A"
+ caller
+ (truncated-list->string (cddr form)))
+ (and (pair? exprs)
+ (pair? (car exprs))
+ (null? (cdr exprs))
+ (case (caar exprs)
+ ((case) ; just the case statement in the else clause
+ (and (equal? selector (cadar exprs))
+ (not (side-effect? selector env))
+ (set! else-foldable (cddar exprs))))
+ ((if) ; just if -- if foldable, make it look like it came from case
+ (and (equal? selector (eqv-selector (cadar exprs)))
+ (cond-eqv? (cadar exprs) selector #t)
+ (not (side-effect? selector env))
+ ;; else-foldable as (((keys-from-test) true-branch) (else false-branch))
+ (set! else-foldable
+ (if (pair? (cdddar exprs))
+ `(,(case-branch (cadar exprs) selector (list (caddar exprs)))
+ (else ,(car (cdddar exprs))))
+ (list (case-branch (cadar exprs) selector (cddar exprs)))))))
+ (else #f)))))))
+ (lint-walk-open-body caller head exprs env))))
+ (cddr form))
+
+ (if (and has-else
+ (pair? result)
+ (not else-foldable))
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (null? (cdr result))
+ (car result)
+ `(begin , at result))))
+ (set! exprs-repeated #f)))
+
+ (when (or exprs-repeated else-foldable)
+ (let ((new-keys-and-exprs ())
+ (mergers ())
+ (else-clause (if else-foldable
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (c) (if (eq? (car c) 'else) (return c))) else-foldable)
+ ()))
+ (or has-else ()))))
+
+ (define merge-case-keys
+ (let ((else-exprs (and (pair? else-clause) (cdr else-clause))))
+ (define (a-few lst)
+ (if (> (length lst) 3)
+ (copy lst (make-list 4 '...) 0 3)
+ lst))
+ (lambda (clause)
+ (let ((keys (car clause))
+ (exprs (cdr clause)))
+ (when (and (pair? exprs) ; ignore clauses that are messed up
+ (not (eq? keys 'else))
+ (not (equal? exprs else-exprs)))
+ (let ((prev (member exprs new-keys-and-exprs (lambda (a b) (equal? a (cdr b))))))
+ (if prev
+ (let* ((cur-clause (car prev))
+ (cur-keys (car cur-clause)))
+ (when (pair? cur-keys)
+ (set! mergers (cons (list (a-few keys) (a-few cur-keys)) mergers))
+ (set-car! cur-clause
+ (append cur-keys
+ (map (lambda (key)
+ (if (memv key cur-keys) (values) key))
+ keys)))))
+ (set! new-keys-and-exprs (cons (cons (copy (car clause)) (cdr clause)) new-keys-and-exprs)))))))))
- (if (and prev-clause
- (not has-combinations)
- (> len 2)
- (pair? clause)
- (equal? (cdr clause) (cdr prev-clause)))
- (if (memq (car clause) '(else #t)) ; (cond ... (x z) (else z)) -> (cond ... (else z))
- (if (not (side-effect? (car prev-clause) env))
- (lint-format "this clause could be omitted: ~A" name prev-clause))
- (set! has-combinations #t))) ; handle these later
- (set! prev-clause clause)
+ (for-each merge-case-keys (cddr form))
+ (if (pair? else-foldable)
+ (for-each merge-case-keys else-foldable))
- (if (not (pair? clause))
+ (if (null? new-keys-and-exprs)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (or (null? else-clause) ; can this happen? (it's caught above as an error)
+ (null? (cdr else-clause)))
+ ()
+ (if (null? (cddr else-clause))
+ (cadr else-clause)
+ `(begin ,@(cdr else-clause))))))
(begin
- (lint-format "cond clause is messed up: ~A" name (truncated-list->string clause))
- (set! has-combinations #f))
+ ;; (null? (cdr new-keys-and-exprs)) is rare and kinda dumb -- cases look like test suite entries
+ (for-each
+ (lambda (clause)
+ (if (and (pair? (car clause))
+ (pair? (cdar clause)))
+ (if (every? integer? (car clause))
+ (set-car! clause (sort! (car clause) <))
+ (if (every? char? (car clause))
+ (set-car! clause (sort! (car clause) char<?))))))
+ new-keys-and-exprs)
+ (let ((new-form (if (pair? else-clause)
+ `(case ,(cadr form) ,@(reverse new-keys-and-exprs) ,else-clause)
+ `(case ,(cadr form) ,@(reverse new-keys-and-exprs)))))
+ (lint-format "perhaps ~A" caller
+ (if (pair? mergers)
+ (format #f "merge keys ~{~{~A with ~A~}~^, ~}: ~A"
+ (reverse mergers)
+ (lists->string form new-form))
+ (lists->string form new-form)))))))))))
+ env)
+
+ ;; ---------------- do ----------------
+ ((do)
+ (let ((vars ()))
+ (if (not (and (>= (length form) 3)
+ (proper-list? (cadr form))
+ (proper-list? (caddr form))))
+ (lint-format "do is messed up: ~A" caller (truncated-list->string form))
+
+ (let ((step-vars (cadr form))
+ (inner-env #f))
+
+ (define (var-step v) ((cdr v) 'step))
+
+ (if (not (side-effect? form env))
+ (let ((end+result (caddr form)))
+ (if (or (not (pair? end+result))
+ (null? (cdr end+result)))
+ (lint-format "this do-loop could be replaced by (): ~A" caller (truncated-list->string form))
+ (if (and (null? (cddr end+result))
+ (code-constant? (cadr end+result)))
+ (lint-format "this do-loop could be replaced by ~A: ~A" caller (cadr end+result) (truncated-list->string form))))))
+
+ ;; walk the init forms before adding the step vars to env
+ (do ((bindings step-vars (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "do variable list is not a proper list? ~S" caller step-vars)))
+ (when (binding-ok? caller head (car bindings) env #f)
+ (for-each (lambda (v)
+ (if (and (not (eq? (var-initial-value v) (var-name v)))
+ (tree-memq (var-name v) (cadar bindings))
+ (not (hash-table-ref built-in-functions (var-name v)))
+ (not (tree-table-member binders (cadar bindings))))
+ (if (not (var-member (var-name v) env))
+ (lint-format "~A in ~A does not appear to be defined in the calling environment" caller
+ (var-name v) (car bindings))
+ (lint-format "~A in ~A refers to the caller's ~A, not the do-loop variable" caller
+ (var-name v) (car bindings) (var-name v)))))
+ vars)
+
+ (lint-walk caller (cadar bindings) env)
+ (set! vars (cons (let ((v (make-var :name (caar bindings)
+ :definer 'do
+ :initial-value (cadar bindings))))
+ (let ((stepper (and (pair? (cddar bindings)) (caddar bindings))))
+ (varlet (cdr v) :step stepper)
+ (if stepper (set! (var-history v) (cons (list 'set! (caar bindings) stepper) (var-history v)))))
+ v)
+ vars))))
+
+ (set! inner-env (append vars env))
+
+ ;; walk the step exprs
+ (let ((baddies ())) ; these are step vars (with step exprs) used within other step vars step expressions
+ (do ((bindings step-vars (cdr bindings)))
+ ((not (pair? bindings)))
+ (let ((stepper (car bindings))) ; the entire binding: '(i 0 (+ i 1))
+ (when (and (binding-ok? caller head stepper env #t)
+ (pair? (cddr stepper)))
+ (let ((data (var-member (car stepper) vars)))
+ (let ((old-ref (var-ref data)))
+ (lint-walk caller (caddr stepper) inner-env)
+ (set! (var-ref data) old-ref))
+ (if (eq? (car stepper) (caddr stepper)) ; (i 0 i) -> (i 0)
+ (lint-format "perhaps ~A" caller (lists->string stepper (list (car stepper) (cadr stepper)))))
+ ;; pointless caddr here happens very rarely
+ (set! (var-set data) (+ (var-set data) 1))) ; (pair? cddr) above
+ (when (and (pair? (caddr stepper))
+ (not (eq? (car stepper) (cadr stepper))) ; (lst lst (cdr lst))
+ (eq? (car (caddr stepper)) 'cdr)
+ (eq? (cadr stepper) (cadr (caddr stepper))))
+ (lint-format "this looks suspicious: ~A" caller stepper))
+ (for-each (lambda (v)
+ (if (and (var-step v)
+ (not (eq? (var-name v) (car stepper)))
+ (or (eq? (var-name v) (caddr stepper))
+ (and (pair? (caddr stepper))
+ (tree-unquoted-member (var-name v) (caddr stepper)))))
+ (set! baddies (cons (car stepper) baddies))))
+ vars))))
+
+ (check-unordered-exprs caller form (map var-initial-value vars) env)
+
+ (when (pair? baddies)
+ ;; (do ((i 0 j) (j ...))...) is unreadable -- which (binding of) j is i set to?
+ ;; but this is tricky if there is more than one such variable -- if cross links, we'll need named let
+ ;; and if no step expr, there's no confusion.
+ ;; (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4)) (format *stderr* "~A ~A~%" i j))
+ ;; (let __1__ ((i 0) (j 1) (k 0)) (if (= k 4) () (begin (format *stderr* "~A ~A~%" i j) (__1__ j i (+ k 1)))))
+ (let ((new-steppers (map (lambda (stepper)
+ (if (memq (car stepper) baddies)
+ `(,(car stepper) ,(cadr stepper))
+ stepper))
+ step-vars))
+ (new-sets (map (lambda (stepper)
+ (if (memq (car stepper) baddies)
+ `(set! ,(car stepper) ,(caddr stepper))
+ (values)))
+ step-vars)))
+ (if (or (null? (cdr baddies))
+ (let ((trails new-sets))
+ (not (any? (lambda (v) ; for each baddy, is it used in any following set!?
+ (and (pair? (cdr trails))
+ (set! trails (cdr trails))
+ (tree-unquoted-member v trails)))
+ (reverse baddies)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(do ,new-steppers
+ ,(caddr form)
+ ,@(cdddr form)
+ , at new-sets)))
+ (let* ((loop (find-unique-name form #f))
+ (test (if (pair? (caddr form))
+ (caaddr form)
+ ()))
+ (result (if (not (and (pair? (caddr form))
+ (pair? (cdaddr form))))
+ ()
+ (if (null? (cdr (cdaddr form)))
+ (car (cdaddr form))
+ `(begin ,@(cdaddr form)))))
+ (let-loop `(,loop ,@(map (lambda (s)
+ (if (pair? (cddr s))
+ (caddr s)
+ (car s)))
+ step-vars)))
+ (new-body (if (pair? (cdddr form))
+ `(begin ,@(cdddr form) ,let-loop)
+ let-loop)))
+ (lint-format "this do loop is unreadable; perhaps ~A" caller
+ (lists->string form
+ `(let ,loop ,(map (lambda (s)
+ (list (car s) (cadr s)))
+ step-vars)
+ (if ,test ,result ,new-body)))))))))
+
+ ;; walk the body and end stuff (it's too tricky to find infinite do loops)
+ (when (pair? (caddr form))
+ (let ((end+result (caddr form)))
+ (when (pair? end+result)
+ (let ((end (car end+result)))
+ (lint-walk caller end inner-env) ; this will call simplify-boolean
+ (if (pair? (cdr end+result))
+ (if (null? (cddr end+result))
+ (lint-walk caller (cadr end+result) inner-env)
+ (lint-walk-open-body caller 'do-result (cdr end+result) inner-env)))
+ (if (and (symbol? end) (memq end '(= > < >= <= null? not)))
+ (lint-format "perhaps missing parens: ~A" caller end+result))
+
+ (cond ((never-false end)
+ (lint-format "end test is never false: ~A" caller end))
+
+ (end ; it's not #f
+ (if (never-true end)
+ (lint-format "end test is never true: ~A" caller end)
+ (let ((v (and (pair? end)
+ (memq (car end) '(< > <= >=))
+ (pair? (cdr end))
+ (symbol? (cadr end))
+ (var-member (cadr end) vars))))
+ ;; if found, v is the var info
+ (when (pair? v)
+ (let ((step (var-step v)))
+ (when (pair? step)
+ (let ((inc (and (memq (car step) '(+ -))
+ (pair? (cdr step))
+ (pair? (cddr step))
+ (or (and (real? (cadr step)) (cadr step))
+ (and (real? (caddr step)) (caddr step))))))
+ (when (and (real? inc)
+ (case (car step)
+ ((+) (and (positive? inc)
+ (memq (car end) '(< <=))))
+ ((-) (and (positive? inc)
+ (memq (car end) '(> >=))))
+ (else #f)))
+ (lint-format "do step looks like it doesn't match end test: ~A" caller
+ (lists->string step end))))))))))
+ ((pair? (cdr end+result))
+ (lint-format "result is unreachable: ~A" caller end+result)))
+
+ (if (and (symbol? end)
+ (not (var-member end env))
+ (procedure? (symbol->value end *e*)))
+ (lint-format "strange do end-test: ~A in ~A is a procedure" caller end end+result))))))
+
+ (lint-walk-body caller head (cdddr form) inner-env)
+
+ ;; before report-usage, check for unused variables, and don't complain about them if
+ ;; they are referenced in an earlier step expr.
+ (do ((v vars (cdr v)))
+ ((null? v))
+ (let ((var (car v)))
+ (when (zero? (var-ref var))
+ ;; var was not seen in the end+result/body or any subsequent step exprs
+ ;; vars is reversed order, so we need only scan var-step of the rest
+ (if (side-effect? (var-step var) env)
+ (set! (var-ref var) (+ (var-ref var) 1))
+ (for-each
+ (lambda (nv)
+ (if (or (eq? (var-name var) (var-step nv))
+ (and (pair? (var-step nv))
+ (tree-unquoted-member (var-name var) (var-step nv))))
+ (set! (var-ref var) (+ (var-ref var) 1))))
+ (cdr v))))))
+ (report-usage caller head vars inner-env)
+
+ ;; look for constant expressions in the do body
+ (when *report-constant-expressions-in-do*
+ (let ((constant-exprs (find-constant-exprs 'do (map var-name vars) (cdddr form))))
+ (if (pair? constant-exprs)
+ (if (null? (cdr constant-exprs))
+ (lint-format "in ~A, ~A appears to be constant" caller
+ (truncated-list->string form)
+ (car constant-exprs))
+ (lint-format "in ~A, the following expressions appear to be constant:~%~NC~A" caller
+ (truncated-list->string form)
+ (+ lint-left-margin 4) #\space
+ (format #f "~{~A~^, ~}" constant-exprs))))))
+
+ ;; if simple lambda expanded and exists only for the loop, remove let as well?
+ ;; this can sometimes be simplified
+ (let ((body (cdddr form)))
+ (when (and (pair? body)
+ (null? (cdr body))
+ (pair? (car body)))
+ (let ((v (var-member (caar body) env)))
+ (when (and (var? v)
+ (memq (var-ftype v) '(define lambda)))
+ (let* ((vfunc (var-initial-value v))
+ (vbody (cddr vfunc)))
+ ;; we already detect a do body with no side-effects (walk-body)
+ (if (and (proper-list? (if (eq? (var-ftype v) 'define) (cdadr vfunc) (cadr vfunc)))
+ (null? (cdr vbody))
+ (< (tree-leaves vbody) 16))
+ (do ((pp (var-arglist v) (cdr pp)))
+ ((or (null? pp)
+ (> (tree-count1 (car pp) vbody 0) 1))
+ (when (null? pp)
+ (let ((new-body (copy vbody)))
+ (for-each (lambda (par arg)
+ (if (not (eq? par arg))
+ (set! new-body (tree-subst arg par new-body))))
+ (var-arglist v)
+ (cdar body))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(do ,(cadr form)
+ ,(caddr form)
+ , at new-body)))))))))))))
+
+ ;; check for do-loop as copy/fill! stand-in and other similar cases
+ (when (and (pair? vars)
+ (null? (cdr vars)))
+ (let ((end-test (and (pair? (caddr form)) (caaddr form)))
+ (first-var (caadr form))
+ (body (cdddr form))
+ (setv #f))
+ (when (and (pair? end-test)
+ (pair? body)
+ (null? (cdr body))
+ (pair? (car body))
+ (memq (car end-test) '(>= =)))
+ (let ((vname (car first-var))
+ (start (cadr first-var))
+ (step (and (pair? (cddr first-var))
+ (caddr first-var)))
+ (end (caddr end-test)))
+ (when (and step
+ (pair? step)
+ (eq? (car step) '+)
+ (memq vname step)
+ (memv 1 step)
+ (null? (cdddr step))
+ (or (eq? (cadr end-test) vname)
+ (and (eq? (car end-test) '=)
+ (eq? (caddr end-test) vname)
+ (set! end (cadr end-test)))))
+ ;; we have (do ((v start (+ v 1)|(+ 1 v))) ((= v end)|(= end v)|(>= v end)) one-statement)
+ (set! body (car body))
+ ;; write-char is the only other common case here -> write-string in a few cases
+ (when (and (memq (car body) '(vector-set! float-vector-set! int-vector-set! list-set! string-set! byte-vector-set!))
+ ;; integer type check here isn't needed because we're using this as an index below
+ ;; the type error will be seen in report-usage if not earlier
+ (eq? (caddr body) vname)
+ (let ((val (cadddr body)))
+ (set! setv val)
+ (or (code-constant? val)
+ (and (pair? val)
+ (memq (car val) '(vector-ref float-vector-ref int-vector-ref list-ref string-ref byte-vector-ref))
+ (eq? (caddr val) vname)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (code-constant? setv)
+ `(fill! ,(cadr body) ,(cadddr body) ,start ,end)
+ `(copy ,(cadr setv) ,(cadr body) ,start ,end))))))))))))
+ env))
+
+ ;; ---------------- let ----------------
+ ((let)
+ (if (or (< (length form) 3)
+ (not (or (symbol? (cadr form))
+ (list? (cadr form)))))
+ (lint-format "let is messed up: ~A" caller (truncated-list->string form))
+ (let ((named-let (and (symbol? (cadr form)) (cadr form))))
+ (if (keyword? named-let)
+ (lint-format "bad let name: ~A" caller named-let))
+ (unless named-let
+
+ (if (and (null? (cadr form)) ; this can be fooled by macros that define things
+ (eq? form lint-current-form) ; i.e. we're in a body?
+ (not (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
+ load eval eval-string require)
+ (cddr form))))
+ (lint-format "pointless let: ~A" caller (truncated-list->string form))
+
+ (let ((body (cddr form)))
+ (if (and (null? (cdr body))
+ (pair? (car body)))
+ (if (memq (caar body) '(let let*))
+ (if (null? (cadr form))
+ (lint-format "pointless let: ~A" caller (lists->string form (car body)))
+ (if (null? (cadar body))
+ (lint-format "pointless let: ~A" caller (lists->string form `(let ,(cadr form) ,@(cddar body))))))
+ (if (and (memq (caar body) '(lambda lambda*)) ; or any definer?
+ (null? (cadr form)))
+ (lint-format "pointless let: ~A" caller (lists->string form (car body)))))))))
+
+ (let ((vars (if (and named-let
+ (not (keyword? named-let))
+ (or (null? (caddr form))
+ (and (proper-list? (caddr form))
+ (every? pair? (caddr form)))))
+ (list (make-fvar :name named-let
+ :ftype head
+ :decl (dummy-func caller form (list 'define (cons '_ (map car (caddr form))) #f))
+ :arglist (map car (caddr form))
+ :initial-value form
+ :env env))
+ ()))
+ (varlist (if named-let (caddr form) (cadr form)))
+ (body (if named-let (cdddr form) (cddr form))))
+
+ (if (not (list? varlist))
+ (lint-format "let is messed up: ~A" caller (truncated-list->string form))
+ (if (and (null? varlist)
+ (pair? body)
+ (null? (cdr body))
+ (not (side-effect? (car body) env)))
+ (lint-format "perhaps ~A" caller (lists->string form (car body)))))
+
+ (do ((bindings varlist (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "let variable list is not a proper list? ~S" caller varlist)))
+ (when (binding-ok? caller head (car bindings) env #f)
+ (let ((val (cadar bindings)))
+ (if (and (pair? val)
+ (eq? 'lambda (car val))
+ (tree-car-member (caar bindings) val)
+ (not (var-member (caar bindings) env)))
+ (lint-format "let variable ~A is called in its binding? Perhaps let should be letrec: ~A"
+ caller (caar bindings)
+ (truncated-list->string bindings))
+ (unless named-let
+ (for-each (lambda (v)
+ (if (and (tree-memq (var-name v) (cadar bindings))
+ (not (hash-table-ref built-in-functions (var-name v)))
+ (not (tree-table-member binders (cadar bindings))))
+ (if (not (var-member (var-name v) env))
+ (lint-format "~A in ~A does not appear to be defined in the calling environment" caller
+ (var-name v) (car bindings))
+ (lint-format "~A in ~A refers to the caller's ~A, not the let variable" caller
+ (var-name v) (car bindings) (var-name v)))))
+ vars)))
+ (lint-walk caller val env)
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value val
+ :definer (if named-let 'named-let 'let))
+ vars)))))
+
+ (check-unordered-exprs caller form
+ (map (if (not named-let)
+ var-initial-value
+ (lambda (v)
+ (if (eq? (var-name v) named-let)
+ (values)
+ (var-initial-value v))))
+ vars)
+ env)
+
+ (let ((suggest made-suggestion))
+ (when (and (pair? varlist) ; (let ((x (A))) (if x (f x) B)) -> (cond ((A) => f) (else B)
+ (pair? (car varlist)) ; ^ this happens a lot, so it's worth this tedious search
+ (null? (cdr varlist)) ; also (let ((x (A))) (cond (x (f x))...)
+ (pair? body)
+ (null? (cdr body))
+ (pair? (cdar varlist))
+ (pair? (cadar varlist)))
+ (let ((p (car body))
+ (vname (caar varlist))
+ (vvalue (cadar varlist)))
+
+ (when (and (not named-let) ; (let ((x (assq a y))) (set! z (if x (cadr x) 0))) -> (set! z (cond ((assq a y) => cadr) (else 0)))
+ (pair? p)
+ (not (memq (car p) '(if cond)))
+ (= (tree-count2 vname p 0) 2))
+ (do ((i 0 (+ i 1))
+ (bp (cdr p) (cdr bp)))
+ ((or (null? bp)
+ (let ((b (car bp)))
+ (and (pair? b)
+ (eq? (car b) 'if)
+ (= (tree-count2 vname b 0) 2)
+ (eq? vname (cadr b))
+ (pair? (caddr b))
+ (pair? (cdaddr b))
+ (null? (cddr (caddr b)))
+ (eq? vname (cadr (caddr b))))))
+ (if (pair? bp)
+ (let ((else-clause (if (pair? (cdddar bp)) `((else ,@(cdddar bp))) ())))
+ (set! last-assoc-form (car bp))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,@(copy p (make-list (+ i 1)))
+ (cond (,vvalue => ,(caaddr (car bp))) , at else-clause)
+ ,@(cdr bp)))))))))
+ (when (and (pair? p)
+ (pair? (cdr p)))
+ (when (and (eq? (car p) 'cond) ; (let ((x (f y))) (cond (x (g x)) ...)) -> (cond ((f y) => g) ...)
+ (pair? (cadr p))
+ (eq? (caadr p) vname)
+ (pair? (cdadr p))
+ (null? (cddadr p))
+ (or (and (pair? (cadadr p))
+ (pair? (cdr (cadadr p)))
+ (null? (cddr (cadadr p))) ; one arg to func
+ (eq? vname (cadr (cadadr p))))
+ (eq? vname (cadadr p)))
+ (or (null? (cddr p))
+ (not (tree-unquoted-member vname (cddr p)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? vname (cadadr p))
+ (if (and (pair? (cddr p))
+ (pair? (caddr p))
+ (memq (caaddr p) '(else #t t)))
+ (if (null? (cddr (caddr p)))
+ `(or ,vvalue ,(cadr (caddr p)))
+ `(or ,vvalue (begin ,@(cdaddr p))))
+ `(or ,vvalue
+ (cond ,@(cddr p))))
+ `(cond (,vvalue => ,(caadr (cadr p)))
+ ,@(cddr p))))))
- (let ((expr (simplify-boolean (car clause) () falses env))
- (test (car clause))
- (sequel (cdr clause)))
+ (when (and (null? (cddr p)) ; (let ((x (+ y 1))) (abs x)) -> (abs (+ y 1))
+ (eq? vname (cadr p))) ; not tree-subst or trailing (pair) args because then the let might be forcing evaluation order
+ (let ((v (var-member (car p) env)))
+ (if (or (and (var? v)
+ (memq (var-definer v) '(define define* lambda lambda*)))
+ (hash-table-ref built-in-functions (car p)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(car p) ,vvalue)))
+ (if (not (or (any-macro? vname env)
+ (tree-unquoted-member vname (car p))))
+ (lint-format "perhaps, assuming ~A is not a macro, ~A" caller (car p)
+ (lists->string form `(,(car p) ,vvalue)))))))
+
+ (when (pair? (cddr p))
+ (when (and (pair? (cdddr p))
+ (eq? (car p) 'if))
+
+ (when (and (eq? (cadr p) vname) ; (let ((x (g y))) (if x #t #f)) -> (g y)
+ (boolean? (caddr p))
+ (boolean? (cadddr p))
+ (not (eq? (caddr p) (cadddr p))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if (caddr p) vvalue `(not ,vvalue)))))
+
+ (when (and (pair? (cadr p)) ; (let ((x (f y))) (if (not x) B (g x))) -> (cond ((f y) => g) (else B))
+ (eq? (caadr p) 'not)
+ (eq? (cadadr p) vname)
+ (pair? (cadddr p))
+ (pair? (cdr (cadddr p)))
+ (null? (cddr (cadddr p)))
+ (eq? vname (cadr (cadddr p))))
+ (let ((else-clause (if (eq? (caddr p) vname)
+ `((else #f))
+ (if (and (pair? (caddr p))
+ (tree-unquoted-member vname (caddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(caddr p)))))))
+ (unless (eq? else-clause :oops!)
+ (lint-format "perhaps ~A" caller (lists->string form `(cond (,vvalue => ,(car (cadddr p))) , at else-clause)))))))
- (when (memq test '(else #t))
- (set! has-else #t)
- (if (and (pair? sequel)
- (pair? (car sequel))
- (null? (cdr sequel))
- (eq? (caar sequel) 'cond))
- (lint-format "else clause cond could be folded into the outer cond: ~A" name (truncated-list->string clause))))
- (if (never-false expr)
- (if (not (= ctr len))
- (lint-format "cond test is never false: ~A" name form)
- (if (and (not (memq expr '(#t else)))
- (not (side-effect? test env)))
- (lint-format "cond last test could be #t: ~A" name form)))
- (if (never-true expr)
- (lint-format "cond test is never true: ~A" name form)))
- (if (not (side-effect? test env))
- (begin
- (if (and (not (memq test '(else #t)))
- (pair? sequel)
- (null? (cdr sequel)))
- (if (equal? test (car sequel))
- (lint-format "no need to repeat the test: ~A" name (lists->string clause (list test)))
- (if (and (pair? (car sequel))
- (pair? (cdar sequel))
- (null? (cddar sequel))
- (equal? test (cadar sequel)))
- (lint-format "perhaps use => here: ~A" name
- (lists->string clause (list test '=> (caar sequel)))))))
- (if (member test exprs)
- (lint-format "cond test repeated: ~A" name (truncated-list->string clause))
- (set! exprs (cons test exprs)))))
- (if (boolean? expr)
- (if (not expr)
- (lint-format "cond test is always false: ~A" name (truncated-list->string clause))
- (if (not (= ctr len))
- (lint-format "cond #t clause is not the last: ~A" name (truncated-list->string form))))
- (if (eq? test 'else)
- (if (not (= ctr len))
- (lint-format "cond else clause is not the last: ~A" name (truncated-list->string form)))
- (lint-walk name test env)))
- (if (eq? result :unset)
- (set! result sequel)
- (if (not (equal? result sequel))
- (set! result :unequal)))
- (if (pair? sequel)
- (if (eq? (car sequel) '=>)
- (if (or (not (pair? (cdr sequel)))
- (pair? (cddr sequel)))
- (lint-format "cond => target is messed up: ~A" name (truncated-list->string clause))
- (let ((f (cadr sequel)))
- (if (symbol? f)
- (let ((val (symbol->value f *e*)))
- (if (procedure? val)
- (if (not (aritable? val 1)) ; here values might be in test expr
- (lint-format "=> target (~A) may be unhappy: ~A" name f clause))))
- (if (and (pair? f)
- (eq? (car f) 'lambda)
- (pair? (cdr f))
- (pair? (cadr f))
- (not (= (length (cadr f)) 1)))
- (lint-format "=> target (~A) may be unhappy: ~A" name f clause)))
- (lint-walk name f env)))
- (lint-walk-body name head sequel env))
- (if (not (null? sequel)) ; (not (null?...)) here is correct -- we're looking for stray dots (lint is confused)
- (lint-format "cond clause is messed up: ~A" name (truncated-list->string clause))))
- (if (not (side-effect? expr env))
- (set! falses (cons expr falses))
- (set! result :unequal)))))
- (cdr form))
- (if (and has-else (pair? result)) ; all result clauses are the same (and not implicit)
- (if (null? (cdr result))
- (lint-format "perhaps ~A" name (lists->string form (car result)))
- (lint-format "perhaps ~A" name (lists->string form `(begin , at result)))))
-
- (if (= len 2)
- (let ((c1 (cadr form))
- (c2 (caddr form)))
- (if (and (pair? c1) (= (length c1) 2)
- (pair? c2) (= (length c2) 2)
- (boolean? (cadr c1))
- (boolean? (cadr c2))
- (memq (car c2) '(#t else)))
- (if (equal? (cadr c1) (cadr c2))
- (if (not (side-effect? (car c1) env))
- (lint-format "perhaps ~A" name (lists->string form (cadr c1))))
- (if (eq? (cadr c1) #t)
- (lint-format "perhaps ~A" name (lists->string form (car c1)))
- (lint-format "perhaps ~A" name (lists->string form `(not ,(car c1)))))))))
-
- (when has-combinations
- (let ((new-clauses ())
- (current-clauses ()))
- (do ((clauses (cdr form) (cdr clauses)))
- ((null? clauses)
- (lint-format "perhaps ~A" name (lists->string form `(cond ,@(reverse new-clauses)))))
- (let* ((clause (car clauses))
- (result (cdr clause))) ; can be null in which case the test is the result
- (if (and (pair? (cdr clauses))
- (equal? result (cdar (cdr clauses))))
- (set! current-clauses (cons clause current-clauses))
- (if (pair? current-clauses)
- (begin
- (set! current-clauses (cons clause current-clauses))
- (set! new-clauses (cons
- (cons (simplify-boolean `(or ,@(map car (reverse current-clauses))) () () env)
- result)
- new-clauses))
- (set! current-clauses ()))
- (set! new-clauses (cons clause new-clauses))))))))))
- env))
+ (let ((crf #f))
+ ;; all this stuff still misses (cond ((not x)...)) and (set! y (if x (cdr x)...)) i.e. need embedding in this case
+ (when (and (or (and (memq (car p) '(if and)) ; (let ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))
+ (eq? (cadr p) vname))
+ (and (eq? (car p) 'or)
+ (equal? (cadr p) `(not ,vname)))
+ (and (pair? vvalue)
+ (memq (car vvalue) '(assoc assv assq member memv memq))
+ (pair? (cadr p))
+ (or (eq? (caadr p) 'pair?)
+ (and (eq? (caadr p) 'null?)
+ (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair"
+ caller p vname (car vvalue) (truncated-list->string (car varlist)))
+ #f))
+ (eq? (cadadr p) vname)))
+
+ (or (and (pair? (caddr p))
+ (pair? (cdaddr p))
+ (null? (cddr (caddr p))) ; one func arg
+ (or (eq? vname (cadr (caddr p)))
+ (and (memq (caaddr p) '(car cdr caar cadr cddr cdar caaar caadr caddr
+ cdddr cdaar cddar cadar cdadr cadddr cddddr))
+ ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
+ (and cr
+ (< (length cr) 5)
+ (eq? vname arg)
+ (set! crf (string->symbol (string-append "c" cr "r")))))
+ (combine-cxrs (caddr p))))))
+ (and (eq? (car p) 'if)
+ (eq? (caddr p) vname)
+ (not (tree-unquoted-member vname (cdddr p)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cdddr p))
+ vvalue
+ `(or ,vvalue ,(cadddr p)))))
+ #f))
+ (pair? (caddr p))
+ (or (eq? (car p) 'if)
+ (null? (cdddr p))))
+ (let ((else-clause (cond ((pair? (cdddr p))
+ (if (eq? (cadddr p) vname)
+ `((else #f)) ; this stands in for the local var
+ (if (and (pair? (cadddr p))
+ (tree-unquoted-member vname (cadddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(cadddr p))))))
+ ((eq? (car p) 'and)
+ `((else #f)))
+ ((eq? (car p) 'or)
+ `((else #t)))
+ (else ()))))
+ (set! last-assoc-form p)
+ (unless (eq? else-clause :oops!)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(cond (,vvalue => ,(or crf (caaddr p))) , at else-clause))))))))
+ ))) ; one var in varlist
+
+ ;; --------
+ ;; (let ((x 1) (y 2)) (+ x y)) -> (+ 1 2)
+ ;; this happens a lot, but it often looks like a form of documentation
+ (when (and (= suggest made-suggestion)
+ (not named-let)
+ (pair? varlist)
+ (pair? body)
+ (pair? (car body))
+ (pair? (cdar body))
+ (null? (cdr body))
+ (< (length varlist) 8)
+ (not (memq (caar body) '(lambda lambda* define define* define-macro)))
+ (not (and (eq? (caar body) 'set!)
+ (any? (lambda (v) (eq? (car v) (cadar body))) varlist)))
+ (not (any-macro? (caar body) env))
+ (not (any? (lambda (p)
+ (and (pair? p)
+ (not (eq? (car p) 'quote))
+ (or (not (hash-table-ref no-side-effect-functions (car p)))
+ (any? pair? (cdr p)))))
+ (cdar body)))
+ (every? (lambda (v)
+ (and (pair? v)
+ (pair? (cdr v))
+ (< (tree-leaves (cadr v)) 8)
+ (= (tree-count1 (car v) body 0) 1)))
+ varlist))
+ (let ((new-body (copy (car body)))
+ (bool-arg? #f))
+ (for-each (lambda (v)
+ (if (not bool-arg?)
+ (let tree-walk ((tree body))
+ (if (pair? tree)
+ (if (and (memq (car tree) '(or and))
+ (memq (car v) (cdr tree)))
+ (set! bool-arg? #t)
+ (begin
+ (tree-walk (car tree))
+ (tree-walk (cdr tree)))))))
+ (set! new-body (tree-subst (cadr v) (car v) new-body)))
+ varlist)
+ (lint-format (if bool-arg?
+ "perhaps, ignoring short-circuit issues, ~A"
+ "perhaps ~A")
+ caller (lists->string form new-body))))
+ ;; --------
+ ) ; suggest let
+
+
+ (let* ((cur-env (append vars env))
+ (e (lint-walk-body (or named-let caller) head body cur-env))
+ (nvars (if (null? cur-env)
+ e
+ (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ())))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars))))
+
+ (if (and (pair? body)
+ (equal? (list-ref body (- (length body) 1)) '(curlet))) ; the standard library tag
+ (for-each (lambda (v)
+ (set! (var-ref v) (+ (var-ref v) 1)))
+ e))
+
+ (report-usage caller head vars cur-env))
+
+ (unless named-let
+ (find-let-constant-exprs caller form vars body))
+
+ ;; copied from letrec below -- happens about a dozen times
+ (when (and (not named-let)
+ (pair? varlist)
+ (pair? (car varlist))
+ (null? (cdr varlist))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (null? (cdddr form)))
+ (let ((body (caddr form))
+ (sym (caar varlist))
+ (lform (and (pair? (caadr form))
+ (pair? (cdar (cadr form)))
+ (cadar (cadr form)))))
+ (if (and (pair? lform)
+ (pair? (cdr lform))
+ (eq? (car lform) 'lambda)
+ (proper-list? (cadr lform)))
+ ;; unlike in letrec, here there can't be recursion (ref to same name is ref to outer env)
+ (if (eq? sym (car body))
+ (if (not (tree-memq sym (cdr body)))
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form `(let ,(map list (cadr lform) (cdr body))
+ ,@(cddr lform)))))
+ (if (= (tree-count1 sym body 0) 1)
+ (let ((call (find-call sym body)))
+ (when (pair? call)
+ (let ((new-call `(let ,(map list (cadr lform) (cdr call))
+ ,@(cddr lform))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst new-call call body)))))))))))
+
+
+ (if (and (pair? body) ; (let ((x y)) x) -> y
+ (null? (cdr body))
+ (pair? varlist) ; (let ()...)
+ (pair? (car varlist)) ; (let (x) ...)
+ (eq? (car body) (caar varlist))
+ (null? (cdr varlist))
+ (pair? (cdar varlist))) ; (let ((a))...)
+ (lint-format "perhaps ~A" caller (lists->string form (cadar varlist))))
+ ;; also (let ((x ...)) (let ((y x)...))) happens but it looks like automatically generated code or test suite junk
+
+ (when (and (pair? body)
+ (pair? (car body))
+ (pair? (cdar body))
+ (pair? (cddar body))
+ (eq? (caar body) 'set!))
+ (if (and (not named-let) ; (let ((x 0)...) (set! x 1)...) -> (let ((x 1)...)...)
+ (not (tree-memq 'curlet (caddar body)))
+ (cond ((assq (cadar body) vars)
+ => (lambda (v)
+ (or (and (code-constant? (var-initial-value v))
+ (code-constant? (caddar body)))
+ (not (any? (lambda (v1)
+ (or (tree-memq (car v1) (caddar body))
+ (side-effect? (cadr v1) env)))
+ varlist)))))
+ (else #f)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cdr body)) ; this only happens in test suites...
+ (if (null? (cdr varlist))
+ (caddar body)
+ `(let ,(map (lambda (v) (if (eq? (car v) (cadar body)) (values) v)) varlist)
+ ,(caddar body)))
+ `(let ,(map (lambda (v)
+ (if (eq? (car v) (cadar body))
+ (list (car v) (caddar body))
+ v))
+ varlist)
+ ,@(if (null? (cddr body))
+ (cdr body)
+ `(,(cadr body) ...))))))
+ ;; repetition for the moment
+ (when (and (pair? varlist)
+ (assq (cadar body) vars) ; settee is a local var
+ (not (eq? (cadar body) named-let)) ; (let loop () (set! loop 3))!
+ (or (null? (cdr body))
+ (and (null? (cddr body))
+ (eq? (cadar body) (cadr body))))) ; (let... (set! local val) local)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (or (tree-memq (cadar body) (caddar body))
+ (side-effect? (cadr (assq (cadar body) varlist)) env))
+ `(let ,varlist ,(caddar body))
+ (if (null? (cdr varlist))
+ (caddar body)
+ `(let ,(remove-if (lambda (v)
+ (eq? (car v) (cadar body)))
+ varlist)
+ ,(caddar body)))))))))
+
+ ;; all let vars are ref'd only in init-vals, no cdr, so substitute
+ (when (and (not named-let)
+ (pair? body)
+ (null? (cdr body))
+ (pair? (car body))
+ (eq? (caar body) 'do)
+ (pair? (cadar body)))
+ (let ((inits (map cadr (cadar body))))
+ (when (every? (lambda (v)
+ (and (= (tree-count1 (car v) (car body) 0) 1)
+ (tree-memq (car v) inits)))
+ varlist)
+ (let ((new-cadr (copy (cadar body))))
+ (for-each (lambda (v)
+ (set! new-cadr (tree-subst (cadr v) (car v) new-cadr)))
+ varlist)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(do ,new-cadr ...)))))))
+
+ ;; this is slower in s7 if one step var(?) -- collapse if more than one?
+ ;; TODO: what about shadowing?
+ (when (and (not named-let)
+ (pair? body)
+ (pair? (car body))
+ (eq? (caar body) 'do)
+ (or (null? (cadar body))
+ (pair? (cdadar body)))
+ (< (tree-leaves (cdr body)) 24)
+ (or (null? (caddar body))
+ (< (tree-leaves (cdr (caddar body))) 24)))
+ (let ((inits (and (pair? (cadar body))
+ (map cadr (cadar body)))))
+ (unless (and (pair? inits)
+ (any? (lambda (v)
+ (or (tree-memq (car v) inits)
+ (side-effect? (cadr v) env))) ; let var opens *stdin*, do stepper reads it at init
+ varlist))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((do-form (car body)))
+ (if (null? (cdr body))
+ `(do (, at varlist
+ ,@(cadr do-form))
+ ...)
+ `(do (, at varlist
+ ,@(cadr do-form))
+ (,(and (pair? (caddr do-form)) (caaddr do-form))
+ ,@(if (side-effect? (cdr (caddr do-form)) env) (cdr (caddr do-form)) ())
+ ,@(cdr body))
+ ...))))))))
+ (when (and (not named-let)
+ (pair? varlist)
+ (> (length body) 3)
+ (every? pair? varlist)
+ (not (tree-set-car-member '(define define* define-macro define-macro*
+ define-bacro define-bacro* define-constant define-expansion)
+ body)))
+ ;; define et al are like a continuation of the let bindings, so we can't restrict them by accident
+ ;; (let ((x 1)) (define y x) ...)
+ (let ((last-refs (map (lambda (v) (vector (var-name v) #f 0 v)) vars))
+ (got-lambdas (tree-set-car-member '(lambda lambda*) body)))
+ ;; (let ((x #f) (y #t)) (set! x (lambda () y)) (set! y 5) (x))
+ (do ((p body (cdr p))
+ (i 0 (+ i 1)))
+ ((null? p)
+ (let ((end 0)
+ (len i))
+ (for-each (lambda (v)
+ (set! end (max end (v 2))))
+ last-refs)
+ (if (and (< end (/ len lint-let-reduction-factor))
+ (eq? form lint-current-form)
+ (< (tree-leaves (car body)) 100))
+ (lint-format "this let could be tightened:~%~NC~A ->~%~NC~A~%~NC~A ..." caller
+ (+ lint-left-margin 4) #\space
+ (truncated-list->string form)
+ (+ lint-left-margin 4) #\space
+ (let ((old-pp ((funclet 'lint-pretty-print) '*pretty-print-left-margin*)))
+ (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) (+ lint-left-margin 4))
+ (let ((res (lint-pp `(let ,(cadr form)
+ ,@(copy body (make-list (+ end 1)))))))
+ (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) old-pp)
+ res))
+ (+ lint-left-margin 4) #\space
+ (lint-pp (list-ref body (+ end 1))))
+
+ (let ((mnv ())
+ (cur-end len))
+ (for-each (lambda (v)
+ (when (and (or (null? mnv)
+ (<= (v 2) cur-end))
+ (positive? (var-ref (v 3)))
+ (let ((expr (var-initial-value (v 3))))
+ (not (any? (lambda (ov) ; watch out for shadowed vars
+ (tree-memq (car ov) expr))
+ varlist))))
+ (set! mnv (if (= (v 2) cur-end)
+ (cons v mnv)
+ (list v)))
+ (set! cur-end (v 2))))
+ last-refs)
+ (when (and (pair? mnv)
+ (< cur-end (/ len lint-let-reduction-factor))
+ (> (- len cur-end) 3))
+ ;; mnv is in the right order because last-refs is reversed
+ (lint-format "the scope of ~{~A~^, ~} could be reduced: ~A" caller
+ (map (lambda (v) (v 0)) mnv)
+ (lists->string form
+ `(let ,(map (lambda (v)
+ (if (member (car v) mnv (lambda (a b) (eq? a (b 0))))
+ (values)
+ v))
+ varlist)
+ (let ,(map (lambda (v)
+ (list (v 0) (var-initial-value (v 3))))
+ mnv)
+ ,@(copy body (make-list (+ cur-end 1))))
+ ,(list-ref body (+ cur-end 1))
+ ...))))))))
+ (if (and (not got-lambdas)
+ (pair? (car p))
+ (pair? (cdr p))
+ (eq? (caar p) 'set!)
+ (var-member (cadar p) vars)
+ (not (tree-memq (cadar p) (cdr p))))
+ (if (not (side-effect? (caddar p) env))
+ (lint-format "~A in ~A could be omitted" caller (car p) (truncated-list->string form))
+ (lint-format "perhaps ~A" caller (lists->string (car p) (caddar p)))))
+
+ (for-each (lambda (v)
+ (when (tree-memq (v 0) (car p))
+ (set! (v 2) i)
+ (if (not (v 1)) (set! (v 1) i))))
+ last-refs))))
+
+ ;; out of place and repetitive code...
+ (when (and (pair? (cadr form))
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (pair? (caddr form)))
+ (let ((inner (caddr form)))
+ (when (and (eq? (car inner) 'let)
+ (pair? (cdr inner))
+ (symbol? (cadr inner)))
+ (let ((named-body (cdddr inner))
+ (named-args (caddr inner)))
+ (unless (any? (lambda (v) ; TODO: here and elsewhere -- no definers in the cadrs, and only one side-effect?
+ (or (not (= (tree-count1 (car v) named-args 0) 1))
+ (tree-memq (car v) named-body)))
+ varlist)
+ (let ((new-args (copy named-args)))
+ (for-each (lambda (v)
+ (set! new-args (tree-subst (cadr v) (car v) new-args)))
+ varlist)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let ,(cadr inner) ,new-args , at named-body)))))))))
+
+ ;; maybe more code than this is worth -- combine lets
+ (when (and (pair? (cadr form))
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (pair? (caddr form))
+ (memq (caaddr form) '(let let*))
+ (pair? (cdr (caddr form)))
+ (pair? (cadr (caddr form))))
+ (let ((inner (caddr form)))
+
+ (define (letstar . lets)
+ (let loop ((vars (list 'curlet)) (forms lets))
+ (and (pair? forms)
+ (or (and (pair? (car forms))
+ (or (tree-set-member vars (car forms))
+ (any? (lambda (a)
+ (or (not (pair? a))
+ (not (pair? (cdr a)))
+ (side-effect? (cadr a) env)))
+ (car forms))))
+ (loop (append (map car (car forms)) vars)
+ (cdr forms))))))
+
+ (cond ((and (null? (cdadr form)) ; let(1) + let* -> let*
+ (eq? (car inner) 'let*)
+ (not (symbol? (cadr inner)))) ; not named let*
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner))))))
+ ((and (pair? (cddr inner))
+ (pair? (caddr inner))
+ (null? (cdddr inner))
+ (eq? (caaddr inner) 'let)
+ (pair? (cdr (caddr inner)))
+ (pair? (cadr (caddr inner))))
+ (let ((inner1 (caddr inner)))
+ (if (and (pair? (cddr inner1))
+ (null? (cdddr inner1))
+ (pair? (caddr inner1))
+ (eq? (caaddr inner1) 'let)
+ (pair? (cdr (caddr inner1)))
+ (pair? (cadr (caddr inner1))))
+ (let ((inner2 (caddr inner1)))
+ (if (not (letstar (cadr form)
+ (cadr inner)
+ (cadr inner1)
+ (cadr inner2)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner)
+ ,@(cadr inner1)
+ ,@(cadr inner2))
+ ,@(one-call-and-dots (cddr inner2)))))))
+ (if (not (letstar (cadr form)
+ (cadr inner)
+ (cadr inner1)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner)
+ ,@(cadr inner1))
+ ,@(one-call-and-dots (cddr inner1)))))))))
+ ((not (letstar (cadr form)
+ (cadr inner)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner))))))
+
+ ((and (null? (cdadr form)) ; 1 outer var
+ (pair? (cadr inner))
+ (null? (cdadr inner))) ; 1 inner var, dependent on outer
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner)))))))))
+
+ ))) ; messed up let
+ env)
- (define (case-case)
- ;; ---------------- case ----------------
- ;; here the keys are not evaluated, so we might have a list like (letrec define ...)
- ;; also unlike cond, only 'else marks a default branch (not #t)
- (if (< (length form) 3)
- (lint-format "case is messed up: ~A" name (truncated-list->string form))
- (let ((sel-type #t)
- (selector (cadr form)))
- (if (and (not (pair? selector))
- (constant? selector))
- (lint-format "case selector is a constant: ~A" name (truncated-list->string form)))
- (lint-walk name selector env)
- (if (and (pair? selector)
- (symbol? (car selector)))
- (begin
- (set! sel-type (return-type (car selector)))
- (if (and (symbol? sel-type)
- (not (memq sel-type selector-types)))
- (lint-format "case selector may not work with eqv: ~A" name (truncated-list->string selector)))))
- (let ((all-keys ())
- (all-exprs ())
- (ctr 0)
- (result :unset)
- (exprs-repeated #f)
- (else-foldable #f)
- (has-else #f)
- (len (length (cddr form))))
- (for-each
- (lambda (clause)
- (set! ctr (+ ctr 1))
- (if (not (pair? clause))
- (lint-format "case clause should be a list: ~A" name (truncated-list->string clause))
- (let ((keys (car clause))
- (exprs (cdr clause)))
- (if (null? exprs)
- (lint-format "clause result is missing: ~A" name clause))
- (if (eq? result :unset)
- (set! result exprs)
- (if (not (equal? result exprs))
- (set! result :unequal)))
- (if (member exprs all-exprs)
- (set! exprs-repeated exprs)
- (set! all-exprs (cons exprs all-exprs)))
- (if (and (pair? exprs)
- (null? (cdr exprs))
- (pair? (car exprs))
- (pair? (cdar exprs))
- (null? (cddar exprs))
- (equal? selector (cadar exprs)))
- (lint-format "perhaps use => here: ~A" name
- (lists->string clause (list keys '=> (caar exprs)))))
- (if (pair? keys)
- (if (not (proper-list? keys))
- (if (null? keys)
- (lint-format "null case key list: ~A" name (truncated-list->string clause))
- (lint-format "stray dot in case case key list: ~A" name (truncated-list->string clause)))
- (for-each
- (lambda (key)
- (if (or (vector? key)
- (string? key)
- (pair? key)
- (hash-table? key))
- (lint-format "case key ~S in ~S is unlikely to work (case uses eqv?)" name key clause))
- (if (member key all-keys)
- (lint-format "repeated case key ~S in ~S" name key clause)
- (set! all-keys (cons key all-keys)))
- ;; unintentional quote here, as in (case x ('a b)...) never happens and
- ;; is hard to distinguish from (case x ((quote a) b)...) which happens a lot
- (if (not (compatible? sel-type (->type key)))
- (lint-format "case key ~S in ~S is pointless" name key clause)))
- keys))
- (if (not (eq? keys 'else))
- (lint-format "bad case key ~S in ~S" name keys clause)
- (begin
- (set! has-else clause)
- ;; exprs: (res) or if case, ((case ...)...)
- (if (not (= ctr len))
- (lint-format "case else clause is not the last: ~A"
- name
- (truncated-list->string (cddr form)))
- (when (and (pair? exprs)
- (pair? (car exprs))
- (null? (cdr exprs)) ; just the case statement in the else clause
- (eq? (caar exprs) 'case)
- (equal? selector (cadar exprs))
- (not (side-effect? selector env)))
- (set! else-foldable (cddar exprs)))))))
- (lint-walk-body name head exprs env))))
- (cddr form))
- (if (and has-else
- (pair? result)
- (not else-foldable))
- (begin
- (if (null? (cdr result))
- (lint-format "perhaps ~A" name (lists->string form (car result)))
- (lint-format "perhaps ~A" name (lists->string form `(begin , at result))))
- (set! exprs-repeated #f)))
-
- (when (or exprs-repeated else-foldable)
- (let* ((new-keys-and-exprs ())
- (else-clause (if else-foldable
- (call-with-exit
- (lambda (return)
- (for-each (lambda (c) (if (eq? (car c) 'else) (return c))) else-foldable)
- ()))
- (or has-else ())))
- (else-exprs (and (pair? else-clause) (cdr else-clause))))
-
- (define (merge-case-keys clause)
- ;(format *stderr* "clause: ~S~%" clause)
- (let ((keys (car clause))
- (exprs (cdr clause)))
- (when (and (pair? exprs) ; ignore clauses that are messed up
- (not (eq? keys 'else))
- (not (equal? exprs else-exprs)))
- (let ((prev (member exprs new-keys-and-exprs (lambda (a b) (equal? a (cdr b))))))
- (if prev
- (let* ((cur-clause (car prev))
- (cur-keys (car cur-clause)))
- (when (pair? cur-keys)
- (set-car! cur-clause
- (append cur-keys
- (map (lambda (key)
- (if (memv key cur-keys) (values) key))
- keys)))))
- (set! new-keys-and-exprs (cons (cons (copy (car clause)) (cdr clause)) new-keys-and-exprs)))))))
-
- (for-each merge-case-keys (cddr form))
- (if else-foldable
- (for-each merge-case-keys else-foldable))
-
- ;(format *stderr* "~%~A -> new: ~A, else: ~A~%" form new-keys-and-exprs else-clause)
-
- (if (null? new-keys-and-exprs)
- (if (or (null? else-clause) ; can this happen? (it's caught above as an error)
- (null? (cdr else-clause)))
- (lint-format "perhaps ~A" name (lists->string form ()))
- (if (null? (cddr else-clause))
- (lint-format "perhaps ~A" name (lists->string form (cadr else-clause)))
- (lint-format "perhaps ~A" name (lists->string form `(begin ,@(cdr else-clause))))))
- (lint-format "perhaps ~A" name
- (lists->string form
- (if (pair? else-clause)
- `(case ,(cadr form) ,@(reverse new-keys-and-exprs) ,else-clause)
- `(case ,(cadr form) ,@(reverse new-keys-and-exprs)))))))))))
- env)
+ ;; ---------------- let* ----------------
+ ((let*)
+ (if (< (length form) 3)
+ (lint-format "let* is messed up: ~A" caller (truncated-list->string form))
+ (let ((named-let (and (symbol? (cadr form)) (cadr form))))
+
+ (let ((vars (if named-let (list (make-var :name named-let
+ :definer 'let*)) ())) ; TODO: fvar
+ (varlist (if named-let (caddr form) (cadr form)))
+ (body (if named-let (cdddr form) (cddr form))))
+ (if (not (list? varlist))
+ (lint-format "let* is messed up: ~A" caller (truncated-list->string form)))
+
+ (let ((side-effects #f))
+ (do ((bindings varlist (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "let* variable list is not a proper list? ~S"
+ caller (if named-let (caddr form) (cadr form)))))
+ (when (binding-ok? caller head (car bindings) env #f)
+ (let ((expr (cadar bindings))
+ (side (side-effect? (cadar bindings) env)))
+ (if (not (or (eq? bindings varlist)
+ ;; first var side-effect is innocuous (especially if it's the only one!)
+ ;; does this need to protect against a side-effect that the next var accesses?
+ ;; I think we're ok -- the accessed var must be exterior, and we go down in order
+ side-effects))
+ (set! side-effects side))
+ (lint-walk caller expr (append vars env))
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value expr
+ :definer (if named-let 'named-let* 'let*))
+ vars))
+ ;; look for duplicate values
+
+ ;; TODO: protect against any shadows if included in any expr
+
+ (if (and (pair? expr)
+ (not (code-constant? expr))
+ (not (maker? expr))
+ (not side))
+ (let ((name (caar bindings)))
+ (let dup-check ((vs (cdr vars)))
+ (if (and (pair? vs)
+ (pair? (car vs))
+ (not (eq? name (caar vs)))
+ (not (tree-memq (caar vs) expr)))
+ ;; perhaps also not side-effect of car vs initial-value (char-ready? + read + char-ready? again)
+ (if (equal? expr (var-initial-value (car vs)))
+ (lint-format "~A's value ~A could be ~A" caller
+ name expr (caar vs))
+ (dup-check (cdr vs))))))))))
+
+ (if (not (or side-effects
+ (any? (lambda (v) (positive? (var-ref v))) vars)))
+ (lint-format "let* could be let: ~A" caller (truncated-list->string form))))
+ ;; in s7, let evaluates var values top down, so this message is correct
+ ;; even in cases like (let ((ind (open-sound...)) (mx (maxamp))) ...)
+ ;; in r7rs, the order is not specified (section 4.2.2 of the spec), so
+ ;; here we would restrict this message to cases where there is only
+ ;; one variable, or where subsequent values are known to be independent.
+ ;; if each function could tell us what globals it depends on or affects,
+ ;; we could make this work in all cases.
+
+ (let* ((cur-env (append vars env))
+ (e (lint-walk-body caller head body cur-env))
+ (nvars (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ()))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars))))
+
+ (report-usage caller head vars cur-env))
+
+ (unless named-let
+ ;; look for exprs replaceable with vars
+ (find-let-constant-exprs caller form vars body)
+
+ ;; (let*->let*) combined into one
+ (if (and (pair? body)
+ (pair? (car body))
+ (or (eq? (caar body) 'let*) ; let*+let* -> let*
+ (and (eq? (caar body) 'let) ; let*+let(1) -> let*
+ (or (null? (cadar body))
+ (and (pair? (cadar body))
+ (null? (cdadar body))))))
+ (null? (cdddr form))
+ (not (symbol? (cadar body))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (, at varlist
+ ,@(cadar body))
+ ,@(one-call-and-dots (cddar body))))))
+
+ ;; if last var only occurs once in body, and timing can't be an issue, substitute its value
+ ;; this largely copied from the let case above (but only one substitution)
+ ;; in both cases, we're assuming that the possible last-var value's side-effect won't
+ ;; affect other vars (in let* the local, in let something outside that might be used locally)
+ ;; perhaps add (not (side-effect (cadr last-var) env))?
+ (when (pair? varlist)
+ (let* ((len (length varlist))
+ (last-var (and (positive? len)
+ (list-ref varlist (- len 1)))))
+ (if (and (> len 1)
+ (pair? last-var)
+ (pair? (cdr last-var))
+ (< (tree-leaves (cadr last-var)) 12)
+ (= (tree-count1 (car last-var) body 0) 1)
+ (pair? body)
+ (pair? (car body))
+ (null? (cdr body))
+ (not (memq (caar body) '(lambda lambda* define define* define-macro)))
+ (not (and (eq? (caar body) 'set!)
+ (eq? (car last-var) (cadar body))))
+ (not (any-macro? (caar body) env))
+ (not (any? (lambda (p)
+ (and (pair? p)
+ (not (eq? (car p) 'quote))
+ (or (not (hash-table-ref no-side-effect-functions (car p)))
+ (any? pair? (cdr p)))))
+ (cdar body))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(if (= len 2) 'let 'let*)
+ ,(copy varlist (make-list (- len 1)))
+ ,@(tree-subst (cadr last-var) (car last-var) body))))))))
+
+ (when (and (pair? varlist) ; (let* (...(x A)) (if x (f A) B)) -> (let(*) (...) (cond (A => f) (else B)))
+ (pair? body)
+ (null? (cdr body)))
+ (let* ((varlen (length varlist))
+ (var (and (positive? varlen)
+ (varlist (- varlen 1)))))
+
+ (when (and (pair? var)
+ (pair? (cdr var)))
+ (let ((p (car body)))
+ (when (and (pair? p)
+ (pair? (cdr p))
+ (case (car p)
+ ((if and) (eq? (cadr p) (car var)))
+ ((or) (equal? (cadr p) `(not ,(car var))))
+ (else #f))
+ (pair? (cddr p))
+ (pair? (caddr p))
+ (or (eq? (car p) 'if)
+ (null? (cdddr p)))
+ (pair? (cdaddr p))
+ (not (eq? (caaddr p) (car var))) ; ! (let* (...(x A)) (if x (x x)))
+ (null? (cddr (caddr p)))
+ (eq? (car var) (cadr (caddr p))))
+
+ (let ((else-clause (cond ((pair? (cdddr p)) ; only if 'if (see above)
+ (if (eq? (cadddr p) (car var))
+ `((else #f)) ; this stands in for the local var
+ (if (and (pair? (cadddr p))
+ (tree-unquoted-member (car var) (cadddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(cadddr p))))))
+ ((eq? (car p) 'and)
+ `((else #f)))
+ ((eq? (car p) 'or)
+ `((else #t)))
+ (else ()))))
+ (if (not (eq? else-clause :oops!))
+ (case varlen
+ ((1) (lint-format "perhaps ~A" caller
+ (lists->string form `(cond (,(cadr var) => ,(caaddr p))
+ , at else-clause))))
+ ((2) (lint-format "perhaps ~A" caller
+ (lists->string form `(let (,(car varlist))
+ (cond (,(cadr var) => ,(caaddr p))
+ , at else-clause)))))
+ (else (lint-format "perhaps ~A" caller
+ (lists->string form `(let* (,@(copy varlist (make-list (- varlen 1))))
+ (cond (,(cadr var) => ,(caaddr p))
+ , at else-clause)))))))))))))
+ (if (and (pair? body) ; same as let: (let* ((x y)) x) -> y
+ (null? (cdr body))
+ (pair? varlist) ; (let* ()...)
+ (pair? (car varlist)) ; (let* (x) ...)
+ (not (pair? (car body))))
+ (if (and (eq? (car body) (caar varlist))
+ (null? (cdr varlist))
+ (pair? (cdar varlist))) ; (let* ((a...)) a)
+ (lint-format "perhaps ~A" caller (lists->string form (cadar varlist)))
+ (let* ((len (length varlist))
+ (last-var (and (positive? len)
+ (list-ref varlist (- len 1)))))
+ (if (and (> len 1) ; (let* (... (x y)) x) -> (let(*)(...) y)
+ (pair? last-var)
+ (pair? (cdr last-var))
+ (null? (cddr last-var))
+ (eq? (car body) (car last-var)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(if (= len 2) 'let 'let*)
+ ,(copy varlist (make-list (- len 1)))
+ ,(cadr last-var))))))))
+ (when (and (not named-let)
+ (> (length body) 3)
+ (> (length vars) 1)
+ (every? pair? varlist)
+ (not (tree-set-car-member '(define define* define-macro define-macro*
+ define-bacro define-bacro* define-constant define-expansion)
+ body)))
+ (let ((last-ref (vector (var-name (car vars)) #f 0 (car vars))))
+ (do ((p body (cdr p))
+ (i 0 (+ i 1)))
+ ((null? p)
+ (let ((len i))
+ (if (and (< (last-ref 2) (/ len lint-let-reduction-factor))
+ (> (- len (last-ref 2)) 3))
+ (lint-format "the scope of ~A could be reduced: ~A" caller
+ (last-ref 0)
+ (lists->string form
+ `(,(if (> (length vars) 2) 'let* 'let)
+ ,(copy varlist (make-list (- (length vars) 1)))
+ (let (,(list (last-ref 0) (var-initial-value (last-ref 3))))
+ ,@(copy body (make-list (+ (last-ref 2) 1))))
+ ,(list-ref body (+ (last-ref 2) 1))
+ ...))))))
+ (when (tree-memq (last-ref 0) (car p))
+ (set! (last-ref 2) i)
+ (if (not (last-ref 1)) (set! (last-ref 1) i))))))
+ )))
+ env)
- (define (do-case)
- ;; ---------------- do ----------------
- (let ((vars ()))
- (if (or (< (length form) 3)
- (not (proper-list? (cadr form)))
- (not (proper-list? (caddr form))))
- (lint-format "do is messed up: ~A" name (truncated-list->string form))
-
- (let ((step-vars (cadr form)))
-
- (if (not (side-effect? form env))
- (let ((end+result (caddr form)))
- (if (or (not (pair? end+result))
- (null? (cdr end+result)))
- (lint-format "this do-loop could be replaced by (): ~A" name (truncated-list->string form))
- (if (and (null? (cddr end+result))
- (code-constant? (cadr end+result)))
- (lint-format "this do-loop could be replaced by ~A: ~A" name (cadr end+result) (truncated-list->string form))))))
-
- ;; walk the init forms before adding the step vars to env
- (do ((bindings step-vars (cdr bindings)))
- ((not (pair? bindings))
- (if (pair? bindings)
- (lint-format "do variable list is not a proper list? ~S" name step-vars)))
- (if (binding-ok? name head (car bindings) env #f)
- (begin
- (lint-walk name (cadar bindings) env)
- (set! vars (append (list (make-var :name (caar bindings)
- :typ (->type (cadar bindings))
- :val (and (pair? (cddar bindings)) (caddar bindings))))
- vars)))))
-
- ;; walk the step exprs
- (do ((bindings step-vars (cdr bindings)))
- ((not (pair? bindings)))
- (let ((stepper (car bindings))) ; the entire binding: '(i 0 (+ i 1))
- (when (and (binding-ok? name head stepper env #t)
- (pair? (cddr stepper)))
- (lint-walk name (caddr stepper) (append vars env))
- (if (eq? (car stepper) (caddr stepper)) ; (i 0 i) -> (i 0)
- (lint-format "perhaps ~A" name (lists->string stepper (list (car stepper) (cadr stepper)))))
- (let ((data (var-member (car stepper) vars)))
- (set! (var-ref data) #f))
- (when (and (pair? (caddr stepper))
- (not (eq? (car stepper) (cadr stepper))) ; (lst lst (cdr lst))
- (eq? (car (caddr stepper)) 'cdr)
- (eq? (cadr stepper) (cadr (caddr stepper))))
- (lint-format "this looks suspicious: ~A" name stepper)))))
-
- ;; walk the body and end stuff (it's too tricky to find infinite do loops)
- (if (pair? (caddr form))
- (let ((end+result (caddr form)))
- (lint-walk-body name head (cddr form) (append vars env))
- (if (pair? end+result)
- (let ((end (car end+result)))
- (if (and (symbol? end) (memq end '(= > < >= <= null? not)))
- (lint-format "perhaps missing parens: ~A" name end+result))
- (if (never-false end)
- (lint-format "end test is never false: ~A" name end)
- (if end ; it's not #f
- (if (never-true end)
- (lint-format "end test is never true: ~A" name end)
- (let ((v (and (pair? end)
- (memq (car end) '(< > <= >=))
- (pair? (cdr end))
- (symbol? (cadr end))
- (member (cadr end) vars (lambda (a b) (eq? a (var-name b)))))))
- ;; if found, v is the var info
- (when (pair? v)
- (let ((step (var-value (car v))))
- (when (pair? step)
- (let ((inc (and (memq (car step) '(+ -))
- (pair? (cdr step))
- (pair? (cddr step))
- (or (and (real? (cadr step)) (cadr step))
- (and (real? (caddr step)) (caddr step))))))
- (when (real? inc)
- (if (or (and (eq? (car step) '+)
- (positive? inc)
- (memq (car end) '(< <=)))
- (and (eq? (car step) '-)
- (positive? inc)
- (memq (car end) '(> >=))))
- (lint-format "do step looks like it doesn't match end test: ~A" name
- (lists->string step end))))))))))
- (if (pair? (cdr end+result))
- (lint-format "result is unreachable: ~A" name end+result)))))))
- (lint-walk-body name head (cdddr form) (append vars env)))
-
- ;; before report-usage, check for unused variables, and don't complain about them if
- ;; they are referenced in an earlier step expr?(!)
- (do ((v vars (cdr v)))
- ((null? v))
- (let ((var (car v)))
- (unless (var-ref var)
- ;; var was not seen in the end+result/body or any subsequent step exprs
- ;; vars is reversed order, so we need only scan var-value of the rest
-
- (if (side-effect? (var-value var) env)
- (set! (var-ref var) #t)
- (for-each
- (lambda (nv)
- (if (or (eq? (var-name var) (var-value nv))
- (and (pair? (var-value nv))
- (tree-member (var-name var) (var-value nv))))
- (set! (var-ref var) #t)))
- (cdr v))))))
-
- (report-usage name 'variable head vars)
-
- ;; check for do-loop as copy/fill! stand-in
- (let ((end-test (and (pair? (caddr form)) (caaddr form)))
- (body (cdddr form))
- (setv #f))
- (when (and (pair? end-test)
- (= (length vars) 1)
- (= (length body) 1)
- (pair? (car body))
- (memq (caar body) '(vector-set! float-vector-set! int-vector-set! list-set! string-set!))
- (eq? (var-type (car vars)) 'integer?)
- (eq? (car end-test) '=)
- (eq? (cadr end-test) (var-name (car vars)))
- (eq? (caddar body) (var-name (car vars)))
- (let ((val (car (cdddar body))))
- (set! setv val)
- (or (code-constant? val)
- (and (pair? val)
- (memq (car val) '(vector-ref float-vector-ref int-vector-ref list-ref string-ref))
- (eq? (caddr val) (var-name (car vars)))))))
- (if (code-constant? setv)
- (lint-format "perhaps ~A" name
- (lists->string form `(fill! ,(cadar body) ,(car (cdddar body)) 0 ,(caddr end-test))))
- (lint-format "perhaps ~A" name
- (lists->string form `(copy ,(cadr setv) ,(cadar body) 0 ,(caddr end-test)))))))))
- env))
+ ;; ---------------- letrec ----------------
+ ((letrec letrec*)
+ (if (< (length form) 3)
+ (lint-format "~A is messed up: ~A" caller head (truncated-list->string form))
+ (let ((vars ()))
+ (cond ((null? (cadr form))
+ (lint-format "~A could be let: ~A" caller head (truncated-list->string form)))
+ ((not (pair? (cadr form)))
+ (lint-format "~A is messed up: ~A" caller head (truncated-list->string form)))
+ ((and (null? (cdadr form))
+ (eq? head 'letrec*))
+ (lint-format "letrec* could be letrec: ~A" caller (truncated-list->string form))))
+
+ (do ((bindings (cadr form) (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "~A variable list is not a proper list? ~S" caller head (cadr form))))
+ (when (binding-ok? caller head (car bindings) env #f)
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value (if (and (eq? (caar bindings) (cadar bindings))
+ (or (eq? head 'letrec)
+ (not (var-member (caar bindings) vars))))
+ (begin
+ (lint-format "~A is the same as (~A #<undefined>) in ~A" caller
+ (car bindings) (caar bindings) head)
+ ;; in letrec* ((x 12) (x x)) is an error
+ #<undefined>)
+ (cadar bindings))
+ :definer head)
+ vars))))
+
+ (when (eq? head 'letrec)
+ (check-unordered-exprs caller form (map var-initial-value vars) env))
+
+ (if (pair? vars) ; if none of the local vars occurs in any of the values, no need for the "rec"
+ (do ((bindings (cadr form) (cdr bindings))
+ (vs (map var-name vars)))
+ ((or (not (pair? bindings))
+ (not (pair? (car bindings)))
+ (not (pair? (cdar bindings)))
+ (memq (cadar bindings) vs)
+ (tree-set-member vs (cadar bindings)))
+ (if (null? bindings)
+ (lint-format "~A could be ~A: ~A" caller
+ head (if (eq? head 'letrec) 'let 'let*)
+ (truncated-list->string form))))))
+
+ (when (and (pair? vars)
+ (null? (cdr vars))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (null? (cdddr form)))
+ (let ((body (caddr form))
+ (sym (var-name (car vars)))
+ (lform (cadar (cadr form)))) ; the letrec var's lambda
+ (when (and (pair? lform)
+ (pair? (cdr lform))
+ (eq? (car lform) 'lambda)
+ (proper-list? (cadr lform))) ; includes ()
+ (if (eq? sym (car body)) ; (letrec ((x (lambda ...))) (x...)) -> (let x (...)...)
+ (if (and (not (tree-memq sym (cdr body)))
+ (< (tree-leaves body) 100))
+ ;; the limit on tree-leaves is for cases where the args are long lists of data --
+ ;; more like for-each than let, and easier to read if the code is first, I think.
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form `(let ,sym
+ ,(map list (cadr lform) (cdr body))
+ ,@(cddr lform)))))
+ (if (and (not (eq? caller 'define))
+ (= (tree-count1 sym body 0) 1))
+ (let ((call (find-call sym body)))
+ (when (pair? call)
+ (let ((new-call `(let ,sym
+ ,(map list (cadr lform) (cdr call))
+ ,@(cddr lform))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst new-call call body)))))))))))
+ ;; maybe (let () ...) here because (letrec ((x (lambda (y) (+ y 1)))) (x (define z 32))) needs to block z?
+ ;; currently we get (let x ((y (define z 32))) (+ y 1))
+ ;; and even that should be (let () (define z 32) (+ z 1)) or something similar
+ ;; lambda here is handled under define??
+
+ (let ((new-env (append vars env)))
+ (do ((bindings (cadr form) (cdr bindings)))
+ ((not (pair? bindings)))
+ (if (binding-ok? caller head (car bindings) env #t)
+ (lint-walk caller (cadar bindings) new-env)))
+
+ (let* ((cur-env (append vars env))
+ (e (lint-walk-body caller head (cddr form) cur-env))
+ (nvars (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ()))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars))))
+
+ (report-usage caller head vars cur-env))))) ; constant exprs never happen here
+ env)
- (define (let-case)
- ;; ---------------- let ----------------
- (if (or (< (length form) 3)
- (and (not (symbol? (cadr form)))
- (not (list? (cadr form)))))
- (lint-format "let is messed up: ~A" name (truncated-list->string form))
- (let ((named-let (and (symbol? (cadr form)) (cadr form))))
- (if (keyword? named-let)
- (lint-format "bad let name: ~A" name named-let))
-
- (unless named-let
- ;; this could be extended to other such cases
- (or (any? (lambda (var)
- (or (not (pair? var))
- (not (pair? (cdr var)))
- (not (code-constant? (cadr var)))))
- (cadr form))
- (any? (lambda (expr)
- (side-effect? expr env))
- (cddr form))
- (catch #t
- (lambda ()
- (let ((val (eval (copy-tree form) (rootlet))))
- (lint-format "perhaps ~A" name (lists->string form val))))
- (lambda args
- 'error))))
-
- (let ((vars (if (and named-let
- (not (keyword? named-let))
- (or (null? (caddr form))
- (and (proper-list? (caddr form))
- (every? pair? (caddr form)))))
- (list (make-var named-let
- :new (inlet :type head
- :decl (eval (list 'define (cons '_ (map car (caddr form))) #f))
- :signature #f
- :side-effect #t
- :arglist (map car (caddr form))
- :definition form
- :location #__line__))) ; TODO: named-let*
- ()))
- (varlist (if named-let (caddr form) (cadr form)))
- (body (if named-let (cdddr form) (cddr form))))
-
- (if (not (list? varlist))
- (lint-format "let is messed up: ~A" name (truncated-list->string form))
- (if (and (null? varlist)
- (pair? body)
- (null? (cdr body))
- (not (side-effect? (car body) env)))
- (lint-format "perhaps ~A" name (lists->string form (car body)))))
-
- (do ((bindings varlist (cdr bindings)))
- ((not (pair? bindings))
- (if (pair? bindings)
- (lint-format "let variable list is not a proper list? ~S" name varlist)))
- (if (binding-ok? name head (car bindings) env #f)
- (let ((val (cadar bindings)))
- (if (and (pair? val)
- (eq? 'lambda (car val))
- (not (hash-table-ref globals (caar bindings)))
- (tree-car-member (caar bindings) val)
- (not (var-member (caar bindings) env)))
- (lint-format "let variable ~A is called in its binding? Perhaps let should be letrec: ~A"
- name (caar bindings)
- (truncated-list->string bindings)))
- (lint-walk name val env)
-
- ;; can we tell its type and (as long as not set) check for type errors?
- ;; need a function that turns a constant into a type indication,
- ;; then append that as the 4th entry below (used only in do?)
- ;; then use that in arg checks if arg is a known var
-
- (set! vars (append (list (make-var (caar bindings) :val val :typ (->type val))) vars)))))
- ;; each var is (sym ref set opt-type-data new)
-
- (let* ((cur-env (append vars env))
- (e (lint-walk-body name head body cur-env))
- (nvars (if (null? cur-env)
- e
- (and (not (eq? e cur-env))
- (env-difference name e cur-env ())))))
- ;(format *stderr* "nvars: ~A e: ~A~%" nvars e)
- (if (pair? nvars)
- (if (eq? (var-name (car nvars)) '[anonymous])
- (begin
- (set! env (cons (car nvars) env))
- (set! nvars (cdr nvars)))
- (set! vars (append nvars vars)))))
- (report-usage name 'variable head vars))))
- env)
+ ;; ---------------- begin ----------------
+ ((begin)
+ (if (not (proper-list? form))
+ (begin
+ (lint-format "stray dot in begin? ~A" caller (truncated-list->string form))
+ env)
+ (begin
+ (if (and (pair? (cdr form))
+ (null? (cddr form)))
+ (lint-format "begin could be omitted: ~A" caller (truncated-list->string form)))
+ (lint-walk-open-body caller head (cdr form) env))))
+
+ ;; ---------------- with-baffle ----------------
+ ;; with-baffle introduces a new frame, so we need to handle it here
+ ((with-baffle)
+ (lint-walk-body caller head (cdr form) env)
+ env)
- (define (let*-case)
- ;; ---------------- let* ----------------
- (if (< (length form) 3)
- (lint-format "let* is messed up: ~A" name (truncated-list->string form))
- (let ((named-let (and (symbol? (cadr form)) (cadr form))))
- (let ((vars (if named-let (list (make-var named-let)) ()))
- (varlist (if named-let (caddr form) (cadr form)))
- (side-effects #f))
- (if (not (list? varlist))
- (lint-format "let* is messed up: ~A" name (truncated-list->string form)))
- (do ((bindings varlist (cdr bindings)))
- ((not (pair? bindings))
- (if (pair? bindings)
- (lint-format "let* variable list is not a proper list? ~S"
- name (if named-let (caddr form) (cadr form)))))
- (if (binding-ok? name head (car bindings) env #f)
- (begin
- (if (not side-effects)
- (set! side-effects (side-effect? (cadar bindings) env)))
- (lint-walk name (cadar bindings) (append vars env))
- (set! vars (append (list (make-var (caar bindings) :val (cadar bindings) :typ (->type (cadar bindings)))) vars)))))
-
- (if (and (not side-effects)
- (not (any? var-ref vars)))
- (lint-format "let* could be let: ~A" name (truncated-list->string form)))
-
- ;; in s7, let evaluates var values top down, so this message is correct
- ;; even in cases like (let ((ind (open-sound...)) (mx (maxamp))) ...)
- ;; in r7rs, the order is not specified (section 4.2.2 of the spec), so
- ;; here we would restrict this message to cases where there is only
- ;; one variable, or where subsequent values are known to be independent.
- ;; if each function could tell us what globals it depends on or affects,
- ;; we could make this work in all cases.
-
- (let* ((cur-env (append vars env))
- (e (lint-walk-body name head (if named-let (cdddr form) (cddr form)) cur-env))
- (nvars (and (not (eq? e cur-env))
- (env-difference name e cur-env ()))))
- (if (pair? nvars)
- (set! vars (append nvars vars))))
-
- (report-usage name 'variable head vars))))
- env)
+ ;; -------- with-let --------
+ ((with-let)
+ (if (< (length form) 3)
+ (lint-format "~A is messed up: ~A" head caller (truncated-list->string form))
+ (let ((e (cadr form)))
+ (if (or (and (code-constant? e)
+ (not (let? e)))
+ (and (pair? e)
+ (let ((op (return-type (car e) env)))
+ (and op
+ (not (return-type-ok? 'let? op))))))
+ (lint-format "~A: first argument should be an environment: ~A" head caller (truncated-list->string form)))
+
+ (if (symbol? e)
+ (set-ref e caller form env)
+ (if (pair? e)
+ (begin
+ (if (and (null? (cdr e))
+ (eq? (car e) 'curlet))
+ (lint-format "~A is not needed here: ~A" head caller (truncated-list->string form)))
+ (lint-walk caller e env))))
+ (let ((walked #f)
+ (new-env (cons (make-var :name :with-let :initial-value form :definer head) env)))
+ (if (or (and (symbol? e)
+ (memq e '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*)))
+ (and (pair? e)
+ (eq? (car e) 'sublet)
+ (pair? (cdr e))
+ (memq (cadr e) '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*))
+ (set! e (cadr e))))
+ (let ((lib (if (defined? e)
+ (symbol->value e)
+ (let ((file (*autoload* e)))
+ (and (string? file)
+ (load file))))))
+ (when (let? lib)
+ (let ((old-e *e*))
+ (set! *e* lib)
+ (let ((e (lint-walk-open-body caller head (cddr form) new-env)))
+ (report-usage caller head
+ (if (eq? e env)
+ ()
+ (env-difference caller e env ()))
+ new-env))
+ (set! *e* old-e)
+ (set! walked #t)))))
+
+ (unless walked
+ (lint-walk-open-body caller head (cddr form) new-env)))))
+ env)
- (define (letrec-case)
- ;; ---------------- letrec ----------------
- (if (< (length form) 3)
- (lint-format "~A is messed up: ~A" name head (truncated-list->string form))
- (let ((vars ()))
- (if (null? (cadr form))
- (lint-format "~A could be let: ~A" name head (truncated-list->string form))
- (if (not (pair? (cadr form)))
- (lint-format "~A is messed up: ~A" name head (truncated-list->string form))
- (if (and (null? (cdadr form))
- (eq? head 'letrec*)) ; this happens all the time!
- (lint-format "letrec* could be letrec? ~A" name (truncated-list->string form)))))
- (do ((bindings (cadr form) (cdr bindings)))
- ((not (pair? bindings))
- (if (pair? bindings)
- (lint-format "letrec variable list is not a proper list? ~S" name (cadr form))))
- (if (binding-ok? name head (car bindings) env #f)
- (set! vars (append (list (make-var (caar bindings) :val (cadar bindings) :typ (->type (cadar bindings)))) vars))))
- (let ((new-env (append vars env)))
- (do ((bindings (cadr form) (cdr bindings)))
- ((not (pair? bindings)))
- (if (binding-ok? name head (car bindings) env #t)
- (lint-walk name (cadar bindings) new-env)))
-
- (let* ((cur-env (append vars env))
- (e (lint-walk-body name head (cddr form) cur-env))
- (nvars (and (not (eq? e cur-env))
- (env-difference name e cur-env ()))))
- (if (pair? nvars)
- (set! vars (append nvars vars)))))
-
- (report-usage name 'variable head vars)))
- env)
+ ;; ---------------- defmacro ----------------
+ ((defmacro defmacro*)
+ (if (or (< (length form) 4)
+ (not (symbol? (cadr form))))
+ (begin
+ (lint-format "~A declaration is messed up: ~A" caller head (truncated-list->string form))
+ env)
+ (let ((sym (cadr form))
+ (args (caddr form))
+ (body (cdddr form)))
+ (if (and (pair? args)
+ (repeated-member? args env))
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args))
+ (lint-format "~A is deprecated; perhaps ~A" caller head
+ (truncated-lists->string form
+ `(,(if (eq? head 'defmacro) 'define-macro 'define-macro*)
+ ,(cons sym args)
+ , at body))))
+ (lint-walk-function head sym args body form env)
+ (cons (make-var :name sym :initial-value form :definer head) env))))
- (define (begin-case)
- ;; ---------------- begin ----------------
- (if (not (proper-list? form))
- (begin
- (lint-format "stray dot in begin? ~A" name (truncated-list->string form))
- env)
- (begin
- (if (and (pair? (cdr form))
- (null? (cddr form)))
- (lint-format "begin could be omitted: ~A" name (truncated-list->string form)))
- (lint-walk-body name head (cdr form) env)))
- env)
+ ;; ---------------- defgenerator ----------------
+ ((defgenerator)
+ (append (get-generator caller form env) env))
- (define (when-case)
- ;; -------- when, unless --------
- (if (< (length form) 3)
- (lint-format "~A is messed up: ~A" name head (truncated-list->string form))
- (let ((test (cadr form)))
- (if (and (pair? test)
- (eq? (car test) 'not))
- (lint-format "possible optimization: ~A -> ~A"
- name
- (truncated-list->string form)
- (truncated-list->string `(,(if (eq? head 'when) 'unless 'when)
- ,(cadr test)
- ,@(cddr form)))))
- (if (never-false test)
- (lint-format "~A test is never false: ~A" name head form)
- (if (never-true test)
- (lint-format "~A test is never true: ~A" name head form)))
- (if (symbol? test)
- (set-ref? test env)
- (if (pair? test)
- (lint-walk name test env)))
- (let* ((e (lint-walk-body name head (cddr form) env))
- (vars (if (not (eq? e env))
- (env-difference name e env ())
- ())))
- (report-usage name 'variable head vars))))
- env)
+
+ ;; ---------------- load ----------------
+ ((load)
+ (lint-walk caller (cdr form) env)
+ (if (and *report-loaded-files*
+ (string? (cadr form)))
+ (catch #t
+ (lambda ()
+ (lint-file (cadr form) env))
+ (lambda args
+ env))
+ env))
+
+ ;; ---------------- require ----------------
+ ((require)
+ (if (not *report-loaded-files*)
+ env
+ (let ((vars env))
+ (for-each
+ (lambda (f)
+ (let ((file (*autoload* f)))
+ (if (string? file)
+ (catch #t
+ (lambda ()
+ (set! vars (lint-file file vars)))
+ (lambda args
+ #f)))))
+ (cdr form))
+ vars)))
+
+ ;; ----------------
+ ((call-with-input-string call-with-input-file call-with-output-file call-with-output-string)
+ (let ((len (if (eq? head 'call-with-output-string) 2 3))) ; call-with-output-string func is the first arg, not second
+ (when (= (length form) len)
+ (let ((func (list-ref form (- len 1))))
+ (if (= len 3)
+ (lint-walk caller (cadr form) env))
+ (if (not (and (pair? func)
+ (eq? (car func) 'lambda)))
+ (lint-walk caller func env)
+ (let* ((args (cadr func))
+ (body (cddr func))
+ (port (and (pair? args) (car args))))
+ (if (or (not port)
+ (pair? (cdr args)))
+ (lint-format "~A argument should be a function of one argument: ~A" caller head func)
+ (if (and (null? (cdr body))
+ (pair? (car body))
+ (pair? (cdar body))
+ (eq? (cadar body) port)
+ (null? (cddar body)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (= len 2)
+ `(,head ,(caar body))
+ `(,head ,(cadr form) ,(caar body)))))
+ (let ((cc (make-var :name port
+ :initial-value (list (case head
+ ((call-with-input-string) 'open-input-string)
+ ((call-with-output-string) 'open-output-string)
+ ((call-with-input-file) 'open-input-file)
+ ((call-with-output-file) 'open-output-file)))
+ :definer head)))
+ (lint-walk-body caller head body (cons cc env))
+ (report-usage caller head (list cc) env)))))))))
+ env)
- (define (with-let-case)
- ;; -------- with-let --------
- (if (< (length form) 3)
- (lint-format "~A is messed up: ~A" head name (truncated-list->string form))
- (let ((e (cadr form)))
- (if (or (and (code-constant? e)
- (not (let? e)))
- (and (symbol? e)
- (defined? e)
- (not (let? (symbol->value e))))
- (and (pair? e)
- (let ((op (return-type (car e))))
- (and op
- (not (return-type-ok? 'let? op))))))
- (lint-format "~A: first argument should be an environment: ~A" head name (truncated-list->string form)))
- (if (symbol? e)
- (set-ref? e env)
- (if (pair? e)
- (begin
- (if (and (null? (cdr e))
- (eq? (car e) 'curlet))
- (lint-format "~A is not needed here: ~A" head name (truncated-list->string form)))
- (lint-walk name e env))))
- (let ((walked #f))
- (if (or (and (symbol? e)
- (memq e '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*)))
- (and (pair? e)
- (eq? (car e) 'sublet)
- (pair? (cdr e))
- (memq (cadr e) '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*))
- (set! e (cadr e))))
- (let ((lib (if (not (defined? e))
- (let ((file (*autoload* e)))
- (and (string? file)
- (load file)))
- (symbol->value e))))
- (when (let? lib)
- (let ((old-e *e*))
- (set! *e* lib)
- (let* ((e (lint-walk-body name head (cddr form) env))
- (vars (if (not (eq? e env))
- (env-difference name e env ())
- ())))
- (report-usage name 'variable head vars))
- (set! *e* old-e)
- (set! walked #t)))))
-
- (unless walked
- (let* ((e (lint-walk-body name head (cddr form) env))
- (vars (if (not (eq? e env))
- (env-difference name e env ())
- ())))
- (report-usage name 'variable head vars))))))
- env)
+ ;; ----------------
+ ((catch)
+ ;; catch tag is tricky -- it is evaluated, then eq? matches at error time, so we need
+ ;; to catch constants that can't be eq?
+ ;; also I'm not sure the catch marker business below buys anything -- these are dynamic, not lexical,
+ ;; so lint can't make any pronouncements about them.
+ (if (not (= (length form) 4))
+ (begin
+ (lint-format "catch takes 3 arguments (tag body error-handler): ~A" caller (truncated-list->string form))
+ (lint-walk caller (cdr form) env))
+ (let ((tag (cadr form)))
+ (if (or (and (not (pair? tag))
+ (or (number? tag) (char? tag) (length tag)))
+ (and (pair? tag)
+ (eq? (car tag) 'quote)
+ (or (not (pair? (cdr tag)))
+ (length (cadr tag)))))
+ (lint-format "catch tag ~S is unreliable (catch uses eq? to match tags)" caller tag))
+ (let ((body (caddr form))
+ (error-handler (cadddr form)))
+ ;; empty catch+catch apparently never happens
+ (lint-walk caller body (cons (make-var :name :catch
+ :initial-value form
+ :definer head)
+ env))
+ (lint-walk caller error-handler env))))
+ env)
- (define (else-case)
- ;; ---------------- everything else ----------------
- (if (not (proper-list? form))
- (begin
- ;; these appear to be primarily macro arguments
- (if (and (pair? form)
- (symbol? (car form))
- (procedure? (symbol->value (car form) *e*)))
- (lint-format "unexpected dot: ~A" name (truncated-list->string form)))
- env)
- (begin
- (when (symbol? head)
- (check-call name head form env)
- (if (not (or (hash-table-ref globals head)
- (var-member head env)))
- (check-special-cases name head form env))
- (if (assq head deprecated-ops)
- (lint-format "~A is deprecated; use ~A" name head (cdr (assq head deprecated-ops))))
-
- (if (and (not (= line-number last-simplify-numeric-line-number))
- (not (hash-table-ref globals head))
- (hash-table-ref numeric-ops head)
- (not (var-member head env)))
- (let ((val (simplify-numerics form env)))
- (if (not (equal-ignoring-constants? form val))
- (begin
- (set! last-simplify-numeric-line-number line-number)
- (lint-format "perhaps ~A" name (lists->string form val))))))
-
- ;; if we loaded this file first, and f (head) is defined (e.g. scan above),
- ;; and it is used before it is defined, but not thereafter, the usage stuff
- ;; can get confused, so other-identifiers is trying to track those.
-
- (if (and (not (hash-table-ref other-identifiers head))
- (not (defined? head start-up-let)))
- (hash-table-set! other-identifiers head #t)))
-
- (when (and (pair? head)
- (> (length head) 0)
- (eq? (car head) 'lambda))
- (if (and (proper-list? (cadr head))
- (not (= (length (cadr head)) (length (cdr form)))))
- (lint-format "~A has ~A arguments: ~A"
- head (car head)
- (if (> (length (cadr head)) (length (cdr form)))
- "too few" "too many")
- (truncated-list->string form))))
-
- (let ((vars env))
- (for-each
- (lambda (f)
- (set! vars (lint-walk name f vars)))
- form))
- ))
- env)
+ ;; ----------------
+ ((call/cc call-with-current-continuation call-with-exit)
+ (let ((continuation (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'lambda)
+ (pair? (cdadr form))
+ (pair? (cddadr form))
+ (pair? (cadadr form))
+ (car (cadadr form)))))
+ (if (not (symbol? continuation))
+ (lint-walk caller (cdr form) env)
+ (let ((body (cddadr form)))
+
+ (if (not (or (eq? head 'call-with-exit)
+ (eq? continuation (car body))
+ (tree-sym-set-member continuation '(lambda lambda* define define* curlet error apply) body)))
+ ;; this checks for continuation as arg (of anything), and any of set as car
+ (lint-format* caller
+ (string-append "perhaps " (symbol->string head))
+ " could be call-with-exit: "
+ (truncated-list->string form)))
+
+ (if (not (tree-unquoted-member continuation body))
+ (lint-format "~A ~A ~A appears to be unused: ~A" caller head
+ (if (eq? head 'call-with-exit) "exit function" "continuation")
+ continuation
+ (truncated-list->string form))
+ (let ((last (and (proper-list? body)
+ (list-ref body (- (length body) 1)))))
+ (if (and (pair? last)
+ (eq? (car last) continuation))
+ (lint-format "~A is redundant here: ~A" caller continuation (truncated-list->string last)))))
+
+ (let ((cc (make-var :name continuation
+ :initial-value (if (eq? head 'call-with-exit) :call/exit :call/cc)
+ :definer head)))
+ (lint-walk-body caller head body (cons cc env))
+ (report-usage caller head (list cc) env)))))
+ env)
+
+ ;; ----------------
+ ((define-module import export) ; module apparently has different syntax and expectations in various schemes
+ env)
+
+ ((define-syntax)
+ ;; we need to put the macro name in env with ftype=define-syntax
+ (if (and (pair? (cdr form))
+ (symbol? (cadr form))
+ (not (keyword? (cadr form)))) ; !! this thing is a disaster from the very start
+ (cons (make-fvar (cadr form) :ftype 'define-syntax) env)
+ env))
+
+ ((define-method) ; guile and mit-scheme have different syntaxes here
+ (if (not (and (pair? (cdr form))
+ (pair? (cddr form))))
+ env
+ (if (symbol? (cadr form))
+ (if (keyword? (cadr form))
+ (lint-walk-body caller head (cdddr form) env)
+ (let ((new-env (if (var-member (cadr form) env)
+ env
+ (cons (make-fvar (cadr form) :ftype 'define-method) env))))
+ (lint-walk-body caller (cadr form) (cdddr form) new-env)))
+ (let ((new-env (if (var-member (caadr form) env)
+ env
+ (cons (make-fvar (caadr form) :ftype 'define-method) env))))
+ (lint-walk-body caller (caadr form) (cddr form) new-env)))))
+
+ ((let-syntax letrec-syntax)
+ (lint-walk-body caller head (cddr form) env)
+ env)
+
+ ;; ----------------
+ ((case-lambda)
+ (when (pair? (cdr form))
+ (let ((lens ())
+ (body (if (string? (cadr form)) (cddr form) (cdr form))) ; might have a doc string before the clauses
+ (doc-string (and (string? (cadr form)) (cadr form))))
+
+ (define (arg->defaults arg b1 b2 defaults)
+ (and defaults
+ (cond ((null? b1) (and (null? b2) defaults))
+ ((null? b2) (and (null? b1) defaults))
+ ((eq? arg b1) (cons b2 defaults))
+ ((eq? arg b2) (cons b1 defaults))
+ ((pair? b1)
+ (and (pair? b2)
+ (arg->defaults arg (car b1) (car b2) (arg->defaults arg (cdr b1) (cdr b2) defaults))))
+ (else (and (equal? b1 b2) defaults)))))
+ (for-each
+ (lambda (choice)
+ (if (pair? choice)
+ (let ((len (length (car choice))))
+ (if (member len lens)
+ (lint-format "repeated parameter list? ~A in ~A" caller (car choice) form))
+ (set! lens (cons len lens))
+ (lint-walk 'case-lambda `(lambda , at choice) env))))
+ body)
+
+ (case (length lens)
+ ((1)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if doc-string
+ `(let ((documentation ,doc-string))
+ (lambda ,(caar body) ,@(cdar body)))
+ `(lambda ,(caar body) ,@(cdar body))))))
+ ((2)
+ (when (let arglists-equal? ((args1 (caar body))
+ (args2 (caadr body)))
+ (if (null? args1)
+ (and (pair? args2) (null? (cdr args2)))
+ (and (pair? args1)
+ (if (null? args2)
+ (null? (cdr args1))
+ (and (pair? args2)
+ (eq? (car args1) (car args2))
+ (arglists-equal? (cdr args1) (cdr args2)))))))
+ (let* ((clause1 (car body))
+ (arg1 (car clause1))
+ (body1 (cdr clause1))
+ (clause2 (cadr body))
+ (arg2 (car clause2))
+ (body2 (cdr clause2))
+ (arglist (if (> (car lens) (cadr lens)) arg2 arg1)) ; lens is reversed
+ (arg-name (list-ref arglist (- (length arglist) 1)))
+ (diffs (arg->defaults arg-name body1 body2 ())))
+ (when (and (pair? diffs)
+ (null? (cdr diffs))
+ (code-constant? (car diffs)))
+ (let ((new-body (if (> (car lens) (cadr lens)) body2 body1))
+ (new-arglist (if (not (car diffs))
+ arglist
+ (if (null? (cdr arglist))
+ `((,arg-name ,(car diffs)))
+ `(,(car arglist) (,arg-name ,(car diffs)))))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if doc-string
+ `(let ((documentation ,doc-string))
+ (lambda* ,new-arglist , at new-body))
+ `(lambda* ,new-arglist , at new-body))))))))))))
+ env)
- (set! line-number (pair-line-number form))
- (case head
-
- ((define define*
- define-constant define-envelope
- define-expansion define-macro define-macro* define-bacro define-bacro*
- definstrument defanimal)
- (define-case))
-
- ((lambda lambda*) (lambda-case))
- ((set!) (set-case))
- ((quote) (quote-case))
- ((cond) (cond-case))
- ((case) (case-case))
- ((do) (do-case))
- ((let) (let-case))
- ((let*) (let*-case))
- ((letrec letrec*) (letrec-case))
- ((begin) (begin-case))
- ((when unless) (when-case))
- ((with-let) (with-let-case))
-
- ((defmacro defmacro*) (defmacro-case))
- ((defgenerator) (generator-case))
- ((define-syntax let-syntax letrec-syntax define-module) ; all meaningless in s7
- ;; actually the real problem with checking other schemes' code is that they use a large number
- ;; of non-standard # and \ forms. The # forms can mostly be kludged up via #*readers, but I'm
- ;; not going to start building in all the crazy \ stuff.
- ;; Some schemes use the execrable [] substitutes for () -- Gauche in particular.
- env)
-
- (else
- (else-case))))
-
- ;; else form is not a symbol and not a pair
- env)))
+ ;; ---------------- everything else ----------------
+ (else
+ (if (not (proper-list? form))
+ ;; these appear to be primarily macro/match arguments
+ ;; other cases (not list) have already been dealt with far above
+ (if (and (pair? form)
+ (symbol? head)
+ (procedure? (symbol->value head *e*)))
+ (lint-format "unexpected dot: ~A" caller (truncated-list->string form)))
+ (begin
+ (when (symbol? head)
+ (let ((v (var-member head env)))
+ (if (and (var? v)
+ (not (memq form (var-history v))))
+ (set! (var-history v) (cons form (var-history v))))
+ (check-call caller head form env)
+
+ (when (pair? form)
+ ;; save any references to vars in their var-history (type checked later)
+ ;; this can be fooled by macros, as everywhere else
+ (for-each (lambda (arg)
+ (if (symbol? arg)
+ (let ((v (var-member arg env)))
+ (if (and (var? v)
+ (not (memq form (var-history v))))
+ (set! (var-history v) (cons form (var-history v)))))))
+ form)
+
+ (if (and *report-any-!-as-setter* ; (inc! x) when inc! is unknown, assume it sets x
+ (symbol? (car form))
+ (pair? (cdr form))
+ (symbol? (cadr form))
+ (not (var-member (car form) env))
+ (not (hash-table-ref built-in-functions (car form)))
+ (let ((str (symbol->string (car form))))
+ (char=? (string-ref str (- (length str) 1)) #\!)))
+ (set-set (cadr form) caller form env)))
+
+ (if (not (var? v))
+ (check-special-cases caller head form env)
+ (if (and (memq (var-ftype v) '(define lambda define* lambda*))
+ (not (memq caller (var-scope v))))
+ (let ((cv (var-member caller env)))
+ (set! (var-scope v)
+ (cons (if (and (var? cv)
+ (memq (var-ftype cv) '(define lambda define* lambda*))) ; named-let does not define ftype
+ caller
+ (cons caller env))
+ (var-scope v))))))
+
+ (if (assq head deprecated-ops)
+ (lint-format "~A is deprecated; use ~A" caller head (cond ((assq head deprecated-ops) => cdr))))
+
+ (if (and (not (= line-number last-simplify-numeric-line-number))
+ (not (var? v))
+ (hash-table-ref numeric-ops head)
+ (proper-tree? form))
+ (let ((val (simplify-numerics form env)))
+ (if (not (equal-ignoring-constants? form val))
+ (begin
+ (set! last-simplify-numeric-line-number line-number)
+ (lint-format "perhaps ~A" caller (lists->string form val))))))
+
+ ;; ----------------
+ ;; (f ... (if A B C) (if A D E) ...) -> (f ... (if A (values B D) (values C E)) ...)
+ ;; these happen up to almost any number of clauses
+ ;; need true+false in every case, and need to be contiguous
+ ;; case/cond happen here, but very rarely in a way we can combine via values
+
+ (unless (any-macro? (car form) env) ; actually most macros are safe here...
+ (let ((p (member 'if (cdr form) (lambda (x q)
+ (and (pair? q)
+ (eq? (car q) 'if) ; it's an if expression
+ (pair? (cdr q))
+ (pair? (cddr q)) ; there's a true branch
+ (pair? (cdddr q))))))) ; and a false branch (similarly below)
+ (when (pair? p)
+ (let ((test (cadar p)))
+ (do ((q (cdr p) (cdr q)))
+ ((not (and (pair? q)
+ (let ((x (car q)))
+ (and (pair? x)
+ (eq? (car x) 'if)
+ (pair? (cdr x))
+ (equal? (cadr x) test)
+ (pair? (cddr x))
+ (pair? (cdddr x))))))
+ (unless (eq? q (cdr p))
+ (let ((header (do ((i 1 (+ i 1))
+ (r (cdr form) (cdr r)))
+ ((eq? r p)
+ (copy form (make-list i)))))
+ (middle (do ((r p (cdr r))
+ (trues ())
+ (falses ()))
+ ((eq? r q)
+ `(if ,test
+ (values ,@(reverse trues))
+ (values ,@(reverse falses))))
+ (set! trues (cons (caddar r) trues))
+ (set! falses (cons (car (cdddar r)) falses)))))
+ (lint-format "perhaps~A ~A" caller
+ (if (side-effect? test env)
+ (format #f " (ignoring ~S's possible side-effects)" test)
+ "")
+ (lists->string form `(, at header ,middle , at q)))))))))))
+ ;; ----------------
+
+ ;; if a var is used before it is defined, the var history and ref/set
+ ;; info needs to be saved until the definition, so other-identifiers collects it
+ (unless (or (var? v)
+ (defined? head (rootlet)))
+ (hash-table-set! other-identifiers head
+ (if (not (hash-table-ref other-identifiers head))
+ (list form)
+ (cons form (hash-table-ref other-identifiers head)))))))
+
+ ;; `(,(car x) ,@(cdr x)) -> ,x ({list} (car x) ({apply_values} (cdr x))) -- almost never happens
+
+ (when (and (pair? head)
+ (pair? (cdr head))
+ (memq (car head) '(lambda lambda*)))
+ (cond ((and (identity? head)
+ (pair? (cdr form))) ; identity needs an argument
+ (lint-format "perhaps ~A" caller (truncated-lists->string form (cadr form))))
+
+ ((and (null? (cadr head))
+ (pair? (cddr head)))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string
+ form
+ (if (and (null? (cdddr head))
+ (not (and (pair? (caddr head))
+ (memq (caaddr head) '(define define* define-constant define-macro define-macro*)))))
+ (caddr head)
+ `(let () ,@(cddr head))))))
+
+ ((and (pair? (cddr head)) ; ((lambda (...) ...) ...) -> (let ...) -- lambda here is ugly and slow
+ (proper-list? (cddr head))
+ (not (any? (lambda (a) (mv-range a env)) (cdr form))))
+ (call-with-exit
+ (lambda (quit) ; uncountably many things can go wrong with the lambda form
+ (let ((vars ())
+ (vals ()))
+ (do ((v (cadr head) (cdr v))
+ (a (cdr form) (cdr a)))
+ ((not (and (pair? a)
+ (pair? v)))
+ (if (symbol? v)
+ (begin
+ (set! vars (cons v vars))
+ (set! vals (cons `(list , at a) vals)))
+ (do ((v v (cdr v)))
+ ((not (pair? v)))
+ (if (not (pair? v))
+ (quit))
+ (if (pair? (car v))
+ (begin
+ (if (not (pair? (cdar v)))
+ (quit))
+ (set! vars (cons (caar v) vars))
+ (set! vals (cons (cadar v) vals)))
+ (begin
+ (set! vars (cons (car v) vars))
+ (set! vals (cons #f vals)))))))
+ (set! vars (cons (if (pair? (car v)) (caar v) (car v)) vars))
+ (set! vals (cons (car a) vals)))
+
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,(if (or (eq? (car head) 'lambda)
+ (not (pair? (cadr head)))
+ (null? (cdadr head)))
+ 'let 'let*)
+ ,(map list (reverse vars) (reverse vals))
+ ,@(cddr head))))))))))
+ (let ((vars env))
+ (for-each
+ (lambda (f)
+ (set! vars (lint-walk caller f vars)))
+ form))))
+ env))))))))
+
+
+ ;; -------- lint-file --------
+ (define *report-input* #t)
+
+ (define (lint-file-1 file env)
+ (set! linted-files (cons file linted-files))
+ (let ((fp (if (input-port? file)
+ file
+ (begin
+ (set! *current-file* file)
+ (catch #t
+ (lambda ()
+ (let ((p (open-input-file file)))
+ (if *report-input*
+ (format outport
+ (if (and (output-port? outport)
+ (not (member outport (list *stderr* *stdout*))))
+ (values "~%~NC~%;~A~%" (+ lint-left-margin 16) #\-)
+ ";~A~%")
+ file))
+ p))
+ (lambda args
+ (format outport "~NCcan't open ~S: ~A~%" lint-left-margin #\space file (apply format #f (cadr args)))
+ #f))))))
+
+ (when (input-port? fp)
+ (let ((vars env)
+ (line 0)
+ (last-form #f)
+ (last-line-number -1))
+
+ (do ((form (read fp) (read fp)))
+ ((eof-object? form))
+ (if (pair? form)
+ (set! line (max line (pair-line-number form))))
+
+ (if (not (or (= last-line-number -1)
+ (side-effect? last-form vars)))
+ (format outport "~NCtop-level (line ~D): this has no effect: ~A~%"
+ lint-left-margin #\space last-line-number
+ (truncated-list->string last-form)))
+ (set! last-form form)
+ (set! last-line-number line)
+
+ (if (and (pair? form)
+ (memq (car form) '(define define-macro))
+ (pair? (cdr form))
+ (pair? (cadr form)))
+ (let ((f (caadr form)))
+ (if (and (symbol? f)
+ (hash-table-ref built-in-functions f))
+ (format outport "~NCtop-level ~Aredefinition of built-in function ~A: ~A~%"
+ lint-left-margin #\space
+ (if (> (pair-line-number form) 0)
+ (format #f "(line ~D) " (pair-line-number form))
+ "")
+ f (truncated-list->string form)))))
+
+ (set! vars (lint-walk (if (symbol? form)
+ form
+ (and (pair? form)
+ (car form)))
+ form
+ vars)))
+
+ (if (not (input-port? file))
+ (close-input-port fp))
+
+ vars))))
+
+
+ (define (lint-file file env)
+ ;; (if (string? file) (format *stderr* "lint ~S~%" file))
- ;;; --------------------------------------------------------------------------------
- (let ((documentation "(lint file port) looks for infelicities in file's scheme code"))
- (lambda* (file (outp *lint-output-port*) (report-input #t))
- (set! outport outp)
- (set! globals (make-hash-table))
- (set! other-identifiers (make-hash-table))
- (set! loaded-files ())
- (set! last-simplify-boolean-line-number -1)
- (set! last-simplify-numeric-line-number -1)
- (set! last-checker-line-number -1)
- (set! line-number -1)
- (set! quote-warnings 0)
-
- ;(format *stderr* "lint ~S~%" file)
-
- (let ((fp (if (input-port? file)
- file
- (begin
- (set! *current-file* file)
- (if *load-file-first* ; this can improve the error checks
- (load file))
- (catch #t
- (lambda ()
- (let ((p (open-input-file file)))
- (if report-input (format outport ";~A~%" file))
- (set! loaded-files (cons file loaded-files))
- p))
- (lambda args
- (format outport " can't open ~S: ~A~%" file (apply format #f (cadr args)))
- #f))))))
+ (if (member file linted-files)
+ env
+ (let ((old-current-file *current-file*)
+ (old-pp-left-margin pp-left-margin)
+ (old-lint-left-margin lint-left-margin)
+ (old-load-path *load-path*))
- (if (input-port? fp)
- (let ((vars ())
- (line 0)
- (last-form #f)
- (last-line-number -1))
- (do ((form (read fp) (read fp)))
- ((eof-object? form))
- (if (pair? form)
- (set! line (max line (pair-line-number form))))
-
- (if (and (not (= last-line-number -1))
- (not (side-effect? last-form vars)))
- (format outport " top-level (line ~D): this has no effect: ~A~%"
- last-line-number
- (truncated-list->string last-form)))
- (set! last-form form)
- (set! last-line-number line)
- (set! vars (lint-walk (if (symbol? form)
- form
- (and (pair? form)
- (car form)))
- form
- vars)))
-
- (if (and (pair? vars)
- *report-multiply-defined-top-level-functions*)
- (for-each
- (lambda (var)
- (let ((var-file (hash-table-ref *top-level-objects* (car var))))
- (if (not var-file)
- (hash-table-set! *top-level-objects* (car var) *current-file*)
- (if (and (string? *current-file*)
- (not (string=? var-file *current-file*)))
- (format outport ";~S is defined at the top level in ~S and ~S~%" (car var) var-file *current-file*)))))
- vars))
-
- (if (and (string? file)
- (pair? vars)
- *report-unused-top-level-functions*)
- (report-usage file 'top-level-var "" vars))
+ (dynamic-wind
+ (lambda ()
+ (set! pp-left-margin (+ pp-left-margin 4))
+ (set! lint-left-margin (+ lint-left-margin 4))
+ (when (and (string? file)
+ (char=? (file 0) #\/))
+ (let ((last-pos 0))
+ (do ((pos (char-position #\/ file (+ last-pos 1)) (char-position #\/ file (+ last-pos 1))))
+ ((not pos)
+ (if (> last-pos 0)
+ (set! *load-path* (cons (substring file 0 last-pos) *load-path*))))
+ (set! last-pos pos)))))
+
+ (lambda ()
+ (lint-file-1 file env))
+
+ (lambda ()
+ (set! pp-left-margin old-pp-left-margin)
+ (set! lint-left-margin old-lint-left-margin)
+ (set! *current-file* old-current-file)
+ (set! *load-path* old-load-path)
+ (if (positive? (length *current-file*))
+ (newline outport)))))))
+
+
+
+ ;;; --------------------------------------------------------------------------------'
+ ;;; lint itself
+ ;;;
+ (let ((documentation "(lint file port) looks for infelicities in file's scheme code")
+ (signature (list #t string? output-port? boolean?)))
+ (lambda* (file (outp *lint-output-port*) (report-input #t))
+ (set! outport outp)
+ (set! other-identifiers (make-hash-table))
+ (set! linted-files ())
+ (set! last-simplify-boolean-line-number -1)
+ (set! last-simplify-numeric-line-number -1)
+ (set! last-simplify-cxr-line-number -1)
+ (set! last-checker-line-number -1)
+ (set! last-cons-line-number -1)
+ (set! last-if-line-number -1)
+ (set! last-rewritten-internal-define #f)
+ (set! last-assoc-form #f)
+ (set! line-number -1)
+ (set! quote-warnings 0)
+ (set! pp-left-margin 0)
+ (set! lint-left-margin -3) ; lint-file above adds 4
+
+ (set! big-constants (make-hash-table))
+ (set! equable-closures (make-hash-table))
+
+ (set! *report-input* report-input)
+ (set! *report-nested-if* (if (integer? *report-nested-if*) (max 3 *report-nested-if*) 4))
+ (set! *report-short-branch* (if (integer? *report-short-branch*) (max 0 *report-short-branch*) 12))
+
+ (set! *#readers*
+ (list (cons #\e (lambda (str)
+ (if (not (string=? str "e"))
+ (let ((num (string->number (substring str 1))))
+ (if num
+ (cond ((rational? num)
+ (format outport "~NCthis #e is dumb, #~A -> ~A~%" lint-left-margin #\space str (substring str 1)))
+ ((not (real? num))
+ (format outport "~NC#e can't handle complex numbers, #~A -> ~A~%" lint-left-margin #\space str num))
+ ((= num (floor num))
+ (format outport "~NCperhaps #~A -> ~A~%" lint-left-margin #\space str (floor num)))))))
+ #f))
+ (cons #\i (lambda (str)
+ (if (not (string=? str "i"))
+ (let ((num (string->number (substring str 1))))
+ (if num
+ (format outport
+ (if (not (rational? num))
+ (values "~NCthis #i is dumb, #~A -> ~A~%" lint-left-margin #\space str (substring str 1))
+ (values "~NCperhaps #~A -> ~A~%" lint-left-margin #\space str (* 1.0 num)))))))
+ #f))
+ (cons #\d (lambda (str)
+ (if (and (not (string=? str "d"))
+ (string->number (substring str 1)))
+ (format outport "~NC#d is pointless, #~A -> ~A~%" lint-left-margin #\space str (substring str 1)))
+ #f))
+
+ (cons #\' (lambda (str) ; for Guile (and syntax-rules, I think)
+ (list 'syntax (if (string=? str "'") (read) (string->symbol str)))))
+
+ (cons #\` (lambda (str) ; for Guile (sigh)
+ (list 'quasisyntax (if (string=? str "'") (read) (string->symbol str)))))
+
+ (cons #\, (lambda (str) ; the same, the last is #,@ -> unsyntax-splicing -- right.
+ (list 'unsyntax (if (string=? str "'") (read) (string->symbol str)))))
+
+ (cons #\! (lambda (str)
+ (if (member str '("!optional" "!default" "!rest" "!key" "!aux" "!false" "!true") string-ci=?) ; for MIT-scheme
+ (make-keyword (substring str 1))
+ (let ((lc (str 0))) ; s7 should handle this, but...
+ (do ((c (read-char) (read-char)))
+ ((or (and (eof-object? c)
+ (or (format outport "~NCunclosed block comment~%" lint-left-margin #\space)
+ #t))
+ (and (char=? lc #\!)
+ (char=? c #\#)))
+ #f)
+ (set! lc c))))))))
+
+ ;; try to get past all the # and \ stuff in other Schemes
+ ;; main remaining problem: [] used as parentheses (Gauche and Chicken for example)
+ (set! (hook-functions *read-error-hook*)
+ (list (lambda (h)
+ (let ((data (h 'data))
+ (line (port-line-number)))
+ (if (not (h 'type))
+ (begin
+ (format outport "~NCreader[~A]: unknown \\ usage: \\~C~%" lint-left-margin #\space line data)
+ (set! (h 'result) data))
+ (begin
+ (format outport "~NCreader[~A]: unknown # object: #~A~%" lint-left-margin #\space line data)
+ (set! (h 'result)
+ (case (data 0)
+ ((#\;) (read) (values))
+
+ ((#\T) (string=? data "T"))
+ ((#\F) (and (string=? data "F") (list 'quote #f)))
+ ((#\X)
+ (let ((num (string->number (substring data 1)))) ; mit-scheme, maybe others
+ (if (number? num)
+ (begin
+ (format outport "~NCuse #x~A not #~A~%" lint-left-margin #\space (substring data 1) data)
+ num)
+ (string->symbol data))))
+
+ ((#\l #\z)
+ (let ((num (string->number (substring data 1)))) ; Bigloo (also has #ex #lx #z and on and on)
+ (if (number? num)
+ (begin
+ (format outport "~NCjust omit this silly #~C!~%" lint-left-margin #\space (data 0))
+ num)
+ (string->symbol data))))
+
+ ((#\u) ; for Bigloo
+ (if (string=? data "unspecified")
+ (format outport "~NCuse #<unspecified>, not #unspecified~%" lint-left-margin #\space))
+ ;; #<unspecified> seems to hit the no-values check?
+ (string->symbol data))
+
+ ((#\v) ; r6rs byte-vectors?
+ (if (string=? data "vu8")
+ (format outport "~NCuse #u8 in s7, not #vu8~%" lint-left-margin #\space))
+ (string->symbol data))
+
+ ((#\>) ; for Chicken, apparently #>...<# encloses in-place C code
+ (do ((last #\#)
+ (c (read-char) (read-char)))
+ ((and (char=? last #\<)
+ (char=? c #\#))
+ (values))
+ (if (char=? c #\newline)
+ (set! (port-line-number ()) (+ (port-line-number) 1)))
+ (set! last c)))
+
+ ((#\<) ; Chicken also, #<<EOF -> EOF
+ (if (and (char=? (data 1) #\<)
+ (> (length data) 2))
+ (let ((end (substring data 2)))
+ (do ((c (read-line) (read-line)))
+ ((string-position end c)
+ (values))))
+ (string->symbol data)))
+
+ ((#\\)
+ (cond ((assoc data '(("\\newline" . #\newline)
+ ("\\return" . #\return)
+ ("\\space" . #\space)
+ ("\\tab" . #\tab)
+ ("\\null" . #\null)
+ ("\\nul" . #\null)
+ ("\\linefeed" . #\linefeed)
+ ("\\alarm" . #\alarm)
+ ("\\esc" . #\escape)
+ ("\\escape" . #\escape)
+ ("\\rubout" . #\delete)
+ ("\\delete" . #\delete)
+ ("\\backspace" . #\backspace)
+ ("\\page" . #\xc)
+
+ ;; rest are for Guile
+ ("\\vt" . #\xb)
+ ("\\bs" . #\backspace)
+ ("\\cr" . #\newline)
+ ("\\sp" . #\space)
+ ("\\lf" . #\linefeed)
+ ("\\nl" . #\null)
+ ("\\ht" . #\tab)
+ ("\\ff" . #\xc)
+ ("\\np" . #\xc))
+ string-ci=?)
+ => (lambda (c)
+ (format outport "~NCperhaps use ~W instead~%" (+ lint-left-margin 4) #\space (cdr c))
+ (cdr c)))
+ (else
+ (string->symbol (substring data 1)))))
+ (else
+ (string->symbol data))))))))))
+
+ (let ((vars (lint-file file ())))
+ (set! lint-left-margin (max lint-left-margin 1))
+
+ (if (and (pair? vars)
+ *report-multiply-defined-top-level-functions*)
+ (for-each
+ (lambda (var)
+ (let ((var-file (hash-table-ref *top-level-objects* (car var))))
+ (if (not var-file)
+ (hash-table-set! *top-level-objects* (car var) *current-file*)
+ (if (and (string? *current-file*)
+ (not (string=? var-file *current-file*)))
+ (format outport "~NC~S is defined at the top level in ~S and ~S~%"
+ lint-left-margin #\space
+ (car var) var-file *current-file*)))))
+ vars))
+
+ (if (and (string? file)
+ (pair? vars))
+ (report-usage top-level: "" vars vars)))
+
+ (for-each
+ (lambda (p)
+ (if (or (> (cdr p) 5)
+ (and (> (cdr p) 3)
+ (> (length (car p)) 12)))
+ (format outport "~A~A occurs ~D times~%"
+ (if (pair? (car p)) "'" "")
+ (truncated-list->string (car p)) (cdr p))))
+ big-constants)
+
+ (if (and *report-undefined-identifiers*
+ (positive? (hash-table-entries other-identifiers)))
+ (let ((lst (sort! (map car other-identifiers) (lambda (a b)
+ (string<? (symbol->string a) (symbol->string b))))))
+ (format outport "~NCth~A identifier~A not defined~A: ~{~S~^ ~}~%"
+ lint-left-margin #\space
+ (if (= (hash-table-entries other-identifiers) 1)
+ (values "is" " was")
+ (values "e following" "s were"))
+ (if (string? file) (format #f " in ~S" file) "")
+ lst)
+ (fill! other-identifiers #f)))))))
- (if (not (input-port? file))
- (close-input-port fp))))))))))
@@ -4701,14 +13773,11 @@
(substring str (+ epos 4)))))
(let ((apos (string-position "<a " str))
(epos (string-position "<em " str)))
- (if (and (not apos)
- (not epos))
+ (if (not (or apos epos))
str
(let* ((pos (if (and apos epos) (min apos epos) (or apos epos)))
(bpos (char-position #\> str (+ pos 1)))
- (epos (if (and apos (= pos apos))
- (string-position "</a>" str (+ bpos 1))
- (string-position "</em>" str (+ bpos 1)))))
+ (epos (string-position (if (and apos (= pos apos)) "</a>" "</em>") str (+ bpos 1))))
(string-append (substring str 0 pos)
(substring str (+ bpos 1) epos)
(remove-markups (substring str (+ epos (if (and apos (= apos pos)) 4 5)))))))))))
@@ -4718,15 +13787,15 @@
(if (not pos)
str
(string-append (substring str 0 pos)
- (let ((epos (char-position #\; str pos)))
- (let ((substr (substring str (+ pos 1) epos)))
- (let ((replacement (cond ((string=? substr "gt") ">")
- ((string=? substr "lt") "<")
- ((string=? substr "mdash") "-")
- ((string=? substr "amp") "&")
- (else (format #t "unknown: ~A~%" substr)))))
- (string-append replacement
- (fixup-html (substring str (+ epos 1)))))))))))
+ (let* ((epos (char-position #\; str pos))
+ (substr (substring str (+ pos 1) epos)))
+ (string-append (cond ((assoc substr '(("gt" . ">")
+ ("lt" . "<")
+ ("mdash" . "-")
+ ("amp" . "&"))
+ string=?) => cdr)
+ (else (format () "unknown: ~A~%" substr)))
+ (fixup-html (substring str (+ epos 1)))))))))
(call-with-input-file file
(lambda (f)
@@ -4739,41 +13808,157 @@
;; if so, clean out html markup stuff, call lint on that
(let ((pos (string-position "<pre" line)))
- (if pos
- (let ((code (substring line (+ (char-position #\> line) 1))))
- (do ((cline (read-line f #t) (read-line f #t))
- (rline 1 (+ rline 1)))
- ((string-position "</pre>" cline)
- (set! line-num (+ line-num rline)))
- (set! code (string-append code cline)))
+ (when pos
+ (let ((code (substring line (+ (char-position #\> line) 1))))
+ (do ((cline (read-line f #t) (read-line f #t))
+ (rline 1 (+ rline 1)))
+ ((string-position "</pre>" cline)
+ (set! line-num (+ line-num rline)))
+ (set! code (string-append code cline)))
+
+ ;; is first non-whitespace char #\(? ignoring comments
+ (let ((len (length code)))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (let ((c (string-ref code i)))
+ (if (not (char-whitespace? c))
+ (if (char=? c #\;)
+ (set! i (char-position #\newline code i))
+ (begin
+ (set! i (+ len 1))
+ (if (char=? c #\()
+ (catch #t
+ (lambda ()
+ (let* ((ncode (with-input-from-string
+ (fixup-html (remove-markups code))
+ read))
+ (outstr (call-with-output-string
+ (lambda (op)
+ (call-with-input-string (format #f "~S" ncode)
+ (lambda (ip)
+ (let-temporarily ((*report-shadowed-variables* #t))
+ (lint ip op #f))))))))
+ (if (> (length outstr) 1) ; possible newline at end
+ (format () ";~A ~D: ~A~%" file line-num outstr))))
+ (lambda args
+ (format () ";~A ~D, error in read: ~A ~A~%" file line-num args
+ (fixup-html (remove-markups code)))))))))))))))))))
+
+
+;;; --------------------------------------------------------------------------------
+;;; and this reads C code looking for s7_eval_c_string. No attempt here to
+;;; handle weird cases.
+
+(define (C-lint file)
+ (call-with-input-file file
+ (lambda (f)
+ (do ((line-num 0 (+ line-num 1))
+ (line (read-line f #t) (read-line f #t)))
+ ((eof-object? line))
+
+ ;; look for s7_eval_c_string, get string arg without backslashes, call lint
+ (let ((pos (string-position "s7_eval_c_string(sc, \"(" line)))
+ (when pos
+ (let ((code (substring line (+ pos (length "s7_eval_c_string(sc, \"")))))
+ (if (not (string-position "\");" code))
+ (do ((cline (read-line f #t) (read-line f #t))
+ (rline 1 (+ rline 1)))
+ ((string-position "\");" cline)
+ (set! code (string-append code cline))
+ (set! line-num (+ line-num rline)))
+ (set! code (string-append code cline))))
+
+ (let ((len (string-position "\");" code)))
+ (set! code (substring code 0 len))
- ;; is first non-whitespace char #\(? ignoring comments
- (let ((len (length code)))
- (do ((i 0 (+ i 1)))
- ((>= i len))
- (let ((c (string-ref code i)))
- (if (not (char-whitespace? c))
- (if (char=? c #\;)
- (set! i (char-position #\newline code i))
- (begin
- (set! i (+ len 1))
- (if (char=? c #\()
- (catch #t
- (lambda ()
- (let ((ncode (with-input-from-string
- (fixup-html (remove-markups code))
- read)))
- (call-with-output-file "t631-temp.scm"
- (lambda (fout)
- (format fout "~S~%" ncode)))
- (let ((outstr (call-with-output-string
- (lambda (p)
- (let ((old-shadow *report-shadowed-variables*))
- (set! *report-shadowed-variables* #t)
- (lint "t631-temp.scm" p #f)
- (set! *report-shadowed-variables* old-shadow))))))
- (if (> (length outstr) 0)
- (format #t ";~A ~D: ~A~%" file line-num outstr)))))
- (lambda args
- (format #t ";~A ~D, error in read: ~A ~A~%" file line-num args
- (fixup-html (remove-markups code)))))))))))))))))))
+ ;; clean out backslashes
+ (do ((i 0 (+ i 1)))
+ ((>= i (- len 3)))
+ (if (char=? (code i) #\\)
+ (cond ((char=? (code (+ i 1)) #\n)
+ (set! (code i) #\space)
+ (set! (code (+ i 1)) #\space))
+
+ ((memv (code (+ i 1)) '(#\newline #\"))
+ (set! (code i) #\space))
+
+ ((and (char=? (code (+ i 1)) #\\)
+ (char=? (code (- i 1)) #\#))
+ (set! (code (- i 1)) #\space)
+ (set! (code i) #\#))))))
+ (catch #t
+ (lambda ()
+ (let ((outstr (call-with-output-string
+ (lambda (op)
+ (call-with-input-string code
+ (lambda (ip)
+ (let-temporarily ((*report-shadowed-variables* #t))
+ (lint ip op #f))))))))
+ (if (> (length outstr) 1) ; possible newline at end
+ (format () ";~A ~D: ~A~%" file line-num outstr))))
+ (lambda args
+ (format () ";~A ~D, error in read: ~A ~A~%" file line-num args code))))))))))
+
+
+;;; --------------------------------------------------------------------------------
+;;; this sends lint's output to the Snd repl's widget
+
+(define (snd-lint file)
+ (lint file (openlet
+ (inlet :name "lint-output-port"
+ :format (lambda (p str . args) (snd-print (apply format #f str args)))
+ :write (lambda (obj p) (snd-print (object->string obj #t)))
+ :display (lambda (obj p) (snd-print (object->string obj #f)))
+ :write-string (lambda (str p) (snd-print str))
+ :write-char (lambda (ch p) (snd-print (string ch)))
+ :newline (lambda (p) (snd-print (string #\newline)))
+ :close-output-port (lambda (p) #f)
+ :flush-output-port (lambda (p) #f)))))
+
+#|
+;;; external use of lint contents:
+(for-each (lambda (f)
+ (if (not (hash-table-ref (*lint* 'no-side-effect-functions) (car f)))
+ (format *stderr* "~A " (car f))))
+ (*lint* 'built-in-functions))
+|#
+
+#|
+;;; get rid of []'s! (using Snd)
+(define (edit file)
+ (let ((str (file->string file)))
+ (let ((len (length str)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (case (str i)
+ ((#\]) (set! (str i) #\)))
+ ((#\[) (set! (str i) #\()))))
+ (call-with-output-file file
+ (lambda (p)
+ (display str p)))))
+|#
+
+;;; --------------------------------------------------------------------------------
+;;; TODO:
+;;;
+;;; code-equal if/when/unless/cond, case: any order of clauses, let: any order of vars, etc, zero/=0
+;;; snd-lint: load lint, add to various hash-tables via *lint* [if provided? 'snd load snd-lint.scm or something]
+;;; auto unit tests, *report-tests* -> list of funcs to test as in zauto, possibly fix errors
+;;; indentation is confused in pp by if expr+values?, pp handling of (list ((lambda...)..)) is bad
+;;; there are now lots of cases where we need to check for values (/ as invert etc)
+;;; x used as number then (if x...) or (and (vector-ref 0) (string-length (vector-ref 0)))
+;;; the ((lambda ...)) -> let rewriter is still tricked by values
+;;;
+;;; lambda (define? named-let?) constant seqs -> closure? what about others similar (sqrt2 (sqrt 2))...? [9792]
+;;; (let ((A (f x)) (let ((B (g A))) <no use of A>...))) or let* -> (let ((B (g (f x))))?
+;;; see member/string= case in t347 -- smarter cond -> assoc code needed
+;;; also reversed order (eq? 'a x) (eq? 'b x) etc (reorder either way)
+;;; also need code-equal for cond test repetition check (or at least reversible check -- this works in or/and I think)
+;;; and the rewrite looks nutty -- (#f 4)!
+;;; */- are reversible after first
+;;; infinite? -> +/-inf.0 in cond->case? or does this require real? nan.0 isn't eqv? so can't work in case?
+;;; pi also should be ok and most-positive|negative-fixnum but each requires the actual number -- won't work for pi: #_pi?
+;;; case with #_abs etc?
+;;; case with all results (f ...) does happen (else being an error)
+;;;
+;;; 114 22113 433088
diff --git a/makefile.in b/makefile.in
index 388b328..e590fcc 100644
--- a/makefile.in
+++ b/makefile.in
@@ -3,7 +3,7 @@ SHELL = @SHELL@
INSTALL = @INSTALL@
INSTALL_DATA = ${INSTALL} -m 0644
-CFLAGS = @CFLAGS@
+CFLAGS = @CPPFLAGS@ @CFLAGS@
GTK_CFLAGS = @GTK_CFLAGS@
XEN_CFLAGS = @XEN_CFLAGS@
CAIRO_CFLAGS = @CAIRO_CFLAGS@
@@ -24,6 +24,8 @@ GSL_LIBS = @GSL_LIBS@
GL_LIBS = @GL_LIBS@
GL_FILES = @GL_FILES@
FFTW_LIBS = @FFTW_LIBS@
+WEBSERVER_LIBS = @WEBSERVER_LIBS@
+WEBSERVER_FILES = @WEBSERVER_FILES@
JACK_LIBS = @JACK_LIBS@
GMP_LIBS = @GMP_LIBS@
@@ -81,8 +83,8 @@ NO_FILES =
main_target: @MAKE_TARGET@
-snd: $(SNDLIB_HEADERS) $(SND_HEADERS) $(GX_HEADERS) $(S7_HEADERS) $(S7_O_FILES) $(SNDLIB_O_FILES) $(O_FILES) $(GX_FILES) $(GL_FILES)
- $(CC) $(LDFLAGS) $(CFLAGS) $(S7_O_FILES) $(SNDLIB_O_FILES) $(O_FILES) $(GX_FILES) $(GL_FILES) -o snd $(SNDLIB_LIB) $(XEN_LIBS) $(GTK_LIBS) $(GL_LIBS) $(JACK_LIBS) $(AUDIO_LIB) $(FFTW_LIBS) $(GSL_LIBS) $(GMP_LIBS) $(LIBS)
+snd: $(SNDLIB_HEADERS) $(SND_HEADERS) $(GX_HEADERS) $(S7_HEADERS) $(S7_O_FILES) $(SNDLIB_O_FILES) $(O_FILES) $(GX_FILES) $(GL_FILES) $(WEBSERVER_FILES)
+ $(CC) $(LDFLAGS) $(CFLAGS) $(S7_O_FILES) $(SNDLIB_O_FILES) $(O_FILES) $(GX_FILES) $(GL_FILES) $(WEBSERVER_FILES) -o snd $(SNDLIB_LIB) $(XEN_LIBS) $(GTK_LIBS) $(GL_LIBS) $(WEBSERVER_LIBS) $(JACK_LIBS) $(AUDIO_LIB) $(FFTW_LIBS) $(GSL_LIBS) $(GMP_LIBS) $(LIBS)
xm: xen.h mus-config.h $(S7_HEADERS)
$(CC) -c xm.c -DUSE_SND=0 $(DEFS) $(SO_FLAGS) $(GTK_CFLAGS) $(CAIRO_CFLAGS) $(CFLAGS) $(XEN_CFLAGS) $(GSL_FLAGS) $(JACK_FLAGS) $(GL_FLAGS)
@@ -116,6 +118,12 @@ $(MOTIF_O_FILES): $(SNDLIB_HEADERS) $(SND_HEADERS) $(SND_X_HEADERS) $(S7_HEADERS
$(GTK_O_FILES): $(SNDLIB_HEADERS) $(SND_HEADERS) $(SND_G_HEADERS) $(S7_HEADERS)
$(S7_O_FILES): $(S7_HEADERS) $(S7_FILES)
+s7webserver/s7webserver.o: s7webserver/s7webserver.cpp
+ cd s7webserver && make s7webserver.o
+
+s7webserver/qhttpserver-master/lib/libqhttpserver.a:
+ cd s7webserver && make qhttpserver-master/lib/libqhttpserver.a
+
clean:
rm -f $(SNDLIB_O_FILES)
rm -f $(O_FILES)
diff --git a/maraca.scm b/maraca.scm
index fcc2c15..4870f38 100644
--- a/maraca.scm
+++ b/maraca.scm
@@ -40,7 +40,7 @@
(begin
;; shake over 50msec and add shake energy
(set! temp (+ temp h20))
- (set! shake-energy (+ shake-energy (- 1.0 (cos temp))))))
+ (set! shake-energy (- (+ shake-energy 1.0) (cos temp)))))
(set! shake-energy (* shake-energy system-decay))
;; if collision, add energy
(if (< (random 1.0) probability)
@@ -103,7 +103,7 @@
(begin
;; shake over 50msec and add shake energy
(set! temp (+ temp h20))
- (set! shake-energy (+ shake-energy (- 1.0 (cos temp))))))
+ (set! shake-energy (- (+ shake-energy 1.0) (cos temp)))))
(set! shake-energy (* shake-energy system-decay))
;; if collision, add energy
@@ -126,10 +126,9 @@
(do ((j 0 (+ j 1)))
((= j resn))
(set! sum (+ sum (two-pole (vector-ref tzs j) input))))
-
- (if with-filters
- (outa k (one-zero oz (- sum last-sum)))
- (outa k (* sndamp sum))))))))
+ (outa k (if with-filters
+ (one-zero oz (- sum last-sum))
+ (* sndamp sum))))))))
;;; tambourine: (with-sound (:play #t :statistics #t) (big-maraca 0 1 .25 0.95 0.9985 .03125 '(2300 5600 8100) '(0.96 0.995 0.995) .01))
;;; sleighbells: (with-sound (:play #t :statistics #t) (big-maraca 0 2 .15 0.97 0.9994 0.03125 '(2500 5300 6500 8300 9800) '(0.999 0.999 0.999 0.999 0.999)))
diff --git a/marks-menu.scm b/marks-menu.scm
index fb2f4b3..30708e7 100644
--- a/marks-menu.scm
+++ b/marks-menu.scm
@@ -55,8 +55,9 @@
(lambda ()
(play-between-marks (integer->mark play-between-marks-m1) (integer->mark play-between-marks-m2)))))
-(if (or (provided? 'xm)
- (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! play-between-marks-menu-label (add-to-menu marks-menu play-between-marks-label cp-play-between-marks))
(begin
(define (set-syncs)
@@ -66,10 +67,9 @@
(lambda (chan-marks)
(for-each
(lambda (m)
- (if (or (= (mark->integer m) play-between-marks-m1)
- (= (mark->integer m) play-between-marks-m2))
- (set! (sync m) 1)
- (set! (sync m) 0)))
+ (set! (sync m) (if (or (= (mark->integer m) play-between-marks-m1)
+ (= (mark->integer m) play-between-marks-m2))
+ 1 0)))
chan-marks))
snd-marks))
(marks))
@@ -82,98 +82,92 @@
(apply min (map mark->integer (marks (selected-sound) (selected-channel)))))
(define (post-play-between-marks-dialog)
- (if (not play-between-marks-dialog)
- (let ((inits (find-two-marks))
- (max-mark-id (max-mark))
- (sliders ()))
-
- (if (null? inits)
- (snd-display ";no marks")
+ (unless play-between-marks-dialog
+ (let ((inits (find-two-marks))
+ (max-mark-id (max-mark))
+ (sliders ()))
+
+ (if (null? inits)
+ (snd-display ";no marks")
+
+ (begin
+ (set! play-between-marks-m1 (car inits))
+ (set! play-between-marks-m2 (cadr inits))
+ (set-syncs)
+ (mark-sync-color "yellow")
- (begin
- (set! play-between-marks-m1 (car inits))
- (set! play-between-marks-m2 (cadr inits))
- (set-syncs)
- (mark-sync-color "yellow")
-
- (set! play-between-marks-dialog
- (make-effect-dialog
- play-between-marks-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-play-between-marks))
- (lambda (w context info) (cp-play-between-marks)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Define selection by marks Help"
- "Plays area between specified marks. Use the sliders to select the boundary marks."))
- (lambda (w context info)
- (help-dialog "Define selection by marks Help"
- "Plays area between specified marks. Use the sliders to select the boundary marks.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) play-between-marks-m1)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) play-between-marks-m2)
- )
- (lambda (w c i)
- ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) play-between-marks-m1))
- ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) play-between-marks-m2))))))
-
- (set! sliders
- (add-sliders
- play-between-marks-dialog
- (list (list "mark one" 0 play-between-marks-m1 max-mark-id
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (set! play-between-marks-m1 ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)))
- (set-syncs))
- (lambda (w context info)
- (set! play-between-marks-m1 ((*motif* '.value) info))
- (set-syncs)))
- 1)
- (list "mark two" 0 play-between-marks-m2 max-mark-id
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (set! play-between-marks-m2 ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)))
- (set-syncs))
- (lambda (w context info)
- (set! play-between-marks-m2 ((*motif* '.value) info))
- (set-syncs)))
- 1))))
-
- (if (provided? 'snd-motif)
- (with-let (sublet *motif*)
- (hook-push select-channel-hook (lambda (hook)
- (let ((max-ms (max-mark))
- (min-ms (min-mark))
- (current-ms (find-two-marks)))
- (if (null? current-ms)
- (set! current-ms (list min-ms max-ms)))
- (if max-ms
- (for-each
- (lambda (slider)
- (XtVaSetValues slider
- (list XmNmaximum max-ms
- XmNminimum min-ms
- XmNvalue (car current-ms)))
- (set! current-ms (cdr current-ms)))
- sliders)))))
- (hook-push mark-hook (lambda (hook)
- (if (and (= (hook 'snd) (selected-sound))
- (= (hook 'chn) (selected-channel))
- (= (hook 'reason) 0)) ; add-mark
- (for-each
- (lambda (slider)
- (XtVaSetValues slider (list XmNmaximum (max-mark))))
- sliders))))))))
- (if play-between-marks-dialog
- (activate-dialog play-between-marks-dialog)))))
+ (set! play-between-marks-dialog
+ (make-effect-dialog play-between-marks-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-play-between-marks))
+ (lambda (w context)
+ (help-dialog "Define selection by marks Help"
+ "Plays area between specified marks. Use the sliders to select the boundary marks."))
+ (lambda (w data)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) play-between-marks-m1)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) play-between-marks-m2)))
+ (values (lambda (w context info)
+ (cp-play-between-marks))
+ (lambda (w context info)
+ (help-dialog "Define selection by marks Help"
+ "Plays area between specified marks. Use the sliders to select the boundary marks."))
+ (lambda (w c i)
+ ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) play-between-marks-m1))
+ ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) play-between-marks-m2)))))))
+ (set! sliders
+ (add-sliders
+ play-between-marks-dialog
+ (list (list "mark one" 0 play-between-marks-m1 max-mark-id
+ (if (provided? 'snd-gtk)
+ (lambda (w context)
+ (set! play-between-marks-m1 ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)))
+ (set-syncs))
+ (lambda (w context info)
+ (set! play-between-marks-m1 ((*motif* '.value) info))
+ (set-syncs)))
+ 1)
+ (list "mark two" 0 play-between-marks-m2 max-mark-id
+ (if (provided? 'snd-gtk)
+ (lambda (w context)
+ (set! play-between-marks-m2 ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)))
+ (set-syncs))
+ (lambda (w context info)
+ (set! play-between-marks-m2 ((*motif* '.value) info))
+ (set-syncs)))
+ 1))))
+
+ (if (provided? 'snd-motif)
+ (with-let (sublet *motif*)
+ (hook-push select-channel-hook (lambda (hook)
+ (let ((max-ms (max-mark))
+ (min-ms (min-mark))
+ (current-ms (find-two-marks)))
+ (if (null? current-ms)
+ (set! current-ms (list min-ms max-ms)))
+ (if max-ms
+ (for-each
+ (lambda (slider)
+ (XtVaSetValues slider
+ (list XmNmaximum max-ms
+ XmNminimum min-ms
+ XmNvalue (car current-ms)))
+ (set! current-ms (cdr current-ms)))
+ sliders)))))
+ (hook-push mark-hook (lambda (hook)
+ (if (and (= (hook 'snd) (selected-sound))
+ (= (hook 'chn) (selected-channel))
+ (= (hook 'reason) 0)) ; add-mark
+ (for-each
+ (lambda (slider)
+ (XtVaSetValues slider (list XmNmaximum (max-mark))))
+ sliders))))))))
+ (if play-between-marks-dialog
+ (activate-dialog play-between-marks-dialog)))))
- (set! play-between-marks-menu-label (add-to-menu marks-menu "Play between marks" post-play-between-marks-dialog)))
-
- (set! play-between-marks-menu-label (add-to-menu marks-menu play-between-marks-label cp-play-between-marks)))
+ (set! play-between-marks-menu-label (add-to-menu marks-menu "Play between marks" post-play-between-marks-dialog))))
+
+
(set! marks-list (cons (lambda ()
(let ((new-label (format #f "Play between marks (~D ~D)" play-between-marks-m1 play-between-marks-m2)))
@@ -184,163 +178,162 @@
;;; -------- Loop play between marks
-(if (provided? 'xm)
- (with-let (sublet *motif*)
-
- (define loop-between-marks-m1 0)
- (define loop-between-marks-m2 1)
- (define loop-between-marks-buffer-size 512)
- (define loop-between-marks-label "Loop play between marks")
- (define loop-between-marks-dialog #f)
- (define loop-between-marks-default-buffer-widget #f)
- (define loop-between-marks-menu-label #f)
-
- (define use-combo-box-for-buffer-size #f) ; radio-buttons or combo-box choice
-
- (define (cp-loop-between-marks)
- ;; cp-loop-between-marks) loops between two marks, playing (marks-menu)
- (loop-between-marks (integer->mark loop-between-marks-m1) (integer->mark loop-between-marks-m2) loop-between-marks-buffer-size))
-
- (define (overall-max-mark-id default-max)
- (let ((maxid default-max))
- (for-each
- (lambda (snd-marks)
- (for-each
- (lambda (chan-marks)
- (for-each
- (lambda (m)
- (set! maxid (max maxid (mark->integer m))))
- chan-marks))
- snd-marks))
- (marks))
- maxid))
-
- (define (post-loop-between-marks-dialog)
- (if (not loop-between-marks-dialog)
- ;; if loop-between-marks-dialog doesn't exist, create it
- (let ((initial-loop-between-marks-m1 0)
- (initial-loop-between-marks-m2 1)
- (sliders ())
- (max-mark-id (overall-max-mark-id 25)))
- (set! loop-between-marks-dialog
- (make-effect-dialog
- loop-between-marks-label
- (lambda (w context info)
- (cp-loop-between-marks))
- (lambda (w context info)
- (help-dialog "Loop play between marks"
- "Move the sliders to set the mark numbers. Check a radio button to set the buffer size."))
- (lambda (w c i)
- (stop-playing))))
- (set! sliders
- (add-sliders
- loop-between-marks-dialog
- (list (list "mark one" 0 initial-loop-between-marks-m1 max-mark-id
- (lambda (w context info)
- (set! loop-between-marks-m1 (.value info)))
- 1)
- (list "mark two" 0 initial-loop-between-marks-m2 max-mark-id
- (lambda (w context info)
- (set! loop-between-marks-m2 (.value info)))
- 1))))
-
- ;; now add either a radio-button box or a combo-box for the buffer size
- ;; need to use XtParent here since "mainform" isn't returned by add-sliders
-
- (if use-combo-box-for-buffer-size
- ;; this block creates a "combo box" to handle the buffer size
- (let* ((s1 (XmStringCreateLocalized "Buffer size"))
- (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
- (list XmNborderWidth 1
- XmNshadowType XmSHADOW_ETCHED_IN
- XmNpositionIndex 2)))
- (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (lab (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNlabelString s1
- XmNbackground *basic-color*)))
- (buffer-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "2048" "4096")))
- (combo (XtCreateManagedWidget "buffersize" xmComboBoxWidgetClass frm
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget lab
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNitems buffer-labels
- XmNitemCount (length buffer-labels)
- XmNcomboBoxType XmDROP_DOWN_COMBO_BOX
- XmNbackground *basic-color*))))
- (set! loop-between-marks-default-buffer-widget combo)
- (for-each XmStringFree buffer-labels)
- (XmStringFree s1)
- (XtSetValues combo (list XmNselectedPosition 1))
- (XtAddCallback combo XmNselectionCallback
- (lambda (w c i)
- (let* ((selected (.item_or_text i))
- (size-as-string (XmStringUnparse selected #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (set! loop-between-marks-buffer-size (string->number size-as-string))))))
-
- ;; this block creates a "radio button box"
- (let* ((s1 (XmStringCreateLocalized "Buffer size"))
- (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
- (list XmNborderWidth 1
- XmNshadowType XmSHADOW_ETCHED_IN
- XmNpositionIndex 2)))
- (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (rc (XtCreateManagedWidget "rc" xmRowColumnWidgetClass frm
- (list XmNorientation XmHORIZONTAL
- XmNradioBehavior #t
- XmNradioAlwaysOne #t
- XmNentryClass xmToggleButtonWidgetClass
- XmNisHomogeneous #t
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNbackground *basic-color*))))
- (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget rc
- XmNbottomAttachment XmATTACH_FORM
- XmNlabelString s1
- XmNalignment XmALIGNMENT_BEGINNING
- XmNbackground *basic-color*))
- (for-each
-
- (lambda (size)
- (let ((button (XtCreateManagedWidget (format #f "~D" size) xmToggleButtonWidgetClass rc
- (list XmNbackground *basic-color*
- XmNvalueChangedCallback (list (lambda (w c i) (if (.set i) (set! loop-between-marks-buffer-size c))) size)
- XmNset (= size loop-between-marks-buffer-size)))))
- (if (= size loop-between-marks-buffer-size)
- (set! loop-between-marks-default-buffer-widget button))))
- (list 64 128 256 512 1024 2048 4096))
- (XmStringFree s1)))))
- (activate-dialog loop-between-marks-dialog))
-
- (set! loop-between-marks-menu-label (add-to-menu marks-menu "Loop play between marks" post-loop-between-marks-dialog))
-
- (set! marks-list (cons (lambda ()
- (let ((new-label (format #f "Loop play between marks (~D ~D ~D)"
- loop-between-marks-m1 loop-between-marks-m2 loop-between-marks-buffer-size)))
- (if loop-between-marks-menu-label (change-label loop-between-marks-menu-label new-label))
- (set! loop-between-marks-label new-label)))
- marks-list))))
+(when (provided? 'xm)
+ (with-let (sublet *motif*)
+
+ (define loop-between-marks-m1 0)
+ (define loop-between-marks-m2 1)
+ (define loop-between-marks-buffer-size 512)
+ (define loop-between-marks-label "Loop play between marks")
+ (define loop-between-marks-dialog #f)
+ (define loop-between-marks-default-buffer-widget #f)
+ (define loop-between-marks-menu-label #f)
+
+ (define use-combo-box-for-buffer-size #f) ; radio-buttons or combo-box choice
+
+ (define (cp-loop-between-marks)
+ ;; cp-loop-between-marks) loops between two marks, playing (marks-menu)
+ (loop-between-marks (integer->mark loop-between-marks-m1) (integer->mark loop-between-marks-m2) loop-between-marks-buffer-size))
+
+ (define (overall-max-mark-id default-max)
+ (let ((maxid default-max))
+ (for-each
+ (lambda (snd-marks)
+ (for-each
+ (lambda (chan-marks)
+ (for-each
+ (lambda (m)
+ (set! maxid (max maxid (mark->integer m))))
+ chan-marks))
+ snd-marks))
+ (marks))
+ maxid))
+
+ (define (post-loop-between-marks-dialog)
+ (unless loop-between-marks-dialog
+ ;; if loop-between-marks-dialog doesn't exist, create it
+ (let ((initial-loop-between-marks-m1 0)
+ (initial-loop-between-marks-m2 1)
+ (sliders ())
+ (max-mark-id (overall-max-mark-id 25)))
+ (set! loop-between-marks-dialog
+ (make-effect-dialog
+ loop-between-marks-label
+ (lambda (w context info)
+ (cp-loop-between-marks))
+ (lambda (w context info)
+ (help-dialog "Loop play between marks"
+ "Move the sliders to set the mark numbers. Check a radio button to set the buffer size."))
+ (lambda (w c i)
+ (stop-playing))))
+ (set! sliders
+ (add-sliders
+ loop-between-marks-dialog
+ (list (list "mark one" 0 initial-loop-between-marks-m1 max-mark-id
+ (lambda (w context info)
+ (set! loop-between-marks-m1 (.value info)))
+ 1)
+ (list "mark two" 0 initial-loop-between-marks-m2 max-mark-id
+ (lambda (w context info)
+ (set! loop-between-marks-m2 (.value info)))
+ 1))))
+
+ ;; now add either a radio-button box or a combo-box for the buffer size
+ ;; need to use XtParent here since "mainform" isn't returned by add-sliders
+
+ (if use-combo-box-for-buffer-size
+ ;; this block creates a "combo box" to handle the buffer size
+ (let* ((s1 (XmStringCreateLocalized "Buffer size"))
+ (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
+ (list XmNborderWidth 1
+ XmNshadowType XmSHADOW_ETCHED_IN
+ XmNpositionIndex 2)))
+ (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (lab (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNlabelString s1
+ XmNbackground *basic-color*)))
+ (buffer-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "2048" "4096")))
+ (combo (XtCreateManagedWidget "buffersize" xmComboBoxWidgetClass frm
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget lab
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNitems buffer-labels
+ XmNitemCount (length buffer-labels)
+ XmNcomboBoxType XmDROP_DOWN_COMBO_BOX
+ XmNbackground *basic-color*))))
+ (set! loop-between-marks-default-buffer-widget combo)
+ (for-each XmStringFree buffer-labels)
+ (XmStringFree s1)
+ (XtSetValues combo (list XmNselectedPosition 1))
+ (XtAddCallback combo XmNselectionCallback
+ (lambda (w c i)
+ (set! loop-between-marks-buffer-size
+ (string->number (XmStringUnparse (.item_or_text i) #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL))))))
+
+ ;; this block creates a "radio button box"
+ (let* ((s1 (XmStringCreateLocalized "Buffer size"))
+ (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
+ (list XmNborderWidth 1
+ XmNshadowType XmSHADOW_ETCHED_IN
+ XmNpositionIndex 2)))
+ (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (rc (XtCreateManagedWidget "rc" xmRowColumnWidgetClass frm
+ (list XmNorientation XmHORIZONTAL
+ XmNradioBehavior #t
+ XmNradioAlwaysOne #t
+ XmNentryClass xmToggleButtonWidgetClass
+ XmNisHomogeneous #t
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNbackground *basic-color*))))
+ (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget rc
+ XmNbottomAttachment XmATTACH_FORM
+ XmNlabelString s1
+ XmNalignment XmALIGNMENT_BEGINNING
+ XmNbackground *basic-color*))
+ (for-each
+
+ (lambda (size)
+ (let ((button (XtCreateManagedWidget (format #f "~D" size) xmToggleButtonWidgetClass rc
+ (list XmNbackground *basic-color*
+ XmNvalueChangedCallback (list (lambda (w c i) (if (.set i) (set! loop-between-marks-buffer-size c))) size)
+ XmNset (= size loop-between-marks-buffer-size)))))
+ (if (= size loop-between-marks-buffer-size)
+ (set! loop-between-marks-default-buffer-widget button))))
+ (list 64 128 256 512 1024 2048 4096))
+ (XmStringFree s1)))))
+ (activate-dialog loop-between-marks-dialog))
+
+ (set! loop-between-marks-menu-label (add-to-menu marks-menu "Loop play between marks" post-loop-between-marks-dialog))
+
+ (set! marks-list (cons (lambda ()
+ (let ((new-label (format #f "Loop play between marks (~D ~D ~D)"
+ loop-between-marks-m1 loop-between-marks-m2 loop-between-marks-buffer-size)))
+ (if loop-between-marks-menu-label (change-label loop-between-marks-menu-label new-label))
+ (set! loop-between-marks-label new-label)))
+ marks-list))))
(add-to-menu marks-menu #f #f)
@@ -352,7 +345,7 @@
(lambda ()
(let ((snc (sync)))
(define (trim-front-one-channel snd chn)
- (if (< (length (marks snd chn)) 1)
+ (if (null? (marks snd chn))
(status-report "trim-front needs a mark" snd)
(delete-samples 0 (mark-sample (car (marks snd chn))) snd chn)))
(if (> snc 0)
@@ -370,7 +363,7 @@
(lambda ()
(let ((snc (sync)))
(define (trim-back-one-channel snd chn)
- (if (< (length (marks snd chn)) 1)
+ (if (null? (marks snd chn))
(status-report "trim-back needs a mark" snd)
(let ((endpt (mark-sample (car (reverse (marks snd chn))))))
(delete-samples (+ endpt 1) (- (framples snd chn) endpt)))))
@@ -428,65 +421,59 @@
(fit-selection-between-marks (integer->mark fit-to-mark-one) (integer->mark fit-to-mark-two))
(define-selection-via-marks (integer->mark fit-to-mark-one) (integer->mark fit-to-mark-two))))))
-(if (or (provided? 'xm)
- (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! fit-to-mark-menu-label (add-to-menu marks-menu fit-to-mark-label cp-fit-to-marks))
(begin
(define (post-fit-to-mark-dialog)
- (if (not fit-to-mark-dialog)
- (let ((initial-fit-to-mark-one 0)
- (initial-fit-to-mark-two 1)
- (sliders ()))
-
- (set! fit-to-mark-dialog
- (make-effect-dialog
- fit-to-mark-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-fit-to-marks))
- (lambda (w context info) (cp-fit-to-marks)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Fit selection to marks Help"
- "Fit-selection-between-marks tries to squeeze the current selection between two marks,\
-using the granulate generator to fix up the selection duration (this still is not perfect). Move the sliders to set the mark numbers."))
- (lambda (w context info)
- (help-dialog "Fit selection to marks Help"
- "Fit-selection-between-marks tries to squeeze the current selection between two marks,\
-using the granulate generator to fix up the selection duration (this still is not perfect). Move the sliders to set the mark numbers.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! fit-to-mark-one initial-fit-to-mark-one)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) fit-to-mark-one)
- (set! fit-to-mark-two initial-fit-to-mark-two)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) fit-to-mark-two)
- )
- (lambda (w c i)
- (set! fit-to-mark-one initial-fit-to-mark-one)
- ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) fit-to-mark-one))
- (set! fit-to-mark-two initial-fit-to-mark-two)
- ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) fit-to-mark-two))))))
-
- (set! sliders
- (add-sliders
- fit-to-mark-dialog
- (list (list "mark one" 0 initial-fit-to-mark-one 20
- (if (provided? 'snd-gtk)
- (lambda (w context) (set! fit-to-mark-one ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fit-to-mark-one ((*motif* '.value) info))))
- 1)
- (list "mark two" 0 initial-fit-to-mark-two 20
- (if (provided? 'snd-gtk)
- (lambda (w context) (set! fit-to-mark-two ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fit-to-mark-two (.value info))))
- 1))))))
+ (unless fit-to-mark-dialog
+ (let ((initial-fit-to-mark-one 0)
+ (initial-fit-to-mark-two 1)
+ (sliders ()))
+
+ (set! fit-to-mark-dialog
+ (make-effect-dialog fit-to-mark-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-fit-to-marks))
+ (lambda (w context)
+ (help-dialog "Fit selection to marks Help"
+ "Fit-selection-between-marks tries to squeeze the current selection \
+between two marks,using the granulate generator to fix up the selection duration (this still is not perfect). Move the sliders to set the mark numbers."))
+ (lambda (w data)
+ (set! fit-to-mark-one initial-fit-to-mark-one)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) fit-to-mark-one)
+ (set! fit-to-mark-two initial-fit-to-mark-two)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) fit-to-mark-two)))
+ (values (lambda (w context info)
+ (cp-fit-to-marks))
+ (lambda (w context info)
+ (help-dialog "Fit selection to marks Help"
+ "Fit-selection-between-marks tries to squeeze the current selection \
+between two marks,using the granulate generator to fix up the selection duration (this still is not perfect). Move the sliders to set the mark numbers."))
+ (lambda (w c i)
+ (set! fit-to-mark-one initial-fit-to-mark-one)
+ ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) fit-to-mark-one))
+ (set! fit-to-mark-two initial-fit-to-mark-two)
+ ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) fit-to-mark-two)))))))
+ (set! sliders
+ (add-sliders
+ fit-to-mark-dialog
+ (list (list "mark one" 0 initial-fit-to-mark-one 20
+ (if (provided? 'snd-gtk)
+ (lambda (w context) (set! fit-to-mark-one ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fit-to-mark-one ((*motif* '.value) info))))
+ 1)
+ (list "mark two" 0 initial-fit-to-mark-two 20
+ (if (provided? 'snd-gtk)
+ (lambda (w context) (set! fit-to-mark-two ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fit-to-mark-two (.value info))))
+ 1))))))
(activate-dialog fit-to-mark-dialog))
- (set! fit-to-mark-menu-label (add-to-menu marks-menu "Fit selection to marks" post-fit-to-mark-dialog)))
-
- (set! fit-to-mark-menu-label (add-to-menu marks-menu fit-to-mark-label cp-fit-to-marks)))
+ (set! fit-to-mark-menu-label (add-to-menu marks-menu "Fit selection to marks" post-fit-to-mark-dialog))))
+
(set! marks-list (cons (lambda ()
(let ((new-label (format #f "Fit selection to marks (~D ~D)" fit-to-mark-one fit-to-mark-two)))
@@ -516,67 +503,62 @@ using the granulate generator to fix up the selection duration (this still is no
(chn (cadr m1sc)))
(set! (selection-member? snd chn) #t)
(set! (selection-position snd chn) beg)
- (set! (selection-framples snd chn) (+ 1 (- end beg)))))))))
+ (set! (selection-framples snd chn) (- (+ end 1) beg))))))))
(define (cp-define-by-marks)
(define-selection-via-marks (integer->mark define-by-mark-one) (integer->mark define-by-mark-two)))
-(if (or (provided? 'xm) (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! define-by-mark-menu-label (add-to-menu marks-menu define-by-mark-label cp-define-by-marks))
(begin
(define (post-define-by-mark-dialog)
- (if (not define-by-mark-dialog)
- (let ((initial-define-by-mark-one 0)
- (initial-define-by-mark-two 1)
- (sliders ()))
-
- (set! define-by-mark-dialog
- (make-effect-dialog
- define-by-mark-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-define-by-marks))
- (lambda (w context info) (cp-define-by-marks)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Define selection by marks Help"
- "Selects and highlights area between marks. Use the sliders to choose the boundary marks."))
- (lambda (w context info)
- (help-dialog "Define selection by marks Help"
- "Selects and highlights area between marks. Use the sliders to choose the boundary marks.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! define-by-mark-one initial-define-by-mark-one)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) define-by-mark-one)
- (set! define-by-mark-two initial-define-by-mark-two)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) define-by-mark-two)
- )
- (lambda (w c i)
- (set! define-by-mark-one initial-define-by-mark-one)
- ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) define-by-mark-one))
- (set! define-by-mark-two initial-define-by-mark-two)
- ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) define-by-mark-two))))))
-
- (set! sliders
- (add-sliders
- define-by-mark-dialog
- (list (list "mark one" 0 initial-define-by-mark-one 25
- (if (provided? 'snd-gtk)
- (lambda (w context) (set! define-by-mark-one ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! define-by-mark-one ((*motif* '.value) info))))
- 1)
- (list "mark two" 0 initial-define-by-mark-two 25
- (if (provided? 'snd-gtk)
- (lambda (w context) (set! define-by-mark-two ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! define-by-mark-two ((*motif* '.value) info))))
- 1))))))
+ (unless define-by-mark-dialog
+ (let ((initial-define-by-mark-one 0)
+ (initial-define-by-mark-two 1)
+ (sliders ()))
+
+ (set! define-by-mark-dialog
+ (make-effect-dialog define-by-mark-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-define-by-marks))
+ (lambda (w context)
+ (help-dialog "Define selection by marks Help"
+ "Selects and highlights area between marks. Use the sliders to choose the boundary marks."))
+ (lambda (w data)
+ (set! define-by-mark-one initial-define-by-mark-one)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) define-by-mark-one)
+ (set! define-by-mark-two initial-define-by-mark-two)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (cadr sliders)) define-by-mark-two)))
+ (values (lambda (w context info)
+ (cp-define-by-marks))
+ (lambda (w context info)
+ (help-dialog "Define selection by marks Help"
+ "Selects and highlights area between marks. Use the sliders to choose the boundary marks."))
+ (lambda (w c i)
+ (set! define-by-mark-one initial-define-by-mark-one)
+ ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) define-by-mark-one))
+ (set! define-by-mark-two initial-define-by-mark-two)
+ ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) define-by-mark-two)))))))
+ (set! sliders
+ (add-sliders
+ define-by-mark-dialog
+ (list (list "mark one" 0 initial-define-by-mark-one 25
+ (if (provided? 'snd-gtk)
+ (lambda (w context) (set! define-by-mark-one ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! define-by-mark-one ((*motif* '.value) info))))
+ 1)
+ (list "mark two" 0 initial-define-by-mark-two 25
+ (if (provided? 'snd-gtk)
+ (lambda (w context) (set! define-by-mark-two ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! define-by-mark-two ((*motif* '.value) info))))
+ 1))))))
(activate-dialog define-by-mark-dialog))
- (set! define-by-mark-menu-label (add-to-menu marks-menu "Define selection by marks" post-define-by-mark-dialog)))
-
- (set! define-by-mark-menu-label (add-to-menu marks-menu define-by-mark-label cp-define-by-marks)))
+ (set! define-by-mark-menu-label (add-to-menu marks-menu "Define selection by marks" post-define-by-mark-dialog))))
+
(set! marks-list (cons (lambda ()
(let ((new-label (format #f "Define selection by marks (~D ~D)" define-by-mark-one define-by-mark-two)))
@@ -649,296 +631,275 @@ using the granulate generator to fix up the selection duration (this still is no
;;; -------- mark loop dialog (this refers to sound header mark points, not Snd mark objects!)
-(if (provided? 'xm)
- (with-let (sublet *motif*)
-
- ;; Here is a first stab at the loop dialog (I guessed a lot as to what these buttons
- ;; are supposed to do -- have never used these loop points).
-
- (define loop-dialog #f)
- (define loop-data '(0 0 0 0 0 0 1 1))
-
- (define (update-labels start range end sus-rel range-in-secs)
- (if range-in-secs
- (begin
- (change-label start (format #f "~,3F" (/ (loop-data (* sus-rel 2)) (srate))))
- (change-label range (format #f "~,3F" (/ (- (loop-data (+ 1 (* sus-rel 2))) (loop-data (* sus-rel 2))) (srate))))
- (change-label end (format #f "~,3F" (/ (loop-data (+ 1 (* sus-rel 2))) (srate)))))
- (begin
- (change-label start (format #f "~D" (loop-data (* sus-rel 2))))
- (change-label range (format #f "~D" (- (loop-data (+ 1 (* sus-rel 2))) (loop-data (* sus-rel 2)))))
- (change-label end (format #f "~D" (loop-data (+ 1 (* sus-rel 2))))))))
-
- (define (create-loop-dialog)
- (if (not (Widget? loop-dialog))
- (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
- (xsave (XmStringCreate "Save" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "Loop Points" XmFONTLIST_DEFAULT_TAG)))
- (set! loop-dialog
- (XmCreateTemplateDialog (cadr (main-widgets)) "loop-points"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNokLabelString xsave
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNbackground *basic-color*
- XmNtransient #f)))
- (XtAddCallback loop-dialog
- XmNcancelCallback (lambda (w context info)
- (XtUnmanageChild loop-dialog)))
- (XtAddCallback loop-dialog
- XmNhelpCallback (lambda (w context info)
- (snd-print "set loop points")))
- (XtAddCallback loop-dialog
- XmNokCallback (lambda (w context info)
- (set! (sound-loop-info) loop-data)))
- (XmStringFree xhelp)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
- (XmStringFree xsave)
- (let* ((mainform
- (XtCreateManagedWidget "form" xmFormWidgetClass loop-dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild loop-dialog XmDIALOG_SEPARATOR)
- XmNbackground *basic-color*)))
- (leftform
- (XtCreateManagedWidget "lform" xmFormWidgetClass mainform
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_POSITION
- XmNrightPosition 50
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (rightform
- (XtCreateManagedWidget "rform" xmFormWidgetClass mainform
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget leftform
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*))))
- (for-each
- (lambda (parent top-label offset)
- (let* ((main-label (XtCreateManagedWidget top-label xmLabelWidgetClass parent
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE)))
- (main-frame (XtCreateManagedWidget "fr" xmFrameWidgetClass parent
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget main-label
- XmNbottomAttachment XmATTACH_FORM
- XmNshadowThickness 6
- XmNshadowType XmSHADOW_ETCHED_OUT)))
- (frame-form (XtCreateManagedWidget "fform" xmFormWidgetClass main-frame ()))
- (top-frame (XtCreateManagedWidget "topf" xmFrameWidgetClass frame-form
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE)))
- (top-form (XtCreateManagedWidget "tform" xmFormWidgetClass top-frame ()))
- (left-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form
- (list XmNorientation XmVERTICAL
- XmNbackground *position-color*
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_POSITION
- XmNrightPosition 40
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM)))
- (mid-column (XtCreateManagedWidget "lcol" xmFormWidgetClass top-form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget left-column
- XmNrightAttachment XmATTACH_POSITION
- XmNrightPosition 60
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM)))
- (right-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form
- (list XmNorientation XmVERTICAL
- XmNbackground *position-color*
- XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget mid-column
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM)))
- (rowlefttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column
+(when (provided? 'xm)
+ (with-let (sublet *motif*)
+
+ ;; Here is a first stab at the loop dialog (I guessed a lot as to what these buttons
+ ;; are supposed to do -- have never used these loop points).
+
+ (define loop-dialog #f)
+ (define loop-data '(0 0 0 0 0 0 1 1))
+
+ (define (update-labels start range end sus-rel range-in-secs)
+ (if range-in-secs
+ (begin
+ (change-label start (format #f "~,3F" (/ (loop-data (* sus-rel 2)) (srate))))
+ (change-label range (format #f "~,3F" (/ (- (loop-data (+ 1 (* sus-rel 2))) (loop-data (* sus-rel 2))) (srate))))
+ (change-label end (format #f "~,3F" (/ (loop-data (+ 1 (* sus-rel 2))) (srate)))))
+ (begin
+ (change-label start (format #f "~D" (loop-data (* sus-rel 2))))
+ (change-label range (format #f "~D" (- (loop-data (+ 1 (* sus-rel 2))) (loop-data (* sus-rel 2)))))
+ (change-label end (format #f "~D" (loop-data (+ 1 (* sus-rel 2))))))))
+
+ (define (create-loop-dialog)
+ (unless (Widget? loop-dialog)
+ (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+ (xsave (XmStringCreate "Save" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "Loop Points" XmFONTLIST_DEFAULT_TAG)))
+ (set! loop-dialog
+ (XmCreateTemplateDialog (cadr (main-widgets)) "loop-points"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNokLabelString xsave
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNbackground *basic-color*
+ XmNtransient #f)))
+ (XtAddCallback loop-dialog
+ XmNcancelCallback (lambda (w context info)
+ (XtUnmanageChild loop-dialog)))
+ (XtAddCallback loop-dialog
+ XmNhelpCallback (lambda (w context info)
+ (snd-print "set loop points")))
+ (XtAddCallback loop-dialog
+ XmNokCallback (lambda (w context info)
+ (set! (sound-loop-info) loop-data)))
+ (for-each XmStringFree (vector xhelp xdismiss titlestr xsave))
+ (let* ((mainform
+ (XtCreateManagedWidget "form" xmFormWidgetClass loop-dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild loop-dialog XmDIALOG_SEPARATOR)
+ XmNbackground *basic-color*)))
+ (leftform
+ (XtCreateManagedWidget "lform" xmFormWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_POSITION
+ XmNrightPosition 50
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (rightform
+ (XtCreateManagedWidget "rform" xmFormWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget leftform
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*))))
+ (for-each
+ (lambda (parent top-label offset)
+ (let* ((main-label (XtCreateManagedWidget top-label xmLabelWidgetClass parent
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE)))
+ (main-frame (XtCreateManagedWidget "fr" xmFrameWidgetClass parent
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget main-label
+ XmNbottomAttachment XmATTACH_FORM
+ XmNshadowThickness 6
+ XmNshadowType XmSHADOW_ETCHED_OUT)))
+ (frame-form (XtCreateManagedWidget "fform" xmFormWidgetClass main-frame ()))
+ (top-frame (XtCreateManagedWidget "topf" xmFrameWidgetClass frame-form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE)))
+ (top-form (XtCreateManagedWidget "tform" xmFormWidgetClass top-frame ()))
+ (left-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form
+ (list XmNorientation XmVERTICAL
+ XmNbackground *position-color*
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_POSITION
+ XmNrightPosition 40
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM)))
+ (mid-column (XtCreateManagedWidget "lcol" xmFormWidgetClass top-form
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget left-column
+ XmNrightAttachment XmATTACH_POSITION
+ XmNrightPosition 60
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM)))
+ (right-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form
+ (list XmNorientation XmVERTICAL
+ XmNbackground *position-color*
+ XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget mid-column
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM)))
+ (rowlefttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column
+ (list XmNorientation XmHORIZONTAL
+ XmNbackground *position-color*
+ XmNspacing 0)))
+ (leftrange (XtCreateManagedWidget "range" xmPushButtonWidgetClass left-column ()))
+ (rowleftbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column
+ (list XmNorientation XmHORIZONTAL
+ XmNbackground *position-color*
+ XmNspacing 0)))
+ (rowrighttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column
+ (list XmNorientation XmHORIZONTAL
+ XmNbackground *position-color*
+ XmNspacing 0)))
+ (rowrightbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column
(list XmNorientation XmHORIZONTAL
XmNbackground *position-color*
XmNspacing 0)))
- (leftrange (XtCreateManagedWidget "range" xmPushButtonWidgetClass left-column ()))
- (rowleftbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column
- (list XmNorientation XmHORIZONTAL
- XmNbackground *position-color*
- XmNspacing 0)))
- (rowrighttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column
- (list XmNorientation XmHORIZONTAL
- XmNbackground *position-color*
- XmNspacing 0)))
- (rowrightmid (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column
- (list XmNorientation XmHORIZONTAL
- XmNbackground *position-color*)))
- (rightsep (XtCreateManagedWidget "rsep" xmSeparatorWidgetClass rowrightmid
- (list XmNseparatorType XmNO_LINE
- XmNorientation XmVERTICAL
- XmNbackground *position-color*
- XmNwidth 20)))
- (rightlock (XtCreateManagedWidget "lock" xmToggleButtonWidgetClass rowrightmid ()))
-
- (rowrightbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column
- (list XmNorientation XmHORIZONTAL
- XmNbackground *position-color*
- XmNspacing 0)))
- (midlab1 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_POSITION
- XmNtopPosition 10
- XmNbottomAttachment XmATTACH_NONE)))
- (midlab2 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_POSITION
- XmNtopPosition 40
- XmNbottomAttachment XmATTACH_NONE)))
- (midlab3 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_NONE
- XmNbottomAttachment XmATTACH_POSITION
- XmNbottomPosition 90)))
- (bottom-form (XtCreateManagedWidget "bform" xmFormWidgetClass frame-form
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget top-frame
- XmNbottomAttachment XmATTACH_FORM)))
- (bottom-left (XtCreateManagedWidget "bleft" xmFormWidgetClass bottom-form
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM)))
- (bottom-right (XtCreateManagedWidget "bright" xmFrameWidgetClass bottom-form
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget bottom-left
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM)))
- (bottom-left-label (XtCreateManagedWidget "Loop Mode" xmLabelWidgetClass bottom-left
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE)))
- (bottom-left-button (XtCreateManagedWidget "forwards" xmPushButtonWidgetClass bottom-left
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget bottom-left-label
- XmNbottomAttachment XmATTACH_FORM)))
- (range-in-secs #t))
- (let ((mode 1))
- (XtAddCallback bottom-left-button
- XmNactivateCallback
- (lambda (w context info)
- (if (= mode 1)
- (set! mode 2)
- (set! mode 1))
- (set! (loop-data (+ offset 6)) mode)
- (change-label w (if (= mode 1) "forward" "forw/back")))))
- (XtAddCallback leftrange XmNactivateCallback
- (lambda (w c i)
- (set! range-in-secs (not range-in-secs))
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))
- (for-each
- (lambda (rparent loc)
- (let ((farleft (XtCreateManagedWidget "<<" xmPushButtonWidgetClass rparent ()))
- (stopleft (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ()))
- (lotsleft (XtCreateManagedWidget "<< " xmPushButtonWidgetClass rparent ()))
- (someleft (XtCreateManagedWidget " < " xmPushButtonWidgetClass rparent ()))
- (sus-rel-start (* offset 2)))
-
- (XtAddCallback farleft XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
- (set! (loop-data (+ loc (* offset 2))) ml)
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback stopleft XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
- (set! (loop-data (+ loc (* offset 2))) ml)
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback lotsleft XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
- (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 10)))
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback someleft XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
- (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 1)))
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))))
- (list rowlefttop rowleftbottom)
- (list 0 1))
- (for-each
- (lambda (rparent loc)
- (let ((someright (XtCreateManagedWidget " > " xmPushButtonWidgetClass rparent ()))
- (lotsright (XtCreateManagedWidget " >>" xmPushButtonWidgetClass rparent ()))
- (stopright (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ()))
- (farright (XtCreateManagedWidget ">>" xmPushButtonWidgetClass rparent ()))
- (sus-rel-start (* offset 2)))
-
- (XtAddCallback farright XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
- (set! (loop-data (+ loc (* offset 2))) ml)
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback stopright XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
- (set! (loop-data (+ loc (* offset 2))) ml)
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback lotsright XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
- (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 10)))
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))
- (XtAddCallback someright XmNactivateCallback
- (lambda (w c i)
- (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
- (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 1)))
- (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))))
- (list rowrighttop rowrightbottom)
- (list 0 1))))
- (list leftform rightform)
- (list "Sustain" "Release")
- (list 0 1)))
- (for-each-child
- loop-dialog
- (lambda (n)
- (if (and (XtIsWidget n)
- (not (XmIsRowColumn n))
- (not (XmIsSeparator n)))
- (begin
- (XmChangeColor n *basic-color*)
- (if (XmIsToggleButton n)
- (XtVaSetValues n (list XmNselectColor
- (let* ((col (XColor))
- (dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
- (XAllocNamedColor dpy cmap "yellow" col col)
- (.pixel col)))))))))
- ))
- (XtManageChild loop-dialog))
-
- (add-to-menu marks-menu "Show loop editor" create-loop-dialog)
- ))
+ (midlab1 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_POSITION
+ XmNtopPosition 10
+ XmNbottomAttachment XmATTACH_NONE)))
+ (midlab2 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_POSITION
+ XmNtopPosition 40
+ XmNbottomAttachment XmATTACH_NONE)))
+ (midlab3 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_NONE
+ XmNbottomAttachment XmATTACH_POSITION
+ XmNbottomPosition 90)))
+ (bottom-form (XtCreateManagedWidget "bform" xmFormWidgetClass frame-form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget top-frame
+ XmNbottomAttachment XmATTACH_FORM)))
+ (bottom-left (XtCreateManagedWidget "bleft" xmFormWidgetClass bottom-form
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM)))
+ (bottom-left-label (XtCreateManagedWidget "Loop Mode" xmLabelWidgetClass bottom-left
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE)))
+ (bottom-left-button (XtCreateManagedWidget "forwards" xmPushButtonWidgetClass bottom-left
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget bottom-left-label
+ XmNbottomAttachment XmATTACH_FORM)))
+ (range-in-secs #t))
+ (let ((mode 1))
+ (XtAddCallback bottom-left-button
+ XmNactivateCallback
+ (lambda (w context info)
+ (set! mode (if (= mode 1) 2 1))
+ (set! (loop-data (+ offset 6)) mode)
+ (change-label w (if (= mode 1) "forward" "forw/back")))))
+ (XtAddCallback leftrange XmNactivateCallback
+ (lambda (w c i)
+ (set! range-in-secs (not range-in-secs))
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))
+ (for-each
+ (lambda (rparent loc)
+ (let ((farleft (XtCreateManagedWidget "<<" xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback farleft XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
+ (set! (loop-data (+ loc (* offset 2))) ml)
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((stopleft (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback stopleft XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
+ (set! (loop-data (+ loc (* offset 2))) ml)
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((lotsleft (XtCreateManagedWidget "<< " xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback lotsleft XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
+ (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 10)))
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((someleft (XtCreateManagedWidget " < " xmPushButtonWidgetClass rparent ()))
+ (sus-rel-start (* offset 2)))
+ (XtAddCallback someleft XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start))))
+ (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 1)))
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))))
+ (list rowlefttop rowleftbottom)
+ (list 0 1))
+
+ (for-each
+ (lambda (rparent loc)
+ (let ((sus-rel-start (* offset 2)))
+ (let ((someright (XtCreateManagedWidget " > " xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback someright XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
+ (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 1)))
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((lotsright (XtCreateManagedWidget " >>" xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback lotsright XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
+ (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 10)))
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((stopright (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback stopright XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
+ (set! (loop-data (+ loc (* offset 2))) ml)
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))
+ (let ((farright (XtCreateManagedWidget ">>" xmPushButtonWidgetClass rparent ())))
+ (XtAddCallback farright XmNactivateCallback
+ (lambda (w c i)
+ (let ((ml (if (= loc 0) (loop-data (+ sus-rel-start 1)) (framples))))
+ (set! (loop-data (+ loc (* offset 2))) ml)
+ (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))))
+ (list rowrighttop rowrightbottom)
+ (list 0 1))))
+
+ (list leftform rightform)
+ (list "Sustain" "Release")
+ (list 0 1)))
+ (for-each-child
+ loop-dialog
+ (lambda (n)
+ (if (and (XtIsWidget n)
+ (not (XmIsRowColumn n))
+ (not (XmIsSeparator n)))
+ (begin
+ (XmChangeColor n *basic-color*)
+ (if (XmIsToggleButton n)
+ (XtVaSetValues n (list XmNselectColor
+ (let* ((col (XColor))
+ (dpy (XtDisplay (cadr (main-widgets))))
+ (scr (DefaultScreen dpy))
+ (cmap (DefaultColormap dpy scr)))
+ (XAllocNamedColor dpy cmap "yellow" col col)
+ (.pixel col)))))))))
+ ))
+ (XtManageChild loop-dialog))
+
+ (add-to-menu marks-menu "Show loop editor" create-loop-dialog)
+ ))
(add-to-menu marks-menu #f #f)
diff --git a/marks.scm b/marks.scm
index e8918e8..14b07c4 100644
--- a/marks.scm
+++ b/marks.scm
@@ -76,12 +76,10 @@
(chn (cadr mark-setting))
(max-edits (apply + (edits snd chn)))
(descr ())
- (header (list id sound: snd (short-file-name snd) 'channel: chn)))
+ (header (list id sound: snd (short-file-name snd) channel: chn)))
(do ((i max-edits (- i 1)))
- ((< i 0) descr)
- (if (member id (marks snd chn i))
- (set! descr (cons (mark-sample id i) descr))
- (set! descr (cons #f descr))))
+ ((< i 0))
+ (set! descr (cons (and (member id (marks snd chn i)) (mark-sample id i)) descr)))
(cons header descr))
(error 'no-such-mark (list "describe-mark" id)))))))
@@ -103,15 +101,15 @@
(lambda ids
(let* ((samps (map mark-sample ids))
(max-samp (apply max samps)))
- (define (pad-to-sync lst-ids lst-samps)
+ (let pad-to-sync ((lst-ids ids)
+ (lst-samps samps))
(if (pair? lst-ids)
(begin
(if (< (car lst-samps) max-samp)
(let ((nsamps (- max-samp (car lst-samps)))
(snd-chn (mark-home (car lst-ids))))
(insert-samples 0 nsamps (make-float-vector nsamps) (car snd-chn) (cadr snd-chn))))
- (pad-to-sync (cdr lst-ids) (cdr lst-samps)))))
- (pad-to-sync ids samps)))))
+ (pad-to-sync (cdr lst-ids) (cdr lst-samps)))))))))
;;; -------- fit selection between marks, expanding via granulate (this needs some tweaking...)
@@ -197,7 +195,7 @@
(lambda args
(let* ((snd (or (selected-sound) (car (sounds))))
(chn (or (selected-channel) 0))
- (m1 (if (> (length args) 0)
+ (m1 (if (pair? args)
(car args)
(let find-mark ((ms (marks snd chn)))
(if (null? ms)
@@ -208,7 +206,8 @@
(car ms)
(find-mark (cdr ms)))))))
(m2 (and (mark? m1)
- (if (> (length args) 1)
+ (if (and (pair? args)
+ (pair? (cdr args)))
(cadr args)
(let find-another-mark ((ms (marks snd chn)))
(if (null? ms)
@@ -237,18 +236,19 @@
(lambda ()
(hook-push start-playing-hook
(lambda (snd)
- (let* ((marklist (marks snd 0))
- (samplist (map mark-sample marklist))
- (samp 0))
-
- (define (report-mark-names-play-hook hook)
- (set! samp (+ samp (hook 'size)))
- (if (and (pair? samplist)
- (>= samp (car samplist)))
- (begin
- (status-report (mark-name (car marklist)) snd)
- (set! marklist (cdr marklist))
- (set! samplist (cdr samplist)))))
+ (let ((marklist (marks snd 0)))
+
+ (define report-mark-names-play-hook
+ (let ((samplist (map mark-sample marklist))
+ (samp 0))
+ (lambda (hook)
+ (set! samp (+ samp (hook 'size)))
+ (if (and (pair? samplist)
+ (>= samp (car samplist)))
+ (begin
+ (status-report (mark-name (car marklist)) snd)
+ (set! marklist (cdr marklist))
+ (set! samplist (cdr samplist)))))))
(define (report-mark-names-stop-playing-hook hook)
(status-report "" (hook 'snd))
@@ -294,7 +294,7 @@
(set! (selection-member? #t) #f)) ; clear entire current selection, if any
(set! (selection-member? snd chn) #t)
(set! (selection-position snd chn) beg)
- (set! (selection-framples snd chn) (+ 1 (- end beg)))))))))
+ (set! (selection-framples snd chn) (- (+ end 1) beg))))))))
;;; -------- snap-mark-to-beat
@@ -335,13 +335,14 @@
(lambda (mark)
(let ((end (mark-sample mark)))
(if (> end start)
- (let ((filename (format #f "mark-~D.snd" file-ctr)))
+ (let ((filename (format #f "mark-~D.snd" file-ctr))
+ (dur (- end start)))
(set! file-ctr (+ 1 file-ctr))
(do ((i 0 (+ 1 i)))
((= i (channels snd)))
(set! (selection-member? snd i) #t)
(set! (selection-position snd i) start)
- (set! (selection-framples snd i) (- end start)))
+ (set! (selection-framples snd i) dur))
(save-selection filename :header-type htype :sample-type dformat :srate (srate snd))
(do ((i 0 (+ 1 i)))
((= i (channels snd)))
@@ -375,8 +376,7 @@
(for-each
(lambda (m)
(let ((mp (mark-properties m)))
- (if (and mp
- (pair? mp))
+ (if (pair? mp)
(let ((mhome (mark-home m))
(msamp (mark-sample m)))
(format fd "(let ((s (find-sound ~S)))~%" (file-name (car mhome)))
@@ -403,9 +403,9 @@
""))
(mark-sample n)
(* 1.0 (/ (mark-sample n) (srate (car (mark-home n)))))
- (if (not (= (sync n) 0))
- (format #f "~% sync: ~A" (sync n))
- "")
+ (if (= (sync n) 0)
+ ""
+ (format #f "~% sync: ~A" (sync n)))
(let ((props (mark-properties n)))
(if (pair? props)
(format #f "~% properties: '~A" props)
diff --git a/maxf.scm b/maxf.scm
index bde4364..b83a9e8 100644
--- a/maxf.scm
+++ b/maxf.scm
@@ -43,7 +43,7 @@
(define *locsig-type* mus-interp-sinusoidal)
(define (snd-msg frm . args)
- (let ((str (apply format (append (list #f frm) args))))
+ (let ((str (apply format #f frm args)))
(if (getenv "EMACS")
(display str)
(snd-print str))))
@@ -72,16 +72,13 @@
;; Conditions for JOS constraints
;; maxdecay: Filter may be unstable
;; mindecay: Filter may not oscillate
- (if (>= fdecay maxdecay)
- (set! fdecay maxdecay)
- (if (<= fdecay mindecay)
- (set! fdecay mindecay)))
- (set! (b 'pp1) (- 1.0 (/ i2s fdecay)))
- (set! (b 'pp2) (* ffreq pi2s))
- (set! (b 'pp3) (* (b 'pp2) famp)))))
+ (set! fdecay (max mindecay (min fdecay maxdecay))))
+ (set! (b 'pp1) (- 1.0 (/ i2s fdecay)))
+ (set! (b 'pp2) centerfreq)
+ (set! (b 'pp3) (* (b 'pp2) famp))))
-(define (make-array initial-value dim1 dim2) ; I'm guessing ...
- (make-vector (list dim1 dim2) initial-value))
+(define (make-array dim1) ; I'm guessing ...
+ (make-vector (list dim1 3) 0.0))
(define (array-set! arr val i1 i2)
(set! (arr i1 i2) val))
@@ -128,194 +125,195 @@ the desired phase.
(end (+ beg dur))
(rdA (make-readin :file file :channel 0))
(ampf (make-env :envelope amp-env :scaler amplitude :length dur))
- (state-0 (make-array 0.0 1 3))
- (state-1 (make-array 0.0 12 3))
- (state-2 (make-array 0.0 9 3))
- (state-3 (make-array 0.0 13 3))
- (state-4 (make-array 0.0 4 3))
- (state-5 (make-array 0.0 2 3))
+ (state-0 (make-array 1))
+ (state-1 (make-array 12))
+ (state-2 (make-array 9))
+ (state-3 (make-array 13))
+ (state-4 (make-array 4))
+ (state-5 (make-array 2))
(loc (make-locsig :degree degree
:distance distance
:reverb reverb-amount
:type *locsig-type*)))
- (cond ((= numf 1)
- (snd-msg ";;;; State 0 (default): One filter~%")
- (array-set! state-0 7.54e-002 0 0)
- (array-set! state-0 (* 2000 freqfactor) 0 1)
- (array-set! state-0 2.0 0 2))
- ;;
- ((= numf 2)
- (snd-msg ";;;; State 5: Two filters~%")
- (array-set! state-5 7.54e-003 0 0)
- (array-set! state-5 (* 200.0 freqfactor) 0 1)
- (array-set! state-5 4.0 0 2)
- ;;
- (array-set! state-5 7.54e-004 1 0)
- (array-set! state-5 (* 800.0 freqfactor) 1 1)
- (array-set! state-5 1.0 1 2))
- ;;
- ((= numf 4)
- (snd-msg ";;;; State 4: Four filters~%")
- (array-set! state-4 7.54e-002 0 0)
- (array-set! state-4 (* 1000.0 freqfactor) 0 1)
- (array-set! state-4 0.5 0 2)
- ;;
- (array-set! state-4 3.225e-002 1 0)
- (array-set! state-4 (* 400.0 freqfactor) 1 1)
- (array-set! state-4 3.0 1 2)
- ;;
- (array-set! state-4 1.14e-002 2 0)
- (array-set! state-4 (* 800.0 freqfactor) 2 1)
- (array-set! state-4 2.8 2 2)
- ;;
- (array-set! state-4 7.54e-002 3 0)
- (array-set! state-4 (* 1600.0 freqfactor) 3 1)
- (array-set! state-4 1.0 3 2))
- ;;
- ((= numf 9)
- (snd-msg ";;;; State 2: Streached overtone string 9 filters~%")
- (array-set! state-2 1.07e-002 0 0)
- (array-set! state-2 100.0 0 1)
- (array-set! state-2 2.5 0 2)
- ;;
- (array-set! state-2 1.07e-002 1 0)
- (array-set! state-2 202.0 1 1)
- (array-set! state-2 0.75 1 2)
- ;;
- (array-set! state-2 1.07e-002 2 0)
- (array-set! state-2 305.0 2 1)
- (array-set! state-2 0.5 2 2)
- ;;
- (array-set! state-2 7.077e-003 3 0)
- (array-set! state-2 408.0 3 1)
- (array-set! state-2 0.4 3 2)
- ;;
- (array-set! state-2 1.07e-002 4 0)
- (array-set! state-2 501.0 4 1)
- (array-set! state-2 0.3 4 2)
- ;;
- (array-set! state-2 1.07e-002 5 0)
- (array-set! state-2 612.0 5 1)
- (array-set! state-2 0.25 5 2)
- ;;
- (array-set! state-2 1.07e-003 6 0)
- (array-set! state-2 715.0 6 1)
- (array-set! state-2 0.25 6 2)
- ;;
- (array-set! state-2 1.07e-002 7 0)
- (array-set! state-2 817.0 7 1)
- (array-set! state-2 0.2 7 2)
- ;;
- (array-set! state-2 1.07e-002 8 0)
- (array-set! state-2 920.0 8 1)
- (array-set! state-2 0.18 8 2))
- ;;
- ((= numf 12)
- (snd-msg ";;;; State 1: Risset bell long 12 filters~%")
- (array-set! state-1 5.025e-002 0 0)
- (array-set! state-1 224.0 0 1)
- (array-set! state-1 3.7 0 2)
- ;;
- (array-set! state-1 5.025e-002 1 0)
- (array-set! state-1 225.0 1 1)
- (array-set! state-1 3.3 1 2)
- ;;
- (array-set! state-1 5.025e-002 2 0)
- (array-set! state-1 368.0 2 1)
- (array-set! state-1 2.8 2 2)
- ;;
- (array-set! state-1 5.025e-002 3 0)
- (array-set! state-1 369.0 3 1)
- (array-set! state-1 2.4 3 2)
- ;;
- (array-set! state-1 1.047e-002 4 0)
- (array-set! state-1 476.0 4 1)
- (array-set! state-1 1.9 4 2)
- ;;
- (array-set! state-1 5.025e-002 5 0)
- (array-set! state-1 680.0 5 1)
- (array-set! state-1 1.7 5 2)
- ;;
- (array-set! state-1 5.025e-002 6 0)
- (array-set! state-1 800.0 6 1)
- (array-set! state-1 1.5 6 2)
- ;;
- (array-set! state-1 4.05e-002 7 0)
- (array-set! state-1 1096.0 7 1)
- (array-set! state-1 1.1 7 2)
- ;;
- (array-set! state-1 4.05e-002 8 0)
- (array-set! state-1 1099.0 8 1)
- (array-set! state-1 0.9 8 2)
- ;;
- (array-set! state-1 4.05e-002 9 0)
- (array-set! state-1 1200.0 9 1)
- (array-set! state-1 0.6 9 2)
- ;;
- (array-set! state-1 3.78e-002 10 0)
- (array-set! state-1 1504.0 10 1)
- (array-set! state-1 0.4 10 2)
- ;;
- (array-set! state-1 4.05e-002 11 0)
- (array-set! state-1 1628.0 11 1)
- (array-set! state-1 0.3 11 2))
- ;;
- ((= numf 13)
- (snd-msg ";;;; State 3: Open major chord with repeated octave 12 filters~%")
- (array-set! state-3 5.025e-002 0 0)
- (array-set! state-3 100.0 0 1)
- (array-set! state-3 2.0 0 2)
- ;;
- (array-set! state-3 5.025e-002 1 0)
- (array-set! state-3 251.0 1 1)
- (array-set! state-3 2.0 1 2)
- ;;
- (array-set! state-3 5.025e-002 2 0)
- (array-set! state-3 299.0 2 1)
- (array-set! state-3 2.0 2 2)
- ;;
- (array-set! state-3 5.025e-002 3 0)
- (array-set! state-3 401.0 3 1)
- (array-set! state-3 2.0 3 2)
- ;;
- (array-set! state-3 5.025e-002 4 0)
- (array-set! state-3 199.0 4 1)
- (array-set! state-3 2.0 4 2)
- ;;
- (array-set! state-3 5.025e-002 5 0)
- (array-set! state-3 501.0 5 1)
- (array-set! state-3 2.0 5 2)
- ;;
- (array-set! state-3 5.025e-002 6 0)
- (array-set! state-3 599.0 6 1)
- (array-set! state-3 2.0 6 2)
- ;;
- (array-set! state-3 5.025e-002 7 0)
- (array-set! state-3 801.0 7 1)
- (array-set! state-3 2.0 7 2)
- ;;
- (array-set! state-3 5.025e-002 8 0)
- (array-set! state-3 201.0 8 1)
- (array-set! state-3 2.0 8 2)
- ;;
- (array-set! state-3 5.025e-002 9 0)
- (array-set! state-3 749.0 9 1)
- (array-set! state-3 2.0 9 2)
- ;;
- (array-set! state-3 5.025e-002 10 0)
- (array-set! state-3 900.0 10 1)
- (array-set! state-3 2.0 10 2)
- ;;
- (array-set! state-3 5.025e-004 11 0)
- (array-set! state-3 1205.0 11 1)
- (array-set! state-3 2.0 11 2)
- ;;
- (array-set! state-3 5.025e-004 12 0)
- (array-set! state-3 1205.0 12 1)
- (array-set! state-3 2.0 12 2))
- (t
- (snd-msg "Please leave default or enter [1] [2] [4] [9] [12] [13]~%")
- (set! numf 1)))
+ (case numf
+ ((1)
+ (snd-msg ";;;; State 0 (default): One filter~%")
+ (array-set! state-0 7.54e-002 0 0)
+ (array-set! state-0 (* 2000 freqfactor) 0 1)
+ (array-set! state-0 2.0 0 2))
+ ;;
+ ((2)
+ (snd-msg ";;;; State 5: Two filters~%")
+ (array-set! state-5 7.54e-003 0 0)
+ (array-set! state-5 (* 200.0 freqfactor) 0 1)
+ (array-set! state-5 4.0 0 2)
+ ;;
+ (array-set! state-5 7.54e-004 1 0)
+ (array-set! state-5 (* 800.0 freqfactor) 1 1)
+ (array-set! state-5 1.0 1 2))
+ ;;
+ ((4)
+ (snd-msg ";;;; State 4: Four filters~%")
+ (array-set! state-4 7.54e-002 0 0)
+ (array-set! state-4 (* 1000.0 freqfactor) 0 1)
+ (array-set! state-4 0.5 0 2)
+ ;;
+ (array-set! state-4 3.225e-002 1 0)
+ (array-set! state-4 (* 400.0 freqfactor) 1 1)
+ (array-set! state-4 3.0 1 2)
+ ;;
+ (array-set! state-4 1.14e-002 2 0)
+ (array-set! state-4 (* 800.0 freqfactor) 2 1)
+ (array-set! state-4 2.8 2 2)
+ ;;
+ (array-set! state-4 7.54e-002 3 0)
+ (array-set! state-4 (* 1600.0 freqfactor) 3 1)
+ (array-set! state-4 1.0 3 2))
+ ;;
+ ((9)
+ (snd-msg ";;;; State 2: Streached overtone string 9 filters~%")
+ (array-set! state-2 1.07e-002 0 0)
+ (array-set! state-2 100.0 0 1)
+ (array-set! state-2 2.5 0 2)
+ ;;
+ (array-set! state-2 1.07e-002 1 0)
+ (array-set! state-2 202.0 1 1)
+ (array-set! state-2 0.75 1 2)
+ ;;
+ (array-set! state-2 1.07e-002 2 0)
+ (array-set! state-2 305.0 2 1)
+ (array-set! state-2 0.5 2 2)
+ ;;
+ (array-set! state-2 7.077e-003 3 0)
+ (array-set! state-2 408.0 3 1)
+ (array-set! state-2 0.4 3 2)
+ ;;
+ (array-set! state-2 1.07e-002 4 0)
+ (array-set! state-2 501.0 4 1)
+ (array-set! state-2 0.3 4 2)
+ ;;
+ (array-set! state-2 1.07e-002 5 0)
+ (array-set! state-2 612.0 5 1)
+ (array-set! state-2 0.25 5 2)
+ ;;
+ (array-set! state-2 1.07e-003 6 0)
+ (array-set! state-2 715.0 6 1)
+ (array-set! state-2 0.25 6 2)
+ ;;
+ (array-set! state-2 1.07e-002 7 0)
+ (array-set! state-2 817.0 7 1)
+ (array-set! state-2 0.2 7 2)
+ ;;
+ (array-set! state-2 1.07e-002 8 0)
+ (array-set! state-2 920.0 8 1)
+ (array-set! state-2 0.18 8 2))
+ ;;
+ ((12)
+ (snd-msg ";;;; State 1: Risset bell long 12 filters~%")
+ (array-set! state-1 5.025e-002 0 0)
+ (array-set! state-1 224.0 0 1)
+ (array-set! state-1 3.7 0 2)
+ ;;
+ (array-set! state-1 5.025e-002 1 0)
+ (array-set! state-1 225.0 1 1)
+ (array-set! state-1 3.3 1 2)
+ ;;
+ (array-set! state-1 5.025e-002 2 0)
+ (array-set! state-1 368.0 2 1)
+ (array-set! state-1 2.8 2 2)
+ ;;
+ (array-set! state-1 5.025e-002 3 0)
+ (array-set! state-1 369.0 3 1)
+ (array-set! state-1 2.4 3 2)
+ ;;
+ (array-set! state-1 1.047e-002 4 0)
+ (array-set! state-1 476.0 4 1)
+ (array-set! state-1 1.9 4 2)
+ ;;
+ (array-set! state-1 5.025e-002 5 0)
+ (array-set! state-1 680.0 5 1)
+ (array-set! state-1 1.7 5 2)
+ ;;
+ (array-set! state-1 5.025e-002 6 0)
+ (array-set! state-1 800.0 6 1)
+ (array-set! state-1 1.5 6 2)
+ ;;
+ (array-set! state-1 4.05e-002 7 0)
+ (array-set! state-1 1096.0 7 1)
+ (array-set! state-1 1.1 7 2)
+ ;;
+ (array-set! state-1 4.05e-002 8 0)
+ (array-set! state-1 1099.0 8 1)
+ (array-set! state-1 0.9 8 2)
+ ;;
+ (array-set! state-1 4.05e-002 9 0)
+ (array-set! state-1 1200.0 9 1)
+ (array-set! state-1 0.6 9 2)
+ ;;
+ (array-set! state-1 3.78e-002 10 0)
+ (array-set! state-1 1504.0 10 1)
+ (array-set! state-1 0.4 10 2)
+ ;;
+ (array-set! state-1 4.05e-002 11 0)
+ (array-set! state-1 1628.0 11 1)
+ (array-set! state-1 0.3 11 2))
+ ;;
+ ((13)
+ (snd-msg ";;;; State 3: Open major chord with repeated octave 12 filters~%")
+ (array-set! state-3 5.025e-002 0 0)
+ (array-set! state-3 100.0 0 1)
+ (array-set! state-3 2.0 0 2)
+ ;;
+ (array-set! state-3 5.025e-002 1 0)
+ (array-set! state-3 251.0 1 1)
+ (array-set! state-3 2.0 1 2)
+ ;;
+ (array-set! state-3 5.025e-002 2 0)
+ (array-set! state-3 299.0 2 1)
+ (array-set! state-3 2.0 2 2)
+ ;;
+ (array-set! state-3 5.025e-002 3 0)
+ (array-set! state-3 401.0 3 1)
+ (array-set! state-3 2.0 3 2)
+ ;;
+ (array-set! state-3 5.025e-002 4 0)
+ (array-set! state-3 199.0 4 1)
+ (array-set! state-3 2.0 4 2)
+ ;;
+ (array-set! state-3 5.025e-002 5 0)
+ (array-set! state-3 501.0 5 1)
+ (array-set! state-3 2.0 5 2)
+ ;;
+ (array-set! state-3 5.025e-002 6 0)
+ (array-set! state-3 599.0 6 1)
+ (array-set! state-3 2.0 6 2)
+ ;;
+ (array-set! state-3 5.025e-002 7 0)
+ (array-set! state-3 801.0 7 1)
+ (array-set! state-3 2.0 7 2)
+ ;;
+ (array-set! state-3 5.025e-002 8 0)
+ (array-set! state-3 201.0 8 1)
+ (array-set! state-3 2.0 8 2)
+ ;;
+ (array-set! state-3 5.025e-002 9 0)
+ (array-set! state-3 749.0 9 1)
+ (array-set! state-3 2.0 9 2)
+ ;;
+ (array-set! state-3 5.025e-002 10 0)
+ (array-set! state-3 900.0 10 1)
+ (array-set! state-3 2.0 10 2)
+ ;;
+ (array-set! state-3 5.025e-004 11 0)
+ (array-set! state-3 1205.0 11 1)
+ (array-set! state-3 2.0 11 2)
+ ;;
+ (array-set! state-3 5.025e-004 12 0)
+ (array-set! state-3 1205.0 12 1)
+ (array-set! state-3 2.0 12 2))
+ (else
+ (snd-msg "Please leave default or enter [1] [2] [4] [9] [12] [13]~%")
+ (set! numf 1)))
(let ((run-state (case numf
((1) state-0)
diff --git a/misc.scm b/misc.scm
index 21ec2dd..fc20303 100644
--- a/misc.scm
+++ b/misc.scm
@@ -30,12 +30,7 @@
(lambda (w)
(if (and (Widget? w)
(or (not (XmIsPushButton w))
- (string=? (XtName w) "revlen-label")
- (string=? (XtName w) "revscl-label")
- (string=? (XtName w) "contrast-label")
- (string=? (XtName w) "expand-label")
- (string=? (XtName w) "srate-label")
- (string=? (XtName w) "amp-label")))
+ (member (XtName w) '("revscl-label" "contrast-label" "expand-label" "srate-label" "amp-label") string=?)))
(XtSetValues w (list XmNbackgroundPixmap wd))))))
(paint-all (cadr (main-widgets)))
@@ -58,33 +53,8 @@
(add-mark-pane)
-(add-sound-file-extension "ogg")
-(add-sound-file-extension "OGG")
-(add-sound-file-extension "sf")
-(add-sound-file-extension "SF2")
-(add-sound-file-extension "mp3")
-(add-sound-file-extension "MP3")
-(add-sound-file-extension "W01")
-(add-sound-file-extension "W02")
-(add-sound-file-extension "W03")
-(add-sound-file-extension "W04")
-(add-sound-file-extension "W05")
-(add-sound-file-extension "W06")
-(add-sound-file-extension "W07")
-(add-sound-file-extension "W08")
-(add-sound-file-extension "W09")
-(add-sound-file-extension "W10")
-(add-sound-file-extension "w01")
-(add-sound-file-extension "w02")
-(add-sound-file-extension "w03")
-(add-sound-file-extension "w04")
-(add-sound-file-extension "w05")
-(add-sound-file-extension "w06")
-(add-sound-file-extension "w07")
-(add-sound-file-extension "w08")
-(add-sound-file-extension "w09")
-(add-sound-file-extension "w10")
-
+(for-each add-sound-file-extension '("ogg" "OGG" "sf" "SF2" "mp3" "MP3" "W01" "W02" "W03" "W04" "W05" "W06" "W07"
+ "W08" "W09" "W10" "w01" "w02" "w03" "w04" "w05" "w06" "w07" "w08" "w09" "w10"))
;;;
;;; disable original Play radio button
@@ -117,86 +87,83 @@
(add-to-menu 0 "Rename"
(lambda ()
;; open dialog to get new name, save-as that name, open
- (if (not rename-dialog)
- ;; make a standard dialog
- (let* ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "Rename" XmFONTLIST_DEFAULT_TAG))
- (new-dialog (XmCreateTemplateDialog
- (cadr (main-widgets)) "Rename"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNokLabelString xok
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNbackground *basic-color*
- XmNtransient #f))))
- (for-each
- (lambda (button color)
- (XtVaSetValues
- (XmMessageBoxGetChild new-dialog button)
- (list XmNarmColor *selection-color*
- XmNbackground color)))
- (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
- (list *highlight-color* *highlight-color* *highlight-color*))
-
- (XtAddCallback new-dialog XmNcancelCallback
- (lambda (w c i) (XtUnmanageChild w)))
-
- (XtAddCallback new-dialog XmNhelpCallback
- (lambda (w c i)
- (help-dialog "Rename" "Give a new file name to rename the currently selected sound.")))
-
- (XtAddCallback new-dialog XmNokCallback
- (lambda (w c i)
- (let ((new-name (XmTextFieldGetString rename-text)))
- (if (and (string? new-name)
- (> (length new-name) 0)
- (>= (selected-sound) 0))
- (let ();(current-name (file-name)))
- (save-sound-as new-name)
- (close-sound)
+ (unless rename-dialog
+ ;; make a standard dialog
+ (let* ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "Rename" XmFONTLIST_DEFAULT_TAG))
+ (new-dialog (XmCreateTemplateDialog
+ (cadr (main-widgets)) "Rename"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNokLabelString xok
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNbackground *basic-color*
+ XmNtransient #f))))
+ (for-each
+ (lambda (button color)
+ (XtVaSetValues
+ (XmMessageBoxGetChild new-dialog button)
+ (list XmNarmColor *selection-color*
+ XmNbackground color)))
+ (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
+ (list *highlight-color* *highlight-color* *highlight-color*))
+
+ (XtAddCallback new-dialog XmNcancelCallback
+ (lambda (w c i) (XtUnmanageChild w)))
+
+ (XtAddCallback new-dialog XmNhelpCallback
+ (lambda (w c i)
+ (help-dialog "Rename" "Give a new file name to rename the currently selected sound.")))
+
+ (XtAddCallback new-dialog XmNokCallback
+ (lambda (w c i)
+ (let ((new-name (XmTextFieldGetString rename-text)))
+ (if (and (string? new-name)
+ (> (length new-name) 0)
+ (>= (selected-sound) 0))
+ (let ();(current-name (file-name)))
+ (save-sound-as new-name)
+ (close-sound)
;(rename-file current-name new-name)
- ;; (delete-file current-name) perhaps?
- (open-sound new-name)
- (XtUnmanageChild w))))))
- (XmStringFree xhelp)
- (XmStringFree xok)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
- (set! rename-dialog new-dialog)
- (let* ((mainform (XtCreateManagedWidget "formd" xmRowColumnWidgetClass rename-dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild rename-dialog XmDIALOG_SEPARATOR)
- XmNorientation XmVERTICAL
- XmNbackground *basic-color*)))
- (label (XtCreateManagedWidget "new name:" xmLabelWidgetClass mainform
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*))))
- (set! rename-text
- (XtCreateManagedWidget "newname" xmTextFieldWidgetClass mainform
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget label
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (XtAddEventHandler rename-text EnterWindowMask #f
- (lambda (w context ev flag)
- (XmProcessTraversal w XmTRAVERSE_CURRENT)
- (XtSetValues w (list XmNbackground (white-pixel)))))
- (XtAddEventHandler rename-text LeaveWindowMask #f
- (lambda (w context ev flag)
- (XtSetValues w (list XmNbackground *basic-color*)))))))
+ ;; (delete-file current-name) perhaps?
+ (open-sound new-name)
+ (XtUnmanageChild w))))))
+ (for-each XmStringFree (vector xhelp xok xdismiss titlestr))
+ (set! rename-dialog new-dialog)
+ (let* ((mainform (XtCreateManagedWidget "formd" xmRowColumnWidgetClass rename-dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild rename-dialog XmDIALOG_SEPARATOR)
+ XmNorientation XmVERTICAL
+ XmNbackground *basic-color*)))
+ (label (XtCreateManagedWidget "new name:" xmLabelWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*))))
+ (set! rename-text
+ (XtCreateManagedWidget "newname" xmTextFieldWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget label
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (XtAddEventHandler rename-text EnterWindowMask #f
+ (lambda (w context ev flag)
+ (XmProcessTraversal w XmTRAVERSE_CURRENT)
+ (XtSetValues w (list XmNbackground (white-pixel)))))
+ (XtAddEventHandler rename-text LeaveWindowMask #f
+ (lambda (w context ev flag)
+ (XtSetValues w (list XmNbackground *basic-color*)))))))
(if (not (XtIsManaged rename-dialog))
(XtManageChild rename-dialog)
(raise-dialog rename-dialog)))
diff --git a/mix.scm b/mix.scm
index acf3c50..cacc461 100644
--- a/mix.scm
+++ b/mix.scm
@@ -24,16 +24,13 @@
(define tree-for-each-reversed
(let ((documentation "(tree-for-each-reversed func tree) applies func to every leaf of 'tree' moving in reverse through all the lists"))
(lambda (func tree)
- (define (flatten lst)
- ;; there's probably a more elegant way to do this
- (cond ((null? lst) ())
- ((pair? lst)
- (if (pair? (car lst))
- (append (flatten (car lst)) (flatten (cdr lst)))
- (cons (car lst) (flatten (cdr lst)))))
- (#t lst)))
- (for-each func (reverse (flatten tree))))))
-
+ (for-each func
+ (reverse
+ (let flatten ((lst tree))
+ (cond ((null? lst) ())
+ ((not (pair? lst)) lst)
+ ((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst))))
+ (else (cons (car lst) (flatten (cdr lst)))))))))))
(define mix-sound
(let ((documentation "(mix-sound file start) mixes file (all chans) at start in the currently selected sound."))
@@ -128,17 +125,17 @@ All mixes sync'd to it are also moved the same number of samples. (hook-remove m
(define (mix-click-sets-amp)
(hook-push mix-click-hook
(lambda (hook)
- (let ((n (hook 'id)))
- (let ((zeroed (mix-property :zero n)))
- (if (not zeroed)
- (begin
- (set! (mix-property :amp n) (mix-amp n))
- (set! (mix-amp n) 0.0)
- (set! (mix-property :zero n) #t))
- (begin
- (set! (mix-amp n) (mix-property :amp n))
- (set! (mix-property :zero n) #f)))
- (set! (hook 'result) #t))))))
+ (let* ((n (hook 'id))
+ (zeroed (mix-property :zero n)))
+ (if zeroed
+ (begin
+ (set! (mix-amp n) (mix-property :amp n))
+ (set! (mix-property :zero n) #f))
+ (begin
+ (set! (mix-property :amp n) (mix-amp n))
+ (set! (mix-amp n) 0.0)
+ (set! (mix-property :zero n) #t)))
+ (set! (hook 'result) #t)))))
;(mix-click-sets-amp)
@@ -150,9 +147,9 @@ All mixes sync'd to it are also moved the same number of samples. (hook-remove m
(lambda (n)
(help-dialog "Mix Help"
(format #f "Mix ~A (sync: ~A):~% position: ~D = ~,3F secs~% length: ~D (~,3F secs)~% in: ~A[~D]~% scaler: ~A~% speed: ~A~% env: ~A~A"
- (if (mix-name n)
- (format #f "~S (~A)" (mix-name n) n)
- (format #f "~A" n))
+ (format #f (if (mix-name n)
+ (values "~S (~A)" (mix-name n) n)
+ (values "~A" n)))
(mix-sync n)
(mix-position n)
(* 1.0 (/ (mix-position n) (srate (car (mix-home n)))))
@@ -342,9 +339,9 @@ last end of the mixes in 'mix-list'"))
(let* ((beg-x (+ first-x (* x-scale (- (mix-position m) beg))))
(end-x (+ first-x (* x-scale (- (+ (mix-position m) (framples m)) beg))))
(wenv (window-envelope beg-x end-x overall-amp-env)))
- (if (null? (mix-amp-env m))
- (set! (mix-amp-env m) wenv)
- (set! (mix-amp-env m) (multiply-envelopes (mix-amp-env m) wenv)))))
+ (set! (mix-amp-env m) (if (null? (mix-amp-env m))
+ wenv
+ (multiply-envelopes (mix-amp-env m) wenv)))))
mix-list)))))))
@@ -553,27 +550,26 @@ begin time of each mix that starts after beg in the given channel"))
(check-mix-tags snd i)))
(let ((mxs (mixes snd chn))
(changed #f))
- (define (check-mix mx trailing-mixes)
- (if (pair? trailing-mixes)
- (let ((pos (mix-position mx))
- (ls (left-sample snd chn))
- (rs (right-sample snd chn)))
- (if (<= ls pos rs)
- (let ((x (x->position (/ pos (srate snd))))
- (y (mix-tag-y mx)))
- (for-each
- (lambda (other-mix)
- (let ((other-pos (mix-position other-mix)))
- (if (<= ls other-pos rs)
- (let ((other-x (x->position (/ other-pos (srate snd))))
- (other-y (mix-tag-y other-mix)))
- (if (and (< (abs (- x other-x)) 6)
- (< (abs (- y other-y)) 10))
- (begin
- (set! (mix-tag-y other-mix) (+ (mix-tag-y other-mix) 20))
- (set! changed #t)))))))
- trailing-mixes)))
- (check-mix (car trailing-mixes) (cdr trailing-mixes)))))
- (check-mix (car mxs) (cdr mxs))
+ (let check-mix ((mx (car mxs))
+ (trailing-mixes (cdr mxs)))
+ (when (pair? trailing-mixes)
+ (let ((pos (mix-position mx))
+ (ls (left-sample snd chn))
+ (rs (right-sample snd chn)))
+ (when (<= ls pos rs)
+ (let ((x (x->position (/ pos (srate snd))))
+ (y (mix-tag-y mx)))
+ (for-each (lambda (other-mix)
+ (let ((other-pos (mix-position other-mix)))
+ (if (<= ls other-pos rs)
+ (let ((other-x (x->position (/ other-pos (srate snd))))
+ (other-y (mix-tag-y other-mix)))
+ (when (and (< (abs (- x other-x)) 6)
+ (< (abs (- y other-y)) 10))
+ (set! (mix-tag-y other-mix) (+ (mix-tag-y other-mix) 20))
+ (set! changed #t))))))
+ trailing-mixes)))
+ (check-mix (car trailing-mixes) (cdr trailing-mixes)))))
(if changed
(update-time-graph snd chn))))))))
+
\ No newline at end of file
diff --git a/mockery.scm b/mockery.scm
index 38cf0e7..c5c5d5c 100644
--- a/mockery.scm
+++ b/mockery.scm
@@ -7,9 +7,10 @@
(define (make-method f accessor)
(lambda args
- (if (let? (car args))
- (apply f (accessor (car args)) (cdr args))
- (apply f (car args) (accessor (cadr args)) (cddr args)))))
+ (apply f
+ (if (let? (car args))
+ (values (accessor (car args)) (cdr args))
+ (values (car args) (accessor (cadr args)) (cddr args))))))
(define (make-object . args)
(openlet
@@ -23,92 +24,94 @@
(lambda () (openlet obj))))
+(define (make-local-method f)
+ (make-method f (lambda (obj) (obj 'value))))
+
;;; --------------------------------------------------------------------------------
(define *mock-vector*
- (let ((mock-vector? #f))
- (let ((mock-vector-class
- (openlet
- (inlet 'morally-equal? (make-method #_morally-equal? (lambda (obj) (obj 'value))) ; see comment below
-
- 'local-set! (lambda (obj i val) ; reactive-vector uses this as a hook into vector-set!
- (if (vector? (obj 'value))
- (#_vector-set! (obj 'value) i val)
- (error 'wrong-type-arg "vector-set! ~S ~S ~S" obj i val))) ; the wrong arg here is 'i
- 'vector-set! (lambda (obj i val) ((obj 'local-set!) obj i val) val)
- 'let-set! (lambda (obj i val) ((obj 'local-set!) obj i val) val)
-
- 'vector-ref (lambda (obj i)
- (if (mock-vector? obj)
- (#_vector-ref (obj 'value) i)
- (error 'wrong-type-arg "vector-ref ~S ~S" obj i)))
-
- 'let-ref (lambda (obj i) (#_vector-ref (obj 'value) i)) ; the implicit case, so 'i can't be the culprit
- 'vector-length (lambda (obj) (#_length (obj 'value)))
- (reader-cond ((not (provided? 'pure-s7))
- 'vector-append (make-method #_vector-append (lambda (obj) (obj 'value)))))
- 'reverse (lambda (obj) (#_reverse (obj 'value)))
- 'sort! (lambda (obj f) (#_sort! (obj 'value) f))
- 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
- 'arity (lambda (obj) (#_arity (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-vector*" "#<mock-vector-class>"))
- 'vector-dimensions (lambda (obj) (#_vector-dimensions (obj 'value)))
- 'fill! (lambda (obj val) (#_fill! (obj 'value) val))
-
- 'vector->list (lambda (obj . args)
- (if (mock-vector? obj)
- (map values (obj 'value))
- (error 'wrong-type-arg "vector->list ~S ~S" obj args)))
-
- 'make-shared-vector (lambda* (obj dim (off 0))
- (if (mock-vector? obj)
- (#_make-shared-vector (obj 'value) dim off)
- (error 'wrong-type-arg "make-shared-vector ~S ~S ~S" obj dim off)))
-
- 'vector-fill! (lambda (obj . args)
- (if (mock-vector? obj)
- (apply #_fill! (obj 'value) args)
- (error 'wrong-type-arg "vector-fill! ~S ~S ~S ~S" obj val start end)))
-
- 'copy (lambda* (source dest . args)
- ;; copy by itself does not make a new vector, but if no dest we
- ;; need a copy of source, so use coverlet/openlet to make sure
- ;; we aren't caught in an infinite recursion.
- (if (mock-vector? source)
- (if (and dest (not (let? dest)))
- (apply copy (source 'value) dest args)
- (let ((nobj (or dest
- (dynamic-wind
- (lambda () (coverlet source))
- (lambda () (openlet (copy source)))
- (lambda () (openlet source))))))
- (if dest
- (apply copy (source 'value) (nobj 'value) args)
- (set! (nobj 'value) (copy (source 'value))))
- nobj))
- (error 'wrong-type-arg "copy ~S ~S ~S" source dest args)))
- 'vector? (lambda (obj) #t)
- 'values (lambda (obj . args) (obj 'value))
- 'length (lambda (obj) (#_length (obj 'value)))
- 'append (make-method #_append (lambda (obj) (obj 'value)))
- 'class-name 'mock-vector))))
-
- (define* (make-mock-vector len (init #<unspecified>))
- (openlet (sublet mock-vector-class
- 'value (#_make-vector len init)
- 'object->string mock->string)))
-
- (define (mock-vector . args)
- (let ((v (make-mock-vector 0)))
- (set! (v 'value) (apply #_vector args))
- v))
-
- (set! mock-vector? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-vector-class))))
-
- (curlet))))
+ (let* ((mock-vector? #f)
+ (mock-vector-class
+ (openlet
+ (inlet 'morally-equal? (make-local-method #_morally-equal?) ; see comment below
+
+ 'local-set! (lambda (obj i val) ; reactive-vector uses this as a hook into vector-set!
+ (if (vector? (obj 'value))
+ (#_vector-set! (obj 'value) i val)
+ (error 'wrong-type-arg "vector-set! ~S ~S ~S" obj i val))) ; the wrong arg here is 'i
+ 'vector-set! (lambda (obj i val) ((obj 'local-set!) obj i val) val)
+ 'let-set! (lambda (obj i val) ((obj 'local-set!) obj i val) val)
+
+ 'vector-ref (lambda (obj i)
+ (if (mock-vector? obj)
+ (#_vector-ref (obj 'value) i)
+ (error 'wrong-type-arg "vector-ref ~S ~S" obj i)))
+
+ 'let-ref (lambda (obj i) (#_vector-ref (obj 'value) i)) ; the implicit case, so 'i can't be the culprit
+ 'vector-length (lambda (obj) (#_length (obj 'value)))
+ 'vector-append (make-local-method #_vector-append)
+ 'reverse (lambda (obj) (#_reverse (obj 'value)))
+ 'sort! (lambda (obj f) (#_sort! (obj 'value) f))
+ 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
+ 'arity (lambda (obj) (#_arity (obj 'value)))
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-vector*" "#<mock-vector-class>"))
+ 'vector-dimensions (lambda (obj) (#_vector-dimensions (obj 'value)))
+ 'fill! (lambda (obj val) (#_fill! (obj 'value) val))
+
+ 'vector->list (lambda (obj . args)
+ (if (mock-vector? obj)
+ (map values (obj 'value))
+ (error 'wrong-type-arg "vector->list ~S ~S" obj args)))
+
+ 'make-shared-vector (lambda* (obj dim (off 0))
+ (if (mock-vector? obj)
+ (#_make-shared-vector (obj 'value) dim off)
+ (error 'wrong-type-arg "make-shared-vector ~S ~S ~S" obj dim off)))
+
+ 'vector-fill! (lambda (obj . args)
+ (if (mock-vector? obj)
+ (apply #_fill! (obj 'value) args)
+ (error 'wrong-type-arg "vector-fill! ~S ~S ~S ~S" obj val start end)))
+
+ 'copy (lambda* (source dest . args)
+ ;; copy by itself does not make a new vector, but if no dest we
+ ;; need a copy of source, so use coverlet/openlet to make sure
+ ;; we aren't caught in an infinite recursion.
+ (if (mock-vector? source)
+ (if (and dest (not (let? dest)))
+ (apply copy (source 'value) dest args)
+ (let ((nobj (or dest
+ (dynamic-wind
+ (lambda () (coverlet source))
+ (lambda () (openlet (copy source)))
+ (lambda () (openlet source))))))
+ (if dest
+ (apply copy (source 'value) (nobj 'value) args)
+ (set! (nobj 'value) (copy (source 'value))))
+ nobj))
+ (error 'wrong-type-arg "copy ~S ~S ~S" source dest args)))
+ 'vector? (lambda (obj) #t)
+ 'values (lambda (obj . args) (obj 'value))
+ 'length (lambda (obj) (#_length (obj 'value)))
+ 'append (make-local-method #_append)
+ 'class-name 'mock-vector))))
+
+ (define* (make-mock-vector len (init #<unspecified>))
+ (openlet (sublet mock-vector-class
+ 'value (#_make-vector len init)
+ 'object->string mock->string)))
+
+ (define (mock-vector . args)
+ (let ((v (make-mock-vector 0)))
+ (set! (v 'value) (apply #_vector args))
+ v))
+
+ (set! mock-vector? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-vector-class))))
+
+ (curlet)))
#|
@@ -153,76 +156,76 @@
;;; --------------------------------------------------------------------------------
(define *mock-hash-table*
- (let ((mock-hash-table? #f))
- (let ((mock-hash-table-class
- (openlet
- (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'mock-hash-table-table) y))
- 'hash-table-ref (lambda (obj key) (#_hash-table-ref (obj 'mock-hash-table-table) key))
- 'hash-table-set! (lambda (obj key val) (#_hash-table-set! (obj 'mock-hash-table-table) key val))
- 'hash-table-entries (lambda (obj) (#_hash-table-entries (obj 'mock-hash-table-table)))
- 'make-iterator (lambda (obj) (#_make-iterator (obj 'mock-hash-table-table)))
-
- 'let-ref-fallback (lambda (obj key)
- (if (defined? 'mock-hash-table-table obj)
- (#_hash-table-ref (obj 'mock-hash-table-table) key)))
- 'let-set!-fallback (lambda (obj key val)
- (if (defined? 'mock-hash-table-table obj)
- (#_hash-table-set! (obj 'mock-hash-table-table) key val)))
-
- ;; the fallbacks are needed because hash-tables and lets use exactly the same syntax in implicit indexing:
- ;; (x 'y) but s7 can't tell that in this one case, we actually want the 'y to be a key not a field.
- ;; So, to avoid infinite recursion in let-ref (implicit index), if let-ref can't find the let field,
- ;; and the let has 'let-ref|set!-fallback, let-ref|set! passes the argument to that function rather than
- ;; return #<undefined>.
- ;;
- ;; (round (openlet (inlet 'round (lambda (obj) (#_round (obj 'value))) 'let-ref-fallback (lambda args 3)))) -> 3
-
- 'fill! (lambda (obj val) (#_fill! (obj 'mock-hash-table-table) val))
- 'reverse (lambda (obj) (#_reverse (obj 'mock-hash-table-table)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-hash-table*" "#<mock-hash-table-class>"))
- 'arity (lambda (obj) (#_arity (obj 'mock-hash-table-table)))
- 'copy (lambda* (source dest . args)
- (if (mock-hash-table? source)
- (if (and dest (not (let? dest)))
- (apply copy (obj 'mock-hash-table-table) dest args)
- (let ((nobj (or dest (openlet (copy (coverlet source))))))
- (openlet source)
- (set! (nobj 'mock-hash-table-table) (copy (source 'mock-hash-table-table)))
- nobj))
- (error 'wrong-type-arg "copy ~S ~S ~S" source dest args)))
- 'hash-table? (lambda (obj) #t)
- 'values (lambda (obj . args) (obj 'mock-hash-table-table))
- 'length (lambda (obj) (#_length (obj 'mock-hash-table-table)))
- 'append (make-method #_append (lambda (obj) (obj 'value)))
- 'class-name 'mock-hash-table))))
-
- (define* (make-mock-hash-table (len 511))
- (openlet
- (sublet mock-hash-table-class
- 'mock-hash-table-table (#_make-hash-table len)
-
- ;; object->string here is a problem -- don't set any value to the object itself!
- 'object->string (lambda (obj . args) ; can't use mock->string because the value is not in the 'value field
- (dynamic-wind
- (lambda () (coverlet obj))
- (lambda () (apply #_object->string (obj 'mock-hash-table-table) args))
- (lambda () (openlet obj)))))))
-
- (define (mock-hash-table . args)
- (let ((v (make-mock-hash-table)))
- (set! (v 'mock-hash-table-table) (apply #_hash-table args))
- v))
-
- (define (mock-hash-table* . args)
- (let ((v (make-mock-hash-table)))
- (set! (v 'mock-hash-table-table) (apply #_hash-table* args))
- v))
-
- (set! mock-hash-table? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-hash-table-class))))
-
- (curlet))))
+ (let* ((mock-hash-table? #f)
+ (mock-hash-table-class
+ (openlet
+ (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'mock-hash-table-table) y))
+ 'hash-table-ref (lambda (obj key) (#_hash-table-ref (obj 'mock-hash-table-table) key))
+ 'hash-table-set! (lambda (obj key val) (#_hash-table-set! (obj 'mock-hash-table-table) key val))
+ 'hash-table-entries (lambda (obj) (#_hash-table-entries (obj 'mock-hash-table-table)))
+ 'make-iterator (lambda (obj) (#_make-iterator (obj 'mock-hash-table-table)))
+
+ 'let-ref-fallback (lambda (obj key)
+ (if (defined? 'mock-hash-table-table obj)
+ (#_hash-table-ref (obj 'mock-hash-table-table) key)))
+ 'let-set!-fallback (lambda (obj key val)
+ (if (defined? 'mock-hash-table-table obj)
+ (#_hash-table-set! (obj 'mock-hash-table-table) key val)))
+
+ ;; the fallbacks are needed because hash-tables and lets use exactly the same syntax in implicit indexing:
+ ;; (x 'y) but s7 can't tell that in this one case, we actually want the 'y to be a key not a field.
+ ;; So, to avoid infinite recursion in let-ref (implicit index), if let-ref can't find the let field,
+ ;; and the let has 'let-ref|set!-fallback, let-ref|set! passes the argument to that function rather than
+ ;; return #<undefined>.
+ ;;
+ ;; (round (openlet (inlet 'round (lambda (obj) (#_round (obj 'value))) 'let-ref-fallback (lambda args 3)))) -> 3
+
+ 'fill! (lambda (obj val) (#_fill! (obj 'mock-hash-table-table) val))
+ 'reverse (lambda (obj) (#_reverse (obj 'mock-hash-table-table)))
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-hash-table*" "#<mock-hash-table-class>"))
+ 'arity (lambda (obj) (#_arity (obj 'mock-hash-table-table)))
+ 'copy (lambda* (source dest . args)
+ (if (mock-hash-table? source)
+ (if (and dest (not (let? dest)))
+ (apply copy (obj 'mock-hash-table-table) dest args)
+ (let ((nobj (or dest (openlet (copy (coverlet source))))))
+ (openlet source)
+ (set! (nobj 'mock-hash-table-table) (copy (source 'mock-hash-table-table)))
+ nobj))
+ (error 'wrong-type-arg "copy ~S ~S ~S" source dest args)))
+ 'hash-table? (lambda (obj) #t)
+ 'values (lambda (obj . args) (obj 'mock-hash-table-table))
+ 'length (lambda (obj) (#_length (obj 'mock-hash-table-table)))
+ 'append (make-local-method #_append)
+ 'class-name 'mock-hash-table))))
+
+ (define* (make-mock-hash-table (len 511))
+ (openlet
+ (sublet mock-hash-table-class
+ 'mock-hash-table-table (#_make-hash-table len)
+
+ ;; object->string here is a problem -- don't set any value to the object itself!
+ 'object->string (lambda (obj . args) ; can't use mock->string because the value is not in the 'value field
+ (dynamic-wind
+ (lambda () (coverlet obj))
+ (lambda () (apply #_object->string (obj 'mock-hash-table-table) args))
+ (lambda () (openlet obj)))))))
+
+ (define (mock-hash-table . args)
+ (let ((v (make-mock-hash-table)))
+ (set! (v 'mock-hash-table-table) (apply #_hash-table args))
+ v))
+
+ (define (mock-hash-table* . args)
+ (let ((v (make-mock-hash-table)))
+ (set! (v 'mock-hash-table-table) (apply #_hash-table* args))
+ v))
+
+ (set! mock-hash-table? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-hash-table-class))))
+
+ (curlet)))
#|
@@ -257,121 +260,133 @@
;;; --------------------------------------------------------------------------------
(define *mock-string*
- (let ((mock-string? #f))
- (let ((mock-string-class
- (openlet
- (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
- 'reverse (lambda (obj) (#_reverse (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-string*" "#<mock-string-class>"))
- 'arity (lambda (obj) (#_arity (obj 'value)))
- 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
- 'let-ref (lambda (obj i) (#_string-ref (obj 'value) i)) ; these are the implicit cases
- 'let-set! (lambda (obj i val) (string-set! (obj 'value) i val))
- 'string-length (lambda (obj) (#_length (obj 'value)))
- 'string-append (make-method #_string-append (lambda (obj) (obj 'value)))
- 'string-copy (lambda (obj) (#_copy (obj 'value)))
- 'string=? (make-method #_string=? (lambda (obj) (obj 'value)))
- 'string<? (make-method #_string<? (lambda (obj) (obj 'value)))
- 'string>? (make-method #_string>? (lambda (obj) (obj 'value)))
- 'string<=? (make-method #_string<=? (lambda (obj) (obj 'value)))
- 'string>=? (make-method #_string>=? (lambda (obj) (obj 'value)))
- 'string-downcase (lambda (obj) (#_string-downcase (obj 'value)))
- 'string-upcase (lambda (obj) (#_string-upcase (obj 'value)))
- 'string->symbol (lambda (obj) (#_string->symbol (obj 'value)))
- 'symbol (lambda (obj) (#_symbol (obj 'value)))
- 'gensym (lambda (obj) (#_gensym (obj 'value)))
- 'make-keyword (lambda (obj) (#_make-keyword (obj 'value)))
- 'open-input-string (lambda (obj) (#_open-input-string (obj 'value)))
- 'call-with-input-string (lambda (obj f) (#_call-with-input-string (obj 'value) f))
- 'with-input-from-string (lambda (obj f) (#_with-input-from-string (obj 'value) f))
- 'directory? (lambda (obj) (#_directory? (obj 'value)))
- 'file-exists? (lambda (obj) (#_file-exists? (obj 'value)))
- 'getenv (lambda (obj) (#_getenv (obj 'value)))
- 'delete-file (lambda (obj) (#_delete-file (obj 'value)))
- 'system (lambda* (obj cap) (#_system (obj 'value) cap))
- '->byte-vector (lambda (obj) (#_->byte-vector (obj 'value))) ; this is in-place!
- 'load (lambda* (obj (e (curlet))) (#_load (obj 'value) e))
- 'eval-string (lambda* (obj (e (curlet))) (#_eval-string (obj 'value) e))
- 'char-position (make-method #_char-position (lambda (obj) (obj 'value)))
-
- 'format (make-method #_format (lambda (obj) (obj 'value)))
- 'string-fill! (lambda* (obj val (start 0) end)
- (if (mock-string? obj)
- (#_string-fill! (obj 'value) val start (or end (#_string-length (obj 'value))))
- (error 'wrong-type-arg "string-fill! ~S ~S ~S ~S" obj val start end)))
-
- 'fill! (lambda (obj val)
- (if (mock-string? obj)
- (#_fill! (obj 'value) val)
- (error 'wrong-type-arg "fill! ~S ~S" obj val)))
-
- 'copy (lambda* (obj . args)
- (if (mock-string? obj)
- (apply #_copy (obj 'value) args)
- (error 'wrong-type-arg "copy ~S ~S" obj args)))
-
- 'substring (lambda (obj . args)
- (if (mock-string? obj)
- (apply #_substring (obj 'value) args)
- (error 'wrong-type-arg "substring ~S ~S" obj args)))
-
- 'string->number (lambda* (obj (r 10))
- (if (mock-string? obj)
- (#_string->number (obj 'value) r)
- (error 'wrong-type-arg "string->number ~S ~S" obj r)))
-
- 'write-string (lambda (obj . args)
- (if (mock-string? obj)
- (apply #_write-string (obj 'value) args)
- (error 'wrong-type-arg "write-string ~S ~S" obj args)))
-
- 'string-position (lambda* (s1 s2 (start 0))
- (if (mock-string? s1)
- (#_string-position (s1 'value) s2 start)
- (if (mock-string? s2)
- (#_string-position s1 (s2 'value) start)
- (error 'wrong-type-arg "write-string ~S ~S ~S" s1 s2 start))))
- 'string-ref (lambda (obj i)
- (if (mock-string? obj)
- (#_string-ref (obj 'value) i)
- (error 'wrong-type-arg "string-ref ~S ~S" obj i)))
-
- 'string-set! (lambda (obj i val)
- (if (mock-string? obj)
- (#_string-set! (obj 'value) i val)
- (error 'wrong-type-arg "string-set! ~S ~S ~S" obj i val)))
- (reader-cond ((not (provided? 'pure-s7))
- 'string->list (make-method #_string->list (lambda (obj) (obj 'value)))
- 'string-ci=? (make-method #_string-ci=? (lambda (obj) (obj 'value)))
- 'string-ci<? (make-method #_string-ci<? (lambda (obj) (obj 'value)))
- 'string-ci>? (make-method #_string-ci>? (lambda (obj) (obj 'value)))
- 'string-ci<=? (make-method #_string-ci<=? (lambda (obj) (obj 'value)))
- 'string-ci>=? (make-method #_string-ci>=? (lambda (obj) (obj 'value)))))
-
- 'string? (lambda (obj) #t)
- 'values (lambda (obj . args) (obj 'value))
- 'length (lambda (obj) (#_string-length (obj 'value)))
- 'append (make-method #_append (lambda (obj) (obj 'value)))
- 'class-name 'mock-string))))
-
- (define* (make-mock-string len (init #\null))
- (openlet (sublet mock-string-class
- 'value (#_make-string len init)
- 'object->string mock->string)))
-
- (define (mock-string . args)
- (let ((v (make-mock-string 0)))
- (set! (v 'value)
- (if (string? (car args))
- (car args)
- (apply #_string args)))
- v))
-
- (set! mock-string? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-string-class))))
-
- (curlet))))
+ (let* ((mock-string? #f)
+ (mock-string-class
+ (openlet
+ (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
+ 'reverse (lambda (obj) (#_reverse (obj 'value)))
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-string*" "#<mock-string-class>"))
+ 'arity (lambda (obj) (#_arity (obj 'value)))
+ 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
+ 'let-ref (lambda (obj i) (#_string-ref (obj 'value) i)) ; these are the implicit cases
+ 'let-set! (lambda (obj i val) (string-set! (obj 'value) i val))
+ 'string-length (lambda (obj) (#_length (obj 'value)))
+ 'string-append (make-local-method #_string-append)
+ 'string-copy (lambda (obj) (#_copy (obj 'value)))
+ 'string=? (make-local-method #_string=?)
+ 'string<? (make-local-method #_string<?)
+ 'string>? (make-local-method #_string>?)
+ 'string<=? (make-local-method #_string<=?)
+ 'string>=? (make-local-method #_string>=?)
+ 'string-downcase (lambda (obj) (#_string-downcase (obj 'value)))
+ 'string-upcase (lambda (obj) (#_string-upcase (obj 'value)))
+ 'string->symbol (lambda (obj) (#_string->symbol (obj 'value)))
+ 'symbol (lambda (obj) (#_symbol (obj 'value)))
+ 'gensym (lambda (obj) (#_gensym (obj 'value)))
+ 'make-keyword (lambda (obj) (#_make-keyword (obj 'value)))
+ 'open-input-string (lambda (obj) (#_open-input-string (obj 'value)))
+ 'call-with-input-string (lambda (obj f) (#_call-with-input-string (obj 'value) f))
+ 'with-input-from-string (lambda (obj f) (#_with-input-from-string (obj 'value) f))
+ 'directory? (lambda (obj) (#_directory? (obj 'value)))
+ 'file-exists? (lambda (obj) (#_file-exists? (obj 'value)))
+ 'getenv (lambda (obj) (#_getenv (obj 'value)))
+ 'delete-file (lambda (obj) (#_delete-file (obj 'value)))
+ 'system (lambda* (obj cap) (#_system (obj 'value) cap))
+ '->byte-vector (lambda (obj) (#_->byte-vector (obj 'value))) ; this is in-place!
+ 'load (lambda* (obj (e (curlet))) (#_load (obj 'value) e))
+ 'eval-string (lambda* (obj (e (curlet))) (#_eval-string (obj 'value) e))
+ 'char-position (make-local-method #_char-position)
+
+ 'format (make-local-method #_format)
+ 'string-fill! (lambda* (obj val (start 0) end)
+ (if (mock-string? obj)
+ (#_string-fill! (obj 'value) val start (or end (#_string-length (obj 'value))))
+ (error 'wrong-type-arg "string-fill! ~S ~S ~S ~S" obj val start end)))
+
+ 'fill! (lambda (obj val)
+ (if (mock-string? obj)
+ (#_fill! (obj 'value) val)
+ (error 'wrong-type-arg "fill! ~S ~S" obj val)))
+
+ 'copy (lambda* (obj . args)
+ (if (mock-string? obj)
+ (apply #_copy (obj 'value) args)
+ (error 'wrong-type-arg "copy ~S ~S" obj args)))
+
+ 'substring (lambda (obj . args)
+ (if (mock-string? obj)
+ (apply #_substring (obj 'value) args)
+ (error 'wrong-type-arg "substring ~S ~S" obj args)))
+
+ 'string->number (lambda* (obj (r 10))
+ (if (mock-string? obj)
+ (#_string->number (obj 'value) r)
+ (error 'wrong-type-arg "string->number ~S ~S" obj r)))
+
+ 'write-string (lambda (obj . args)
+ (if (mock-string? obj)
+ (apply #_write-string (obj 'value) args)
+ (error 'wrong-type-arg "write-string ~S ~S" obj args)))
+
+ 'string-position (lambda* (s1 s2 (start 0))
+ (if (mock-string? s1)
+ (#_string-position (s1 'value) s2 start)
+ (if (mock-string? s2)
+ (#_string-position s1 (s2 'value) start)
+ (error 'wrong-type-arg "write-string ~S ~S ~S" s1 s2 start))))
+ 'string-ref (lambda (obj i)
+ (if (mock-string? obj)
+ (#_string-ref (obj 'value) i)
+ (error 'wrong-type-arg "string-ref ~S ~S" obj i)))
+
+ 'string-set! (lambda (obj i val)
+ (if (mock-string? obj)
+ (#_string-set! (obj 'value) i val)
+ (error 'wrong-type-arg "string-set! ~S ~S ~S" obj i val)))
+
+ 'string->list (if (provided? 'pure-s7)
+ (lambda (obj) (#_map #_values obj))
+ (make-local-method #_string->list))
+ 'string-ci=? (if (provided? 'pure-s7)
+ (lambda strs (apply #_string=? (#_map #_string-upcase strs)))
+ (make-local-method #_string-ci=?))
+ 'string-ci<? (if (provided? 'pure-s7)
+ (lambda strs (apply #_string<? (#_map #_string-upcase strs)))
+ (make-local-method #_string-ci<?))
+ 'string-ci>? (if (provided? 'pure-s7)
+ (lambda strs (apply #_string>? (#_map #_string-upcase strs)))
+ (make-local-method #_string-ci>?))
+ 'string-ci<=? (if (provided? 'pure-s7)
+ (lambda strs (apply #_string<=? (#_map #_string-upcase strs)))
+ (make-local-method #_string-ci<=?))
+ 'string-ci>=? (if (provided? 'pure-s7)
+ (lambda strs (apply #_string>=? (#_map #_string-upcase strs)))
+ (make-local-method #_string-ci>=?))
+
+ 'string? (lambda (obj) #t)
+ 'values (lambda (obj . args) (obj 'value))
+ 'length (lambda (obj) (#_string-length (obj 'value)))
+ 'append (make-local-method #_append)
+ 'class-name 'mock-string))))
+
+ (define* (make-mock-string len (init #\null))
+ (openlet (sublet mock-string-class
+ 'value (#_make-string len init)
+ 'object->string mock->string)))
+
+ (define (mock-string . args)
+ (let ((v (make-mock-string 0)))
+ (set! (v 'value)
+ (if (string? (car args))
+ (car args)
+ (apply #_string args)))
+ v))
+
+ (set! mock-string? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-string-class))))
+
+ (curlet)))
#|
;; string that is always the current time of day
@@ -401,69 +416,69 @@
;;; --------------------------------------------------------------------------------
(define *mock-char*
- (let ((mock-char? #f))
- (let ((mock-char-class
- (openlet
- (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
- 'char-upcase (lambda (obj) (#_char-upcase (obj 'value)))
- 'char-downcase (lambda (obj) (#_char-downcase (obj 'value)))
- 'char->integer (lambda (obj) (#_char->integer (obj 'value)))
- 'char-upper-case? (lambda (obj) (#_char-upper-case? (obj 'value)))
- 'char-lower-case? (lambda (obj) (#_char-lower-case? (obj 'value)))
- 'char-alphabetic? (lambda (obj) (#_char-alphabetic? (obj 'value)))
- 'char-numeric? (lambda (obj) (#_char-numeric? (obj 'value)))
- 'char-whitespace? (lambda (obj) (#_char-whitespace? (obj 'value)))
- 'char=? (make-method #_char=? (lambda (obj) (obj 'value)))
- 'char<? (make-method #_char<? (lambda (obj) (obj 'value)))
- 'char>? (make-method #_char>? (lambda (obj) (obj 'value)))
- 'char<=? (make-method #_char<=? (lambda (obj) (obj 'value)))
- 'char>=? (make-method #_char>=? (lambda (obj) (obj 'value)))
- 'char-ci=? (make-method #_char-ci=? (lambda (obj) (obj 'value)))
- 'char-ci<? (make-method #_char-ci<? (lambda (obj) (obj 'value)))
- 'char-ci>? (make-method #_char-ci>? (lambda (obj) (obj 'value)))
- 'char-ci<=? (make-method #_char-ci<=? (lambda (obj) (obj 'value)))
- 'char-ci>=? (make-method #_char-ci>=? (lambda (obj) (obj 'value)))
- 'string (make-method #_string (lambda (obj) (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-char*" "#<mock-char-class>"))
- 'arity (lambda (obj) (#_arity (obj 'value)))
- 'format (make-method #_format (lambda (obj) (obj 'value)))
- 'make-string (make-method #_make-string (lambda (obj) (obj 'value)))
- 'char-position (make-method #_char-position (lambda (obj) (obj 'value)))
-
- 'write-char (lambda (obj . args)
- (if (mock-char? obj)
- (apply #_write-char (obj 'value) args)
- (error 'wrong-type-arg "write-char: ~S ~S" obj args)))
-
- 'string-set! (lambda (obj ind val)
- (if (and (string? obj)
- (integer? ind))
- (#_string-set! obj ind (val 'value))
- (error 'wrong-type-arg "string-set! ~S ~S ~S" obj ind val)))
-
- 'copy (lambda (obj . args)
- (if (mock-char? obj)
- (obj 'value)
- (error 'wrong-type-arg "copy: ~S ~S" obj args)))
- 'char? (lambda (obj) #t)
- 'class-name 'mock-char
- 'length (lambda (obj) #f)
- 'values (lambda (obj . args) (obj 'value))))))
-
- (define (mock-char c)
- (if (and (char? c)
- (not (let? c)))
- (openlet
- (sublet (*mock-char* 'mock-char-class)
- 'value c
- 'object->string mock->string))
- (error 'wrong-type-arg "mock-char ~S is not a char" c)))
-
- (set! mock-char? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-char-class))))
-
- (curlet))))
+ (let* ((mock-char? #f)
+ (mock-char-class
+ (openlet
+ (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
+ 'char-upcase (lambda (obj) (#_char-upcase (obj 'value)))
+ 'char-downcase (lambda (obj) (#_char-downcase (obj 'value)))
+ 'char->integer (lambda (obj) (#_char->integer (obj 'value)))
+ 'char-upper-case? (lambda (obj) (#_char-upper-case? (obj 'value)))
+ 'char-lower-case? (lambda (obj) (#_char-lower-case? (obj 'value)))
+ 'char-alphabetic? (lambda (obj) (#_char-alphabetic? (obj 'value)))
+ 'char-numeric? (lambda (obj) (#_char-numeric? (obj 'value)))
+ 'char-whitespace? (lambda (obj) (#_char-whitespace? (obj 'value)))
+ 'char=? (make-local-method #_char=?)
+ 'char<? (make-local-method #_char<?)
+ 'char>? (make-local-method #_char>?)
+ 'char<=? (make-local-method #_char<=?)
+ 'char>=? (make-local-method #_char>=?)
+ 'char-ci=? (make-local-method #_char-ci=?)
+ 'char-ci<? (make-local-method #_char-ci<?)
+ 'char-ci>? (make-local-method #_char-ci>?)
+ 'char-ci<=? (make-local-method #_char-ci<=?)
+ 'char-ci>=? (make-local-method #_char-ci>=?)
+ 'string (make-local-method #_string)
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-char*" "#<mock-char-class>"))
+ 'arity (lambda (obj) (#_arity (obj 'value)))
+ 'format (make-local-method #_format)
+ 'make-string (make-local-method #_make-string)
+ 'char-position (make-local-method #_char-position)
+
+ 'write-char (lambda (obj . args)
+ (if (mock-char? obj)
+ (apply #_write-char (obj 'value) args)
+ (error 'wrong-type-arg "write-char: ~S ~S" obj args)))
+
+ 'string-set! (lambda (obj ind val)
+ (if (and (string? obj)
+ (integer? ind))
+ (#_string-set! obj ind (val 'value))
+ (error 'wrong-type-arg "string-set! ~S ~S ~S" obj ind val)))
+
+ 'copy (lambda (obj . args)
+ (if (mock-char? obj)
+ (obj 'value)
+ (error 'wrong-type-arg "copy: ~S ~S" obj args)))
+ 'char? (lambda (obj) #t)
+ 'class-name 'mock-char
+ 'length (lambda (obj) #f)
+ 'values (lambda (obj . args) (obj 'value))))))
+
+ (define (mock-char c)
+ (if (and (char? c)
+ (not (let? c)))
+ (openlet
+ (sublet (*mock-char* 'mock-char-class)
+ 'value c
+ 'object->string mock->string))
+ (error 'wrong-type-arg "mock-char ~S is not a char" c)))
+
+ (set! mock-char? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-char-class))))
+
+ (curlet)))
#|
;;; eventually I'll conjure up unichars like (define lambda (byte-vector #xce #xbb)) via mock-char,
@@ -486,18 +501,18 @@
(let ((mock-number? #f))
(define* (range-method-1 func arg start end)
- (if (not end)
- (func arg (start 'value))
- (if (not (let? start))
- (func arg start (end 'value))
- (apply func arg (start 'value) end ()))))
+ (func arg (if (not end)
+ (start 'value)
+ (if (not (let? start))
+ (values start (end 'value))
+ (values (start 'value) end)))))
(define* (range-method-2 func arg1 arg2 start end)
- (if (not end)
- (func arg1 arg2 (start 'value))
- (if (not (let? start))
- (func arg1 arg2 start (end 'value))
- (apply func arg1 arg2 (start 'value) end ()))))
+ (func arg1 arg2 (if (not end)
+ (start 'value)
+ (if (not (let? start))
+ (values start (end 'value))
+ (values (start 'value) end)))))
(let ((mock-number-class
(openlet
@@ -516,23 +531,24 @@
'negative? (lambda (obj) (#_negative? (obj 'value)))
'infinite? (lambda (obj) (#_infinite? (obj 'value)))
'nan? (lambda (obj) (#_nan? (obj 'value)))
- (reader-cond ((not (provided? 'pure-s7))
- 'make-polar (make-method #_make-polar (lambda (obj) (obj 'value)))
- 'make-rectangular (make-method #_complex (lambda (obj) (obj 'value)))))
- 'complex (make-method #_complex (lambda (obj) (obj 'value)))
- 'random-state (make-method #_random-state (lambda (obj) (obj 'value)))
+ 'make-polar (if (provided? 'pure-s7)
+ (lambda (mag ang) (#_complex (* mag (cos ang)) (* mag (sin ang))))
+ (make-local-method #_make-polar))
+ 'make-rectangular (make-local-method #_complex)
+ 'complex (make-local-method #_complex)
+ 'random-state (make-local-method #_random-state)
'magnitude (lambda (obj) (#_magnitude (obj 'value)))
'angle (lambda (obj) (#_angle (obj 'value)))
- 'rationalize (make-method #_rationalize (lambda (obj) (obj 'value)))
+ 'rationalize (make-local-method #_rationalize)
'abs (lambda (obj) (#_abs (obj 'value)))
'exp (lambda (obj) (#_exp (obj 'value)))
- 'log (make-method #_log (lambda (obj) (obj 'value)))
+ 'log (make-local-method #_log)
'sin (lambda (obj) (#_sin (obj 'value)))
'cos (lambda (obj) (#_cos (obj 'value)))
'tan (lambda (obj) (#_tan (obj 'value)))
'asin (lambda (obj) (#_asin (obj 'value)))
'acos (lambda (obj) (#_acos (obj 'value)))
- 'atan (make-method #_atan (lambda (obj) (obj 'value)))
+ 'atan (make-local-method #_atan)
'sinh (lambda (obj) (#_sinh (obj 'value)))
'cosh (lambda (obj) (#_cosh (obj 'value)))
'tanh (lambda (obj) (#_tanh (obj 'value)))
@@ -540,7 +556,7 @@
'acosh (lambda (obj) (#_acosh (obj 'value)))
'atanh (lambda (obj) (#_atanh (obj 'value)))
'sqrt (lambda (obj) (#_sqrt (obj 'value)))
- 'expt (make-method #_expt (lambda (obj) (obj 'value)))
+ 'expt (make-local-method #_expt)
'floor (lambda (obj) (#_floor (obj 'value)))
'ceiling (lambda (obj) (#_ceiling (obj 'value)))
'truncate (lambda (obj) (#_truncate (obj 'value)))
@@ -557,42 +573,42 @@
'rational? (lambda (obj) (#_rational? (obj 'value)))
'exact? (lambda (obj) (#_exact? (obj 'value)))
'inexact? (lambda (obj) (#_inexact? (obj 'value)))
- 'ash (make-method #_ash (lambda (obj) (obj 'value)))
- 'logbit? (make-method #_logbit? (lambda (obj) (obj 'value)))
- 'number->string (make-method #_number->string (lambda (obj) (obj 'value)))
- 'random (make-method #_random (lambda (obj) (obj 'value)))
- 'quotient (make-method #_quotient (lambda (obj) (obj 'value)))
- 'remainder (make-method #_remainder (lambda (obj) (obj 'value)))
- 'modulo (make-method #_modulo (lambda (obj) (obj 'value)))
+ 'ash (make-local-method #_ash)
+ 'logbit? (make-local-method #_logbit?)
+ 'number->string (make-local-method #_number->string)
+ 'random (make-local-method #_random)
+ 'quotient (make-local-method #_quotient)
+ 'remainder (make-local-method #_remainder)
+ 'modulo (make-local-method #_modulo)
'lognot (lambda (obj) (#_lognot (obj 'value)))
- 'logior (make-method #_logior (lambda (obj) (obj 'value)))
- 'logxor (make-method #_logxor (lambda (obj) (obj 'value)))
- 'logand (make-method #_logand (lambda (obj) (obj 'value)))
+ 'logior (make-local-method #_logior)
+ 'logxor (make-local-method #_logxor)
+ 'logand (make-local-method #_logand)
;; any object that has lcm or gcd also needs rational?
- 'lcm (make-method #_lcm (lambda (obj) (obj 'value)))
- 'gcd (make-method #_gcd (lambda (obj) (obj 'value)))
- '+ (make-method #_+ (lambda (obj) (obj 'value)))
- '- (make-method #_- (lambda (obj) (obj 'value)))
- '* (make-method #_* (lambda (obj) (obj 'value)))
- '/ (make-method #_/ (lambda (obj) (obj 'value)))
+ 'lcm (make-local-method #_lcm)
+ 'gcd (make-local-method #_gcd)
+ '+ (make-local-method #_+)
+ '- (make-local-method #_-)
+ '* (make-local-method #_*)
+ '/ (make-local-method #_/)
;; any object that has min or max also needs real?
- 'max (make-method #_max (lambda (obj) (obj 'value)))
- 'min (make-method #_min (lambda (obj) (obj 'value)))
- '= (make-method #_= (lambda (obj) (obj 'value)))
- '< (make-method #_< (lambda (obj) (obj 'value)))
- '> (make-method #_> (lambda (obj) (obj 'value)))
- '<= (make-method #_<= (lambda (obj) (obj 'value)))
- '>= (make-method #_>= (lambda (obj) (obj 'value)))
+ 'max (make-local-method #_max)
+ 'min (make-local-method #_min)
+ '= (make-local-method #_=)
+ '< (make-local-method #_<)
+ '> (make-local-method #_>)
+ '<= (make-local-method #_<=)
+ '>= (make-local-method #_>=)
'write-byte (lambda (byte . port) (apply #_write-byte (byte 'value) port))
'make-list (lambda (ind . args) (apply #_make-list (ind 'value) args))
- 'make-vector (make-method #_make-vector (lambda (obj) (obj 'value)))
- 'make-float-vector(make-method #_make-float-vector (lambda (obj) (obj 'value)))
+ 'make-vector (make-local-method #_make-vector)
+ 'make-float-vector(make-local-method #_make-float-vector)
'make-hash-table (lambda (ind . args) (apply #_make-hash-table (ind 'value) args))
- 'make-byte-vector (make-method #_make-byte-vector (lambda (obj) (obj 'value)))
+ 'make-byte-vector (make-local-method #_make-byte-vector)
- 'byte-vector (make-method #_byte-vector (lambda (obj) (obj 'value)))
- 'format (make-method #_format (lambda (obj) (obj 'value)))
+ 'byte-vector (make-local-method #_byte-vector)
+ 'format (make-local-method #_format)
'make-string (lambda (ind . args)
(if (mock-number? ind)
@@ -835,119 +851,118 @@
;;; --------------------------------------------------------------------------------
(define *mock-pair*
- (let ((mock-pair? #f))
- (let ((mock-pair-class
- (openlet
- (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
- 'pair-line-number (lambda (obj) (#_pair-line-number (obj 'value)))
- 'list->string (lambda (obj) (#_list->string (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-pair*" "#<mock-pair-class>"))
- 'list? (lambda (obj) (#_list? (obj 'value)))
- 'car (lambda (obj) (#_car (obj 'value)))
- 'cdr (lambda (obj) (#_cdr (obj 'value)))
- 'set-car! (lambda (obj val) (#_set-car! (obj 'value) val))
- 'set-cdr! (lambda (obj val) (#_set-cdr! (obj 'value) val))
- 'caar (lambda (obj) (#_caar (obj 'value)))
- 'cadr (lambda (obj) (#_cadr (obj 'value)))
- 'cdar (lambda (obj) (#_cdar (obj 'value)))
- 'cddr (lambda (obj) (#_cddr (obj 'value)))
- 'caaar (lambda (obj) (#_caaar (obj 'value)))
- 'caadr (lambda (obj) (#_caadr (obj 'value)))
- 'cadar (lambda (obj) (#_cadar (obj 'value)))
- 'cdaar (lambda (obj) (#_cdaar (obj 'value)))
- 'caddr (lambda (obj) (#_caddr (obj 'value)))
- 'cdddr (lambda (obj) (#_cdddr (obj 'value)))
- 'cdadr (lambda (obj) (#_cdadr (obj 'value)))
- 'cddar (lambda (obj) (#_cddar (obj 'value)))
- 'caaaar (lambda (obj) (#_caaaar (obj 'value)))
- 'caaadr (lambda (obj) (#_caaadr (obj 'value)))
- 'caadar (lambda (obj) (#_caadar (obj 'value)))
- 'cadaar (lambda (obj) (#_cadaar (obj 'value)))
- 'caaddr (lambda (obj) (#_caaddr (obj 'value)))
- 'cadddr (lambda (obj) (#_cadddr (obj 'value)))
- 'cadadr (lambda (obj) (#_cadadr (obj 'value)))
- 'caddar (lambda (obj) (#_caddar (obj 'value)))
- 'cdaaar (lambda (obj) (#_cdaaar (obj 'value)))
- 'cdaadr (lambda (obj) (#_cdaadr (obj 'value)))
- 'cdadar (lambda (obj) (#_cdadar (obj 'value)))
- 'cddaar (lambda (obj) (#_cddaar (obj 'value)))
- 'cdaddr (lambda (obj) (#_cdaddr (obj 'value)))
- 'cddddr (lambda (obj) (#_cddddr (obj 'value)))
- 'cddadr (lambda (obj) (#_cddadr (obj 'value)))
- 'cdddar (lambda (obj) (#_cdddar (obj 'value)))
- 'assoc (lambda (val obj . args) (apply #_assoc val (obj 'value) args))
- (reader-cond ((not (provided? 'pure-s7))
- 'assq (lambda (val obj) (#_assq val (obj 'value)))
- 'assv (lambda (val obj) (#_assv val (obj 'value)))
- 'memq (lambda (val obj) (#_memq val (obj 'value)))
- 'memv (lambda (val obj) (#_memv val (obj 'value)))))
- 'member (lambda (val obj . args) (apply #_member val (obj 'value) args))
- 'let-ref (lambda (obj ind) (coverlet obj) (let ((val (#_list-ref (obj 'value) ind))) (openlet obj) val))
- 'let-set! (lambda (obj ind val) (coverlet obj) (#_list-set! (obj 'value) ind val) (openlet obj) val)
- 'arity (lambda (obj) (#_arity (obj 'value)))
- 'fill! (lambda (obj val) (#_fill! (obj 'value) val))
- 'reverse (lambda (obj) (#_reverse (obj 'value)))
- 'reverse! (lambda (obj) (set! (obj 'value) (#_reverse (obj 'value))))
- 'sort! (lambda (obj f) (#_sort! (obj 'value) f))
- 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
- 'eval (lambda (f obj) (#_eval (obj 'value)))
- 'list->vector (lambda (obj) (#_list->vector (obj 'value)))
-
- 'list-tail (lambda (obj . args)
- (if (mock-pair? obj)
- (apply #_list-tail (obj 'value) args)
- (error 'wrong-type-arg "list-tail ~S ~S" obj args)))
-
- 'copy (lambda (obj . args)
- (if (mock-pair? obj)
- (apply #_copy (obj 'value) args)
- (error 'wrong-type-arg "copy ~S ~S" obj args)))
-
- 'make-shared-vector (lambda (obj dims . args)
- (if (mock-pair? dims)
- (apply #_make-shared-vector obj (dims 'value) args)
- (error 'wrong-type-arg "make-shared-vector ~S ~S ~S" obj dims args)))
-
- 'make-vector (lambda (obj dims . args)
- (if (mock-pair? dims)
- (apply #_make-vector obj (dims 'value) args)
- (error 'wrong-type-arg "make-vector ~S ~S ~S" obj dims args)))
-
- 'append (make-method #_append (lambda (obj) (obj 'value)))
-
- 'list-ref (lambda (obj ind)
- (if (mock-pair? obj)
- (#_list-ref (obj 'value) ind)
- (error 'wrong-type-arg "list-ref ~S ~S" obj ind)))
-
- 'list-set! (lambda (obj ind val)
- (if (mock-pair? obj)
- (#_list-set! (obj 'value) ind val)
- (error 'wrong-type-arg "list-set! ~S ~S ~S" obj ind val)))
-
- 'pair? (lambda (obj) #t)
- 'length (lambda (obj) (#_length (obj 'value)))
- 'values (lambda (obj . args) (obj 'value))
- 'append (make-method #_append (lambda (obj) (obj 'value)))
- 'class-name 'mock-pair))))
-
- (define (mock-pair . args)
- (openlet
- (sublet (*mock-pair* 'mock-pair-class)
- 'value (copy args)
- 'object->string mock->string)))
-
- (set! mock-pair? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-pair-class))))
-
- (curlet))))
+ (let* ((mock-pair? #f)
+ (mock-pair-class
+ (openlet
+ (inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
+ 'pair-line-number (lambda (obj) (#_pair-line-number (obj 'value)))
+ 'list->string (lambda (obj) (#_list->string (obj 'value)))
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-pair*" "#<mock-pair-class>"))
+ 'list? (lambda (obj) (#_list? (obj 'value)))
+ 'car (lambda (obj) (#_car (obj 'value)))
+ 'cdr (lambda (obj) (#_cdr (obj 'value)))
+ 'set-car! (lambda (obj val) (#_set-car! (obj 'value) val))
+ 'set-cdr! (lambda (obj val) (#_set-cdr! (obj 'value) val))
+ 'caar (lambda (obj) (#_caar (obj 'value)))
+ 'cadr (lambda (obj) (#_cadr (obj 'value)))
+ 'cdar (lambda (obj) (#_cdar (obj 'value)))
+ 'cddr (lambda (obj) (#_cddr (obj 'value)))
+ 'caaar (lambda (obj) (#_caaar (obj 'value)))
+ 'caadr (lambda (obj) (#_caadr (obj 'value)))
+ 'cadar (lambda (obj) (#_cadar (obj 'value)))
+ 'cdaar (lambda (obj) (#_cdaar (obj 'value)))
+ 'caddr (lambda (obj) (#_caddr (obj 'value)))
+ 'cdddr (lambda (obj) (#_cdddr (obj 'value)))
+ 'cdadr (lambda (obj) (#_cdadr (obj 'value)))
+ 'cddar (lambda (obj) (#_cddar (obj 'value)))
+ 'caaaar (lambda (obj) (#_caaaar (obj 'value)))
+ 'caaadr (lambda (obj) (#_caaadr (obj 'value)))
+ 'caadar (lambda (obj) (#_caadar (obj 'value)))
+ 'cadaar (lambda (obj) (#_cadaar (obj 'value)))
+ 'caaddr (lambda (obj) (#_caaddr (obj 'value)))
+ 'cadddr (lambda (obj) (#_cadddr (obj 'value)))
+ 'cadadr (lambda (obj) (#_cadadr (obj 'value)))
+ 'caddar (lambda (obj) (#_caddar (obj 'value)))
+ 'cdaaar (lambda (obj) (#_cdaaar (obj 'value)))
+ 'cdaadr (lambda (obj) (#_cdaadr (obj 'value)))
+ 'cdadar (lambda (obj) (#_cdadar (obj 'value)))
+ 'cddaar (lambda (obj) (#_cddaar (obj 'value)))
+ 'cdaddr (lambda (obj) (#_cdaddr (obj 'value)))
+ 'cddddr (lambda (obj) (#_cddddr (obj 'value)))
+ 'cddadr (lambda (obj) (#_cddadr (obj 'value)))
+ 'cdddar (lambda (obj) (#_cdddar (obj 'value)))
+ 'assoc (lambda (val obj . args) (apply #_assoc val (obj 'value) args))
+ 'assq (lambda (val obj) (#_assq val (obj 'value)))
+ 'assv (lambda (val obj) (#_assv val (obj 'value)))
+ 'memq (lambda (val obj) (#_memq val (obj 'value)))
+ 'memv (lambda (val obj) (#_memv val (obj 'value)))
+ 'member (lambda (val obj . args) (apply #_member val (obj 'value) args))
+ 'let-ref (lambda (obj ind) (coverlet obj) (let ((val (#_list-ref (obj 'value) ind))) (openlet obj) val))
+ 'let-set! (lambda (obj ind val) (coverlet obj) (#_list-set! (obj 'value) ind val) (openlet obj) val)
+ 'arity (lambda (obj) (#_arity (obj 'value)))
+ 'fill! (lambda (obj val) (#_fill! (obj 'value) val))
+ 'reverse (lambda (obj) (#_reverse (obj 'value)))
+ 'reverse! (lambda (obj) (set! (obj 'value) (#_reverse (obj 'value))))
+ 'sort! (lambda (obj f) (#_sort! (obj 'value) f))
+ 'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
+ 'eval (lambda (f obj) (#_eval (obj 'value)))
+ 'list->vector (lambda (obj) (#_list->vector (obj 'value)))
+
+ 'list-tail (lambda (obj . args)
+ (if (mock-pair? obj)
+ (apply #_list-tail (obj 'value) args)
+ (error 'wrong-type-arg "list-tail ~S ~S" obj args)))
+
+ 'copy (lambda (obj . args)
+ (if (mock-pair? obj)
+ (apply #_copy (obj 'value) args)
+ (error 'wrong-type-arg "copy ~S ~S" obj args)))
+
+ 'make-shared-vector (lambda (obj dims . args)
+ (if (mock-pair? dims)
+ (apply #_make-shared-vector obj (dims 'value) args)
+ (error 'wrong-type-arg "make-shared-vector ~S ~S ~S" obj dims args)))
+
+ 'make-vector (lambda (obj dims . args)
+ (if (mock-pair? dims)
+ (apply #_make-vector obj (dims 'value) args)
+ (error 'wrong-type-arg "make-vector ~S ~S ~S" obj dims args)))
+
+ 'append (make-local-method #_append)
+
+ 'list-ref (lambda (obj ind)
+ (if (mock-pair? obj)
+ (#_list-ref (obj 'value) ind)
+ (error 'wrong-type-arg "list-ref ~S ~S" obj ind)))
+
+ 'list-set! (lambda (obj ind val)
+ (if (mock-pair? obj)
+ (#_list-set! (obj 'value) ind val)
+ (error 'wrong-type-arg "list-set! ~S ~S ~S" obj ind val)))
+
+ 'pair? (lambda (obj) #t)
+ 'length (lambda (obj) (#_length (obj 'value)))
+ 'values (lambda (obj . args) (obj 'value))
+ 'append (make-local-method #_append)
+ 'class-name 'mock-pair))))
+
+ (define (mock-pair . args)
+ (openlet
+ (sublet (*mock-pair* 'mock-pair-class)
+ 'value (copy args)
+ 'object->string mock->string)))
+
+ (set! mock-pair? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-pair-class))))
+
+ (curlet)))
#|
(let ((immutable-list-class
(sublet (*mock-pair* 'mock-pair-class)
'object->string mock->string
-
+
'let-set! (lambda (obj i val)
(set! (obj 'value) (append (copy (obj 'value) (make-list (+ i 1))) (list-tail (obj 'value) (+ i 1))))
(list-set! (obj 'value) i val))
@@ -1019,74 +1034,74 @@
;;; --------------------------------------------------------------------------------
(define *mock-port*
- (let ((mock-port? #f))
- (let ((mock-port-class
- (openlet
- (inlet 'port? (lambda (obj) #t)
- 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
- 'close-input-port (lambda (obj) (#_close-input-port (obj 'value)))
- 'close-output-port (lambda (obj) (#_close-output-port (obj 'value)))
- 'flush-output-port (lambda (obj) (#_flush-output-port (obj 'value)))
- 'get-output-string (lambda (obj) (#_get-output-string (obj 'value)))
- 'newline (lambda (obj) (#_newline (obj 'value)))
- 'write (lambda (x obj) (#_write x (obj 'value)))
- 'display (lambda (x obj) (#_display x (obj 'value)))
- 'read-char (lambda (obj) (#_read-char (obj 'value)))
- 'peek-char (lambda (obj) (#_peek-char (obj 'value)))
- 'read-byte (lambda (obj) (#_read-byte (obj 'value)))
- 'read-line (lambda (obj . args) (apply #_read-line (obj 'value) args))
- 'read (lambda (obj) (#_read (obj 'value)))
- 'input-port? (lambda (obj) (#_input-port? (obj 'value)))
- 'output-port? (lambda (obj) (#_output-port? (obj 'value)))
- 'port-closed? (lambda (obj) (#_port-closed? (obj 'value)))
- 'char-ready? (lambda (obj) (#_char-ready? (obj 'value)))
- 'port-line-number (lambda (obj) (#_port-line-number (obj 'value)))
- 'port-filename (lambda (obj) (#_port-filename (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-port*" "#<mock-port-class>"))
- 'format (make-method #_format (lambda (obj) (obj 'value)))
-
- 'set-current-output-port (lambda (obj) (#_set-current-output-port (obj 'value)))
- 'set-current-input-port (lambda (obj) (#_set-current-input-port (obj 'value)))
- 'set-current-error-port (lambda (obj) (#_set-current-error-port (obj 'value)))
-
- 'write-char (lambda (c obj)
- (if (mock-port? obj)
- (#_write-char c (obj 'value))
- (error 'wrong-type-arg "write-char ~S ~S" c obj)))
-
- 'write-string (lambda (s obj . args)
- (if (mock-port? obj)
- (apply #_write-string s (obj 'value) args)
- (error 'wrong-type-arg "write-string ~S ~S ~S" s obj args)))
-
- 'write-byte (lambda (b obj)
- (if (mock-port? obj)
- (#_write-byte b (obj 'value))
- (error 'wrong-type-arg "write-byte ~S ~S" b obj)))
-
- 'read-string (lambda (k obj)
- (if (mock-port? obj)
- (#_read-string k (obj 'value))
- (error 'wrong-type-arg "read-string ~S ~S" k obj)))
- 'values (lambda (obj . args) (obj 'value))
- 'class-name 'mock-port
- ))))
-
- (define (mock-port port)
- (if (and (or (input-port? port)
- (output-port? port))
- (not (let? port)))
- (openlet
- (sublet (*mock-port* 'mock-port-class)
- 'value port
- 'object->string mock->string))
- (error 'wrong-type-arg "mock-port ~S is not a port" port)))
-
- (set! mock-port? (lambda (obj)
- (and (openlet? obj)
- (outlet-member obj mock-port-class))))
-
- (curlet))))
+ (let* ((mock-port? #f)
+ (mock-port-class
+ (openlet
+ (inlet 'port? (lambda (obj) #t)
+ 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
+ 'close-input-port (lambda (obj) (#_close-input-port (obj 'value)))
+ 'close-output-port (lambda (obj) (#_close-output-port (obj 'value)))
+ 'flush-output-port (lambda (obj) (#_flush-output-port (obj 'value)))
+ 'get-output-string (lambda (obj) (#_get-output-string (obj 'value)))
+ 'newline (lambda (obj) (#_newline (obj 'value)))
+ 'write (lambda (x obj) (#_write x (obj 'value)))
+ 'display (lambda (x obj) (#_display x (obj 'value)))
+ 'read-char (lambda (obj) (#_read-char (obj 'value)))
+ 'peek-char (lambda (obj) (#_peek-char (obj 'value)))
+ 'read-byte (lambda (obj) (#_read-byte (obj 'value)))
+ 'read-line (lambda (obj . args) (apply #_read-line (obj 'value) args))
+ 'read (lambda (obj) (#_read (obj 'value)))
+ 'input-port? (lambda (obj) (#_input-port? (obj 'value)))
+ 'output-port? (lambda (obj) (#_output-port? (obj 'value)))
+ 'port-closed? (lambda (obj) (#_port-closed? (obj 'value)))
+ 'char-ready? (lambda (obj) (#_char-ready? (obj 'value)))
+ 'port-line-number (lambda (obj) (#_port-line-number (obj 'value)))
+ 'port-filename (lambda (obj) (#_port-filename (obj 'value)))
+ 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-port*" "#<mock-port-class>"))
+ 'format (make-local-method #_format)
+
+ 'set-current-output-port (lambda (obj) (#_set-current-output-port (obj 'value)))
+ 'set-current-input-port (lambda (obj) (#_set-current-input-port (obj 'value)))
+ 'set-current-error-port (lambda (obj) (#_set-current-error-port (obj 'value)))
+
+ 'write-char (lambda (c obj)
+ (if (mock-port? obj)
+ (#_write-char c (obj 'value))
+ (error 'wrong-type-arg "write-char ~S ~S" c obj)))
+
+ 'write-string (lambda (s obj . args)
+ (if (mock-port? obj)
+ (apply #_write-string s (obj 'value) args)
+ (error 'wrong-type-arg "write-string ~S ~S ~S" s obj args)))
+
+ 'write-byte (lambda (b obj)
+ (if (mock-port? obj)
+ (#_write-byte b (obj 'value))
+ (error 'wrong-type-arg "write-byte ~S ~S" b obj)))
+
+ 'read-string (lambda (k obj)
+ (if (mock-port? obj)
+ (#_read-string k (obj 'value))
+ (error 'wrong-type-arg "read-string ~S ~S" k obj)))
+ 'values (lambda (obj . args) (obj 'value))
+ 'class-name 'mock-port
+ ))))
+
+ (define (mock-port port)
+ (if (and (or (input-port? port)
+ (output-port? port))
+ (not (let? port)))
+ (openlet
+ (sublet (*mock-port* 'mock-port-class)
+ 'value port
+ 'object->string mock->string))
+ (error 'wrong-type-arg "mock-port ~S is not a port" port)))
+
+ (set! mock-port? (lambda (obj)
+ (and (openlet? obj)
+ (outlet-member obj mock-port-class))))
+
+ (curlet)))
;;; sublet of any of these needs to include the value field or a let-ref-fallback
#|
diff --git a/moog.scm b/moog.scm
index 97618af..fa1682c 100644
--- a/moog.scm
+++ b/moog.scm
@@ -153,9 +153,8 @@
(let-set! m 'sig sig)
(with-let m
(let ((A (* 0.25 (- sig y)))
- (st 0.0))
+ (st s0))
- (set! st s0)
(set! s0 (+ A (* fc (- A st))))
(set! A (+ s0 st))
@@ -180,9 +179,8 @@
(let-set! m 'sig sig)
(with-let m
(let ((A (* 0.25 (- sig y)))
- (st 0.0))
+ (st s0))
- (set! st s0)
(set! s0 (min 0.95 (max -0.95 (+ A (* fc (- A st))))))
(set! A (min 0.95 (max -0.95 (+ s0 st))))
diff --git a/mus-config.h.in b/mus-config.h.in
index fe82738..b124bf6 100644
--- a/mus-config.h.in
+++ b/mus-config.h.in
@@ -94,13 +94,12 @@
#undef HAVE_MPG321
#undef PATH_MPG321
-#undef HAVE_TTA
-#undef PATH_TTA
-
#undef HAVE_WAVPACK
#undef PATH_WAVPACK
#undef PATH_WVUNPACK
+/* --with-webserver */
+#undef ENABLE_WEBSERVER
#undef WORDS_BIGENDIAN
diff --git a/musglyphs.scm b/musglyphs.scm
index 0e83e32..b219948 100644
--- a/musglyphs.scm
+++ b/musglyphs.scm
@@ -10,28 +10,23 @@
(define make-polygon
(lambda (args)
(define (total-length vects len)
- (if (null? vects)
- len
- (if (vector? (car vects))
- (total-length (cdr vects) (+ len (length (car vects))))
- (if (car vects)
- (total-length (cdr vects) (+ len 1))
- (total-length (cdr vects) len)))))
+ (cond ((null? vects) len)
+ ((vector? (car vects)) (total-length (cdr vects) (+ len (length (car vects)))))
+ ((car vects) (total-length (cdr vects) (+ len 1)))
+ (else (total-length (cdr vects) len))))
(define (set-vals vects start vals)
- (if (null? vects)
- vals
- (if (vector? (car vects))
- (let* ((vect (car vects))
- (len (length vect)))
- (do ((i 0 (+ 1 i)))
- ((= i len))
- (set! (vals (+ start i)) (vect i)))
- (set-vals (cdr vects) (+ start len) vals))
- (if (car vects)
- (begin
- (set! (vals start) (car vects))
- (set-vals (cdr vects) (+ start 1) vals))
- (set-vals (cdr vects) start vals)))))
+ (cond ((null? vects) vals)
+ ((vector? (car vects))
+ (let* ((vect (car vects))
+ (len (length vect)))
+ (do ((i 0 (+ 1 i)))
+ ((= i len))
+ (set! (vals (+ start i)) (vect i)))
+ (set-vals (cdr vects) (+ start len) vals)))
+ ((car vects)
+ (set! (vals start) (car vects))
+ (set-vals (cdr vects) (+ start 1) vals))
+ (else (set-vals (cdr vects) start vals))))
(set-vals args 0 (make-vector (total-length args 0)))))
(define (make-bezier-1 x0 y0 x1 y1 x2 y2 x3 y3 n)
@@ -41,8 +36,8 @@
(cy (* 3 (- y1 y0)))
(bx (- (* 3 (- x2 x1)) cx))
(by (- (* 3 (- y2 y1)) cy))
- (ax (- x3 (+ x0 cx bx)))
- (ay (- y3 (+ y0 cy by)))
+ (ax (- x3 x0 cx bx))
+ (ay (- y3 y0 cy by))
(incr (/ 1.0 n))
(pts (make-vector (* 2 (+ n 1)))))
(set! (pts 0) x0)
@@ -206,9 +201,9 @@
((8 9) 5) ; a-flat
(else 6)))) ; b-flat
(list pclass octave
- (if (or (= pclass 1) (= pclass 6))
+ (if (memv pclass '(1 6))
:sharp
- (and (or (= pclass 3) (= pclass 8) (= pclass 10))
+ (and (memv pclass '(3 8 10))
:flat))
cclass
pitch)))
@@ -262,15 +257,13 @@
(draw-treble-clef x0 (+ y0 (* size .76)) size)
(draw-bass-clef (+ x0 (* size .075)) (+ y0 (* size .26)) size))
(set! x0 (+ x0 (* size .8))))
- (if accidental
- (set! x0 (+ x0 (* size .1)))
- (set! x0 (+ x0 (* size .25)))))
+ (set! x0 (+ x0 (* size (if accidental .1 .25)))))
;; accidental
(if accidental
(begin
((if (eq? accidental :sharp) draw-sharp draw-flat) x0 (+ y0 (* .02 size) (* line-sep 0.5 line)) size)
- (set! x0 (+ x0 (* .25 size)))))
+ (set! x0 (+ x0 line-sep))))
;; notehead
(set! notehead-y (+ y0 (* .02 size) (* line-sep 0.5 line)))
@@ -294,25 +287,26 @@
;; stem
(if (< dur 3)
- (if (> line 3)
- ;; stem up
- (fill-rectangle (+ x0 (* size .25)) (+ y0 (* .02 size) (* size -0.8) (* line-sep 0.5 line)) (* size .05) (* size 0.8))
- (fill-rectangle (- x0 (* size .02)) (+ y0 (* line-sep line 0.5)) (* size .05) (* size 0.8))))
+ (fill-rectangle
+ (if (> line 3) ; stem up
+ (values (+ x0 line-sep) (+ y0 (* 0.02 size) (* size -0.8) (* line-sep 0.5 line)))
+ (values (- x0 (* size 0.02)) (+ y0 (* line-sep line 0.5))))
+ (* size 0.05) (* size 0.8)))
;; flags
(if (< dur .6)
(let ((base (+ y0 (* line-sep 0.5 line))))
(if (> line 2)
- (draw-8th-flag-up (+ x0 (* size .25)) (+ base (* size -0.6)) size)
+ (draw-8th-flag-up (+ x0 line-sep) (+ base (* size -0.6)) size)
(draw-8th-flag-down x0 (+ base (* .7 size)) size))
(if (< dur .3)
(begin
(if (> line 2)
- (draw-extend-flag-up (+ x0 (* size .25)) (+ base (* size -0.8)) size)
+ (draw-extend-flag-up (+ x0 line-sep) (+ base (* size -0.8)) size)
(draw-extend-flag-down x0 (+ base (* .9 size)) size))
(if (< dur .15)
(if (> line 2)
- (draw-extend-flag-up (+ x0 (* size .25)) (+ base (* size -1.0)) size)
+ (draw-extend-flag-up (+ x0 line-sep) (+ base (* size -1.0)) size)
(draw-extend-flag-down x0 (+ base (* 1.1 size)) size)))))))
(list notehead-x notehead-y)))
diff --git a/nb.scm b/nb.scm
index d9ad762..6a531f5 100644
--- a/nb.scm
+++ b/nb.scm
@@ -86,15 +86,15 @@ It causes a description of the file to popup when the mouse crosses the filename
(> (length comment) 0))
(format #f "~% comment: ~A" comment)
""))
- (if (and use-gdbm
- (file-exists? nb-database))
+ (if (not (and use-gdbm
+ (file-exists? nb-database)))
+ ""
(let* ((ptr (gdbm-open nb-database 'read))
(note (gdbm-fetch ptr file)))
(gdbm-close! ptr)
(if (string? note)
(format #f "~%~A" note)
- ""))
- ""))))
+ ""))))))
(let ((region-viewer 2))
(set! nb-mouse-response-time (get-internal-real-time))
@@ -111,13 +111,13 @@ It causes a description of the file to popup when the mouse crosses the filename
(+ (cadr files-position) 10))))))))))))
-(define (files-popdown-info type position name)
+(define (files-popdown-info)
(let ((cur-time (get-internal-real-time)))
(in 1000 (lambda ()
(if (> cur-time nb-mouse-response-time)
(hide-widget (list-ref (dialog-widgets) 15)))))))
-(hook-push mouse-enter-label-hook (lambda (hook) (files-popup-info (hook 'type) (hook 'position) (hook 'label))))
-(hook-push mouse-leave-label-hook (lambda (hook) (files-popdown-info (hook 'type) (hook 'position) (hook 'label))))
+(hook-push mouse-enter-label-hook (lambda (hook) (files-popup-info (hook 'type) #f (hook 'label))))
+(hook-push mouse-leave-label-hook (lambda (hook) (files-popdown-info)))
diff --git a/new-effects.scm b/new-effects.scm
index b910a4c..a48c375 100644
--- a/new-effects.scm
+++ b/new-effects.scm
@@ -27,7 +27,7 @@
cw
(* .5 (+ lw rw)))))
;; favor is the point we center the search on
- (define (centered-points points)
+ (let centered-points ((points ms))
(if (= (length points) 2)
points
(let ((p1 (car points))
@@ -35,8 +35,7 @@
(p3 (caddr points)))
(if (< (abs (- p1 favor)) (abs (- p3 favor)))
(list p1 p2)
- (centered-points (cdr points))))))
- (centered-points ms))))))))
+ (centered-points (cdr points)))))))))))))
(define map-chan-over-target-with-sync
;; target: 'marks -> beg=closest marked sample, dur=samples to next mark
@@ -45,47 +44,41 @@
;; 'cursor -> beg=cursor, dur=samples to end of sound
;; decay is how long to run the effect past the end of the sound
(lambda (func target origin decay)
- (if (and (eq? target 'selection)
- (not (selection?)))
- (snd-print ";no selection")
- (if (and (eq? target 'sound)
- (null? (sounds)))
- (snd-print ";no sound")
- (if (and (eq? target 'marks)
- (or (null? (sounds))
- (< (length (marks (selected-sound) (selected-channel))) 2)))
- (snd-print ";no marks")
- (let* ((snc (sync))
- (ms (and (eq? target 'marks)
- (plausible-mark-samples)))
- (beg (if (eq? target 'sound)
- 0
- (if (eq? target 'selection)
- (selection-position)
- (if (eq? target 'cursor)
- (cursor (selected-sound) (selected-channel))
- (car ms)))))
- (overlap (if decay
- (floor (* (srate) decay))
- 0)))
- (apply for-each
- (lambda (snd chn)
- (let ((end (if (memq target '(sound cursor))
- (- (framples snd chn) 1)
- (if (eq? target 'selection)
- (+ (selection-position) (selection-framples))
- (cadr ms)))))
- (if (= (sync snd) snc)
- (map-channel (func (- end beg)) beg (+ end overlap 1) snd chn #f
- (format #f "~A ~A ~A"
- (origin target (- end beg))
- (if (eq? target 'sound) 0 beg)
- (and (not (eq? target 'sound)) (+ 1 (- end beg))))))))
-
- (if (> snc 0)
- (all-chans)
- (list (list (selected-sound))
- (list (selected-channel)))))))))))
+ (cond ((and (eq? target 'selection)
+ (not (selection?)))
+ (snd-print ";no selection"))
+ ((and (eq? target 'sound)
+ (null? (sounds)))
+ (snd-print ";no sound"))
+ ((and (eq? target 'marks)
+ (or (null? (sounds))
+ (< (length (marks (selected-sound) (selected-channel))) 2)))
+ (snd-print ";no marks"))
+ (else
+ (let* ((snc (sync))
+ (ms (and (eq? target 'marks)
+ (plausible-mark-samples)))
+ (beg (case target
+ ((sound) 0)
+ ((selection) (selection-position))
+ ((cursor) (cursor (selected-sound) (selected-channel)))
+ (else (car ms))))
+ (overlap (if decay (floor (* (srate) decay)) 0)))
+ (apply for-each
+ (lambda (snd chn)
+ (let ((end (if (memq target '(sound cursor))
+ (- (framples snd chn) 1)
+ (if (eq? target 'selection)
+ (+ (selection-position) (selection-framples))
+ (cadr ms)))))
+ (if (= (sync snd) snc)
+ (map-channel (func (- end beg)) beg (+ end overlap 1) snd chn
+ #f
+ (format #f "~A ~A ~A" (origin target (- end beg)) (if (eq? target 'sound) 0 beg)
+ (and (not (eq? target 'sound)) (+ 1 (- end beg))))))))
+ (if (> snc 0)
+ (all-chans)
+ (list (list (selected-sound)) (list (selected-channel))))))))))
(define yellow-pixel
(let ((pix #f))
@@ -168,15 +161,15 @@
(define* (effects-squelch-channel amp gate-size snd chn no-silence)
(let ((f0 (make-moving-average gate-size))
(f1 (make-moving-average gate-size :initial-element 1.0)))
- (if no-silence
- (map-channel (lambda (y)
- (let ((val (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
- (and (not (zero? val)) val)))
- 0 #f snd chn #f (format #f "effects-squelch-channel ~A ~A" amp gate-size))
- (map-channel (lambda (y)
- (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp)))))
- 0 #f snd chn #f (format #f "effects-squelch-channel ~A ~A" amp gate-size)))))
-
+ (map-channel
+ (if no-silence
+ (lambda (y)
+ (let ((val (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
+ (and (not (zero? val)) val)))
+ (lambda (y)
+ (* y (moving-average f1 (ceiling (- (moving-average f0 (* y y)) amp))))))
+ 0 #f snd chn #f
+ (format #f "effects-squelch-channel ~A ~A" amp gate-size))))
(let* ((amp-menu-list ())
(amp-menu (XmCreatePulldownMenu (main-menu effects-menu) "Amplitude Effects"
@@ -189,93 +182,93 @@
;;; -------- Gain (gain set by gain-amount)
- (let ((gain-amount 1.0)
- (gain-label "Gain")
- (gain-dialog #f)
- (gain-target 'sound)
- (gain-envelope #f))
-
- (define (scale-envelope e scl)
- (if (null? e)
- ()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
-
- (define (post-gain-dialog)
- (if (not (Widget? gain-dialog))
- ;; if gain-dialog doesn't exist, create it
- (let ((initial-gain-amount 1.0)
- (sliders ())
- (fr #f))
- (set! gain-dialog
- (make-effect-dialog
- gain-label
-
- (lambda (w context info)
- (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
- (scale-envelope (xe-envelope gain-envelope) gain-amount))))
- (if (eq? gain-target 'sound)
- (if with-env
- (env-sound with-env)
- (scale-by gain-amount))
- (if (eq? gain-target 'selection)
- (if (selection?)
- (if with-env
- (env-selection with-env)
- (scale-selection-by gain-amount))
- (snd-print ";no selection"))
- (let ((pts (catch 'no-such-mark
- plausible-mark-samples
- (lambda args #f))))
- (if pts
- (if with-env
- (env-sound with-env (car pts) (- (cadr pts) (car pts)))
- (scale-by gain-amount (car pts) (- (cadr pts) (car pts))))
- (snd-print ";no marks")))))))
-
- (lambda (w context info)
- (help-dialog "Gain"
- "Move the slider to change the gain scaling amount."))
-
- (lambda (w c i)
- (set! gain-amount initial-gain-amount)
- (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
- (XtSetValues (car sliders) (list XmNvalue (floor (* gain-amount 100)))))
-
- (lambda ()
- (effect-target-ok gain-target))))
-
- (set! sliders
- (add-sliders gain-dialog
- (list (list "gain" 0.0 initial-gain-amount 5.0
- (lambda (w context info)
- (set! gain-amount (/ (.value info) 100.0)))
- 100))))
- (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
- (list XmNheight 200
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget (sliders (- (length sliders) 1))
- XmNshadowThickness 4
- XmNshadowType XmSHADOW_ETCHED_OUT)))
-
- (let ((target-row (add-target (XtParent (XtParent (car sliders)))
- (lambda (target)
- (set! gain-target target)
- (XtSetSensitive (XmMessageBoxGetChild gain-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
+ (let ((gain-amount 1.0))
+
+ (define post-gain-dialog
+ (let ((gain-label "Gain")
+ (gain-dialog #f)
+ (gain-target 'sound)
+ (gain-envelope #f))
+
+ (define (scale-envelope e scl)
+ (if (null? e)
+ ()
+ (append (list (car e) (* scl (cadr e)))
+ (scale-envelope (cddr e) scl))))
+
+ (lambda ()
+ (if (Widget? gain-dialog)
(activate-dialog gain-dialog)
-
- (set! gain-envelope (xe-create-enved "gain" fr
- (list XmNheight 200)
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
- (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget target-row)))
-
- )
- (activate-dialog gain-dialog)))
+ ;; if gain-dialog doesn't exist, create it
+ (let ((initial-gain-amount 1.0)
+ (sliders ())
+ (fr #f))
+ (set! gain-dialog
+ (make-effect-dialog
+ gain-label
+
+ (lambda (w context info)
+ (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
+ (scale-envelope (xe-envelope gain-envelope) gain-amount))))
+ (if (eq? gain-target 'sound)
+ (if with-env
+ (env-sound with-env)
+ (scale-by gain-amount))
+ (if (eq? gain-target 'selection)
+ (if (selection?)
+ (if with-env
+ (env-selection with-env)
+ (scale-selection-by gain-amount))
+ (snd-print ";no selection"))
+ (let ((pts (catch 'no-such-mark
+ plausible-mark-samples
+ (lambda args #f))))
+ (if pts
+ (if with-env
+ (env-sound with-env (car pts) (- (cadr pts) (car pts)))
+ (scale-by gain-amount (car pts) (- (cadr pts) (car pts))))
+ (snd-print ";no marks")))))))
+
+ (lambda (w context info)
+ (help-dialog "Gain"
+ "Move the slider to change the gain scaling amount."))
+
+ (lambda (w c i)
+ (set! gain-amount initial-gain-amount)
+ (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtSetValues (car sliders) (list XmNvalue (floor (* gain-amount 100)))))
+
+ (lambda ()
+ (effect-target-ok gain-target))))
+
+ (set! sliders
+ (add-sliders gain-dialog
+ (list (list "gain" 0.0 initial-gain-amount 5.0
+ (lambda (w context info)
+ (set! gain-amount (/ (.value info) 100.0)))
+ 100))))
+ (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
+ (list XmNheight 200
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget (sliders (- (length sliders) 1))
+ XmNshadowThickness 4
+ XmNshadowType XmSHADOW_ETCHED_OUT)))
+
+ (let ((target-row (add-target (XtParent (XtParent (car sliders)))
+ (lambda (target)
+ (set! gain-target target)
+ (XtSetSensitive (XmMessageBoxGetChild gain-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+ (activate-dialog gain-dialog)
+
+ (set! gain-envelope (xe-create-enved "gain" fr
+ (list XmNheight 200)
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget target-row))))))))
(let ((child (XtCreateManagedWidget "Gain" xmPushButtonWidgetClass amp-menu
(list XmNbackground *basic-color*))))
@@ -283,63 +276,63 @@
(lambda (w c i)
(post-gain-dialog)))
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Gain (~1,2F)" gain-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Gain (~1,2F)" gain-amount)))
amp-menu-list))))
;;; -------- Normalize
;;;
- (let ((normalize-amount 1.0)
- (normalize-label "Normalize")
- (normalize-dialog #f)
- (normalize-target 'sound))
-
- (define (post-normalize-dialog)
- (if (not (Widget? normalize-dialog))
- ;; if normalize-dialog doesn't exist, create it
- (let ((initial-normalize-amount 1.0)
- (sliders ()))
- (set! normalize-dialog
- (make-effect-dialog
- normalize-label
-
- (lambda (w context info)
- (if (eq? normalize-target 'sound)
- (scale-to normalize-amount)
- (if (eq? normalize-target 'selection)
- (if (selection?)
- (scale-selection-to normalize-amount)
- (snd-print ";no selection"))
- (let ((pts (plausible-mark-samples)))
- (if pts
- (scale-to normalize-amount (car pts) (- (cadr pts) (car pts))))))))
-
- (lambda (w context info)
- (help-dialog "Normalize"
- "Normalize scales amplitude to the normalize amount. Move the slider to change the scaling amount."))
-
- (lambda (w c i)
- (set! normalize-amount initial-normalize-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* normalize-amount 100)))))
-
- (lambda ()
- (effect-target-ok normalize-target))))
-
- (set! sliders
- (add-sliders normalize-dialog
- (list (list "normalize" 0.0 initial-normalize-amount 1.0
- (lambda (w context info)
- (set! normalize-amount (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! normalize-target target)
- (XtSetSensitive (XmMessageBoxGetChild normalize-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
+ (let ((normalize-amount 1.0))
+
+ (define post-normalize-dialog
+ (let ((normalize-label "Normalize")
+ (normalize-dialog #f)
+ (normalize-target 'sound))
+ (lambda ()
+ (unless (Widget? normalize-dialog)
+ ;; if normalize-dialog doesn't exist, create it
+ (let ((initial-normalize-amount 1.0)
+ (sliders ()))
+ (set! normalize-dialog
+ (make-effect-dialog
+ normalize-label
+
+ (lambda (w context info)
+ (if (eq? normalize-target 'sound)
+ (scale-to normalize-amount)
+ (if (eq? normalize-target 'selection)
+ (if (selection?)
+ (scale-selection-to normalize-amount)
+ (snd-print ";no selection"))
+ (let ((pts (plausible-mark-samples)))
+ (if pts
+ (scale-to normalize-amount (car pts) (- (cadr pts) (car pts))))))))
+
+ (lambda (w context info)
+ (help-dialog "Normalize"
+ "Normalize scales amplitude to the normalize amount. Move the slider to change the scaling amount."))
+
+ (lambda (w c i)
+ (set! normalize-amount initial-normalize-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* normalize-amount 100)))))
+
+ (lambda ()
+ (effect-target-ok normalize-target))))
+
+ (set! sliders
+ (add-sliders normalize-dialog
+ (list (list "normalize" 0.0 initial-normalize-amount 1.0
+ (lambda (w context info)
+ (set! normalize-amount (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! normalize-target target)
+ (XtSetSensitive (XmMessageBoxGetChild normalize-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
- (activate-dialog normalize-dialog))
+ (activate-dialog normalize-dialog))))
(let ((child (XtCreateManagedWidget "Normalize" xmPushButtonWidgetClass amp-menu
(list XmNbackground *basic-color*))))
@@ -348,71 +341,71 @@
(post-normalize-dialog)))
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Normalize (~1,2F)" normalize-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Normalize (~1,2F)" normalize-amount)))
amp-menu-list))))
;;; -------- Gate (gate set by gate-amount)
;;;
- (let ((gate-amount 0.01)
- (gate-label "Gate")
- (gate-dialog #f)
- (gate-size 128)
- (omit-silence #f))
-
- (define (post-gate-dialog)
- (if (not (Widget? gate-dialog))
- ;; if gate-dialog doesn't exist, create it
- (let ((initial-gate-amount 0.01)
- (sliders ()))
- (set! gate-dialog
- (make-effect-dialog
- gate-label
-
- (lambda (w context info)
- (let ((snc (sync)))
- (if (> snc 0)
- (apply map
- (lambda (snd chn)
- (if (= (sync snd) snc)
- (effects-squelch-channel (* gate-amount gate-amount) gate-size snd chn omit-silence)))
- (all-chans))
- (effects-squelch-channel (* gate-amount gate-amount) gate-size (selected-sound) (selected-channel) omit-silence))))
-
- (lambda (w context info)
- (help-dialog "Gate"
- "Move the slider to change the gate intensity. Higher values gate more of the sound."))
-
- (lambda (w c i)
- (set! gate-amount initial-gate-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* gate-amount 1000)))))
-
- (lambda ()
- (pair? (sounds)))))
-
- (set! sliders
- (add-sliders gate-dialog
- (list (list "gate" 0.0 initial-gate-amount 0.1
- (lambda (w context info)
- (set! gate-amount (/ (.value info) 1000.0)))
- 1000))))
- ;; now add a toggle button setting omit-silence
- ;; (need to use XtParent here because the containing RowColumn widget is
- ;; hidden in add-sliders -- perhaps it should be returned in the slider list)
-
- (let* ((s1 (XmStringCreateLocalized "Omit silence"))
- (toggle
- (XtCreateManagedWidget "Omit silence" xmToggleButtonWidgetClass (XtParent (car sliders))
- (list XmNselectColor *selection-color*
- XmNbackground *basic-color*
- XmNvalue (if omit-silence 1 0)
- XmNlabelString s1))))
- (XmStringFree s1)
- (XtAddCallback toggle XmNvalueChangedCallback (lambda (w c i)
- (set! omit-silence (.set i)))))))
- (activate-dialog gate-dialog))
+ (let ((gate-amount 0.01))
+
+ (define post-gate-dialog
+ (let ((gate-label "Gate")
+ (gate-dialog #f)
+ (gate-size 128)
+ (omit-silence #f))
+ (lambda ()
+ (unless (Widget? gate-dialog)
+ ;; if gate-dialog doesn't exist, create it
+ (let ((initial-gate-amount 0.01)
+ (sliders ()))
+ (set! gate-dialog
+ (make-effect-dialog
+ gate-label
+
+ (lambda (w context info)
+ (let ((snc (sync)))
+ (if (> snc 0)
+ (apply map
+ (lambda (snd chn)
+ (if (= (sync snd) snc)
+ (effects-squelch-channel (* gate-amount gate-amount) gate-size snd chn omit-silence)))
+ (all-chans))
+ (effects-squelch-channel (* gate-amount gate-amount) gate-size (selected-sound) (selected-channel) omit-silence))))
+
+ (lambda (w context info)
+ (help-dialog "Gate"
+ "Move the slider to change the gate intensity. Higher values gate more of the sound."))
+
+ (lambda (w c i)
+ (set! gate-amount initial-gate-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* gate-amount 1000)))))
+
+ (lambda ()
+ (pair? (sounds)))))
+
+ (set! sliders
+ (add-sliders gate-dialog
+ (list (list "gate" 0.0 initial-gate-amount 0.1
+ (lambda (w context info)
+ (set! gate-amount (/ (.value info) 1000.0)))
+ 1000))))
+ ;; now add a toggle button setting omit-silence
+ ;; (need to use XtParent here because the containing RowColumn widget is
+ ;; hidden in add-sliders -- perhaps it should be returned in the slider list)
+
+ (let* ((s1 (XmStringCreateLocalized "Omit silence"))
+ (toggle
+ (XtCreateManagedWidget "Omit silence" xmToggleButtonWidgetClass (XtParent (car sliders))
+ (list XmNselectColor *selection-color*
+ XmNbackground *basic-color*
+ XmNvalue (if omit-silence 1 0)
+ XmNlabelString s1))))
+ (XmStringFree s1)
+ (XtAddCallback toggle XmNvalueChangedCallback (lambda (w c i)
+ (set! omit-silence (.set i)))))))
+ (activate-dialog gate-dialog))))
(let ((child (XtCreateManagedWidget "Gate" xmPushButtonWidgetClass amp-menu
(list XmNbackground *basic-color*))))
@@ -421,8 +414,7 @@
(post-gate-dialog)))
(set! amp-menu-list (cons (lambda ()
- (let ((new-label (format #f "Gate (~1,4F)" gate-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Gate (~1,4F)" gate-amount)))
amp-menu-list))))
)
@@ -455,7 +447,7 @@
(lambda* (scaler secs input-samps-1 beg dur snd chn)
(let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
(del (make-delay (round (* secs (srate snd))))))
- (if (and (not input-samps-1) (not dur))
+ (if (not (or input-samps-1 dur))
(map-channel (lambda (inval)
(+ inval
(delay del
@@ -499,70 +491,71 @@
;;; -------- Echo (controlled by delay-time and echo-amount)
(let ((delay-time .5) ; i.e. delay between echoes
- (echo-amount .2)
- (echo-label "Echo")
- (echo-dialog #f)
- (echo-target 'sound)
- (echo-truncate #t))
-
- (define (post-echo-dialog)
- (if (not (Widget? echo-dialog))
- ;; if echo-dialog doesn't exist, create it
- (let ((initial-delay-time 0.5)
- (initial-echo-amount 0.2)
- (sliders ()))
- (set! echo-dialog
- (make-effect-dialog
- echo-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (cutoff)
- (let ((del (make-delay (round (* delay-time (srate)))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (* echo-amount (+ (tap del) (* (env genv) inval))))))))
- echo-target
- (lambda (target input-samps)
- (format #f "effects-echo ~A ~A ~A"
- (and (not (eq? target 'sound)) input-samps)
- delay-time echo-amount))
- (and (not echo-truncate)
- (* 4 delay-time))))
-
- (lambda (w context info)
- (help-dialog "Echo"
- "The sliders change the delay time and echo amount."))
-
- (lambda (w c i)
- (set! delay-time initial-delay-time)
- (XtSetValues (car sliders) (list XmNvalue (floor (* delay-time 100))))
- (set! echo-amount initial-echo-amount)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* echo-amount 100)))))
-
- (lambda ()
- (effect-target-ok echo-target))))
-
- (set! sliders
- (add-sliders echo-dialog
- (list (list "delay time" 0.0 initial-delay-time 2.0
- (lambda (w context info)
- (set! delay-time (/ (.value info) 100.0)))
- 100)
- (list "echo amount" 0.0 initial-echo-amount 1.0
- (lambda (w context info)
- (set! echo-amount (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! echo-target target)
- (XtSetSensitive (XmMessageBoxGetChild echo-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- (lambda (truncate)
- (set! echo-truncate truncate)))))
-
- (activate-dialog echo-dialog))
+ (echo-amount .2))
+
+ (define post-echo-dialog
+ (let ((echo-label "Echo")
+ (echo-dialog #f)
+ (echo-target 'sound)
+ (echo-truncate #t))
+ (lambda ()
+ (unless (Widget? echo-dialog)
+ ;; if echo-dialog doesn't exist, create it
+ (let ((initial-delay-time 0.5)
+ (initial-echo-amount 0.2)
+ (sliders ()))
+ (set! echo-dialog
+ (make-effect-dialog
+ echo-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (cutoff)
+ (let ((del (make-delay (round (* delay-time (srate)))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (* echo-amount (+ (tap del) (* (env genv) inval))))))))
+ echo-target
+ (lambda (target input-samps)
+ (format #f "effects-echo ~A ~A ~A"
+ (and (not (eq? target 'sound)) input-samps)
+ delay-time echo-amount))
+ (and (not echo-truncate)
+ (* 4 delay-time))))
+
+ (lambda (w context info)
+ (help-dialog "Echo"
+ "The sliders change the delay time and echo amount."))
+
+ (lambda (w c i)
+ (set! delay-time initial-delay-time)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* delay-time 100))))
+ (set! echo-amount initial-echo-amount)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* echo-amount 100)))))
+
+ (lambda ()
+ (effect-target-ok echo-target))))
+
+ (set! sliders
+ (add-sliders echo-dialog
+ (list (list "delay time" 0.0 initial-delay-time 2.0
+ (lambda (w context info)
+ (set! delay-time (/ (.value info) 100.0)))
+ 100)
+ (list "echo amount" 0.0 initial-echo-amount 1.0
+ (lambda (w context info)
+ (set! echo-amount (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! echo-target target)
+ (XtSetSensitive (XmMessageBoxGetChild echo-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ (lambda (truncate)
+ (set! echo-truncate truncate)))))
+
+ (activate-dialog echo-dialog))))
(let ((child (XtCreateManagedWidget "Echo" xmPushButtonWidgetClass delay-menu
(list XmNbackground *basic-color*))))
@@ -571,83 +564,83 @@
(post-echo-dialog)))
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Echo (~1,2F ~1,2F)" delay-time echo-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Echo (~1,2F ~1,2F)" delay-time echo-amount)))
delay-menu-list))))
;;; -------- Filtered echo
(let ((flecho-scaler 0.5)
- (flecho-delay 0.9)
- (flecho-label "Filtered echo")
- (flecho-dialog #f)
- (flecho-target 'sound)
- (flecho-truncate #t))
-
- (define flecho-1
- (lambda (scaler secs cutoff)
- (let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
- (del (make-delay (round (* secs (srate)))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (fir-filter flt (* scaler (+ (tap del) (* (env genv) inval))))))))))
-
- (define (post-flecho-dialog)
- (if (not (Widget? flecho-dialog))
- ;; if flecho-dialog doesn't exist, create it
- (let ((initial-flecho-scaler 0.5)
- (initial-flecho-delay 0.9)
- (sliders ()))
- (set! flecho-dialog
- (make-effect-dialog
- flecho-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (input-samps)
- (flecho-1 flecho-scaler flecho-delay input-samps))
- flecho-target
- (lambda (target input-samps)
- (format #f "effects-flecho-1 ~A ~A ~A"
- flecho-scaler flecho-delay
- (and (not (eq? target 'sound)) input-samps)))
- (and (not flecho-truncate)
- (* 4 flecho-delay))))
-
- (lambda (w context info)
- (help-dialog "Filtered echo"
- "Move the sliders to set the filter scaler and the delay time in seconds."))
-
- (lambda (w c i)
- (set! flecho-scaler initial-flecho-scaler)
- (XtSetValues (sliders 0) (list XmNvalue (floor (* flecho-scaler 100))))
- (set! flecho-delay initial-flecho-delay)
- (XtSetValues (sliders 1) (list XmNvalue (floor (* flecho-delay 100)))))
-
- (lambda ()
- (effect-target-ok flecho-target))))
-
- (set! sliders
- (add-sliders flecho-dialog
- (list (list "filter scaler" 0.0 initial-flecho-scaler 1.0
- (lambda (w context info)
- (set! flecho-scaler (/ (.value info) 100.0)))
- 100)
- (list "delay time (secs)" 0.0 initial-flecho-delay 3.0
- (lambda (w context info)
- (set! flecho-delay (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! flecho-target target)
- (XtSetSensitive (XmMessageBoxGetChild flecho-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- (lambda (truncate)
- (set! flecho-truncate truncate)))))
-
- (activate-dialog flecho-dialog))
+ (flecho-delay 0.9))
+
+ (define post-flecho-dialog
+ (let ((flecho-label "Filtered echo")
+ (flecho-dialog #f)
+ (flecho-target 'sound)
+ (flecho-truncate #t))
+ (lambda ()
+ (define flecho-1
+ (lambda (scaler secs cutoff)
+ (let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
+ (del (make-delay (round (* secs (srate)))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (fir-filter flt (* scaler (+ (tap del) (* (env genv) inval))))))))))
+
+ (unless (Widget? flecho-dialog)
+ ;; if flecho-dialog doesn't exist, create it
+ (let ((initial-flecho-scaler 0.5)
+ (initial-flecho-delay 0.9)
+ (sliders ()))
+ (set! flecho-dialog
+ (make-effect-dialog
+ flecho-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (input-samps)
+ (flecho-1 flecho-scaler flecho-delay input-samps))
+ flecho-target
+ (lambda (target input-samps)
+ (format #f "effects-flecho-1 ~A ~A ~A"
+ flecho-scaler flecho-delay
+ (and (not (eq? target 'sound)) input-samps)))
+ (and (not flecho-truncate)
+ (* 4 flecho-delay))))
+
+ (lambda (w context info)
+ (help-dialog "Filtered echo"
+ "Move the sliders to set the filter scaler and the delay time in seconds."))
+
+ (lambda (w c i)
+ (set! flecho-scaler initial-flecho-scaler)
+ (XtSetValues (sliders 0) (list XmNvalue (floor (* flecho-scaler 100))))
+ (set! flecho-delay initial-flecho-delay)
+ (XtSetValues (sliders 1) (list XmNvalue (floor (* flecho-delay 100)))))
+
+ (lambda ()
+ (effect-target-ok flecho-target))))
+
+ (set! sliders
+ (add-sliders flecho-dialog
+ (list (list "filter scaler" 0.0 initial-flecho-scaler 1.0
+ (lambda (w context info)
+ (set! flecho-scaler (/ (.value info) 100.0)))
+ 100)
+ (list "delay time (secs)" 0.0 initial-flecho-delay 3.0
+ (lambda (w context info)
+ (set! flecho-delay (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! flecho-target target)
+ (XtSetSensitive (XmMessageBoxGetChild flecho-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ (lambda (truncate)
+ (set! flecho-truncate truncate)))))
+
+ (activate-dialog flecho-dialog))))
(let ((child (XtCreateManagedWidget "Filtered echo" xmPushButtonWidgetClass delay-menu
(list XmNbackground *basic-color*))))
@@ -656,8 +649,7 @@
(post-flecho-dialog)))
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Filtered echo (~1,2F ~1,2F)" flecho-scaler flecho-delay)))
- (change-label child new-label)))
+ (change-label child (format #f "Filtered echo (~1,2F ~1,2F)" flecho-scaler flecho-delay)))
delay-menu-list))))
@@ -667,91 +659,92 @@
(let ((zecho-scaler 0.5)
(zecho-delay 0.75)
(zecho-freq 6)
- (zecho-amp 10.0)
- (zecho-label "Modulated echo")
- (zecho-dialog #f)
- (zecho-target 'sound)
- (zecho-truncate #t))
-
- (define zecho-1
- (lambda (scaler secs frq amp cutoff)
- (let* ((os (make-oscil frq))
- (len (round (* secs (srate))))
- (del (make-delay len :max-size (round (+ len amp 1))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (* scaler (+ (tap del) (* (env genv) inval)))
- (* amp (oscil os))))))))
-
- (define (post-zecho-dialog)
- (if (not (Widget? zecho-dialog))
- ;; if zecho-dialog doesn't exist, create it
- (let ((initial-zecho-scaler 0.5)
- (initial-zecho-delay 0.75)
- (initial-zecho-freq 6)
- (initial-zecho-amp 10.0)
- (sliders ()))
- (set! zecho-dialog
- (make-effect-dialog
- zecho-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (input-samps)
- (zecho-1 zecho-scaler zecho-delay zecho-freq zecho-amp input-samps))
- zecho-target
- (lambda (target input-samps)
- (format #f "effects-zecho-1 ~A ~A ~A ~A ~A"
- zecho-scaler zecho-delay zecho-freq zecho-amp
- (and (not (eq? target 'sound)) input-samps)))
- (and (not zecho-truncate)
- (* 4 zecho-delay))))
-
- (lambda (w context info)
- (help-dialog "Modulated echo"
- "Move the sliders to set the echo scaler,
+ (zecho-amp 10.0))
+
+ (define post-zecho-dialog
+ (let ((zecho-label "Modulated echo")
+ (zecho-dialog #f)
+ (zecho-target 'sound)
+ (zecho-truncate #t))
+ (lambda ()
+ (define zecho-1
+ (lambda (scaler secs frq amp cutoff)
+ (let* ((os (make-oscil frq))
+ (len (round (* secs (srate))))
+ (del (make-delay len :max-size (round (+ len amp 1))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (* scaler (+ (tap del) (* (env genv) inval)))
+ (* amp (oscil os))))))))
+
+ (unless (Widget? zecho-dialog)
+ ;; if zecho-dialog doesn't exist, create it
+ (let ((initial-zecho-scaler 0.5)
+ (initial-zecho-delay 0.75)
+ (initial-zecho-freq 6)
+ (initial-zecho-amp 10.0)
+ (sliders ()))
+ (set! zecho-dialog
+ (make-effect-dialog
+ zecho-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (input-samps)
+ (zecho-1 zecho-scaler zecho-delay zecho-freq zecho-amp input-samps))
+ zecho-target
+ (lambda (target input-samps)
+ (format #f "effects-zecho-1 ~A ~A ~A ~A ~A"
+ zecho-scaler zecho-delay zecho-freq zecho-amp
+ (and (not (eq? target 'sound)) input-samps)))
+ (and (not zecho-truncate)
+ (* 4 zecho-delay))))
+
+ (lambda (w context info)
+ (help-dialog "Modulated echo"
+ "Move the sliders to set the echo scaler,
the delay time in seconds, the modulation frequency, and the echo amplitude."))
-
- (lambda (w c i)
- (set! zecho-scaler initial-zecho-scaler)
- (XtSetValues (sliders 0) (list XmNvalue (floor (* zecho-scaler 100))))
- (set! zecho-delay initial-zecho-delay)
- (XtSetValues (sliders 1) (list XmNvalue (floor (* zecho-delay 100))))
- (set! zecho-freq initial-zecho-freq)
- (XtSetValues (sliders 2) (list XmNvalue (floor (* zecho-freq 100))))
- (set! zecho-amp initial-zecho-amp)
- (XtSetValues (sliders 3) (list XmNvalue (floor (* zecho-amp 100)))))
-
- (lambda ()
- (effect-target-ok zecho-target))))
-
- (set! sliders
- (add-sliders zecho-dialog
- (list (list "echo scaler" 0.0 initial-zecho-scaler 1.0
- (lambda (w context info)
- (set! zecho-scaler (/ (.value info) 100.0)))
- 100)
- (list "delay time (secs)" 0.0 initial-zecho-delay 3.0
- (lambda (w context info)
- (set! zecho-delay (/ (.value info) 100.0)))
- 100)
- (list "modulation frequency" 0.0 initial-zecho-freq 100.0
- (lambda (w context info)
- (set! zecho-freq (/ (.value info) 100.0)))
- 100)
- (list "modulation amplitude" 0.0 initial-zecho-amp 100.0
- (lambda (w context info)
- (set! zecho-amp (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! zecho-target target)
- (XtSetSensitive (XmMessageBoxGetChild zecho-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- (lambda (truncate)
- (set! zecho-truncate truncate)))))
- (activate-dialog zecho-dialog))
+
+ (lambda (w c i)
+ (set! zecho-scaler initial-zecho-scaler)
+ (XtSetValues (sliders 0) (list XmNvalue (floor (* zecho-scaler 100))))
+ (set! zecho-delay initial-zecho-delay)
+ (XtSetValues (sliders 1) (list XmNvalue (floor (* zecho-delay 100))))
+ (set! zecho-freq initial-zecho-freq)
+ (XtSetValues (sliders 2) (list XmNvalue (floor (* zecho-freq 100))))
+ (set! zecho-amp initial-zecho-amp)
+ (XtSetValues (sliders 3) (list XmNvalue (floor (* zecho-amp 100)))))
+
+ (lambda ()
+ (effect-target-ok zecho-target))))
+
+ (set! sliders
+ (add-sliders zecho-dialog
+ (list (list "echo scaler" 0.0 initial-zecho-scaler 1.0
+ (lambda (w context info)
+ (set! zecho-scaler (/ (.value info) 100.0)))
+ 100)
+ (list "delay time (secs)" 0.0 initial-zecho-delay 3.0
+ (lambda (w context info)
+ (set! zecho-delay (/ (.value info) 100.0)))
+ 100)
+ (list "modulation frequency" 0.0 initial-zecho-freq 100.0
+ (lambda (w context info)
+ (set! zecho-freq (/ (.value info) 100.0)))
+ 100)
+ (list "modulation amplitude" 0.0 initial-zecho-amp 100.0
+ (lambda (w context info)
+ (set! zecho-amp (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! zecho-target target)
+ (XtSetSensitive (XmMessageBoxGetChild zecho-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ (lambda (truncate)
+ (set! zecho-truncate truncate)))))
+ (activate-dialog zecho-dialog))))
(let ((child (XtCreateManagedWidget "Modulated echo" xmPushButtonWidgetClass delay-menu
(list XmNbackground *basic-color*))))
@@ -760,9 +753,8 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-zecho-dialog)))
(set! delay-menu-list (cons (lambda ()
- (let ((new-label (format #f "Modulated echo (~1,2F ~1,2F ~1,2F ~1,2F)"
- zecho-scaler zecho-delay zecho-freq zecho-amp)))
- (change-label child new-label)))
+ (change-label child (format #f "Modulated echo (~1,2F ~1,2F ~1,2F ~1,2F)"
+ zecho-scaler zecho-delay zecho-freq zecho-amp)))
delay-menu-list))))
)
@@ -842,62 +834,63 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
;;; -------- Butterworth band-pass filter
(let ((band-pass-freq 1000)
- (band-pass-bw 100)
- (band-pass-label "Band-pass filter")
- (band-pass-dialog #f)
- (band-pass-target 'sound))
-
- (define (post-band-pass-dialog)
- (if (not (Widget? band-pass-dialog))
- ;; if band-pass-dialog doesn't exist, create it
- (let ((initial-band-pass-freq 1000)
- (initial-band-pass-bw 100)
- (sliders ()))
- (set! band-pass-dialog
- (make-effect-dialog
- band-pass-label
-
- (lambda (w context info)
- (let ((flt (make-butter-band-pass band-pass-freq band-pass-bw)))
- (if (eq? band-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bbp ~A ~A 0 #f" band-pass-freq band-pass-bw))
- (if (eq? band-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bbp ~A ~A ~A ~A" band-pass-freq band-pass-bw bg nd)))))))
- (lambda (w context info)
- (help-dialog "Band-pass filter"
- "Butterworth band-pass filter. Move the sliders to change the center frequency and bandwidth."))
-
- (lambda (w c i)
- (set! band-pass-freq initial-band-pass-freq)
- (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 band-pass-freq 22050)))
- (set! band-pass-bw initial-band-pass-bw)
- (XtSetValues (cadr sliders) (list XmNvalue (floor band-pass-bw))))
-
- (lambda ()
- (effect-target-ok band-pass-target))))
-
- (set! sliders
- (add-sliders band-pass-dialog
- (list (list "center frequency" 20 initial-band-pass-freq 22050
- (lambda (w context info)
- (set! band-pass-freq (scale-linear->log 20 (.value info) 22050)))
- 1 'log)
- (list "bandwidth" 0 initial-band-pass-bw 1000
- (lambda (w context info)
- (set! band-pass-bw (.value info)))
- 1))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! band-pass-target target)
- (XtSetSensitive (XmMessageBoxGetChild band-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog band-pass-dialog))
+ (band-pass-bw 100))
+
+ (define post-band-pass-dialog
+ (let ((band-pass-label "Band-pass filter")
+ (band-pass-dialog #f)
+ (band-pass-target 'sound))
+ (lambda ()
+ (unless (Widget? band-pass-dialog)
+ ;; if band-pass-dialog doesn't exist, create it
+ (let ((initial-band-pass-freq 1000)
+ (initial-band-pass-bw 100)
+ (sliders ()))
+ (set! band-pass-dialog
+ (make-effect-dialog
+ band-pass-label
+
+ (lambda (w context info)
+ (let ((flt (make-butter-band-pass band-pass-freq band-pass-bw)))
+ (if (eq? band-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bbp ~A ~A 0 #f" band-pass-freq band-pass-bw))
+ (if (eq? band-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bbp ~A ~A ~A ~A" band-pass-freq band-pass-bw bg nd)))))))
+ (lambda (w context info)
+ (help-dialog "Band-pass filter"
+ "Butterworth band-pass filter. Move the sliders to change the center frequency and bandwidth."))
+
+ (lambda (w c i)
+ (set! band-pass-freq initial-band-pass-freq)
+ (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 band-pass-freq 22050)))
+ (set! band-pass-bw initial-band-pass-bw)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor band-pass-bw))))
+
+ (lambda ()
+ (effect-target-ok band-pass-target))))
+
+ (set! sliders
+ (add-sliders band-pass-dialog
+ (list (list "center frequency" 20 initial-band-pass-freq 22050
+ (lambda (w context info)
+ (set! band-pass-freq (scale-linear->log 20 (.value info) 22050)))
+ 1 'log)
+ (list "bandwidth" 0 initial-band-pass-bw 1000
+ (lambda (w context info)
+ (set! band-pass-bw (.value info)))
+ 1))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! band-pass-target target)
+ (XtSetSensitive (XmMessageBoxGetChild band-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog band-pass-dialog))))
(let ((child (XtCreateManagedWidget "Band-pass filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -906,69 +899,69 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-band-pass-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Band-pass filter (~,2F ~D" band-pass-freq band-pass-bw)))
- (change-label child new-label)))
+ (change-label child (format #f "Band-pass filter (~,2F ~D" band-pass-freq band-pass-bw)))
filter-menu-list))))
;;; -------- Butterworth band-reject (notch) filter
(let ((notch-freq 100)
- (notch-bw 100)
- (notch-label "Band-reject filter")
- (notch-dialog #f)
- (notch-target 'sound))
-
- (define (post-notch-dialog)
- (if (not (Widget? notch-dialog))
- ;; if notch-dialog doesn't exist, create it
- (let ((initial-notch-freq 100)
- (initial-notch-bw 100)
- (sliders ()))
- (set! notch-dialog
- (make-effect-dialog
- notch-label
-
- (lambda (w context info)
- (let ((flt (make-butter-band-reject notch-freq notch-bw)))
- (if (eq? notch-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bbr ~A ~A 0 #f" notch-freq notch-bw))
- (if (eq? notch-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bbr ~A ~A ~A ~A" notch-freq notch-bw bg nd)))))))
- (lambda (w context info)
- (help-dialog "Band-reject filter"
- "Butterworth band-reject filter. Move the sliders to change the center frequency and bandwidth."))
-
- (lambda (w c i)
- (set! notch-freq initial-notch-freq)
- (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 notch-freq 22050)))
- (set! notch-bw initial-notch-bw)
- (XtSetValues (cadr sliders) (list XmNvalue (floor notch-bw))))
-
- (lambda ()
- (effect-target-ok notch-target))))
-
- (set! sliders
- (add-sliders notch-dialog
- (list (list "center frequency" 20 initial-notch-freq 22050
- (lambda (w context info)
- (set! notch-freq (scale-linear->log 20 (.value info) 22050)))
- 1 'log)
- (list "bandwidth" 0 initial-notch-bw 1000
- (lambda (w context info)
- (set! notch-bw (.value info)))
- 1))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! notch-target target)
- (XtSetSensitive (XmMessageBoxGetChild notch-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog notch-dialog))
+ (notch-bw 100))
+
+ (define post-notch-dialog
+ (let ((notch-label "Band-reject filter")
+ (notch-dialog #f)
+ (notch-target 'sound))
+ (lambda ()
+ (unless (Widget? notch-dialog)
+ ;; if notch-dialog doesn't exist, create it
+ (let ((initial-notch-freq 100)
+ (initial-notch-bw 100)
+ (sliders ()))
+ (set! notch-dialog
+ (make-effect-dialog
+ notch-label
+
+ (lambda (w context info)
+ (let ((flt (make-butter-band-reject notch-freq notch-bw)))
+ (if (eq? notch-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bbr ~A ~A 0 #f" notch-freq notch-bw))
+ (if (eq? notch-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bbr ~A ~A ~A ~A" notch-freq notch-bw bg nd)))))))
+ (lambda (w context info)
+ (help-dialog "Band-reject filter"
+ "Butterworth band-reject filter. Move the sliders to change the center frequency and bandwidth."))
+
+ (lambda (w c i)
+ (set! notch-freq initial-notch-freq)
+ (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 notch-freq 22050)))
+ (set! notch-bw initial-notch-bw)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor notch-bw))))
+
+ (lambda ()
+ (effect-target-ok notch-target))))
+
+ (set! sliders
+ (add-sliders notch-dialog
+ (list (list "center frequency" 20 initial-notch-freq 22050
+ (lambda (w context info)
+ (set! notch-freq (scale-linear->log 20 (.value info) 22050)))
+ 1 'log)
+ (list "bandwidth" 0 initial-notch-bw 1000
+ (lambda (w context info)
+ (set! notch-bw (.value info)))
+ 1))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! notch-target target)
+ (XtSetSensitive (XmMessageBoxGetChild notch-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog notch-dialog))))
(let ((child (XtCreateManagedWidget "Band-reject filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -977,62 +970,62 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-notch-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Band-reject filter (~,2F ~D)" notch-freq notch-bw)))
- (change-label child new-label)))
+ (change-label child (format #f "Band-reject filter (~,2F ~D)" notch-freq notch-bw)))
filter-menu-list))))
;;; -------- Butterworth high-pass filter
- (let ((high-pass-freq 100)
- (high-pass-label "High-pass filter")
- (high-pass-dialog #f)
- (high-pass-target 'sound))
-
- (define (post-high-pass-dialog)
- (if (not (Widget? high-pass-dialog))
- ;; if high-pass-dialog doesn't exist, create it
- (let ((initial-high-pass-freq 100)
- (sliders ()))
- (set! high-pass-dialog
- (make-effect-dialog
- high-pass-label
-
- (lambda (w context info)
- (let ((flt (make-butter-high-pass high-pass-freq)))
- (if (eq? high-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-bhp ~A 0 #f" high-pass-freq))
- (if (eq? high-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-bhp ~A ~A ~A" high-pass-freq bg nd)))))))
-
- (lambda (w context info)
- (help-dialog "High-pass filter"
- "Butterworth high-pass filter. Move the slider to change the high-pass cutoff frequency."))
-
- (lambda (w c i)
- (set! high-pass-freq initial-high-pass-freq)
- (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 high-pass-freq 22050))))
-
- (lambda ()
- (effect-target-ok high-pass-target))))
-
- (set! sliders
- (add-sliders high-pass-dialog
- (list (list "high-pass cutoff frequency" 20 initial-high-pass-freq 22050
- (lambda (w context info)
- (set! high-pass-freq (scale-linear->log 20 (.value info) 22050)))
- 1 'log))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! high-pass-target target)
- (XtSetSensitive (XmMessageBoxGetChild high-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog high-pass-dialog))
+ (let ((high-pass-freq 100))
+
+ (define post-high-pass-dialog
+ (let ((high-pass-label "High-pass filter")
+ (high-pass-dialog #f)
+ (high-pass-target 'sound))
+ (lambda ()
+ (unless (Widget? high-pass-dialog)
+ ;; if high-pass-dialog doesn't exist, create it
+ (let ((initial-high-pass-freq 100)
+ (sliders ()))
+ (set! high-pass-dialog
+ (make-effect-dialog
+ high-pass-label
+
+ (lambda (w context info)
+ (let ((flt (make-butter-high-pass high-pass-freq)))
+ (if (eq? high-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-bhp ~A 0 #f" high-pass-freq))
+ (if (eq? high-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-bhp ~A ~A ~A" high-pass-freq bg nd)))))))
+
+ (lambda (w context info)
+ (help-dialog "High-pass filter"
+ "Butterworth high-pass filter. Move the slider to change the high-pass cutoff frequency."))
+
+ (lambda (w c i)
+ (set! high-pass-freq initial-high-pass-freq)
+ (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 high-pass-freq 22050))))
+
+ (lambda ()
+ (effect-target-ok high-pass-target))))
+
+ (set! sliders
+ (add-sliders high-pass-dialog
+ (list (list "high-pass cutoff frequency" 20 initial-high-pass-freq 22050
+ (lambda (w context info)
+ (set! high-pass-freq (scale-linear->log 20 (.value info) 22050)))
+ 1 'log))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! high-pass-target target)
+ (XtSetSensitive (XmMessageBoxGetChild high-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog high-pass-dialog))))
(let ((child (XtCreateManagedWidget "High-pass filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -1041,63 +1034,63 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-high-pass-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "High-pass filter (~,2F)" high-pass-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "High-pass filter (~,2F)" high-pass-freq)))
filter-menu-list))))
;;; -------- Butterworth low-pass filter
- (let ((low-pass-freq 1000)
- (low-pass-label "Low-pass filter")
- (low-pass-dialog #f)
- (low-pass-target 'sound))
-
- (define (post-low-pass-dialog)
- (if (not (Widget? low-pass-dialog))
- ;; if low-pass-dialog doesn't exist, create it
- (let ((initial-low-pass-freq 1000)
- (sliders ()))
- (set! low-pass-dialog
- (make-effect-dialog
- low-pass-label
-
- (lambda (w context info)
- (let ((flt (make-butter-low-pass low-pass-freq)))
- (if (eq? low-pass-target 'sound)
- (filter-sound flt #f #f #f #f (format #f "effects-blp ~A 0 #f" low-pass-freq))
- (if (eq? low-pass-target 'selection)
- (filter-selection flt)
- (let* ((ms (plausible-mark-samples))
- (bg (car ms))
- (nd (+ 1 (- (cadr ms) (car ms)))))
- (clm-channel flt bg nd #f #f #f #f
- (format #f "effects-blp ~A ~A ~A" low-pass-freq bg nd)))))))
-
- (lambda (w context info)
- (help-dialog "Low-pass filter"
- "Butterworth low-pass filter. Move the slider to change the low-pass cutoff frequency."))
-
- (lambda (w c i)
- (set! low-pass-freq initial-low-pass-freq)
- (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 low-pass-freq 22050))))
-
- (lambda ()
- (effect-target-ok low-pass-target))))
-
- (set! sliders
- (add-sliders low-pass-dialog
- (list (list "low-pass cutoff frequency" 20 initial-low-pass-freq 22050
- (lambda (w context info)
- (set! low-pass-freq (scale-linear->log 20 (.value info) 22050)))
- 1 'log))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! low-pass-target target)
- (XtSetSensitive (XmMessageBoxGetChild low-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog low-pass-dialog))
+ (let ((low-pass-freq 1000))
+
+ (define post-low-pass-dialog
+ (let ((low-pass-label "Low-pass filter")
+ (low-pass-dialog #f)
+ (low-pass-target 'sound))
+ (lambda ()
+ (unless (Widget? low-pass-dialog)
+ ;; if low-pass-dialog doesn't exist, create it
+ (let ((initial-low-pass-freq 1000)
+ (sliders ()))
+ (set! low-pass-dialog
+ (make-effect-dialog
+ low-pass-label
+
+ (lambda (w context info)
+ (let ((flt (make-butter-low-pass low-pass-freq)))
+ (if (eq? low-pass-target 'sound)
+ (filter-sound flt #f #f #f #f (format #f "effects-blp ~A 0 #f" low-pass-freq))
+ (if (eq? low-pass-target 'selection)
+ (filter-selection flt)
+ (let* ((ms (plausible-mark-samples))
+ (bg (car ms))
+ (nd (- (+ (cadr ms) 1) (car ms))))
+ (clm-channel flt bg nd #f #f #f #f
+ (format #f "effects-blp ~A ~A ~A" low-pass-freq bg nd)))))))
+
+ (lambda (w context info)
+ (help-dialog "Low-pass filter"
+ "Butterworth low-pass filter. Move the slider to change the low-pass cutoff frequency."))
+
+ (lambda (w c i)
+ (set! low-pass-freq initial-low-pass-freq)
+ (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 low-pass-freq 22050))))
+
+ (lambda ()
+ (effect-target-ok low-pass-target))))
+
+ (set! sliders
+ (add-sliders low-pass-dialog
+ (list (list "low-pass cutoff frequency" 20 initial-low-pass-freq 22050
+ (lambda (w context info)
+ (set! low-pass-freq (scale-linear->log 20 (.value info) 22050)))
+ 1 'log))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! low-pass-target target)
+ (XtSetSensitive (XmMessageBoxGetChild low-pass-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog low-pass-dialog))))
(let ((child (XtCreateManagedWidget "Low-pass filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -1106,8 +1099,7 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-low-pass-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Low-pass filter (~,2F)" low-pass-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "Low-pass filter (~,2F)" low-pass-freq)))
filter-menu-list))))
;;; more filters
@@ -1117,60 +1109,61 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
;;; (truncate)
(let ((comb-scaler 0.1)
- (comb-size 50)
- (comb-label "Comb filter")
- (comb-dialog #f)
- (comb-target 'sound))
-
- (define (post-comb-dialog)
- (if (not (Widget? comb-dialog))
- ;; if comb-dialog doesn't exist, create it
- (let ((initial-comb-scaler 0.1)
- (initial-comb-size 50)
- (sliders ()))
- (set! comb-dialog
- (make-effect-dialog
- comb-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (effects-comb-filter comb-scaler comb-size))
- comb-target
- (lambda (target samps)
- (format #f "effects-comb-filter ~A ~A" comb-scaler comb-size))
- #f))
-
- (lambda (w context info)
- (help-dialog "Comb filter"
- "Move the sliders to change the comb scaler and size."))
-
- (lambda (w c i)
- (set! comb-scaler initial-comb-scaler)
- (XtSetValues (car sliders) (list XmNvalue (floor (* comb-scaler 100))))
- (set! comb-size initial-comb-size)
- (XtSetValues (cadr sliders) (list XmNvalue (floor comb-size))))
-
- (lambda ()
- (effect-target-ok comb-target))))
-
- (set! sliders
- (add-sliders comb-dialog
- (list (list "scaler" 0.0 initial-comb-scaler 1.0
- (lambda (w context info)
- (set! comb-scaler (/ (.value info) 100.0)))
- 100)
- (list "size" 0 initial-comb-size 100
- (lambda (w context info)
- (set! comb-size (.value info)))
- 1))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! comb-target target)
- (XtSetSensitive (XmMessageBoxGetChild comb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog comb-dialog))
+ (comb-size 50))
+
+ (define post-comb-dialog
+ (let ((comb-label "Comb filter")
+ (comb-dialog #f)
+ (comb-target 'sound))
+ (lambda ()
+ (unless (Widget? comb-dialog)
+ ;; if comb-dialog doesn't exist, create it
+ (let ((initial-comb-scaler 0.1)
+ (initial-comb-size 50)
+ (sliders ()))
+ (set! comb-dialog
+ (make-effect-dialog
+ comb-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (effects-comb-filter comb-scaler comb-size))
+ comb-target
+ (lambda (target samps)
+ (format #f "effects-comb-filter ~A ~A" comb-scaler comb-size))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Comb filter"
+ "Move the sliders to change the comb scaler and size."))
+
+ (lambda (w c i)
+ (set! comb-scaler initial-comb-scaler)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* comb-scaler 100))))
+ (set! comb-size initial-comb-size)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor comb-size))))
+
+ (lambda ()
+ (effect-target-ok comb-target))))
+
+ (set! sliders
+ (add-sliders comb-dialog
+ (list (list "scaler" 0.0 initial-comb-scaler 1.0
+ (lambda (w context info)
+ (set! comb-scaler (/ (.value info) 100.0)))
+ 100)
+ (list "size" 0 initial-comb-size 100
+ (lambda (w context info)
+ (set! comb-size (.value info)))
+ 1))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! comb-target target)
+ (XtSetSensitive (XmMessageBoxGetChild comb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog comb-dialog))))
(let ((child (XtCreateManagedWidget "Comb filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -1180,8 +1173,7 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-comb-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Comb filter (~1,2F ~D)" comb-scaler comb-size)))
- (change-label child new-label)))
+ (change-label child (format #f "Comb filter (~1,2F ~D)" comb-scaler comb-size)))
filter-menu-list))))
;;; -------- Comb-chord filter
@@ -1192,93 +1184,94 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(new-comb-chord-size 60)
(new-comb-chord-amp 0.3)
(new-comb-chord-interval-one 0.75)
- (new-comb-chord-interval-two 1.20)
- (new-comb-chord-label "Comb chord filter")
- (new-comb-chord-dialog #f)
- (new-comb-chord-target 'sound))
-
- (define new-comb-chord
- (lambda (scaler size amp interval-one interval-two)
- ;; Comb chord filter: create chords by using filters at harmonically related sizes.
- (let ((cs (make-comb-bank (vector (make-comb scaler size)
- (make-comb scaler (* size interval-one))
- (make-comb scaler (* size interval-two))))))
- (lambda (x)
- (* amp (comb-bank cs x))))))
-
- (define (post-new-comb-chord-dialog)
- (if (not (Widget? new-comb-chord-dialog))
- ;; if new-comb-chord-dialog doesn't exist, create it
- (let ((initial-new-comb-chord-scaler 0.95)
- (initial-new-comb-chord-size 60)
- (initial-new-comb-chord-amp 0.3)
- (initial-new-comb-chord-interval-one 0.75)
- (initial-new-comb-chord-interval-two 1.20)
- (sliders ()))
- (set! new-comb-chord-dialog
- (make-effect-dialog
- new-comb-chord-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (new-comb-chord new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two))
- new-comb-chord-target
- (lambda (target samps)
- (format #f "effects-comb-chord ~A ~A ~A ~A ~A"
- new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two))
- #f))
-
- (lambda (w context info)
- (help-dialog "Comb chord filter"
- "Creates chords by using filters at harmonically related sizes. Move the sliders to set the comb chord parameters."))
-
- (lambda (w c i)
- (set! new-comb-chord-scaler initial-new-comb-chord-scaler)
- (XtSetValues (sliders 0) (list XmNvalue (floor (* new-comb-chord-scaler 100))))
- (set! new-comb-chord-size initial-new-comb-chord-size)
- (XtSetValues (sliders 1) (list XmNvalue new-comb-chord-size))
- (set! new-comb-chord-amp initial-new-comb-chord-amp)
- (XtSetValues (sliders 2) (list XmNvalue (floor (* new-comb-chord-amp 100))))
- (set! new-comb-chord-interval-one initial-new-comb-chord-interval-one)
- (XtSetValues (sliders 3) (list XmNvalue (floor (* new-comb-chord-interval-one 100))))
- (set! new-comb-chord-interval-two initial-new-comb-chord-interval-two)
- (XtSetValues (sliders 4) (list XmNvalue (floor (* new-comb-chord-interval-two 100)))))
-
- (lambda ()
- (effect-target-ok new-comb-chord-target))))
-
- (set! sliders
- (add-sliders new-comb-chord-dialog
- (list (list "chord scaler" 0.0 initial-new-comb-chord-scaler 1.0
- (lambda (w context info)
- (set! new-comb-chord-scaler (/ (.value info) 100.0)))
- 100)
- (list "chord size" 0 initial-new-comb-chord-size 100
- (lambda (w context info)
- (set! new-comb-chord-size (.value info)))
- 1)
- (list "amplitude" 0.0 initial-new-comb-chord-amp 1.0
- (lambda (w context info)
- (set! new-comb-chord-amp (/ (.value info) 100.0)))
- 100)
- (list "interval one" 0.0 initial-new-comb-chord-interval-one 2.0
- (lambda (w context info)
- (set! new-comb-chord-interval-one (/ (.value info) 100.0)))
- 100)
- (list "interval two" 0.0 initial-new-comb-chord-interval-two 2.0
- (lambda (w context info)
- (set! new-comb-chord-interval-two (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! new-comb-chord-target target)
- (XtSetSensitive (XmMessageBoxGetChild new-comb-chord-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog new-comb-chord-dialog))
+ (new-comb-chord-interval-two 1.20))
+
+ (define post-new-comb-chord-dialog
+ (let ((new-comb-chord-label "Comb chord filter")
+ (new-comb-chord-dialog #f)
+ (new-comb-chord-target 'sound))
+ (lambda ()
+ (define new-comb-chord
+ (lambda (scaler size amp interval-one interval-two)
+ ;; Comb chord filter: create chords by using filters at harmonically related sizes.
+ (let ((cs (make-comb-bank (vector (make-comb scaler size)
+ (make-comb scaler (* size interval-one))
+ (make-comb scaler (* size interval-two))))))
+ (lambda (x)
+ (* amp (comb-bank cs x))))))
+
+ (unless (Widget? new-comb-chord-dialog)
+ ;; if new-comb-chord-dialog doesn't exist, create it
+ (let ((initial-new-comb-chord-scaler 0.95)
+ (initial-new-comb-chord-size 60)
+ (initial-new-comb-chord-amp 0.3)
+ (initial-new-comb-chord-interval-one 0.75)
+ (initial-new-comb-chord-interval-two 1.20)
+ (sliders ()))
+ (set! new-comb-chord-dialog
+ (make-effect-dialog
+ new-comb-chord-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (new-comb-chord new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two))
+ new-comb-chord-target
+ (lambda (target samps)
+ (format #f "effects-comb-chord ~A ~A ~A ~A ~A"
+ new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Comb chord filter"
+ "Creates chords by using filters at harmonically related sizes. Move the sliders to set the comb chord parameters."))
+
+ (lambda (w c i)
+ (set! new-comb-chord-scaler initial-new-comb-chord-scaler)
+ (XtSetValues (sliders 0) (list XmNvalue (floor (* new-comb-chord-scaler 100))))
+ (set! new-comb-chord-size initial-new-comb-chord-size)
+ (XtSetValues (sliders 1) (list XmNvalue new-comb-chord-size))
+ (set! new-comb-chord-amp initial-new-comb-chord-amp)
+ (XtSetValues (sliders 2) (list XmNvalue (floor (* new-comb-chord-amp 100))))
+ (set! new-comb-chord-interval-one initial-new-comb-chord-interval-one)
+ (XtSetValues (sliders 3) (list XmNvalue (floor (* new-comb-chord-interval-one 100))))
+ (set! new-comb-chord-interval-two initial-new-comb-chord-interval-two)
+ (XtSetValues (sliders 4) (list XmNvalue (floor (* new-comb-chord-interval-two 100)))))
+
+ (lambda ()
+ (effect-target-ok new-comb-chord-target))))
+
+ (set! sliders
+ (add-sliders new-comb-chord-dialog
+ (list (list "chord scaler" 0.0 initial-new-comb-chord-scaler 1.0
+ (lambda (w context info)
+ (set! new-comb-chord-scaler (/ (.value info) 100.0)))
+ 100)
+ (list "chord size" 0 initial-new-comb-chord-size 100
+ (lambda (w context info)
+ (set! new-comb-chord-size (.value info)))
+ 1)
+ (list "amplitude" 0.0 initial-new-comb-chord-amp 1.0
+ (lambda (w context info)
+ (set! new-comb-chord-amp (/ (.value info) 100.0)))
+ 100)
+ (list "interval one" 0.0 initial-new-comb-chord-interval-one 2.0
+ (lambda (w context info)
+ (set! new-comb-chord-interval-one (/ (.value info) 100.0)))
+ 100)
+ (list "interval two" 0.0 initial-new-comb-chord-interval-two 2.0
+ (lambda (w context info)
+ (set! new-comb-chord-interval-two (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! new-comb-chord-target target)
+ (XtSetSensitive (XmMessageBoxGetChild new-comb-chord-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog new-comb-chord-dialog))))
(let ((child (XtCreateManagedWidget "Comb chord filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -1287,75 +1280,77 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(post-new-comb-chord-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Comb chord filter (~1,2F ~D ~1,2F ~1,2F ~1,2F)"
- new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
- new-comb-chord-interval-one new-comb-chord-interval-two)))
- (change-label child new-label)))
+ (change-label child
+ (format #f "Comb chord filter (~1,2F ~D ~1,2F ~1,2F ~1,2F)"
+ new-comb-chord-scaler new-comb-chord-size new-comb-chord-amp
+ new-comb-chord-interval-one new-comb-chord-interval-two)))
filter-menu-list))))
;;; -------- Moog filter
;;;
(let ((moog-cutoff-frequency 10000)
- (moog-resonance 0.5)
- (moog-label "Moog filter")
- (moog-dialog #f)
- (moog-target 'sound))
-
- (define (moog freq Q)
- (let ((gen (make-moog-filter freq Q)))
- (lambda (inval)
- (moog-filter gen inval))))
-
- (define (post-moog-dialog)
- (if (not (Widget? moog-dialog))
- ;; if moog-dialog doesn't exist, create it
- (let ((initial-moog-cutoff-frequency 10000)
- (initial-moog-resonance 0.5)
- (sliders ()))
- (set! moog-dialog
- (make-effect-dialog
- moog-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored) (moog moog-cutoff-frequency moog-resonance))
- moog-target
- (lambda (target samps)
- (format #f "effects-moog-filter ~A ~A" moog-cutoff-frequency moog-resonance))
- #f))
-
- (lambda (w context info)
- (help-dialog "Moog filter"
- "Moog-style 4-pole lowpass filter with 24db/oct rolloff and variable resonance.
+ (moog-resonance 0.5))
+
+ (define post-moog-dialog
+ (let ((moog-label "Moog filter")
+ (moog-dialog #f)
+ (moog-target 'sound))
+
+ (define (moog freq Q)
+ (let ((gen (make-moog-filter freq Q)))
+ (lambda (inval)
+ (moog-filter gen inval))))
+
+ (lambda ()
+ (unless (Widget? moog-dialog)
+ ;; if moog-dialog doesn't exist, create it
+ (let ((initial-moog-cutoff-frequency 10000)
+ (initial-moog-resonance 0.5)
+ (sliders ()))
+ (set! moog-dialog
+ (make-effect-dialog
+ moog-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored) (moog moog-cutoff-frequency moog-resonance))
+ moog-target
+ (lambda (target samps)
+ (format #f "effects-moog-filter ~A ~A" moog-cutoff-frequency moog-resonance))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Moog filter"
+ "Moog-style 4-pole lowpass filter with 24db/oct rolloff and variable resonance.
Move the sliders to set the filter cutoff frequency and resonance."))
-
- (lambda (w c i)
- (set! moog-cutoff-frequency initial-moog-cutoff-frequency)
- (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 moog-cutoff-frequency 22050)))
- (set! moog-resonance initial-moog-resonance)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* moog-resonance 100)))))
-
- (lambda ()
- (effect-target-ok moog-target))))
-
- (set! sliders
- (add-sliders moog-dialog
- (list (list "cutoff frequency" 20 initial-moog-cutoff-frequency 22050
- (lambda (w context info)
- (set! moog-cutoff-frequency (scale-linear->log 20 (.value info) 22050)))
- 1 'log)
- (list "resonance" 0.0 initial-moog-resonance 1.0
- (lambda (w context info)
- (set! moog-resonance (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! moog-target target)
- (XtSetSensitive (XmMessageBoxGetChild moog-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog moog-dialog))
+
+ (lambda (w c i)
+ (set! moog-cutoff-frequency initial-moog-cutoff-frequency)
+ (XtSetValues (car sliders) (list XmNvalue (scale-log->linear 20 moog-cutoff-frequency 22050)))
+ (set! moog-resonance initial-moog-resonance)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* moog-resonance 100)))))
+
+ (lambda ()
+ (effect-target-ok moog-target))))
+
+ (set! sliders
+ (add-sliders moog-dialog
+ (list (list "cutoff frequency" 20 initial-moog-cutoff-frequency 22050
+ (lambda (w context info)
+ (set! moog-cutoff-frequency (scale-linear->log 20 (.value info) 22050)))
+ 1 'log)
+ (list "resonance" 0.0 initial-moog-resonance 1.0
+ (lambda (w context info)
+ (set! moog-resonance (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! moog-target target)
+ (XtSetSensitive (XmMessageBoxGetChild moog-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog moog-dialog))))
(let ((child (XtCreateManagedWidget "Moog filter" xmPushButtonWidgetClass filter-menu
(list XmNbackground *basic-color*))))
@@ -1364,8 +1359,7 @@ Move the sliders to set the filter cutoff frequency and resonance."))
(post-moog-dialog)))
(set! filter-menu-list (cons (lambda ()
- (let ((new-label (format #f "Moog filter (~,2F ~1,2F)" moog-cutoff-frequency moog-resonance)))
- (change-label child new-label)))
+ (change-label child (format #f "Moog filter (~,2F ~1,2F)" moog-cutoff-frequency moog-resonance)))
filter-menu-list))))
)
@@ -1385,54 +1379,55 @@ Move the sliders to set the filter cutoff frequency and resonance."))
;;; -------- Sample rate conversion (resample)
;;;
- (let ((src-amount 0.0)
- (src-label "Sample rate conversion")
- (src-dialog #f)
- (src-target 'sound))
-
- (define (post-src-dialog)
- (if (not (Widget? src-dialog))
- ;; if src-dialog doesn't exist, create it
- (let ((initial-src-amount 0.0)
- (sliders ()))
- (set! src-dialog
- (make-effect-dialog
- src-label
-
- (lambda (w context info)
- (if (eq? src-target 'sound)
- (src-sound src-amount)
- (if (eq? src-target 'selection)
- (if (selection?)
- (src-selection src-amount)
- (snd-print ";no selection"))
- (snd-print "can't apply src between marks yet"))))
-
- (lambda (w context info)
- (help-dialog "Sample rate conversion"
- "Move the slider to change the sample rate.
+ (let ((src-amount 0.0))
+
+ (define post-src-dialog
+ (let ((src-label "Sample rate conversion")
+ (src-dialog #f)
+ (src-target 'sound))
+ (lambda ()
+ (unless (Widget? src-dialog)
+ ;; if src-dialog doesn't exist, create it
+ (let ((initial-src-amount 0.0)
+ (sliders ()))
+ (set! src-dialog
+ (make-effect-dialog
+ src-label
+
+ (lambda (w context info)
+ (if (eq? src-target 'sound)
+ (src-sound src-amount)
+ (if (eq? src-target 'selection)
+ (if (selection?)
+ (src-selection src-amount)
+ (snd-print ";no selection"))
+ (snd-print "can't apply src between marks yet"))))
+
+ (lambda (w context info)
+ (help-dialog "Sample rate conversion"
+ "Move the slider to change the sample rate.
Values greater than 1.0 speed up file play, negative values reverse it."))
-
- (lambda (w c i)
- (set! src-amount initial-src-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* src-amount 100)))))
-
- (lambda ()
- (effect-target-ok src-target))))
-
- (set! sliders
- (add-sliders src-dialog
- (list (list "sample rate" -2.0 initial-src-amount 2.0
- (lambda (w context info)
- (set! src-amount (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! src-target target)
- (XtSetSensitive (XmMessageBoxGetChild src-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
- (activate-dialog src-dialog))
-
+
+ (lambda (w c i)
+ (set! src-amount initial-src-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* src-amount 100)))))
+
+ (lambda ()
+ (effect-target-ok src-target))))
+
+ (set! sliders
+ (add-sliders src-dialog
+ (list (list "sample rate" -2.0 initial-src-amount 2.0
+ (lambda (w context info)
+ (set! src-amount (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! src-target target)
+ (XtSetSensitive (XmMessageBoxGetChild src-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+ (activate-dialog src-dialog))))
+
(let ((child (XtCreateManagedWidget "Sample rate scaling" xmPushButtonWidgetClass freq-menu
(list XmNbackground *basic-color*))))
(XtAddCallback child XmNactivateCallback
@@ -1440,8 +1435,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(post-src-dialog)))
(set! freq-menu-list (cons (lambda ()
- (let ((new-label (format #f "Sample rate scaling (~1,2F)" src-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Sample rate scaling (~1,2F)" src-amount)))
freq-menu-list))))
@@ -1449,93 +1443,94 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
;;;
(let ((time-scale 1.0)
- (hop-size 0.05)
- (segment-length 0.15)
- (ramp-scale 0.5)
- (pitch-scale 1.0)
- (expsrc-label "Time/pitch scaling")
- (expsrc-dialog #f)
- (expsrc-target 'sound))
-
- (define (post-expsrc-dialog)
- (if (not (Widget? expsrc-dialog))
- (let ((initial-time-scale 1.0)
- (initial-hop-size 0.05)
- (initial-segment-length 0.15)
- (initial-ramp-scale 0.5)
- (initial-pitch-scale 1.0)
- (sliders ()))
- (set! expsrc-dialog
- (make-effect-dialog
- expsrc-label
-
- (lambda (w context info)
- (let ((snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (speed-control snd) pitch-scale)
- (let ((new-time (* pitch-scale time-scale)))
- (if (not (= new-time 1.0))
- (begin
- (set! (expand-control? snd) #t)
- (set! (expand-control snd) new-time)
- (set! (expand-control-hop snd) hop-size)
- (set! (expand-control-length snd) segment-length)
- (set! (expand-control-ramp snd) ramp-scale))))
- (if (eq? expsrc-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? expsrc-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w context info)
- (help-dialog "Time/pitch scaling"
- "Move the sliders to change the time/pitch scaling parameters."))
-
- (lambda (w c i)
- (set! time-scale initial-time-scale)
- (XtSetValues (sliders 0) (list XmNvalue (floor (* time-scale 100))))
- (set! hop-size initial-hop-size)
- (XtSetValues (sliders 1) (list XmNvalue (floor (* hop-size 100))))
- (set! segment-length initial-segment-length)
- (XtSetValues (sliders 2) (list XmNvalue (floor (* segment-length 100))))
- (set! ramp-scale initial-ramp-scale)
- (XtSetValues (sliders 3) (list XmNvalue (floor (* ramp-scale 100))))
- (set! pitch-scale initial-pitch-scale)
- (XtSetValues (sliders 4) (list XmNvalue (floor (* pitch-scale 100)))))
-
- (lambda ()
- (effect-target-ok expsrc-target))))
-
- (set! sliders
- (add-sliders expsrc-dialog
- (list (list "time scale" 0.0 initial-time-scale 5.0
- (lambda (w context info)
- (set! time-scale (/ (.value info) 100.0)))
- 100)
- (list "hop size" 0.0 initial-hop-size 1.0
- (lambda (w context info)
- (set! hop-size (/ (.value info) 100.0)))
- 100)
- (list "segment length" 0.0 initial-segment-length 0.5
- (lambda (w context info)
- (set! segment-length (/ (.value info) 100.0)))
- 100)
- (list "ramp scale" 0.0 initial-ramp-scale 0.5
- (lambda (w context info)
- (set! ramp-scale (/ (.value info) 100.0)))
- 1000)
- (list "pitch scale" 0.0 initial-pitch-scale 5.0
- (lambda (w context info)
- (set! pitch-scale (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! expsrc-target target)
- (XtSetSensitive (XmMessageBoxGetChild expsrc-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog expsrc-dialog))
+ (pitch-scale 1.0))
+
+ (define post-expsrc-dialog
+ (let ((expsrc-label "Time/pitch scaling")
+ (expsrc-dialog #f)
+ (expsrc-target 'sound)
+ (hop-size 0.05)
+ (segment-length 0.15)
+ (ramp-scale 0.5))
+ (lambda ()
+ (unless (Widget? expsrc-dialog)
+ (let ((initial-time-scale 1.0)
+ (initial-hop-size 0.05)
+ (initial-segment-length 0.15)
+ (initial-ramp-scale 0.5)
+ (initial-pitch-scale 1.0)
+ (sliders ()))
+ (set! expsrc-dialog
+ (make-effect-dialog
+ expsrc-label
+
+ (lambda (w context info)
+ (let ((snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (speed-control snd) pitch-scale)
+ (let ((new-time (* pitch-scale time-scale)))
+ (if (not (= new-time 1.0))
+ (begin
+ (set! (expand-control? snd) #t)
+ (set! (expand-control snd) new-time)
+ (set! (expand-control-hop snd) hop-size)
+ (set! (expand-control-length snd) segment-length)
+ (set! (expand-control-ramp snd) ramp-scale))))
+ (if (eq? expsrc-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? expsrc-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w context info)
+ (help-dialog "Time/pitch scaling"
+ "Move the sliders to change the time/pitch scaling parameters."))
+
+ (lambda (w c i)
+ (set! time-scale initial-time-scale)
+ (XtSetValues (sliders 0) (list XmNvalue (floor (* time-scale 100))))
+ (set! hop-size initial-hop-size)
+ (XtSetValues (sliders 1) (list XmNvalue (floor (* hop-size 100))))
+ (set! segment-length initial-segment-length)
+ (XtSetValues (sliders 2) (list XmNvalue (floor (* segment-length 100))))
+ (set! ramp-scale initial-ramp-scale)
+ (XtSetValues (sliders 3) (list XmNvalue (floor (* ramp-scale 100))))
+ (set! pitch-scale initial-pitch-scale)
+ (XtSetValues (sliders 4) (list XmNvalue (floor (* pitch-scale 100)))))
+
+ (lambda ()
+ (effect-target-ok expsrc-target))))
+
+ (set! sliders
+ (add-sliders expsrc-dialog
+ (list (list "time scale" 0.0 initial-time-scale 5.0
+ (lambda (w context info)
+ (set! time-scale (/ (.value info) 100.0)))
+ 100)
+ (list "hop size" 0.0 initial-hop-size 1.0
+ (lambda (w context info)
+ (set! hop-size (/ (.value info) 100.0)))
+ 100)
+ (list "segment length" 0.0 initial-segment-length 0.5
+ (lambda (w context info)
+ (set! segment-length (/ (.value info) 100.0)))
+ 100)
+ (list "ramp scale" 0.0 initial-ramp-scale 0.5
+ (lambda (w context info)
+ (set! ramp-scale (/ (.value info) 100.0)))
+ 1000)
+ (list "pitch scale" 0.0 initial-pitch-scale 5.0
+ (lambda (w context info)
+ (set! pitch-scale (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! expsrc-target target)
+ (XtSetSensitive (XmMessageBoxGetChild expsrc-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog expsrc-dialog))))
(let ((child (XtCreateManagedWidget "Time/pitch scaling" xmPushButtonWidgetClass freq-menu
(list XmNbackground *basic-color*))))
@@ -1544,96 +1539,93 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(post-expsrc-dialog)))
(set! freq-menu-list (cons (lambda ()
- (let ((new-label (format #f "Time/pitch scaling (~1,2F ~1,2F)" time-scale pitch-scale)))
- (change-label child new-label)))
+ (change-label child (format #f "Time/pitch scaling (~1,2F ~1,2F)" time-scale pitch-scale)))
freq-menu-list))))
;;; -------- Time-varying sample rate conversion (resample)
;;; (KSM)
- (let ((src-timevar-scale 1.0)
- (src-timevar-label "Src-Timevar")
- (src-timevar-dialog #f)
- (src-timevar-target 'sound)
- (src-timevar-envelope #f))
-
- (define (scale-envelope e scl)
- (if (null? e)
- ()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
-
- (define (post-src-timevar-dialog)
- (if (not (Widget? src-timevar-dialog))
- ;; if src-timevar-dialog doesn't exist, create it
- (let ((initial-src-timevar-scale 1.0)
- (sliders ())
- (fr #f))
- (set! src-timevar-dialog
- (make-effect-dialog
- src-timevar-label
-
- (lambda (w context info)
- (let ((env (scale-envelope (xe-envelope src-timevar-envelope)
- src-timevar-scale)))
- (if (eq? src-timevar-target 'sound)
- (src-sound env)
- (if (eq? src-timevar-target 'selection)
- (if (selection-member? (selected-sound))
- (src-selection env)
- (display ";no selection"))
- (let ((pts (plausible-mark-samples)))
- (if pts
- (let* ((beg (car pts))
- (end (cadr pts))
- (len (- end beg)))
- (src-channel (make-env env :length len) beg len (selected-sound)))))))))
-
- (lambda (w context info)
- (help-dialog "Src-Timevar"
- "Move the slider to change the src-timevar scaling amount."))
-
- (lambda (w c i)
- (set! src-timevar-scale initial-src-timevar-scale)
- (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
- (XtSetValues (car sliders) (list XmNvalue (* src-timevar-scale 100))))
-
- (lambda ()
- (effect-target-ok src-timevar-target))))
-
- (set! sliders
- (add-sliders src-timevar-dialog
- (list (list "Resample factor" 0.0 initial-src-timevar-scale 10.0
- (lambda (w context info)
- (set! src-timevar-scale (/ (.value info) 100.0)))
- 100))))
- (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
- (list XmNheight 200
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget (sliders (- (length sliders) 1))
- XmNshadowThickness 4
- XmNshadowType XmSHADOW_ETCHED_OUT)))
-
- (let ((target-row (add-target (XtParent (XtParent (car sliders)))
- (lambda (target)
- (set! src-timevar-target target)
- (XtSetSensitive (XmMessageBoxGetChild src-timevar-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
+ (let ((src-timevar-scale 1.0))
+
+ (define post-src-timevar-dialog
+ (let ((src-timevar-label "Src-Timevar")
+ (src-timevar-dialog #f)
+ (src-timevar-target 'sound)
+ (src-timevar-envelope #f))
+ (lambda ()
+ (define (scale-envelope e scl)
+ (if (null? e)
+ ()
+ (append (list (car e) (* scl (cadr e)))
+ (scale-envelope (cddr e) scl))))
+
+ (if (Widget? src-timevar-dialog)
(activate-dialog src-timevar-dialog)
-
- (set! src-timevar-envelope (xe-create-enved "src-timevar" fr
- (list XmNheight 200)
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
- (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget target-row)))
-
- )
- (activate-dialog src-timevar-dialog)))
-
+ ;; if src-timevar-dialog doesn't exist, create it
+ (let ((initial-src-timevar-scale 1.0)
+ (sliders ())
+ (fr #f))
+ (set! src-timevar-dialog
+ (make-effect-dialog
+ src-timevar-label
+
+ (lambda (w context info)
+ (let ((env (scale-envelope (xe-envelope src-timevar-envelope)
+ src-timevar-scale)))
+ (if (eq? src-timevar-target 'sound)
+ (src-sound env)
+ (if (eq? src-timevar-target 'selection)
+ (if (selection-member? (selected-sound))
+ (src-selection env)
+ (display ";no selection"))
+ (let ((pts (plausible-mark-samples)))
+ (if pts
+ (let* ((beg (car pts))
+ (end (cadr pts))
+ (len (- end beg)))
+ (src-channel (make-env env :length len) beg len (selected-sound)))))))))
+
+ (lambda (w context info)
+ (help-dialog "Src-Timevar"
+ "Move the slider to change the src-timevar scaling amount."))
+
+ (lambda (w c i)
+ (set! src-timevar-scale initial-src-timevar-scale)
+ (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtSetValues (car sliders) (list XmNvalue (* src-timevar-scale 100))))
+
+ (lambda ()
+ (effect-target-ok src-timevar-target))))
+
+ (set! sliders
+ (add-sliders src-timevar-dialog
+ (list (list "Resample factor" 0.0 initial-src-timevar-scale 10.0
+ (lambda (w context info)
+ (set! src-timevar-scale (/ (.value info) 100.0)))
+ 100))))
+ (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
+ (list XmNheight 200
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget (sliders (- (length sliders) 1))
+ XmNshadowThickness 4
+ XmNshadowType XmSHADOW_ETCHED_OUT)))
+
+ (let ((target-row (add-target (XtParent (XtParent (car sliders)))
+ (lambda (target)
+ (set! src-timevar-target target)
+ (XtSetSensitive (XmMessageBoxGetChild src-timevar-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+ (activate-dialog src-timevar-dialog)
+
+ (set! src-timevar-envelope (xe-create-enved "src-timevar" fr
+ (list XmNheight 200)
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope src-timevar-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget target-row))))))))
(let ((child (XtCreateManagedWidget "Time-varying sample rate scaling" xmPushButtonWidgetClass freq-menu
(list XmNbackground *basic-color*))))
@@ -1642,8 +1634,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(post-src-timevar-dialog)))
(set! freq-menu-list (cons (lambda ()
- (let ((new-label "Time-varying sample rate scaling"))
- (change-label child new-label)))
+ (change-label child "Time-varying sample rate scaling"))
freq-menu-list))))
;--------------------------------------------------------------------------------
@@ -1691,85 +1682,85 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
;;;
(let ((am-effect-amount 100.0)
- (am-effect-label "Amplitude modulation")
- (am-effect-dialog #f)
(am-effect-target 'sound)
(am-effect-envelope #f))
- (define am-effect
- (lambda (freq)
- (let* ((os (make-oscil freq))
- (need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
- (e (and need-env (make-env (xe-envelope am-effect-envelope) :length (effect-framples am-effect-target)))))
- (if need-env
- (lambda (inval)
- (amplitude-modulate 1.0 inval (* (env e) (oscil os))))
- (lambda (inval)
- (amplitude-modulate 1.0 inval (oscil os)))))))
-
- (define (post-am-effect-dialog)
- (if (not (Widget? am-effect-dialog))
- ;; if am-effect-dialog doesn't exist, create it
- (let ((initial-am-effect-amount 100.0)
- (sliders ())
- (fr #f))
- (set! am-effect-dialog
- (make-effect-dialog
- am-effect-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (am-effect am-effect-amount))
- am-effect-target
- (lambda (target samps)
- (format #f "effects-am ~A ~A" am-effect-amount
- (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
- (e (and need-env (xe-envelope am-effect-envelope))))
- (and e (format #f "'~A" e)))))
- #f))
-
- (lambda (w context info)
- (help-dialog "Amplitude modulation"
- "Move the slider to change the modulation amount."))
-
- (lambda (w c i)
- (set! am-effect-amount initial-am-effect-amount)
- (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
- (XtSetValues (car sliders) (list XmNvalue (floor am-effect-amount))))
-
- (lambda ()
- (effect-target-ok am-effect-target))))
-
- (set! sliders
- (add-sliders am-effect-dialog
- (list (list "amplitude modulation" 0.0 initial-am-effect-amount 1000.0
- (lambda (w context info)
- (set! am-effect-amount (.value info)))
- 1))))
- (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
- (list XmNheight 200
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget (sliders (- (length sliders) 1))
- XmNshadowThickness 4
- XmNshadowType XmSHADOW_ETCHED_OUT)))
- (let ((target-row (add-target (XtParent (XtParent (car sliders)))
- (lambda (target)
- (set! am-effect-target target)
- (XtSetSensitive (XmMessageBoxGetChild am-effect-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
+ (define post-am-effect-dialog
+ (let ((am-effect-label "Amplitude modulation")
+ (am-effect-dialog #f))
+ (lambda ()
+ (define am-effect
+ (lambda (freq)
+ (let* ((os (make-oscil freq))
+ (need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (e (and need-env (make-env (xe-envelope am-effect-envelope) :length (effect-framples am-effect-target)))))
+ (if need-env
+ (lambda (inval)
+ (amplitude-modulate 1.0 inval (* (env e) (oscil os))))
+ (lambda (inval)
+ (amplitude-modulate 1.0 inval (oscil os)))))))
+
+ (if (Widget? am-effect-dialog)
(activate-dialog am-effect-dialog)
- (set! am-effect-envelope (xe-create-enved "am" fr
- (list XmNheight 200)
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
- (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget target-row)))
- )
- (activate-dialog am-effect-dialog)))
+ ;; if am-effect-dialog doesn't exist, create it
+ (let ((initial-am-effect-amount 100.0)
+ (sliders ())
+ (fr #f))
+ (set! am-effect-dialog
+ (make-effect-dialog
+ am-effect-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (am-effect am-effect-amount))
+ am-effect-target
+ (lambda (target samps)
+ (format #f "effects-am ~A ~A" am-effect-amount
+ (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (e (and need-env (xe-envelope am-effect-envelope))))
+ (and e (format #f "'~A" e)))))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Amplitude modulation"
+ "Move the slider to change the modulation amount."))
+
+ (lambda (w c i)
+ (set! am-effect-amount initial-am-effect-amount)
+ (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtSetValues (car sliders) (list XmNvalue (floor am-effect-amount))))
+
+ (lambda ()
+ (effect-target-ok am-effect-target))))
+
+ (set! sliders
+ (add-sliders am-effect-dialog
+ (list (list "amplitude modulation" 0.0 initial-am-effect-amount 1000.0
+ (lambda (w context info)
+ (set! am-effect-amount (.value info)))
+ 1))))
+ (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
+ (list XmNheight 200
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget (sliders (- (length sliders) 1))
+ XmNshadowThickness 4
+ XmNshadowType XmSHADOW_ETCHED_OUT)))
+ (let ((target-row (add-target (XtParent (XtParent (car sliders)))
+ (lambda (target)
+ (set! am-effect-target target)
+ (XtSetSensitive (XmMessageBoxGetChild am-effect-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog am-effect-dialog)
+ (set! am-effect-envelope (xe-create-enved "am" fr
+ (list XmNheight 200)
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget target-row))))))))
(let ((child (XtCreateManagedWidget "Amplitude modulation" xmPushButtonWidgetClass mod-menu
(list XmNbackground *basic-color*))))
@@ -1778,8 +1769,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(post-am-effect-dialog)))
(set! mod-menu-list (cons (lambda ()
- (let ((new-label (format #f "Amplitude modulation (~1,2F)" am-effect-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Amplitude modulation (~1,2F)" am-effect-amount)))
mod-menu-list))))
;;; -------- Ring modulation
@@ -1787,94 +1777,94 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(let ((rm-frequency 100)
(rm-radians 100)
- (rm-label "Ring modulation")
- (rm-dialog #f)
(rm-target 'sound)
(rm-envelope #f))
- (define rm-effect ; avoid collision with examp.scm
- (lambda (freq gliss-env)
- (let* ((os (make-oscil freq))
- (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0)))))
- (e (and need-env (make-env (xe-envelope rm-envelope) :length (effect-framples rm-target)))))
- (if need-env
- (lambda (inval)
- (* inval (env e) (oscil os)))
- (lambda (inval)
- (* inval (oscil os)))))))
-
- (define (post-rm-dialog)
- (if (not (Widget? rm-dialog))
- ;; if rm-dialog doesn't exist, create it
- (let ((initial-rm-frequency 100)
- (initial-rm-radians 100)
- (sliders ())
- (fr #f))
- (set! rm-dialog
- (make-effect-dialog
- rm-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (rm-effect rm-frequency (list 0 0 1 (hz->radians rm-radians))))
- rm-target
- (lambda (target samps)
- (format #f "effects-rm ~A ~A" rm-frequency
- (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
- (e (and need-env (xe-envelope rm-envelope))))
- (and e (format #f "'~A" e)))))
- #f))
-
- (lambda (w context info)
- (help-dialog "Ring modulation"
- "Move the slider to change the ring modulation parameters."))
-
- (lambda (w c i)
- (set! rm-frequency initial-rm-frequency)
- (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
- (XtSetValues (car sliders) (list XmNvalue rm-frequency))
- (set! rm-radians initial-rm-radians)
- (XtSetValues (cadr sliders) (list XmNvalue rm-radians)))
-
- (lambda ()
- (effect-target-ok rm-target))))
-
- (set! sliders
- (add-sliders rm-dialog
- (list
- (list "modulation frequency" 0 initial-rm-frequency 1000
- (lambda (w context info)
- (set! rm-frequency (.value info)))
- 1)
- (list "modulation radians" 0 initial-rm-radians 360
- (lambda (w context info)
- (set! rm-radians (.value info)))
- 1))))
- (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
- (list XmNheight 200
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget (sliders (- (length sliders) 1))
- XmNshadowThickness 4
- XmNshadowType XmSHADOW_ETCHED_OUT)))
- (let ((target-row (add-target (XtParent (XtParent (car sliders)))
- (lambda (target)
- (set! rm-target target)
- (XtSetSensitive (XmMessageBoxGetChild rm-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
+ (define post-rm-dialog
+ (let ((rm-label "Ring modulation")
+ (rm-dialog #f))
+ (lambda ()
+ (define rm-effect ; avoid collision with examp.scm
+ (lambda (freq gliss-env)
+ (let* ((os (make-oscil freq))
+ (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0)))))
+ (e (and need-env (make-env (xe-envelope rm-envelope) :length (effect-framples rm-target)))))
+ (if need-env
+ (lambda (inval)
+ (* inval (env e) (oscil os)))
+ (lambda (inval)
+ (* inval (oscil os)))))))
+
+ (if (Widget? rm-dialog)
(activate-dialog rm-dialog)
- (set! rm-envelope (xe-create-enved "rm frequency" fr
- (list XmNheight 200)
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
- (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget target-row)))
- )
- (activate-dialog rm-dialog)))
-
+ ;; if rm-dialog doesn't exist, create it
+ (let ((initial-rm-frequency 100)
+ (initial-rm-radians 100)
+ (sliders ())
+ (fr #f))
+ (set! rm-dialog
+ (make-effect-dialog
+ rm-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (rm-effect rm-frequency #f)) ;(list 0 0 1 (hz->radians rm-radians)) -- gliss-env is not implemented above
+ rm-target
+ (lambda (target samps)
+ (format #f "effects-rm ~A ~A" rm-frequency
+ (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
+ (e (and need-env (xe-envelope rm-envelope))))
+ (and e (format #f "'~A" e)))))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Ring modulation"
+ "Move the slider to change the ring modulation parameters."))
+
+ (lambda (w c i)
+ (set! rm-frequency initial-rm-frequency)
+ (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtSetValues (car sliders) (list XmNvalue rm-frequency))
+ (set! rm-radians initial-rm-radians)
+ (XtSetValues (cadr sliders) (list XmNvalue rm-radians)))
+
+ (lambda ()
+ (effect-target-ok rm-target))))
+
+ (set! sliders
+ (add-sliders rm-dialog
+ (list
+ (list "modulation frequency" 0 initial-rm-frequency 1000
+ (lambda (w context info)
+ (set! rm-frequency (.value info)))
+ 1)
+ (list "modulation radians" 0 initial-rm-radians 360
+ (lambda (w context info)
+ (set! rm-radians (.value info)))
+ 1))))
+ (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
+ (list XmNheight 200
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget (sliders (- (length sliders) 1))
+ XmNshadowThickness 4
+ XmNshadowType XmSHADOW_ETCHED_OUT)))
+ (let ((target-row (add-target (XtParent (XtParent (car sliders)))
+ (lambda (target)
+ (set! rm-target target)
+ (XtSetSensitive (XmMessageBoxGetChild rm-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog rm-dialog)
+ (set! rm-envelope (xe-create-enved "rm frequency" fr
+ (list XmNheight 200)
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))
+ (XtVaSetValues fr (list XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget target-row))))))))
+
(let ((child (XtCreateManagedWidget "Ring modulation" xmPushButtonWidgetClass mod-menu
(list XmNbackground *basic-color*))))
(XtAddCallback child XmNactivateCallback
@@ -1882,9 +1872,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(post-rm-dialog)))
(set! mod-menu-list (cons (lambda ()
- (let ((new-label (format #f "Ring modulation (~D ~D)"
- rm-frequency rm-radians)))
- (change-label child new-label)))
+ (change-label child (format #f "Ring modulation (~D ~D)" rm-frequency rm-radians)))
mod-menu-list))))
)
@@ -1950,76 +1938,77 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(let ((reverb-amount 0.1)
(reverb-filter 0.5)
- (reverb-feedback 1.09)
- (reverb-label "McNabb reverb")
- (reverb-dialog #f)
- (reverb-target 'sound))
+ (reverb-feedback 1.09))
;; add reverb-control-decay (with ramp?) and reverb-truncate
- (define (post-reverb-dialog)
- (if (not (Widget? reverb-dialog))
- ;; if reverb-dialog doesn't exist, create it
- (let ((initial-reverb-amount 0.1)
- (initial-reverb-filter 0.5)
- (initial-reverb-feedback 1.09)
- (sliders ()))
- (set! reverb-dialog
- (make-effect-dialog
- reverb-label
-
- (lambda (w context info)
- (let ((snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (reverb-control? snd) #t)
- (set! (reverb-control-scale snd) reverb-amount)
- (set! (reverb-control-lowpass snd) reverb-filter)
- (set! (reverb-control-feedback snd) reverb-feedback)
- (if (eq? reverb-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? reverb-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w context info)
- (help-dialog "McNabb reverb"
- "Reverberator from Michael McNabb.
+ (define post-reverb-dialog
+ (let ((reverb-label "McNabb reverb")
+ (reverb-dialog #f)
+ (reverb-target 'sound))
+ (lambda ()
+ (unless (Widget? reverb-dialog)
+ ;; if reverb-dialog doesn't exist, create it
+ (let ((initial-reverb-amount 0.1)
+ (initial-reverb-filter 0.5)
+ (initial-reverb-feedback 1.09)
+ (sliders ()))
+ (set! reverb-dialog
+ (make-effect-dialog
+ reverb-label
+
+ (lambda (w context info)
+ (let ((snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (reverb-control? snd) #t)
+ (set! (reverb-control-scale snd) reverb-amount)
+ (set! (reverb-control-lowpass snd) reverb-filter)
+ (set! (reverb-control-feedback snd) reverb-feedback)
+ (if (eq? reverb-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? reverb-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w context info)
+ (help-dialog "McNabb reverb"
+ "Reverberator from Michael McNabb.
Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Move the sliders to change the reverb parameters."))
-
- (lambda (w c i)
- (set! reverb-amount initial-reverb-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* reverb-amount 100))))
- (set! reverb-filter initial-reverb-filter)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* reverb-filter 100))))
- (set! reverb-feedback initial-reverb-feedback)
- (XtSetValues (caddr sliders) (list XmNvalue (floor (* reverb-feedback 100)))))
-
- (lambda ()
- (effect-target-ok reverb-target))))
-
- (set! sliders
- (add-sliders reverb-dialog
- (list (list "reverb amount" 0.0 initial-reverb-amount 1.0
- (lambda (w context info)
- (set! reverb-amount (/ (.value info) 100.0)))
- 100)
- (list "reverb filter" 0.0 initial-reverb-filter 1.0
- (lambda (w context info)
- (set! reverb-filter (/ (.value info) 100.0)))
- 100)
- (list "reverb feedback" 0.0 initial-reverb-feedback 1.25
- (lambda (w context info)
- (set! reverb-feedback (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! reverb-target target)
- (XtSetSensitive (XmMessageBoxGetChild reverb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog reverb-dialog))
-
+
+ (lambda (w c i)
+ (set! reverb-amount initial-reverb-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* reverb-amount 100))))
+ (set! reverb-filter initial-reverb-filter)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* reverb-filter 100))))
+ (set! reverb-feedback initial-reverb-feedback)
+ (XtSetValues (caddr sliders) (list XmNvalue (floor (* reverb-feedback 100)))))
+
+ (lambda ()
+ (effect-target-ok reverb-target))))
+
+ (set! sliders
+ (add-sliders reverb-dialog
+ (list (list "reverb amount" 0.0 initial-reverb-amount 1.0
+ (lambda (w context info)
+ (set! reverb-amount (/ (.value info) 100.0)))
+ 100)
+ (list "reverb filter" 0.0 initial-reverb-filter 1.0
+ (lambda (w context info)
+ (set! reverb-filter (/ (.value info) 100.0)))
+ 100)
+ (list "reverb feedback" 0.0 initial-reverb-feedback 1.25
+ (lambda (w context info)
+ (set! reverb-feedback (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! reverb-target target)
+ (XtSetSensitive (XmMessageBoxGetChild reverb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog reverb-dialog))))
+
(let ((child (XtCreateManagedWidget "McNabb reverb" xmPushButtonWidgetClass reverb-menu
(list XmNbackground *basic-color*))))
(XtAddCallback child XmNactivateCallback
@@ -2027,9 +2016,8 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-reverb-dialog)))
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "McNabb reverb (~1,2F ~1,2F ~1,2F)"
- reverb-amount reverb-filter reverb-feedback)))
- (change-label child new-label)))
+ (change-label child (format #f "McNabb reverb (~1,2F ~1,2F ~1,2F)"
+ reverb-amount reverb-filter reverb-feedback)))
reverb-menu-list))))
@@ -2037,62 +2025,63 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
;;;
(let ((jc-reverb-decay 2.0)
- (jc-reverb-volume 0.1)
- (jc-reverb-label "Chowning reverb")
- (jc-reverb-dialog #f)
- (jc-reverb-target 'sound)
- (jc-reverb-truncate #f))
-
- (define (post-jc-reverb-dialog)
- (if (not (Widget? jc-reverb-dialog))
- ;; if jc-reverb-dialog doesn't exist, create it
- (let ((initial-jc-reverb-decay 2.0)
- (initial-jc-reverb-volume 0.1)
- (sliders ()))
- (set! jc-reverb-dialog
- (make-effect-dialog
- jc-reverb-label
-
- (lambda (w context info)
+ (jc-reverb-volume 0.1))
+
+ (define post-jc-reverb-dialog
+ (let ((jc-reverb-label "Chowning reverb")
+ (jc-reverb-dialog #f)
+ (jc-reverb-target 'sound)
+ (jc-reverb-truncate #f))
+ (lambda ()
+ (unless (Widget? jc-reverb-dialog)
+ ;; if jc-reverb-dialog doesn't exist, create it
+ (let ((initial-jc-reverb-decay 2.0)
+ (initial-jc-reverb-volume 0.1)
+ (sliders ()))
+ (set! jc-reverb-dialog
+ (make-effect-dialog
+ jc-reverb-label
+
+ (lambda (w context info)
;(pad-channel (- (framples) 1) (srate))
- (map-chan-over-target-with-sync
- (lambda (samps)
- (effects-jc-reverb jc-reverb-volume samps (framples)))
- jc-reverb-target
- (lambda (target samps)
- (format #f "effects-jc-reverb-1 ~A" jc-reverb-volume))
- (and (not jc-reverb-truncate) jc-reverb-decay)))
-
- (lambda (w context info)
- (help-dialog "Chowning reverb"
- "Nice reverb from John Chowning. Move the sliders to set the reverb parameters."))
-
- (lambda (w c i)
- (set! jc-reverb-decay initial-jc-reverb-decay)
- (XtSetValues (sliders 0) (list XmNvalue (floor (* jc-reverb-decay 100))))
- (set! jc-reverb-volume initial-jc-reverb-volume)
- (XtSetValues (sliders 1) (list XmNvalue (floor (* jc-reverb-volume 100)))))
-
- (lambda ()
- (effect-target-ok jc-reverb-target))))
-
- (set! sliders
- (add-sliders jc-reverb-dialog
- (list (list "decay duration" 0.0 initial-jc-reverb-decay 10.0
- (lambda (w context info)
- (set! jc-reverb-decay (/ (.value info) 100)))
- 100)
- (list "reverb volume" 0.0 initial-jc-reverb-volume 1.0
- (lambda (w context info)
- (set! jc-reverb-volume (/ (.value info) 100)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! jc-reverb-target target)
- (XtSetSensitive (XmMessageBoxGetChild jc-reverb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- (lambda (truncate)
- (set! jc-reverb-truncate truncate)))))
- (activate-dialog jc-reverb-dialog))
+ (map-chan-over-target-with-sync
+ (lambda (samps)
+ (effects-jc-reverb jc-reverb-volume samps (framples)))
+ jc-reverb-target
+ (lambda (target samps)
+ (format #f "effects-jc-reverb-1 ~A" jc-reverb-volume))
+ (and (not jc-reverb-truncate) jc-reverb-decay)))
+
+ (lambda (w context info)
+ (help-dialog "Chowning reverb"
+ "Nice reverb from John Chowning. Move the sliders to set the reverb parameters."))
+
+ (lambda (w c i)
+ (set! jc-reverb-decay initial-jc-reverb-decay)
+ (XtSetValues (sliders 0) (list XmNvalue (floor (* jc-reverb-decay 100))))
+ (set! jc-reverb-volume initial-jc-reverb-volume)
+ (XtSetValues (sliders 1) (list XmNvalue (floor (* jc-reverb-volume 100)))))
+
+ (lambda ()
+ (effect-target-ok jc-reverb-target))))
+
+ (set! sliders
+ (add-sliders jc-reverb-dialog
+ (list (list "decay duration" 0.0 initial-jc-reverb-decay 10.0
+ (lambda (w context info)
+ (set! jc-reverb-decay (/ (.value info) 100)))
+ 100)
+ (list "reverb volume" 0.0 initial-jc-reverb-volume 1.0
+ (lambda (w context info)
+ (set! jc-reverb-volume (/ (.value info) 100)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! jc-reverb-target target)
+ (XtSetSensitive (XmMessageBoxGetChild jc-reverb-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ (lambda (truncate)
+ (set! jc-reverb-truncate truncate)))))
+ (activate-dialog jc-reverb-dialog))))
(let ((child (XtCreateManagedWidget "Chowning reverb" xmPushButtonWidgetClass reverb-menu
(list XmNbackground *basic-color*))))
@@ -2101,9 +2090,7 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-jc-reverb-dialog)))
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "Chowning reverb (~1,2F ~1,2F)"
- jc-reverb-decay jc-reverb-volume)))
- (change-label child new-label)))
+ (change-label child (format #f "Chowning reverb (~1,2F ~1,2F)" jc-reverb-decay jc-reverb-volume)))
reverb-menu-list))))
;;; -------- Convolution
@@ -2112,54 +2099,55 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(let ((convolve-sound-one 0)
(convolve-sound-two 1)
- (convolve-amp 0.01)
- (convolve-label "Convolution")
- (convolve-dialog #f))
-
- (define (post-convolve-dialog)
- (if (not (Widget? convolve-dialog))
- ;; if convolve-dialog doesn't exist, create it
- (let ((initial-convolve-sound-one 0)
- (initial-convolve-sound-two 1)
- (initial-convolve-amp 0.01)
- (sliders ()))
- (set! convolve-dialog
- (make-effect-dialog
- convolve-label
-
- (lambda (w context info)
- (effects-cnv convolve-sound-one convolve-amp convolve-sound-two))
-
- (lambda (w context info)
- (help-dialog "Convolution"
- "Very simple convolution. Move the sliders to set the numbers of the soundfiles to be convolved and the amount for the amplitude scaler. Output will be scaled to floating-point values, resulting in very large (but not clipped) amplitudes. Use the Normalize amplitude effect to rescale the output. The convolution data file typically defines a natural reverberation source, and the output from this effect can provide very striking reverb effects. You can find convolution data files on sites listed at http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
-
- (lambda (w c i)
- (set! convolve-sound-one initial-convolve-sound-one)
- (XtSetValues (sliders 0) (list XmNvalue convolve-sound-one))
- (set! convolve-sound-two initial-convolve-sound-two)
- (XtSetValues (sliders 1) (list XmNvalue convolve-sound-two))
- (set! convolve-amp initial-convolve-amp)
- (XtSetValues (sliders 2) (list XmNvalue (floor (* convolve-amp 100)))))
-
- (lambda ()
- (pair? (sounds)))))
-
- (set! sliders
- (add-sliders convolve-dialog
- (list (list "impulse response file" 0 initial-convolve-sound-one 24
- (lambda (w context info)
- (set! convolve-sound-one (.value info)))
- 1)
- (list "sound file" 0 initial-convolve-sound-two 24
- (lambda (w context info)
- (set! convolve-sound-two (.value info)))
- 1)
- (list "amplitude" 0.0 initial-convolve-amp 0.10
- (lambda (w context info)
- (set! convolve-amp (/ (.value info) 100.0)))
- 1000))))))
- (activate-dialog convolve-dialog))
+ (convolve-amp 0.01))
+
+ (define post-convolve-dialog
+ (let ((convolve-label "Convolution")
+ (convolve-dialog #f))
+ (lambda ()
+ (unless (Widget? convolve-dialog)
+ ;; if convolve-dialog doesn't exist, create it
+ (let ((initial-convolve-sound-one 0)
+ (initial-convolve-sound-two 1)
+ (initial-convolve-amp 0.01)
+ (sliders ()))
+ (set! convolve-dialog
+ (make-effect-dialog
+ convolve-label
+
+ (lambda (w context info)
+ (effects-cnv convolve-sound-one convolve-amp convolve-sound-two))
+
+ (lambda (w context info)
+ (help-dialog "Convolution"
+ "Very simple convolution. Move the sliders to set the numbers of the soundfiles to be convolved and the amount for the amplitude scaler. Output will be scaled to floating-point values, resulting in very large (but not clipped) amplitudes. Use the Normalize amplitude effect to rescale the output. The convolution data file typically defines a natural reverberation source, and the output from this effect can provide very striking reverb effects. You can find convolution data files on sites listed at http://www.bright.net/~dlphilp/linux_csound.html under Impulse Response Data."))
+
+ (lambda (w c i)
+ (set! convolve-sound-one initial-convolve-sound-one)
+ (XtSetValues (sliders 0) (list XmNvalue convolve-sound-one))
+ (set! convolve-sound-two initial-convolve-sound-two)
+ (XtSetValues (sliders 1) (list XmNvalue convolve-sound-two))
+ (set! convolve-amp initial-convolve-amp)
+ (XtSetValues (sliders 2) (list XmNvalue (floor (* convolve-amp 100)))))
+
+ (lambda ()
+ (pair? (sounds)))))
+
+ (set! sliders
+ (add-sliders convolve-dialog
+ (list (list "impulse response file" 0 initial-convolve-sound-one 24
+ (lambda (w context info)
+ (set! convolve-sound-one (.value info)))
+ 1)
+ (list "sound file" 0 initial-convolve-sound-two 24
+ (lambda (w context info)
+ (set! convolve-sound-two (.value info)))
+ 1)
+ (list "amplitude" 0.0 initial-convolve-amp 0.10
+ (lambda (w context info)
+ (set! convolve-amp (/ (.value info) 100.0)))
+ 1000))))))
+ (activate-dialog convolve-dialog))))
(let ((child (XtCreateManagedWidget "Convolution" xmPushButtonWidgetClass reverb-menu
(list XmNbackground *basic-color*))))
@@ -2168,9 +2156,8 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-convolve-dialog)))
(set! reverb-menu-list (cons (lambda ()
- (let ((new-label (format #f "Convolution (~D ~D ~1,2F)"
- convolve-sound-one convolve-sound-two convolve-amp)))
- (change-label child new-label)))
+ (change-label child (format #f "Convolution (~D ~D ~1,2F)"
+ convolve-sound-one convolve-sound-two convolve-amp)))
reverb-menu-list))))
)
@@ -2213,15 +2200,15 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
0 len snd chn #f
(format #f "effects-position-sound ~A ~A" mono-snd pos))
(let ((e1 (make-env pos :length len)))
- (if (and (number? chn) (= chn 1))
- (map-channel (lambda (y)
- (+ y (* (env e1) (read-sample reader1))))
- 0 len snd chn #f
- (format #f "effects-position-sound ~A '~A" mono-snd pos))
- (map-channel (lambda (y)
- (+ y (* (- 1.0 (env e1)) (read-sample reader1))))
- 0 len snd chn #f
- (format #f "effects-position-sound ~A '~A" mono-snd pos)))))))))
+ (map-channel
+ (if (eqv? chn 1)
+ (lambda (y)
+ (+ y (* (env e1) (read-sample reader1))))
+ (lambda (y)
+ (+ y (* (- 1.0 (env e1)) (read-sample reader1)))))
+ 0 len snd chn #f
+ (format #f "effects-position-sound ~A '~A" mono-snd pos))))))))
+
(define effects-flange
(let ((documentation "(effects-flange amount speed time beg dur snd chn) is used by the effects dialog to tie into edit-list->function"))
@@ -2289,90 +2276,88 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(let ((mono-snd 0)
(stereo-snd 1)
- (pan-pos 45)
- (place-sound-label "Place sound")
- (place-sound-dialog #f)
- (place-sound-target 'sound)
- (place-sound-envelope #f))
-
- (define (place-sound mono-snd stereo-snd pan-env)
- ;; (place-sound mono-snd stereo-snd pan-env) mixes a mono sound into a stereo sound, splitting
- ;; it into two copies whose amplitudes depend on the envelope 'pan-env'. If 'pan-env' is
- ;; a number, the sound is split such that 0 is all in channel 0 and 90 is all in channel 1.
- (if (number? pan-env)
- (let ((pos (/ pan-env 90.0)))
- (effects-position-sound mono-snd pos stereo-snd 1)
- (effects-position-sound mono-snd (- 1.0 pos) stereo-snd 0))
- (begin
- (effects-position-sound mono-snd pan-env stereo-snd 1)
- (effects-position-sound mono-snd pan-env stereo-snd 0))))
-
- (define (post-place-sound-dialog)
- (if (not (Widget? place-sound-dialog))
- (let ((initial-mono-snd 0)
- (initial-stereo-snd 1)
- (initial-pan-pos 45)
- (sliders ())
- (fr #f))
- (set! place-sound-dialog
- (make-effect-dialog
- place-sound-label
-
- (lambda (w context info)
- (let ((e (xe-envelope place-sound-envelope)))
- (if (not (equal? e (list 0.0 1.0 1.0 1.0)))
- (place-sound mono-snd stereo-snd e)
- (place-sound mono-snd stereo-snd pan-pos))))
-
- (lambda (w context info)
- (help-dialog "Place sound"
- "Mixes mono sound into stereo sound field."))
-
- (lambda (w c i)
- (set! mono-snd initial-mono-snd)
- (XtSetValues (sliders 0) (list XmNvalue mono-snd))
- (set! stereo-snd initial-stereo-snd)
- (XtSetValues (sliders 1) (list XmNvalue stereo-snd))
- (set! pan-pos initial-pan-pos)
- (XtSetValues (sliders 2) (list XmNvalue pan-pos)))
-
- (lambda ()
- (effect-target-ok place-sound-target))))
-
- (set! sliders
- (add-sliders place-sound-dialog
- (list (list "mono sound" 0 initial-mono-snd 50
- (lambda (w context info)
- (set! mono-snd (.value info)))
- 1)
- (list "stereo sound" 0 initial-stereo-snd 50
- (lambda (w context info)
- (set! stereo-snd (.value info)))
- 1)
- (list "pan position" 0 initial-pan-pos 90
- (lambda (w context info)
- (set! pan-pos (.value info)))
- 1))))
- (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
- (list XmNheight 200
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNbottomAttachment XmATTACH_FORM
- XmNtopWidget (sliders (- (length sliders) 1))
- XmNshadowThickness 4
- XmNshadowType XmSHADOW_ETCHED_OUT)))
-
- (activate-dialog place-sound-dialog)
- (set! place-sound-envelope (xe-create-enved "panning" fr
- (list XmNheight 200
- XmNbottomAttachment XmATTACH_FORM
- )
- '(0.0 1.0 0.0 1.0)))
- (set! (xe-envelope place-sound-envelope) (list 0.0 1.0 1.0 1.0))
- ))
-
- (activate-dialog place-sound-dialog))
+ (pan-pos 45))
+
+ (define post-place-sound-dialog
+ (let ((place-sound-label "Place sound")
+ (place-sound-dialog #f)
+ (place-sound-target 'sound)
+ (place-sound-envelope #f))
+
+ (define (place-sound mono-snd stereo-snd pan-env)
+ ;; (place-sound mono-snd stereo-snd pan-env) mixes a mono sound into a stereo sound, splitting
+ ;; it into two copies whose amplitudes depend on the envelope 'pan-env'. If 'pan-env' is
+ ;; a number, the sound is split such that 0 is all in channel 0 and 90 is all in channel 1.
+ (if (number? pan-env)
+ (let ((pos (/ pan-env 90.0)))
+ (effects-position-sound mono-snd pos stereo-snd 1)
+ (effects-position-sound mono-snd (- 1.0 pos) stereo-snd 0))
+ (begin
+ (effects-position-sound mono-snd pan-env stereo-snd 1)
+ (effects-position-sound mono-snd pan-env stereo-snd 0))))
+
+ (lambda ()
+ (unless (Widget? place-sound-dialog)
+ (let ((fr #f))
+ (let ((sliders ())
+ (initial-mono-snd 0)
+ (initial-stereo-snd 1)
+ (initial-pan-pos 45))
+ (set! place-sound-dialog
+ (make-effect-dialog
+ place-sound-label
+
+ (lambda (w context info)
+ (let ((e (xe-envelope place-sound-envelope)))
+ (place-sound mono-snd stereo-snd (if (not (equal? e (list 0.0 1.0 1.0 1.0))) e pan-pos))))
+
+ (lambda (w context info)
+ (help-dialog "Place sound"
+ "Mixes mono sound into stereo sound field."))
+
+ (lambda (w c i)
+ (set! mono-snd initial-mono-snd)
+ (XtSetValues (sliders 0) (list XmNvalue mono-snd))
+ (set! stereo-snd initial-stereo-snd)
+ (XtSetValues (sliders 1) (list XmNvalue stereo-snd))
+ (set! pan-pos initial-pan-pos)
+ (XtSetValues (sliders 2) (list XmNvalue pan-pos)))
+
+ (lambda ()
+ (effect-target-ok place-sound-target))))
+
+ (set! sliders
+ (add-sliders place-sound-dialog
+ (list (list "mono sound" 0 initial-mono-snd 50
+ (lambda (w context info)
+ (set! mono-snd (.value info)))
+ 1)
+ (list "stereo sound" 0 initial-stereo-snd 50
+ (lambda (w context info)
+ (set! stereo-snd (.value info)))
+ 1)
+ (list "pan position" 0 initial-pan-pos 90
+ (lambda (w context info)
+ (set! pan-pos (.value info)))
+ 1))))
+ (set! fr (XtCreateManagedWidget "fr" xmFrameWidgetClass (XtParent (XtParent (car sliders)))
+ (list XmNheight 200
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNbottomAttachment XmATTACH_FORM
+ XmNtopWidget (sliders (- (length sliders) 1))
+ XmNshadowThickness 4
+ XmNshadowType XmSHADOW_ETCHED_OUT))))
+ (activate-dialog place-sound-dialog)
+ (set! place-sound-envelope (xe-create-enved "panning" fr
+ (list XmNheight 200
+ XmNbottomAttachment XmATTACH_FORM
+ )
+ '(0.0 1.0 0.0 1.0)))
+ (set! (xe-envelope place-sound-envelope) (list 0.0 1.0 1.0 1.0))))
+
+ (activate-dialog place-sound-dialog))))
(let ((child (XtCreateManagedWidget "Place sound" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2381,50 +2366,49 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-place-sound-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Place sound (~D ~D ~D)"
- mono-snd stereo-snd pan-pos)))
- (change-label child new-label)))
+ (change-label child (format #f "Place sound (~D ~D ~D)" mono-snd stereo-snd pan-pos)))
misc-menu-list))))
;;; -------- Insert silence (at cursor, silence-amount in secs)
;;;
- (let ((silence-amount 1.0)
- (silence-label "Add silence")
- (silence-dialog #f))
-
- (define (post-silence-dialog)
- (if (not (Widget? silence-dialog))
- ;; if silence-dialog doesn't exist, create it
- (let ((initial-silence-amount 1.0)
- (sliders ()))
- (set! silence-dialog
- (make-effect-dialog
- silence-label
-
- (lambda (w context info)
- (insert-silence (cursor)
- (floor (* (srate) silence-amount))))
-
- (lambda (w context info)
- (help-dialog "Add silence"
- "Move the slider to change the number of seconds of silence added at the cursor position."))
-
- (lambda (w c i)
- (set! silence-amount initial-silence-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* silence-amount 100)))))
-
- (lambda ()
- (pair? (sounds)))))
-
- (set! sliders
- (add-sliders silence-dialog
- (list (list "silence" 0.0 initial-silence-amount 5.0
- (lambda (w context info)
- (set! silence-amount (/ (.value info) 100.0)))
- 100))))))
- (activate-dialog silence-dialog))
+ (let ((silence-amount 1.0))
+
+ (define post-silence-dialog
+ (let ((silence-label "Add silence")
+ (silence-dialog #f))
+ (lambda ()
+ (unless (Widget? silence-dialog)
+ ;; if silence-dialog doesn't exist, create it
+ (let ((initial-silence-amount 1.0)
+ (sliders ()))
+ (set! silence-dialog
+ (make-effect-dialog
+ silence-label
+
+ (lambda (w context info)
+ (insert-silence (cursor)
+ (floor (* (srate) silence-amount))))
+
+ (lambda (w context info)
+ (help-dialog "Add silence"
+ "Move the slider to change the number of seconds of silence added at the cursor position."))
+
+ (lambda (w c i)
+ (set! silence-amount initial-silence-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* silence-amount 100)))))
+
+ (lambda ()
+ (pair? (sounds)))))
+
+ (set! sliders
+ (add-sliders silence-dialog
+ (list (list "silence" 0.0 initial-silence-amount 5.0
+ (lambda (w context info)
+ (set! silence-amount (/ (.value info) 100.0)))
+ 100))))))
+ (activate-dialog silence-dialog))))
(let ((child (XtCreateManagedWidget "Add silence" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2433,67 +2417,67 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-silence-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Add silence (~1,2F)" silence-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Add silence (~1,2F)" silence-amount)))
misc-menu-list))))
;;; -------- Contrast (brightness control)
;;;
- (let ((contrast-amount 1.0)
- (contrast-label "Contrast enhancement")
- (contrast-dialog #f)
- (contrast-target 'sound))
-
- (define (post-contrast-dialog)
- (if (not (Widget? contrast-dialog))
- ;; if contrast-dialog doesn't exist, create it
- (let ((initial-contrast-amount 1.0)
- (sliders ()))
- (set! contrast-dialog
- (make-effect-dialog
- contrast-label
-
- (lambda (w context info)
- (let ((peak (maxamp))
- (snd (selected-sound)))
- (save-controls snd)
- (reset-controls snd)
- (set! (contrast-control? snd) #t)
- (set! (contrast-control snd) contrast-amount)
- (set! (contrast-control-amp snd) (/ 1.0 peak))
- (set! (amp-control snd) peak)
- (if (eq? contrast-target 'marks)
- (let ((ms (plausible-mark-samples)))
- (apply-controls snd 0 (car ms) (+ 1 (- (cadr ms) (car ms)))))
- (apply-controls snd (if (eq? contrast-target 'sound) 0 2)))
- (restore-controls snd)))
-
- (lambda (w context info)
- (help-dialog "Contrast enhancement"
- "Move the slider to change the contrast intensity."))
-
- (lambda (w c i)
- (set! contrast-amount initial-contrast-amount)
- (XtSetValues (car sliders) (list XmNvalue (floor (* contrast-amount 100)))))
-
- (lambda ()
- (effect-target-ok contrast-target))))
-
- (set! sliders
- (add-sliders contrast-dialog
- (list (list "contrast enhancement" 0.0 initial-contrast-amount 10.0
- (lambda (w context info)
- (set! contrast-amount (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! contrast-target target)
- (XtSetSensitive (XmMessageBoxGetChild contrast-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog contrast-dialog))
+ (let ((contrast-amount 1.0))
+
+ (define post-contrast-dialog
+ (let ((contrast-label "Contrast enhancement")
+ (contrast-dialog #f)
+ (contrast-target 'sound))
+ (lambda ()
+ (unless (Widget? contrast-dialog)
+ ;; if contrast-dialog doesn't exist, create it
+ (let ((initial-contrast-amount 1.0)
+ (sliders ()))
+ (set! contrast-dialog
+ (make-effect-dialog
+ contrast-label
+
+ (lambda (w context info)
+ (let ((peak (maxamp))
+ (snd (selected-sound)))
+ (save-controls snd)
+ (reset-controls snd)
+ (set! (contrast-control? snd) #t)
+ (set! (contrast-control snd) contrast-amount)
+ (set! (contrast-control-amp snd) (/ 1.0 peak))
+ (set! (amp-control snd) peak)
+ (if (eq? contrast-target 'marks)
+ (let ((ms (plausible-mark-samples)))
+ (apply-controls snd 0 (car ms) (- (+ (cadr ms) 1) (car ms))))
+ (apply-controls snd (if (eq? contrast-target 'sound) 0 2)))
+ (restore-controls snd)))
+
+ (lambda (w context info)
+ (help-dialog "Contrast enhancement"
+ "Move the slider to change the contrast intensity."))
+
+ (lambda (w c i)
+ (set! contrast-amount initial-contrast-amount)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* contrast-amount 100)))))
+
+ (lambda ()
+ (effect-target-ok contrast-target))))
+
+ (set! sliders
+ (add-sliders contrast-dialog
+ (list (list "contrast enhancement" 0.0 initial-contrast-amount 10.0
+ (lambda (w context info)
+ (set! contrast-amount (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! contrast-target target)
+ (XtSetSensitive (XmMessageBoxGetChild contrast-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog contrast-dialog))))
(let ((child (XtCreateManagedWidget "Contrast enhancement" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2502,8 +2486,7 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(post-contrast-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Contrast enhancement (~1,2F)" contrast-amount)))
- (change-label child new-label)))
+ (change-label child (format #f "Contrast enhancement (~1,2F)" contrast-amount)))
misc-menu-list))))
;;; -------- Cross synthesis
@@ -2512,166 +2495,165 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(let ((cross-synth-sound 1)
(cross-synth-amp .5)
(cross-synth-fft-size 128)
- (cross-synth-radius 6.0)
- (cross-synth-label "Cross synthesis")
- (cross-synth-dialog #f)
- (cross-synth-default-fft-widget #f)
- (cross-synth-target 'sound))
-
- (define (post-cross-synth-dialog)
- (if (not (Widget? cross-synth-dialog))
- ;; if cross-synth-dialog doesn't exist, create it
- (let ((initial-cross-synth-sound 1)
- (initial-cross-synth-amp .5)
- (initial-cross-synth-fft-size 128)
- (initial-cross-synth-radius 6.0)
- (sliders ()))
- (set! cross-synth-dialog
- (make-effect-dialog
- cross-synth-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (effects-cross-synthesis cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
- cross-synth-target
- (lambda (target samps)
- (format #f "effects-cross-synthesis-1 ~A ~A ~A ~A"
- cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
- #f))
-
- (lambda (w context info)
- (help-dialog "Cross synthesis"
- "The sliders set the number of the soundfile to be cross-synthesized,
+ (cross-synth-radius 6.0))
+
+ (define post-cross-synth-dialog
+ (let ((cross-synth-label "Cross synthesis")
+ (cross-synth-dialog #f)
+ (cross-synth-default-fft-widget #f)
+ (cross-synth-target 'sound))
+ (lambda ()
+ (unless (Widget? cross-synth-dialog)
+ ;; if cross-synth-dialog doesn't exist, create it
+ (let ((initial-cross-synth-sound 1)
+ (initial-cross-synth-amp .5)
+ (initial-cross-synth-radius 6.0)
+ (sliders ()))
+ (let ((initial-cross-synth-fft-size 128))
+ (set! cross-synth-dialog
+ (make-effect-dialog
+ cross-synth-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (effects-cross-synthesis cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
+ cross-synth-target
+ (lambda (target samps)
+ (format #f "effects-cross-synthesis-1 ~A ~A ~A ~A"
+ cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Cross synthesis"
+ "The sliders set the number of the soundfile to be cross-synthesized,
the synthesis amplitude, the FFT size, and the radius value."))
-
- (lambda (w c i)
- (set! cross-synth-sound initial-cross-synth-sound)
- (XtSetValues (sliders 0) (list XmNvalue cross-synth-sound))
- (set! cross-synth-amp initial-cross-synth-amp)
- (XtSetValues (sliders 1) (list XmNvalue (floor (* cross-synth-amp 100))))
- (set! cross-synth-fft-size initial-cross-synth-fft-size)
- (if use-combo-box-for-fft-size ; defined in effects-utils.scm
- (XtSetValues cross-synth-default-fft-widget (list XmNselectedPosition 1))
- (XmToggleButtonSetState cross-synth-default-fft-widget #t #t))
- (set! cross-synth-radius initial-cross-synth-radius)
- (XtSetValues (sliders 2) (list XmNvalue (floor (* cross-synth-radius 100)))))
-
- (lambda ()
- (effect-target-ok cross-synth-target))))
-
- (set! sliders
- (add-sliders cross-synth-dialog
- (list (list "input sound" 0 initial-cross-synth-sound 20
- (lambda (w context info)
- (set! cross-synth-sound (.value info)))
- 1)
- (list "amplitude" 0.0 initial-cross-synth-amp 1.0
- (lambda (w context info)
- (set! cross-synth-amp (/ (.value info) 100)))
- 100)
- (list "radius" 0.0 initial-cross-synth-radius 360.0
- (lambda (w context info)
- (set! cross-synth-radius (/ (.value info) 100)))
- 100))))
-
- ;; now add either a radio-button box or a combo-box for the fft size
- ;; need to use XtParent here since "mainform" isn't returned by add-sliders
-
- (if use-combo-box-for-fft-size
- ;; this block creates a "combo box" to handle the fft size
- (let* ((s1 (XmStringCreateLocalized "FFT size"))
- (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
- (list XmNborderWidth 1
- XmNshadowType XmSHADOW_ETCHED_IN
- XmNpositionIndex 2)))
- (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (lab (XtCreateManagedWidget "FFT size" xmLabelWidgetClass frm
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNlabelString s1
- XmNbackground *basic-color*)))
- (fft-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "4096")))
- (combo (XtCreateManagedWidget "fftsize" xmComboBoxWidgetClass frm
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget lab
+
+ (lambda (w c i)
+ (set! cross-synth-sound initial-cross-synth-sound)
+ (XtSetValues (sliders 0) (list XmNvalue cross-synth-sound))
+ (set! cross-synth-amp initial-cross-synth-amp)
+ (XtSetValues (sliders 1) (list XmNvalue (floor (* cross-synth-amp 100))))
+ (set! cross-synth-fft-size initial-cross-synth-fft-size)
+ (if use-combo-box-for-fft-size ; defined in effects-utils.scm
+ (XtSetValues cross-synth-default-fft-widget (list XmNselectedPosition 1))
+ (XmToggleButtonSetState cross-synth-default-fft-widget #t #t))
+ (set! cross-synth-radius initial-cross-synth-radius)
+ (XtSetValues (sliders 2) (list XmNvalue (floor (* cross-synth-radius 100)))))
+
+ (lambda ()
+ (effect-target-ok cross-synth-target)))))
+
+ (set! sliders
+ (add-sliders cross-synth-dialog
+ (list (list "input sound" 0 initial-cross-synth-sound 20
+ (lambda (w context info)
+ (set! cross-synth-sound (.value info)))
+ 1)
+ (list "amplitude" 0.0 initial-cross-synth-amp 1.0
+ (lambda (w context info)
+ (set! cross-synth-amp (/ (.value info) 100)))
+ 100)
+ (list "radius" 0.0 initial-cross-synth-radius 360.0
+ (lambda (w context info)
+ (set! cross-synth-radius (/ (.value info) 100)))
+ 100))))
+
+ ;; now add either a radio-button box or a combo-box for the fft size
+ ;; need to use XtParent here since "mainform" isn't returned by add-sliders
+
+ (if use-combo-box-for-fft-size
+ ;; this block creates a "combo box" to handle the fft size
+ (let* ((s1 (XmStringCreateLocalized "FFT size"))
+ (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
+ (list XmNborderWidth 1
+ XmNshadowType XmSHADOW_ETCHED_IN
+ XmNpositionIndex 2)))
+ (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
+ (list XmNleftAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_FORM
XmNtopAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_FORM
- XmNitems fft-labels
- XmNitemCount (length fft-labels)
- XmNcomboBoxType XmDROP_DOWN_COMBO_BOX
- XmNbackground *basic-color*))))
- (set! cross-synth-default-fft-widget combo)
- (for-each XmStringFree fft-labels)
- (XmStringFree s1)
- (XtSetValues combo (list XmNselectedPosition 1))
- (XtAddCallback combo XmNselectionCallback
- (lambda (w c i)
- (let* ((selected (.item_or_text i))
- (size-as-string (XmStringUnparse selected #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (set! cross-synth-fft-size (string->number size-as-string))))))
-
- ;; this block creates a "radio button box"
- (let* ((s1 (XmStringCreateLocalized "FFT size"))
- (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
- (list XmNborderWidth 1
- XmNshadowType XmSHADOW_ETCHED_IN
- XmNpositionIndex 2)))
- (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (rc (XtCreateManagedWidget "rc" xmRowColumnWidgetClass frm
- (list XmNorientation XmHORIZONTAL
- XmNradioBehavior #t
- XmNradioAlwaysOne #t
- XmNentryClass xmToggleButtonWidgetClass
- XmNisHomogeneous #t
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNbackground *basic-color*))))
- (XtCreateManagedWidget "FFT size" xmLabelWidgetClass frm
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget rc
- XmNbottomAttachment XmATTACH_FORM
- XmNlabelString s1
- XmNalignment XmALIGNMENT_BEGINNING
- XmNbackground *basic-color*))
- (for-each
- (lambda (size)
- (let ((button (XtCreateManagedWidget (format #f "~D" size) xmToggleButtonWidgetClass rc
- (list XmNbackground *basic-color*
- XmNvalueChangedCallback (list (lambda (w c i)
- (if (.set i)
- (set! cross-synth-fft-size c)))
- size)
- XmNset (= size cross-synth-fft-size)))))
- (if (= size cross-synth-fft-size)
- (set! cross-synth-default-fft-widget button))))
- (list 64 128 256 512 1024 4096))
- (XmStringFree s1)))
-
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! cross-synth-target target)
- (XtSetSensitive (XmMessageBoxGetChild cross-synth-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog cross-synth-dialog))
+ XmNbackground *basic-color*)))
+ (lab (XtCreateManagedWidget "FFT size" xmLabelWidgetClass frm
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNlabelString s1
+ XmNbackground *basic-color*)))
+ (fft-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "4096")))
+ (combo (XtCreateManagedWidget "fftsize" xmComboBoxWidgetClass frm
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget lab
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNitems fft-labels
+ XmNitemCount (length fft-labels)
+ XmNcomboBoxType XmDROP_DOWN_COMBO_BOX
+ XmNbackground *basic-color*))))
+ (set! cross-synth-default-fft-widget combo)
+ (for-each XmStringFree fft-labels)
+ (XmStringFree s1)
+ (XtSetValues combo (list XmNselectedPosition 1))
+ (XtAddCallback combo XmNselectionCallback
+ (lambda (w c i)
+ (set! cross-synth-fft-size
+ (string->number (XmStringUnparse (.item_or_text i) #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL))))))
+ ;; this block creates a "radio button box"
+ (let* ((s1 (XmStringCreateLocalized "FFT size"))
+ (frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders))
+ (list XmNborderWidth 1
+ XmNshadowType XmSHADOW_ETCHED_IN
+ XmNpositionIndex 2)))
+ (frm (XtCreateManagedWidget "frm" xmFormWidgetClass frame
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (rc (XtCreateManagedWidget "rc" xmRowColumnWidgetClass frm
+ (list XmNorientation XmHORIZONTAL
+ XmNradioBehavior #t
+ XmNradioAlwaysOne #t
+ XmNentryClass xmToggleButtonWidgetClass
+ XmNisHomogeneous #t
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNbackground *basic-color*))))
+ (XtCreateManagedWidget "FFT size" xmLabelWidgetClass frm
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget rc
+ XmNbottomAttachment XmATTACH_FORM
+ XmNlabelString s1
+ XmNalignment XmALIGNMENT_BEGINNING
+ XmNbackground *basic-color*))
+ (for-each
+ (lambda (size)
+ (let ((button (XtCreateManagedWidget (format #f "~D" size) xmToggleButtonWidgetClass rc
+ (list XmNbackground *basic-color*
+ XmNvalueChangedCallback (list (lambda (w c i)
+ (if (.set i)
+ (set! cross-synth-fft-size c)))
+ size)
+ XmNset (= size cross-synth-fft-size)))))
+ (if (= size cross-synth-fft-size)
+ (set! cross-synth-default-fft-widget button))))
+ (list 64 128 256 512 1024 4096))
+ (XmStringFree s1)))
+
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! cross-synth-target target)
+ (XtSetSensitive (XmMessageBoxGetChild cross-synth-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog cross-synth-dialog))))
(let ((child (XtCreateManagedWidget "Cross synthesis" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2680,9 +2662,8 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-cross-synth-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Cross synthesis (~D ~1,2F ~D ~1,2F)"
- cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius)))
- (change-label child new-label)))
+ (change-label child (format #f "Cross synthesis (~D ~1,2F ~D ~1,2F)"
+ cross-synth-sound cross-synth-amp cross-synth-fft-size cross-synth-radius)))
misc-menu-list))))
;;; -------- Flange and phasing
@@ -2690,75 +2671,76 @@ the synthesis amplitude, the FFT size, and the radius value."))
(let ((flange-speed 2.0)
(flange-amount 5.0)
- (flange-time 0.001)
- (flange-label "Flange")
- (flange-dialog #f)
- (flange-target 'sound))
-
- (define (post-flange-dialog)
- (if (not (Widget? flange-dialog))
- ;; if flange-dialog doesn't exist, create it
- (let ((initial-flange-speed 2.0)
- (initial-flange-amount 5.0)
- (initial-flange-time 0.001)
- (sliders ()))
- (set! flange-dialog
- (make-effect-dialog
- flange-label
-
- (lambda (w context info)
- (map-chan-over-target-with-sync
- (lambda (ignored)
- (let* ((ri (make-rand-interp :frequency flange-speed :amplitude flange-amount))
- (len (round (* flange-time (srate))))
- (del (make-delay len :max-size (round (+ len flange-amount 1)))))
- (lambda (inval)
- (* .75 (+ inval
- (delay del
- inval
- (rand-interp ri)))))))
- flange-target
- (lambda (target samps)
- (format #f "effects-flange ~A ~A ~A" flange-amount flange-speed flange-time))
- #f))
-
- (lambda (w context info)
- (help-dialog "Flange"
- "Move the sliders to change the flange speed, amount, and time"))
-
- (lambda (w c i)
- (set! flange-speed initial-flange-speed)
- (XtSetValues (car sliders) (list XmNvalue (floor (* flange-speed 10))))
- (set! flange-amount initial-flange-amount)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* flange-amount 10))))
- (set! flange-time initial-flange-time)
- (XtSetValues (caddr sliders) (list XmNvalue (floor (* flange-time 100)))))
-
- (lambda ()
- (effect-target-ok flange-target))))
-
- (set! sliders
- (add-sliders flange-dialog
- (list (list "flange speed" 0.0 initial-flange-speed 100.0
- (lambda (w context info)
- (set! flange-speed (/ (.value info) 10.0)))
- 10)
- (list "flange amount" 0.0 initial-flange-amount 100.0
- (lambda (w context info)
- (set! flange-amount (/ (.value info) 10.0)))
- 10)
- ;; flange time ought to use a non-linear scale (similar to amp in control panel)
- (list "flange time" 0.0 initial-flange-time 1.0
- (lambda (w context info)
- (set! flange-time (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! flange-target target)
- (XtSetSensitive (XmMessageBoxGetChild flange-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog flange-dialog))
+ (flange-time 0.001))
+
+ (define post-flange-dialog
+ (let ((flange-label "Flange")
+ (flange-dialog #f)
+ (flange-target 'sound))
+ (lambda ()
+ (unless (Widget? flange-dialog)
+ ;; if flange-dialog doesn't exist, create it
+ (let ((initial-flange-speed 2.0)
+ (initial-flange-amount 5.0)
+ (initial-flange-time 0.001)
+ (sliders ()))
+ (set! flange-dialog
+ (make-effect-dialog
+ flange-label
+
+ (lambda (w context info)
+ (map-chan-over-target-with-sync
+ (lambda (ignored)
+ (let* ((ri (make-rand-interp :frequency flange-speed :amplitude flange-amount))
+ (len (round (* flange-time (srate))))
+ (del (make-delay len :max-size (round (+ len flange-amount 1)))))
+ (lambda (inval)
+ (* .75 (+ inval
+ (delay del
+ inval
+ (rand-interp ri)))))))
+ flange-target
+ (lambda (target samps)
+ (format #f "effects-flange ~A ~A ~A" flange-amount flange-speed flange-time))
+ #f))
+
+ (lambda (w context info)
+ (help-dialog "Flange"
+ "Move the sliders to change the flange speed, amount, and time"))
+
+ (lambda (w c i)
+ (set! flange-speed initial-flange-speed)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* flange-speed 10))))
+ (set! flange-amount initial-flange-amount)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* flange-amount 10))))
+ (set! flange-time initial-flange-time)
+ (XtSetValues (caddr sliders) (list XmNvalue (floor (* flange-time 100)))))
+
+ (lambda ()
+ (effect-target-ok flange-target))))
+
+ (set! sliders
+ (add-sliders flange-dialog
+ (list (list "flange speed" 0.0 initial-flange-speed 100.0
+ (lambda (w context info)
+ (set! flange-speed (/ (.value info) 10.0)))
+ 10)
+ (list "flange amount" 0.0 initial-flange-amount 100.0
+ (lambda (w context info)
+ (set! flange-amount (/ (.value info) 10.0)))
+ 10)
+ ;; flange time ought to use a non-linear scale (similar to amp in control panel)
+ (list "flange time" 0.0 initial-flange-time 1.0
+ (lambda (w context info)
+ (set! flange-time (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! flange-target target)
+ (XtSetSensitive (XmMessageBoxGetChild flange-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog flange-dialog))))
(let ((child (XtCreateManagedWidget "Flange" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2767,9 +2749,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-flange-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Flange (~1,2F ~1,2F ~1,3F)"
- flange-speed flange-amount flange-time)))
- (change-label child new-label)))
+ (change-label child (format #f "Flange (~1,2F ~1,2F ~1,3F)" flange-speed flange-amount flange-time)))
misc-menu-list))))
@@ -2777,40 +2757,41 @@ the synthesis amplitude, the FFT size, and the radius value."))
;;;
;;; (source, progress, target)
- (let ((random-phase-amp-scaler 3.14)
- (random-phase-label "Randomize phase")
- (random-phase-dialog #f))
-
- (define (post-random-phase-dialog)
- (if (not (Widget? random-phase-dialog))
- ;; if random-phase-dialog doesn't exist, create it
- (let ((initial-random-phase-amp-scaler 3.14)
- (sliders ()))
- (set! random-phase-dialog
- (make-effect-dialog
- random-phase-label
-
- (lambda (w context info)
- (rotate-phase (lambda (x) (random random-phase-amp-scaler))))
-
- (lambda (w context info)
- (help-dialog "Randomize phase"
- "Move the slider to change the randomization amplitude scaler."))
-
- (lambda (w c i)
- (set! random-phase-amp-scaler initial-random-phase-amp-scaler)
- (XtSetValues (car sliders) (list XmNvalue (floor (* random-phase-amp-scaler 100)))))
-
- (lambda ()
- (pair? (sounds)))))
-
- (set! sliders
- (add-sliders random-phase-dialog
- (list (list "amplitude scaler" 0.0 initial-random-phase-amp-scaler 100.0
- (lambda (w context info)
- (set! random-phase-amp-scaler (/ (.value info) 100.0)))
- 100))))))
- (activate-dialog random-phase-dialog))
+ (let ((random-phase-amp-scaler 3.14))
+
+ (define post-random-phase-dialog
+ (let ((random-phase-label "Randomize phase")
+ (random-phase-dialog #f))
+ (lambda ()
+ (unless (Widget? random-phase-dialog)
+ ;; if random-phase-dialog doesn't exist, create it
+ (let ((initial-random-phase-amp-scaler 3.14)
+ (sliders ()))
+ (set! random-phase-dialog
+ (make-effect-dialog
+ random-phase-label
+
+ (lambda (w context info)
+ (rotate-phase (lambda (x) (random random-phase-amp-scaler))))
+
+ (lambda (w context info)
+ (help-dialog "Randomize phase"
+ "Move the slider to change the randomization amplitude scaler."))
+
+ (lambda (w c i)
+ (set! random-phase-amp-scaler initial-random-phase-amp-scaler)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* random-phase-amp-scaler 100)))))
+
+ (lambda ()
+ (pair? (sounds)))))
+
+ (set! sliders
+ (add-sliders random-phase-dialog
+ (list (list "amplitude scaler" 0.0 initial-random-phase-amp-scaler 100.0
+ (lambda (w context info)
+ (set! random-phase-amp-scaler (/ (.value info) 100.0)))
+ 100))))))
+ (activate-dialog random-phase-dialog))))
(let ((child (XtCreateManagedWidget "Randomize phase" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2819,8 +2800,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-random-phase-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Randomize phase (~1,2F)" random-phase-amp-scaler)))
- (change-label child new-label)))
+ (change-label child (format #f "Randomize phase (~1,2F)" random-phase-amp-scaler)))
misc-menu-list))))
;;; -------- Robotize
@@ -2829,73 +2809,71 @@ the synthesis amplitude, the FFT size, and the radius value."))
(let ((samp-rate 1.0)
(osc-amp 0.3)
- (osc-freq 20)
- (robotize-label "Robotize")
- (robotize-dialog #f)
- (robotize-target 'sound))
-
- (define (post-robotize-dialog)
- (if (not (Widget? robotize-dialog))
- ;; if robotize-dialog doesn't exist, create it
- (let ((initial-samp-rate 1.0)
- (initial-osc-amp 0.3)
- (initial-osc-freq 20)
- (sliders ()))
- (set! robotize-dialog
- (make-effect-dialog
- robotize-label
-
- (lambda (w context info)
- (let ((ms (and (eq? robotize-target 'marks)
- (plausible-mark-samples))))
- (effects-fp samp-rate osc-amp osc-freq
- (if (eq? robotize-target 'sound)
- 0
- (if (eq? robotize-target 'selection)
- (selection-position)
- (car ms)))
- (if (eq? robotize-target 'sound)
- (framples)
- (if (eq? robotize-target 'selection)
- (selection-framples)
- (- (cadr ms) (car ms)))))))
-
- (lambda (w context info)
- (help-dialog "Robotize"
- "Move the sliders to set the sample rate, oscillator amplitude, and oscillator frequency."))
-
- (lambda (w c i)
- (set! samp-rate initial-samp-rate)
- (XtSetValues (car sliders) (list XmNvalue (floor (* samp-rate 100))))
- (set! osc-amp initial-osc-amp)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* osc-amp 100))))
- (set! osc-freq initial-osc-freq)
- (XtSetValues (caddr sliders) (list XmNvalue (floor (* osc-freq 100)))))
-
- (lambda ()
- (effect-target-ok robotize-target))))
-
- (set! sliders
- (add-sliders robotize-dialog
- (list (list "sample rate" 0.0 initial-samp-rate 2.0
- (lambda (w context info)
- (set! samp-rate (/ (.value info) 100.0)))
- 100)
- (list "oscillator amplitude" 0.0 initial-osc-amp 1.0
- (lambda (w context info)
- (set! osc-amp (/ (.value info) 100.0)))
- 100)
- (list "oscillator frequency" 0.0 initial-osc-freq 60
- (lambda (w context info)
- (set! osc-freq (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! robotize-target target)
- (XtSetSensitive (XmMessageBoxGetChild robotize-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog robotize-dialog))
+ (osc-freq 20))
+
+ (define post-robotize-dialog
+ (let ((robotize-label "Robotize")
+ (robotize-dialog #f)
+ (robotize-target 'sound))
+ (lambda ()
+ (unless (Widget? robotize-dialog)
+ ;; if robotize-dialog doesn't exist, create it
+ (let ((initial-samp-rate 1.0)
+ (initial-osc-amp 0.3)
+ (initial-osc-freq 20)
+ (sliders ()))
+ (set! robotize-dialog
+ (make-effect-dialog
+ robotize-label
+
+ (lambda (w context info)
+ (let ((ms (and (eq? robotize-target 'marks)
+ (plausible-mark-samples))))
+ (effects-fp samp-rate osc-amp osc-freq
+ (if (eq? robotize-target 'sound)
+ (values 0
+ (framples))
+ (if (eq? robotize-target 'selection)
+ (values (selection-position)
+ (selection-framples))
+ (values (car ms)
+ (- (cadr ms) (car ms))))))))
+ (lambda (w context info)
+ (help-dialog "Robotize"
+ "Move the sliders to set the sample rate, oscillator amplitude, and oscillator frequency."))
+
+ (lambda (w c i)
+ (set! samp-rate initial-samp-rate)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* samp-rate 100))))
+ (set! osc-amp initial-osc-amp)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* osc-amp 100))))
+ (set! osc-freq initial-osc-freq)
+ (XtSetValues (caddr sliders) (list XmNvalue (floor (* osc-freq 100)))))
+
+ (lambda ()
+ (effect-target-ok robotize-target))))
+
+ (set! sliders
+ (add-sliders robotize-dialog
+ (list (list "sample rate" 0.0 initial-samp-rate 2.0
+ (lambda (w context info)
+ (set! samp-rate (/ (.value info) 100.0)))
+ 100)
+ (list "oscillator amplitude" 0.0 initial-osc-amp 1.0
+ (lambda (w context info)
+ (set! osc-amp (/ (.value info) 100.0)))
+ 100)
+ (list "oscillator frequency" 0.0 initial-osc-freq 60
+ (lambda (w context info)
+ (set! osc-freq (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! robotize-target target)
+ (XtSetSensitive (XmMessageBoxGetChild robotize-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog robotize-dialog))))
(let ((child (XtCreateManagedWidget "Robotize" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2904,53 +2882,53 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-robotize-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Robotize (~1,2F ~1,2F ~1,2F)" samp-rate osc-amp osc-freq)))
- (change-label child new-label)))
+ (change-label child (format #f "Robotize (~1,2F ~1,2F ~1,2F)" samp-rate osc-amp osc-freq)))
misc-menu-list))))
;;; -------- Rubber sound
;;;
- (let ((rubber-factor 1.0)
- (rubber-label "Rubber sound")
- (rubber-dialog #f)
- (rubber-target 'sound))
-
- (define (post-rubber-dialog)
- (if (not (Widget? rubber-dialog))
- ;; if rubber-dialog doesn't exist, create it
- (let ((initial-rubber-factor 1.0)
- (sliders ()))
- (set! rubber-dialog
- (make-effect-dialog
- rubber-label
-
- (lambda (w context info)
- (rubber-sound rubber-factor))
-
- (lambda (w context info)
- (help-dialog "Rubber sound"
- "Stretches or contracts the time of a sound. Move the slider to change the stretch factor."))
-
- (lambda (w c i)
- (set! rubber-factor initial-rubber-factor)
- (XtSetValues (car sliders) (list XmNvalue (floor (* rubber-factor 100)))))
-
- (lambda ()
- (effect-target-ok rubber-target))))
-
- (set! sliders
- (add-sliders rubber-dialog
- (list (list "stretch factor" 0.0 initial-rubber-factor 5.0
- (lambda (w context info)
- (set! rubber-factor (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! rubber-target target)
- (XtSetSensitive (XmMessageBoxGetChild rubber-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
- (activate-dialog rubber-dialog))
+ (let ((rubber-factor 1.0))
+
+ (define post-rubber-dialog
+ (let ((rubber-label "Rubber sound")
+ (rubber-dialog #f)
+ (rubber-target 'sound))
+ (lambda ()
+ (unless (Widget? rubber-dialog)
+ ;; if rubber-dialog doesn't exist, create it
+ (let ((initial-rubber-factor 1.0)
+ (sliders ()))
+ (set! rubber-dialog
+ (make-effect-dialog
+ rubber-label
+
+ (lambda (w context info)
+ (rubber-sound rubber-factor))
+
+ (lambda (w context info)
+ (help-dialog "Rubber sound"
+ "Stretches or contracts the time of a sound. Move the slider to change the stretch factor."))
+
+ (lambda (w c i)
+ (set! rubber-factor initial-rubber-factor)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* rubber-factor 100)))))
+
+ (lambda ()
+ (effect-target-ok rubber-target))))
+
+ (set! sliders
+ (add-sliders rubber-dialog
+ (list (list "stretch factor" 0.0 initial-rubber-factor 5.0
+ (lambda (w context info)
+ (set! rubber-factor (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! rubber-target target)
+ (XtSetSensitive (XmMessageBoxGetChild rubber-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+ (activate-dialog rubber-dialog))))
(let ((child (XtCreateManagedWidget "Rubber sound" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -2959,8 +2937,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-rubber-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Rubber sound (~1,2F)" rubber-factor)))
- (change-label child new-label)))
+ (change-label child (format #f "Rubber sound (~1,2F)" rubber-factor)))
misc-menu-list))))
@@ -2969,67 +2946,66 @@ the synthesis amplitude, the FFT size, and the radius value."))
;;; (progress report)
(let ((wobble-frequency 50)
- (wobble-amplitude 0.5)
- (wobble-label "Wobble")
- (wobble-dialog #f)
- (wobble-target 'sound))
-
- (define (post-wobble-dialog)
- (if (not (Widget? wobble-dialog))
- ;; if wobble-dialog doesn't exist, create it
- (let ((initial-wobble-frequency 50)
- (initial-wobble-amplitude 0.5)
- (sliders ()))
- (set! wobble-dialog
- (make-effect-dialog
- wobble-label
-
- (lambda (w context info)
- (let ((ms (and (eq? wobble-target 'marks)
- (plausible-mark-samples))))
- (effects-hello-dentist
- wobble-frequency wobble-amplitude
- (if (eq? wobble-target 'sound)
- 0
- (if (eq? wobble-target 'selection)
- (selection-position)
- (car ms)))
- (if (eq? wobble-target 'sound)
- (framples)
- (if (eq? wobble-target 'selection)
- (selection-framples)
- (- (cadr ms) (car ms)))))))
-
- (lambda (w context info)
- (help-dialog "Wobble"
- "Move the sliders to set the wobble frequency and amplitude."))
-
- (lambda (w c i)
- (set! wobble-frequency initial-wobble-frequency)
- (XtSetValues (car sliders) (list XmNvalue (floor (* wobble-frequency 100))))
- (set! wobble-amplitude initial-wobble-amplitude)
- (XtSetValues (cadr sliders) (list XmNvalue (floor (* wobble-amplitude 100)))))
-
- (lambda ()
- (effect-target-ok wobble-target))))
-
- (set! sliders
- (add-sliders wobble-dialog
- (list (list "wobble frequency" 0 initial-wobble-frequency 100
- (lambda (w context info)
- (set! wobble-frequency (/ (.value info) 100.0)))
- 100)
- (list "wobble amplitude" 0.0 initial-wobble-amplitude 1.0
- (lambda (w context info)
- (set! wobble-amplitude (/ (.value info) 100.0)))
- 100))))
- (add-target (XtParent (car sliders))
- (lambda (target)
- (set! wobble-target target)
- (XtSetSensitive (XmMessageBoxGetChild wobble-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
- #f)))
-
- (activate-dialog wobble-dialog))
+ (wobble-amplitude 0.5))
+
+ (define post-wobble-dialog
+ (let ((wobble-label "Wobble")
+ (wobble-dialog #f)
+ (wobble-target 'sound))
+ (lambda ()
+ (unless (Widget? wobble-dialog)
+ ;; if wobble-dialog doesn't exist, create it
+ (let ((initial-wobble-frequency 50)
+ (initial-wobble-amplitude 0.5)
+ (sliders ()))
+ (set! wobble-dialog
+ (make-effect-dialog
+ wobble-label
+
+ (lambda (w context info)
+ (let ((ms (and (eq? wobble-target 'marks)
+ (plausible-mark-samples))))
+ (effects-hello-dentist
+ wobble-frequency wobble-amplitude
+ (if (eq? wobble-target 'sound)
+ (values 0
+ (framples))
+ (if (eq? wobble-target 'selection)
+ (values (selection-position)
+ (selection-framples))
+ (values (car ms)
+ (- (cadr ms) (car ms))))))))
+
+ (lambda (w context info)
+ (help-dialog "Wobble"
+ "Move the sliders to set the wobble frequency and amplitude."))
+
+ (lambda (w c i)
+ (set! wobble-frequency initial-wobble-frequency)
+ (XtSetValues (car sliders) (list XmNvalue (floor (* wobble-frequency 100))))
+ (set! wobble-amplitude initial-wobble-amplitude)
+ (XtSetValues (cadr sliders) (list XmNvalue (floor (* wobble-amplitude 100)))))
+
+ (lambda ()
+ (effect-target-ok wobble-target))))
+
+ (set! sliders
+ (add-sliders wobble-dialog
+ (list (list "wobble frequency" 0 initial-wobble-frequency 100
+ (lambda (w context info)
+ (set! wobble-frequency (/ (.value info) 100.0)))
+ 100)
+ (list "wobble amplitude" 0.0 initial-wobble-amplitude 1.0
+ (lambda (w context info)
+ (set! wobble-amplitude (/ (.value info) 100.0)))
+ 100))))
+ (add-target (XtParent (car sliders))
+ (lambda (target)
+ (set! wobble-target target)
+ (XtSetSensitive (XmMessageBoxGetChild wobble-dialog XmDIALOG_OK_BUTTON) (effect-target-ok target)))
+ #f)))
+
+ (activate-dialog wobble-dialog))))
(let ((child (XtCreateManagedWidget "Wobble" xmPushButtonWidgetClass misc-menu
(list XmNbackground *basic-color*))))
@@ -3038,10 +3014,8 @@ the synthesis amplitude, the FFT size, and the radius value."))
(post-wobble-dialog)))
(set! misc-menu-list (cons (lambda ()
- (let ((new-label (format #f "Wobble (~1,2F ~1,2F)" wobble-frequency wobble-amplitude)))
- (change-label child new-label)))
- misc-menu-list))))
- )
+ (change-label child (format #f "Wobble (~1,2F ~1,2F)" wobble-frequency wobble-amplitude)))
+ misc-menu-list)))))
;;;
;;; END PARAMETRIZED EFFECTS
@@ -3051,32 +3025,28 @@ the synthesis amplitude, the FFT size, and the radius value."))
(add-to-menu effects-menu "Octave-down" (lambda () (down-oct 2)))
(add-to-menu effects-menu "Remove clicks"
(lambda ()
- (define (find-click loc)
- (let ((reader (make-sampler loc))
- (mmax (make-moving-max 10))
- (samp0 0.0)
- (samp1 0.0)
- (samp2 0.0)
- (len (framples)))
- (call-with-exit
- (lambda (return)
- (do ((ctr loc (+ ctr 1)))
- ((= ctr len) #f)
- (set! samp0 samp1)
- (set! samp1 samp2)
- (set! samp2 (next-sample reader))
- (let ((local-max (max .1 (moving-max mmax samp0))))
- (if (and (> (abs (- samp0 samp1)) local-max)
- (> (abs (- samp1 samp2)) local-max)
- (< (abs (- samp0 samp2)) (/ local-max 2)))
- (return (- ctr 1)))))))))
- (define (remove-click loc)
- (let ((click (find-click loc)))
- (if click
- (begin
- (smooth-sound (- click 2) 4)
- (remove-click (+ click 2))))))
- (remove-click 0)))
+ (let remove-click ((loc 0))
+ (let ((click (let ((reader (make-sampler loc))
+ (mmax (make-moving-max 10))
+ (samp0 0.0)
+ (samp1 0.0)
+ (samp2 0.0)
+ (len (framples)))
+ (call-with-exit
+ (lambda (return)
+ (do ((ctr loc (+ ctr 1)))
+ ((= ctr len) #f)
+ (set! samp0 samp1)
+ (set! samp1 samp2)
+ (set! samp2 (next-sample reader))
+ (let ((local-max (max .1 (moving-max mmax samp0))))
+ (if (and (> (abs (- samp0 samp1)) local-max)
+ (> (abs (- samp1 samp2)) local-max)
+ (< (abs (- samp0 samp2)) (/ local-max 2)))
+ (return (- ctr 1))))))))))
+ (when click
+ (smooth-sound (- click 2) 4)
+ (remove-click (+ click 2)))))))
(define* (effects-remove-dc snd chn)
(let* ((len (framples snd chn))
diff --git a/noise.scm b/noise.scm
index df6d540..a3d5edc 100644
--- a/noise.scm
+++ b/noise.scm
@@ -20,9 +20,7 @@
(define* (attack-point duration attack decay (total-x 100.0))
(* total-x (/ (if (= 0.0 attack)
- (if (= 0.0 decay)
- (/ duration 4)
- (/ (- duration decay) 4))
+ (/ (if (= 0.0 decay) duration (- duration decay)) 4)
attack)
duration)))
diff --git a/nrev.scm b/nrev.scm
index 0010c20..57b589d 100644
--- a/nrev.scm
+++ b/nrev.scm
@@ -21,17 +21,16 @@
(if (not dly-len)
(let ((srscale (/ *clm-srate* 25641)))
- (define (prime? val)
- (or (= val 2)
- (and (odd? val)
- (do ((i 3 (+ i 2))
- (lim (sqrt val)))
- ((or (= 0 (modulo val i)) (> i lim))
- (> i lim))))))
+
(define (next-prime val)
- (if (prime? val)
+ (if (or (= val 2)
+ (and (odd? val)
+ (do ((i 3 (+ i 2))
+ (lim (sqrt val)))
+ ((or (= 0 (modulo val i)) (> i lim)) (> i lim)))))
val
(next-prime (+ val 2))))
+
(set! dly-len (vector 1433 1601 1867 2053 2251 2399 347 113 37 59 53 43 37 29 19))
(do ((i 0 (+ i 1)))
((= i 15))
diff --git a/numerics.scm b/numerics.scm
index e058304..f0aaa71 100644
--- a/numerics.scm
+++ b/numerics.scm
@@ -74,10 +74,10 @@
;;; --------------------------------------------------------------------------------
;;; from Numerical Recipes
-(define (plgndr l m x) ;Legendre polynomial P m/l (x), m and l integer
- ;0 <= m <= l and -1<= x <= 1 (x real)
+(define (plgndr L m x) ;Legendre polynomial P m/L (x), m and L integer
+ ;0 <= m <= L and -1<= x <= 1 (x real)
(if (or (< m 0)
- (> m l)
+ (> m L)
(> (abs x) 1.0))
(snd-error "invalid arguments to plgndr")
(let ((pmm 1.0)
@@ -91,14 +91,14 @@
((> i m))
(set! pmm (* (- pmm) fact somx2))
(set! fact (+ fact 2.0)))))
- (if (= l m)
+ (if (= L m)
pmm
(let ((pmmp1 (* x pmm (+ (* 2 m) 1))))
- (if (= l (+ m 1))
+ (if (= L (+ m 1))
pmmp1
(let ((pk 0.0)) ; NR used "ll" which is unreadable
(do ((k (+ m 2) (+ k 1)))
- ((> k l))
+ ((> k L))
(set! pk (/ (- (* x (- (* 2 k) 1) pmmp1)
(* (+ k m -1) pmm))
(- k m)))
@@ -154,30 +154,23 @@
(define* (gegenbauer n x (alpha 0.0))
- (if (< alpha -0.5) (set! alpha -0.5))
- (if (= n 0)
- 1.0
- (if (= alpha 0.0) ; maxima and A&S 22.3.14 (gsl has bogus values here)
- (* (/ 2.0 n)
- (cos (* n x)))
- (if (= n 1) ; gsl splits out special cases
- (* 2 alpha x) ; G&R 8.93(2)
- (if (= n 2)
- (- (* 2 alpha (+ alpha 1) x x) alpha) ; G&R 8.93(3)
- (let ((fn1 (* 2 x alpha))
- (fn 0.0)
- (fn2 1.0))
- (if (= n 1)
- fn1
- (do ((k 2 (+ k 1))
- (k0 2.0 (+ k0 1.0)))
- ((> k n) fn)
- (set! fn (/ (- (* 2 x fn1 (+ k alpha -1.0))
- (* fn2 (+ k (* 2 alpha) -2.0)))
- k0))
- (set! fn2 fn1)
- (set! fn1 fn)))))))))
-
+ (set! alpha (max alpha -0.5))
+ (cond ((= n 0) 1.0)
+ ((= alpha 0.0) (* (/ 2.0 n) (cos (* n x)))) ; maxima and A&S 22.3.14 (gsl has bogus values here)
+ ((= n 1) (* 2 alpha x)) ; G&R 8.93(2)
+ ((= n 2) (- (* 2 alpha (+ alpha 1) x x) alpha)) ; G&R 8.93(3)
+ (else
+ (let ((fn1 (* 2 x alpha))
+ (fn 0.0)
+ (fn2 1.0))
+ (if (= n 1)
+ fn1
+ (do ((k 2 (+ k 1))
+ (k0 2.0 (+ k0 1.0)))
+ ((> k n) fn)
+ (set! fn (/ (- (* 2 x fn1 (+ k alpha -1.0)) (* fn2 (+ k (* 2 alpha) -2.0))) k0))
+ (set! fn2 fn1)
+ (set! fn1 fn)))))))
;;; (with-sound (:scaled-to 0.5) (do ((i 0 (+ i 1)) (x 0.0 (+ x .1))) ((= i 10000)) (outa i (gegenbauer 15 (cos x) 1.0))))
@@ -637,21 +630,20 @@
((or (= (modulo n 2) 0) (= (modulo n 3) 0) (= (modulo n 5) 0) (= (modulo n 7) 0)
(= (modulo n 17) 0) (= (modulo n 13) 0) (= (modulo n 257) 0) (= (modulo n 11) 0))
- (let ((divisor (if (= (modulo n 2) 0) 2
- (if (= (modulo n 3) 0) 3
- (if (= (modulo n 5) 0) 5
- (if (= (modulo n 7) 0) 7
- (if (= (modulo n 17) 0) 17
- (if (= (modulo n 13) 0) 13
- (if (= (modulo n 11) 0) 11
- 257)))))))))
- (let ((val (sin-m*pi/n 1 (/ n divisor))))
- (and val
- `(let ((ex ,val))
- (/ (- (expt (+ (sqrt (- 1 (* ex ex))) (* 0+i ex)) (/ 1 ,divisor))
- (expt (- (sqrt (- 1 (* ex ex))) (* 0+i ex)) (/ 1 ,divisor)))
- 0+2i))))))
-
+ (let* ((divisor (cond ((= (modulo n 2) 0) 2)
+ ((= (modulo n 3) 0) 3)
+ ((= (modulo n 5) 0) 5)
+ ((= (modulo n 7) 0) 7)
+ ((= (modulo n 17) 0) 17)
+ ((= (modulo n 13) 0) 13)
+ ((= (modulo n 11) 0) 11)
+ (else 257)))
+ (val (sin-m*pi/n 1 (/ n divisor))))
+ (and val
+ `(let ((ex ,val))
+ (/ (- (expt (+ (sqrt (- 1 (* ex ex))) (* 0+i ex)) (/ 1 ,divisor))
+ (expt (- (sqrt (- 1 (* ex ex))) (* 0+i ex)) (/ 1 ,divisor)))
+ 0+2i)))))
(else #f))))
#|
@@ -671,7 +663,7 @@
(begin
(set! maxerr err)
(set! max-case (/ m n)))))))))
- (format #t "sin-m*pi/n (~A cases) max err ~A at ~A~%" cases maxerr max-case))
+ (format () "sin-m*pi/n (~A cases) max err ~A at ~A~%" cases maxerr max-case))
:(sin (/ pi (* 257 17)))
0.00071906440440859
@@ -711,53 +703,54 @@
(set! (chx i) (hx (floor y))))
chx))
- (define expm
- (let* ((ntp 25)
- (tp1 0)
- (tp (make-vector ntp)))
- (lambda (p ak)
- ;; expm = 16^p mod ak. This routine uses the left-to-right binary exponentiation scheme.
-
- ;; If this is the first call to expm, fill the power of two table tp.
- (if (= tp1 0)
- (begin
- (set! tp1 1)
- (set! (tp 0) 1.0)
- (do ((i 1 (+ i 1)))
- ((= i ntp))
- (set! (tp i) (* 2.0 (tp (- i 1)))))))
-
- (if (= ak 1.0)
- 0.0
- (let ((pl -1))
- ;; Find the greatest power of two less than or equal to p.
- (do ((i 0 (+ i 1)))
- ((or (not (= pl -1))
- (= i ntp)))
- (if (> (tp i) p)
- (set! pl i)))
-
- (if (= pl -1) (set! pl ntp))
- (let ((pt (tp (- pl 1)))
- (p1 p)
- (r 1.0))
- ;; Perform binary exponentiation algorithm modulo ak.
-
- (do ((j 1 (+ j 1)))
- ((> j pl) r)
- (if (>= p1 pt)
- (begin
- (set! r (* 16.0 r))
- (set! r (- r (* ak (floor (/ r ak)))))
- (set! p1 (- p1 pt))))
- (set! pt (* 0.5 pt))
- (if (>= pt 1.0)
- (begin
- (set! r (* r r))
- (set! r (- r (* ak (floor (/ r ak))))))))))))))
-
(define (series m id)
;; This routine evaluates the series sum_k 16^(id-k)/(8*k+m) using the modular exponentiation technique.
+
+ (define expm
+ (let* ((ntp 25)
+ (tp1 0)
+ (tp (make-vector ntp)))
+ (lambda (p ak)
+ ;; expm = 16^p mod ak. This routine uses the left-to-right binary exponentiation scheme.
+
+ ;; If this is the first call to expm, fill the power of two table tp.
+ (if (= tp1 0)
+ (begin
+ (set! tp1 1)
+ (set! (tp 0) 1.0)
+ (do ((i 1 (+ i 1)))
+ ((= i ntp))
+ (set! (tp i) (* 2.0 (tp (- i 1)))))))
+
+ (if (= ak 1.0)
+ 0.0
+ (let ((pl -1))
+ ;; Find the greatest power of two less than or equal to p.
+ (do ((i 0 (+ i 1)))
+ ((or (not (= pl -1))
+ (= i ntp)))
+ (if (> (tp i) p)
+ (set! pl i)))
+
+ (if (= pl -1) (set! pl ntp))
+ (let ((pt (tp (- pl 1)))
+ (p1 p)
+ (r 1.0))
+ ;; Perform binary exponentiation algorithm modulo ak.
+
+ (do ((j 1 (+ j 1)))
+ ((> j pl) r)
+ (if (>= p1 pt)
+ (begin
+ (set! r (* 16.0 r))
+ (set! r (- r (* ak (floor (/ r ak)))))
+ (set! p1 (- p1 pt))))
+ (set! pt (* 0.5 pt))
+ (if (>= pt 1.0)
+ (begin
+ (set! r (* r r))
+ (set! r (- r (* ak (floor (/ r ak))))))))))))))
+
(let ((eps 1e-17)
(s 0.0))
(do ((k 0 (+ k 1)))
@@ -784,7 +777,7 @@
(s2 (series 4 id))
(s3 (series 5 id))
(s4 (series 6 id))
- (pid (+ (* 4.0 s1) (* -2.0 s2) (- s3) (- s4))))
+ (pid (- (+ (* 4.0 s1) (* -2.0 s2)) s3 s4)))
(set! pid (+ 1.0 (- pid (floor pid))))
(ihex pid 10 chx)
(format #t " position = ~D~% fraction = ~,15F~% hex digits = ~S~%" id pid chx)))
diff --git a/peak-phases.scm b/peak-phases.scm
index a3afe28..cf6b260 100644
--- a/peak-phases.scm
+++ b/peak-phases.scm
@@ -35,7 +35,7 @@
;;
;; let peak-loc = (acos (/ (- (sqrt 33) 1) 8))
;; peak (+ (sin peak-loc) (sin (* 2 peak-loc)))
-;; and assume we're focusing on the 1st min (not pi)
+;; and assume we're focusing on the first min (not pi)
;;
;; sin(peak-loc) + sin(2*peak-loc + phase) <= peak
;; so sin(2*peak-loc (i.e. 1.8718) + phase) < (peak - sin(peak-loc)) = 0.9551, but that means phase >= 0 (sin is going down at this point)
@@ -625,8 +625,8 @@
6.911687 (fv 0.000000 1.423917 -0.117078 -0.215912 1.065526 1.018507 0.645263 1.632151 0.540556 0.415851 1.870183 1.161732 0.983376 1.723916 0.372700 0.063452 0.534166 1.512588 1.454603 0.719318 0.962295 1.537720 1.562020 1.433858 0.930756 1.181983 1.504188 -0.167777 1.662278 0.680834 0.246207 0.675469 0.268474 1.089455 0.369548 -0.146942 -0.055836 1.091821 1.976652 0.486415 1.202030 0.175707 0.854435 0.506884 1.646470 0.139127 0.235704 1.857608 0.297006)
;; 50-1
- 6.910295 #(0.000000 1.059948 1.102312 -0.154766 0.271011 1.001259 -0.322228 0.611181 1.084580 0.193049 1.708690 0.549448 0.114307 -0.112275 1.323751 1.621007 1.041438 1.446405 0.346446 0.779211 0.803707 0.229069 1.620947 -0.129471 -0.141064 0.581982 -0.069220 1.242954 -0.424957 -0.059702 -0.076232 1.090459 1.897927 -0.587283 0.232044 0.877329 -0.465364 1.521832 1.430023 0.510607 0.119336 0.032708 0.304452 0.848312 0.725150 0.798920 0.612486 0.214940 1.234846)
- 6.907185 #(0.000000 1.059469 1.114179 -0.150791 0.258478 0.994889 -0.336259 0.599168 1.084896 0.192104 1.698208 0.543042 0.115884 -0.128271 1.314296 1.621485 1.044197 1.442142 0.334969 0.776113 0.823403 0.227295 1.618113 -0.132905 -0.144839 0.578330 -0.074014 1.260097 -0.447140 -0.067108 -0.086664 1.078815 1.896924 -0.604152 0.214555 0.862267 -0.492164 1.511993 1.411560 0.503434 0.119933 0.010833 0.282277 0.838215 0.717315 0.788849 0.600355 0.201253 1.210362)
+ 6.874368 #(0.000000 1.204417 0.954334 -0.405108 0.059322 1.004871 -0.307909 0.766418 1.079079 0.002645 1.437193 0.338324 0.101886 -0.559571 1.466710 1.621612 0.973989 1.377429 0.337678 1.035741 0.679343 0.146983 1.275159 -0.370675 -0.331425 0.304277 -0.450477 1.075881 -0.790453 -0.423723 -0.417480 0.648387 -0.501882 -0.980950 -0.159587 0.593728 -0.757113 1.129266 0.980355 0.172786 -0.231542 -0.093435 -0.126900 0.604505 0.503262 0.476708 0.056575 0.183795 0.839623)
+ 6.871628 #(0.000000 1.197339 0.943600 -0.418761 0.049685 1.002197 -0.323377 0.763534 1.062841 -0.005796 1.425933 0.322430 0.084053 -0.585670 1.449690 1.603999 0.946354 1.356731 0.301596 1.002372 0.650650 0.119315 1.243049 -0.407370 -0.367523 0.258301 -0.505816 1.032723 -0.832489 -0.467654 -0.467807 0.598599 -0.548874 -1.027291 -0.206361 0.534378 -0.811327 1.081884 0.922436 0.108022 -0.303016 -0.150120 -0.199521 0.546600 0.438688 0.415808 -0.008696 0.110784 0.758574)
)
;;; 50 all -------------------------------------------------------------------------------- ; 7.071
@@ -638,25 +638,28 @@
7.064944 #(0.000000 1.558009 -0.108565 -0.226913 0.920197 1.180894 0.537671 1.554384 0.613756 0.458358 0.091191 1.387557 0.869986 1.858139 0.547904 0.135691 0.583740 1.710905 1.421339 0.744505 1.032127 1.414994 1.701011 1.686329 0.940524 1.064348 1.388446 -0.279583 1.723434 0.898036 0.320378 0.547937 0.335420 1.264319 0.407052 0.022184 -0.017105 0.905945 1.912730 0.523724 1.239641 0.158867 0.840449 0.693502 1.785642 0.002311 0.342012 1.897108 0.429747 0.359280)
;; 51-1?
- 6.967233 #(0.000000 0.970268 1.092398 1.888744 0.176055 1.242915 -0.182630 0.498873 0.714528 0.065776 1.516006 0.488189 0.172228 1.824642 1.137081 1.246514 0.918186 1.083274 0.311853 0.739323 0.800717 0.461460 1.390793 1.467948 1.702761 -0.157496 0.172343 0.955766 -0.200187 -0.202194 -0.109455 0.590305 1.500923 -0.065490 1.470764 0.488682 -0.351464 1.288146 1.359535 0.275868 1.584539 0.037303 -0.097518 0.950689 0.185166 0.880435 0.283304 -0.239816 1.354407 1.605268)
6.966444 #(0.000000 0.969561 1.094228 1.889603 0.178237 1.243506 -0.179029 0.498784 0.715615 0.064553 1.519591 0.490911 0.171201 1.825529 1.138600 1.243991 0.920476 1.084610 0.315165 0.739666 0.806931 0.459500 1.392905 1.470398 1.703973 -0.154232 0.175316 0.961121 -0.195877 -0.203581 -0.104914 0.596805 1.500152 -0.064411 1.474852 0.495330 -0.345550 1.291380 1.361659 0.279253 1.587805 0.037979 -0.094175 0.955070 0.189359 0.883451 0.286407 -0.239876 1.359571 1.605865)
+ 6.966047 #(0.000000 0.962905 1.097330 1.888512 0.176170 1.249181 -0.168544 0.509171 0.717525 0.069686 1.526076 0.503308 0.181151 1.831084 1.142478 1.254775 0.935821 1.099009 0.324329 0.750637 0.817716 0.473950 1.405312 1.489970 1.715244 -0.138333 0.191055 0.986798 -0.177541 -0.183900 -0.081646 0.626605 1.530354 -0.052123 1.504605 0.533551 -0.327117 1.309658 1.385783 0.305850 1.613358 0.056196 -0.069816 0.982784 0.217704 0.915410 0.315681 -0.214270 1.383464 1.628385)
)
;;; 51 all -------------------------------------------------------------------------------- ; 7.141
(vector 51 8.8213935921978 (fv 0 0 1 0 1 1 1 1 1 0 1 1 1 0 1 0 1 1 1 1 1 1 1 0 0 1 0 1 0 0 0 0 0 1 1 1 1 0 1 1 1 0 0 1 0 1 1 1 0 0 1)
7.062061 (fv 0.000000 1.277482 1.272374 1.604932 -0.114681 1.091849 -0.113655 0.581995 0.517152 0.112646 1.392203 0.473053 0.525951 1.781540 1.014930 1.311666 0.597941 1.173291 0.649975 0.688396 0.657382 0.570575 1.699334 1.669408 1.662666 -0.233111 0.196711 0.718758 -0.174442 0.105462 -0.039308 0.924279 1.329687 1.401301 1.538357 0.347724 -0.110320 1.449195 1.223831 0.349599 1.470761 0.191238 1.885833 0.819453 0.145490 0.967802 0.015777 -0.014902 1.276127 1.513254 0.227467)
- 7.061972 #(0.000000 1.276628 1.273765 1.607581 -0.114970 1.091264 -0.113040 0.580864 0.516735 0.113082 1.390932 0.474109 0.525638 1.784132 1.017927 1.316859 0.597754 1.174733 0.647452 0.691328 0.661372 0.567341 1.701460 1.671297 1.665426 -0.232474 0.194748 0.720612 -0.170875 0.103745 -0.037365 0.924964 1.329745 1.406880 1.540907 0.349954 -0.109891 1.449476 1.227519 0.347601 1.477324 0.191963 1.887908 0.821661 0.147626 0.967297 0.015607 -0.013051 1.280470 1.516669 0.226095)
+ 6.975170 #(0.000000 1.372924 1.059217 -0.645861 1.097945 1.058807 0.153152 0.527074 0.651159 0.424719 0.459322 0.332180 0.264613 -0.372847 0.683198 1.120562 0.213922 0.685600 0.345552 0.459914 1.129925 0.756644 0.458857 -0.052979 1.594004 -0.921247 0.485511 1.115573 -0.083642 0.773245 0.508692 1.481091 0.025171 1.228864 1.684948 0.240036 0.474172 0.435815 1.326902 1.195703 -0.007047 1.017216 0.874417 1.846797 0.909867 1.892877 1.240478 -0.484663 1.778802 -0.122729 0.589405)
+ 6.971782 #(0.000000 1.381134 1.053573 -0.642284 1.106927 1.065731 0.156795 0.531640 0.658480 0.423307 0.458153 0.332929 0.258309 -0.378345 0.690163 1.115051 0.213852 0.690863 0.353610 0.459744 1.132735 0.758828 0.447315 -0.071617 1.577100 -0.919334 0.495653 1.111932 -0.086022 0.770249 0.516654 1.486418 0.018200 1.218929 1.677748 0.244186 0.465632 0.411266 1.326302 1.201131 -0.010901 1.028025 0.862583 1.846154 0.922121 1.887046 1.218211 -0.479984 1.767657 -0.113149 0.573554)
)
;;; 52 all -------------------------------------------------------------------------------- ; 7.211
(vector 52 8.9920463562012 (fv 0 1 1 0 1 0 0 0 0 0 1 0 0 0 1 0 1 1 1 0 0 1 1 0 1 1 0 1 0 1 0 0 0 0 1 0 0 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0)
7.134954 (fv 0.000000 0.621560 1.464578 1.482376 0.135707 1.345519 0.584967 0.540885 1.784345 0.393329 1.745283 0.530433 1.414971 1.247472 1.329889 0.999552 0.933504 1.580199 0.519254 0.315472 0.473007 1.123477 -0.056053 0.241576 0.391709 1.244898 1.883529 1.120931 1.698334 -0.149261 0.218191 1.134898 0.533381 1.222211 0.249553 -0.114715 1.262472 0.846800 0.877356 0.688478 0.673983 1.103698 1.385836 1.036560 1.331275 0.414915 1.604362 0.874160 0.543444 1.406115 1.239524 0.816202)
- 7.131761 #(0.000000 0.537475 1.434186 1.485257 0.169881 1.416948 0.579251 0.545053 1.903917 0.399401 1.765906 0.542670 1.396121 1.264296 1.322696 0.985374 0.995894 1.591655 0.505552 0.250919 0.433406 1.124308 -0.040021 0.168815 0.391865 1.242269 1.875020 1.121196 1.704677 -0.131089 0.170120 1.111726 0.615076 1.228577 0.309881 -0.149015 1.305694 0.861912 0.914108 0.664306 0.720147 1.136263 1.351328 1.011200 1.402304 0.485461 1.536405 0.819898 0.530949 1.451849 1.212610 0.799774)
+ 7.102459 #(0.000000 0.648837 1.347937 1.394205 0.228772 1.369761 0.659192 0.578381 -0.056010 0.281439 1.788400 0.481565 1.424466 1.245338 1.307438 1.071654 0.849375 1.612358 0.470180 0.053038 0.353912 1.080684 -0.161116 0.151468 0.433202 1.019193 1.757938 0.968555 1.596947 -0.203879 0.025193 0.991804 0.446937 1.059356 0.023869 -0.400100 1.079870 0.688268 0.741558 0.481001 0.496940 1.006445 1.004308 0.856157 1.144916 0.288878 1.267244 0.487227 0.316277 1.265206 1.008151 0.448535)
+ 7.101828 #(0.000000 0.646351 1.348437 1.394446 0.228508 1.370485 0.660337 0.579558 -0.056026 0.283749 1.791709 0.481733 1.428712 1.245523 1.307690 1.074069 0.851835 1.612005 0.472059 0.051512 0.355641 1.080975 -0.158863 0.150463 0.435366 1.019121 1.758753 0.965820 1.596435 -0.205826 0.026983 0.989221 0.450040 1.062201 0.025319 -0.395664 1.085851 0.689762 0.740855 0.484733 0.501691 1.010487 1.006025 0.857003 1.147326 0.289999 1.266663 0.490356 0.319639 1.268445 1.014342 0.448435)
;; 51+1
- 7.189639 #(0.000000 1.613047 1.226926 1.461226 -0.208975 1.160308 0.015278 0.874276 0.441796 0.145203 1.228806 0.566007 0.867165 1.631256 1.099751 1.575849 0.905365 1.096254 1.105187 0.482059 0.890391 0.608271 1.917275 1.824879 1.614793 0.165400 0.031023 0.768526 0.036022 0.101130 0.266024 1.042278 1.643239 1.401788 1.800366 0.504130 0.383632 -0.022284 1.238194 0.732080 1.858191 0.525715 0.107150 0.590054 0.832408 1.192418 0.215401 0.405342 1.484800 1.897855 1.002469 0.467126)
+ 7.145012 #(0.000000 1.352385 1.096112 -0.482272 0.885332 0.870800 0.112570 0.382211 0.798266 0.531129 0.345406 0.278068 0.081547 -0.522592 0.532216 1.052537 0.102793 0.798891 0.416786 0.277444 0.906912 0.754729 0.700156 -0.252504 1.434329 -1.160114 0.522833 0.926005 -0.230879 0.705542 0.399151 1.195170 -0.005753 1.038829 1.626916 0.206308 0.196067 0.121343 1.290769 1.164188 0.034677 0.629244 0.574748 1.749902 0.694682 1.749273 1.187350 -0.674905 1.512501 -0.358396 0.363063 -0.122492)
+ 7.144789 #(0.000000 1.352391 1.096101 -0.482270 0.885354 0.870760 0.112575 0.382220 0.798263 0.531121 0.345380 0.278012 0.081522 -0.522597 0.532194 1.052519 0.102779 0.798921 0.416757 0.277445 0.906956 0.754684 0.700152 -0.252540 1.434318 -1.160054 0.522800 0.925955 -0.230874 0.705534 0.399191 1.195193 -0.005723 1.038783 1.626886 0.206343 0.196079 0.121327 1.290786 1.164142 0.034729 0.629201 0.574727 1.749850 0.694693 1.749269 1.187356 -0.674899 1.512518 -0.358412 0.362988 -0.122524)
)
;;; 53 all -------------------------------------------------------------------------------- ; 7.280
@@ -665,20 +668,25 @@
7.198047 (fv 0.000000 0.609644 0.849387 1.600527 1.158365 1.715833 0.524245 -0.059778 0.291176 0.319451 0.985683 1.372433 1.089427 1.749317 1.594481 0.166060 0.927925 -0.362027 0.850015 1.635397 0.732972 1.007069 0.880865 0.290674 0.176669 0.886718 1.772633 0.908528 -0.020813 0.082874 0.257671 1.590012 0.330359 1.893554 1.401328 1.102801 0.720925 0.360594 1.357080 1.833049 0.574052 1.403405 1.851942 1.638866 1.670052 -0.125543 1.654904 0.840665 0.189500 1.798641 0.330271 0.101100 1.702877)
;; 54-1
- 7.246308 #(0.000000 1.532310 -0.094995 1.372753 -0.225031 1.502079 0.056954 0.367578 1.317903 -0.308906 0.288435 -0.135988 0.144140 1.007501 -0.258190 0.832754 1.691061 0.210863 0.421782 1.089380 1.093649 0.443939 0.473594 0.319946 1.564712 -0.127810 1.590182 1.208800 1.280863 -0.068396 1.806097 1.025552 0.141011 1.391092 0.873396 0.397519 1.327658 0.757527 1.353264 0.340770 0.460425 0.732779 1.339617 0.707719 1.128519 1.697349 1.656716 0.826604 0.294361 0.406394 0.110907 1.094470 0.337662)
+ 7.176884 #(0.000000 0.737356 0.760874 1.677578 1.139788 1.733776 0.512545 0.168962 0.294969 0.278922 1.229915 1.512859 1.087438 -0.081926 1.604920 0.197320 1.063397 -0.398250 0.879705 1.816289 0.744289 1.022891 1.064721 0.415657 0.347902 0.773736 1.527156 1.136404 0.028489 0.350665 0.276554 1.845571 0.604279 0.038246 1.467967 1.374232 0.791320 0.557650 1.482264 -0.049230 0.938062 1.746697 0.132063 1.652819 1.777078 0.039226 1.666124 1.061506 0.103648 0.026453 0.558713 0.008013 0.082476)
+ 7.170025 #(0.000000 0.735367 0.761108 1.674444 1.148859 1.727214 0.506019 0.166885 0.301941 0.289424 1.228914 1.514765 1.088336 -0.084927 1.605465 0.191699 1.059128 -0.394739 0.884851 1.807751 0.747579 1.030098 1.071564 0.404714 0.353145 0.766117 1.522688 1.133668 0.028958 0.353932 0.272825 1.843589 0.590551 0.041758 1.471960 1.368203 0.792332 0.554867 1.486774 -0.039669 0.938500 1.744333 0.139825 1.659686 1.776069 0.036261 1.664792 1.057651 0.104623 0.024123 0.551601 0.015304 0.093561)
+ 7.168422 #(0.000000 0.734800 0.755002 1.678637 1.148472 1.726884 0.506566 0.162329 0.304752 0.290731 1.237477 1.522988 1.097235 -0.074667 1.611785 0.203012 1.069009 -0.398864 0.892774 1.815871 0.743283 1.031741 1.066124 0.407989 0.358481 0.762020 1.519272 1.133826 0.019027 0.362472 0.267333 1.835621 0.594226 0.045578 1.461712 1.370620 0.794797 0.554188 1.488530 -0.030031 0.948673 1.753818 0.146713 1.671920 1.781890 0.035858 1.658572 1.054561 0.107770 0.028848 0.546289 0.017191 0.104880)
)
;;; 54 all -------------------------------------------------------------------------------- ; 7.348
(vector 54 9.1825122833252 (fv 0 1 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0 0 0 1 1 1 1 0 0 1 0 1 1 1 1 1 1 0 1 1 1 0 1 1 0 0 0 0 1 0 0 1 1)
7.253898 (fv 0.000000 1.663275 -0.127344 1.382101 -0.144643 1.243444 0.071415 0.455351 1.200018 -0.228088 0.114774 0.009236 0.130605 1.041538 -0.220166 0.676007 1.432141 0.450339 0.554653 1.087402 1.040513 0.270076 0.433523 0.188787 1.457394 -0.061608 1.604147 1.071620 1.033490 -0.059301 1.622008 1.136168 0.012303 1.419176 0.768515 0.526817 1.171505 0.678139 1.461086 0.399056 0.554571 0.834287 1.199853 0.770698 1.010430 1.778823 1.630548 0.874770 0.206125 0.453526 0.079377 1.237714 0.535149 0.779971)
- 7.251376 #(0.000000 1.671606 -0.132668 1.341878 -0.143910 1.246587 0.061425 0.494279 1.199722 -0.185866 0.117035 0.003655 0.151884 1.021723 -0.210779 0.641242 1.366533 0.459003 0.565412 1.109528 1.023492 0.285228 0.454125 0.242355 1.465689 -0.057208 1.627387 1.006195 1.007496 -0.044962 1.574220 1.136668 0.030509 1.454684 0.778081 0.519496 1.098118 0.703324 1.453053 0.377008 0.578494 0.803467 1.196201 0.736893 1.011210 1.821383 1.576365 0.863547 0.163595 0.432959 0.102185 1.227214 0.512712 0.787061)
+ 7.246128 #(0.000000 1.690671 -0.136333 1.336875 -0.134620 1.250743 0.054577 0.501967 1.180021 -0.191687 0.078154 -0.016563 0.154368 1.002103 -0.214317 0.587755 1.338737 0.453959 0.537717 1.091959 0.985931 0.262538 0.420710 0.232601 1.445283 -0.098407 1.587696 0.956027 0.987798 -0.092532 1.496016 1.083347 0.008893 1.420578 0.727868 0.503289 1.042996 0.653965 1.415827 0.315669 0.540912 0.741976 1.142476 0.660826 0.954089 1.754673 1.467880 0.779704 0.086156 0.370375 0.034370 1.174035 0.430349 0.715725)
+ 7.245591 #(0.000000 1.686555 -0.134051 1.339159 -0.139744 1.249317 0.052837 0.496203 1.186868 -0.190398 0.085087 -0.014578 0.148546 1.002089 -0.222856 0.596406 1.341405 0.448014 0.534314 1.092500 0.986488 0.256202 0.422281 0.225300 1.439830 -0.098135 1.589744 0.958350 0.982778 -0.091329 1.504731 1.087277 -0.000312 1.417081 0.729922 0.495573 1.045881 0.653448 1.408480 0.315198 0.535103 0.741972 1.142084 0.667364 0.951873 1.748001 1.479988 0.783357 0.087811 0.364817 0.035646 1.164454 0.433389 0.712104)
)
;;; 55 all -------------------------------------------------------------------------------- ; 7.416
(vector 55 9.0889595835043 (fv 0 0 1 0 0 1 0 0 1 1 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0 1 0 0 0 0 1 1 1 1 1 1 0 1 0 1 1 1 0 1 1 1 1 1 0 1 1 0 1 0 1)
7.328036 (fv 0.000000 0.947722 0.378414 1.734925 1.134763 1.116950 -0.197611 1.060282 0.984801 1.744033 0.450580 0.852453 1.635373 0.966832 1.084419 1.003901 1.404608 1.476265 -0.291566 1.533682 1.691990 0.972863 0.920394 1.410967 0.405768 0.418479 1.362359 0.024022 1.434953 0.091943 0.952661 1.025574 1.292952 0.834214 1.423909 0.663594 1.666584 0.346034 0.453528 -0.158265 1.069551 0.339500 0.250235 -0.001369 1.635787 0.775741 0.405595 1.391152 1.825120 -0.221132 -0.233774 0.866177 1.169485 0.610484 1.501517)
+ 7.300139 #(0.000000 1.020956 0.293768 1.798256 1.119674 1.146994 -0.132937 1.003662 0.949888 1.796803 0.459925 0.880925 1.582417 0.875464 1.100289 0.952720 1.490815 1.407379 -0.298626 1.479744 1.580341 1.028316 0.802627 1.364981 0.250262 0.211014 1.412363 -0.072953 1.428751 0.047277 0.916222 0.964928 1.114795 0.871317 1.452807 0.648605 1.592871 0.307802 0.554241 -0.122514 1.103516 0.321014 0.250400 0.032285 1.623249 0.802559 0.366667 1.421272 1.732780 -0.264221 -0.262668 0.728446 1.186912 0.469786 1.716376)
+ 7.299987 #(0.000000 1.020969 0.293796 1.798197 1.119668 1.147020 -0.132959 1.003677 0.949931 1.796829 0.459947 0.880914 1.582469 0.875424 1.100277 0.952769 1.490876 1.407382 -0.298616 1.479769 1.580356 1.028332 0.802614 1.364991 0.250327 0.211041 1.412324 -0.072992 1.428778 0.047292 0.916259 0.964910 1.114739 0.871338 1.452857 0.648648 1.592866 0.307820 0.554266 -0.122522 1.103511 0.320958 0.250360 0.032244 1.623283 0.802510 0.366699 1.421281 1.732770 -0.264247 -0.262690 0.728471 1.186845 0.469835 1.716425)
;; 54+1
7.432099 #(0.000000 1.618747 -0.153449 1.551651 0.057022 0.983319 0.329322 0.592671 1.061368 -0.265451 0.093666 0.073689 0.191970 0.941940 -0.226532 0.630718 1.504459 0.398912 0.677456 0.969759 0.922508 0.474687 0.473824 0.106191 1.485519 0.211317 1.508720 1.087336 1.052013 0.035924 1.550864 1.050089 0.185510 1.339619 0.715238 0.544593 0.922333 0.813638 1.418714 0.428930 0.510114 0.892067 1.174189 0.405049 1.026718 -0.076773 1.305507 0.682450 0.215555 0.324834 -0.145842 1.269187 0.603278 0.899585 -0.345857)
@@ -695,6 +703,7 @@
7.442633 (fv 0.000000 0.628456 1.084630 0.786609 1.548782 0.496773 0.435493 0.422694 1.803774 0.918361 0.997194 1.049098 0.185525 0.660957 1.525706 1.561906 1.871425 -0.071743 1.628047 1.493214 -0.116955 0.206404 -0.134909 1.268493 0.758821 0.611040 1.564268 1.138473 1.072129 1.438518 1.711282 0.723211 0.929199 1.378242 0.744685 0.403345 1.655964 0.451399 1.464052 1.394001 0.957137 1.897197 1.337811 0.214489 1.090057 0.644474 1.099729 1.418576 0.330091 1.432560 0.258645 0.901692 0.058744 1.707516 1.251524 1.445949 1.245045)
7.441636 #(0.000000 0.622348 1.085878 0.781116 1.543398 0.503464 0.436201 0.436360 1.804081 0.922203 0.997170 1.054550 0.182189 0.658266 1.514505 1.560476 1.876098 -0.073438 1.631568 1.494541 -0.115431 0.197586 -0.136568 1.260188 0.759194 0.602693 1.552249 1.137538 1.078917 1.441614 1.707363 0.723396 0.932457 1.367004 0.727498 0.408065 1.643814 0.447632 1.455697 1.392558 0.945330 1.895625 1.343191 0.216675 1.082075 0.643569 1.094957 1.407053 0.340178 1.425341 0.271660 0.889612 0.056066 1.700603 1.245948 1.440641 1.250791)
+ 7.441467 #(0.000000 0.622317 1.086709 0.781210 1.543555 0.503242 0.435992 0.435167 1.805588 0.922076 0.997063 1.053812 0.182167 0.657560 1.514895 1.560202 1.875822 -0.073404 1.631644 1.494624 -0.115787 0.198249 -0.137542 1.260390 0.759500 0.603371 1.553048 1.137852 1.078723 1.442159 1.707807 0.723280 0.931846 1.367412 0.727839 0.407781 1.645303 0.447632 1.455182 1.393340 0.945452 1.895842 1.343341 0.216348 1.083126 0.643542 1.095796 1.407207 0.340817 1.425984 0.271019 0.890314 0.056560 1.699782 1.246486 1.440900 1.252017)
;; 56+1
7.588529 #(0.000000 1.559006 1.528143 -0.234828 1.510743 0.072763 1.134383 1.362254 0.303204 1.570684 -0.091506 0.027141 0.127155 1.600459 1.489127 0.559851 0.585109 1.217750 0.060591 0.195572 1.371350 0.291252 1.406886 1.100984 -0.016324 1.766768 0.695302 0.610137 0.999643 1.441896 1.186797 1.655783 1.557906 1.163328 -0.045033 0.552673 1.529458 1.154094 0.507727 0.569429 0.791719 0.355519 0.577628 0.178344 0.617622 -0.241675 1.589877 0.728380 1.261435 0.065292 1.580960 -0.002275 1.148223 0.618586 1.286855 -1.867003 0.103477)
@@ -717,7 +726,7 @@
7.533390 #(0.000000 0.631892 1.030548 0.996535 1.749363 0.527130 0.477024 0.368639 1.802926 1.003296 1.026792 0.861445 0.354012 0.677047 1.520092 1.568568 1.887052 -0.077599 1.681866 1.559188 -0.163779 -0.032281 -0.010624 1.336711 0.753633 0.560677 1.590572 1.250944 1.018806 1.569329 1.806513 0.820053 1.037991 1.389344 0.762236 0.480656 1.661302 0.465658 1.499904 1.500135 0.971523 1.890287 1.276369 0.072382 1.249962 0.582710 1.223535 1.436175 0.383524 1.412000 0.135455 0.769171 0.142483 1.827353 1.151930 1.547046 1.202745 -0.195258)
7.481139 #(0.000000 0.494120 0.912027 1.088506 1.796520 0.662315 0.621396 0.504785 1.809811 0.899674 1.186628 0.627937 0.587445 0.746949 1.418182 1.435063 1.844205 -0.044267 1.752818 1.424221 -0.141018 -0.093784 -0.133478 1.461699 0.840220 0.767006 1.740731 1.152491 1.108382 1.653182 1.853596 0.981136 1.198681 1.579726 0.839579 0.463906 1.810603 0.643978 1.514569 1.529989 1.033048 0.123830 1.430921 0.210010 1.371841 0.593103 1.143424 1.331116 0.451352 1.357884 0.020742 0.723087 0.311054 -0.015301 1.089900 1.570530 1.273463 -0.350924)
- 7.472170 #(0.000000 0.430844 0.953515 1.095387 1.834428 0.602659 0.597853 0.392425 1.797011 0.826392 1.113427 0.446408 0.529227 0.680942 1.329125 1.343688 1.818639 -0.122172 1.616802 1.292467 -0.195382 -0.212590 -0.247151 1.374774 0.796549 0.699593 1.645545 0.964816 1.084815 1.558580 1.737062 0.927802 1.039786 1.477445 0.712702 0.296961 1.758646 0.488444 1.376075 1.455278 0.882990 -0.037083 1.238179 0.077306 1.133427 0.444398 0.934392 1.211465 0.276242 1.242882 -0.192105 0.541924 0.088132 -0.286088 0.846397 1.327678 1.119123 -0.618251)
+ 7.471443 #(0.000000 0.426257 0.958229 1.101908 1.838005 0.610307 0.610431 0.402294 1.784945 0.821317 1.119801 0.451192 0.541444 0.688311 1.334853 1.336110 1.825022 -0.121597 1.624253 1.303585 -0.201276 -0.206522 -0.234612 1.368607 0.780881 0.700656 1.644105 0.970363 1.079078 1.564363 1.736314 0.925048 1.037757 1.476082 0.706932 0.300800 1.747548 0.507618 1.347506 1.440798 0.870823 -0.047835 1.238022 0.066382 1.125573 0.437220 0.934851 1.197820 0.289481 1.232537 -0.191118 0.529022 0.086441 -0.284966 0.840338 1.327489 1.118018 -0.608987)
)
;;; 59 all -------------------------------------------------------------------------------- ; 7.6811
@@ -730,13 +739,25 @@
; 58+1
7.567729 #(0.000000 0.753874 1.108606 0.974281 0.283985 0.662033 0.650997 0.171167 1.713034 0.855505 1.018749 0.891985 0.435917 0.540560 1.459830 1.555159 -0.222214 -0.376165 1.777521 1.607719 -0.138482 -0.185224 0.145078 1.584935 1.029502 0.327951 1.867036 1.174458 1.172033 1.652747 -0.202580 1.284972 0.919829 1.617599 1.002052 0.275343 0.183263 0.550709 1.391786 1.438151 1.764529 0.225407 1.674751 0.321832 1.364256 0.748496 1.336450 1.931791 0.857675 1.688807 0.307620 0.802036 0.148078 0.020000 1.074227 1.654778 1.010253 0.016684 -0.457710)
- 7.555219 #(0.000000 0.684018 1.137315 0.968223 0.237663 0.655411 0.703581 0.179129 1.756606 0.877973 1.046593 1.013282 0.452948 0.616147 1.401809 1.505193 -0.202722 -0.390244 1.724472 1.616182 -0.097477 -0.170782 0.119472 1.497307 1.040170 0.317714 1.813227 1.115091 1.108189 1.689417 -0.262762 1.307718 0.931892 1.606817 0.960377 0.411286 0.247771 0.642681 1.412085 1.412909 1.797063 0.172164 1.740367 0.372886 1.379890 0.765467 1.444968 -0.036026 0.938248 1.692947 0.425883 0.844447 0.152098 -0.006221 1.039656 1.801143 1.018286 -0.026353 -0.556475)
+ 7.503908 #(0.000000 0.755402 1.031043 1.054810 0.281310 0.638484 0.678755 -0.061091 1.874942 1.026651 1.013456 0.902683 0.466589 0.656849 1.693231 1.404646 -0.263499 -0.445923 1.593863 1.790864 -0.147432 -0.163796 0.230058 1.683194 1.076008 0.167830 1.806973 1.082076 1.043689 1.852409 -0.288292 1.355796 0.902626 1.723859 1.100962 0.151371 0.713536 0.566031 1.310021 1.519736 1.945202 0.276664 -0.060810 0.310036 1.449414 0.880895 1.568827 0.004992 1.081894 1.776013 0.590232 0.884973 0.104276 0.124961 0.994848 1.794748 0.874122 -0.016952 -0.401667)
+
+ 7.474074 #(0.000000 0.784407 1.041782 1.035925 0.294935 0.427093 0.721984 0.092420 1.735766 1.156420 1.019936 1.054348 0.499760 0.769486 1.715944 1.586067 -0.192704 -0.173666 1.684164 1.921163 0.055086 -0.007516 0.369080 1.699228 1.136967 0.294437 -0.044080 1.192357 1.158602 -0.133550 -0.087984 1.529854 0.947299 1.902997 1.119257 0.426808 0.806222 0.633135 1.477237 1.877676 0.160692 0.419085 0.158979 0.467821 1.632899 1.068960 1.780863 0.236819 1.171400 0.053940 0.893322 1.037749 0.323864 0.262747 1.171663 1.870355 1.006856 0.079239 0.012532)
+ 7.470479 #(0.000000 0.785689 1.041036 1.049808 0.305124 0.429787 0.717256 0.088775 1.726292 1.152522 1.020546 1.048587 0.486018 0.780821 1.724902 1.577515 -0.178695 -0.185526 1.691389 1.934796 0.046932 -0.005323 0.368779 1.699941 1.124598 0.296039 -0.054371 1.191052 1.153518 -0.147974 -0.090335 1.539271 0.964525 1.914880 1.137202 0.430133 0.776829 0.627048 1.462344 1.865385 0.169020 0.418703 0.158957 0.462524 1.623646 1.046298 1.759655 0.230031 1.170263 0.041395 0.885317 1.027465 0.314913 0.257396 1.158882 1.872474 1.012965 0.087584 0.001521)
+ 7.469439 #(0.000000 0.786053 1.040825 1.050267 0.305344 0.429180 0.717962 0.088837 1.725419 1.152362 1.020784 1.048370 0.486073 0.781280 1.724120 1.577030 -0.178365 -0.185633 1.691507 1.934596 0.047136 -0.005417 0.368219 1.700165 1.124068 0.296017 -0.054066 1.191543 1.153852 -0.148804 -0.090665 1.539214 0.964764 1.914412 1.137764 0.431014 0.776666 0.626264 1.462361 1.865260 0.168893 0.419387 0.159040 0.463215 1.623762 1.046651 1.759104 0.229882 1.170489 0.041888 0.885618 1.026993 0.314162 0.256790 1.158778 1.872242 1.012776 0.087727 0.001263)
)
;;; 60 all -------------------------------------------------------------------------------- ; 7.7459
(vector 60 9.575254043103 (fv 0 0 0 0 1 0 0 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 0 0 1 0 1 1 0 0 0 1 1 1 1 1 0 0 1 1)
7.588747 (fv 0.000000 0.303100 0.261228 0.917131 0.691793 -0.677124 0.027342 -0.014801 1.166154 0.416979 0.851167 1.410955 0.139409 -0.306122 1.416862 1.054300 0.792442 0.062922 1.507148 0.118287 1.375215 1.459904 1.620963 0.828106 -0.237368 0.987982 0.753194 0.096604 1.712227 1.239483 0.673351 0.871862 0.125962 0.260000 0.626286 0.147473 0.131774 0.201212 -0.194457 0.538798 0.418147 1.292448 0.871870 0.794549 0.988888 1.131816 -0.166311 0.052304 0.543793 -0.229410 0.113585 0.733683 0.271039 1.008427 1.788452 0.654055 0.106430 0.828086 0.097436 0.376461)
+
+ 7.602978 #(0.000000 0.343421 0.247838 0.890443 0.690536 -0.636145 0.032627 -0.000378 1.156652 0.432584 0.839393 1.416383 0.127840 -0.292709 1.416467 1.036542 0.772399 0.056651 1.495999 0.127272 1.372797 1.502550 1.644134 0.832570 -0.243375 0.997261 0.769525 0.097453 1.710505 1.253870 0.665368 0.892296 0.140093 0.282802 0.651418 0.158940 0.136050 0.208538 -0.153899 0.575825 0.407418 1.313964 0.907919 0.810047 0.999387 1.167125 -0.147437 0.049028 0.552121 -0.233036 0.124726 0.749826 0.278658 1.024092 1.803794 0.682067 0.122571 0.837344 0.113035 0.386515)
+ 7.590331 #(0.000000 0.311984 0.250997 0.912573 0.685307 -0.665850 0.023992 -0.010652 1.155235 0.412085 0.828254 1.410116 0.128955 -0.317825 1.409520 1.027436 0.770269 0.045987 1.490193 0.103477 1.366721 1.457750 1.601967 0.817113 -0.255006 0.965021 0.733462 0.069204 1.685229 1.226151 0.638827 0.852828 0.104728 0.233598 0.610755 0.125702 0.105148 0.180856 -0.214881 0.523640 0.392812 1.269846 0.858737 0.764879 0.959798 1.115862 -0.192768 0.019990 0.508867 -0.268592 0.089478 0.700272 0.229721 0.977531 1.747500 0.628081 0.078292 0.787525 0.066967 0.336229)
+
+ ;; 59+1
+ 7.590282 #(0.000000 0.733138 1.013982 0.976445 0.137462 0.487623 0.751851 0.069472 1.549481 1.155782 1.046980 1.186482 0.568124 0.803953 1.789655 1.516254 -0.191066 -0.219967 1.700371 -0.224496 0.157791 -0.111548 0.405580 1.483434 1.154097 0.317993 -0.073620 0.992764 1.231445 -0.032509 -0.320514 1.522634 0.865145 1.901286 0.960655 0.354881 0.887935 0.632429 1.539449 1.796728 0.215526 0.494912 0.201957 0.338737 1.611488 0.995308 1.769709 0.293624 1.032457 -0.035773 0.969779 0.986746 0.288318 0.266521 1.043059 1.780802 1.010653 0.120423 -0.003596 0.427001)
+
+ 7.603891 #(0.000000 0.869514 1.080279 1.038282 0.135313 0.502512 0.753215 0.089242 1.596695 1.140586 1.072278 1.110589 0.576325 0.731075 1.742992 1.495632 -0.196475 -0.226828 1.727532 -0.133741 0.230207 -0.117450 0.423631 1.531789 1.092093 0.236032 -0.105598 1.029301 1.286697 -0.074793 -0.255644 1.497986 0.908690 1.870731 1.038299 0.451133 0.829007 0.646965 1.519446 -0.162832 0.219693 0.485075 0.227341 0.372733 1.638093 0.931769 1.686949 0.361408 1.025558 -0.066479 0.903195 0.950470 0.309255 0.305219 1.085274 1.776201 0.968529 0.071917 -0.078070 0.465046)
)
;;; 61 all -------------------------------------------------------------------------------- ; 7.8102
@@ -748,15 +769,19 @@
7.753858 (fv 0.000000 0.319725 1.167003 1.840366 0.153760 1.056380 1.530371 0.068799 1.142107 1.630458 0.891055 1.372619 0.446834 1.091219 0.302492 1.393205 0.356103 1.143793 0.345744 1.558858 0.517245 1.731373 1.219460 0.122291 1.292388 0.849768 0.068299 1.373758 1.017991 0.385053 1.507703 1.138013 0.742591 0.285609 -0.125056 1.492440 1.058816 0.934160 0.593744 0.533680 -0.158800 0.426341 1.446080 1.766771 1.695866 1.560056 1.478090 1.737231 1.729597 0.116298 0.076540 -0.001350 0.001958 0.473570 1.021992 1.263777 1.530152 1.876463 0.039103 0.812610 1.066132)
;; 60+1
- 7.729878 #(0.000000 0.501241 0.237606 0.978914 0.682320 -0.738346 0.003863 0.191015 1.258332 0.203094 0.830345 1.438000 0.152627 -0.532209 1.427014 1.183594 0.624701 0.243054 1.493579 0.176931 1.408163 1.569029 1.678314 1.134453 -0.499872 1.081037 0.741424 0.444731 -0.070094 1.364678 0.717892 0.199159 0.000037 0.421827 0.501644 0.000638 0.131801 0.556608 -0.305504 0.649919 0.349420 1.653016 0.747436 0.624576 1.071688 1.251490 -0.264205 0.104670 0.467823 -0.348124 0.060239 0.441345 0.332223 0.905903 -0.014010 1.116703 0.324059 1.085578 0.038446 0.393074 -0.044048)
- 7.729641 #(0.000000 0.463648 0.245219 0.945196 0.651048 -0.734088 -0.016499 0.184730 1.247724 0.212438 0.819397 1.428152 0.148261 -0.535985 1.427158 1.161684 0.581178 0.249034 1.491750 0.150878 1.346200 1.564279 1.670074 1.129799 -0.517659 1.083110 0.682400 0.429246 1.869837 1.323050 0.738685 0.117986 -0.006088 0.376783 0.463179 -0.062397 0.035476 0.478607 -0.302119 0.573529 0.313684 1.619169 0.720247 0.569804 1.007611 1.154366 -0.364804 0.027671 0.390125 -0.440484 -0.028117 0.397064 0.225794 0.831365 -0.099773 1.002690 0.244315 1.000681 -0.071291 0.315345 -0.100933)
- 7.724678 #(0.000000 0.468911 0.239568 0.955993 0.660017 -0.740608 -0.005773 0.183020 1.262803 0.205104 0.825719 1.427337 0.148985 -0.545646 1.421878 1.165785 0.583348 0.241399 1.492038 0.153867 1.352915 1.564264 1.676784 1.122923 -0.525089 1.072617 0.697447 0.431113 1.876815 1.332016 0.730929 0.138318 -0.020534 0.383941 0.464477 -0.046001 0.053991 0.488682 -0.308619 0.592538 0.314268 1.634774 0.717562 0.581911 1.005194 1.161246 -0.358260 0.043757 0.409907 -0.425384 -0.020488 0.390805 0.247045 0.840009 -0.081618 1.014893 0.255614 1.022742 -0.054507 0.325271 -0.099612)
+ 7.719726 #(0.000000 0.495866 0.238287 0.955451 0.664842 -0.741345 -0.016068 0.189591 1.246084 0.190700 0.813293 1.426582 0.137309 -0.550659 1.409544 1.156142 0.580188 0.236603 1.480403 0.143969 1.355902 1.548768 1.667460 1.127939 -0.533143 1.068231 0.694662 0.416966 1.883169 1.321748 0.722703 0.140270 -0.032806 0.383094 0.464150 -0.057082 0.068615 0.492413 -0.310601 0.595711 0.295373 1.620960 0.719532 0.564630 0.996701 1.168180 -0.350959 0.028358 0.396854 -0.442188 -0.001549 0.385465 0.224100 0.834114 -0.091422 1.036164 0.264065 1.003524 -0.049053 0.311309 -0.096718)
+ 7.718493 #(0.000000 0.490794 0.242481 0.957898 0.662750 -0.742881 -0.016296 0.184736 1.253821 0.192761 0.810471 1.424644 0.139002 -0.552618 1.410815 1.159145 0.578377 0.235962 1.481912 0.147798 1.356870 1.551452 1.671348 1.124242 -0.535143 1.068113 0.692544 0.422646 1.876765 1.326092 0.722719 0.142011 -0.034790 0.381612 0.462371 -0.053314 0.063624 0.488941 -0.311525 0.596438 0.293354 1.627834 0.719558 0.563559 0.991769 1.160122 -0.358559 0.031628 0.400641 -0.444384 -0.013306 0.380359 0.226825 0.830723 -0.092522 1.028901 0.262077 1.004376 -0.055799 0.311561 -0.101231)
+
+ ;; 60+1 again
+ 7.740198 #(0.000000 0.626739 1.296742 1.008614 0.293424 0.673945 1.073779 -0.211836 1.789694 0.930583 0.771294 1.085775 0.936451 0.678115 1.636147 1.915783 -0.565114 0.016750 1.572576 0.084592 0.301576 -0.310737 0.302595 1.479719 0.731290 0.568211 0.229456 1.273391 1.255441 -0.231203 -0.609672 1.501491 0.823575 0.038113 1.037421 0.736999 0.580686 0.559838 1.809673 1.766341 0.365552 0.291068 0.626044 0.162497 1.648849 0.838850 1.891879 0.314825 1.268314 0.150269 0.467688 0.951233 0.016958 0.225952 0.821191 0.154682 1.000594 -0.136155 -0.311460 0.356212 0.395845)
+ 7.729055 #(0.000000 0.585218 1.217250 0.968645 0.317516 0.671104 1.031096 -0.218820 1.818353 0.927202 0.776661 1.093725 0.958565 0.748559 1.659429 1.900342 -0.549276 -0.033594 1.531030 0.098096 0.293928 -0.287718 0.284175 1.493491 0.641827 0.540804 0.149517 1.305126 1.287830 -0.191264 -0.570626 1.464567 0.809850 0.041962 0.973217 0.694254 0.561611 0.538641 1.801023 1.733931 0.334890 0.298869 0.624020 0.134066 1.666975 0.854407 1.865345 0.369098 1.230856 0.127409 0.434359 0.938522 0.003558 0.217472 0.903037 0.161198 1.059970 -0.106324 -0.400141 0.345606 0.415173)
)
;;; 62 all -------------------------------------------------------------------------------- ; 7.8740
(vector 62 9.9292116165161 (fv 0 0 0 1 1 1 1 0 1 0 1 1 1 1 1 0 0 1 1 0 1 0 1 0 1 0 1 1 0 0 1 0 0 0 0 0 0 1 0 0 1 0 1 1 1 1 0 0 0 1 0 0 0 0 1 1 0 0 0 0 1 0)
7.792971 (fv 0.000000 0.798156 1.779815 0.185967 1.670273 1.438952 1.815697 1.053871 0.087440 0.689337 0.052342 1.443903 1.423782 0.060887 1.727890 0.158639 0.952692 0.005318 0.914138 1.225205 0.683016 0.673829 0.109419 1.593849 0.225994 1.125995 0.418481 0.240605 0.743642 0.622844 0.353010 1.543180 1.534972 1.657806 0.217386 1.492286 1.132686 0.760213 1.147881 1.490201 0.001889 1.030507 1.289026 1.160822 0.387338 1.616191 1.464636 1.793960 1.874455 0.680274 1.683218 1.490668 0.689023 0.705366 0.946252 1.171040 0.109657 1.208442 0.793211 0.697986 1.263366 1.490757)
+ 7.791756 #(0.000000 0.794255 1.776105 0.184372 1.667961 1.440185 1.817320 1.053449 0.082409 0.687457 0.048164 1.444125 1.423252 0.061081 1.727243 0.162932 0.953680 0.005222 0.917056 1.225176 0.682682 0.672057 0.108792 1.597133 0.224159 1.125545 0.417480 0.240811 0.741742 0.625708 0.356451 1.543976 1.537969 1.658348 0.209650 1.492266 1.130024 0.756184 1.143465 1.484763 0.002845 1.030762 1.291665 1.164813 0.385858 1.615844 1.466799 1.796934 1.874708 0.677123 1.684900 1.485354 0.688305 0.708676 0.948779 1.173098 0.106201 1.209490 0.787951 0.696086 1.257404 1.488223)
)
;;; 63 all -------------------------------------------------------------------------------- ; 7.9372
@@ -767,8 +792,8 @@
7.876881 (fv 0.000000 0.730162 1.053547 1.853555 0.252740 0.906538 1.566071 0.152709 1.015626 1.877411 0.660255 1.513063 -0.004442 1.023537 0.043516 0.973208 -0.080949 0.883081 -0.126245 1.080582 0.224101 1.423101 0.674610 1.604094 0.756913 0.381286 1.606872 1.293154 0.397443 1.644011 1.075770 0.644269 0.164589 -0.255888 1.331182 0.886941 0.357762 0.438290 1.706681 1.847928 1.153249 1.311949 1.226087 1.303371 0.783267 0.589091 0.697039 0.351577 0.554862 0.724022 0.729451 0.902218 0.841292 1.194121 1.061823 1.429706 0.001167 -0.011629 0.776088 1.037188 1.244629 1.522995 0.260285)
;; 62+1
- 7.805914 #(0.000000 0.601934 1.819111 0.471849 1.796784 1.557939 -0.026564 1.127818 0.479364 1.051771 0.128278 1.076188 1.581105 0.002062 1.593371 -0.164858 0.669949 -0.006771 0.676728 1.318085 0.880976 0.767111 0.655478 1.155761 0.306644 0.952223 0.140967 -0.196485 0.579088 0.861236 0.136455 1.859532 1.366764 1.343580 -0.020718 1.262958 0.917610 0.622309 1.387853 1.550991 -0.057003 1.281603 1.600851 1.216655 0.278309 1.739420 1.301224 -0.116573 -0.098586 0.465030 1.677940 1.531395 1.096719 0.709448 0.878166 1.233881 -0.104305 1.481973 0.932474 0.299442 0.967864 1.232287 -0.358064)
- 7.800306 #(0.000000 0.593041 1.814687 0.483090 1.809567 1.570434 -0.010963 1.133312 0.508100 1.082828 0.132800 1.081295 1.609650 0.004376 1.602307 -0.148895 0.679922 0.003650 0.695902 1.342115 0.911951 0.821441 0.666366 1.192523 0.330741 0.982706 0.167927 -0.164040 0.595303 0.873621 0.175773 1.884907 1.412718 1.374024 -0.003632 1.286158 0.950933 0.635806 1.438790 1.594221 -0.018194 1.324380 1.640059 1.280459 0.314889 1.818114 1.342146 -0.063931 -0.074642 0.525213 1.767962 1.608859 1.143810 0.780779 0.927340 1.305959 -0.057784 1.556344 1.011039 0.353582 0.998321 1.295658 -0.292113)
+ 7.793784 #(0.000000 0.604834 1.810468 0.479158 1.833042 1.567985 -0.008145 1.139628 0.500517 1.068759 0.129009 1.082620 1.606832 0.022087 1.588661 -0.153130 0.676199 0.010115 0.698933 1.351365 0.913525 0.821255 0.678484 1.196033 0.336031 0.980483 0.167734 -0.166196 0.584197 0.895241 0.166400 1.887408 1.404231 1.357967 0.000767 1.273439 0.959305 0.625351 1.435222 1.581734 -0.027156 1.322760 1.634581 1.284691 0.324951 1.829465 1.346510 -0.070824 -0.074038 0.522954 1.755297 1.609271 1.147322 0.784177 0.915115 1.284187 -0.070344 1.582369 1.006518 0.377560 1.009520 1.290325 -0.295994)
+ 7.792658 #(0.000000 0.604958 1.810993 0.479572 1.832501 1.568102 -0.008375 1.139554 0.500438 1.068891 0.129208 1.082690 1.606602 0.021403 1.588850 -0.152836 0.676059 0.009863 0.698550 1.351044 0.912935 0.821309 0.678462 1.195880 0.335962 0.980439 0.167296 -0.166103 0.584580 0.895326 0.165904 1.888061 1.403790 1.358315 0.000771 1.273834 0.958915 0.625533 1.434996 1.581517 -0.027021 1.322879 1.634409 1.284726 0.325288 1.829740 1.346606 -0.071117 -0.074172 0.523456 1.755231 1.609173 1.147725 0.784584 0.915037 1.284527 -0.069280 1.582487 1.006637 0.377855 1.009315 1.289847 -0.296346)
)
;;; 64 all -------------------------------------------------------------------------------- ; 8
@@ -780,8 +805,8 @@
7.992914 (fv 0.000000 0.651329 1.088511 1.713470 0.442276 0.963521 1.501931 0.310181 1.212960 -0.011104 0.778232 1.515305 0.316833 1.237177 0.296916 1.189311 0.026642 1.098222 -0.017818 1.134719 0.273596 1.474260 0.550810 1.706455 0.919546 0.198719 1.526951 0.883788 0.268629 1.826193 1.021575 0.329612 -0.041590 1.516394 1.042877 0.648305 0.185654 -0.069051 1.607952 1.190320 1.094592 0.588439 0.829542 0.393611 0.610572 0.171199 0.117077 0.152394 -0.147682 0.017404 0.185404 0.037181 0.373288 0.371013 0.642715 0.482850 0.968331 1.382474 1.590294 -0.024057 0.298876 0.749699 1.152958 1.682631)
;; 63+1
- 7.860026 #(0.000000 0.809578 1.898769 0.467844 0.006957 1.570179 0.166964 1.399056 0.441035 1.263158 0.221043 1.092426 1.474756 0.007976 1.573880 0.092893 0.611450 0.051852 0.479088 1.319456 0.803792 1.198336 0.735571 1.265423 0.465756 0.760698 0.362640 -0.062961 0.627636 0.844966 -0.014667 1.769347 1.323936 1.245960 0.116850 1.375744 0.996394 0.370750 1.317375 1.741914 -0.329960 1.202157 1.458151 1.120658 0.217396 1.857269 1.281001 -0.057938 -0.080468 0.444525 1.682891 1.595713 1.143362 0.554820 0.939242 1.248217 -0.289778 1.508665 1.074317 0.351970 0.956968 1.151169 -0.275737 -0.049296)
- 7.856464 #(0.000000 0.822234 1.908730 0.467749 0.006656 1.612213 0.171726 1.378057 0.490600 1.283019 0.198540 1.138986 1.474359 0.023573 1.618066 0.107006 0.645127 0.046120 0.470802 1.320344 0.831192 1.192841 0.749343 1.290871 0.485677 0.828180 0.364554 -0.060479 0.620764 0.905935 -0.004028 1.773415 1.346206 1.276795 0.145101 1.369520 1.077798 0.374122 1.316067 1.750075 -0.308445 1.240419 1.495628 1.155630 0.297494 1.866545 1.311588 -0.004376 -0.041514 0.509113 1.692680 1.642970 1.149448 0.643495 0.990275 1.299612 -0.217370 1.583383 1.064236 0.447176 1.021444 1.233603 -0.209539 0.030332)
+ 7.852593 #(0.000000 0.825112 1.882318 0.451509 0.012998 1.639009 0.186070 1.361114 0.503493 1.308226 0.187566 1.154228 1.519693 0.016493 1.654055 0.133569 0.677683 0.038167 0.453693 1.326886 0.811770 1.182840 0.767976 1.306039 0.513845 0.875502 0.344585 -0.071461 0.625939 0.904824 0.020665 1.775810 1.364597 1.313323 0.157145 1.372768 1.111614 0.377004 1.340696 1.756191 -0.307041 1.279247 1.512890 1.161668 0.344904 1.870013 1.328981 0.030268 -0.036888 0.551836 1.737903 1.637471 1.164315 0.705326 1.030571 1.361467 -0.181207 1.620264 1.058937 0.469215 1.047362 1.285537 -0.195579 0.052724)
+ 7.850378 #(0.000000 0.818256 1.893797 0.447574 0.004615 1.627422 0.174323 1.354149 0.505328 1.291333 0.192178 1.130810 1.484813 -0.020048 1.628923 0.116957 0.662375 0.012432 0.429672 1.291396 0.784440 1.176860 0.720821 1.253711 0.466453 0.835831 0.299457 -0.100473 0.586092 0.852720 -0.020740 1.729307 1.309937 1.257236 0.131855 1.336452 1.066797 0.322890 1.283543 1.689513 -0.371492 1.214117 1.466426 1.111681 0.289267 1.807002 1.269572 -0.053895 -0.092329 0.477788 1.677216 1.588667 1.094746 0.622096 0.954171 1.266653 -0.249077 1.541492 0.994736 0.424957 0.957923 1.192779 -0.269608 -0.039051)
)
;;; 65 all -------------------------------------------------------------------------------- ; 8.0622
@@ -792,9 +817,12 @@
;; pp:
7.973113 (fv 0.000000 0.586863 1.108547 1.809568 0.236474 0.932200 1.490976 0.236358 1.190604 -0.011282 0.981987 1.626061 0.541325 1.333541 0.166220 1.028548 0.073540 1.235912 0.201403 1.061871 0.289618 1.557561 0.463038 1.533243 0.718960 -0.031407 1.248624 0.634414 -0.029632 1.295765 0.653432 0.144947 1.300831 1.398877 0.579343 0.760977 0.024336 1.714192 1.357070 0.952728 0.458396 0.300957 -0.033236 0.181552 1.850554 1.728158 1.394294 1.294304 1.438841 1.230165 1.383584 1.610036 1.601644 1.798980 0.041945 -0.165907 -0.108364 0.492371 0.832142 1.280146 1.457449 -0.051803 0.040231 0.532391 1.056982)
- ;; 65+1
+ ;; 64+1??
7.989976 #(0.000000 0.717074 1.790137 0.303763 0.122314 1.682143 0.216359 1.275289 0.381110 1.232945 0.219920 1.195050 1.544622 0.012541 1.697713 0.164535 0.808696 -0.033093 0.436931 1.424336 0.953440 1.075346 0.847229 1.377732 0.455680 0.844396 0.388170 -0.232520 0.566111 1.006265 0.239235 -0.064356 1.478182 1.310771 0.100992 1.360730 1.120501 0.518973 1.403629 1.737998 -0.215831 1.519996 1.486448 1.299685 0.264762 0.058410 1.261254 0.113761 -0.018088 0.416310 -0.086576 1.654308 1.428048 0.818894 0.929752 1.422804 -0.004686 1.681128 1.117926 0.396261 1.114085 1.263468 -0.302127 -0.143751 0.249776)
7.986549 #(0.000000 0.705159 -0.181004 0.217327 0.156922 1.778990 0.191147 1.113801 0.272034 1.171044 0.257920 1.334728 -0.188087 -0.096820 -0.018998 0.262759 0.954023 -0.039897 0.341389 1.444996 0.917955 1.089303 1.099624 1.600822 0.474003 1.078678 0.419361 -0.346529 0.769135 1.102121 0.462514 0.194004 1.393289 1.207814 0.168583 1.451937 1.578978 0.606330 1.663672 1.685805 -0.285434 1.500953 1.544223 1.459210 0.522782 0.144120 1.248342 0.284057 0.175310 0.542283 0.012495 1.586311 1.315843 1.018961 1.170529 -0.156886 0.147650 -0.231754 1.368201 0.537962 1.411226 1.416444 -0.114344 -0.050059 0.647067)
+
+ 7.936705 #(0.000000 1.517428 0.111828 0.173226 0.840059 0.526041 1.411719 1.400612 -0.303887 0.230833 0.238673 -0.042085 0.173922 -0.488247 -0.875499 0.144489 1.065445 -0.071232 -0.251031 -0.143214 0.545256 1.307426 0.624098 1.604714 0.476813 0.403036 0.397383 -0.691500 1.462074 1.550083 0.768183 0.930280 0.458416 0.838168 0.784667 1.167295 -1.040754 0.791308 -0.864278 0.598538 -1.010391 1.656175 0.144524 -0.290241 0.441806 0.078668 -0.056179 -0.659905 1.071833 0.387457 0.707236 1.208921 0.879213 0.283834 1.382955 0.578802 -0.772961 -0.113529 0.594627 1.029134 1.703053 0.890258 0.476451 -1.188193 0.046657)
+ 7.935374 #(0.000000 1.516508 0.110662 0.175958 0.836131 0.527757 1.411364 1.402933 -0.304009 0.233367 0.236759 -0.044789 0.175612 -0.486791 -0.877026 0.147806 1.067130 -0.071661 -0.249068 -0.143232 0.548582 1.308817 0.625581 1.605825 0.476254 0.402177 0.399931 -0.689265 1.463205 1.551126 0.770705 0.932593 0.459681 0.842986 0.780890 1.170908 -1.038140 0.797070 -0.861980 0.600440 -1.006688 1.655334 0.145026 -0.290652 0.442934 0.083346 -0.055655 -0.658549 1.077569 0.388346 0.715047 1.209914 0.883597 0.287116 1.384240 0.580259 -0.768209 -0.114151 0.598252 1.027948 1.705250 0.896332 0.480110 -1.183952 0.051204)
)
;;; 66 all -------------------------------------------------------------------------------- ; 8.1240
@@ -803,8 +831,8 @@
8.056638 (fv 0.000000 1.161331 1.936583 0.473825 1.730430 1.710083 1.722704 0.938539 0.650961 -0.301116 0.711382 0.874289 0.712393 1.263523 0.315048 0.391659 1.059022 0.363325 1.881127 0.161704 0.986800 1.590034 -0.289492 0.615410 -0.014906 1.387045 1.412270 1.265945 0.128543 0.445787 0.121476 1.705959 1.084173 1.066949 0.774156 0.933891 1.279265 0.297308 0.298325 1.512363 0.271282 1.243162 1.580605 1.521644 0.312598 0.465014 1.006013 0.269153 1.083812 0.157700 1.646414 0.707835 0.598039 1.973506 0.954025 0.104991 0.944717 0.038847 0.538283 0.734911 0.143649 0.104089 0.567333 0.271330 0.665962 0.751070)
;; 67-1
- 8.057849 #(0.000000 0.557868 1.277675 0.035082 0.606360 1.351203 1.836909 0.715558 1.256481 1.526554 0.538579 1.530425 0.580514 1.498578 0.116903 0.933739 0.019326 0.887252 -0.086797 0.604738 1.551540 0.736914 0.131651 1.149747 0.282533 1.227997 0.618183 0.164429 1.585108 1.228651 0.546852 -0.196864 1.480532 0.533190 -0.284020 1.599530 1.236535 0.954887 0.575524 0.413221 -0.000524 0.162211 1.214867 0.627804 0.589019 0.838842 0.451898 0.970982 0.399993 0.164558 0.108022 0.046075 0.027216 0.532334 0.358013 0.837176 0.729555 1.147175 0.936661 1.785417 0.184687 0.636068 0.955301 1.150651 1.841869 1.851218)
- 8.044495 #(0.000000 0.581065 1.291916 0.059254 0.617899 1.347083 1.813127 0.736507 1.273944 1.499042 0.544683 1.521865 0.547535 1.489105 0.122725 0.930947 -0.019577 0.828332 -0.123574 0.579943 1.554404 0.681236 0.080353 1.124307 0.249845 1.207295 0.630833 0.181490 1.580635 1.191264 0.544001 -0.219496 1.461932 0.541340 -0.290780 1.610474 1.275097 0.940533 0.570196 0.341107 -0.017602 0.133281 1.166976 0.573116 0.556656 0.758376 0.419521 0.906007 0.305727 0.149020 0.017843 0.033007 -0.043063 0.469814 0.304703 0.839693 0.673714 1.093033 0.885579 1.735487 0.146827 0.560866 0.914370 1.104996 1.771632 1.846520)
+ 8.015795 #(0.000000 0.482185 1.174631 0.006809 0.401780 1.237554 1.609013 0.588930 1.364153 1.497911 0.479714 1.430977 0.382104 1.324174 0.126882 0.919708 -0.100361 0.979679 -0.154974 0.411044 1.431094 0.610463 0.047752 1.055827 0.418075 1.131057 0.351532 -0.093894 1.532471 1.157174 0.298591 -0.302172 1.190200 0.350212 -0.469230 1.440439 1.054072 0.838197 0.416628 0.293297 -0.104136 -0.061434 0.960707 0.489913 0.124304 0.770013 0.316144 0.728268 0.218632 -0.102007 0.074373 -0.213063 -0.207226 0.313323 0.277535 0.498637 0.514308 0.823833 0.726893 1.568923 -0.149485 0.343111 0.825139 1.056977 1.559384 -0.284248)
+ 8.011520 #(0.000000 0.479799 1.169638 0.004612 0.402406 1.230765 1.595897 0.593685 1.374878 1.499275 0.489410 1.425320 0.373395 1.315599 0.138105 0.920155 -0.108520 0.991482 -0.149108 0.410130 1.436361 0.601706 0.046153 1.052899 0.424418 1.134897 0.348693 -0.098617 1.547368 1.151172 0.294748 -0.290030 1.189252 0.345030 -0.465760 1.441002 1.060075 0.832617 0.418488 0.293880 -0.106037 -0.059478 0.956595 0.497960 0.117059 0.767911 0.318840 0.717594 0.220912 -0.113412 0.081739 -0.211641 -0.217173 0.315598 0.272673 0.484197 0.526183 0.827437 0.728223 1.566384 -0.150430 0.337045 0.831304 1.069362 1.566148 -0.280307)
)
;;; 67 all -------------------------------------------------------------------------------- ; 8.1853
@@ -813,7 +841,8 @@
8.144904 (fv 0.000000 0.836848 1.681555 1.191647 0.070261 0.942251 1.797644 1.070294 0.265921 1.462866 0.142770 0.004389 0.118755 0.795004 0.861059 0.364013 1.094070 0.938540 1.352932 1.681133 0.801557 -0.166830 1.660232 1.811404 -0.089491 1.793031 0.410641 1.462829 0.992048 -0.005221 0.624981 -0.049054 -0.100216 0.046599 -0.054149 1.061978 0.471687 -0.484886 1.299787 0.103592 0.873660 1.581185 1.539111 1.747106 0.867454 1.194479 0.984380 1.039016 -0.137566 1.440640 0.758746 0.623227 0.623868 1.161467 1.535042 0.328555 1.691644 -0.115223 0.929805 1.714954 0.103897 1.241682 1.520953 1.062392 0.666399 0.064868 1.788882)
;; pp:
- 8.072785 (fv 0.000000 0.714480 1.141487 -0.059495 0.626617 1.143106 1.724186 0.562381 1.166774 1.775820 0.595712 1.588031 0.453186 1.514340 0.088154 0.928491 -0.033585 0.878492 -0.006785 0.660928 1.635393 0.709844 0.143551 1.201690 0.276956 1.367207 0.639357 0.086720 1.577267 1.234748 0.475681 -0.133351 1.448411 0.486601 -0.203691 1.708040 1.315311 0.962381 0.408017 0.396955 1.868803 -0.051618 1.159243 0.738595 0.693611 0.852762 0.510509 0.806906 0.489441 0.162663 0.197789 0.090682 0.076822 0.594675 0.394390 0.961428 0.800767 1.169831 1.000600 1.531863 1.954261 0.431033 0.762550 1.024871 1.795795 1.769037 0.290496)
+ 8.047705 #(0.000000 0.723228 1.099176 -0.100694 0.795584 1.226000 1.797595 0.767514 1.189968 1.770414 0.592457 1.632373 0.568783 1.570965 0.191327 0.911400 -0.022316 0.899532 0.007665 0.667853 1.568194 0.721875 0.202951 1.285669 0.230444 1.429343 0.815993 0.012435 1.649015 1.193109 0.625662 -0.046776 1.588223 0.552563 -0.302890 1.679576 1.260813 0.930680 0.445604 0.348973 1.926722 0.133110 1.169041 0.703410 0.591692 0.750705 0.471868 0.931521 0.435714 0.165223 0.319019 0.050970 0.055362 0.598500 0.290706 1.016017 0.946745 1.221686 1.001124 1.567104 0.056814 0.422743 0.731562 1.013128 1.856895 1.850611 0.319558)
+ 8.043962 #(0.000000 0.723361 1.098199 -0.104317 0.796240 1.226712 1.796964 0.767870 1.189764 1.772492 0.590978 1.631570 0.568976 1.570933 0.191811 0.911209 -0.021351 0.900745 0.009021 0.667781 1.566923 0.719770 0.205199 1.286787 0.231357 1.429685 0.816164 0.009201 1.644886 1.192474 0.623028 -0.047424 1.588652 0.551514 -0.304566 1.681018 1.259199 0.930654 0.444058 0.347527 1.926688 0.132038 1.165961 0.703045 0.587795 0.751154 0.472421 0.933684 0.438476 0.165192 0.320128 0.049852 0.054657 0.597137 0.289172 1.017612 0.945610 1.220099 1.001383 1.565341 0.058830 0.420956 0.733110 1.012036 1.857676 1.850677 0.317955)
)
;;; 68 all -------------------------------------------------------------------------------- ; 8.2462
@@ -822,7 +851,8 @@
8.168157 (fv 0.000000 0.354978 1.878673 1.059221 0.759731 0.956747 0.711479 0.720163 0.372733 0.204844 0.455442 0.097446 1.506513 0.919884 0.814781 0.935488 0.786490 1.074073 1.203975 1.052443 0.726494 1.730845 0.062987 1.716136 1.412039 0.233751 0.090641 -0.003605 0.550389 0.691280 1.313887 0.137194 1.521036 1.556316 0.070039 0.198694 1.780701 0.986693 1.284403 1.408455 0.102332 1.273719 0.728671 0.008237 1.436719 1.092816 0.742660 1.480879 0.410157 1.288179 0.559234 1.425899 1.219179 0.189574 0.471285 1.159537 -0.028955 1.469388 0.210392 1.141156 -0.135055 0.687474 1.468060 -0.235268 0.553950 0.681055 0.986756 1.515599)
;; 69-1
- 8.134657 #(0.000000 0.790373 1.239220 0.460881 1.120937 1.102394 0.719196 1.260788 1.351581 0.150109 0.706820 1.708757 0.126405 0.573565 0.873737 1.541466 0.883699 0.146819 0.862233 -0.420165 0.374490 0.879454 1.601783 1.026685 -0.075871 -0.210918 0.449967 0.015278 0.084909 0.099093 -0.094596 1.643405 -0.042800 1.741808 0.515794 1.802790 0.939496 -0.125366 1.455519 0.180731 0.916674 -0.121997 0.876713 0.618219 0.625033 -0.767565 0.178266 0.158103 -0.126698 1.357885 1.217166 -0.144966 -0.267986 0.336938 0.761158 0.645268 0.017305 1.693864 1.248389 0.629256 0.208779 -0.415265 -0.031605 -0.400471 0.725040 0.782451 0.715907 0.712328)
+ 8.131853 #(0.000000 0.784104 1.233565 0.461379 1.122608 1.104526 0.722387 1.255939 1.344588 0.136431 0.691426 1.710711 0.131100 0.566340 0.865438 1.537496 0.878693 0.133465 0.855818 -0.432042 0.379762 0.876524 1.602175 1.021625 -0.093271 -0.210101 0.454316 0.002103 0.079420 0.100395 -0.098889 1.625973 -0.047062 1.737996 0.506589 1.792992 0.939323 -0.140724 1.456990 0.171514 0.906369 -0.130797 0.877514 0.626041 0.619243 -0.783477 0.176466 0.146820 -0.143043 1.354027 1.213392 -0.157870 -0.263919 0.335949 0.779235 0.639234 0.011670 1.687112 1.239883 0.625064 0.203838 -0.430763 -0.038392 -0.419755 0.708217 0.793274 0.717371 0.706499)
+ 8.131379 #(0.000000 0.777086 1.225294 0.459335 1.120518 1.101510 0.718447 1.262945 1.346941 0.144684 0.695095 1.701131 0.123010 0.559466 0.867624 1.525977 0.858162 0.137330 0.853375 -0.428338 0.368918 0.875336 1.605285 1.009970 -0.095199 -0.219955 0.449222 0.000464 0.090789 0.090543 -0.094428 1.635821 -0.065302 1.739981 0.500960 1.791399 0.927017 -0.130394 1.444057 0.172796 0.901920 -0.118461 0.861131 0.631330 0.620706 -0.801290 0.162692 0.158567 -0.135443 1.344771 1.192462 -0.162338 -0.266366 0.328646 0.783136 0.650960 0.026458 1.672924 1.221292 0.618317 0.191901 -0.429128 -0.026945 -0.415707 0.709906 0.791929 0.708422 0.702801)
)
;;; 69 all -------------------------------------------------------------------------------- ; 8.3066
@@ -831,7 +861,8 @@
8.197146 (fv 0.000000 0.551719 0.168788 -0.171535 0.603472 1.646430 0.831219 -0.112901 1.600971 0.776706 -0.257580 1.457106 0.729936 0.539913 1.421843 0.548661 0.072361 0.728562 0.364648 -0.109430 1.359599 1.471812 0.472868 -0.088533 0.623026 0.167759 1.605110 0.053141 0.996253 1.258861 1.710199 1.079237 0.316774 0.568130 0.226861 -0.084943 1.702544 1.075688 0.298153 0.507109 1.291563 1.177929 1.707324 -0.001439 0.386332 0.512557 0.380487 0.243873 1.516865 0.101344 -0.768813 1.646072 0.275192 0.139649 1.389985 1.576705 0.346880 0.446918 1.441036 0.376743 1.075298 0.134005 0.942798 0.778785 1.014815 1.144279 1.213481 1.047075 1.249788)
;; 70-1
- 8.143974 #(0.000000 0.563151 1.347234 0.372166 1.011160 1.230491 0.749402 1.243692 1.327484 0.188943 0.690097 1.705036 0.306148 0.675830 0.924357 1.699354 0.831298 0.036827 0.920452 -0.161127 0.378618 1.012001 1.732453 1.018416 0.093399 -0.223999 0.415971 -0.093239 0.157176 -0.107480 -0.077653 1.591872 -0.197575 1.675265 0.529602 1.688724 1.228937 -0.066917 1.910851 0.147616 0.958159 0.065098 0.692177 0.777376 0.643403 -0.410706 0.296222 0.415687 -0.096263 1.411122 1.263478 0.068706 -0.286121 0.572877 1.080715 0.960873 -0.048076 1.732249 1.330711 0.695044 0.195422 -0.180667 0.159809 -0.240900 0.873699 0.964556 0.811214 0.629243 -0.017179)
+ 8.141488 #(0.000000 0.574183 1.353612 0.374915 1.030848 1.242040 0.744144 1.258569 1.336700 0.191968 0.691270 1.721372 0.311349 0.667908 0.915341 1.702762 0.832541 0.057365 0.926883 -0.151411 0.409001 1.010518 1.740308 1.032309 0.081237 -0.217082 0.415212 -0.071661 0.155303 -0.089140 -0.060725 1.591797 -0.172680 1.694895 0.543894 1.693239 1.206424 -0.050239 1.924102 0.172957 0.976794 0.085955 0.708872 0.776705 0.648853 -0.409925 0.316385 0.431673 -0.080960 1.419047 1.273976 0.066194 -0.289390 0.572552 1.102567 0.973972 -0.045359 1.746990 1.335632 0.698963 0.200154 -0.171320 0.156816 -0.222154 0.877092 0.959484 0.814725 0.645169 0.000279)
+ 8.140284 #(0.000000 0.574274 1.353235 0.374880 1.030900 1.241934 0.744056 1.258652 1.336888 0.191881 0.691290 1.721325 0.311221 0.667796 0.914975 1.702712 0.832796 0.057800 0.926778 -0.151752 0.409056 1.010584 1.740825 1.032269 0.081080 -0.217110 0.415261 -0.071717 0.155276 -0.088899 -0.060899 1.591545 -0.172297 1.695170 0.543998 1.693375 1.206363 -0.050497 1.924309 0.173097 0.976699 0.086114 0.708934 0.776887 0.648438 -0.409990 0.317299 0.431348 -0.080917 1.418905 1.274203 0.066144 -0.289260 0.572513 1.102504 0.974167 -0.045152 1.746839 1.335333 0.699271 0.200129 -0.170859 0.156721 -0.222333 0.876801 0.959324 0.814751 0.645600 0.000208)
)
;;; 70 all -------------------------------------------------------------------------------- ; 8.3666
@@ -846,8 +877,8 @@
8.319609 (fv 0.000000 0.140438 -0.156343 1.390907 0.216508 0.199081 1.047301 1.430567 0.016863 1.549577 0.363516 1.057536 -0.217538 0.646697 0.414461 0.993065 1.127770 0.877766 0.873392 0.440804 0.760841 0.449527 0.494946 1.105821 0.463488 1.200046 1.158237 0.977607 1.309426 0.772719 -0.483517 0.568526 0.817490 0.531524 0.272201 1.656272 -0.164981 0.659567 1.062868 -0.123485 1.015493 0.120132 0.671070 0.461022 1.766703 1.319785 0.775590 0.108288 0.757022 1.176333 1.486331 1.779348 -0.137633 1.540074 -0.041450 0.361903 1.057755 1.116867 0.573932 0.250328 1.480465 0.262890 0.893036 1.148682 1.046983 0.264942 1.618761 0.311598 1.395691 0.570219 0.159607)
;; 70+1
- 8.333845 #(0.000000 0.741042 1.489019 -0.124872 1.268392 1.336326 0.512548 0.937748 0.951723 0.152568 1.028858 -0.243353 0.086205 0.754698 1.441559 1.417305 1.142670 0.184075 0.610630 -0.436955 0.403625 1.323364 0.186977 1.074933 -0.224436 -0.269303 1.049190 0.015439 -0.107110 0.312582 0.157384 1.210121 0.061920 -0.163401 -0.010172 1.328828 -0.661526 -0.792391 -0.010926 -0.210071 1.441868 0.452979 0.227037 0.940601 0.552485 -0.755529 0.905193 -0.467293 0.369813 1.273291 1.124208 -0.504204 0.400118 0.917761 0.809535 0.178683 -0.004496 -0.260484 -0.237370 0.532021 0.652869 0.225451 -0.671013 0.610113 1.148179 1.320266 0.936680 0.634471 0.405144 1.190440 0.850770)
- 8.312176 #(0.000000 0.874002 1.383024 0.378933 0.799884 1.165596 0.533309 1.282741 0.886396 0.160934 0.729340 0.018471 0.256784 0.836821 0.836340 1.632305 0.875224 0.107603 1.058269 -0.313629 0.260148 1.563506 0.301401 1.147223 0.010044 0.210590 0.782179 0.044072 -0.074852 0.152561 0.153788 1.381267 -0.147303 1.443749 -0.014793 1.548909 0.014576 -0.121925 0.202272 0.029847 1.157828 0.486406 0.678816 1.002783 0.802159 -0.032653 0.703505 0.093729 0.211124 1.142051 1.177369 -0.359654 -0.078427 0.818294 0.971684 0.534909 -0.090789 -0.374344 1.667746 0.494486 0.436543 0.088578 -0.362483 0.515273 1.078602 1.312304 0.992479 0.513991 0.105033 1.004668 0.388247)
+ 8.291682 #(0.000000 0.876360 1.340339 0.367854 0.833412 1.105639 0.584245 1.188771 0.943418 0.250187 0.630698 -0.068665 0.279948 0.860334 0.732167 1.695945 0.897917 0.078292 1.045266 -0.333182 0.322926 1.637234 0.164051 1.142522 -0.007921 0.252497 0.780763 0.003414 -0.048763 0.073861 0.171499 1.284103 -0.089733 1.440877 -0.081573 1.527112 0.082712 -0.151289 0.255666 0.094915 1.149112 0.413227 0.691320 1.014965 0.789606 -0.102840 0.792525 0.145016 0.117221 1.222312 1.251613 -0.402327 -0.063091 0.826531 0.883896 0.465081 -0.032634 -0.408593 1.616507 0.441444 0.501925 0.126666 -0.391606 0.529294 1.070538 1.229843 1.052507 0.538182 0.119222 0.991880 0.323259)
+ 8.291337 #(0.000000 0.876359 1.340283 0.367845 0.833375 1.105664 0.584271 1.188768 0.943451 0.250250 0.630656 -0.068635 0.279930 0.860317 0.732184 1.695932 0.897961 0.078310 1.045223 -0.333231 0.322957 1.637262 0.164086 1.142535 -0.007984 0.252507 0.780797 0.003458 -0.048747 0.073861 0.171483 1.284136 -0.089705 1.440806 -0.081590 1.527122 0.082721 -0.151244 0.255684 0.094848 1.149118 0.413274 0.691318 1.014955 0.789606 -0.102756 0.792501 0.144964 0.117187 1.222333 1.251710 -0.402265 -0.063046 0.826524 0.883969 0.465066 -0.032718 -0.408605 1.616554 0.441389 0.502001 0.126714 -0.391606 0.529285 1.070446 1.229824 1.052451 0.538215 0.119274 0.991866 0.323308)
)
;;; 72 all -------------------------------------------------------------------------------- ; 8.4853
@@ -856,20 +887,27 @@
8.472893 (fv 0.000000 -0.093428 0.860520 0.651650 0.036400 1.174208 -0.214755 0.653075 0.661176 1.355137 1.759893 1.116459 1.283776 0.222435 0.388195 1.541066 0.171819 0.911538 0.292609 1.508023 0.997352 1.385529 0.022962 0.061408 -0.061153 0.241196 0.345845 0.923448 0.626801 0.283115 0.129077 0.499608 0.703807 0.614285 0.908458 0.403245 1.817077 1.458947 0.221667 1.213107 1.163972 1.117128 0.465749 0.627880 0.010093 0.512887 0.278332 0.535697 1.736410 -0.297420 0.467311 1.419905 1.531806 0.300181 0.244309 1.719696 1.200428 1.778805 1.081039 0.613164 1.654092 1.161237 1.675808 0.051072 0.709895 1.432879 0.690303 1.567340 0.453011 1.156931 0.253055 -0.113821)
;; pp.scm:
- 8.398072 (fv 0.000000 0.721030 0.948975 1.651519 0.233429 1.256419 1.215593 0.048780 1.144871 0.213229 0.880829 1.692382 0.366636 0.960208 1.629523 0.574770 1.546769 0.517973 1.617121 0.416046 1.542708 0.301404 1.290249 0.820158 0.258866 0.894435 0.090675 1.532038 0.985523 -0.034703 1.528561 0.881196 0.099225 -0.003432 1.044040 0.536864 -0.131692 1.029980 1.151362 0.675489 -0.005731 -0.378928 1.525987 1.057922 0.658986 0.443501 0.074450 0.429490 -0.435612 0.068631 -0.209332 1.531485 1.585628 1.667775 1.257877 1.589580 1.146646 -0.378411 1.726866 -0.167738 -0.290459 -0.269650 0.365115 0.370457 0.748015 1.193861 1.678605 0.010066 0.170551 0.863723 0.838123 1.538906)
+ 8.375884 #(0.000000 0.704287 1.002073 1.665258 0.322937 1.455570 1.095676 0.019520 1.265776 0.283182 0.917991 1.741290 0.286595 0.909432 1.680753 0.853512 1.790234 0.580849 1.462104 0.390604 1.608631 0.491512 1.302107 0.855899 0.376743 0.878628 -0.166734 1.586900 0.799671 -0.063381 1.765431 0.627081 -0.164410 -0.007173 0.940347 0.645761 -0.294937 1.130494 1.024960 0.847385 -0.017840 -0.118371 1.360715 1.113073 0.529708 0.795901 0.574578 0.399736 -0.603738 0.201753 -0.310289 1.521464 1.779789 1.691203 1.658944 1.634184 1.099516 -0.336477 -0.077931 -0.045300 -0.292630 -0.240387 0.307058 0.437574 0.891669 1.282560 1.663663 -0.191286 -0.153149 0.842573 0.846091 1.564507)
+ 8.367751 #(0.000000 0.645558 1.020824 1.674879 0.297321 1.478215 1.159425 0.013301 1.239885 0.350033 0.888999 1.831881 0.311808 0.919253 1.727115 0.871519 1.738071 0.513558 1.443664 0.420753 1.667825 0.484271 1.279276 0.823868 0.381782 0.911943 -0.096163 1.562504 0.828536 -0.144974 1.874517 0.768201 -0.125865 0.027788 0.992868 0.715728 -0.253408 1.108264 1.073157 0.786938 -0.002734 -0.154497 1.429041 1.081506 0.490310 0.770013 0.521515 0.288890 -0.695918 0.082180 -0.343666 1.544801 1.719927 1.637916 1.693329 1.678105 1.069958 -0.338832 -0.083132 -0.171885 -0.331886 -0.261796 0.380058 0.414290 0.757097 1.213104 1.511562 -0.172398 -0.158558 0.833537 0.819748 1.537843)
+
+ ;; 73-1
+ 8.393433 #(0.000000 -1.651316 0.301642 1.466674 0.575226 1.013593 0.593794 -0.111599 1.175040 -0.036844 0.640902 -0.496840 0.997861 0.882127 1.022937 -0.182002 1.272243 -0.123920 0.043991 1.030819 1.511195 1.158707 -0.310897 1.682674 0.196749 1.379163 0.680074 0.977267 1.032336 1.755391 0.420238 0.127288 -0.116036 1.422986 0.200070 0.221084 0.315906 0.920268 0.575823 0.602266 1.097544 0.016105 0.141377 -0.123217 -0.343006 -0.132707 -0.193667 1.477259 0.489569 1.413642 -0.024032 -0.207016 0.154750 0.997956 -0.351070 0.296357 1.115717 0.543150 0.264016 1.680397 1.236837 0.299616 -0.037861 0.721978 -0.322788 -0.300188 1.010597 0.394676 1.139314 -0.124559 -0.185844 1.210473)
)
;;; 73 all -------------------------------------------------------------------------------- ; 8.5440
(vector 73 10.773231506348 (fv 0 0 1 1 0 0 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0 0 0 1 1 1 0 1 0 1 1 1 0 1 1 0 1 1 0 0 1 0 0 1 0 1 1 1 1 1 0 1 1 1 1 0 1 1 0 1 1 1 0 0 1 0 1 0 1 0 0 1 1)
- 8.432898 (fv 0.000000 -1.848123 0.239060 1.464251 0.628713 1.091837 0.714118 0.011434 1.168318 0.062880 1.015397 -0.328225 1.126530 0.965816 1.106076 -0.063170 1.197633 -1.809778 0.091864 0.972492 1.580451 1.036972 -0.065401 1.876586 0.421742 1.575936 0.943040 0.998651 1.251175 1.731410 0.520979 0.344525 -0.022728 1.604302 0.415026 0.363810 0.330426 1.053516 0.529548 0.585862 1.282692 0.064995 0.245738 0.033146 -0.021970 -0.243322 -0.102869 1.628985 0.462863 1.533635 0.132871 0.079809 0.450013 1.062550 1.900737 0.507033 1.228155 0.664499 0.381483 1.660810 1.361854 0.409741 0.569163 0.877009 1.830036 -0.331099 1.110302 0.325340 1.299368 0.004038 0.123887 1.612282 0.588683)
- 8.433132 (fv 0.000000 -1.847444 0.237344 1.464638 0.628887 1.093285 0.714406 0.013323 1.168036 0.063810 1.016680 -0.328601 1.126593 0.966206 1.107076 -0.063367 1.197228 -1.807287 0.093599 0.972529 1.580674 1.036337 -0.065390 1.875846 0.422275 1.575682 0.944151 0.999284 1.251360 1.730976 0.519804 0.344632 -0.023064 1.604915 0.415187 0.364741 0.329769 1.054442 0.530131 0.585700 1.283021 0.065351 0.245840 0.033137 -0.021137 -0.245019 -0.102624 1.631439 0.462301 1.532901 0.133014 0.079045 0.450558 1.061941 1.898554 0.507196 1.226904 0.663782 0.379349 1.659890 1.360030 0.408513 0.568905 0.876030 1.829471 -0.331743 1.109442 0.325360 1.299379 0.003611 0.124368 1.612931 0.587209)
+ 8.384025 #(0.000000 -1.759204 0.258773 1.490961 0.614632 1.064083 0.749896 -0.054942 1.188953 -0.082775 0.873036 -0.312376 1.062898 0.841428 1.045571 -0.065614 1.274975 -1.916910 0.276098 1.092748 1.503967 1.111596 -0.088316 1.884539 0.350921 1.500472 0.770480 1.064780 1.223070 1.884184 0.475186 0.211115 -0.005807 1.621787 0.302411 0.412290 0.527707 1.021672 0.701884 0.707746 1.214077 0.185530 0.223747 0.017949 -0.122008 -0.024415 -0.102678 1.672194 0.539296 1.640314 0.112358 -0.000335 0.417518 1.145914 1.923035 0.558680 1.387459 0.626065 0.470292 1.786608 1.415338 0.546162 0.422057 0.960620 1.843908 -0.193870 1.077382 0.539432 1.348518 0.161710 0.094632 1.427803 0.677105)
+
+ 8.371506 #(0.000000 -1.867938 0.232496 1.586661 0.641992 0.928863 0.649348 -0.044198 1.085010 0.079229 0.862927 -0.237800 1.012094 0.965795 1.257653 -0.154609 1.363426 -0.126060 0.258325 1.241200 1.562391 1.221551 -0.017796 -0.046230 0.396012 1.553068 0.824411 1.145699 1.128785 -0.049237 0.673355 0.304031 -0.042615 1.642256 0.320764 0.567488 0.582997 1.177975 0.715492 0.736721 1.338915 0.369645 0.312354 0.097607 -0.086716 0.014634 0.001469 1.805330 0.848100 1.689101 -0.032587 0.024783 0.624333 1.292453 0.091180 0.653940 1.534562 0.693020 0.501144 0.009915 1.675154 0.697198 0.435218 1.219144 0.148845 0.005218 1.413815 0.712782 1.528783 0.213630 0.113661 1.648322 0.824916)
)
;;; 74 all -------------------------------------------------------------------------------- ; 8.6023
(vector 74 10.684138298035 (fv 0 1 1 0 0 1 1 1 1 1 0 1 0 0 0 1 1 1 1 1 1 1 0 0 0 1 0 0 1 0 1 0 1 0 0 1 0 1 0 0 0 0 0 1 0 0 0 0 1 1 1 0 0 1 1 0 1 1 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 1)
8.497103 (fv 0.000000 1.325782 0.182538 1.505234 0.945874 -0.041671 1.080868 0.605444 0.042184 0.866151 0.092779 0.735532 1.859565 0.020319 1.317206 0.107906 1.193633 1.487996 0.330731 0.601261 1.523499 -0.092194 -0.139866 0.997309 1.096776 -0.197191 1.061243 0.954641 0.070885 1.639404 0.509022 -0.561148 1.719565 1.632249 0.046116 -0.076359 1.376098 -0.015465 1.245129 0.220256 -0.000849 1.641349 1.603215 1.034336 0.812483 1.278349 1.510965 -0.515530 0.337854 1.060139 1.372801 0.633196 -0.113165 0.038608 0.288776 0.637200 0.027245 0.289307 1.083582 1.060936 0.972742 0.986362 -0.049682 0.384401 -0.025034 0.779020 0.227500 0.842052 1.419898 1.088862 -0.034683 -0.286302 1.416569 1.188508)
+
+ 8.468489 #(0.000000 1.397351 0.199115 1.454114 1.031715 -0.176142 1.092851 0.462165 -0.016726 0.853430 -0.146725 0.811539 1.707371 -0.117500 1.407819 0.198961 1.078765 1.327293 0.331176 0.524536 1.478718 -0.063221 -0.112592 0.975553 1.167568 -0.244228 0.941673 1.029112 0.072643 1.555004 0.515688 -0.520416 1.848291 1.770668 -0.056909 0.037394 1.125814 -0.215204 1.309496 0.093237 -0.026125 1.523106 1.564912 1.107622 0.871096 1.093068 1.436174 -0.591776 -0.083622 0.913864 1.332465 0.538923 -0.091814 0.025942 0.246267 0.665145 0.061016 0.018831 1.154856 0.928981 0.707435 0.975317 -0.203276 0.390356 -0.015578 0.659407 0.326913 0.774677 1.281753 0.892058 0.125387 -0.275161 1.292193 1.029723)
)
;;; 75 all -------------------------------------------------------------------------------- ; 8.6603
@@ -881,28 +919,33 @@
8.821449 (fv 0.000000 0.643920 1.130972 1.690238 0.292464 0.869774 1.528895 0.096431 0.833368 1.732367 0.427956 1.133243 1.895101 0.800425 1.503313 0.355825 1.366323 0.344133 1.388010 0.331489 1.394341 0.485612 1.420333 0.688914 1.775329 0.789323 0.036609 1.415234 0.580136 1.640322 0.948602 0.310562 1.639770 0.988134 0.358709 1.824434 1.269806 0.767195 0.219365 1.612634 1.203169 0.799392 0.490094 0.057192 1.813674 1.532055 1.111172 0.983185 0.529777 0.494315 0.164905 0.200436 0.060224 0.054336 1.844838 1.742836 -0.015897 1.650654 1.808368 1.772294 1.907511 0.205329 0.331823 0.493249 0.521115 0.584376 0.981386 1.313449 1.561550 1.968782 0.480174 0.693653 1.229745 1.573452 0.052739)
;; 74+1
- 8.558162 #(0.000000 1.299463 0.144766 1.482206 0.852041 0.041751 0.945435 0.663483 0.032304 0.784185 0.138079 0.757000 1.655016 -0.051151 1.355972 0.142680 1.361194 1.375515 0.355950 0.322113 1.647006 -0.122201 -0.167635 1.027227 0.946767 -0.181720 1.159893 0.860801 0.046383 1.617661 0.451596 -0.634275 1.845795 1.639204 0.033347 -0.058314 1.256252 0.010245 1.129872 0.165186 -0.262708 1.745515 1.511527 1.020459 0.814780 1.270884 1.648219 -0.420679 0.234869 1.046009 1.235347 0.477491 0.107721 -0.063079 0.160473 0.709557 -0.087490 0.220254 0.843552 0.987545 0.718476 0.992398 -0.027851 0.215501 0.090914 0.848865 0.253479 0.800849 1.468047 1.086774 -0.125845 -0.438777 1.410433 1.246292 0.092658)
-
- ;; 76-1
- 9.623 (fv 0.000000 0.389242 -0.170662 1.421644 1.248164 0.164000 0.718605 1.792721 0.677210 1.518595 0.963267 -0.186472 1.263794 1.595425 0.383743 0.443182 1.535243 0.669172 1.194047 0.802827 1.746269 0.569800 1.408025 1.796723 1.258639 0.620093 0.886554 0.863256 0.711462 1.456391 -0.186271 0.639923 1.414383 -0.059653 0.858601 0.618312 0.847274 0.301714 0.319909 0.359052 0.817062 -0.212571 0.558016 0.169995 1.152558 0.886044 1.332154 0.013242 0.369659 -0.032997 1.710630 1.029547 0.363359 -0.095703 0.197840 0.264645 1.078918 0.774045 1.172991 1.082380 0.650868 1.140749 0.194089 0.747056 0.734148 0.248352 1.094670 0.793873 -0.197763 1.665030 0.915389 0.675623 1.504323 1.585265 1.586133)
+ 8.515318 #(0.000000 1.389029 0.053243 1.526646 1.085943 -0.014266 1.021845 0.785533 0.105740 1.066202 0.109541 0.721402 1.481339 -0.062236 1.471506 0.193577 1.353902 1.400242 0.278679 0.324177 1.590186 -0.227902 -0.241771 0.976773 0.943703 -0.115168 1.214668 0.867933 0.090538 1.812393 0.551644 -0.544819 1.885995 1.482864 0.072438 -0.206638 1.277003 0.005949 1.175272 0.161211 -0.337581 1.706146 1.432946 0.961103 0.665555 1.251116 1.581164 -0.454588 0.421031 1.091995 1.387656 0.588011 0.099113 -0.117947 0.106565 0.807292 -0.158839 0.438389 0.959674 0.818415 0.684353 0.940338 0.056996 0.185598 0.120952 0.730169 0.579518 0.929526 1.498906 1.051412 -0.221875 -0.584880 1.336940 1.131418 0.326487)
+ 8.512424 #(0.000000 1.411165 0.066815 1.545993 0.946095 -0.013826 1.044201 0.645921 0.167534 0.936997 0.015362 0.752008 1.506866 -0.158860 1.516968 0.188211 1.320449 1.416434 0.301211 0.249914 1.630679 -0.182057 -0.250234 1.010984 0.856089 -0.194871 1.267794 0.818904 0.026503 1.685044 0.447764 -0.570160 1.818021 1.556283 0.065474 -0.160812 1.254420 0.015713 1.097954 0.076322 -0.329350 1.595682 1.328596 0.970473 0.523251 1.172474 1.547586 -0.576799 0.315720 1.005997 1.384889 0.446334 0.034057 -0.043520 0.102641 0.907794 -0.217100 0.330956 0.799047 0.751974 0.718734 0.830887 -0.040874 0.108169 -0.077398 0.706941 0.367992 0.821591 1.448143 1.030496 -0.359435 -0.609102 1.208112 1.153589 0.207741)
)
;;; 76 all -------------------------------------------------------------------------------- ; 8.7178
(vector 76 10.689208030701 (fv 0 0 1 1 1 0 0 1 0 1 1 1 0 1 1 0 0 0 0 0 0 0 1 0 1 0 1 0 0 0 1 0 0 1 1 1 0 1 0 0 0 1 0 1 1 0 1 1 0 1 1 1 0 0 1 1 0 1 0 1 1 0 1 1 1 1 0 0 0 1 0 0 1 0 0 0)
8.622898 (fv 0.000000 0.389242 -0.170662 1.421644 1.248164 0.164000 0.718605 1.792721 0.677210 1.518595 0.963267 -0.186472 1.263794 1.595425 0.383743 0.443182 1.535243 0.669172 1.194047 0.802827 1.746269 0.569800 1.408025 1.796723 1.258639 0.620093 0.886554 0.863256 0.711462 1.456391 -0.186271 0.639923 1.414383 -0.059653 0.858601 0.618312 0.847274 0.301714 0.319909 0.359052 0.817062 -0.212571 0.558016 0.169995 1.152558 0.886044 1.332154 0.013242 0.369659 -0.032997 1.710630 1.029547 0.363359 -0.095703 0.197840 0.264645 1.078918 0.774045 1.172991 1.082380 0.650868 1.140749 0.194089 0.747056 0.734148 0.248352 1.094670 0.793873 -0.197763 1.665030 0.915389 0.675623 1.504323 1.585265 1.586133 1.087431)
+
+ 8.574100 #(0.000000 0.381067 -0.272442 1.488465 1.142707 0.360320 0.746704 1.847055 0.740548 1.508045 0.951781 -0.163260 1.230184 1.623769 0.378228 0.442543 1.444666 0.627164 1.121499 0.747522 1.711575 0.455052 1.521242 1.941174 1.200574 0.592945 0.847791 0.979331 0.775371 1.568106 -0.195026 0.565512 1.483676 -0.004045 0.884949 0.722398 0.759194 0.390231 0.390425 0.259838 0.870917 -0.376787 0.551015 0.111447 1.304287 0.854661 1.506961 -0.032845 0.351362 0.031608 1.942972 1.061692 0.389298 -0.107628 -0.038521 0.239436 1.098754 0.925984 1.312533 1.079671 0.638668 1.047785 0.324774 0.836243 0.863976 0.266976 1.127471 0.871925 -0.192469 1.644992 0.941790 0.676374 1.373040 1.680505 1.659912 0.999514)
+ 8.566643 #(0.000000 0.381106 -0.266391 1.483482 1.132005 0.371120 0.752013 1.832292 0.729074 1.486332 1.011195 -0.165598 1.221917 1.641575 0.360666 0.433077 1.404878 0.604388 1.104926 0.729165 1.669029 0.450931 1.499767 -0.080683 1.221002 0.625260 0.828962 0.972153 0.755738 1.545260 -0.154840 0.581108 1.513378 0.013021 0.891683 0.702677 0.747453 0.397193 0.417760 0.289893 0.885881 -0.366958 0.566657 0.149934 1.332346 0.845232 1.552276 -0.056636 0.409890 0.036503 -0.043099 1.055520 0.429840 -0.126953 0.004032 0.241993 1.122772 0.921410 1.349658 1.081742 0.615932 1.026733 0.322881 0.803706 0.857043 0.333651 1.097387 0.873399 -0.168242 1.662747 0.934611 0.695385 1.391924 1.697835 1.605684 0.993676)
)
;;; 77 all -------------------------------------------------------------------------------- ; 8.7750
(vector 77 11.114716461811 (fv 0 1 0 0 1 1 1 1 1 0 0 1 0 1 0 1 0 1 1 0 0 0 0 0 0 1 0 1 0 0 1 1 1 1 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 0 1 0 0 0 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 0 1 1 0 0 0 0)
8.693626 (fv 0.000000 0.342470 0.518102 0.602103 1.407511 1.793531 0.096346 0.250378 0.943784 0.388159 0.656038 0.296223 1.141950 0.214103 0.212479 0.828756 1.402312 1.692057 0.511954 0.158583 -0.254149 0.373835 0.095344 -0.147316 0.784069 0.081610 -0.056393 0.798330 0.705534 1.696239 0.742515 1.236436 -0.107133 1.590407 0.658892 -0.033009 -0.161883 1.612218 1.476439 0.692575 -0.060023 1.224517 0.875204 0.501273 0.494798 0.327706 1.600469 0.607079 0.567961 0.917115 0.716199 1.138396 0.731691 -0.084350 0.371809 0.181536 0.739186 1.478965 0.762792 0.759384 1.499056 1.662862 1.474568 1.752637 0.981158 1.382311 0.543578 -0.609814 1.825975 0.848970 1.045950 0.310451 0.519502 0.003348 1.354017 -0.105098 1.298274)
+
+ 8.657403 #(0.000000 0.144503 0.521174 0.518787 1.193244 1.814457 -0.020944 0.363643 0.853723 0.860530 0.580514 0.078066 1.010161 0.221441 0.183044 0.759859 1.545184 -0.010635 0.635858 0.285802 -0.330206 0.372074 0.148651 -0.307361 0.733497 -0.192823 -0.013078 0.625648 0.850253 1.811781 0.605791 1.229804 0.065972 1.468728 0.623063 -0.230764 -0.019445 1.531051 1.297899 0.768834 -0.081130 1.071894 0.927752 0.511168 0.237065 0.316832 -0.004891 0.571763 0.647286 1.228392 0.493001 1.368827 0.671571 -0.234110 0.332624 0.387950 0.822479 1.176496 1.091221 0.738538 1.432063 1.421456 1.054724 -0.269734 0.700009 1.401715 0.397450 -0.246031 -0.115146 0.640052 0.961541 0.375597 0.318506 -0.237690 1.548563 -0.512722 1.445228)
+ 8.655850 #(0.000000 0.144015 0.521787 0.519011 1.193985 1.813929 -0.020721 0.363063 0.853642 0.859887 0.580896 0.078449 1.009266 0.221508 0.182992 0.759898 1.544517 -0.010376 0.635651 0.285693 -0.330723 0.371939 0.149327 -0.307594 0.733085 -0.192814 -0.013453 0.625868 0.850147 1.811263 0.605103 1.230124 0.065834 1.468308 0.622956 -0.230654 -0.019787 1.531322 1.297364 0.769617 -0.081404 1.071828 0.928156 0.511154 0.237021 0.316908 -0.004413 0.571845 0.646678 1.228590 0.492699 1.369241 0.672452 -0.233665 0.332431 0.388115 0.821896 1.176234 1.091315 0.738910 1.432114 1.421319 1.054889 -0.269641 0.700596 1.402150 0.397349 -0.245474 -0.116062 0.640946 0.961580 0.375676 0.318553 -0.237609 1.548434 -0.512459 1.445327)
)
;;; 78 all -------------------------------------------------------------------------------- ; 8.8318
(vector 78 11.471938943963 (fv 0 1 1 0 1 0 0 0 0 1 0 0 1 0 1 1 1 0 0 1 1 0 0 1 1 0 1 1 1 0 0 0 1 0 1 1 1 1 0 0 0 1 1 1 0 1 0 0 1 0 1 0 1 1 1 1 1 1 1 0 0 0 1 0 0 0 0 0 1 0 0 1 1 1 0 0 0 1)
- 8.722411 (fv 0.000000 1.255512 1.230399 0.081980 0.091889 1.621099 0.342591 1.837930 1.553347 0.020611 1.397162 1.790981 1.252453 0.690562 0.318059 1.053703 0.774563 1.716197 0.556425 0.552259 0.785064 1.839927 0.777897 1.437066 0.895405 0.585543 1.604873 0.287802 1.218230 1.490317 0.738166 1.716918 1.559725 1.441156 1.459900 0.634618 1.118581 1.560941 1.459563 0.686391 0.612299 1.393780 -0.080258 0.668424 0.483242 1.297761 1.805261 0.997133 1.633324 0.413677 0.790560 1.306313 0.980643 1.877269 0.988455 0.158400 0.345980 0.044253 -0.181533 1.453766 -0.079535 1.631519 0.486812 0.259728 0.034933 -0.142793 0.162924 0.999804 0.854260 0.983588 1.417702 1.583925 0.160842 -0.232352 1.810021 0.235258 1.847667 1.008413)
+ 8.721647 #(0.000000 1.249128 1.236819 0.086271 0.084870 1.618123 0.329492 1.828009 1.561909 0.021559 1.381905 1.787354 1.267428 0.679445 0.317703 1.068186 0.771332 1.720040 0.579492 0.551164 0.773425 1.834796 0.776430 1.432091 0.890602 0.586016 1.596666 0.290630 1.219329 1.491675 0.728639 1.708194 1.560487 1.434303 1.462488 0.635070 1.113941 1.563335 1.460331 0.701917 0.605822 1.400388 -0.075938 0.671582 0.475347 1.301044 1.799871 0.995216 1.609922 0.401184 0.764542 1.290171 0.978260 1.880400 0.986160 0.147021 0.340498 0.060183 -0.194639 1.442758 -0.089614 1.632445 0.465746 0.262863 0.032668 -0.154147 0.169869 0.985285 0.862469 0.985943 1.417781 1.577680 0.168817 -0.243252 1.808701 0.241312 1.826852 1.010182)
+ 8.713157 #(0.000000 1.185175 1.397998 0.029507 -0.003150 1.681558 0.352287 -0.142980 1.503432 -0.031653 1.606742 1.761627 1.241378 0.692257 0.198504 1.080125 0.928512 1.682058 0.474050 0.647248 0.825797 1.866311 0.823439 1.412665 0.855734 0.627072 1.762849 0.273347 1.224795 1.527402 0.799841 1.826401 1.613076 1.464329 1.459644 0.659045 1.125726 1.685514 1.459290 0.692583 0.629938 1.416569 -0.101579 0.653448 0.364955 1.272692 1.662367 1.045389 1.620168 0.458585 0.835933 1.249466 0.947077 -0.133359 1.014573 0.250790 0.421139 -0.005825 -0.027874 1.307059 0.066093 1.637593 0.497687 0.345017 0.115925 -0.006858 0.311739 1.192497 0.790849 1.021741 1.387921 1.598464 0.189632 -0.083007 1.800753 0.182932 -0.105722 0.993536)
)
;;; 79 all -------------------------------------------------------------------------------- ; 8.8882
@@ -911,7 +954,8 @@
8.845367 (fv 0.000000 1.238318 1.165090 1.291700 0.803595 0.614248 1.388497 1.905092 0.146964 0.775475 0.093294 -0.057178 0.069260 0.967289 0.726888 1.927694 0.404014 -0.050125 1.170622 0.795731 0.415661 0.113117 0.949983 0.547877 0.937155 0.147536 1.182414 0.680260 0.043365 0.406697 0.191985 0.520170 0.649818 0.646884 0.567272 1.384599 1.089945 0.420022 1.776381 1.388186 1.481564 0.061642 1.806781 0.638535 0.038366 1.606509 1.826388 1.366478 1.328019 0.480776 1.683074 0.476259 0.537766 1.179629 1.609320 1.234604 0.090600 0.429089 1.028733 0.835166 0.689618 1.227466 0.068475 0.130750 1.461448 1.601183 1.627224 0.857096 1.862391 0.455364 1.260302 0.135047 1.550455 0.219288 0.922341 0.004761 0.651583 1.409352 1.642849)
;; pp:
- 8.789422 (fv 0.000000 0.841271 1.349529 1.890897 0.486913 1.229207 1.764686 0.291323 1.071234 1.657114 0.392223 1.196564 -0.051237 1.012534 1.818519 0.557943 1.398685 0.101423 1.163908 0.287712 1.222706 0.108952 1.110220 0.148905 1.491258 0.557702 1.639140 0.711113 1.834003 1.123857 0.414123 1.736420 1.249713 0.566166 1.633495 0.696955 0.342141 1.602019 1.390394 0.718811 0.378092 1.687751 1.289262 0.793430 0.544409 0.190417 1.780346 1.824595 1.124520 1.532834 0.805430 0.739198 0.373300 -0.106662 1.921342 -0.093028 1.851981 1.677334 0.037484 1.564822 1.520739 1.501603 1.425816 1.592847 1.805684 0.130893 0.254917 0.439595 0.443645 0.715009 0.911405 1.240948 -0.028352 0.369153 0.881458 1.168966 1.410521 1.748339 0.400660)
+ 8.777582 #(0.000000 0.850012 1.278466 1.671652 0.485604 1.428681 1.798079 0.243483 0.926746 1.779185 0.395714 1.026729 -0.089658 1.070596 1.891094 0.483045 1.500429 0.189865 1.099066 0.205077 0.960527 0.060100 1.107914 0.183231 1.450310 0.468483 1.446982 0.685162 -0.081146 1.099289 0.484068 -0.117908 1.374114 0.639742 1.715595 0.816256 0.293012 1.668108 1.425294 0.747308 0.296172 1.780496 1.411915 0.770108 0.585162 0.343644 1.740454 0.115329 1.259755 1.673967 0.856085 0.577614 0.383167 0.304410 -0.049803 0.056826 -0.212368 1.721031 0.015177 1.660724 1.618929 1.612917 1.203620 1.624606 1.770412 0.046014 0.166329 0.333277 0.356575 0.671429 0.926511 1.256476 -0.022764 0.419017 0.748312 1.255568 1.486031 1.553904 0.445544)
+ 8.767436 #(0.000000 0.718403 1.251314 1.486434 0.417739 1.537028 1.781280 0.371804 0.856023 1.697105 0.410324 1.015131 -0.119095 1.081250 -0.157946 0.436892 1.552209 0.310681 1.199628 0.374846 0.988915 0.054273 1.300951 0.365816 1.604177 0.398188 1.427075 0.723659 0.021475 1.135277 0.715183 -0.075549 1.555657 0.584681 1.776086 0.831855 0.296030 1.723871 1.434840 0.893843 0.399844 1.754534 1.625700 0.603594 0.563673 0.311786 1.758993 0.014755 1.458293 1.648023 0.983651 0.560806 0.171502 0.278061 0.103727 -0.090556 -0.256311 1.589447 0.057298 1.706317 1.625686 1.735520 1.218723 1.651189 1.784299 0.256509 0.287738 0.688962 0.644695 0.791051 0.753121 1.204382 -0.074638 0.485008 0.749887 1.461595 1.411150 1.659818 0.509864)
)
;;; 80 all -------------------------------------------------------------------------------- ; 8.9443
@@ -927,6 +971,13 @@
;; pp:
8.909320 (fv 0.000000 0.637783 1.093840 1.736075 0.229438 0.855956 1.363854 0.030260 0.521624 1.242121 0.051165 0.675419 1.614595 0.476873 1.278688 0.012785 0.817110 -0.304934 0.720383 -0.202920 0.733695 0.107439 1.315558 0.129614 1.122993 0.193244 1.234642 0.403581 1.725244 0.895732 0.205820 1.636536 0.593082 1.809528 1.260391 0.470119 -0.070091 1.399098 0.818162 0.271203 1.928340 1.562814 0.865292 0.051460 1.916623 1.232135 1.265689 0.734799 0.654116 0.188660 0.092307 1.641866 1.468875 0.817027 0.972897 0.621305 0.637924 0.617240 0.962249 0.473819 0.518139 0.286173 0.438785 0.267011 0.412016 0.426579 0.834941 1.189978 1.256888 1.096694 1.389245 1.442391 -0.226908 0.347927 0.458943 0.982038 1.505430 1.850054 0.061414 0.437908 0.768823)
+
+ ;; also 80+1 originally:
+ 8.968686 #(0.000000 0.248430 0.863441 0.293416 0.756185 1.379289 -0.270431 1.263800 1.341315 1.557550 1.197384 0.213673 0.196685 0.062803 0.468673 0.734019 1.159371 0.832869 1.483006 0.904988 -0.128901 0.681963 0.619993 1.568168 0.324132 1.473951 1.629584 0.505398 0.500570 -0.070053 1.349935 -0.001861 1.159249 0.864343 0.801291 -0.786597 0.513558 0.362321 0.664120 0.282478 0.118044 1.145415 -0.296862 0.587955 -0.589352 0.600173 1.355457 -0.471847 0.396241 0.750727 1.123705 -0.583153 0.192765 0.272763 0.931980 0.776263 0.394773 0.897959 0.871419 0.420019 0.376219 -0.208891 0.894969 0.785338 0.828230 0.967371 0.361582 -0.266678 0.703981 -0.550373 0.421334 -0.253234 1.003690 -0.389957 -0.015548 -0.430183 -0.152241 1.200914 0.591632 -0.142675 -0.492441)
+
+ ;; 80+1
+ 8.836929 #(0.000000 0.600435 0.759195 0.460866 0.876786 1.482477 0.022359 1.530133 1.386064 1.556967 0.976396 0.025139 0.378942 0.486623 0.305352 0.510982 1.177583 0.608411 1.729528 1.236330 0.190738 0.641421 0.479741 1.167104 0.251154 1.751805 1.529684 0.421282 0.583147 -0.254542 1.145882 0.076055 1.307550 0.788062 0.476419 -0.171713 0.409127 0.068193 0.662941 0.634739 0.179937 1.124114 -0.219237 0.782837 -0.420680 0.508914 1.655542 -0.207171 0.385791 0.948310 0.881939 -0.206557 0.102690 0.659804 1.271695 0.207066 0.533428 0.862800 0.316247 0.044228 0.537516 0.119275 0.869325 1.102893 0.890935 0.541211 0.248483 -0.283730 0.928308 0.005152 0.569189 -0.249080 1.036720 -0.500679 -0.213149 1.594222 1.282267 1.317859 0.748067 -0.281326 -0.552875)
+ 8.820685 #(0.000000 0.593630 0.758230 0.465683 0.876524 1.481189 0.021360 1.524018 1.384660 1.558040 0.979102 0.025450 0.375612 0.490752 0.307436 0.514843 1.178678 0.610527 1.730121 1.227185 0.190461 0.641406 0.480351 1.164691 0.252412 1.750200 1.527118 0.419865 0.574258 -0.253171 1.144507 0.077228 1.307466 0.786104 0.467165 -0.173541 0.404628 0.061764 0.661230 0.631406 0.172778 1.124031 -0.219100 0.782068 -0.416493 0.503292 1.655559 -0.202729 0.385799 0.951281 0.886755 -0.209660 0.100539 0.655964 1.272005 0.200569 0.540622 0.867801 0.319978 0.043401 0.528483 0.117444 0.872904 1.107140 0.890387 0.545268 0.258207 -0.290140 0.927740 0.000544 0.566356 -0.246542 1.030323 -0.508880 -0.210882 1.592254 1.281549 1.315862 0.753109 -0.282396 -0.551603)
)
;;; 82 all -------------------------------------------------------------------------------- ; 9.0554
@@ -936,6 +987,10 @@
;; pp:
8.942054 (fv 0.000000 0.741190 1.211121 1.767480 0.098390 0.839201 1.102556 -0.209453 0.453250 1.122839 0.064920 0.959867 1.388767 0.263801 1.292900 0.219769 1.265994 0.422114 1.103821 -0.093210 0.755477 0.000245 0.969187 1.607339 1.053959 0.313625 1.046034 0.279348 1.465040 0.751688 0.022843 1.470315 0.592990 1.853486 1.118710 0.593243 1.855200 0.862858 0.945784 0.185739 1.601158 1.076300 0.669622 0.291600 1.841348 1.175765 0.663836 0.601642 0.369909 1.837262 -0.023948 1.335189 1.343186 0.755277 0.855544 0.293163 0.518573 0.368668 0.285100 0.386831 1.688397 0.163703 0.172910 0.313842 -0.159903 -0.137818 0.212922 0.539645 0.627827 0.897666 0.865830 1.159886 1.047275 1.360198 1.762925 0.204264 1.078567 0.797293 1.200018 1.357729 0.204458 0.441846)
+
+ ;; 81+1
+ 8.880112 #(0.000000 0.556277 1.048737 0.613952 0.943721 1.398746 0.037508 1.566628 1.720178 1.471825 1.010904 0.025372 0.431461 0.799911 0.262693 0.572971 1.206602 0.470885 -0.146209 1.018200 0.199475 1.039326 0.590090 1.259119 0.106599 1.618621 1.760723 0.128449 0.965865 -0.693032 0.901930 0.079273 0.877431 1.081960 0.292130 -0.302787 0.661667 0.066792 0.553002 0.733824 0.686894 0.969632 -0.164122 0.666971 -0.478541 0.472820 1.668413 -0.165306 0.521892 0.841207 1.141238 0.005202 0.337850 0.736190 1.034924 0.589782 0.482412 0.213340 0.040924 0.191594 0.782320 0.149989 0.926438 1.170121 1.044384 0.654924 0.181060 -0.001892 1.133516 -0.444317 0.800939 0.008067 1.334041 -0.523482 -0.041892 1.486796 1.257363 1.192524 0.832377 -0.233294 -0.488597 0.403022)
+ 8.870389 #(0.000000 0.539105 1.020560 0.615701 0.902145 1.387963 0.032876 1.624264 1.691685 1.494854 0.992079 0.020606 0.409928 0.807917 0.254101 0.573450 1.228237 0.499346 -0.152651 1.036348 0.219489 1.037518 0.560376 1.223274 0.125394 1.633074 1.733231 0.124910 0.927101 -0.716583 0.919669 0.061181 0.923685 1.036030 0.279797 -0.280539 0.637433 0.056302 0.550060 0.698308 0.630813 0.945211 -0.178066 0.682062 -0.467876 0.469626 1.667023 -0.217450 0.514912 0.876848 1.096408 -0.029194 0.320719 0.731463 1.010086 0.603898 0.489255 0.223415 0.057358 0.181859 0.772520 0.085671 0.928553 1.165232 1.078291 0.627360 0.183386 -0.026442 1.094239 -0.460656 0.746429 -0.022000 1.289367 -0.534942 -0.061511 1.508274 1.279393 1.222449 0.824799 -0.271340 -0.437408 0.388773)
)
;;; 83 all -------------------------------------------------------------------------------- ; 9.1104
@@ -996,8 +1051,8 @@
9.351480 (fv 0.000000 0.115345 0.952969 1.130622 0.084058 0.254252 0.443202 0.470071 0.932794 0.466331 0.591979 0.457396 1.528107 0.715257 1.847307 0.403253 0.673874 1.456603 0.267262 0.304798 0.064020 -0.007350 0.259234 -0.287472 0.913317 0.595047 1.491194 0.951199 1.469407 0.524123 -0.304693 -0.076445 1.827209 1.059199 1.449793 1.495662 0.754984 0.852314 0.216817 0.724819 0.597427 1.273980 0.926620 0.643916 0.066061 0.625597 1.284699 0.657854 0.605911 1.653365 1.442076 1.033587 -0.542590 1.262635 1.257414 1.117301 0.126208 0.112501 1.272548 0.912632 0.005045 0.757226 0.049364 -0.033316 1.800311 -0.300949 0.310947 1.267820 0.529700 0.817110 -0.265053 1.152779 -0.048439 0.296709 1.270792 1.398568 -1.703554 0.050635 0.940556 0.440806 1.384526 0.885947 -0.609539 0.281434 0.391260 0.168064 1.027217 1.891400 0.923378)
;; 90-1:
- 9.353077 #(0.000000 0.101446 0.552891 0.728107 0.524893 0.145214 1.596053 1.301540 0.926397 0.496933 0.459068 0.452889 -0.240583 1.847402 1.625502 1.401709 1.344010 1.170760 1.113124 0.952056 0.990499 1.326791 1.137187 1.344890 1.398023 1.149659 1.097175 1.559308 1.708797 -0.021498 0.416394 0.386368 0.384056 0.606232 0.977603 1.375793 1.270354 1.302953 0.359489 0.616160 1.115795 1.441415 1.647690 0.643610 0.895244 0.975118 1.685984 -0.077953 0.815100 1.503675 0.336177 0.774857 1.287785 1.833629 0.348295 1.088177 0.209087 0.777608 -0.029670 0.123001 1.329891 0.059409 1.263588 0.016222 0.685238 1.233668 0.561348 1.497739 1.015119 0.057179 0.615014 1.898096 0.865835 1.905681 0.688463 -0.268308 1.169876 0.259887 1.566670 1.025132 -0.067077 1.290408 0.701373 0.247065 1.395004 1.347652 0.414191 -0.013443 1.694985)
- 9.345721 #(0.000000 0.103486 0.551861 0.726996 0.523771 0.144646 1.597548 1.302819 0.925442 0.494761 0.457372 0.448545 -0.241478 1.847854 1.625226 1.401271 1.344622 1.169875 1.113623 0.952209 0.990633 1.328837 1.137936 1.343935 1.399193 1.149690 1.096126 1.561038 1.711408 -0.022261 0.415937 0.388160 0.384297 0.607557 0.979556 1.373917 1.270638 1.303704 0.361732 0.614655 1.116132 1.440007 1.647123 0.645566 0.896623 0.974182 1.687056 -0.077314 0.812365 1.506132 0.337144 0.772963 1.287030 1.834127 0.348950 1.088801 0.208217 0.776609 -0.031553 0.124342 1.329352 0.062088 1.264941 0.018704 0.686528 1.235155 0.563447 1.498951 1.015729 0.058587 0.616286 1.897192 0.867074 1.907854 0.688520 -0.265323 1.172547 0.258395 1.566059 1.027835 -0.069245 1.293131 0.701031 0.244435 1.397502 1.346741 0.412354 -0.014152 1.693363)
+ 9.322408 #(0.000000 0.087378 0.601494 0.619045 0.520565 0.192831 1.612417 1.279546 0.906053 0.457737 0.527283 0.437611 -0.272512 1.874208 1.597992 1.409776 1.395697 1.186577 1.086526 1.009432 1.136012 1.350067 1.144909 1.313540 1.533071 1.215995 1.081919 1.612408 1.898244 0.017826 0.553763 0.358095 0.618098 0.619590 1.152026 1.444621 1.376277 1.371746 0.475136 0.610211 1.154551 1.450756 1.825969 0.720349 1.002339 1.015582 1.779811 -0.009618 0.773423 1.486991 0.489018 0.816238 1.366259 -0.141599 0.467276 1.257869 0.320233 0.863396 -0.043865 0.225559 1.375686 0.193795 1.432403 0.122460 0.896371 1.257467 0.544644 1.620326 1.065587 0.154166 0.693743 -0.000523 0.966448 0.011206 0.776220 -0.165885 1.230078 0.317955 1.642970 1.105363 -0.006317 1.325943 0.779924 0.349832 1.497132 1.504927 0.446970 0.172096 1.705193)
+ 9.320140 #(0.000000 0.085732 0.602185 0.617175 0.522197 0.190997 1.611235 1.274110 0.904142 0.452835 0.528448 0.436361 -0.269442 1.875946 1.604690 1.410246 1.390954 1.185226 1.083722 1.011452 1.135590 1.350393 1.145416 1.310658 1.529711 1.210268 1.075280 1.616587 1.889615 0.017964 0.548241 0.362206 0.608718 0.620881 1.136435 1.437719 1.368805 1.361704 0.470220 0.611816 1.147835 1.452097 1.805611 0.720099 1.006618 1.019936 1.776678 -0.022447 0.775934 1.492975 0.482909 0.813476 1.367056 -0.142436 0.453330 1.253107 0.316399 0.860587 -0.029985 0.219767 1.368874 0.195670 1.423338 0.128208 0.885181 1.249081 0.542164 1.611389 1.068132 0.152847 0.699013 0.000977 0.975096 0.009537 0.780185 -0.175101 1.220930 0.302282 1.634100 1.108302 -0.008121 1.320665 0.766574 0.346841 1.493147 1.498406 0.444256 0.163379 1.706039)
)
;;; 90 all -------------------------------------------------------------------------------- ; 9.4868
@@ -1107,7 +1162,10 @@
9.969423 (fv 0.000000 0.594013 1.021081 1.737097 -0.040619 0.752674 1.481517 0.041655 0.616216 1.273976 -0.239494 0.706555 1.350693 0.121717 0.873486 1.615554 0.502899 0.859104 0.100209 1.240389 0.001564 0.940100 -0.110501 0.399212 1.639677 0.823186 1.849867 0.970964 1.815596 0.977295 1.876945 1.029064 0.250663 1.106062 0.440754 1.692440 0.937531 0.143047 1.343876 0.363444 1.897361 0.954251 0.489534 1.687124 1.352147 0.540407 -0.261830 1.349441 0.704373 0.447495 1.734922 1.090380 0.653989 0.307022 1.449780 1.794904 0.808626 0.497093 0.423383 -0.280469 1.640122 1.217125 1.143712 0.677390 0.472908 0.243924 0.123084 -0.178887 1.588534 1.317289 1.403860 1.454850 1.459048 1.165832 1.237401 1.000847 1.421104 1.051039 1.364625 1.447050 1.541757 1.176845 1.530906 1.723380 1.795645 0.095341 0.481918 0.307978 0.454615 1.009308 0.963604 1.200422 1.757436 -0.015019 0.420112 1.020994 1.127410 1.866034 -0.291409 0.497289 1.096855)
;; 100+1
- 9.935434 #(0.000000 0.608940 0.851264 -0.183247 1.727138 0.122260 0.917387 1.478656 1.680087 0.974509 0.439323 0.791848 -0.400157 0.270939 0.826559 1.771349 -0.433691 -0.112515 1.672261 1.661638 0.947155 -0.005681 0.389466 0.024556 0.225657 1.489635 0.270053 1.524879 1.478658 0.920158 1.189636 1.632789 1.150797 0.730326 1.420509 0.804787 0.804256 0.161800 1.160606 0.404414 0.173309 -0.015766 0.808661 0.387616 1.832938 0.006849 1.436327 0.251026 0.730578 0.634439 -0.102483 1.314743 1.381684 1.164318 0.424834 0.251180 -0.031006 -0.152152 -0.160917 -0.051668 0.286561 0.725355 0.786811 0.879068 0.251667 1.304955 -0.186646 0.532400 0.492416 -0.418753 0.613717 0.827376 1.513960 0.266304 1.474733 0.648266 1.615446 1.681220 0.455322 0.845513 1.730307 -0.669948 1.389624 1.537351 0.147023 0.449375 1.548892 1.696954 0.063719 1.612335 0.578406 1.747879 1.363473 0.348630 1.578073 0.726784 1.512834 1.528359 1.464039 0.047404 0.063700)
+ 9.928334 #(0.000000 0.665967 0.808488 -0.299452 1.814455 0.103115 0.907176 1.394075 1.630101 0.900795 0.296519 0.962833 -0.433738 0.560295 0.666980 1.835154 -0.279839 -0.031634 1.784110 1.588290 1.067637 -0.084296 0.498781 -0.141826 0.313843 1.417194 0.278161 1.651147 1.555702 0.978173 1.181141 1.302529 1.194189 0.828430 1.413184 0.866774 0.480085 0.297646 1.211562 0.387667 0.067199 -0.347159 0.722985 0.483741 1.855309 -0.030363 1.226310 0.179911 0.429117 0.527809 -0.278101 1.140370 1.021869 1.189527 0.283868 0.208805 -0.049884 -0.127424 -0.115078 0.078040 0.263018 0.600699 1.081708 0.738634 0.138893 1.341511 -0.222681 0.831975 0.385157 -0.493602 0.352038 0.759227 1.590774 0.426044 1.540029 0.849237 1.363690 1.556222 0.415629 0.866591 1.752437 -0.973681 1.445077 1.553262 -0.064956 0.403839 1.648532 -0.192842 0.191551 1.416306 0.656144 1.672848 1.613529 0.059245 1.705726 0.684303 1.153859 1.402257 1.265878 0.157130 -0.103303)
+
+ 9.923211 #(0.000000 0.606742 0.854252 -0.177107 1.717126 0.126638 0.927513 1.476397 1.664457 0.956378 0.451133 0.780343 -0.425380 0.274120 0.819410 1.770573 -0.423863 -0.102054 1.673610 1.665172 0.958864 0.002206 0.371610 0.035190 0.215930 1.472185 0.267288 1.510818 1.485723 0.910446 1.171075 1.613295 1.124870 0.735294 1.425415 0.799763 0.800290 0.148538 1.137687 0.418827 0.153019 -0.025494 0.839196 0.398827 1.841432 -0.009078 1.453123 0.257094 0.733715 0.627138 -0.121791 1.284946 1.399290 1.158477 0.423864 0.225825 -0.032272 -0.147351 -0.167399 -0.074160 0.282590 0.763953 0.741827 0.899306 0.215637 1.297259 -0.216774 0.533894 0.471905 -0.440553 0.570270 0.815305 1.465352 0.243327 1.458778 0.617832 1.630736 1.654231 0.454113 0.835126 1.701784 -0.680319 1.360576 1.516060 0.138474 0.422235 1.535120 1.717955 0.034676 1.563572 0.571682 1.668014 1.359079 0.300267 1.569925 0.710452 1.497267 1.484788 1.467677 0.005121 0.068300)
+ 9.921866 #(0.000000 0.609806 0.853415 -0.178376 1.715639 0.125045 0.929898 1.476379 1.662595 0.957740 0.451135 0.781655 -0.427268 0.272758 0.818830 1.769523 -0.423916 -0.099803 1.673197 1.666031 0.957481 0.001110 0.369464 0.033970 0.216228 1.474165 0.268320 1.512523 1.483804 0.905565 1.174848 1.613266 1.125148 0.735425 1.428468 0.800602 0.802242 0.149205 1.137841 0.417883 0.150486 -0.027202 0.838573 0.398456 1.843236 -0.009638 1.452756 0.256842 0.733285 0.629225 -0.121467 1.285077 1.401085 1.159273 0.424114 0.225501 -0.029926 -0.145884 -0.166779 -0.070962 0.279800 0.763832 0.738411 0.899842 0.214924 1.297806 -0.216209 0.533724 0.471481 -0.437480 0.570518 0.814214 1.466310 0.243161 1.457087 0.616447 1.631480 1.653547 0.454623 0.836976 1.700774 -0.681521 1.358712 1.514908 0.139939 0.422637 1.532737 1.719310 0.035224 1.562793 0.575545 1.665604 1.357164 0.300428 1.567753 0.710501 1.494752 1.484684 1.466794 0.007458 0.066101)
)
;;; 102 all -------------------------------------------------------------------------------- ; 10.0995
@@ -1119,14 +1177,22 @@
10.025038 (fv 0.000000 0.605553 0.983049 1.667341 0.280594 0.813730 1.347579 0.067151 0.773566 1.170135 -0.000437 0.776577 1.339736 0.097477 0.851330 1.565309 0.392180 1.136191 -0.027326 0.943192 1.737718 0.813011 1.699444 0.599876 1.617440 0.776150 1.855177 0.961431 1.915827 0.882986 1.666203 0.596064 -0.104064 1.326950 0.560052 1.687567 0.667080 1.807593 1.118197 0.382149 1.651756 0.780071 0.152645 1.439416 0.767927 0.282152 1.693680 1.210781 0.759553 0.009785 1.134002 0.817236 0.333315 0.071267 1.596603 1.242164 0.957402 0.421360 -0.130961 1.394848 1.288611 0.865712 0.865151 0.398958 0.298422 -0.229411 1.889300 1.384404 1.672436 1.144983 1.294122 0.887806 0.874167 0.414036 1.058747 0.759420 0.922388 0.730377 0.900207 0.658168 0.691340 0.678324 0.551776 0.884009 1.344859 1.136367 1.415423 1.606731 1.827838 -0.020510 0.115669 0.332208 0.674134 1.028023 1.276947 1.696675 0.283199 0.564387 1.040113 1.365277 -0.292333 0.240887)
;; 100+2
- 10.007699 #(0.000000 0.699259 0.886512 -0.027935 1.951661 0.038656 0.782145 1.495632 1.825902 1.099844 0.475719 1.085184 -0.119480 0.345084 0.668327 1.655215 -0.443184 -0.222547 1.620205 1.430704 0.954443 0.138630 0.492113 0.019065 0.360482 1.757422 0.157902 1.550392 1.470306 0.988675 1.229630 1.690004 1.105453 0.565169 1.377624 0.841390 0.797989 0.376013 1.289740 0.395261 0.327620 0.083381 0.811382 0.494890 1.711550 0.206485 1.428555 0.082286 0.761093 0.622976 0.077603 1.537629 1.287362 1.146947 0.366315 0.298958 -0.023089 -0.278375 -0.121615 0.126454 0.360907 0.413437 0.811052 0.779664 0.308170 1.185116 -0.261499 0.353036 0.563752 -0.254871 0.625520 0.581032 1.603887 0.363229 1.270011 0.973174 1.589594 1.789366 0.533330 0.642520 1.506401 -0.681000 1.607118 1.357272 0.089328 0.463060 1.308512 1.901050 0.296922 1.480369 0.840448 1.959389 1.137022 0.183179 1.512091 0.749846 1.564567 1.660530 1.343282 0.039704 0.123170 -0.256915)
+ 10.002736 #(0.000000 0.694136 0.884286 -0.019865 1.949416 0.045647 0.784966 1.485288 1.831237 1.096539 0.463002 1.083013 -0.121170 0.359435 0.652933 1.645807 -0.422716 -0.232256 1.626278 1.440555 0.958131 0.134457 0.490737 0.007571 0.357050 1.752163 0.151816 1.558855 1.454026 0.987545 1.222854 1.687668 1.100248 0.567262 1.370806 0.848200 0.795775 0.373350 1.291901 0.405117 0.336479 0.081039 0.805242 0.490027 1.710694 0.189571 1.425039 0.086172 0.763664 0.606525 0.069586 1.531524 1.275494 1.130168 0.349598 0.298878 -0.039090 -0.285912 -0.120615 0.138896 0.355171 0.409218 0.795399 0.792160 0.288768 1.170359 -0.260392 0.351573 0.565468 -0.250055 0.636086 0.568462 1.596076 0.355472 1.258735 0.969838 1.592115 1.783400 0.530721 0.636731 1.503600 -0.690920 1.599651 1.373458 0.089786 0.445422 1.295129 1.885568 0.290790 1.482001 0.849877 1.956561 1.126285 0.177909 1.515702 0.760935 1.535581 1.648591 1.330225 0.034311 0.125802 -0.263447)
+
+ ;; 103-1
+ 10.005473 #(0.000000 0.838980 0.811821 0.292160 0.449079 -0.307282 0.933362 1.480374 0.208636 0.701613 0.433885 0.738788 -0.163196 0.069086 0.180351 0.129560 1.658816 0.937982 1.725598 -0.219727 -0.190210 1.475660 0.996768 1.327001 1.275781 -0.030914 0.689923 1.387993 1.194676 1.062303 0.447502 0.886918 1.035286 0.766146 0.099314 0.250142 -0.386195 1.501334 1.121681 1.274635 0.640345 -0.611023 0.450001 1.019627 1.440522 0.697300 -0.023140 1.283472 0.279581 1.393780 1.586139 0.993131 1.208457 1.548968 0.100477 1.174748 1.104071 0.743429 1.496343 0.272839 1.548385 0.798045 1.490342 1.777682 1.368501 0.822008 0.267053 0.794202 0.107460 1.499345 0.867964 1.491427 -0.097215 1.533169 0.402921 0.270250 -0.257992 0.733165 0.362933 1.318893 1.077996 -0.215798 0.338811 0.219994 0.763092 0.618092 0.499119 0.751451 1.206091 1.662182 0.980493 1.134808 0.914764 1.670832 0.950703 1.641772 -0.118915 0.240632 1.010529 0.168161 0.110520 0.996952)
+
+ 9.999728 #(0.000000 0.816321 0.637377 0.345148 0.370938 -0.276054 0.911607 1.500056 0.306062 0.790557 0.435222 0.904894 -0.191779 0.048392 0.194431 0.115956 1.667616 0.992921 1.656976 -0.052697 -0.117059 1.375805 0.940264 1.270518 1.293832 0.011597 0.625970 1.355481 1.224093 1.039601 0.449887 0.805739 0.950859 0.738520 0.174875 0.191457 -0.433487 1.473827 1.049203 1.269233 0.624622 -0.685355 0.429236 0.942447 1.442405 0.657046 -0.121011 1.211024 0.340089 1.400597 1.568255 1.012470 1.153465 1.450019 0.074731 1.166228 1.006182 0.717416 1.410198 0.328986 1.433746 0.699736 1.482788 1.837097 1.328917 0.778439 0.165472 0.752659 0.035502 1.456631 0.791084 1.409037 -0.237446 1.429494 0.422722 0.146817 -0.260727 0.839136 0.358089 1.270740 1.006772 -0.235207 0.256828 0.253288 0.716702 0.519351 0.455918 0.685843 1.184617 1.591454 0.861383 1.138751 0.863117 1.629288 0.841736 1.491610 -0.065444 0.127160 0.950055 0.171078 0.161369 0.979305)
)
;;; 103 all -------------------------------------------------------------------------------- ; 10.1489
(vector 103 13.435972213745 (fv 0 1 1 0 0 1 0 0 1 1 0 0 1 0 0 0 1 0 1 1 0 1 1 1 1 1 1 1 0 1 0 0 0 0 0 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 0 1 0 0 0 0 1 0 0 0 1 1 0 0 0 1 0 1 0 0 1 1 1 0 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1)
10.072606 (fv 0.000000 0.775992 0.789071 0.551328 0.298530 -0.168268 0.810417 1.541024 0.478641 0.826848 0.407673 0.769783 0.052469 0.071330 0.252339 -0.003477 1.565238 1.042251 1.681717 0.063581 0.058867 1.442741 0.917343 1.448313 1.294486 -0.061724 0.478951 1.132882 1.128620 1.082449 0.123678 0.578486 1.003285 0.918654 0.241363 0.278868 -0.414912 1.418211 0.927244 1.134797 0.489863 -0.664481 0.529310 0.940119 1.393533 0.416277 0.044802 1.197865 0.283028 1.514978 1.590639 1.159829 1.236485 1.237279 0.109313 1.090962 1.341243 0.602478 1.179629 0.285726 1.482652 0.648833 1.308230 1.743441 1.346535 0.727031 0.061582 0.907076 -0.185896 1.479865 0.775766 1.389852 -0.161651 1.518832 0.594834 0.022777 -0.099476 0.851631 0.289254 1.413652 0.958286 -0.309988 0.125895 0.222920 0.633318 0.584266 0.503924 0.660246 1.182087 1.319466 1.213616 1.220516 0.662413 1.589230 0.875855 1.466144 0.036061 0.139801 0.986962 0.226038 0.202950 0.978447 0.999923)
- 10.023934 #(0.000000 0.753951 0.779673 0.518393 0.316206 -0.218083 0.870139 1.504736 0.508331 0.809688 0.422025 0.773554 0.037541 0.011964 0.304036 -0.003721 1.596496 1.002801 1.709587 -0.064057 -0.025768 1.445605 0.900990 1.377053 1.302865 -0.071628 0.443866 1.140251 1.156707 1.055832 0.196967 0.522965 0.962707 0.915851 0.186338 0.326806 -0.419425 1.382164 0.924290 1.127505 0.506077 -0.717365 0.490628 0.923836 1.311668 0.417410 -0.037217 1.246121 0.223044 1.428120 1.587827 1.073312 1.216073 1.312023 0.011344 1.054200 1.272110 0.513048 1.232588 0.290590 1.484043 0.603027 1.228594 1.651785 1.264921 0.718395 0.081981 0.874691 -0.108206 1.415361 0.782165 1.369202 -0.230282 1.487595 0.594625 -0.026402 -0.131347 0.854028 0.304794 1.364105 0.950801 -0.275135 0.155865 0.133819 0.584290 0.570116 0.430581 0.629602 1.186517 1.300988 1.131914 1.156254 0.652711 1.526271 0.724500 1.498674 -0.060166 0.161032 0.948319 0.277002 0.145951 0.963056 1.070311)
+ 9.939365 #(0.000000 0.794367 0.781191 0.495064 0.495230 -0.388009 0.971616 1.347277 0.328242 0.741267 0.530537 1.078181 -0.237622 0.107581 0.258589 0.255024 1.565355 1.278328 1.789249 -0.140007 -0.199710 1.294397 0.953960 1.338212 1.138392 0.017529 0.484971 1.300470 1.202522 0.969811 0.455432 0.750845 0.761123 0.668283 0.289374 0.280222 -0.329630 1.253548 0.930314 1.087111 0.685593 -0.730896 0.513015 0.942289 1.448130 0.624245 -0.099966 1.306897 0.278573 1.322888 1.648294 0.849613 1.245918 1.545777 -0.106941 1.147216 0.903444 0.450981 1.376132 0.256174 1.368394 0.763297 1.355029 1.779789 1.255780 0.812388 0.170237 0.940509 -0.017353 1.623185 0.693251 1.320359 -0.226935 1.435723 0.278225 0.247083 -0.427620 0.856951 0.463721 1.355469 0.897870 -0.255243 0.194551 0.144239 0.768570 0.690462 0.453432 0.766815 1.332179 1.485970 0.855947 1.311144 0.868609 1.737822 0.574654 1.449286 -0.052990 0.247284 0.755917 0.347662 0.133411 0.978837 1.128108)
+ 9.938814 #(0.000000 0.794369 0.781179 0.494978 0.495207 -0.387960 0.971662 1.347297 0.328234 0.741307 0.530523 1.078218 -0.237594 0.107602 0.258606 0.255021 1.565400 1.278380 1.789238 -0.140020 -0.199735 1.294381 0.953983 1.338265 1.138336 0.017495 0.485041 1.300450 1.202504 0.969724 0.455427 0.750931 0.761094 0.668250 0.289329 0.280179 -0.329611 1.253574 0.930366 1.087063 0.685627 -0.730833 0.513027 0.942251 1.448095 0.624348 -0.100009 1.306860 0.278533 1.322852 1.648329 0.849694 1.245891 1.545774 -0.106935 1.147152 0.903447 0.451005 1.376091 0.256221 1.368425 0.763333 1.355003 1.779765 1.255779 0.812329 0.170135 0.940480 -0.017373 1.623180 0.693238 1.320324 -0.226936 1.435741 0.278227 0.247217 -0.427735 0.856978 0.463701 1.355420 0.897766 -0.255204 0.194551 0.144265 0.768579 0.690419 0.453417 0.766802 1.332201 1.485955 0.855932 1.311069 0.868635 1.737826 0.574603 1.449298 -0.053025 0.247307 0.755792 0.347674 0.133379 0.978880 1.128060)
+
+ 9.936450 #(0.000000 0.693644 0.706899 0.533961 0.430990 -0.357687 1.008502 1.374702 0.412678 0.741797 0.480081 1.019998 -0.130973 0.053049 0.311034 0.176361 1.575930 1.070088 1.721818 -0.094212 -0.064284 1.475356 0.919353 1.359786 1.249341 0.013083 0.514667 1.199770 1.229977 1.008921 0.437274 0.710316 0.870077 0.789348 0.187900 0.290913 -0.370061 1.358992 0.912977 1.233039 0.528258 -0.736479 0.451532 0.908453 1.426336 0.514161 0.001487 1.299314 0.308671 1.371317 1.605556 0.910902 1.236094 1.469478 -0.163740 1.081131 1.027298 0.436227 1.399959 0.293762 1.463416 0.759976 1.365407 1.783410 1.210381 0.856808 0.150643 0.958655 -0.052444 1.555663 0.803912 1.301037 -0.234888 1.489758 0.433564 0.214734 -0.174858 0.935477 0.468519 1.406960 1.062581 -0.199662 0.290782 0.285152 0.771353 0.684526 0.389441 0.762788 1.291542 1.444611 0.892838 1.229118 0.775000 1.690738 0.620913 1.533937 -0.049548 0.336829 0.889832 0.374353 0.184623 1.007735 1.061825)
)
;;; 104 all -------------------------------------------------------------------------------- ; 10.1980
@@ -1135,31 +1201,48 @@
10.124244 (fv 0.000000 1.622675 1.706946 0.969141 1.395974 1.097698 0.150298 1.207570 1.449278 0.836769 1.526696 -0.147627 1.089028 1.314193 0.833408 0.265551 0.958522 0.397626 0.447242 0.837858 1.676927 0.883730 1.604731 0.779720 0.388122 0.713835 1.704244 0.052983 0.837107 0.054588 0.549459 0.093126 1.768139 0.144405 0.937970 0.532416 -0.149569 1.622840 1.586484 0.686471 0.830291 0.095651 0.908595 0.259853 -0.301519 0.855324 -0.014912 0.748872 1.538644 -0.030037 0.020462 0.792578 0.531283 0.625746 0.346250 0.434570 0.703831 1.586850 1.489275 1.435865 0.300417 1.125540 0.355002 0.123270 0.728375 0.039493 1.718698 1.307117 0.118823 0.358408 0.405752 1.413026 1.454448 0.630369 0.900592 1.792896 1.090807 1.061221 1.814531 1.630768 0.510555 0.618481 1.214968 0.122072 0.455822 1.727623 0.073245 -0.177442 0.329678 1.542732 1.673278 -0.469931 -0.007785 0.142142 0.231493 0.623628 0.711468 0.673585 0.185009 1.333716 0.659875 0.472080 1.635059 0.745116)
;; 103+1
- 10.275285 #(0.000000 0.766045 0.758318 0.527263 0.297602 -0.220660 0.843254 1.514408 0.485353 0.812135 0.348878 0.775197 0.047879 0.029543 0.283642 0.002716 1.604201 1.035276 1.656724 -0.040752 0.022899 1.491112 0.898813 1.356951 1.324619 -0.033929 0.459965 1.111102 1.133048 1.011882 0.204025 0.504974 0.921280 0.802500 0.220289 0.307291 -0.400054 1.435114 0.877954 1.160776 0.500458 -0.700012 0.491131 0.918641 1.205216 0.410209 0.061124 1.219224 0.201639 1.418580 1.569885 1.076223 1.149827 1.271335 0.104510 1.096467 1.299860 0.536464 1.174176 0.267049 1.435559 0.590482 1.183704 1.667286 1.299866 0.752687 0.061344 0.872137 -0.023202 1.396793 0.800897 1.378479 -0.284533 1.542592 0.617940 -0.056150 -0.076140 0.860473 0.211375 1.366917 1.010531 -0.227839 0.171693 0.186622 0.600417 0.530929 0.483380 0.644987 1.142519 1.358336 1.101883 1.125957 0.647607 1.571711 0.728839 1.592844 -0.003107 0.163651 0.931816 0.281116 0.161282 0.950629 1.042875 -0.059815)
+ 10.017665 #(0.000000 0.745584 0.754703 0.591172 0.316730 -0.304771 0.899483 1.291576 0.545676 0.772500 0.260173 0.994469 0.010841 -0.025249 0.470119 -0.206891 1.625251 1.051634 1.804633 -0.290226 0.044365 1.520714 1.169280 1.579603 1.507492 -0.098599 0.554837 1.115406 1.434064 1.033197 0.173666 0.501633 0.832630 0.961445 0.155427 0.671127 -0.251235 1.186810 0.870334 0.942028 0.540752 -0.482588 0.541485 1.032711 1.176554 0.575710 0.196807 1.247991 -0.309114 1.373943 1.309961 0.661994 1.095118 1.475934 -0.067967 1.122540 1.395244 0.408007 1.356964 0.251346 1.416704 0.875598 1.007338 1.720110 0.906456 0.746887 0.314809 1.255942 0.123637 1.421756 0.602684 1.336186 -0.397992 1.545369 0.942007 -0.105531 0.032651 0.903727 0.429977 1.262458 1.203957 -0.177847 0.186686 0.130438 0.458904 0.322547 0.256233 0.884282 1.238120 1.393593 1.126188 1.032025 0.626466 1.697238 0.820645 1.808108 -0.040709 0.161290 1.012239 0.476207 0.102979 0.908021 1.239960 0.369493)
+ 10.017453 #(0.000000 0.745577 0.754726 0.591226 0.316735 -0.304732 0.899502 1.291541 0.545628 0.772480 0.260199 0.994494 0.010830 -0.025236 0.470134 -0.206891 1.625282 1.051660 1.804596 -0.290274 0.044351 1.520736 1.169238 1.579583 1.507532 -0.098601 0.554891 1.115436 1.434077 1.033226 0.173646 0.501686 0.832596 0.961466 0.155369 0.671140 -0.251224 1.186790 0.870343 0.942036 0.540730 -0.482603 0.541428 1.032737 1.176541 0.575710 0.196818 1.248017 -0.309128 1.373931 1.309926 0.661951 1.095129 1.475952 -0.067947 1.122542 1.395225 0.407986 1.356975 0.251359 1.416747 0.875553 1.007359 1.720145 0.906470 0.746959 0.314821 1.255928 0.123650 1.421810 0.602637 1.336189 -0.398002 1.545393 0.941942 -0.105497 0.032645 0.903719 0.429973 1.262454 1.203968 -0.177843 0.186621 0.130389 0.458896 0.322543 0.256192 0.884272 1.238132 1.393568 1.126227 1.031989 0.626539 1.697275 0.820678 1.808099 -0.040685 0.161330 1.012238 0.476235 0.102962 0.907998 1.239960 0.369514)
)
;;; 105 all -------------------------------------------------------------------------------- ; 10.2470
(vector 105 13.595993876506 (fv 0 1 0 0 1 1 0 0 1 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 0 1 0 1 1 1 0 0 0 1 0 1 1 1 0 0 1 0 0 0 1 0 1 1 1 1 0 1 1 0 1 0 1 0 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 0 1 0 0 0 1 1 0 0 1 1 1 0 0 1 1 1 0 0 1 0)
10.169606 (fv 0.000000 0.591462 0.235800 1.321672 1.356594 -0.405542 0.538022 0.615762 0.326243 1.062550 -0.153260 -0.031444 1.233243 1.770308 1.085997 1.514420 0.095655 1.000755 -0.065552 -0.053493 1.481942 0.777394 0.483679 1.419470 0.159850 -0.259703 0.126983 0.478035 1.178492 1.111834 1.075738 1.268063 0.962249 1.943997 1.083333 1.538989 0.307093 1.387414 1.941208 1.284189 -0.012780 1.356158 1.317824 1.095171 0.472030 0.459214 1.096373 0.477967 0.565821 1.566421 0.590639 1.381435 1.150189 0.197776 0.315906 0.587160 0.629501 0.853485 0.797405 -0.187739 1.489470 1.296970 0.273664 0.102171 1.749652 1.601370 1.902817 1.658081 0.403983 0.138955 1.356476 1.693746 1.125750 0.916183 1.246086 0.386904 -0.248158 0.148664 0.070783 0.819794 -0.019914 0.547099 0.323707 -0.046514 1.635194 0.435105 0.156523 0.390396 -0.277746 0.665321 0.200546 1.082837 1.059380 -0.041536 0.592565 0.634526 1.116414 0.039718 0.575393 -0.178156 1.655927 0.370318 0.615340 1.693958 1.282592)
+
+ ;; 103+2
+ 10.064945 #(0.000000 0.682652 0.800210 0.421652 0.554062 -0.360055 0.792317 1.465481 -0.019712 0.697608 0.554698 0.858084 0.164354 -0.019234 0.162952 0.345627 1.621651 0.956217 1.656476 -0.303453 -0.187651 1.271041 0.778998 1.434856 1.150013 -0.072967 0.339790 1.321211 1.320212 0.949083 0.543303 0.516765 0.879307 1.039360 0.093945 0.385943 -0.388725 1.561230 1.166808 1.287025 0.753324 -1.134186 0.285245 0.840389 1.554768 0.666549 -0.096352 0.924158 0.213888 1.502858 1.582784 0.980705 1.341049 1.650316 -0.198796 1.508087 1.243789 0.381493 1.651510 0.258432 1.593643 0.607159 1.330584 1.752940 1.190114 0.752124 0.301833 0.828769 -0.217850 1.553288 0.804465 1.268535 -0.132772 1.463816 0.052920 -0.009087 -0.356015 0.855416 0.196469 1.378625 1.182028 -0.269272 0.104746 0.083642 0.567469 0.929739 0.150765 0.641904 1.229939 1.430161 0.787585 1.158738 0.883860 1.662494 0.756218 1.382603 -0.075116 0.404544 1.158715 0.557851 -0.000464 1.098986 0.925246 -0.557344 -0.464571)
+ 10.063561 #(0.000000 0.681917 0.800545 0.422200 0.553031 -0.358791 0.792275 1.464678 -0.019974 0.698355 0.554660 0.858955 0.164181 -0.019183 0.163011 0.345816 1.622067 0.956173 1.657341 -0.303259 -0.187543 1.270627 0.778435 1.434875 1.149544 -0.073515 0.340352 1.321088 1.319472 0.949179 0.543646 0.516189 0.877323 1.039058 0.094178 0.386382 -0.389059 1.561917 1.166614 1.288418 0.753780 -1.134975 0.286121 0.840573 1.554402 0.666717 -0.096764 0.924388 0.213118 1.501876 1.581562 0.980168 1.340301 1.650719 -0.197635 1.506340 1.243795 0.380830 1.653721 0.258877 1.593702 0.606867 1.330583 1.752876 1.189965 0.751133 0.302075 0.827786 -0.217646 1.553498 0.803802 1.267631 -0.133418 1.463956 0.053990 -0.008952 -0.356111 0.855322 0.196092 1.378596 1.181998 -0.269211 0.103217 0.082299 0.566694 0.929139 0.150334 0.640354 1.229212 1.430106 0.787460 1.158173 0.885012 1.662401 0.755054 1.382697 -0.076381 0.402460 1.158400 0.558679 0.000097 1.098492 0.924207 -0.557968 -0.463825)
)
;;; 106 all -------------------------------------------------------------------------------- ; 10.2956
(vector 106 13.200031373463 (fv 0 0 1 0 1 0 0 1 0 0 0 1 1 0 0 1 0 0 1 0 1 0 0 1 0 0 0 0 1 0 0 1 0 1 1 1 0 1 0 1 1 1 1 0 0 0 0 1 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 1 1 0 0 1 0 0 0 0 0 1 1 0 0 1 0 1 1 0 0 1 1 1 1 1 1 0 0 1 1 0 1 1 0 0 0 0 0 1 0 1)
10.233770 (fv 0.000000 0.055119 -0.050942 1.221658 1.069634 0.969833 -0.120088 0.537260 0.774846 1.097793 1.607343 1.125046 1.248849 0.110938 0.000911 -0.176700 1.224234 0.974172 0.258380 0.044520 0.328839 0.706861 1.491508 0.262253 0.850888 0.129635 0.528138 0.085967 1.206179 1.203105 -0.212392 0.552998 1.277370 0.069273 1.300991 0.395491 0.052184 1.017350 -0.139116 0.060719 1.223876 0.765705 1.643712 0.809882 1.480192 -0.160266 1.133315 0.396498 1.706614 0.389700 1.530945 1.033706 0.669577 0.953867 0.549025 0.735362 1.230749 1.732990 0.576594 1.599366 0.250495 1.206074 1.016404 1.623424 1.318513 0.223760 1.354914 1.140942 0.138240 0.414002 0.134404 1.756706 -0.015032 -0.196090 0.317193 0.119056 -0.492220 1.081019 0.025882 -0.092539 1.764132 1.357709 0.458311 1.060374 1.019483 -0.126097 0.259596 0.137076 0.020444 0.418031 0.040745 0.523959 1.133024 0.593829 1.429205 1.802013 0.365195 0.248492 1.498863 -0.344913 0.359725 1.657142 1.374238 1.289802 -0.217105 1.333949)
+
+ ;; 105+1 = 103+3
+ 10.179981 #(0.000000 0.771266 0.798162 0.574106 0.509046 -0.454532 0.722646 1.382152 0.188134 0.639741 0.416137 0.934678 0.075406 0.041008 0.256970 0.360043 1.637722 1.021983 1.620165 -0.251506 -0.173651 1.345505 0.774331 1.358020 1.178455 0.048273 0.190944 1.354709 1.390135 0.925530 0.585598 0.586646 0.925457 0.930732 0.084979 0.308249 -0.510277 1.508378 1.202203 1.312776 0.712836 -1.217347 0.291576 1.028994 1.475323 0.702825 -0.072470 0.840094 0.187818 1.417625 1.468715 1.001276 1.223171 1.644290 -0.182504 1.499121 1.198948 0.364839 1.508784 0.234796 1.494133 0.521892 1.439752 1.612444 1.042789 0.871256 0.313132 0.872711 -0.384633 1.449440 0.726706 1.126102 -0.147870 1.347148 0.064771 0.128024 -0.342719 0.813697 0.226743 1.421921 1.020328 -0.362916 0.016145 0.192478 0.585608 0.784156 0.021533 0.652162 0.963185 1.437016 0.624122 1.232038 1.005325 1.412486 0.735986 1.181102 -0.186937 0.322568 1.015044 0.519059 0.114269 1.113254 0.730024 -0.587578 -0.573285 0.170710)
+ 10.179541 #(0.000000 0.771216 0.798169 0.574042 0.509021 -0.454539 0.722595 1.382180 0.188162 0.639751 0.416025 0.934627 0.075422 0.041033 0.257004 0.360076 1.637659 1.021990 1.620175 -0.251486 -0.173697 1.345557 0.774305 1.358151 1.178428 0.048243 0.190927 1.354610 1.390083 0.925624 0.585662 0.586630 0.925417 0.930772 0.084986 0.308253 -0.510266 1.508313 1.202180 1.312826 0.712764 -1.217280 0.291519 1.029037 1.475318 0.702806 -0.072479 0.840059 0.187882 1.417657 1.468702 1.001289 1.223142 1.644299 -0.182528 1.499144 1.198899 0.364912 1.508768 0.234745 1.494112 0.521884 1.439753 1.612428 1.042749 0.871259 0.313122 0.872774 -0.384718 1.449386 0.726766 1.126118 -0.147831 1.347158 0.064750 0.128074 -0.342700 0.813748 0.226859 1.421859 1.020298 -0.363011 0.016155 0.192420 0.585619 0.784178 0.021472 0.652147 0.963182 1.437033 0.624162 1.231941 1.005289 1.412507 0.736078 1.181129 -0.186935 0.322466 1.015056 0.519117 0.114263 1.113370 0.730072 -0.587500 -0.573316 0.170672)
)
;;; 107 all -------------------------------------------------------------------------------- ; 10.3441
(vector 107 13.224366750161 (fv 0 1 0 1 1 1 0 0 1 1 0 1 1 0 0 1 1 0 0 1 1 0 1 0 1 1 1 0 0 0 1 0 0 1 0 0 0 1 0 1 0 0 1 0 1 1 0 1 1 0 0 1 1 0 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0 1 0 1 1 0 1 1 1 1 1 1 0 1 0 1 1 1 1 0 1 0 1 1 1 1 1 0 0 0 0 0 0 1 1 1 1 1)
10.273899 (fv 0.000000 1.285870 0.722685 1.695642 1.789973 0.495199 0.001511 0.648393 1.565696 0.756830 0.421656 -0.184836 0.187469 1.381401 1.501800 0.551266 1.079110 0.129360 0.283265 1.059394 -0.217105 1.758613 1.156467 0.305791 0.018881 1.709795 1.386465 1.716357 0.543922 -0.077767 0.376814 1.917356 1.703183 0.375846 1.314995 1.049255 -0.015490 1.182770 0.105614 1.125738 1.580574 0.196175 0.043631 0.176951 1.523484 1.504279 0.024743 0.233174 0.051990 0.885176 0.485127 0.978870 1.366279 1.841166 1.225239 0.599047 0.937430 1.422432 0.950869 1.195765 0.360876 1.187450 1.491233 0.274262 0.123358 1.276789 1.498182 1.151090 1.495794 1.385360 0.511524 1.320969 1.040843 1.323508 0.526850 1.486006 0.358172 -0.084804 0.784722 0.263761 0.033435 1.669885 0.179635 1.097636 0.771172 0.674320 0.095788 1.426496 1.763465 0.078301 1.972016 1.520526 1.431005 0.272982 0.550020 1.118797 -0.453975 1.686563 1.286924 1.481496 1.458102 0.550556 0.115818 1.002355 0.493193 0.718245 1.621218)
+
+ ;; 105+2 = 103+4
+ 10.264612 #(0.000000 0.514224 0.665359 0.437182 0.342816 -0.368387 0.867170 1.680316 -0.035238 0.578630 0.393687 0.938896 -0.024374 -0.189156 0.035454 0.187626 1.668105 0.892639 1.570971 -0.276314 -0.041612 1.538700 0.575011 1.442591 1.128708 -0.096511 0.254928 1.337942 1.315964 0.935516 0.311726 0.253932 1.021526 1.268822 -0.023742 0.192028 -0.370923 1.506415 1.235486 1.032651 0.730433 -1.027437 0.230300 0.841525 1.268688 0.417647 -0.000948 0.997350 0.123998 1.172791 1.587045 0.633923 1.380769 1.634328 -0.214874 1.352466 1.164864 0.221440 1.321201 0.301078 1.532112 0.479377 1.263841 1.506446 0.979971 0.441986 0.145681 0.815023 -0.650102 1.205600 0.776509 1.020238 -0.283679 0.966039 0.145650 0.034616 -0.371329 0.803160 0.169955 1.683053 1.044817 -0.289624 -0.108629 0.452027 0.488696 0.786211 -0.208619 0.885069 1.098623 1.325857 0.780057 1.242131 0.812645 1.416037 0.467165 1.275112 -0.271849 0.464109 0.892644 0.500155 -0.131218 1.071176 0.890519 -0.502997 -0.497750 -0.438493 -0.169193)
+ 10.258830 #(0.000000 0.574863 0.710649 0.509173 0.341705 -0.258603 0.827721 1.686497 0.043643 0.656999 0.401360 0.893339 -0.070537 -0.202877 0.146726 0.184347 1.723139 0.817529 1.582194 -0.235982 0.005561 1.455954 0.674079 1.352605 1.054095 -0.078206 0.213315 1.347753 1.318381 0.982781 0.354958 0.244635 0.967764 1.229868 0.031999 0.198154 -0.444690 1.565985 1.253320 1.055940 0.818868 -1.001331 0.183205 0.867393 1.254304 0.529154 0.062476 0.852551 0.183546 1.206638 1.616905 0.704326 1.451973 1.653828 -0.165437 1.359257 1.147685 0.230348 1.322073 0.342002 1.534217 0.472562 1.303407 1.493484 0.935931 0.519310 0.245942 0.859223 -0.594681 1.279503 0.739153 0.988145 -0.268491 0.963612 0.300691 0.003142 -0.262801 0.791987 0.206787 1.692192 1.027639 -0.307391 -0.108335 0.524530 0.487821 0.760637 -0.044761 0.812681 1.025608 1.312415 0.795498 1.359445 0.826687 1.362466 0.594357 1.199103 -0.267334 0.478113 0.924328 0.481065 -0.027388 1.086650 0.900592 -0.574983 -0.573938 -0.427218 -0.169596)
)
;;; 108 all -------------------------------------------------------------------------------- ; 10.3923
(vector 108 13.534 (fv 0 1 1 0 0 0 0 1 0 1 0 0 1 1 0 1 1 1 0 1 1 0 0 0 0 1 0 1 0 0 0 1 0 1 0 0 1 0 1 0 1 1 0 0 1 1 0 1 1 0 1 0 0 1 0 0 0 0 0 1 1 1 0 0 0 1 0 0 0 0 0 1 1 0 1 1 1 0 1 0 1 1 1 0 0 0 0 1 1 1 1 1 1 0 0 1 0 1 1 0 1 0 1 0 0 0 0 1)
10.312988 (fv 0.000000 1.293654 0.754043 1.806542 1.109001 0.766775 1.436021 1.627340 0.528605 1.806494 1.181378 0.013554 0.353388 0.092480 0.431618 0.200495 0.904126 0.741464 0.675051 -0.110957 1.146773 1.810641 0.552983 0.275055 0.835876 1.123930 -0.182193 -0.339155 0.645146 0.163632 0.868047 1.269556 0.830686 1.219557 1.665806 1.060039 1.944315 -0.011848 0.365415 0.718256 0.624511 1.571990 0.113371 0.572031 1.797961 0.876379 0.068642 0.072119 0.553161 0.329387 0.545574 0.337595 1.647194 1.034042 0.468339 1.774314 0.240404 1.846502 1.142528 1.223731 0.832499 0.428931 0.643890 1.257704 1.085969 0.643637 0.429070 0.971966 0.109095 0.689833 0.417898 1.804672 1.346983 0.150026 0.404292 0.575881 1.441149 0.533070 -0.177095 0.298641 0.921545 1.086883 0.410704 0.849120 1.518187 1.874571 0.517824 1.242109 -0.053714 0.834159 0.276990 1.956354 1.765190 1.537622 1.530954 -0.106766 1.325278 -0.071959 1.045056 0.533410 0.699958 0.068418 0.070057 1.204618 1.620552 1.072110 1.372120 0.848823)
+
+ ;; 103+5
+ 10.374947 #(0.000000 0.662339 0.669289 0.531784 0.392339 -0.487364 0.675984 1.450839 0.161241 0.606092 0.594508 0.957385 0.057680 0.014652 0.220997 0.348879 1.603675 0.790978 1.705154 -0.137396 -0.198596 1.586401 0.726590 1.454575 1.399518 -0.206849 0.214718 1.311202 1.330318 0.855445 0.730970 0.492104 0.709457 0.869844 0.240430 0.326572 -0.219863 1.541532 1.358838 1.328103 0.876125 -0.864476 0.220602 1.023093 1.583629 0.603693 -0.281458 1.247304 0.173858 1.272146 1.547201 0.868617 1.202148 1.566443 -0.265227 1.475538 1.126832 0.442072 1.272975 0.069743 1.608569 0.546375 1.729787 -0.165266 1.244618 0.434472 0.280333 0.487761 -0.045704 1.380884 0.731120 0.869899 -0.062065 1.238076 -0.181995 0.375944 -0.599288 1.052764 0.185947 1.610670 1.114319 -0.459327 -0.081027 0.072067 0.570945 0.780858 0.208049 0.664110 1.308748 1.451123 0.574459 1.287385 0.565553 1.601243 0.555906 1.166221 -0.072585 0.321487 1.099870 0.756450 0.016973 1.247515 0.826123 -0.483806 -0.505822 -0.111992 -0.050341 0.277622)
+ 10.366958 #(0.000000 0.662251 0.670071 0.534968 0.390769 -0.487492 0.676412 1.452624 0.159875 0.606901 0.595543 0.956937 0.059026 0.011015 0.223033 0.349504 1.604402 0.791507 1.705129 -0.138244 -0.198943 1.586770 0.728435 1.456034 1.399704 -0.206504 0.216513 1.310164 1.330934 0.855469 0.728598 0.492931 0.709221 0.867021 0.242327 0.325006 -0.218785 1.543222 1.356338 1.327603 0.876469 -0.863391 0.220009 1.022662 1.583744 0.605894 -0.280755 1.246294 0.173429 1.274126 1.548489 0.867987 1.203052 1.564818 -0.264731 1.474519 1.125297 0.442497 1.273224 0.068873 1.609204 0.547852 1.727712 -0.165089 1.242479 0.435346 0.278407 0.487182 -0.045296 1.381315 0.729883 0.869821 -0.063016 1.238543 -0.181664 0.377990 -0.600131 1.054236 0.187515 1.612190 1.112474 -0.459367 -0.080814 0.068618 0.572010 0.780117 0.207856 0.662783 1.308574 1.451137 0.575486 1.289353 0.567156 1.600155 0.556068 1.167633 -0.072487 0.322513 1.100221 0.757263 0.020228 1.247118 0.824014 -0.483968 -0.504566 -0.113982 -0.049005 0.275202)
)
;;; 109 all -------------------------------------------------------------------------------- ; 10.440306508911
@@ -1178,17 +1261,22 @@
10.457243 #(0.000000 1.269530 0.760051 1.729694 1.122945 0.814880 1.466156 1.631086 0.616903 1.786832 1.344985 0.030797 0.418832 0.037877 0.373313 0.275814 0.977767 0.677872 0.673791 -0.065296 1.118192 1.826436 0.508528 0.285632 0.821565 1.103219 -0.267070 -0.330900 0.618539 0.170243 0.892990 1.223460 0.764058 1.162302 1.620423 0.957344 0.023461 -0.059770 0.381474 0.692706 0.660066 1.703495 0.098695 0.624314 1.751336 0.844891 0.120502 0.057294 0.621996 0.319901 0.586587 0.186646 1.685806 0.974557 0.474304 1.735548 0.234787 1.810600 1.138824 1.194376 0.872559 0.435412 0.677166 1.290849 1.011702 0.701077 0.322755 0.950082 0.024752 0.607227 0.415633 1.702576 1.323090 0.195261 0.365091 0.675664 1.408251 0.606997 -0.208324 0.308915 0.941088 1.034722 0.364193 0.967725 1.444390 1.941283 0.456248 1.293589 0.032476 0.805832 0.141117 1.965347 1.709815 1.528055 1.586120 -0.152788 1.361484 0.019126 1.044770 0.500796 0.670659 0.067435 -0.009310 1.226198 1.603811 1.046583 1.365223 0.883194 0.193296)
;; 110-1
- 10.322689 #(0.000000 0.462741 1.225949 -0.043832 0.328249 1.203588 1.366455 0.188790 0.662494 1.254935 0.088331 0.613339 1.462149 0.115526 0.949842 1.737591 0.506946 1.154137 -0.032436 0.629976 1.492938 0.520189 1.718079 0.515487 1.428565 0.137996 1.083472 0.059980 1.139261 0.225618 1.233707 0.316895 1.419668 0.505397 -0.033495 1.176194 0.083251 0.973170 -0.022020 1.079081 0.404451 -0.075399 0.954069 0.083319 1.505012 0.979962 0.145560 1.327979 0.617711 0.036057 1.210156 0.994048 0.360797 0.174071 1.687531 1.240584 0.732227 -0.166972 1.189885 0.961323 0.562443 0.160936 1.676083 1.644780 1.189431 1.265120 0.457405 -0.062176 -0.195559 1.385371 1.408492 1.397143 0.885687 1.094863 0.605162 1.202260 0.535171 0.604107 -0.037920 -0.116681 -0.077010 -0.133672 0.060191 0.259325 0.089984 -0.015913 0.025781 0.203482 0.430865 0.266253 0.224375 0.677975 0.937860 1.248001 1.478415 1.717389 -0.074246 -0.120586 0.330859 0.557195 1.125288 1.605582 1.607504 0.218383 0.840491 1.393138 1.612134 0.160685 0.161037)
- 10.322461 #(0.000000 0.462674 1.225929 -0.043823 0.328289 1.203623 1.366492 0.188811 0.662499 1.254926 0.088298 0.613331 1.462150 0.115531 0.949884 1.737576 0.506973 1.154095 -0.032430 0.630002 1.492901 0.520199 1.718088 0.515495 1.428578 0.137955 1.083433 0.059942 1.139302 0.225628 1.233696 0.316931 1.419646 0.505419 -0.033497 1.176199 0.083263 0.973159 -0.022043 1.079044 0.404491 -0.075384 0.954089 0.083290 1.505001 0.979986 0.145592 1.327990 0.617711 0.036068 1.210133 0.994076 0.360795 0.174016 1.687546 1.240574 0.732273 -0.167006 1.189898 0.961364 0.562444 0.160956 1.676079 1.644808 1.189461 1.265171 0.457402 -0.062179 -0.195550 1.385369 1.408507 1.397115 0.885691 1.094876 0.605175 1.202259 0.535204 0.604108 -0.037958 -0.116695 -0.076978 -0.133663 0.060171 0.259320 0.089947 -0.015900 0.025779 0.203485 0.430891 0.266250 0.224373 0.677986 0.937839 1.248001 1.478410 1.717359 -0.074278 -0.120509 0.330877 0.557156 1.125282 1.605553 1.607549 0.218369 0.840506 1.393115 1.612150 0.160649 0.161027)
+ 10.317140 #(0.000000 0.466349 1.223037 -0.048547 0.323977 1.203657 1.367719 0.187630 0.657819 1.251362 0.086519 0.614105 1.466130 0.119399 0.944664 1.740988 0.506084 1.149516 -0.030954 0.628514 1.494005 0.524832 1.717562 0.517597 1.425941 0.137206 1.081399 0.061277 1.144121 0.221716 1.237433 0.317276 1.420766 0.500184 -0.036811 1.170497 0.081161 0.970515 -0.023715 1.079773 0.402574 -0.076358 0.951794 0.085641 1.507539 0.981921 0.150846 1.328708 0.618279 0.035311 1.211298 0.994117 0.364832 0.177592 1.691178 1.236486 0.735313 -0.167267 1.196100 0.966444 0.565143 0.158981 1.675120 1.645837 1.195019 1.267396 0.458918 -0.062222 -0.191658 1.389608 1.410277 1.396420 0.888634 1.096165 0.607965 1.202499 0.534216 0.611126 -0.033770 -0.109171 -0.080915 -0.138588 0.061623 0.262473 0.091042 -0.019937 0.028635 0.201372 0.434309 0.265176 0.227450 0.679082 0.941635 1.249687 1.479264 1.715302 -0.073877 -0.121298 0.329766 0.557230 1.127078 1.604542 1.610922 0.215699 0.843190 1.390034 1.611440 0.159691 0.162556)
+ 10.316139 #(0.000000 0.467860 1.225582 -0.051091 0.323359 1.199983 1.366975 0.187719 0.660883 1.253225 0.082708 0.616737 1.474208 0.120695 0.946148 1.740641 0.509628 1.149625 -0.031684 0.627981 1.494201 0.523906 1.719545 0.517678 1.423044 0.134403 1.080799 0.058887 1.146126 0.223450 1.240782 0.320888 1.420488 0.499238 -0.036895 1.166877 0.079242 0.965835 -0.026305 1.082043 0.407016 -0.078901 0.951307 0.084236 1.509812 0.984128 0.155672 1.326788 0.624829 0.033701 1.214113 0.999905 0.359963 0.181048 1.698251 1.226178 0.741043 -0.169162 1.197122 0.969420 0.565193 0.157309 1.679759 1.648950 1.194633 1.269799 0.462660 -0.066040 -0.191739 1.394509 1.412861 1.398929 0.890176 1.092218 0.605306 1.201780 0.531418 0.616650 -0.032708 -0.104746 -0.085490 -0.136596 0.060249 0.261684 0.098136 -0.024191 0.030064 0.203361 0.438227 0.265314 0.225969 0.675420 0.938390 1.248614 1.479216 1.714123 -0.073635 -0.128780 0.326731 0.554524 1.126561 1.604426 1.604094 0.214665 0.842457 1.393251 1.611608 0.158085 0.161986)
)
;;; 110 all -------------------------------------------------------------------------------- ; 10.4881
(vector 110 13.592092514038 (fv 0 0 1 0 0 1 1 1 0 1 0 1 1 0 1 0 0 0 0 1 0 0 1 0 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 0 1 1 0 1 0 0 1 0 0 0 1 0 0 1 0 0 1 0 1 1 0 1 1 0 0 1 1 0 0 0 0 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 1 0 0 0 1 1 1 0 1 1 1 1 1 1 0 1 0 1 0 1 0 1)
- 10.443826 (fv 0.000000 0.966857 -0.310939 0.754018 -0.215289 0.050408 1.345912 1.407669 0.917300 1.537339 0.464664 1.377382 -0.129707 1.562018 0.873176 0.378480 1.188634 1.002593 1.467403 -0.157591 0.611052 1.240086 1.200021 0.642960 0.011727 1.278266 0.757206 1.221576 1.173971 1.148607 0.352945 0.591698 0.569729 0.204560 1.805523 0.091751 0.494475 0.741755 1.173490 0.125853 1.836232 0.189233 1.047389 0.359034 0.299905 1.335669 1.331935 0.866342 1.429328 0.175988 0.321575 0.808716 0.418347 0.305766 0.587213 0.859103 1.233827 1.612185 0.649515 1.232962 0.438531 1.088539 1.160206 1.276056 0.991705 0.605889 1.920272 1.294151 0.591700 0.477186 -0.114311 0.103729 0.053546 1.057780 1.113226 0.935069 0.869987 0.585069 1.193799 0.314064 1.564843 1.009796 1.434593 -0.061294 0.394207 1.540076 0.463315 1.070060 1.005570 -0.247697 1.209164 0.032912 1.882456 0.617912 -0.419949 0.119714 0.033254 -0.149035 1.146172 0.301556 1.043038 0.611637 1.119274 -0.185496 1.474180 0.910726 0.869288 0.008729 1.113223 0.605574)
+ 10.443826 (fv 0.000000 0.966857 -0.310939 0.754018 -0.215289 0.050408 1.345912 1.407669 0.917300 1.537339 0.464664 1.377382 -0.129707 1.562018 0.873176 0.378480 1.188634 1.002593 1.467403 -0.157591 0.611052 1.240086 1.200021 0.642960 0.011727 1.278266 0.757206 1.221576 1.173971 1.148607 0.352945 0.591698 0.569729 0.204560 1.805523 0.091751 0.494475 0.741755 1.173490 0.125853 1.836232 0.189233 1.047389 0.359034 0.299905 1.335669 1.331935 0.866342 1.429328 0.175988 0.321575 0.808716 0.418347 0.305766
+0.587213 0.859103 1.233827 1.612185 0.649515 1.232962 0.438531 1.088539 1.160206 1.276056 0.991705 0.605889 1.920272 1.294151 0.591700 0.477186 -0.114311 0.103729 0.053546 1.057780 1.113226 0.935069 0.869987 0.585069 1.193799 0.314064 1.564843 1.009796 1.434593 -0.061294 0.394207 1.540076 0.463315 1.070060 1.005570 -0.247697 1.209164 0.032912 1.882456 0.617912 -0.419949 0.119714 0.033254 -0.149035 1.146172 0.301556 1.043038 0.611637 1.119274 -0.185496 1.474180 0.910726 0.869288 0.008729 1.113223 0.605574)
;; pp:
10.416677 (fv 0.000000 0.636826 1.168776 1.802237 0.316567 0.986572 1.395425 0.009381 0.711647 1.264223 1.932392 0.627165 1.472185 0.196446 0.915303 1.747756 0.298057 1.087093 -0.098251 0.679800 1.474105 0.503701 1.516136 0.488851 1.222583 0.157308 1.093122 0.014882 1.111898 0.174280 1.267353 0.186944 1.319383 0.570938 1.741756 0.793533 -0.092041 0.821354 -0.104426 1.044239 0.485714 1.864668 0.984585 0.108795 1.386239 0.942801 0.150487 1.312495 0.693148 -0.057522 1.440466 0.911264 0.464590 -0.106316 1.425558 0.757031 0.414982 -0.197207 1.393462 0.845365 0.655558 0.173740 1.724477 1.622714 1.133952 1.113326 0.491749 0.027662 -0.081584 1.624363 1.523158 1.483424 1.009127 1.065663 0.489911 0.865535 0.429699 0.506066 0.168610 0.091635 -0.004728 0.101995 0.057231 0.244394 0.215629 0.140294 0.025423 0.249165 0.312773 0.491767 0.509301 0.585407 1.082514 1.193775 1.427418 1.634094 0.038165 -0.066305 0.261200 0.531951 1.008338 1.495805 1.630762 0.003123 0.564786 1.124822 1.373512 0.020469 0.093862 0.692170)
+
+ ;; 109+1
+ 10.387950 #(0.000000 0.515686 1.264891 -0.055069 0.324088 1.179085 1.335788 0.136489 0.919154 1.188155 -0.141610 0.717958 1.358218 0.093185 0.896015 1.671807 0.471790 1.141052 0.051579 0.537490 1.459698 0.584651 1.830808 0.363032 1.369938 0.000274 0.907004 -0.093829 1.224177 0.475784 1.246547 0.352307 1.450525 0.675832 0.013928 1.051336 -0.056690 0.739815 -0.043085 0.988473 0.181872 -0.198536 1.207807 0.272700 1.535978 1.102951 0.131450 1.223792 0.690160 0.142129 1.227746 0.844209 0.420668 0.245746 1.521870 1.240517 0.759658 -0.189023 1.110249 0.975685 0.561038 0.208456 1.726728 1.762213 1.410558 1.390253 0.568141 0.009314 -0.066588 1.510186 1.490948 1.223995 0.684559 1.083791 0.423654 1.233083 0.433267 0.557294 -0.196449 -0.046355 -0.048752 0.047230 -0.047134 0.493004 0.400752 0.312416 0.075458 0.155296 0.421062 0.311827 0.162606 0.700352 0.907002 1.326783 1.485723 -0.152238 -0.031436 -0.145811 0.279371 0.397448 1.049233 1.455768 1.607980 0.104646 0.721954 1.211206 1.533891 0.073983 0.190426 0.414118)
+ 10.384532 #(0.000000 0.497058 1.308854 -0.040087 0.317842 1.212991 1.348869 0.169218 0.937322 1.141868 -0.161541 0.702285 1.374915 0.105577 0.895118 1.715852 0.486357 1.126045 0.027516 0.506764 1.422714 0.578087 1.785847 0.360577 1.340809 0.040639 0.924986 -0.064845 1.218475 0.441481 1.282493 0.367747 1.417112 0.662713 0.020057 1.075916 -0.019298 0.721943 -0.067674 0.989188 0.221610 -0.166666 1.205634 0.245282 1.512389 1.116780 0.133433 1.209361 0.683941 0.136270 1.207963 0.840404 0.407464 0.237523 1.553628 1.290834 0.738111 -0.201487 1.118700 0.992136 0.530099 0.232821 1.709001 1.753916 1.400184 1.373110 0.591245 -0.001719 -0.097997 1.485341 1.510549 1.267389 0.699366 1.037211 0.446472 1.249648 0.436481 0.541104 -0.183563 -0.029851 -0.044651 0.058473 -0.046411 0.519596 0.324425 0.295881 0.020130 0.121258 0.421385 0.343422 0.175010 0.744278 0.928241 1.278265 1.460120 -0.158640 -0.046458 -0.164552 0.259068 0.355794 1.089478 1.431301 1.606926 0.103582 0.653958 1.133151 1.513113 0.087404 0.126034 0.426687)
)
;;; 111 all -------------------------------------------------------------------------------- ; 10.5357
@@ -2282,7 +2370,7 @@
-;;; ---------------------------------------- prime-numbered harmonics (and 1st) ----------------------------------------
+;;; ---------------------------------------- prime-numbered harmonics (and first) ----------------------------------------
(define primoid-min-peak-phases (vector
@@ -4299,23 +4387,23 @@
(loc 0.0))
(do ((x 0.0 (+ x incr)))
((> x (* 2 pi)) (list mx loc))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 2)))
- ((= k len))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))
- (if (> (abs val) mx)
- (begin
- (set! mx (abs val))
- (set! loc x)))))))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 2)))
+ ((= k len)
+ (when (> (abs val) mx)
+ (set! mx (abs val))
+ (set! loc x)))
+ (set! val (+ val (sin (+ (* j x) (* pi (phs k))))))))))
+
(define (tstoddderiv x phs)
- (let ((sum 0.0)
- (len (length phs)))
- (do ((i 0 (+ i 1))
- (j 1 (+ j 2)))
- ((= i len) sum)
- (set! sum (+ sum (* j (cos (+ (* j x) (* pi (phs i))))))))))
+ (do ((sum 0.0)
+ (len (length phs))
+ (i 0 (+ i 1))
+ (j 1 (+ j 2)))
+ ((= i len) sum)
+ (set! sum (+ sum (* j (cos (+ (* j x) (* pi (phs i)))))))))
(define* (tstall phs phs1)
@@ -4326,15 +4414,14 @@
(loc 0.0))
(do ((x 0.0 (+ x incr)))
((> x (* 2 pi)) (list mx loc))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 1)))
- ((= k len))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))
- (if (> (abs val) mx)
- (begin
- (set! mx (abs val))
- (set! loc x)))))))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 1)))
+ ((= k len)
+ (when (> (abs val) mx)
+ (set! mx (abs val))
+ (set! loc x)))
+ (set! val (+ val (sin (+ (* j x) (* pi (phs k))))))))))
(define (tstallf mult phs)
(let ((len (length phs))
@@ -4343,17 +4430,16 @@
(loc 0.0))
(do ((x 0.0 (+ x incr)))
((> x (* 2 pi)) (list mx loc))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 1)))
- ((= k len))
- (if (= k (- len 1))
- (set! val (+ val (* mult (sin (+ (* j x) (* pi (phs k)))))))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k))))))))
- (if (> (abs val) mx)
- (begin
- (set! mx (abs val))
- (set! loc x)))))))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 1)))
+ ((= k len)
+ (when (> (abs val) mx)
+ (set! mx (abs val))
+ (set! loc x)))
+ (set! val (+ val (if (= k (- len 1))
+ (* mult (sin (+ (* j x) (* pi (phs k)))))
+ (sin (+ (* j x) (* pi (phs k)))))))))))
(define (tsteven phs)
(let ((len (length phs))
@@ -4362,14 +4448,13 @@
(loc 0.0))
(do ((x 0.0 (+ x incr)))
((> x (* 2 pi)) (list mx loc))
- (let ((val 0.0))
- (do ((k 0 (+ k 1)))
- ((= k len))
- (set! val (+ val (sin (+ (* (max (* 2 k) 1) x) (* pi (phs k)))))))
- (if (> (abs val) mx)
- (begin
- (set! mx (abs val))
- (set! loc x)))))))
+ (do ((val 0.0)
+ (k 0 (+ k 1)))
+ ((= k len)
+ (when (> (abs val) mx)
+ (set! mx (abs val))
+ (set! loc x)))
+ (set! val (+ val (sin (+ (* (max (* 2 k) 1) x) (* pi (phs k))))))))))
(define (tstprime phs)
(let ((len (length phs))
@@ -4388,101 +4473,93 @@
(set! loc x)))))))
(define (tstallderiv x phs)
- (let ((sum 0.0)
- (len (length phs)))
- (do ((i 0 (+ i 1))
- (j 1 (+ j 1)))
- ((= i len) sum)
- (set! sum (+ sum (* j (cos (+ (* j x) (* pi (phs i))))))))))
+ (do ((sum 0.0)
+ (len (length phs))
+ (i 0 (+ i 1))
+ (j 1 (+ j 1)))
+ ((= i len) sum)
+ (set! sum (+ sum (* j (cos (+ (* j x) (* pi (phs i)))))))))
(define (get-best choice n)
-
- (define (vector-find-if func vect)
+ (let ((func (lambda (val)
+ (and val
+ (vector? val)
+ (= (val 0) n)
+ (let ((a-val (val 1))
+ (a-len (length val))
+ (a-data (val 2)))
+ (do ((k 3 (+ 1 k)))
+ ((= k a-len))
+ (if (and (number? (val k))
+ (< (val k) a-val))
+ (begin
+ (set! a-val (val k))
+ (set! a-data (val (+ k 1))))))
+ (list a-val a-data)))))
+ (vect (case choice
+ ((:all) noid-min-peak-phases)
+ ((:odd) nodd-min-peak-phases)
+ ((:even) neven-min-peak-phases)
+ (else primoid-min-peak-phases))))
(let ((len (length vect))
(result #f))
(do ((i 0 (+ i 1)))
- ((or (= i len)
- result)
- result)
- (set! result (func (vect i))))))
-
- (vector-find-if (lambda (val)
- (and val
- (vector? val)
- (= (val 0) n)
- (let ((a-val (val 1))
- (a-len (length val))
- (a-data (val 2)))
- (do ((k 3 (+ 1 k)))
- ((= k a-len))
- (if (and (number? (val k))
- (< (val k) a-val))
- (begin
- (set! a-val (val k))
- (set! a-data (val (+ k 1))))))
- (list a-val a-data))))
- (if (eq? choice :all)
- noid-min-peak-phases
- (if (eq? choice :odd)
- nodd-min-peak-phases
- (if (eq? choice :even)
- neven-min-peak-phases
- primoid-min-peak-phases)))))
+ ((or (= i len) result) result)
+ (set! result (func (vect i)))))))
+
(define (showall len)
(let* ((phs-data (get-best :all len))
(phs (cadr phs-data))
(mx (car phs-data))
- (v (make-float-vector (ceiling (+ (* 2 pi 1000) 2))))
- (incr 0.001))
- (do ((x 0.0 (+ x incr))
+ (v (make-float-vector (ceiling (+ (* pi 2000) 2)))))
+ (do ((incr 0.001)
+ (x 0.0 (+ x incr))
(i 0 (+ i 1)))
((> x (* 2 pi)))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 1)))
- ((= k len))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))
- (set! (v i) val)))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 1)))
+ ((= k len)
+ (set! (v i) val))
+ (set! val (+ val (sin (+ (* j x) (* pi (phs k))))))))
(new-sound)
(float-vector->channel v)
(set! (y-bounds) (list (- mx) mx))))
(define (showphases mx phs)
- (let ((v (make-float-vector (ceiling (+ (* 2 pi 1000) 2))))
- (incr 0.001)
- (len (length phs)))
- (do ((x 0.0 (+ x incr))
- (i 0 (+ i 1)))
- ((> x (* 2 pi)))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 1)))
- ((= k len))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))
- (set! (v i) val)))
- (new-sound)
- (float-vector->channel v)
- (set! (y-bounds) (list (- mx) mx))))
-
-
+ (do ((v (make-float-vector (ceiling (+ (* pi 2000) 2))))
+ (incr 0.001)
+ (len (length phs))
+ (x 0.0 (+ x incr))
+ (i 0 (+ i 1)))
+ ((> x (* 2 pi))
+ (new-sound)
+ (float-vector->channel v)
+ (set! (y-bounds) (list (- mx) mx)))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 1)))
+ ((= k len)
+ (set! (v i) val))
+ (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))))
(define (showodd len)
(let* ((phs-data (get-best :odd len))
(phs (cadr phs-data))
(mx (car phs-data))
- (v (make-float-vector (ceiling (+ (* 2 pi 1000) 2))))
- (incr 0.001))
- (do ((x 0.0 (+ x incr))
+ (v (make-float-vector (ceiling (+ (* pi 2000) 2)))))
+ (do ((incr 0.001)
+ (x 0.0 (+ x incr))
(i 0 (+ i 1)))
((> x (* 2 pi)))
- (let ((val 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 2)))
- ((= k len))
- (set! val (+ val (sin (+ (* j x) (* pi (phs k)))))))
- (set! (v i) val)))
+ (do ((val 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 2)))
+ ((= k len)
+ (set! (v i) val))
+ (set! val (+ val (sin (+ (* j x) (* pi (phs k))))))))
(new-sound)
(float-vector->channel v)
(set! (y-bounds) (list (- mx) mx))))
@@ -4498,8 +4575,7 @@
(if (< (data i) -1)
(set! (data i) (+ (data i) 2.0)))))
(new-sound)
- (float-vector->channel data)
- ))
+ (float-vector->channel data)))
(define (differ snd)
(let ((x 0.0))
@@ -4528,7 +4604,7 @@
(set! (temp-phases i) (modulo (+ (temp-phases i) 1.0) 2.0)))
(let ((val (car (tstall temp-phases))))
(if (> (abs (- val peak-amp)) .001)
- (format #t ";~A -> ~A?~%" peak-amp val))
+ (format () ";~A -> ~A?~%" peak-amp val))
(set! results (cons (list val temp-phases) results)))
;; get case symmetric around 0
@@ -4538,7 +4614,7 @@
(set! (temp-phases i) (modulo (- 2.0 (temp-phases i)) 2.0)))
(let ((val (car (tstall temp-phases))))
(if (> (abs (- val peak-amp)) .001)
- (format #t ";~A -> ~A?~%" peak-amp val))
+ (format () ";~A -> ~A?~%" peak-amp val))
(set! results (cons (list val temp-phases) results)))
;; flip evens on the previous case
@@ -4548,7 +4624,7 @@
(set! (temp-phases i) (modulo (+ (temp-phases i) 1.0) 2.0)))
(let ((val (car (tstall temp-phases))))
(if (> (abs (- val peak-amp)) .001)
- (format #t ";~A -> ~A?~%" peak-amp val))
+ (format () ";~A -> ~A?~%" peak-amp val))
(set! results (cons (list val temp-phases) results)))
; (format #f "~{~{~,8F ~A~%~}~}" (reverse results))
@@ -4593,11 +4669,11 @@
(let ((new-peak (car new-peak-info)))
(if (> (abs (- new-peak old-peak)) .001)
(format *stderr* "oops: ~D: ~A ~A~%" i old-peak new-peak))
- (format p "(vector ~D ~,6F (fv " i new-peak)
- (do ((k 1 (+ k 1)))
- ((= k i))
- (format p "~,6F " (phases (- k 1))))
- (format p "~,6F))~% ;; loc: ~F~%~%" (phases (- i 1)) (/ (cadr new-peak-info) pi))))))))
+ (format p "(vector ~D ~,6F (fv " i new-peak))
+ (do ((k 1 (+ k 1)))
+ ((= k i))
+ (format p "~,6F " (phases (- k 1))))
+ (format p "~,6F))~% ;; loc: ~F~%~%" (phases (- i 1)) (/ (cadr new-peak-info) pi)))))))
(define (canonicalize)
;; this is slow because we call tstall on each one
@@ -4623,12 +4699,12 @@
(if (or (> (abs (- (caar other-mins) (car data))) .001)
(> (abs (- (caadr other-mins) (car data))) .001)
(> (abs (- (caaddr other-mins) (car data))) .001))
- (format #t "trouble in ~D: ~A ~A~%" i data other-mins))
+ (format () "trouble in ~D: ~A ~A~%" i data other-mins))
(let ((phases (sort! (list pk1 pk2 pk3 pk4)
(lambda (a b)
(< (a 1) (b 1))))))
- (format #t "~,8F~% ~A~% ~A~% ~A~% ~A~%"
+ (format () "~,8F~% ~A~% ~A~% ~A~% ~A~%"
(data 0)
(phases 0)
(phases 1)
@@ -4708,26 +4784,34 @@
;; 1 Sep 4152.306
;; 1 Oct 4152.200
;; 1 Nov 4152.089
-
-; all 0.4860 (20) to 0.4987 (106), dist: 0.0000, 13.5427
+;; 1 Dec 4151.958
+;; (16)
+;; 1 Jan 4151.620
+;; 1 Feb 4151.208
+;; 1 Mar 4151.007
+;; 1 Apr 4150.840
+;; 1 May 4150.665
+
+; all 0.4860 (20) to 0.4986 (125), dist: 0.0000, 14.9637
; odd 0.4820 (11) to 0.5000 (112), dist: 0.0000, 8.5572
; even 0.5085 (115) to 0.5242 (22), dist: 57.6719, 0.0000
-; prime 0.5445 (24) to 0.5540 (67), dist: 232.5954, 0.0000
+; prime 0.5444 (24) to 0.5540 (67), dist: 232.5920, 0.0000
;(test-all-phases #f) in test-phases.scm
#|
+<1> (load "test-phases.scm")
+test-all-phases
<2> (test-all-phases #f)
-;all peaks... Mon 26-Oct-2015 13:11
+;all peaks... Fri 29-Apr-2016 04:21
(0.001495737399423547 101)
-;odd peaks... Mon 26-Oct-2015 13:17
+;odd peaks... Fri 29-Apr-2016 04:29
(0.001687315629258279 125)
-;even peaks... Mon 26-Oct-2015 13:21
+;even peaks... Fri 29-Apr-2016 04:33
(0.001467169674692848 4)
-;prime peaks... Mon 26-Oct-2015 13:25
+;prime peaks... Fri 29-Apr-2016 04:37
(0.001975582609148319 2048)
-;all done! Mon 26-Oct-2015 13:30
-";all done! Mon 26-Oct-2015 13:30
+;all done! Fri 29-Apr-2016 04:43
|#
;;; gad161: clean-up-evens
diff --git a/piano.scm b/piano.scm
index 5091c67..edd599e 100644
--- a/piano.scm
+++ b/piano.scm
@@ -11,7 +11,6 @@
(define number-of-stiffness-allpasses 8)
(define longitudinal-mode-cutoff-keynum 29)
(define longitudinal-mode-stiffness-coefficient -.5)
-(define golden-mean .618)
(define loop-gain-env-t60 .05)
(define loop-gain-default .9999)
(define nstrings 3)
@@ -133,53 +132,50 @@
(list (make-one-zero a0 a1)
(make-one-pole 1.0 b1)))
- (define (apPhase a1 wT)
- (atan (* (- (* a1 a1) 1.0)
- (sin wT))
- (+ (* 2.0 a1)
- (* (+ (* a1 a1) 1.0)
- (cos wT)))))
-
- (define (opozPhase b0 b1 a1 wT)
- (let ((s (sin wT))
- (c (cos wT)))
- (atan (- (* a1 s (+ b0 (* b1 c)))
- (* b1 s (+ 1 (* a1 c))))
- (+ (* (+ b0 (* b1 c))
- (+ 1 (* a1 c)))
- (* b1 s a1 s)))))
-
(define (signum n)
;; in CL this returns 1.0 if n is float
(if (positive? n) 1
(if (zero? n) 0
-1)))
- (define (get-allpass-coef samp-frac wT)
- (let ((ta (tan (- (* samp-frac wT))))
- (c (cos wT))
- (s (sin wT)))
- (/ (+ (- ta)
- (* (signum ta)
- (sqrt (* (+ 1 (* ta ta))
- (* s s))))) ; is this correct? it's in the original
- (- (* c ta) s))))
-
- (define (apfloor len wT)
- (let* ((len-int (floor len))
- (len-frac (- len len-int)))
- (if (< len-frac golden-mean)
- (begin
- (set! len-int (- len-int 1))
- (set! len-frac (+ len-frac 1.0))))
- (if (and (< len-frac golden-mean)
- (> len-int 0))
- (begin
- (set! len-int (- len-int 1))
- (set! len-frac (+ len-frac 1.0))))
- (list len-int (get-allpass-coef len-frac wT))))
+ (define apfloor
+ (let ((golden-mean .618))
+ (define (get-allpass-coef samp-frac wT)
+ (let ((ta (tan (- (* samp-frac wT))))
+ (c (cos wT))
+ (s (sin wT)))
+ (/ (- (* (signum ta)
+ (sqrt (* (+ 1 (* ta ta)) s s))) ta) ; is the (* s s) correct? it's in the original
+ (- (* c ta) s))))
+ (lambda (len wT)
+ (let* ((len-int (floor len))
+ (len-frac (- len len-int)))
+ (if (< len-frac golden-mean)
+ (begin
+ (set! len-int (- len-int 1))
+ (set! len-frac (+ len-frac 1.0))))
+ (if (and (< len-frac golden-mean)
+ (> len-int 0))
+ (begin
+ (set! len-int (- len-int 1))
+ (set! len-frac (+ len-frac 1.0))))
+ (list len-int (get-allpass-coef len-frac wT))))))
(define (tune-piano frequency stiffnessCoefficient numAllpasses b0 b1 a1)
+ (define (apPhase a1 wT)
+ (atan (* (- (* a1 a1) 1.0)
+ (sin wT))
+ (+ (* 2.0 a1)
+ (* (+ (* a1 a1) 1.0)
+ (cos wT)))))
+ (define (opozPhase b0 b1 a1 wT)
+ (let ((s (sin wT))
+ (c (cos wT)))
+ (atan (- (* a1 s (+ b0 (* b1 c)))
+ (* b1 s (+ 1 (* a1 c))))
+ (+ (* (+ b0 (* b1 c))
+ (+ 1 (* a1 c)))
+ (* b1 s a1 s)))))
(let* ((wT (/ (* frequency two-pi) *clm-srate*))
(len (/ (+ two-pi
(* numAllpasses
@@ -267,18 +263,14 @@
(- stiffnessFactor 1)))
(* stiffnessCoefficient stiffnessFactor))))
- (let ((ctemp (+ 1 (- b) g (- (* a g))
- (* nstrings (+ 1 (- b) (- g) (* a g)))))
+ (let ((ctemp (- (+ 1 g (* nstrings (- (+ 1 (* a g)) b g))) b (* a g)))
(stiffnessCoefficientL (if (<= keyNum longitudinal-mode-cutoff-keynum)
longitudinal-mode-stiffness-coefficient
stiffnessCoefficient)))
- (let ((cfb0 (/ (* 2 (+ -1 b g (- (* a g)))) ctemp))
- (cfb1 (/ (* 2 (+ a (- (* a b)) (- (* b g)) (* a b g))) ctemp))
- (cfa1 (/ (+ (- a) (* a b) (- (* b g)) (* a b g)
- (* nstrings (+ (- a) (* a b) (* b g) (- (* a b g)))))
- ctemp))
-
+ (let ((cfb0 (/ (* 2 (- (+ -1 b g) (* a g))) ctemp))
+ (cfb1 (/ (* 2 (- (+ a (* a b g)) (* a b) (* b g))) ctemp))
+ (cfa1 (/ (- (+ (* a b) (* a b g) (* nstrings (- (* b (+ a g)) a (* a b g)))) a (* b g)) ctemp))
(agraffe-delay1 (make-delay dlen1))
(agraffe-tuning-ap1 (make-one-pole-all-pass 1 apcoef1)))
@@ -287,7 +279,7 @@
(vals1 (tune-piano freq1 stiffnessCoefficientL number-of-stiffness-allpasses cfb0 cfb1 cfa1))
(vals2 (tune-piano freq2 stiffnessCoefficient number-of-stiffness-allpasses cfb0 cfb1 cfa1))
(vals3 (tune-piano freq3 stiffnessCoefficient number-of-stiffness-allpasses cfb0 cfb1 cfa1)))
-
+
(let ((delayLength1 (car vals1))
(tuningCoefficient1 (cadr vals1))
@@ -295,128 +287,131 @@
(tuningCoefficient2 (cadr vals2))
(delayLength3 (car vals3))
- (tuningCoefficient3 (cadr vals3)))
-
- (let ((dryTap0 (car dryTap-one-pole-one-zero-pair))
- (dryTap1 (cadr dryTap-one-pole-one-zero-pair))
-
- (wetTap0 (car wetTap-one-pole-one-zero-pair))
- (wetTap1 (cadr wetTap-one-pole-one-zero-pair))
-
- (op1 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
- (op2 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
- (op3 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
- (op4 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
-
- (cou0 (car couplingFilter-pair))
- (cou1 (cadr couplingFilter-pair))
-
- (string1-delay (make-delay (- delayLength1 1)))
- (string1-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient1))
- (string1-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficientL))
-
- (string2-delay (make-delay (- delayLength2 1)))
- (string2-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient2))
- (string2-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficient))
-
- (string3-delay (make-delay (- delayLength3 1)))
- (string3-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient3))
- (string3-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficient))
-
- ;;initialize loop-gain envelope
- (loop-gain loop-gain-default)
- (loop-gain-ry (* releaseLoopGain (In-t60 loop-gain-env-t60)))
- (loop-gain-rx (- 1.0 (In-t60 loop-gain-env-t60)))
-
- (dry-coef (* 1.0 DryTapFiltCoefCurrent))
- (dry-coef-ry (* DryTapFiltCoefTarget (In-t60 DryTapFiltCoeft60)))
- (dry-coef-rx (- 1.0 (In-t60 DryTapFiltCoeft60)))
-
- (wet-coef 0.0)
- (wet-coef-ry (* -0.5 (In-t60 pedalEnvelopet60)))
- (wet-coef-rx (- 1.0 (In-t60 pedalEnvelopet60)))
-
- (dryTap 0.0)
- (dryTap-x 1.0)
- (dryTap-rx (- 1.0 (In-t60 DryTapAmpt60)))
-
- (openStrings 0.0)
- (wetTap-x (* sustainPedalLevel pedalPresenceFactor (if pedal-down 1.0 DryPedalResonanceFactor)))
- (wetTap-rx (- 1.0 (In-t60 pedalEnvelopet60)))
-
- (combedExcitationSignal 0.0)
- (adelOut 0.0)
- (adelIn 0.0)
- (totalTap 0.0)
- (string1-junction-input 0.0)
- (string2-junction-input 0.0)
- (string3-junction-input 0.0)
- (couplingFilter-input 0.0)
- (couplingFilter-output 0.0)
- (temp1 0.0)
- ;; (pn-gen 16383)
- (pnoise (int-vector 16383))
- (interp 0.0)
- )
-
- (define (piano-loop beg end)
- (do ((i beg (+ i 1)))
- ((= i end))
-
- (set! loop-gain (+ (* interp (+ loop-gain-ry (* loop-gain-rx loop-gain)))
- (* (- 1.0 interp) loop-gain-default)))
-
- (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp))))
- (set! dry-coef (+ dry-coef-ry (* dry-coef-rx dry-coef)))
- (set! dryTap-one-pole-swept (- (* (+ 1.0 dry-coef) temp1) (* dry-coef dryTap-one-pole-swept)))
- (set! dryTap-x (* dryTap-x dryTap-rx))
- (set! dryTap (* dryTap-x dryTap-one-pole-swept))
-
- (set! temp1 (one-zero wetTap0 (one-pole wetTap1 (piano-noise pnoise amp))))
- (set! wet-coef (+ wet-coef-ry (* wet-coef-rx wet-coef)))
- (set! wetTap-one-pole-swept (- (* (+ 1.0 wet-coef) temp1) (* wet-coef wetTap-one-pole-swept)))
- (set! wetTap-x (* wetTap-x wetTap-rx))
- (set! openStrings (* wetTap-x wetTap-one-pole-swept))
-
- (set! totalTap (+ dryTap openStrings))
-
- (set! adelIn (one-pole op1 (one-pole op2 (one-pole op3 (one-pole op4 totalTap)))))
- (set! combedExcitationSignal (* hammerGain (+ adelOut (* adelIn StrikePositionInvFac))))
- (set! adelOut (one-pole-all-pass agraffe-tuning-ap1 (delay agraffe-delay1 adelIn)))
-
- (set! string1-junction-input
- (+ (* unaCordaGain combedExcitationSignal)
- (* loop-gain
- (delay string1-delay
- (one-pole-all-pass string1-tuning-ap
- (one-pole-all-pass string1-stiffness-ap
- (+ string1-junction-input couplingFilter-output)))))))
- (set! string2-junction-input
- (+ combedExcitationSignal
- (* loop-gain
- (delay string2-delay
- (one-pole-all-pass string2-tuning-ap
- (one-pole-all-pass string2-stiffness-ap
- (+ string2-junction-input couplingFilter-output)))))))
- (set! string3-junction-input
- (+ combedExcitationSignal
- (* loop-gain
- (delay string3-delay
- (one-pole-all-pass string3-tuning-ap
- (one-pole-all-pass string3-stiffness-ap
- (+ string3-junction-input couplingFilter-output)))))))
-
- (set! couplingFilter-input (+ string1-junction-input string2-junction-input string3-junction-input))
- (set! couplingFilter-output (one-zero cou0 (one-pole cou1 couplingFilter-input)))
-
- (outa i couplingFilter-input)))
-
- (piano-loop beg release-time)
- (set! dryTap-rx (- 1.0 sb-cutoff-rate))
- (set! wetTap-rx dryTap-rx)
- (set! interp 1.0)
- (piano-loop release-time end)
- ))))))))))
+ (tuningCoefficient3 (cadr vals3))
+
+ (interp 0.0)
+ (dryTap-rx 0.0)
+ (wetTap-rx 0.0))
+
+ (define piano-loop
+ (let ((dryTap0 (car dryTap-one-pole-one-zero-pair))
+ (dryTap1 (cadr dryTap-one-pole-one-zero-pair))
+
+ (wetTap0 (car wetTap-one-pole-one-zero-pair))
+ (wetTap1 (cadr wetTap-one-pole-one-zero-pair))
+
+ (op1 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
+ (op2 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
+ (op3 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
+ (op4 (make-one-pole (- 1.0 hammerPole) (- hammerPole)))
+
+ (cou0 (car couplingFilter-pair))
+ (cou1 (cadr couplingFilter-pair))
+
+ (string1-delay (make-delay (- delayLength1 1)))
+ (string1-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient1))
+ (string1-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficientL))
+
+ (string2-delay (make-delay (- delayLength2 1)))
+ (string2-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient2))
+ (string2-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficient))
+
+ (string3-delay (make-delay (- delayLength3 1)))
+ (string3-tuning-ap (make-one-pole-all-pass 1 tuningCoefficient3))
+ (string3-stiffness-ap (make-one-pole-all-pass 8 stiffnessCoefficient))
+
+ ;;initialize loop-gain envelope
+ (loop-gain loop-gain-default)
+ (loop-gain-ry (* releaseLoopGain (In-t60 loop-gain-env-t60)))
+ (loop-gain-rx (- 1.0 (In-t60 loop-gain-env-t60)))
+
+ (dry-coef (* 1.0 DryTapFiltCoefCurrent))
+ (dry-coef-ry (* DryTapFiltCoefTarget (In-t60 DryTapFiltCoeft60)))
+ (dry-coef-rx (- 1.0 (In-t60 DryTapFiltCoeft60)))
+
+ (wet-coef 0.0)
+ (wet-coef-ry (* -0.5 (In-t60 pedalEnvelopet60)))
+ (wet-coef-rx (- 1.0 (In-t60 pedalEnvelopet60)))
+
+ (dryTap 0.0)
+ (dryTap-x 1.0)
+
+ (openStrings 0.0)
+ (wetTap-x (* sustainPedalLevel pedalPresenceFactor (if pedal-down 1.0 DryPedalResonanceFactor)))
+
+ (combedExcitationSignal 0.0)
+ (adelOut 0.0)
+ (adelIn 0.0)
+ (totalTap 0.0)
+ (string1-junction-input 0.0)
+ (string2-junction-input 0.0)
+ (string3-junction-input 0.0)
+ (couplingFilter-input 0.0)
+ (couplingFilter-output 0.0)
+ (temp1 0.0)
+ ;; (pn-gen 16383)
+ (pnoise (int-vector 16383)))
+
+ (lambda (beg end)
+ (do ((i beg (+ i 1)))
+ ((= i end))
+
+ (set! loop-gain (+ (* interp (+ loop-gain-ry (* loop-gain-rx loop-gain)))
+ (* (- 1.0 interp) loop-gain-default)))
+
+ (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp))))
+ (set! dry-coef (+ dry-coef-ry (* dry-coef-rx dry-coef)))
+ (set! dryTap-one-pole-swept (- (* (+ 1.0 dry-coef) temp1) (* dry-coef dryTap-one-pole-swept)))
+ (set! dryTap-x (* dryTap-x dryTap-rx))
+ (set! dryTap (* dryTap-x dryTap-one-pole-swept))
+
+ (set! temp1 (one-zero wetTap0 (one-pole wetTap1 (piano-noise pnoise amp))))
+ (set! wet-coef (+ wet-coef-ry (* wet-coef-rx wet-coef)))
+ (set! wetTap-one-pole-swept (- (* (+ 1.0 wet-coef) temp1) (* wet-coef wetTap-one-pole-swept)))
+ (set! wetTap-x (* wetTap-x wetTap-rx))
+ (set! openStrings (* wetTap-x wetTap-one-pole-swept))
+
+ (set! totalTap (+ dryTap openStrings))
+
+ (set! adelIn (one-pole op1 (one-pole op2 (one-pole op3 (one-pole op4 totalTap)))))
+ (set! combedExcitationSignal (* hammerGain (+ adelOut (* adelIn StrikePositionInvFac))))
+ (set! adelOut (one-pole-all-pass agraffe-tuning-ap1 (delay agraffe-delay1 adelIn)))
+
+ (set! string1-junction-input
+ (+ (* unaCordaGain combedExcitationSignal)
+ (* loop-gain
+ (delay string1-delay
+ (one-pole-all-pass string1-tuning-ap
+ (one-pole-all-pass string1-stiffness-ap
+ (+ string1-junction-input couplingFilter-output)))))))
+ (set! string2-junction-input
+ (+ combedExcitationSignal
+ (* loop-gain
+ (delay string2-delay
+ (one-pole-all-pass string2-tuning-ap
+ (one-pole-all-pass string2-stiffness-ap
+ (+ string2-junction-input couplingFilter-output)))))))
+ (set! string3-junction-input
+ (+ combedExcitationSignal
+ (* loop-gain
+ (delay string3-delay
+ (one-pole-all-pass string3-tuning-ap
+ (one-pole-all-pass string3-stiffness-ap
+ (+ string3-junction-input couplingFilter-output)))))))
+
+ (set! couplingFilter-input (+ string1-junction-input string2-junction-input string3-junction-input))
+ (set! couplingFilter-output (one-zero cou0 (one-pole cou1 couplingFilter-input)))
+
+ (outa i couplingFilter-input)))))
+
+ (set! dryTap-rx (- 1.0 (In-t60 DryTapAmpt60)))
+ (set! wetTap-rx (- 1.0 (In-t60 pedalEnvelopet60)))
+
+ (piano-loop beg release-time)
+ (set! dryTap-rx (- 1.0 sb-cutoff-rate))
+ (set! wetTap-rx dryTap-rx)
+ (set! interp 1.0)
+ (piano-loop release-time end))))))))))
#|
(with-sound ()
diff --git a/play.scm b/play.scm
index 20e0148..129fa4c 100644
--- a/play.scm
+++ b/play.scm
@@ -71,14 +71,15 @@
(define play-often
(let ((documentation "(play-often n) plays the selected sound 'n' times (interruptible via C-g)"))
(lambda (n)
- (let ((plays (- n 1)))
- (define (play-once reason)
- (if (and (> plays 0)
- (= reason 0))
- (begin
- (set! plays (- plays 1))
- (play (selected-sound) :start 0 :stop play-once))))
- (play (selected-sound) :start 0 :stop play-once)))))
+ (define play-once
+ (let ((plays (- n 1)))
+ (lambda (reason)
+ (if (and (> plays 0)
+ (= reason 0))
+ (begin
+ (set! plays (- plays 1))
+ (play (selected-sound) :start 0 :stop play-once))))))
+ (play (selected-sound) :start 0 :stop play-once))))
;;(bind-key #\p 0 (lambda (n) "play often" (play-often (max 1 n))))
diff --git a/poly.scm b/poly.scm
index 7bffd98..72d31f6 100644
--- a/poly.scm
+++ b/poly.scm
@@ -39,11 +39,11 @@
(define poly-as-vector-eval
(let ((documentation "(poly-as-vector-eval v x) treats 'v' as a vector of polynomial coefficients, returning the value of the polynomial at x"))
(lambda (v x)
- (let ((top (- (length v) 1)))
- (let ((sum (v top)))
- (do ((i (- top 1) (- i 1)))
- ((< i 0) sum)
- (set! sum (+ (* sum x) (v i)))))))))
+ (let* ((top (- (length v) 1))
+ (sum (v top)))
+ (do ((i (- top 1) (- i 1)))
+ ((< i 0) sum)
+ (set! sum (+ (* sum x) (v i))))))))
(define poly-as-vector-reduce
@@ -56,11 +56,7 @@
(+ i 1)))))
(if (= new-len (length p1))
p1
- (let ((np (make-vector new-len)))
- (do ((i 0 (+ i 1)))
- ((= i new-len))
- (set! (np i) (p1 i)))
- np))))))
+ (copy p1 (make-vector new-len)))))))
(define poly-reduce
(let ((documentation "(poly-reduce p1) removes trailing (high-degree) zeros from the float-vector p1"))
@@ -105,8 +101,10 @@
(define poly-as-vector*
(let ((documentation "(poly-as-vector* p1 p2) multiplies (as polynomials) the vectors p1 and p2"))
(lambda (p1 p2)
- (if (vector? p1)
- (if (vector? p2)
+ (if (not (vector? p1))
+ (vector-scale! (copy p2) p1)
+ (if (not (vector? p2))
+ (vector-scale! (copy p1) p2)
(let* ((p1len (length p1))
(p2len (length p2))
(len (+ p1len p2len))
@@ -116,9 +114,7 @@
(do ((j 0 (+ j 1)))
((= j p2len))
(set! (m (+ i j)) (+ (m (+ i j)) (* (p1 i) (p2 j))))))
- m)
- (vector-scale! (copy p1) p2))
- (vector-scale! (copy p2) p1)))))
+ m))))))
(define poly*
(let ((documentation "(poly* p1 p2) multiplies the polynomials (float-vectors or vectors) p1 and p2"))
@@ -138,8 +134,10 @@
(define poly-as-vector/
(let ((documentation "(poly-as-vector/ p1 p2) divides the polynomial p1 by p2 (both vectors)"))
(lambda (p1 p2)
- (if (vector? p1)
- (if (vector? p2)
+ (if (not (vector? p1))
+ (list (vector 0) p2)
+ (if (not (vector? p2))
+ (list (poly-as-vector* p1 (/ p2)) (vector 0))
;; Numerical Recipes poldiv
(let ((p1len (length p1))
(p2len (length p2)))
@@ -162,9 +160,7 @@
(do ((j nv (+ j 1)))
((> j n))
(set! (r j) 0))
- (list q r)))))
- (list (poly-as-vector* p1 (/ p2)) (vector 0)))
- (list (vector 0) p2)))))
+ (list q r))))))))))
(define poly/
(let ((documentation "(poly/ p1 p2) divides p1 by p2, both polynomials either float-vectors or vectors"))
@@ -226,31 +222,29 @@
(if (not (float-vector? mx))
(error 'wrong-type-arg "determinant argument should be a float-vector")
(let ((n (car (vector-dimensions mx))))
- (if (= n 1)
- (mx 0 0)
- (if (= n 2)
- (- (* (mx 0 0) (mx 1 1))
- (* (mx 0 1) (mx 1 0)))
- (if (= n 3)
- (- (+ (* (mx 0 0) (mx 1 1) (mx 2 2))
- (* (mx 0 1) (mx 1 2) (mx 2 0))
- (* (mx 0 2) (mx 1 0) (mx 2 1)))
- (+ (* (mx 0 0) (mx 1 2) (mx 2 1))
- (* (mx 0 1) (mx 1 0) (mx 2 2))
- (* (mx 0 2) (mx 1 1) (mx 2 0))))
- (let ((sum 0.0)
- (sign 1))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((mult (mx 0 i)))
- (if (not (= mult 0.0))
- (set! sum (+ sum (* sign mult (determinant (submatrix mx 0 i))))))
- (set! sign (- sign))))
- sum)))))))
+ (case n
+ ((1) (mx 0 0))
+ ((2) (- (* (mx 0 0) (mx 1 1)) (* (mx 0 1) (mx 1 0))))
+ ((3) (- (+ (* (mx 0 0) (mx 1 1) (mx 2 2))
+ (* (mx 0 1) (mx 1 2) (mx 2 0))
+ (* (mx 0 2) (mx 1 0) (mx 2 1)))
+ (* (mx 0 0) (mx 1 2) (mx 2 1))
+ (* (mx 0 1) (mx 1 0) (mx 2 2))
+ (* (mx 0 2) (mx 1 1) (mx 2 0))))
+ (else
+ (let ((sum 0.0)
+ (sign 1))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((mult (mx 0 i)))
+ (if (not (= mult 0.0))
+ (set! sum (+ sum (* sign mult (determinant (submatrix mx 0 i))))))
+ (set! sign (- sign))))
+ sum))))))
(define (poly-as-vector-resultant p1 p2)
- (if (or (not (vector? p1))
- (not (vector? p2)))
+ (if (not (and (vector? p1)
+ (vector? p2)))
(error 'wrong-type-arg "poly-as-vector-resultant arguments should be vectors")
(let* ((m (length p1))
(n (length p2))
@@ -359,8 +353,8 @@
(define (quadratic-roots a b c) ; ax^2 + bx + c
(let ((d (sqrt (- (* b b) (* 4 a c)))))
- (list (/ (+ (- b) d) (* 2 a))
- (/ (- (- b) d) (* 2 a)))))
+ (list (/ (- d b) (* 2 a))
+ (/ (- (+ d b)) (* 2 a)))))
(define (cubic-roots a b c d) ; ax^3 + bx^2 + cx + d
;; Abramowitz & Stegun 3.8.2
@@ -403,32 +397,30 @@
(a1 (/ d a))
(a2 (/ c a))
(a3 (/ b a))
- (yroot (poly-as-vector-roots (vector (+ (* 4 a2 a0) (- (* a1 a1)) (- (* a3 a3 a0)))
+ (yroot (poly-as-vector-roots (vector (- (* 4 a2 a0) (* a1 a1) (* a3 a3 a0))
(- (* a1 a3) (* 4 a0))
(- a2)
1.0))))
- (if (and yroot
- (pair? yroot)
- (= (length yroot) 4))
- (do ((i 0 (+ i 1)))
- ((= i 3))
- (let* ((y1 (yroot i))
- (R (sqrt (+ (* 0.25 a3 a3) (- a2) y1)))
- (D (if (= R 0)
- (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (* 2 (sqrt (- (* y1 y1) (* 4 a0))))))
- (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (- (* R R))
- (/ (* 0.25 (+ (* 4 a3 a2) (* -8 a1) (- (* a3 a3 a3)))) R)))))
- (E (if (= R 0)
- (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (* -2 (sqrt (- (* y1 y1) (* 4 a0))))))
- (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (- (* R R))
- (/ (* -0.25 (+ (* 4 a3 a2) (* -8 a1) (- (* a3 a3 a3)))) R)))))
- (z1 (+ (* -0.25 a3) (* 0.5 R) (* 0.5 D)))
- (z2 (+ (* -0.25 a3) (* 0.5 R) (* -0.5 D)))
- (z3 (+ (* -0.25 a3) (* -0.5 R) (* 0.5 E)))
- (z4 (+ (* -0.25 a3) (* -0.5 R) (* -0.5 E))))
-
- (if (< (magnitude (poly-as-vector-eval (vector e d c b a) z1)) poly-roots-epsilon)
- (return (list z1 z2 z3 z4))))))
+ (when (and yroot
+ (pair? yroot)
+ (= (length yroot) 4))
+ (do ((i 0 (+ i 1)))
+ ((= i 3))
+ (let* ((y1 (yroot i))
+ (R (sqrt (- (+ (* 0.25 a3 a3) y1) a2)))
+ (D (if (= R 0)
+ (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (* 2 (sqrt (- (* y1 y1) (* 4 a0))))))
+ (sqrt (- (+ (* 0.75 a3 a3) (* -2 a2) (/ (* 0.25 (- (+ (* 4 a3 a2) (* -8 a1)) (* a3 a3 a3))) R)) (* R R)))))
+ (E (if (= R 0)
+ (sqrt (+ (* 0.75 a3 a3) (* -2 a2) (* -2 (sqrt (- (* y1 y1) (* 4 a0))))))
+ (sqrt (- (+ (* 0.75 a3 a3) (* -2 a2) (/ (* -0.25 (- (+ (* 4 a3 a2) (* -8 a1)) (* a3 a3 a3))) R)) (* R R)))))
+ (z1 (+ (* -0.25 a3) (* 0.5 R) (* 0.5 D)))
+ (z2 (+ (* -0.25 a3) (* 0.5 R) (* -0.5 D)))
+ (z3 (+ (* -0.25 a3) (* -0.5 R) (* 0.5 E)))
+ (z4 (+ (* -0.25 a3) (* -0.5 R) (* -0.5 E))))
+
+ (if (< (magnitude (poly-as-vector-eval (vector e d c b a) z1)) poly-roots-epsilon)
+ (return (list z1 z2 z3 z4))))))
#f))))
(define (nth-roots a b deg) ; ax^n + b
@@ -442,120 +434,121 @@
(let ((deg (- (length p1) 1)))
- (if (= deg 0) ; just constant
- ()
+ (cond ((= deg 0) ; just constant
+ ())
- (if (= (p1 0) 0.0) ; constant=0.0, divide through by x, recurse on new
- (if (= deg 1)
- (list 0.0)
- (let ((pnew (make-vector deg)))
- (do ((i 1 (+ i 1)))
- ((> i deg))
- (set! (pnew (- i 1)) (p1 i)))
- (append (list 0.0) (poly-as-vector-roots pnew))))
+ ((= (p1 0) 0.0) ; constant=0.0, divide through by x, recurse on new
+ (if (= deg 1)
+ (list 0.0)
+ (let ((pnew (make-vector deg)))
+ (do ((i 1 (+ i 1)))
+ ((> i deg))
+ (set! (pnew (- i 1)) (p1 i)))
+ (cons 0.0 (poly-as-vector-roots pnew)))))
- (if (= deg 1) ; ax + b -> -b/a
- (linear-root (p1 1) (p1 0))
+ ((= deg 1) ; ax + b -> -b/a
+ (linear-root (p1 1) (p1 0)))
- (if (= deg 2) ; ax^2 + bx + c -> -b +/- sqrt(b^2 - 4ac) / 2a
- (quadratic-roots (p1 2) (p1 1) (p1 0))
-
- (or (and (= deg 3)
- ;; it may be better to fall into Newton's method here
- (cubic-roots (p1 3) (p1 2) (p1 1) (p1 0)))
-
- (and (= deg 4)
- (quartic-roots (p1 4) (p1 3) (p1 2) (p1 1) (p1 0)))
-
- ;; degree>4 (or trouble above), use Newton's method unless some simple case pops up
- (let ((ones 0))
- (do ((i 1 (+ i 1)))
- ((> i deg))
- (if (not (= (p1 i) 0.0))
- (set! ones (+ 1 ones))))
-
- (if (= ones 1) ; x^n + b -- "linear" in x^n
- (nth-roots (p1 deg) (p1 0) deg)
-
- (if (and (= ones 2)
- (even? deg)
- (not (= (p1 (/ deg 2)) 0.0)))
- (let ((roots ()) ; quadratic in x^(n/2)
- (n (/ deg 2)))
- (for-each
- (lambda (r)
- (set! roots (append roots (nth-roots 1.0 (- r) n))))
- (poly-as-vector-roots (vector (p1 0)
- (p1 (/ deg 2))
- (p1 deg))))
- roots)
-
- (if (and (> deg 3)
- (= ones 3)
- (= (modulo deg 3) 0)
- (not (= (p1 (/ deg 3)) 0.0))
- (not (= (p1 (/ (* 2 deg) 3)) 0.0)))
- (let ((roots ()) ; cubic in x^(n/3)
- (n (/ deg 3)))
- (for-each
- (lambda (r)
- (set! roots (append roots (nth-roots 1.0 (- r) n))))
- (poly-as-vector-roots (vector (p1 0)
- (p1 (/ deg 3))
- (p1 (/ (* 2 deg) 3))
- (p1 deg))))
- roots)
-
- ;; perhaps get derivative roots, plug in main -- need to get nth derivative to be safe in this
- ;; from Cohen, "Computational Algebraic Number Theory"
- (let* ((roots ())
- (q (copy p1))
- (pp (poly-as-vector-derivative p1))
- (qp (copy pp))
- (n deg)
- (x 1.3+0.314159i)
- (v (poly-as-vector-eval q x))
- (m (* (magnitude v) (magnitude v)))
- (dx 0.0)
- (last-dx 1.0) ; guard against infinite loop
- (happy #f))
- (do ()
- (happy)
- (set! dx (/ v (poly-as-vector-eval qp x)))
- (if (or (<= (magnitude dx) poly-roots-epsilon)
- (= dx last-dx))
- (set! happy #t)
+ ((= deg 2) ; ax^2 + bx + c -> -b +/- sqrt(b^2 - 4ac) / 2a
+ (quadratic-roots (p1 2) (p1 1) (p1 0)))
+
+ (else
+ (or (and (= deg 3)
+ ;; it may be better to fall into Newton's method here
+ (cubic-roots (p1 3) (p1 2) (p1 1) (p1 0)))
+
+ (and (= deg 4)
+ (quartic-roots (p1 4) (p1 3) (p1 2) (p1 1) (p1 0)))
+
+ ;; degree>4 (or trouble above), use Newton's method unless some simple case pops up
+ (let ((ones 0))
+ (do ((i 1 (+ i 1)))
+ ((> i deg))
+ (if (not (= (p1 i) 0.0))
+ (set! ones (+ 1 ones))))
+
+ (cond ((= ones 1) ; x^n + b -- "linear" in x^n
+ (nth-roots (p1 deg) (p1 0) deg))
+
+ ((and (= ones 2)
+ (even? deg)
+ (not (= (p1 (/ deg 2)) 0.0)))
+ (let ((roots ()) ; quadratic in x^(n/2)
+ (n (/ deg 2)))
+ (for-each
+ (lambda (r)
+ (set! roots (append roots (nth-roots 1.0 (- r) n))))
+ (poly-as-vector-roots (vector (p1 0)
+ (p1 (/ deg 2))
+ (p1 deg))))
+ roots))
+
+ ((and (> deg 3)
+ (= ones 3)
+ (= (modulo deg 3) 0)
+ (not (= (p1 (/ deg 3)) 0.0))
+ (not (= (p1 (/ (* 2 deg) 3)) 0.0)))
+ (let ((roots ()) ; cubic in x^(n/3)
+ (n (/ deg 3)))
+ (for-each
+ (lambda (r)
+ (set! roots (append roots (nth-roots 1.0 (- r) n))))
+ (poly-as-vector-roots (vector (p1 0)
+ (p1 (/ deg 3))
+ (p1 (/ (* 2 deg) 3))
+ (p1 deg))))
+ roots))
+
+ (else
+ ;; perhaps get derivative roots, plug in main -- need to get nth derivative to be safe in this
+ ;; from Cohen, "Computational Algebraic Number Theory"
+ (let ((roots ())
+ (q (copy p1))
+ (n deg)
+ (x 1.3+0.314159i))
+ (let ((pp (poly-as-vector-derivative p1)))
+ (let ((happy #f)
+ (qp (copy pp))
+ (dx 0.0)
+ (v (poly-as-vector-eval q x))
+ (last-dx 1.0)) ; guard against infinite loop
+ (do ((m (* (magnitude v) (magnitude v))))
+ (happy)
+ (set! dx (/ v (poly-as-vector-eval qp x)))
+ (if (or (<= (magnitude dx) poly-roots-epsilon)
+ (= dx last-dx))
+ (set! happy #t)
+ (begin
+ (set! last-dx dx)
+ (do ((c 0 (+ 1 c))
+ (step3 #f))
+ ((or (>= c 20)
+ step3
+ (<= (magnitude dx) poly-roots-epsilon)))
+ (let* ((y (- x dx))
+ (v1 (poly-as-vector-eval q y))
+ (m1 (* (magnitude v1) (magnitude v1))))
+ (if (< m1 m)
(begin
- (set! last-dx dx)
- (do ((c 0 (+ 1 c))
- (step3 #f))
- ((or (>= c 20)
- step3
- (<= (magnitude dx) poly-roots-epsilon)))
- (let* ((y (- x dx))
- (v1 (poly-as-vector-eval q y))
- (m1 (* (magnitude v1) (magnitude v1))))
- (if (< m1 m)
- (begin
- (set! x y)
- (set! v v1)
- (set! m m1)
- (set! step3 #t))
- (set! dx (/ dx 4.0))))))))
- (set! x (- x (/ (poly-as-vector-eval p1 x) (poly-as-vector-eval pp x))))
- (set! x (- x (/ (poly-as-vector-eval p1 x) (poly-as-vector-eval pp x))))
- (if (< (imag-part x) poly-roots-epsilon)
- (begin
- (set! x (real-part x))
- (set! q (poly-as-vector/ q (vector (- x) 1.0)))
- (set! n (- n 1)))
- (begin
- (set! q (poly-as-vector/ q (vector (magnitude x) 0.0 1.0)))
- (set! n (- n 2))))
- (set! roots (cons x roots))
- (if (> n 0)
- (set! roots (append (poly-as-vector-roots (poly-as-vector-reduce (car q))) roots)))
- roots))))))))))))
+ (set! x y)
+ (set! v v1)
+ (set! m m1)
+ (set! step3 #t))
+ (set! dx (/ dx 4.0)))))))))
+ (set! x (- x (/ (poly-as-vector-eval p1 x) (poly-as-vector-eval pp x))))
+ (set! x (- x (/ (poly-as-vector-eval p1 x) (poly-as-vector-eval pp x)))))
+ (if (< (imag-part x) poly-roots-epsilon)
+ (begin
+ (set! x (real-part x))
+ (set! q (poly-as-vector/ q (vector (- x) 1.0)))
+ (set! n (- n 1)))
+ (begin
+ (set! q (poly-as-vector/ q (vector (magnitude x) 0.0 1.0)))
+ (set! n (- n 2))))
+ (set! roots (cons x roots))
+ (if (> n 0)
+ (set! roots (append (poly-as-vector-roots (poly-as-vector-reduce (car q))) roots)))
+ roots)))))))))
(define poly-roots
(let ((documentation "(poly-roots p1) returns the roots of polynomial p1"))
@@ -565,7 +558,8 @@
(for-each
(lambda (q)
(let ((dx (magnitude (poly-as-vector-eval v1 q))))
- (if (> dx poly-roots-epsilon) (format #t ";poly.scm 502: (poly-roots ~A) numerical trouble (polynomial root is not very good): ~A at ~A: ~A" p1 v1 q dx))))
+ (if (> dx poly-roots-epsilon)
+ (format () ";poly.scm 502: (poly-roots ~A) numerical trouble (polynomial root is not very good): ~A at ~A: ~A" p1 v1 q dx))))
roots)
roots))))
diff --git a/prc95.scm b/prc95.scm
index c366484..480e5b5 100644
--- a/prc95.scm
+++ b/prc95.scm
@@ -126,9 +126,9 @@
(bowtemp 0.0))
(if bowing
(if (not (= maxvelocity bowvelocity))
- (if (< bowvelocity maxvelocity)
- (set! bowvelocity (+ bowvelocity attackrate))
- (set! bowvelocity (- bowvelocity attackrate))))
+ (set! bowvelocity (if (< bowvelocity maxvelocity)
+ (+ bowvelocity attackrate)
+ (- bowvelocity attackrate))))
(if (> bowvelocity 0.0)
(set! bowvelocity (- bowvelocity attackrate))))
(set! bowtemp (* 0.3 bowvelocity))
@@ -169,9 +169,9 @@
((= i end))
(if blowing
(if (not (= maxpressure breathpressure))
- (if (< breathpressure maxpressure)
- (set! breathpressure (+ breathpressure attackrate))
- (set! breathpressure (- breathpressure attackrate))))
+ (set! breathpressure (if (< breathpressure maxpressure)
+ (+ breathpressure attackrate)
+ (- breathpressure attackrate))))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! dout (delayl delayline (dc-block dcblocker
@@ -209,9 +209,9 @@
(let ((pressurediff 0.0))
(if blowing
(if (not (= maxpressure breathpressure))
- (if (< breathpressure maxpressure)
- (set! breathpressure (+ breathpressure attackrate))
- (set! breathpressure (- breathpressure attackrate))))
+ (set! breathpressure (if (< breathpressure maxpressure)
+ (+ breathpressure attackrate)
+ (- breathpressure attackrate))))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! pressurediff (- (one-zero filt (* -0.95 dlyout)) breathpressure))
@@ -263,9 +263,9 @@
(set! randpressure (+ randpressure (* 0.05 breathpressure (sin sinphase))))
(if blowing
(if (not (= maxpressure breathpressure))
- (if (< breathpressure maxpressure)
- (set! breathpressure (+ breathpressure attackrate))
- (set! breathpressure (- breathpressure attackrate))))
+ (set! breathpressure (if (< breathpressure maxpressure)
+ (+ breathpressure attackrate)
+ (- breathpressure attackrate))))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! temp (dc-block dcblocker (one-pole filt boreout)))
diff --git a/primes.scm b/primes.scm
index e09b93e..c5d4437 100644
--- a/primes.scm
+++ b/primes.scm
@@ -4633,7 +4633,7 @@
(set! factors (cons p factors))
(set! num val)
(if (= num 1)
- (return (reverse factors)))))
+ (return))))
primes)))
(if (> num 1)
(call-with-exit
@@ -4645,7 +4645,7 @@
(set! factors (cons p factors))
(set! num val)
(if (= num 1)
- (return (reverse factors))))))))
+ (return)))))))
(reverse factors)))
;(factorize (* 76507 81299))
diff --git a/profile.scm b/profile.scm
new file mode 100644
index 0000000..614ae0b
--- /dev/null
+++ b/profile.scm
@@ -0,0 +1,30 @@
+(define* (show-profile (n 100))
+ (let ((info (*s7* 'profile-info)))
+ (if (null? info)
+ (format *stderr* "no profiling data!~%")
+ (let ((vect (make-vector (hash-table-entries info))))
+ (copy info vect)
+ (set! vect (sort! vect (lambda (a b) (> (cadr a) (cadr b)))))
+ (set! n (min n (length vect)))
+ (do ((i 0 (+ i 1)))
+ ((= i n) (newline *stderr*))
+ (let* ((data (vect i))
+ (key (car data))
+ (count (cadr data))
+ (expr (cddr data))
+ (file (pair-filename expr))
+ (line (pair-line-number expr)))
+ (if (> (ash key -20) 0)
+ (format *stderr* "~A[~A]: ~A~40T~A~%"
+ file line count
+ (let ((val (object->string expr)))
+ (if (> (length val) 40)
+ (string-append (substring val 0 36) " ...")
+ val))))))))))
+
+#|
+(define old-version s7-version)
+(define (s7-version)
+ (show-profile)
+ (old-version))
+|#
diff --git a/pvoc.scm b/pvoc.scm
index d6c8fce..d982cf0 100644
--- a/pvoc.scm
+++ b/pvoc.scm
@@ -65,7 +65,7 @@
(define (pvoc-output pv) (pv 0))
(define (set-pvoc-output pv val) (set! (pv 0) val))
(define (pvoc-interp pv) (pv 1))
- (define (set-pvoc-interp pv val) (set! (pv 1) val))
+ ;(define (set-pvoc-interp pv val) (set! (pv 1) val))
(define (pvoc-filptr pv) (pv 2))
(define (set-pvoc-filptr pv val) (set! (pv 2) val))
(define (pvoc-N pv) (pv 3))
@@ -85,69 +85,68 @@
(let ((pi2 (* 2.0 pi)))
- (if (>= (pvoc-output pv) (pvoc-interp pv))
- ;; get next block of amp/phase info
- (let ((N (pvoc-N pv))
- (D (pvoc-D pv))
- (amps (pvoc-ampinc pv))
- (freqs (pvoc-freqs pv))
- (filptr (pvoc-filptr pv)))
-
- (if (pvoc-analyze pv)
- ((pvoc-analyze pv) pv input)
- ;; if no analysis func:
- (begin
- (fill! freqs 0.0)
- (set-pvoc-output pv 0)
- (if (not (pvoc-in-data pv))
+ (when (>= (pvoc-output pv) (pvoc-interp pv))
+ ;; get next block of amp/phase info
+ (let ((N (pvoc-N pv))
+ (D (pvoc-D pv))
+ (amps (pvoc-ampinc pv))
+ (freqs (pvoc-freqs pv))
+ (filptr (pvoc-filptr pv)))
+
+ (if (pvoc-analyze pv)
+ ((pvoc-analyze pv) pv input)
+ ;; if no analysis func:
+ (begin
+ (fill! freqs 0.0)
+ (set-pvoc-output pv 0)
+ (if (not (pvoc-in-data pv))
+ (begin
+ (set-pvoc-in-data pv (make-float-vector N))
+ (do ((i 0 (+ i 1)))
+ ((= i N))
+ (set! ((pvoc-in-data pv) i) (input))))
+ (let ((indat (pvoc-in-data pv)))
+ ;; extra loop here since I find the optimized case confusing (we could dispense with the data move)
+ (float-vector-move! indat 0 D)
+ (do ((i (- N D) (+ i 1)))
+ ((= i N))
+ (set! (indat i) (input)))))
+ (let ((buf (modulo filptr N)))
+ (if (= buf 0)
(begin
- (set-pvoc-in-data pv (make-float-vector N))
- (do ((i 0 (+ i 1)))
- ((= i N))
- (set! ((pvoc-in-data pv) i) (input))))
- (let ((indat (pvoc-in-data pv)))
- ;; extra loop here since I find the optimized case confusing (we could dispense with the data move)
- (float-vector-move! indat 0 D)
- (do ((i (- N D) (+ i 1)))
- ((= i N))
- (set! (indat i) (input)))))
- (let ((buf (modulo filptr N)))
- (if (= buf 0)
- (begin
- (fill! amps 0.0)
- (float-vector-add! amps (pvoc-in-data pv))
- (float-vector-multiply! amps (pvoc-window pv)))
- (begin
- (do ((k 0 (+ k 1)))
- ((= k N))
- (set! (amps buf) (* ((pvoc-window pv) k) ((pvoc-in-data pv) k)))
- (set! buf (+ 1 buf))
- (if (= buf N) (set! buf 0))))))
- (set-pvoc-filptr pv (+ filptr D))
- (mus-fft amps freqs N 1)
- (rectangular->polar amps freqs)))
-
- (if (pvoc-edit pv)
- ((pvoc-edit pv) pv)
- (let ((lp (pvoc-lastphase pv))
- (pscl (/ 1.0 D))
- (kscl (/ pi2 N))
- (lim (floor (/ N 2))))
- ;; if no editing func:
- (do ((k 0 (+ k 1)))
- ((= k lim))
- (let ((phasediff (remainder (- (freqs k) (lp k)) pi2)))
- (float-vector-set! lp k (freqs k))
- (if (> phasediff pi) (set! phasediff (- phasediff pi2))
- (if (< phasediff (- pi)) (set! phasediff (+ phasediff pi2))))
- (set! (freqs k) (+ (* pscl phasediff) (* k kscl)))))))
-
- (let ((scl (/ 1.0 (pvoc-interp pv))))
- (float-vector-subtract! amps (pvoc-amps pv))
- (float-vector-subtract! freqs (pvoc-phaseinc pv))
- (float-vector-scale! amps scl)
- (float-vector-scale! freqs scl)
- )))
+ (fill! amps 0.0)
+ (float-vector-add! amps (pvoc-in-data pv))
+ (float-vector-multiply! amps (pvoc-window pv)))
+ (do ((k 0 (+ k 1)))
+ ((= k N))
+ (set! (amps buf) (* ((pvoc-window pv) k) ((pvoc-in-data pv) k)))
+ (set! buf (+ 1 buf))
+ (if (= buf N) (set! buf 0)))))
+ (set-pvoc-filptr pv (+ filptr D))
+ (mus-fft amps freqs N 1)
+ (rectangular->polar amps freqs)))
+
+ (if (pvoc-edit pv)
+ ((pvoc-edit pv) pv)
+ (let ((lp (pvoc-lastphase pv))
+ (pscl (/ 1.0 D))
+ (kscl (/ pi2 N))
+ (lim (floor (/ N 2))))
+ ;; if no editing func:
+ (do ((k 0 (+ k 1)))
+ ((= k lim))
+ (let ((phasediff (remainder (- (freqs k) (lp k)) pi2)))
+ (float-vector-set! lp k (freqs k))
+ (if (> phasediff pi) (set! phasediff (- phasediff pi2))
+ (if (< phasediff (- pi)) (set! phasediff (+ phasediff pi2))))
+ (set! (freqs k) (+ (* pscl phasediff) (* k kscl)))))))
+
+ (let ((scl (/ 1.0 (pvoc-interp pv))))
+ (float-vector-subtract! amps (pvoc-amps pv))
+ (float-vector-subtract! freqs (pvoc-phaseinc pv))
+ (float-vector-scale! amps scl)
+ (float-vector-scale! freqs scl)
+ )))
(set-pvoc-output pv (+ 1 (pvoc-output pv)))
@@ -277,72 +276,70 @@
(do ((i 0 (+ i 1)))
((>= i outlen))
- (if (>= output interp) ;; if all the samples have been output then do the next frame
- (let ((buffix (modulo filptr N)))
+ (when (>= output interp) ;; if all the samples have been output then do the next frame
+ (let ((buffix (modulo filptr N)))
; buffix is the index into the input buffer
; it wraps around circularly as time increases in the input
- (set! output 0) ; reset the output sample counter
- ;; save the old amplitudes and frequencies
- (fill! lastamp 0.0)
- (fill! lastfreq 0.0)
- (float-vector-add! lastamp fdr)
- (float-vector-add! lastfreq fdi)
- (do ((k 0 (+ k 1)))
- ((= k N))
- ;; apply the window and then stuff into the input array
- (set! (fdr buffix) (* (window k) (in-data (- filptr in-data-beg))))
- (set! filptr (+ 1 filptr))
- ;; increment the buffer index with wrap around
- (set! buffix (+ 1 buffix))
- (if (>= buffix N) (set! buffix 0)))
- ;; rewind the file for the next hop
- (set! filptr (- filptr (- N D)))
- (if (> filptr (+ in-data-beg N))
- (begin
- (set! in-data-beg filptr)
- (set! in-data (channel->float-vector in-data-beg (* N 2) snd chn))))
- ;; no imaginary component input so zero out fdi
- (fill! fdi 0.0)
- ;; compute the fft
- (mus-fft fdr fdi N 1)
- ;; now convert into magnitude and interpolated frequency
- (do ((k 0 (+ k 1)))
- ((= k N2))
- (let* ((a (fdr k))
- (b (fdi k))
- (mag (sqrt (+ (* a a) (* b b))))
- (phase 0)
- (phasediff 0))
- (set! (fdr k) mag) ;; current amp stored in fdr
- ;; mag is always positive
- ;; if it is zero then the phase difference is zero
- (if (> mag 0)
- (begin
- (set! phase (- (atan b a)))
- (set! phasediff (- phase (lastphase k)))
- (set! (lastphase k) phase)
- ;; frequency wrapping from Moore p. 254
- (if (> phasediff pi) (do () ((<= phasediff pi)) (set! phasediff (- phasediff pi2))))
- (if (< phasediff (- pi)) (do () ((>= phasediff (- pi))) (set! phasediff (+ phasediff pi2))))))
- ;; current frequency stored in fdi
- ;; scale by the pitch transposition
- (set! (fdi k)
- (* pitch (+ (/ (* phasediff sr) (* D sr))
- (* k fundamental)
- poffset)))
- ;; resynthesis gating
- (if (< (fdr k) syngate) (set! (fdr k) 0.0))
- ;; take (lastamp k) and count up to (fdr k)
- ;; interpolating by ampinc
- (set! (ampinc k) (/ (- (fdr k) (lastamp k)) interp))
- ;; take (lastfreq k) and count up to (fdi k)
- ;; interpolating by freqinc
- (set! (freqinc k) (/ (- (fdi k) (lastfreq k)) interp))))))
+ (set! output 0) ; reset the output sample counter
+ ;; save the old amplitudes and frequencies
+ (fill! lastamp 0.0)
+ (fill! lastfreq 0.0)
+ (float-vector-add! lastamp fdr)
+ (float-vector-add! lastfreq fdi)
+ (do ((k 0 (+ k 1)))
+ ((= k N))
+ ;; apply the window and then stuff into the input array
+ (set! (fdr buffix) (* (window k) (in-data (- filptr in-data-beg))))
+ (set! filptr (+ 1 filptr))
+ ;; increment the buffer index with wrap around
+ (set! buffix (+ 1 buffix))
+ (if (>= buffix N) (set! buffix 0)))
+ ;; rewind the file for the next hop
+ (set! filptr (- (+ filptr D) N))
+ (if (> filptr (+ in-data-beg N))
+ (begin
+ (set! in-data-beg filptr)
+ (set! in-data (channel->float-vector in-data-beg (* N 2) snd chn))))
+ ;; no imaginary component input so zero out fdi
+ (fill! fdi 0.0)
+ ;; compute the fft
+ (mus-fft fdr fdi N 1)
+ ;; now convert into magnitude and interpolated frequency
+ (do ((k 0 (+ k 1)))
+ ((= k N2))
+ (let* ((a (fdr k))
+ (b (fdi k))
+ (mag (sqrt (+ (* a a) (* b b))))
+ (phase 0)
+ (phasediff 0))
+ (set! (fdr k) mag) ;; current amp stored in fdr
+ ;; mag is always positive
+ ;; if it is zero then the phase difference is zero
+ (if (> mag 0)
+ (begin
+ (set! phase (- (atan b a)))
+ (set! phasediff (- phase (lastphase k)))
+ (set! (lastphase k) phase)
+ ;; frequency wrapping from Moore p. 254
+ (if (> phasediff pi) (do () ((<= phasediff pi)) (set! phasediff (- phasediff pi2))))
+ (if (< phasediff (- pi)) (do () ((>= phasediff (- pi))) (set! phasediff (+ phasediff pi2))))))
+ ;; current frequency stored in fdi
+ ;; scale by the pitch transposition
+ (set! (fdi k)
+ (* pitch (+ (/ (* phasediff sr) (* D sr))
+ (* k fundamental)
+ poffset)))
+ ;; resynthesis gating
+ (if (< (fdr k) syngate) (set! (fdr k) 0.0))
+ ;; take (lastamp k) and count up to (fdr k)
+ ;; interpolating by ampinc
+ (set! (ampinc k) (/ (- (fdr k) (lastamp k)) interp))
+ ;; take (lastfreq k) and count up to (fdi k)
+ ;; interpolating by freqinc
+ (set! (freqinc k) (/ (- (fdi k) (lastfreq k)) interp))))))
;; loop over the partials interpolate frequency and amplitude
(float-vector-add! lastamp ampinc)
(float-vector-add! lastfreq freqinc)
(float-vector-set! out-data i (oscil-bank obank))
(set! output (+ 1 output)))
(float-vector->channel out-data 0 (max len outlen))))))
-
-
diff --git a/r7rs.scm b/r7rs.scm
index f3471b8..620a673 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -19,15 +19,8 @@
(copy s (make-vector (- stop start)) start stop)))
(define list-copy copy)
-
-(define* (vector-copy v (start 0) end)
- (let ((stop (or end (length v))))
- (copy v (make-vector (- stop start)) start stop)))
-
-(define* (r7rs-string-copy s (start 0) end)
- (let ((stop (or end (length s))))
- (copy s (make-string (- stop start)) start stop)))
-
+(define vector-copy string->vector)
+(define r7rs-string-copy vector->string) ; the latter doesn't know its not a vector
(define r7rs-vector-fill! fill!) ; or do these return the sequence, not the filler?
(define r7rs-string-fill! fill!)
@@ -133,7 +126,7 @@
(define u8-ready? char-ready?)
(define peek-u8 peek-char)
(define* (utf8->string v (start 0) end) (substring v start (or end (length v))))
-(define* (string->utf8 s (start 0) end) (->byte-vector (substring s start (or end (length s)))))
+(define* (string->utf8 s (start 0) end) (->byte-vector (utf8->string s start end)))
(define write-simple write)
(define (eof-object) #<eof>)
@@ -166,16 +159,56 @@
;; or (format #f "~^ this is a comment ")
-(define-macro (define-values vars . body)
- `(apply begin (map (lambda (var val) `(define ,var ,val)) ',vars (list (begin , at body)))))
+(define-macro (define-values vars expression)
+ `(if (not (null? ',vars))
+ (varlet (curlet) ((lambda ,vars (curlet)) ,expression))))
-(define-macro (let*-values vars . body)
- `(let ()
- ,@(map (lambda (nvars . nbody)
- `(apply define-values ',nvars ', at nbody))
- (map car vars)
- (map cdr vars))
- , at body))
+#|
+(define-macro (define*-values vars expression) ; same but allows defaults for the vars
+ `(if (not (null? ',vars))
+ (varlet (curlet) ((lambda* ,vars (curlet)) ,expression))))
+
+(define-macro (define-values vars . body) ; but the spec says "<expression>" here
+ `(apply begin (map (lambda (var val) `(define ,var ,val)) ',vars (list (begin , at body)))))
+|#
+
+(define-macro (let-values vars . body)
+ (if (and (pair? vars)
+ (pair? (car vars))
+ (null? (cdar vars)))
+ `((lambda ,(caar vars)
+ , at body)
+ ,(cadar vars))
+ `(with-let (apply sublet (curlet)
+ (list ,@(map (lambda (v)
+ `((lambda ,(car v)
+ (values ,@(map (lambda (name)
+ (values (symbol->keyword name) name))
+ (let args->proper-list ((args (car v)))
+ (cond ((symbol? args) (list args))
+ ((not (pair? args)) args)
+ ((pair? (car args)) (cons (caar args) (args->proper-list (cdr args))))
+ (else (cons (car args) (args->proper-list (cdr args)))))))))
+ ,(cadr v)))
+ vars)))
+ , at body)))
+
+(define-macro (let*-values vals . body)
+ (let ((args ())
+ (exprs ()))
+ (for-each
+ (lambda (arg+expr)
+ (set! args (cons (car arg+expr) args))
+ (set! exprs (cons (cadr arg+expr) exprs)))
+ vals)
+ (let ((form `((lambda ,(car args) , at body) ,(car exprs))))
+ (if (not (null? (cdr args)))
+ (for-each
+ (lambda (arg expr)
+ (set! form `((lambda ,arg ,form) ,expr)))
+ (cdr args)
+ (cdr exprs)))
+ form)))
;; case-lambda
@@ -296,7 +329,7 @@
(else
`(let ((sym (symbol (object->string ',lib))))
(if (not (defined? sym))
- (format #t "~A not loaded~%" sym)
+ (format () "~A not loaded~%" sym)
(symbol->value sym))))))
libs)))
@@ -388,9 +421,9 @@
;; records
(define-macro (define-record-type type make ? . fields)
(let ((new-type (if (pair? type) (car type) type))
- (inherited (if (pair? type) `(list ,@(cdr type)) ())))
+ (inherited (if (pair? type) (cdr type) ())))
`(begin
- (define-class ,new-type ,inherited
+ (define-class ,new-type ,inherited ; from stuff.scm
(map (lambda (f) (if (pair? f) (car f) f)) ',fields))
(define (,? obj) ; perhaps the define-class type predicate should use this
@@ -413,23 +446,23 @@
,@(map
(lambda (field)
- (if (pair? field)
- (if (null? (cdr field))
- (values)
- (if (null? (cddr field))
- `(define (,(cadr field) obj)
- (if (not (,? obj))
- (error 'wrong-type-arg "~S should be a ~A" obj ',type))
- (obj ',(car field)))
- `(begin
- (define (,(cadr field) obj)
- (if (not (,? obj))
- (error 'wrong-type-arg "~S should be a ~A" obj ',type))
- (obj ',(car field)))
- (define (,(caddr field) obj val)
- (if (not (,? obj))
- (error 'wrong-type-arg "~S should be a ~A" obj ',type))
- (set! (obj ',(car field)) val)))))))
+ (when (pair? field)
+ (if (null? (cdr field))
+ (values)
+ (if (null? (cddr field))
+ `(define (,(cadr field) obj)
+ (if (not (,? obj))
+ (error 'wrong-type-arg "~S should be a ~A" obj ',type))
+ (obj ',(car field)))
+ `(begin
+ (define (,(cadr field) obj)
+ (if (not (,? obj))
+ (error 'wrong-type-arg "~S should be a ~A" obj ',type))
+ (obj ',(car field)))
+ (define (,(caddr field) obj val)
+ (if (not (,? obj))
+ (error 'wrong-type-arg "~S should be a ~A" obj ',type))
+ (set! (obj ',(car field)) val)))))))
fields)
',new-type)))
diff --git a/repl.scm b/repl.scm
index 4ad7944..2c72316 100644
--- a/repl.scm
+++ b/repl.scm
@@ -66,17 +66,18 @@
(histsize 100)
(histpos 0)
(m-p-pos 0)
- (histtop ())
- (histtail ()))
+ (histtop ()))
- (define (push-line line)
- (if (null? histtop)
- (begin
- (set! histtop (list line))
- (set! histtail histtop))
- (begin
- (set-cdr! histtail (list line))
- (set! histtail (cdr histtail)))))
+ (define push-line
+ (let ((histtail ()))
+ (lambda (line)
+ (if (null? histtop)
+ (begin
+ (set! histtop (list (copy line)))
+ (set! histtail histtop))
+ (begin
+ (set-cdr! histtail (list line))
+ (set! histtail (cdr histtail)))))))
(define (history-member line)
(do ((i 0 (+ i 1)))
@@ -96,13 +97,9 @@
(let loop ((oldpos histpos)
(newpos new-end))
(set! (new-hist newpos) (histbuf oldpos))
- (if (zero? newpos)
- (set! newpos (- new-size 1))
- (set! newpos (- newpos 1)))
+ (set! newpos (- (if (zero? newpos) new-size newpos) 1))
(unless (= newpos new-end)
- (if (zero? oldpos)
- (set! oldpos (- histsize 1))
- (set! oldpos (- oldpos 1)))
+ (set! oldpos (- (if (zero? oldpos) histsize oldpos) 1))
(unless (= oldpos histpos)
(loop oldpos newpos))))
(set! histsize new-size)
@@ -113,11 +110,11 @@
(define history (dilambda
(lambda (back)
(let ((i (+ histpos back)))
- (if (< i 0)
- (histbuf (+ histsize i))
- (if (>= i histsize)
- (histbuf (- i histsize))
- (histbuf i)))))
+ (copy (if (< i 0)
+ (histbuf (+ histsize i))
+ (if (>= i histsize)
+ (histbuf (- i histsize))
+ (histbuf i))))))
(lambda (new-line)
(let ((pos (history-member new-line)))
@@ -128,16 +125,15 @@
(set! (histbuf i) (histbuf (+ i 1))))
(set! (histbuf (- histsize 1)) (histbuf 0))
(set! pos 0))
-
(do ((i pos (+ i 1)))
((>= i (- histpos 1)))
(set! (histbuf i) (histbuf (+ i 1))))
- (set! histpos (- histpos 1)))
+ (set! histpos (- histpos 1))))
- (set! (histbuf histpos) new-line)
- (set! histpos (+ histpos 1))
- (if (= histpos histsize)
- (set! histpos 0))))))
+ (set! (histbuf histpos) (copy new-line))
+ (set! histpos (+ histpos 1))
+ (if (= histpos histsize)
+ (set! histpos 0)))))
(define (history-help)
(set! (*repl* 'helpers)
@@ -193,7 +189,10 @@
;; -------- evaluation ---------
(define (badexpr h) ; *missing-close-paren-hook* function for Enter command
- (set! (h 'result) 'string-read-error))
+ (let ((ow (owlet)))
+ (if (ow 'error-file)
+ (error "missing close paren in ~S" (ow 'error-file))
+ (set! (h 'result) 'string-read-error))))
(define (shell? h) ; *unbound-variable-hook* function, also for Enter
;; examine cur-line -- only call system if the unbound variable matches the first non-whitespace chars
@@ -267,16 +266,19 @@
;; -------- match parens --------
- (define (char-constant? pos)
- (and (> pos 2)
- (char=? (cur-line (- pos 1)) #\\)
- (char=? (cur-line (- pos 2)) #\#)))
-
(define (check-parens)
+
+ (define (char-constant? pos)
+ (and (> pos 2)
+ (char=? (cur-line (- pos 1)) #\\)
+ (char=? (cur-line (- pos 2)) #\#)))
+
(let ((endpos (- cursor-pos 1)))
- (if (and (> cursor-pos 1)
- (char=? (cur-line endpos) #\)) ; ")" on left of cursor
- (not (char-constant? endpos))) ; it's not "#\)"
+ (if (or (<= cursor-pos 1)
+ (not (char=? (cur-line endpos) #\))) ; ")" on left of cursor
+ (char-constant? endpos)) ; it's not "#\)"
+ (if (number? red-par-pos)
+ (set! red-par-pos #f))
(let ((oparens ())
(new-red-pos #f))
(do ((i 0 (+ i 1)))
@@ -315,15 +317,10 @@
(set! i (+ k 1))
(if (>= i endpos)
(set! oparens ()))))))))
-
(if (pair? oparens)
(set! new-red-pos (car oparens)))
(unless (equal? new-red-pos red-par-pos)
- (if (number? new-red-pos)
- (set! red-par-pos new-red-pos)
- (set! red-par-pos #f))))
- (if (number? red-par-pos)
- (set! red-par-pos #f)))))
+ (set! red-par-pos (and (number? new-red-pos) new-red-pos)))))))
;; -------- indentation --------
@@ -336,31 +333,29 @@
(check-parens)
(set! cur-line old-line)
(set! cursor-pos old-cursor)
+ (when red-par-pos
(let ((new-red red-par-pos))
(set! red-par-pos old-red)
(let ((col 0))
(do ((i 0 (+ i 1)))
((= i new-red))
- (if (char=? (cur-line i) #\newline)
- (set! col 0)
- (set! col (+ col 1))))
- (let ((sym (do ((i (+ new-red 1) (+ i 1)))
- ((not (char-alphabetic? (cur-line i)))
- (substring cur-line (+ new-red 1) i)))))
-
- (let ((spaces (+ col (if (member sym '("or" "and" "cond" "if"))
- (+ (length sym) 2)
- 2))))
- (if (= cursor-pos (length cur-line))
- (begin
- (set! cur-line (format #f "~A~NC" cur-line spaces #\space))
- (set! cursor-pos (length cur-line)))
- (begin
- (set! cur-line (format #f "~A~NC~A"
- (substring cur-line 0 cursor-pos)
- spaces #\space
- (substring cur-line (+ cursor-pos 1))))
- (set! cursor-pos (+ cursor-pos spaces))))))))))
+ (set! col (if (char=? (cur-line i) #\newline) 0 (+ col 1))))
+ (let* ((sym (do ((i (+ new-red 1) (+ i 1)))
+ ((not (char-alphabetic? (cur-line i)))
+ (substring cur-line (+ new-red 1) i))))
+ (spaces (+ col (if (member sym '("or" "and" "cond" "if"))
+ (+ (length sym) 2)
+ 2))))
+ (if (= cursor-pos (length cur-line))
+ (begin
+ (set! cur-line (format #f "~A~NC" cur-line spaces #\space))
+ (set! cursor-pos (length cur-line)))
+ (begin
+ (set! cur-line (format #f "~A~NC~A"
+ (substring cur-line 0 cursor-pos)
+ spaces #\space
+ (substring cur-line (+ cursor-pos 1))))
+ (set! cursor-pos (+ cursor-pos spaces))))))))))
;; -------- prompt --------
@@ -370,13 +365,13 @@
;; -------- vt100 --------
- (define (bold text) (format #f "~C[1m~A~C[0m" #\escape text #\escape))
(define (red text) (format #f "~C[31m~A~C[0m" #\escape text #\escape)) ; black=30, green=32, yellow=33, blue=34
(define* (rgb text (r 0) (g 0) (b 0) all-colors)
- (if all-colors
- (format #f "~C[38;5;~Dm~A~C[0m" #\escape (+ 16 (* 36 (round (* r 5))) (* 6 (round (* g 5))) (round (* b 5))) text #\escape)
- (format #f "~C[~Dm~A~C[0m" #\escape (+ 30 (ash (round b) 2) (ash (round g) 1) (round r)) text #\escape)))
+ (format #f (if all-colors
+ (values "~C[38;5;~Dm~A~C[0m" #\escape (+ 16 (* 36 (round (* r 5))) (* 6 (round (* g 5))) (round (* b 5))))
+ (values "~C[~Dm~A~C[0m" #\escape (+ 30 (ash (round b) 2) (ash (round g) 1) (round r))))
+ text #\escape))
(define (move-cursor y x)
(format *stderr* "~C[~D;~DH" #\escape y x))
@@ -433,30 +428,33 @@
(cursor-bounds))
(define (display-line start end)
-
+
+ (define (bold text)
+ (format #f "~C[1m~A~C[0m" #\escape text #\escape))
+
;; if a line wraps, it will confuse the redisplay/cursor positioning code. so truncate the display
(let ((line-len (+ (- end start) 1 prompt-length)))
(if (>= line-len last-col)
- (set! end (- end (- line-len last-col)))))
+ (set! end (- (+ end line-len) last-col))))
(if (and red-par-pos
(<= start red-par-pos)
(< red-par-pos end))
(string-append
- (if (zero? start)
- (format #f "~A" prompt-string)
- (format #f "~NC" prompt-length #\space))
- (if (= start red-par-pos)
- (format #f "~A~A"
- (bold (red "("))
- (substring cur-line (+ start 1) end))
- (format #f "~A~A~A"
- (substring cur-line start red-par-pos)
- (bold (red "("))
- (substring cur-line (+ red-par-pos 1) end))))
- (if (zero? start)
- (format #f "~A~A" prompt-string (substring cur-line 0 end))
- (format #f "~NC~A" prompt-length #\space (substring cur-line start end)))))
+ (format #f (if (zero? start)
+ (values "~A" prompt-string)
+ (values "~NC" prompt-length #\space)))
+ (format #f (if (= start red-par-pos)
+ (values "~A~A"
+ (bold (red "("))
+ (substring cur-line (+ start 1) end))
+ (values "~A~A~A"
+ (substring cur-line start red-par-pos)
+ (bold (red "("))
+ (substring cur-line (+ red-par-pos 1) end)))))
+ (format #f (if (zero? start)
+ (values "~A~A" prompt-string (substring cur-line 0 end))
+ (values "~NC~A" prompt-length #\space (substring cur-line start end))))))
(define (display-cursor)
(let ((row 0)
@@ -486,13 +484,13 @@
;; -------- help/debugging --------
(define (one-line text)
- (if (string? text)
+ (if (not (string? text))
+ text
(let ((ntext (copy text)))
(do ((i 0 (+ i 1)))
((= i (length ntext))
ntext)
- (if (char=? (ntext i) #\newline) (set! (ntext i) #\|))))
- text))
+ (if (char=? (ntext i) #\newline) (set! (ntext i) #\|))))))
(define (help c)
(when (pair? (*repl* 'helpers))
@@ -518,10 +516,10 @@
(lambda (c)
(format #f "cursor: ~A, ~C, line: ~S"
cursor-pos
- (if (> (length cur-line) 0)
+ (if (zero? (length cur-line))
+ #\space
(let ((c (cur-line (max 0 (min cursor-pos (- (length cur-line) 1))))))
- (if (char=? c #\newline) #\| c))
- #\space)
+ (if (char=? c #\newline) #\| c)))
(one-line cur-line)))
(lambda (c)
(format #f "len: ~D, selection: ~S, previous: ~S"
@@ -550,27 +548,26 @@
(keymap-functions (char->integer c)))
((integer? c)
(keymap-functions c))
- ((string? c)
- (if (= (length c) 1)
- (keymap-functions (char->integer (c 0)))
- (if (and (= (length c) 2)
- (char=? (c 0) #\escape))
- (meta-keymap-functions (char->integer (c 1)))
- (lambda (c) #t))))
- (else (error 'wrong-type-arg "keymap takes a character or string argument"))))
-
+ ((not (string? c))
+ (error 'wrong-type-arg "keymap takes a character or string argument"))
+ ((= (length c) 1)
+ (keymap-functions (char->integer (c 0))))
+ ((and (= (length c) 2)
+ (char=? (c 0) #\escape))
+ (meta-keymap-functions (char->integer (c 1))))
+ (else (lambda (c) #t))))
(lambda (c f)
(cond ((char? c)
(set! (keymap-functions (char->integer c)) f))
((integer? c)
(set! (keymap-functions c) f))
- ((string? c)
- (if (= (length c) 1)
- (set! (keymap-functions (char->integer (c 0))) f)
- (if (and (= (length c) 2)
- (char=? (c 0) #\escape))
- (set! (meta-keymap-functions (char->integer (c 1))) f))))
- (else (error 'wrong-type-arg "set! keymap takes a character or string first argument"))))))
+ ((not (string? c))
+ (error 'wrong-type-arg "set! keymap takes a character or string first argument"))
+ ((= (length c) 1)
+ (set! (keymap-functions (char->integer (c 0))) f))
+ ((and (= (length c) 2)
+ (char=? (c 0) #\escape))
+ (set! (meta-keymap-functions (char->integer (c 1))) f))))))
(define C-a 1) ; #\x01 etc
(define C-b 2)
@@ -638,11 +635,11 @@
(let ((main-keyfunc (lambda (c)
(if (<= chars 1) (save-line))
- (if (= cursor-pos (length cur-line))
- (set! cur-line (string-append cur-line (string c)))
- (if (= cursor-pos 0)
- (set! cur-line (string-append (string c) cur-line))
- (set! cur-line (string-append
+ (set! cur-line (if (= cursor-pos (length cur-line))
+ (string-append cur-line (string c))
+ (if (= cursor-pos 0)
+ (string-append (string c) cur-line)
+ (string-append
(substring cur-line 0 cursor-pos)
(string c)
(substring cur-line cursor-pos)))))
@@ -770,11 +767,11 @@
(lambda (c)
(when selection
(save-line)
- (if (zero? cursor-pos)
- (set! cur-line (string-append selection cur-line))
- (if (>= cursor-pos (length cur-line))
- (set! cur-line (string-append cur-line selection))
- (set! cur-line (string-append (substring cur-line 0 cursor-pos)
+ (set! cur-line (if (zero? cursor-pos)
+ (string-append selection cur-line)
+ (if (>= cursor-pos (length cur-line))
+ (string-append cur-line selection)
+ (string-append (substring cur-line 0 cursor-pos)
selection
(substring cur-line cursor-pos)))))
(set! cursor-pos (+ cursor-pos (length selection))))))
@@ -789,19 +786,25 @@
;; -------- add newline
(set! (keymap-functions C-o)
(lambda (c)
- (if (= cursor-pos 0)
- (set! cur-line (string-append (string #\space #\newline) cur-line))
- (if (>= cursor-pos (length cur-line))
- (set! cur-line (string-append cur-line (string #\space #\newline)))
- (if (char=? (cur-line (- cursor-pos 1)) #\newline)
- (set! cur-line (string-append (substring cur-line 0 cursor-pos)
- (string #\space #\newline)
- (substring cur-line cursor-pos)))
- (set! cur-line (string-append (substring cur-line 0 cursor-pos)
- (if (char=? (cur-line (+ cursor-pos 1)) #\newline)
- (string #\space #\newline #\space)
- (string #\space #\newline))
- (substring cur-line (+ cursor-pos 1)))))))
+ (set! cur-line (string-append (cond ((= cursor-pos 0)
+ (values (string #\space #\newline)
+ cur-line))
+
+ ((>= cursor-pos (length cur-line))
+ (values cur-line
+ (string #\space #\newline)))
+
+ ((char=? (cur-line (- cursor-pos 1)) #\newline)
+ (values (substring cur-line 0 cursor-pos)
+ (string #\space #\newline)
+ (substring cur-line cursor-pos)))
+
+ (else
+ (values (substring cur-line 0 cursor-pos)
+ (if (char=? (cur-line (+ cursor-pos 1)) #\newline)
+ (string #\space #\newline #\space)
+ (string #\space #\newline))
+ (substring cur-line (+ cursor-pos 1)))))))
(when (= last-row (+ prompt-row cur-row))
(set! prompt-row (- prompt-row 1))
(display-lines))))
@@ -836,26 +839,26 @@
(if (and (positive? start)
(= end start))
(indent start)
- (if (= cursor-pos end)
- (let ((loc (do ((i (- end 1) (- i 1)))
- ((or (< i 0)
- (char-whitespace? (cur-line i))
- (member (cur-line i) '(#\( #\' #\" #\)) eqv?))
- i))))
- (if (< loc 0)
- (set! completion (symbol-completion cur-line))
- (if (char=? (cur-line loc) #\")
- (set! completion (filename-completion (substring cur-line (+ loc 1))))
- (set! completion (symbol-completion (substring cur-line (+ loc 1))))))
- (when (and completion
- (> (length completion) (- end loc 1)))
- (save-line)
- (if (= end (length cur-line))
- (set! cur-line (string-append (substring cur-line 0 (+ loc 1)) completion))
- (set! cur-line (string-append (substring cur-line 0 (+ loc 1))
- completion
- (substring cur-line (+ end 1)))))
- (set! cursor-pos (end-of-line cursor-pos))))))))))
+ (when (= cursor-pos end)
+ (let ((loc (do ((i (- end 1) (- i 1)))
+ ((or (< i 0)
+ (char-whitespace? (cur-line i))
+ (memv (cur-line i) '(#\( #\' #\" #\))))
+ i))))
+ (set! completion (if (< loc 0)
+ (symbol-completion cur-line)
+ (if (char=? (cur-line loc) #\")
+ (filename-completion (substring cur-line (+ loc 1)))
+ (symbol-completion (substring cur-line (+ loc 1))))))
+ (when (and completion
+ (> (length completion) (- end loc 1)))
+ (save-line)
+ (set! cur-line (if (= end (length cur-line))
+ (string-append (substring cur-line 0 (+ loc 1)) completion)
+ (string-append (substring cur-line 0 (+ loc 1))
+ completion
+ (substring cur-line (+ end 1)))))
+ (set! cursor-pos (end-of-line cursor-pos))))))))))
;; -------- evaluation/multiline
(set! (keymap-functions Enter)
@@ -889,7 +892,7 @@
(if (or (= chars 1)
(not (= input-fd terminal-fd)))
(display-lines))
- (set! (history) (copy cur-line))
+ (set! (history) cur-line)
(set! m-p-pos 0)
(with-repl-let
@@ -902,6 +905,11 @@
(set! unbound-case #f)
(begin
(format *stderr* "~S~%" val)
+ ;; this set! of '** has one odd consequence: if val is a lambda expression
+ ;; find_closure in s7 will fallback on the current environment trying to
+ ;; find an associated name, and the only thing it finds is '**! So,
+ ;; when we type **, we get back **, which seems perverse. I suppose
+ ;; we could trap the string above, see "**" and change to ~W or something.
(set! ((*repl* 'top-level-let) '**) val))))))))
(lambda (type info)
@@ -910,8 +918,12 @@
(return))))
(lambda (type info)
- (format *stderr* "~A: " (red "error"))
- (apply format *stderr* info)
+ (format *stderr* "~A:" (red "error"))
+ (if (and (pair? info)
+ (string? (car info)))
+ (format *stderr* " ~A" (apply format #f info))
+ (if (not (null? info))
+ (format *stderr* " ~A" info)))
(newline *stderr*)))
(push-line (copy cur-line))
@@ -944,11 +956,11 @@
(set! cur-row newlines)))
(define (get-previous-line c) ; get earlier line indexed by numeric arg
- (let ((len (length histtop)))
- (let ((pos (or (string->number cur-line) len)))
- (set! pos (min len (max pos 1)))
- (set! cur-line (histtop (- pos 1)))
- (fixup-new-line))))
+ (let* ((len (length histtop))
+ (pos (or (string->number cur-line) len)))
+ (set! pos (min len (max pos 1)))
+ (set! cur-line (copy (histtop (- pos 1))))
+ (fixup-new-line)))
(define (move-forward-in-history c)
(set! m-p-pos (min 0 (+ m-p-pos 1)))
@@ -1030,7 +1042,7 @@
(tty #t))
;; we're in libc here, so exit is libc's exit!
- (define (tty-reset no)
+ (define (tty-reset)
(if tty (tcsetattr terminal-fd TCSAFLUSH saved))
(if (not (equal? input-fd terminal-fd)) (close input-fd))
(#_exit))
@@ -1039,7 +1051,7 @@
:exit (let ((documentation "(exit) resets the repl tty and exits the repl"))
(lambda ()
(newline *stderr*)
- (tty-reset 0))))
+ (tty-reset))))
;; check for dumb terminal
(if (or (zero? (isatty terminal-fd)) ; not a terminal -- input from pipe probably
@@ -1068,109 +1080,107 @@
(format *stderr* "> ")))))))))
;; not a pipe or a dumb terminal -- hopefully all others accept vt100 codes
- (let ((buf (termios.make))
- (read-size 128))
-
- (set! next-char ; this indirection is needed if user pastes the selection into the repl
- (let* ((c (make-string read-size #\null))
- (cc (string->c-pointer c))
- (ctr 0))
- (lambda ()
- (call-with-exit
- (lambda (return)
- (when (>= ctr chars)
- (set! ctr 0)
- (set! chars (read input-fd cc read-size))
- (if (= chars 0)
- (tty-reset terminal-fd))
-
- (when (= chars read-size)
- ;; concatenate buffers until we get the entire selection
- (let ((str (substring c 0 read-size)))
- (let reading ((num (read input-fd cc read-size)))
- (set! str (string-append str (substring c 0 num)))
- (set! chars (+ chars num))
- (if (= num read-size)
- (reading (read input-fd cc read-size))))
-
- ;; look for simple cut/paste -- no control chars etc
- (when (= input-fd terminal-fd)
- (let ((bcksp (integer->char 127))
- (ok-chars (list #\newline #\linefeed #\return #\tab)))
- (do ((i 0 (+ i 1)))
- ((or (= i chars)
- (char>=? (str i) bcksp)
- (and (char<? (str i) #\space)
- (not (member (str i) ok-chars eq?))))
-
- (when (= i chars)
- (let ((search-chars (string #\tab #\return #\newline))
- (old-pos 0)
- (start 0)
- (max-cols 0))
- (do ((pos (char-position search-chars str 0) (char-position search-chars str (+ pos 1))))
- ((not pos))
- (set! cur-line (string-append cur-line
- (substring str old-pos pos)
- (if (char=? (str pos) #\tab)
- tab-as-space
- (string #\space #\newline))))
- (set! old-pos (+ pos 1))
- (unless (char=? (str pos) #\tab)
- (set! max-cols (max max-cols (- pos start)))
- (set! start pos)))
- (if (< (+ old-pos 1) (length str))
- (set! cur-line (string-append cur-line (substring str (+ old-pos 1)))))
-
- ;; if the line is too long, the cursor gets confused, so try to reformat over-long strings
- ;; this still messes up sometimes
-
- (when (> max-cols (- last-col prompt-length))
- (let ((old-len ((funclet pretty-print) '*pretty-print-length*)))
- (set! ((funclet pretty-print) '*pretty-print-length*) (- last-col prompt-length 2))
- (set! cur-line (with-output-to-string
- (lambda ()
- (pretty-print (with-input-from-string cur-line #_read)))))
- (set! ((funclet pretty-print) '*pretty-print-length*) old-len)))
-
+ (let ((buf (termios.make)))
+ (let ((read-size 128))
+ (set! next-char ; this indirection is needed if user pastes the selection into the repl
+ (let* ((c (make-string read-size #\null))
+ (cc (string->c-pointer c))
+ (ctr 0))
+ (lambda ()
+ (call-with-exit
+ (lambda (return)
+ (when (>= ctr chars)
+ (set! ctr 0)
+ (set! chars (read input-fd cc read-size))
+ (if (= chars 0)
+ (tty-reset))
+
+ (when (= chars read-size)
+ ;; concatenate buffers until we get the entire selection
+ (let ((str (substring c 0 read-size)))
+ (let reading ((num (read input-fd cc read-size)))
+ (set! str (string-append str (substring c 0 num)))
+ (set! chars (+ chars num))
+ (if (= num read-size)
+ (reading (read input-fd cc read-size))))
+
+ ;; look for simple cut/paste -- no control chars etc
+ (when (= input-fd terminal-fd)
+ (let ((bcksp #\delete)
+ (ok-chars (list #\newline #\linefeed #\return #\tab)))
+ (do ((i 0 (+ i 1)))
+ ((or (= i chars)
+ (char>=? (str i) bcksp)
+ (and (char<? (str i) #\space)
+ (not (memv (str i) ok-chars))))
+
+ (when (= i chars)
+ (let ((search-chars (string #\tab #\return #\newline))
+ (old-pos 0)
+ (start 0)
+ (max-cols 0))
+ (do ((pos (char-position search-chars str 0) (char-position search-chars str (+ pos 1))))
+ ((not pos))
+ (set! cur-line (string-append cur-line
+ (substring str old-pos pos)
+ (if (char=? (str pos) #\tab)
+ tab-as-space
+ (string #\space #\newline))))
+ (set! old-pos (+ pos 1))
+ (unless (char=? (str pos) #\tab)
+ (set! max-cols (max max-cols (- pos start)))
+ (set! start pos)))
+ (if (< (+ old-pos 1) (length str))
+ (set! cur-line (string-append cur-line (substring str (+ old-pos 1)))))
+
+ ;; if the line is too long, the cursor gets confused, so try to reformat over-long strings
+ ;; this still messes up sometimes
+
+ (when (> max-cols (- last-col prompt-length))
+ (let ((old-len ((funclet pretty-print) '*pretty-print-length*)))
+ (set! ((funclet pretty-print) '*pretty-print-length*) (- last-col prompt-length 2))
+ (set! cur-line (with-output-to-string
+ (lambda ()
+ (pretty-print (with-input-from-string cur-line #_read)))))
+ (set! ((funclet pretty-print) '*pretty-print-length*) old-len))))
+
(set! cursor-pos (length cur-line))
(set! chars 0)
(set! ctr 1)
(display-lines)
- (return #\newline)))))))
-
- (set! c str)
- (set! cc (string->c-pointer c))
- ;; avoid time-consuming redisplays. We need to use a recursive call on next-char here
- ;; since we might have multi-char commands (embedded #\escape -> meta, etc)
- ;; actually, the time is not the repl's fault -- xterm seems to be waiting
- ;; for the window manager or someone to poke it -- if I move the mouse,
- ;; I get immediate output. I also get immediate output in any case in OSX.
- ;; valgrind and ps say we're not computing, we're just sitting there.
- (catch #t
- (lambda ()
- (do ((ch (next-char) (next-char)))
- ((= ctr (- chars 1))
- (set! chars 0)
- (display-lines)
- (return ch))
- ((keymap-functions (char->integer ch)) ch)))
+ (return #\newline))))))
- (lambda (type info)
- (set! chars 0)
- (move-cursor prompt-row prompt-col)
- (format *stderr* "internal error: ")
- (apply format *stderr* info)
- (newline *stderr*)
- (format *stderr* "line ~A: ~A~%" ((owlet) 'error-line) ((owlet) 'error-code))
- (set! chars 0)
- (set! ctr 0)
- (new-prompt)
- (return #\null))))))
-
- (let ((result (c ctr)))
- (set! ctr (+ ctr 1))
- result))))))
+ (set! c str)
+ (set! cc (string->c-pointer c))
+ ;; avoid time-consuming redisplays. We need to use a recursive call on next-char here
+ ;; since we might have multi-char commands (embedded #\escape -> meta, etc)
+ ;; actually, the time is not the repl's fault -- xterm seems to be waiting
+ ;; for the window manager or someone to poke it -- if I move the mouse,
+ ;; I get immediate output. I also get immediate output in any case in OSX.
+ ;; valgrind and ps say we're not computing, we're just sitting there.
+ (catch #t
+ (lambda ()
+ (do ((ch (next-char) (next-char)))
+ ((= ctr (- chars 1))
+ (set! chars 0)
+ (display-lines)
+ (return ch))
+ ((keymap-functions (char->integer ch)) ch)))
+
+ (lambda (type info)
+ (set! chars 0)
+ (move-cursor prompt-row prompt-col)
+ (format *stderr* "internal error: ")
+ (apply format *stderr* info)
+ (format *stderr* "~%line ~A: ~A~%" ((owlet) 'error-line) ((owlet) 'error-code))
+ (set! chars 0)
+ (set! ctr 0)
+ (new-prompt)
+ (return #\null))))))
+
+ (let ((result (c ctr)))
+ (set! ctr (+ ctr 1))
+ result)))))))
(set! input-fd (if (not file)
terminal-fd
@@ -1184,7 +1194,7 @@
(termios.set_c_cc buf VMIN 1)
(termios.set_c_cc buf VTIME 0)
(when (negative? (tcsetattr terminal-fd TCSAFLUSH buf))
- (tty-reset terminal-fd))
+ (tty-reset))
;; -------- the repl --------
@@ -1319,27 +1329,27 @@
(define* (apropos name (e (*repl* 'top-level-let)))
(define (levenshtein s1 s2)
- (let ((l1 (length s1))
- (l2 (length s2)))
- (cond ((zero? l1) l2)
- ((zero? l2) l1)
- (else (let ((distance (make-vector (list (+ l2 1) (+ l1 1)) 0)))
+ (let ((L1 (length s1))
+ (L2 (length s2)))
+ (cond ((zero? L1) L2)
+ ((zero? L2) L1)
+ (else (let ((distance (make-vector (list (+ L2 1) (+ L1 1)) 0)))
(do ((i 0 (+ i 1)))
- ((> i l1))
+ ((> i L1))
(set! (distance 0 i) i))
(do ((i 0 (+ i 1)))
- ((> i l2))
+ ((> i L2))
(set! (distance i 0) i))
(do ((i 1 (+ i 1)))
- ((> i l2))
+ ((> i L2))
(do ((j 1 (+ j 1)))
- ((> j l1))
+ ((> j L1))
(let ((c1 (+ (distance i (- j 1)) 1))
(c2 (+ (distance (- i 1) j) 1))
(c3 (+ (distance (- i 1) (- j 1))
(if (char=? (s2 (- i 1)) (s1 (- j 1))) 0 1))))
(set! (distance i j) (min c1 c2 c3)))))
- (distance l2 l1))))))
+ (distance L2 L1))))))
(define* (make-full-let-iterator lt (stop (rootlet))) ; walk the entire let chain
(if (eq? stop lt)
@@ -1350,12 +1360,11 @@
(lambda ()
(let ((result (iter)))
(if (and (eof-object? result)
- (iterator-at-end? iter))
- (if (eq? stop (iterator-sequence iter))
- result
- (begin
- (set! iter (make-iterator (outlet (iterator-sequence iter))))
- (iterloop)))
+ (iterator-at-end? iter)
+ (not (eq? stop (iterator-sequence iter))))
+ (begin
+ (set! iter (make-iterator (outlet (iterator-sequence iter))))
+ (iterloop))
result))))))
(make-iterator iterloop))))
@@ -1378,7 +1387,8 @@
(set! strs (cons (cons binding distance) strs))))))))
(make-full-let-iterator ap-env))
- (if (pair? strs)
+ (if (not (pair? strs))
+ 'no-match
(begin
(for-each (lambda (b)
(format *stderr*
@@ -1387,16 +1397,14 @@
"~C[38;5;208m~A~C[0m: ~S~%")) ; orange for less likely choices
#\escape (caar b) #\escape
(if (procedure? (cdar b))
- (let ((doc (procedure-documentation (cdar b))))
- (if (and (string? doc)
- (positive? (length doc)))
+ (let ((doc (procedure-documentation (cdar b)))) ; returns "" if no doc
+ (if (positive? (length doc))
doc
'procedure))
(cdar b))))
(sort! strs (lambda (a b)
(string<? (symbol->string (caar a)) (symbol->string (caar b))))))
- '----)
- 'no-match))))
+ '----)))))
;;; --------------------------------------------------------------------------------
diff --git a/rgb.scm b/rgb.scm
index 21f6ad4..cf9816e 100644
--- a/rgb.scm
+++ b/rgb.scm
@@ -2,6 +2,9 @@
(provide 'snd-rgb.scm)
+(define *rgb*
+ (let ()
+
;; tan -> tawny 24-Aug-01
(define snow (make-color 1.00 0.98 0.98))
@@ -661,3 +664,5 @@
(define dark-magenta (make-color 0.54 0.00 0.54))
(define dark-red (make-color 0.54 0.00 0.00))
(define light-green (make-color 0.56 0.93 0.56))
+
+(curlet)))
diff --git a/rubber.scm b/rubber.scm
index 970e536..a8d60b1 100644
--- a/rubber.scm
+++ b/rubber.scm
@@ -149,18 +149,16 @@
(sr0 (make-sampler (floor s0)))
(sr1 (make-sampler (floor s1)))
(ampsum (make-one-pole 1.0 -1.0))
- (diffsum (make-one-pole 1.0 -1.0))
- (samp0 0.0))
- (do ((i 0 (+ i 1)))
+ (diffsum (make-one-pole 1.0 -1.0)))
+ (do ((samp0 0.0)
+ (i 0 (+ i 1)))
((= i len))
(set! samp0 (next-sample sr0))
(one-pole ampsum (abs samp0))
(one-pole diffsum (abs (- (next-sample sr1) samp0))))
(set! diffsum (one-pole diffsum 0.0))
(set! ampsum (one-pole ampsum 0.0))
- (if (= diffsum 0.0)
- (set! current-min 0.0)
- (set! current-min (/ diffsum ampsum))))
+ (set! current-min (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
(set! min-samps (round (* 0.5 current-min)))
(let ((top (min (- crosses 1) current-mark (+ i zeros-checked))))
(do ((k (+ i 1) (+ k 1)))
@@ -172,18 +170,16 @@
(sr0 (make-sampler (floor s0)))
(sr1 (make-sampler (floor s1)))
(ampsum (make-one-pole 1.0 -1.0))
- (diffsum (make-one-pole 1.0 -1.0))
- (samp0 0.0))
- (do ((i 0 (+ i 1)))
+ (diffsum (make-one-pole 1.0 -1.0)))
+ (do ((samp0 0.0)
+ (i 0 (+ i 1)))
((= i len))
(set! samp0 (next-sample sr0))
(one-pole ampsum (abs samp0))
(one-pole diffsum (abs (- (next-sample sr1) samp0))))
(set! diffsum (one-pole diffsum 0.0))
(set! ampsum (one-pole ampsum 0.0))
- (if (= diffsum 0.0)
- (set! wgt 0.0)
- (set! wgt (/ diffsum ampsum))))
+ (set! wgt (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
(if (< wgt min-samps)
(begin
(set! min-samps (floor wgt))
@@ -241,38 +237,38 @@
(beg (floor (cross-samples best-mark)))
(next-beg (floor (cross-samples (floor (cross-marks best-mark)))))
(len (floor (cross-periods best-mark))))
- (if (> len 0)
- (if adding
- (let ((new-samps
- (env-add beg next-beg len)))
- (if show-details
- (add-named-mark beg (format #f "~D:~D" i (floor (/ len extension)))))
- (insert-samples beg len new-samps)
- (if (> mult 1)
- (do ((k 1 (+ k 1)))
- ((= k mult))
- (insert-samples (+ beg (* k len)) len new-samps)))
- (set! changed-len (+ changed-len (* mult len)))
+ (when (> len 0)
+ (if adding
+ (let ((new-samps
+ (env-add beg next-beg len)))
+ (if show-details
+ (add-named-mark beg (format #f "~D:~D" i (floor (/ len extension)))))
+ (insert-samples beg len new-samps)
+ (if (> mult 1)
+ (do ((k 1 (+ k 1)))
+ ((= k mult))
+ (insert-samples (+ beg (* k len)) len new-samps)))
+ (set! changed-len (+ changed-len (* mult len)))
+ (do ((j 0 (+ 1 j)))
+ ((= j weights))
+ (let ((curbeg (floor (cross-samples j))))
+ (if (> curbeg beg)
+ (set! (cross-samples j) (+ curbeg len))))))
+ (begin
+ (if (>= beg (framples))
+ (snd-print (format #f "trouble at ~D: ~D of ~D~%" i beg (framples))))
+ (if show-details
+ (add-named-mark (- beg 1) (format #f "~D:~D" i (floor (/ len extension)))))
+ (delete-samples beg len)
+ (set! changed-len (+ changed-len len))
+ (let ((end (+ beg len)))
(do ((j 0 (+ 1 j)))
((= j weights))
(let ((curbeg (floor (cross-samples j))))
(if (> curbeg beg)
- (set! (cross-samples j) (+ curbeg len))))))
- (begin
- (if (>= beg (framples))
- (snd-print (format #f "trouble at ~D: ~D of ~D~%" i beg (framples))))
- (if show-details
- (add-named-mark (- beg 1) (format #f "~D:~D" i (floor (/ len extension)))))
- (delete-samples beg len)
- (set! changed-len (+ changed-len len))
- (let ((end (+ beg len)))
- (do ((j 0 (+ 1 j)))
- ((= j weights))
- (let ((curbeg (floor (cross-samples j))))
- (if (> curbeg beg)
- (if (< curbeg end)
- (set! (cross-periods j) 0)
- (set! (cross-samples j) (- curbeg len))))))))))))
+ (if (< curbeg end)
+ (set! (cross-periods j) 0)
+ (set! (cross-samples j) (- curbeg len))))))))))))
(if show-details
(snd-print (format #f "wanted: ~D, got ~D~%" (floor samps) (floor changed-len)))))
))
diff --git a/s7-slib-init.scm b/s7-slib-init.scm
index c89f2e9..f6a7ec7 100644
--- a/s7-slib-init.scm
+++ b/s7-slib-init.scm
@@ -58,22 +58,16 @@
;;; customize a computer environment for a user.
(define (home-vicinity)
(let ((home (getenv "HOME")))
- (and home
- (case (software-type)
- ((unix coherent ms-dos) ;V7 unix has a / on HOME
- (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
- home
- (string-append home "/")))
- (else home)))))
-
+ (if (and (memq (software-type) '(unix coherent ms-dos))
+ (not (char=? #\/ (string-ref home (- (string-length home) 1)))))
+ (string-append home "/")
+ home)))
;@
(define in-vicinity string-append)
;@
(define (user-vicinity)
- (case (software-type)
- ((vms) "[.]")
- (else "")))
+ (if (eq? (software-type) 'vms) "[.]" ""))
(define *load-pathname* #f) ; *load-path* is a list of dirs in s7
@@ -104,22 +98,23 @@
(slib:error 'program-vicinity " called; use slib:load to load")))
;@
(define sub-vicinity
- (case (software-type)
- ((vms) (lambda (vic name)
- (let ((l (string-length vic)))
- (if (or (zero? (string-length vic))
- (not (char=? #\] (string-ref vic (- l 1)))))
- (string-append vic "[" name "]")
- (string-append (substring vic 0 (- l 1))
- "." name "]")))))
- (else (let ((*vicinity-suffix*
- (case (software-type)
- ((nosve) ".")
- ((macos thinkc) ":")
- ((ms-dos windows atarist os/2) "\\")
- ((unix coherent plan9 amiga) "/"))))
- (lambda (vic name)
- (string-append vic name *vicinity-suffix*))))))
+ (if (eq? (software-type) 'vms)
+ (lambda (vic name)
+ (let ((L (string-length vic)))
+ (string-append
+ (if (or (zero? (string-length vic))
+ (not (char=? #\] (string-ref vic (- L 1)))))
+ (values vic "[")
+ (values (substring vic 0 (- L 1)) "."))
+ name "]")))
+ (let ((*vicinity-suffix* (case (software-type)
+ ((nosve) ".")
+ ((macos thinkc) ":")
+ ((ms-dos windows atarist os/2) "\\")
+ ((unix coherent plan9 amiga) "/"))))
+ (lambda (vic name)
+ (string-append vic name *vicinity-suffix*)))))
+
;@
(define (make-vicinity <pathname>) <pathname>)
;@
@@ -288,21 +283,21 @@
(define (defmacro? m) (assq m *defmacros*))
;@
(define (macroexpand-1 e)
- (if (pair? e)
+ (if (not (pair? e))
+ e
(let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
- (else e)))
- e))
+ (else e)))))
;@
(define (macroexpand e)
- (if (pair? e)
+ (if (not (pair? e))
+ e
(let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
- (else e)))
- e))
+ (else e)))))
;@
(define gentemp
(let ((*gensym-counter* -1))
@@ -325,9 +320,7 @@
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
- (display "Warn: " cep)
- (for-each (lambda (x) (display #\space cep) (write x cep)) args)
- (newline cep))))
+ (format cep "Warn: ~{ ~S~}~%" args))))
;;@ define an error procedure for the library
(define slib:error error)
@@ -365,18 +358,18 @@
(try "netscape '" "'")))
;;@ define these as appropriate for your system.
-(define slib:tab (integer->char 9))
+(define slib:tab #\tab)
(define slib:form-feed (integer->char 12))
;;@ Support for older versions of Scheme. Not enough code for its own file.
-(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
+(define (last-pair lst) (if (pair? (cdr lst)) (last-pair (cdr lst)) lst))
(define t #t)
(define nil #f)
;;@ Define these if your implementation's syntax can support it and if
;;; they are not already defined.
(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
+(define (-1+ n) (- n 1))
(define 1- -1+)
;;@ Define SLIB:EXIT to be the implementation procedure to exit or
@@ -385,9 +378,7 @@
;;@ Here for backward compatability
(define scheme-file-suffix
- (let ((suffix (case (software-type)
- ((nosve) "_scm")
- (else ".scm"))))
+ (let ((suffix (if (eq? (software-type) 'nosve) "_scm" ".scm")))
(lambda () suffix)))
;;@ (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
diff --git a/s7.c b/s7.c
index aecf195..c9b2d26 100644
--- a/s7.c
+++ b/s7.c
@@ -41,7 +41,7 @@
* cload.scm and lib*.scm tie in various C libraries.
* lint.scm checks Scheme code for infelicities.
* r7rs.scm implements some of r7rs (small).
- * write.scm currrenly has pretty-print.
+ * write.scm currrently has pretty-print.
* mockery.scm has the mock-data definitions.
* stuff.scm has some stuff.
*
@@ -195,7 +195,6 @@
#if WITH_PURE_S7
#define WITH_EXTRA_EXPONENT_MARKERS 0
#define WITH_IMMUTABLE_UNQUOTE 1
- #define WITH_QUASIQUOTE_VECTOR 0
/* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values, defmacro(*)
* and a lot more (inexact/exact, integer-length, etc) -- see s7.html.
*/
@@ -218,11 +217,6 @@
/* this removes the name "unquote" */
#endif
-#ifndef WITH_QUASIQUOTE_VECTOR
- #define WITH_QUASIQUOTE_VECTOR 0
- /* this determines whether we include support for quasiquoted vector constants `#(...) */
-#endif
-
#ifndef WITH_C_LOADER
#define WITH_C_LOADER WITH_GCC
/* (load file.so [e]) looks for (e 'init_func) and if found, calls it
@@ -231,6 +225,22 @@
*/
#endif
+#ifndef WITH_HISTORY
+ #define WITH_HISTORY 0
+ /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */
+#endif
+
+#ifndef DEFAULT_HISTORY_SIZE
+ #define DEFAULT_HISTORY_SIZE 8
+ /* this is the default length of the eval history buffer */
+#endif
+
+#ifndef WITH_PROFILE
+ #define WITH_PROFILE 0
+ /* this includes profiling data collection accessible from scheme via the hash-table (*s7* 'profile-info) */
+#endif
+
+
#define WITH_GCC (defined(__GNUC__) || defined(__clang__))
/* in case mus-config.h forgets these */
@@ -319,10 +329,13 @@
#endif
#include <setjmp.h>
-/* currently longjmps in s7_call, s7_error, g_throw, eval at OP_ERROR_HOOK_QUIT */
#include "s7.h"
+enum {NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, ERROR_QUIT_JUMP};
+enum {NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, S7_CALL_SET_JUMP, EVAL_SET_JUMP};
+
+
#ifndef M_PI
#define M_PI 3.1415926535897932384626433832795029L
#endif
@@ -723,7 +736,7 @@ typedef struct s7_cell {
} unq;
struct { /* counter (internal) */
- s7_pointer result, list, env; /* env = counter_let (curlet after map/for-each frame created) */
+ s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each frame created) */
unsigned long long int cap; /* sc->capture_let_counter for frame reuse */
} ctr;
@@ -827,10 +840,14 @@ struct s7_scheme {
unsigned int heap_size;
int gc_freed;
+#if WITH_HISTORY
+ s7_pointer eval_history1, eval_history2, error_history;
+ bool using_history1;
+#endif
/* "int" or "unsigned int" seems safe here:
* sizeof(s7_cell) = 48 bytes
* so to get more than 2^32 actual objects would require ca 206 GBytes RAM
- * vectors might be full of the same object (sc->NIL for example), so there
+ * vectors might be full of the same object (sc->nil for example), so there
* we need ca 38 GBytes RAM (8 bytes per pointer).
*/
@@ -839,15 +856,15 @@ struct s7_scheme {
s7_pointer protected_objects, protected_accessors; /* a vector of gc-protected objects */
unsigned int protected_objects_size, protected_objects_loc, protected_accessors_size, protected_accessors_loc;
- s7_pointer NIL; /* empty list */
+ s7_pointer nil; /* empty list */
s7_pointer T; /* #t */
s7_pointer F; /* #f */
- s7_pointer EOF_OBJECT; /* #<eof> */
- s7_pointer UNDEFINED; /* #<undefined> */
- s7_pointer UNSPECIFIED; /* #<unspecified> */
- s7_pointer NO_VALUE; /* the (values) value */
- s7_pointer ELSE; /* else */
- s7_pointer GC_NIL; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */
+ s7_pointer eof_object; /* #<eof> */
+ s7_pointer undefined; /* #<undefined> */
+ s7_pointer unspecified; /* #<unspecified> */
+ s7_pointer no_value; /* the (values) value */
+ s7_pointer else_object; /* else */
+ s7_pointer gc_nil; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */
s7_pointer symbol_table; /* symbol table */
s7_pointer rootlet, shadow_rootlet; /* rootlet */
@@ -866,7 +883,7 @@ struct s7_scheme {
s7_pointer load_hook; /* *load-hook* hook object */
s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */
s7_pointer missing_close_paren_hook;
- s7_pointer error_hook; /* *error-hook* hook object */
+ s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */
s7_pointer direct_str;
bool gc_off; /* gc_off: if true, the GC won't run */
@@ -874,10 +891,11 @@ struct s7_scheme {
unsigned int gensym_counter, cycle_counter, f_class, add_class, multiply_class, subtract_class, equal_class;
int format_column;
unsigned long long int capture_let_counter;
- bool symbol_table_is_locked;
+ bool symbol_table_is_locked, short_print;
long long int let_number;
double default_rationalize_error, morally_equal_float_epsilon, hash_table_float_epsilon;
- s7_int default_hash_table_length, initial_string_port_length, print_length, max_vector_length, max_string_length, max_list_length, max_vector_dimensions;
+ s7_int default_hash_table_length, initial_string_port_length, print_length, history_size, true_history_size;
+ s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions;
s7_pointer stacktrace_defaults;
vdims_t *wrap_only;
@@ -906,11 +924,13 @@ struct s7_scheme {
s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10;
s7_pointer temp_cell, temp_cell_1, temp_cell_2;
s7_pointer d1, d2, d3, d4;
- s7_pointer T1_1, T2_1, T2_2, T3_1, T3_2, T3_3, Z2_1, Z2_2;
- s7_pointer A1_1, A2_1, A2_2, A3_1, A3_2, A3_3, A4_1, A4_2, A4_3, A4_4;
+ s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2;
+ s7_pointer a1_1, a2_1, a2_2, a3_1, a3_2, a3_3, a4_1, a4_2, a4_3, a4_4;
jmp_buf goto_start;
bool longjmp_ok;
+ int setjmp_loc;
+
void (*begin_hook)(s7_scheme *sc, bool *val);
int no_values, current_line, s7_call_line, safety;
@@ -929,105 +949,147 @@ struct s7_scheme {
int ht_iter_tag, baffle_ctr, bignum_precision;
s7_pointer default_rng;
+ /* these symbols are primarily for the generic function search */
+ s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, arity_symbol,
+ ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol,
+ autoload_symbol, autoloader_symbol,
+ byte_vector_symbol,
+ c_pointer_symbol, caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol,
+ caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol,
+ call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol,
+ call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol,
+ catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol,
+ cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol,
+ ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol,
+ char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol,
+ close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol,
+ curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol,
+ denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, dynamic_wind_symbol,
+ eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exp_symbol, expt_symbol,
+ features_symbol, fill_symbol, float_vector_ref_symbol, float_vector_set_symbol, float_vector_symbol, floor_symbol,
+ flush_output_port_symbol, for_each_symbol, format_symbol, funclet_symbol,
+ gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol,
+ hash_table_entries_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_star_symbol, hash_table_symbol,
+ help_symbol,
+ imag_part_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol,
+ integer_decode_float_symbol, integer_to_char_symbol, is_aritable_symbol, is_boolean_symbol, is_byte_vector_symbol,
+ is_c_object_symbol, is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol,
+ is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol,
+ is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol,
+ is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_gensym_symbol, is_hash_table_symbol,
+ is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol,
+ is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_morally_equal_symbol, is_nan_symbol, is_negative_symbol,
+ is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol,
+ is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol,
+ is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_symbol_symbol,
+ is_vector_symbol, is_zero_symbol, iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol,
+ is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol,
+ keyword_to_symbol_symbol,
+ lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol,
+ let_set_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, load_path_symbol,
+ load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol,
+ magnitude_symbol, make_byte_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, make_int_vector_symbol,
+ make_iterator_symbol, make_keyword_symbol, make_list_symbol, make_shared_vector_symbol, make_string_symbol,
+ make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol,
+ multiply_symbol,
+ newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol,
+ object_to_string_symbol, open_input_file_symbol, open_input_string_symbol, open_output_file_symbol, openlet_symbol,
+ outlet_symbol, owlet_symbol,
+ pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol,
+ procedure_documentation_symbol, procedure_signature_symbol, procedure_source_symbol, provide_symbol,
+ quotient_symbol,
+ random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol,
+ read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol,
+ require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol,
+ set_car_symbol, set_cdr_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol,
+ stacktrace_symbol, string_append_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol,
+ string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol,
+ string_set_symbol, string_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol,
+ sublet_symbol, substring_symbol, subtract_symbol, symbol_access_symbol, symbol_symbol, symbol_to_dynamic_value_symbol,
+ symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol,
+ tan_symbol, tanh_symbol, throw_symbol, to_byte_vector_symbol, truncate_symbol,
+ unlet_symbol,
+ values_symbol, varlet_symbol, vector_append_symbol, vector_dimensions_symbol, vector_fill_symbol, vector_ref_symbol,
+ vector_set_symbol, vector_symbol,
+ with_input_from_file_symbol, with_input_from_string_symbol, with_output_to_file_symbol, with_output_to_string_symbol,
+ write_byte_symbol, write_char_symbol, write_string_symbol, write_symbol;
+
+#if (!WITH_PURE_S7)
+ s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol,
+ let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_ci_eq_symbol,
+ string_ci_geq_symbol, string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, string_length_symbol,
+ string_copy_symbol, list_to_string_symbol, list_to_vector_symbol, vector_length_symbol, make_polar_symbol,
+ make_rectangular_symbol;
+#endif
+
+ /* s7 env symbols */
+ s7_pointer stack_top_symbol, symbol_table_is_locked_symbol, heap_size_symbol, gc_freed_symbol, gc_protected_objects_symbol,
+ free_heap_size_symbol, file_names_symbol, symbol_table_symbol, cpu_time_symbol, c_objects_symbol, float_format_precision_symbol,
+ stack_size_symbol, rootlet_size_symbol, c_types_symbol, safety_symbol, max_stack_size_symbol, gc_stats_symbol,
+ strings_symbol, vectors_symbol, input_ports_symbol, output_ports_symbol, continuations_symbol, hash_tables_symbol, gensyms_symbol,
+ catches_symbol, exits_symbol, stack_symbol, default_rationalize_error_symbol, max_string_length_symbol, default_random_state_symbol,
+ max_list_length_symbol, max_vector_length_symbol, max_vector_dimensions_symbol, default_hash_table_length_symbol, profile_info_symbol,
+ hash_table_float_epsilon_symbol, morally_equal_float_epsilon_symbol, initial_string_port_length_symbol, memory_usage_symbol,
+ undefined_identifier_warnings_symbol, print_length_symbol, bignum_precision_symbol, stacktrace_defaults_symbol, history_size_symbol;
+
+ /* syntax symbols et al */
+ s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, unquote_symbol, macroexpand_symbol,
+ define_expansion_symbol, baffle_symbol, with_let_symbol, documentation_symbol, signature_symbol, if_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,
+ define_macro_star_symbol, define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, letrec_star_symbol,
+ let_star_symbol, key_rest_symbol, key_allow_other_keys_symbol, key_readable_symbol, baffled_symbol,
+ __func___symbol, set_symbol, body_symbol, class_name_symbol, feed_to_symbol, format_error_symbol,
+ wrong_number_of_args_symbol, read_error_symbol, string_read_error_symbol, syntax_error_symbol, division_by_zero_symbol,
+ no_catch_symbol, io_error_symbol, invalid_escape_function_symbol, wrong_type_arg_symbol, out_of_range_symbol;
+
+ /* optimizer symbols */
+ s7_pointer and_p2_symbol, and_p_symbol, and_unchecked_symbol, begin_unchecked_symbol, case_simple_symbol, case_simpler_1_symbol,
+ case_simpler_ss_symbol, case_simpler_symbol, case_simplest_ss_symbol, case_simplest_symbol, case_unchecked_symbol,
+ cond_all_x_2_symbol, cond_all_x_symbol, cond_s_symbol, cond_simple_symbol, cond_unchecked_symbol, decrement_1_symbol,
+ define_constant_unchecked_symbol, define_funchecked_symbol, define_star_unchecked_symbol, define_unchecked_symbol,
+ do_unchecked_symbol, dotimes_p_symbol, dox_symbol, if_a_p_p_symbol, if_a_p_symbol, if_and2_p_p_symbol, if_and2_p_symbol,
+ if_andp_p_p_symbol, if_andp_p_symbol, if_cc_p_p_symbol, if_cc_p_symbol, if_cs_p_p_symbol, if_cs_p_symbol, if_csc_p_p_symbol,
+ if_csc_p_symbol, if_csq_p_p_symbol, if_csq_p_symbol, if_css_p_p_symbol, if_css_p_symbol, if_is_pair_p_p_symbol,
+ if_is_pair_p_symbol, if_is_symbol_p_p_symbol, if_is_symbol_p_symbol, if_not_s_p_p_symbol, if_not_s_p_symbol,
+ if_opssq_p_p_symbol, if_opssq_p_symbol, if_orp_p_p_symbol, if_orp_p_symbol, if_p_feed_symbol, if_p_p_p_symbol,
+ if_p_p_symbol, if_s_opcq_p_p_symbol, if_s_opcq_p_symbol, if_s_p_p_symbol, if_s_p_symbol, if_unchecked_symbol,
+ if_z_p_p_symbol, if_z_p_symbol, increment_1_symbol, increment_sa_symbol, increment_saa_symbol, increment_ss_symbol,
+ increment_sss_symbol, increment_sz_symbol, lambda_star_unchecked_symbol, lambda_unchecked_symbol, let_all_c_symbol,
+ let_all_opsq_symbol, let_all_s_symbol, let_all_x_symbol, let_c_symbol, let_no_vars_symbol, let_one_symbol,
+ let_opcq_symbol, let_opsq_p_symbol, let_opsq_symbol, let_opssq_symbol, let_s_symbol, let_star2_symbol,
+ let_star_all_x_symbol, let_star_unchecked_symbol, let_unchecked_symbol, let_z_symbol, letrec_star_unchecked_symbol,
+ letrec_unchecked_symbol, named_let_no_vars_symbol, named_let_star_symbol, named_let_symbol, or_p2_symbol, or_p_symbol,
+ or_unchecked_symbol, quote_unchecked_symbol, safe_do_symbol, safe_dotimes_symbol, set_cons_symbol, set_let_all_x_symbol,
+ set_let_s_symbol, set_normal_symbol, set_pair_a_symbol, set_pair_c_p_symbol, set_pair_c_symbol, set_pair_p_symbol,
+ set_pair_symbol, set_pair_z_symbol, set_pair_za_symbol, set_pws_symbol, set_symbol_a_symbol, set_symbol_c_symbol,
+ set_symbol_opcq_symbol, set_symbol_opsq_symbol, set_symbol_opssq_symbol, set_symbol_opsssq_symbol, set_symbol_p_symbol,
+ set_symbol_q_symbol, set_symbol_s_symbol, set_symbol_z_symbol, set_unchecked_symbol, simple_do_a_symbol,
+ simple_do_e_symbol, simple_do_p_symbol, simple_do_symbol, unless_s_symbol, unless_unchecked_symbol, when_s_symbol,
+ when_unchecked_symbol, with_baffle_unchecked_symbol, with_let_s_symbol, with_let_unchecked_symbol,
+ dox_slot_symbol;
+
#if WITH_GMP
+ s7_pointer bignum_symbol, is_bignum_symbol;
s7_pointer *bigints, *bigratios, *bigreals, *bignumbers;
int bigints_size, bigratios_size, bigreals_size, bignumbers_size;
int bigints_loc, bigratios_loc, bigreals_loc, bignumbers_loc;
#endif
- /* these are symbols, primarily for the generic function search */
- s7_pointer SUBTRACT, MULTIPLY, ADD, DIVIDE, LT, LEQ, EQ, GT, GEQ, ABS, ACOS, ACOSH;
- s7_pointer ANGLE, APPEND, APPLY, IS_ARITABLE, ARITY, ASH, ASIN, ASINH, ASSOC, ASSQ, ASSV, ATAN, ATANH;
- s7_pointer SUBLET, VARLET, UNLET, CUTLET, AUTOLOAD, AUTOLOADER, IS_BOOLEAN, BYTE_VECTOR, IS_BYTE_VECTOR, CAAAAR, CAAADR, CAAAR, CAADAR, CAADDR;
- s7_pointer CAADR, CAAR, CADAAR, CADADR, CADAR, CADDAR, CADDDR, CADDR, CADR, CALL_CC, CALL_WITH_CURRENT_CONTINUATION, CALL_WITH_EXIT, COVERLET;
- s7_pointer CALL_WITH_INPUT_FILE, CALL_WITH_INPUT_STRING, CALL_WITH_OUTPUT_FILE, CALL_WITH_OUTPUT_STRING, CAR, CATCH, CDAAAR;
- s7_pointer CDAADR, CDAAR, CDADAR, CDADDR, CDADR, CDAR, CDDAAR, CDDADR, CDDAR, CDDDAR, CDDDDR, CDDDR, CDDR, CDR, CEILING, CURLET;
- s7_pointer CHAR_LEQ, CHAR_LT, CHAR_EQ, CHAR_GEQ, CHAR_GT, IS_CHAR, CHAR_POSITION, CHAR_TO_INTEGER, IS_CHAR_ALPHABETIC;
- s7_pointer CHAR_DOWNCASE, IS_CHAR_LOWER_CASE, IS_CHAR_NUMERIC, CHAR_UPCASE, IS_CHAR_UPPER_CASE;
- s7_pointer IS_CHAR_WHITESPACE, CLOSE_INPUT_PORT, CLOSE_OUTPUT_PORT, IS_COMPLEX, CONS, IS_CONSTANT, IS_CONTINUATION, COPY, COS, COSH;
- s7_pointer CURRENT_INPUT_PORT, CURRENT_OUTPUT_PORT, CURRENT_ERROR_PORT, C_POINTER, IS_C_POINTER, IS_C_OBJECT;
- s7_pointer IS_DEFINED, DENOMINATOR, DISPLAY, DYNAMIC_WIND, IS_LET, INLET, LET_REF, LET_REF_FALLBACK, LET_SET, LET_SET_FALLBACK;
- s7_pointer IS_EOF_OBJECT, IS_EQ, IS_EQUAL, IS_EQV, ERROR, EVAL, EVAL_STRING, IS_EVEN, IS_EXACT;
- s7_pointer EXACT_TO_INEXACT, EXP, EXPT, FILL, INT_VECTOR_REF, INT_VECTOR_SET;
- s7_pointer MAKE_FLOAT_VECTOR, FLOAT_VECTOR, IS_FLOAT_VECTOR, FLOAT_VECTOR_REF, FLOAT_VECTOR_SET, MAKE_INT_VECTOR, INT_VECTOR, IS_INT_VECTOR;
- s7_pointer FLOOR, FLUSH_OUTPUT_PORT, FORMAT, FOR_EACH, GC, GCD, GENSYM, IS_GENSYM, GET_OUTPUT_STRING, HASH_TABLE, HASH_TABLE_STAR;
- s7_pointer IS_HASH_TABLE, HASH_TABLE_REF, HASH_TABLE_SET, HASH_TABLE_ENTRIES, HELP, IMAG_PART, IS_INEXACT, INEXACT_TO_EXACT;
- s7_pointer IS_INFINITE, IS_INPUT_PORT, IS_INTEGER, INTEGER_TO_CHAR, INTEGER_DECODE_FLOAT, IS_KEYWORD, KEYWORD_TO_SYMBOL;
- s7_pointer LCM, LENGTH, IS_SEQUENCE, IS_ITERATOR, MAKE_ITERATOR, ITERATE, ITERATOR_SEQUENCE, ITERATOR_IS_AT_END;
- s7_pointer LIST, IS_LIST, LIST_REF, LIST_SET, LIST_TAIL, LOAD, LOG, LOGAND, LOGBIT, LOGIOR, LOGNOT, LOGXOR;
- s7_pointer IS_MACRO, MAKE_BYTE_VECTOR, MAKE_HASH_TABLE, MAKE_KEYWORD, MAKE_LIST, RANDOM_STATE;
- s7_pointer MAKE_STRING, MAKE_SHARED_VECTOR, MAKE_VECTOR, MAP, MAX, MEMBER, MEMQ, MEMV, MIN, MODULO, IS_MORALLY_EQUAL, IS_NAN, IS_NEGATIVE, NEWLINE;
- s7_pointer NOT, IS_NULL, IS_NUMBER, NUMBER_TO_STRING, NUMERATOR, OBJECT_TO_STRING, IS_ODD, OPENLET, IS_OPENLET, OPEN_INPUT_FILE;
- s7_pointer OPEN_INPUT_STRING, OPEN_OUTPUT_FILE, OUTLET, IS_OUTPUT_PORT, OWLET, IS_PAIR, PAIR_LINE_NUMBER, PEEK_CHAR;
- s7_pointer IS_PORT_CLOSED, PORT_FILENAME, PORT_LINE_NUMBER, IS_PROPER_LIST;
- s7_pointer IS_POSITIVE, IS_PROCEDURE, PROCEDURE_DOCUMENTATION, PROCEDURE_SIGNATURE, FUNCLET, PROCEDURE_SOURCE;
- s7_pointer IS_DILAMBDA, PROVIDE, ROOTLET;
- s7_pointer IS_PROVIDED, QUOTIENT, RANDOM, IS_RANDOM_STATE, RANDOM_STATE_TO_LIST, RATIONALIZE, IS_RATIONAL, READ, READ_BYTE, READ_CHAR, READ_LINE, IS_REAL;
- s7_pointer READ_STRING, REAL_PART, REMAINDER, REQUIRE, REVERSE, REVERSEB, ROUND, SET_CAR, SET_CDR, SIN, SINH, SORT, SQRT, STACKTRACE;
- s7_pointer STRING, STRING_DOWNCASE, STRING_UPCASE, STRING_LEQ, STRING_LT, STRING_EQ;
- s7_pointer STRING_GEQ, STRING_GT, IS_STRING, STRING_POSITION, STRING_TO_NUMBER, STRING_TO_SYMBOL, STRING_APPEND;
- s7_pointer STRING_FILL, STRING_REF, STRING_SET, SUBSTRING, SYMBOL;
- s7_pointer SYMBOL_ACCESS, IS_SYMBOL, SYMBOL_TO_KEYWORD, SYMBOL_TO_STRING, SYMBOL_TO_DYNAMIC_VALUE, SYMBOL_TO_VALUE;
- s7_pointer TAN, TANH, THROW, TO_BYTE_VECTOR, TRUNCATE, VALUES, VECTOR, VECTOR_APPEND, VECTOR_FILL;
- s7_pointer IS_VECTOR, VECTOR_DIMENSIONS, VECTOR_REF, VECTOR_SET, WITH_INPUT_FROM_FILE;
- s7_pointer WITH_INPUT_FROM_STRING, WITH_OUTPUT_TO_FILE, WITH_OUTPUT_TO_STRING, WRITE, WRITE_BYTE, WRITE_CHAR, WRITE_STRING, IS_ZERO;
- s7_pointer S7_FEATURES, LOAD_PATH, PI, MAGNITUDE, COMPLEX;
-#if (!WITH_PURE_S7)
- s7_pointer IS_CHAR_READY, CHAR_CI_LEQ, CHAR_CI_LT, CHAR_CI_EQ, CHAR_CI_GEQ, CHAR_CI_GT, LET_TO_LIST, INTEGER_LENGTH;
- s7_pointer STRING_CI_LEQ, STRING_CI_LT, STRING_CI_EQ, STRING_CI_GEQ, STRING_CI_GT, STRING_TO_LIST, VECTOR_TO_LIST;
- s7_pointer STRING_LENGTH, STRING_COPY, LIST_TO_STRING, LIST_TO_VECTOR, VECTOR_LENGTH, MAKE_POLAR, MAKE_RECTANGULAR;
-#endif
-
-#if WITH_GMP
- s7_pointer BIGNUM, IS_BIGNUM;
-#endif
#if WITH_SYSTEM_EXTRAS
- s7_pointer IS_DIRECTORY, FILE_EXISTS, DELETE_FILE, GETENV, SYSTEM, DIRECTORY_TO_LIST, FILE_MTIME;
+ s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, getenv_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol;
#endif
- /* these are the associated functions, not symbols */
- s7_pointer Vector_Set, String_Set, List_Set, Hash_Table_Set, Let_Set; /* Cons (see the setter stuff at the end) */
-
- s7_pointer LAMBDA, LAMBDA_STAR, LET, QUOTE, UNQUOTE, MACROEXPAND, DEFINE_EXPANSION, BAFFLE, WITH_LET, DOCUMENTATION, SIGNATURE;
- s7_pointer IF, WHEN, UNLESS, BEGIN, COND, CASE, AND, OR, DO, DEFINE, DEFINE_STAR, DEFINE_CONSTANT, WITH_BAFFLE;
- s7_pointer DEFINE_MACRO, DEFINE_MACRO_STAR, DEFINE_BACRO, DEFINE_BACRO_STAR;
- s7_pointer LETREC, LETREC_STAR, LET_STAR;
- s7_pointer SET, QQ_List, QQ_Apply_Values, QQ_Append, Multivector;
- s7_pointer Apply, Vector;
- s7_pointer WRONG_TYPE_ARG, wrong_type_arg_info, OUT_OF_RANGE, out_of_range_info;
- s7_pointer simple_wrong_type_arg_info, simple_out_of_range_info, DIVISION_BY_ZERO, DIVISION_BY_ZERO_ERROR, NO_CATCH, IO_ERROR, INVALID_ESCAPE_FUNCTION;
- s7_pointer FORMAT_ERROR, WRONG_NUMBER_OF_ARGS, READ_ERROR, STRING_READ_ERROR, SYNTAX_ERROR, TOO_MANY_ARGUMENTS, NOT_ENOUGH_ARGUMENTS;
- s7_pointer KEY_REST, KEY_ALLOW_OTHER_KEYS, KEY_READABLE, BAFFLED;
- s7_pointer __FUNC__;
- s7_pointer Object_Set; /* applicable object set method */
- s7_pointer FEED_TO; /* => */
- s7_pointer BODY, CLASS_NAME, IS_FLOAT, IS_INTEGER_OR_REAL_AT_END, IS_INTEGER_OR_ANY_AT_END;
- s7_pointer QUOTE_UNCHECKED, BEGIN_UNCHECKED, CASE_UNCHECKED, SET_UNCHECKED, LAMBDA_UNCHECKED, LET_UNCHECKED, WITH_LET_UNCHECKED, WITH_LET_S;
- s7_pointer LET_STAR_UNCHECKED, LETREC_UNCHECKED, LETREC_STAR_UNCHECKED, COND_UNCHECKED, COND_SIMPLE, WITH_BAFFLE_UNCHECKED;
- s7_pointer SET_SYMBOL_C, SET_SYMBOL_S, SET_SYMBOL_Q, SET_SYMBOL_P, SET_SYMBOL_Z, SET_SYMBOL_A;
- s7_pointer SET_SYMBOL_opSq, SET_SYMBOL_opSSq, SET_SYMBOL_opSSSq, SET_SYMBOL_opCq;
- s7_pointer SET_NORMAL, SET_PAIR, SET_PAIR_Z, SET_PAIR_A, SET_PAIR_ZA, SET_PAIR_P, SET_PWS, SET_LET_S, SET_LET_ALL_X, SET_PAIR_C, SET_PAIR_C_P;
- s7_pointer LAMBDA_STAR_UNCHECKED, DO_UNCHECKED, DEFINE_UNCHECKED, DEFINE_FUNCHECKED, DEFINE_STAR_UNCHECKED, DEFINE_CONSTANT_UNCHECKED;
- s7_pointer CASE_SIMPLE, CASE_SIMPLER, CASE_SIMPLER_1, CASE_SIMPLER_SS, CASE_SIMPLEST, CASE_SIMPLEST_SS;
- s7_pointer LET_C, LET_S, LET_ALL_C, LET_ALL_S, LET_ALL_X;
- s7_pointer LET_STAR_ALL_X, LET_opCq, LET_opSSq;
- s7_pointer LET_NO_VARS, NAMED_LET, NAMED_LET_NO_VARS, NAMED_LET_STAR, LET_STAR2, IF_UNCHECKED, AND_UNCHECKED, AND_P, AND_P2, OR_UNCHECKED, OR_P, OR_P2;
- s7_pointer IF_P_P_P, IF_P_P, IF_S_P_P, IF_S_P, IF_P_FEED;
- s7_pointer IF_Z_P, IF_Z_P_P, IF_A_P, IF_A_P_P, IF_ANDP_P, IF_ANDP_P_P, IF_ORP_P, IF_ORP_P_P, IF_CC_P_P;
- s7_pointer IF_CS_P_P, IF_CC_P, IF_CS_P, IF_AND2_P, IF_AND2_P_P;
- s7_pointer IF_CSQ_P, IF_CSQ_P_P, IF_CSS_P, IF_CSS_P_P, IF_CSC_P, IF_CSC_P_P;
- s7_pointer IF_IS_PAIR_P, IF_IS_PAIR_P_P, IF_opSSq_P, IF_opSSq_P_P, IF_S_opCq_P, IF_S_opCq_P_P;
- s7_pointer IF_IS_SYMBOL_P, IF_IS_SYMBOL_P_P, IF_NOT_S_P, IF_NOT_S_P_P;
- s7_pointer WHEN_UNCHECKED, UNLESS_UNCHECKED, WHEN_S, UNLESS_S;
- s7_pointer COND_ALL_X, COND_ALL_X_2, COND_S;
- s7_pointer INCREMENT_1, DECREMENT_1, SET_CONS, INCREMENT_SS, INCREMENT_SSS, INCREMENT_SZ, INCREMENT_SA, INCREMENT_SAA;
- s7_pointer LET_opSq, LET_ALL_opSq, LET_opSq_P, LET_ONE, LET_Z;
- s7_pointer SIMPLE_DO, SAFE_DOTIMES, SAFE_DO, SIMPLE_DO_P, DOTIMES_P, SIMPLE_DO_A, SIMPLE_DO_E;
- s7_pointer DOX, dox_slot_symbol, else_symbol;
+ /* setter and quasiquote functions */
+ s7_pointer vector_set_function, string_set_function, list_set_function, hash_table_set_function, let_set_function, object_set_function,
+ qq_list_function, qq_apply_values_function, qq_append_function, multivector_function,
+ apply_function, vector_function;
+ s7_pointer wrong_type_arg_info, out_of_range_info, simple_wrong_type_arg_info, simple_out_of_range_info;
+ s7_pointer too_many_arguments_string, not_enough_arguments_string, division_by_zero_error_string;
s7_pointer *safe_lists, *syn_docs; /* prebuilt evaluator arg lists, syntax doc strings */
- s7_pointer autoload_table, libraries;
+ s7_pointer autoload_table, libraries, profile_info;
const char ***autoload_names;
int *autoload_names_sizes;
bool **autoloaded_already;
@@ -1040,16 +1102,6 @@ struct s7_scheme {
xf_t *cur_rf;
xf_t *rf_free_list, *rf_stack;
-
- /* s7 env symbols */
- s7_pointer stack_top_symbol, symbol_table_is_locked_symbol, heap_size_symbol, gc_freed_symbol, gc_protected_objects_symbol;
- s7_pointer free_heap_size_symbol, file_names_symbol, symbol_table_symbol, cpu_time_symbol, c_objects_symbol, float_format_precision_symbol;
- s7_pointer stack_size_symbol, rootlet_size_symbol, c_types_symbol, safety_symbol, max_stack_size_symbol, gc_stats_symbol;
- s7_pointer strings_symbol, vectors_symbol, input_ports_symbol, output_ports_symbol, continuations_symbol, hash_tables_symbol, gensyms_symbol;
- s7_pointer catches_symbol, exits_symbol, stack_symbol, default_rationalize_error_symbol, max_string_length_symbol, default_random_state_symbol;
- s7_pointer max_list_length_symbol, max_vector_length_symbol, max_vector_dimensions_symbol, default_hash_table_length_symbol;
- s7_pointer hash_table_float_epsilon_symbol, morally_equal_float_epsilon_symbol, initial_string_port_length_symbol, memory_usage_symbol;
- s7_pointer undefined_identifier_warnings_symbol, print_length_symbol, bignum_precision_symbol, stacktrace_defaults_symbol;
bool undefined_identifier_warnings;
};
@@ -1186,6 +1238,15 @@ static void init_types(void)
t_simple_p[T_OUTPUT_PORT] = true;
}
+#if WITH_HISTORY
+#define current_code(Sc) car(Sc->cur_code)
+#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); car(Sc->cur_code) = Code;} while (0)
+#define mark_current_code(Sc) do {int i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < sc->history_size; i++, p = cdr(p)) S7_MARK(car(p));} while (0)
+#else
+#define current_code(Sc) Sc->cur_code
+#define set_current_code(Sc, Code) Sc->cur_code = Code
+#define mark_current_code(Sc) S7_MARK(Sc->cur_code)
+#endif
#define typeflag(p) ((p)->tf.flag)
#define typesflag(p) ((p)->tf.sflag)
@@ -1246,6 +1307,8 @@ static s7_scheme *hidden_sc = NULL;
{ \
if (((typeflag(p) & T_IMMUTABLE) != 0) && ((typeflag(p) != (f)))) \
fprintf(stderr, "%d: set immutable %p type %x to %x\n", __LINE__, p, unchecked_type(p), f); \
+ if (((typeflag(p) & T_LINE_NUMBER) != 0) && (((typeflag(p)) & 0xff) == T_PAIR) && (((f) & T_LINE_NUMBER) == 0)) \
+ fprintf(stderr, "%d unsets line_number\n", __LINE__); \
} \
typeflag(p) = f; \
} while (0)
@@ -1369,6 +1432,7 @@ static s7_scheme *hidden_sc = NULL;
#define is_any_macro(P) t_any_macro_p[type(P)]
#define is_any_closure(P) t_any_closure_p[type(P)]
#define is_procedure_or_macro(P) ((t_any_macro_p[type(P)]) || ((typeflag(P) & T_PROCEDURE) != 0))
+#define is_any_procedure(P) (type(P) >= T_CLOSURE)
#define has_closure_let(P) t_has_closure_let[type(P)]
#define is_simple_sequence(P) (t_sequence_p[type(P)])
@@ -1394,6 +1458,7 @@ static s7_scheme *hidden_sc = NULL;
#define SYNTACTIC_TYPE (unsigned short)(T_SYMBOL | T_DONT_EVAL_ARGS | T_SYNTACTIC)
#define SYNTACTIC_PAIR (unsigned short)(T_PAIR | T_SYNTACTIC)
/* this marks symbols that represent syntax objects, it should be in the second byte */
+#define set_syntactic_pair(p) typeflag(p) = (SYNTACTIC_PAIR | (typeflag(p) & 0xffff0000))
#define T_PROCEDURE (1 << (TYPE_BITS + 2))
#define is_procedure(p) ((typesflag(_NFre(p)) & T_PROCEDURE) != 0)
@@ -1455,7 +1520,7 @@ static s7_scheme *hidden_sc = NULL;
static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int line)
{
if ((is_global(symbol)) || (is_syntactic(symbol)))
- fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, BOLD_TEXT, DISPLAY(symbol), UNBOLD_TEXT, DISPLAY_80(sc->cur_code));
+ fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, BOLD_TEXT, DISPLAY(symbol), UNBOLD_TEXT, DISPLAY_80(current_code(sc)));
typeflag(symbol) = (typeflag(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
}
#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
@@ -1482,7 +1547,9 @@ static s7_scheme *hidden_sc = NULL;
#define T_LINE_NUMBER (1 << (TYPE_BITS + 10))
#define has_line_number(p) ((typeflag(_TLst(p)) & T_LINE_NUMBER) != 0)
#define set_has_line_number(p) typeflag(_TLst(p)) |= T_LINE_NUMBER
-/* pair in question has line/file info added during read, or the environment has function placement info */
+/* pair in question has line/file info added during read, or the environment has function placement info
+ * this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it.
+ */
#define T_LOADER_PORT T_LINE_NUMBER
#define is_loader_port(p) ((typeflag(_TPrt(p)) & T_LOADER_PORT) != 0)
@@ -1617,7 +1684,6 @@ bool s7_is_stepper(s7_pointer p) {return(is_stepper(p));}
#define set_has_set_fallback(p) typeflag(_TLet(p)) |= T_HAS_SET_FALLBACK
#define set_all_methods(p, e) typeflag(_TLet(p)) |= (typeflag(e) & (T_HAS_METHODS | T_HAS_REF_FALLBACK | T_HAS_SET_FALLBACK))
-
#define T_COPY_ARGS (1 << (TYPE_BITS + 20))
#define needs_copied_args(p) ((typeflag(_NFre(p)) & T_COPY_ARGS) != 0)
/* this marks something that might mess with its argument list, it should not be in the second byte */
@@ -1667,7 +1733,7 @@ static int not_heap = -1;
#define not_in_heap(p) ((_NFre(p))->hloc < 0)
#define unheap(p) (p)->hloc = not_heap--
-#define is_eof(p) (_NFre(p) == sc->EOF_OBJECT)
+#define is_eof(p) (_NFre(p) == sc->eof_object)
#define is_true(Sc, p) ((_NFre(p)) != Sc->F)
#define is_false(Sc, p) ((_NFre(p)) == Sc->F)
@@ -1680,8 +1746,8 @@ static int not_heap = -1;
#endif
#define is_pair(p) (type(p) == T_PAIR)
-#define is_null(p) ((_NFre(p)) == sc->NIL)
-#define is_not_null(p) ((_NFre(p)) != sc->NIL)
+#define is_null(p) ((_NFre(p)) == sc->nil)
+#define is_not_null(p) ((_NFre(p)) != sc->nil)
#if (!DEBUGGING)
@@ -1739,8 +1805,7 @@ static int not_heap = -1;
#define opt1(p, Role) opt1_1(hidden_sc, _TLst(p), Role, __func__, __LINE__)
#define set_opt1(p, x, Role) set_opt1_1(hidden_sc, _TLst(p), x, Role, __func__, __LINE__)
-#define F_SET (1 << 1)
-#define F_C_CALL (1 << 18) /* c_function invocation */
+#define F_SET (1 << 1) /* bit 18 is free */
#define F_KEY (1 << 19) /* case key */
#define F_SLOW (1 << 20) /* slow list in member/assoc circular list check */
#define F_SYM (1 << 21) /* symbol */
@@ -1748,7 +1813,7 @@ static int not_heap = -1;
#define F_CON (1 << 23) /* constant as above */
#define F_CALL (1 << 24) /* c-func */
#define F_LAMBDA (1 << 25) /* lambda form */
-#define F_MASK (F_C_CALL | F_KEY | F_SLOW | F_SYM | F_PAIR | F_CON | F_CALL | F_LAMBDA | S_NAME)
+#define F_MASK (F_KEY | F_SLOW | F_SYM | F_PAIR | F_CON | F_CALL | F_LAMBDA | S_NAME)
#define opt2_is_set(p) (((p)->debugger_bits & F_SET) != 0)
#define set_opt2_is_set(p) (p)->debugger_bits |= F_SET
@@ -1793,6 +1858,7 @@ static int not_heap = -1;
#define has_opt_back(P) (cdr(opt_back(P)) == P )
#define opt_cfunc(P) opt1(P, E_CFUNC)
#define set_opt_cfunc(P, X) set_opt1(P, X, E_CFUNC)
+#define opt_lambda_unchecked(P) opt1(P, E_LAMBDA)
#define opt_lambda(P) _TClo(opt1(P, E_LAMBDA))
#define set_opt_lambda(P, X) set_opt1(P, X, E_LAMBDA)
#define opt_goto(P) _TGot(opt1(P, E_GOTO))
@@ -1878,10 +1944,10 @@ static int not_heap = -1;
#define cons(Sc, A, B) s7_cons(Sc, A, B)
#endif
-#define list_1(Sc, A) cons(Sc, A, sc->NIL)
-#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, sc->NIL))
-#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, sc->NIL)))
-#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, sc->NIL))))
+#define list_1(Sc, A) cons(Sc, A, sc->nil)
+#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, sc->nil))
+#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, sc->nil)))
+#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, sc->nil))))
#define is_string(p) (type(p) == T_STRING)
#define string_value(p) (_TStr(p))->object.string.svalue
@@ -2047,7 +2113,7 @@ static void pair_set_syntax_symbol(s7_pointer p, s7_pointer op) {pair_syntax_sym
#define iterator_next(p) (_TItr(p))->object.iter.next
#define iterator_is_at_end(p) (iterator_next(p) == iterator_finished)
-#define ITERATOR_END EOF_OBJECT
+#define ITERATOR_END eof_object
#define ITERATOR_END_NAME "#<eof>"
#define is_input_port(p) (type(p) == T_INPUT_PORT)
@@ -2162,6 +2228,8 @@ static void pair_set_syntax_symbol(s7_pointer p, s7_pointer op) {pair_syntax_sym
#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET)
#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0)))
+#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, _TClo(p))))
+
#define catch_tag(p) (_TCat(p))->object.rcatch.tag
#define catch_goto_loc(p) (_TCat(p))->object.rcatch.goto_loc
#define catch_op_loc(p) (_TCat(p))->object.rcatch.op_stack_loc
@@ -2219,6 +2287,7 @@ static int num_object_types = 0;
#define counter_capture(p) (_TCtr(p))->object.ctr.cap
#define counter_let(p) _TLid((_TCtr(p))->object.ctr.env)
#define counter_set_let(p, L) (_TCtr(p))->object.ctr.env = _TLid(L)
+#define counter_slots(p) (_TCtr(p))->object.ctr.slots
#define is_baffle(p) (type(p) == T_BAFFLE)
#define baffle_key(p) (_TBfl(p))->object.baffle_key
@@ -2483,7 +2552,6 @@ static token_t token(s7_scheme *sc);
static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices);
static bool s7_is_morally_equal(s7_scheme *sc, s7_pointer x, s7_pointer y);
static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym);
-static s7_pointer find_symbol_unchecked(s7_scheme *sc, s7_pointer symbol);
static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym);
static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body);
static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_pointer e);
@@ -2496,10 +2564,24 @@ static s7_int big_integer_to_s7_int(mpz_t n);
static double next_random(s7_pointer r);
#endif
+#if DEBUGGING && WITH_GCC
+ static s7_pointer find_symbol_unchecked_1(s7_scheme *sc, s7_pointer symbol);
+ #define find_symbol_unchecked(Sc, Sym) check_null_sym(Sc, find_symbol_unchecked_1(Sc, Sym), Sym, __LINE__, __func__)
+ static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int line, const char *func);
+ #define find_symbol_unexamined(Sc, Sym) find_symbol_unchecked_1(Sc, Sym)
+#else
+ static s7_pointer find_symbol_unchecked(s7_scheme *sc, s7_pointer symbol);
+ #define find_symbol_unexamined(Sc, Sym) find_symbol_unchecked(Sc, Sym)
+#endif
+
#if WITH_GCC
-#define find_symbol_checked(Sc, Sym) ({s7_pointer _x_; _x_ = find_symbol_unchecked(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
+ #if DEBUGGING
+ #define find_symbol_checked(Sc, Sym) ({s7_pointer _x_; _x_ = find_symbol_unchecked_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
+ #else
+ #define find_symbol_checked(Sc, Sym) ({s7_pointer _x_; _x_ = find_symbol_unchecked(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
+ #endif
#else
-#define find_symbol_checked(Sc, Sym) find_symbol_unchecked(Sc, Sym)
+ #define find_symbol_checked(Sc, Sym) find_symbol_unchecked(Sc, Sym)
#endif
static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol);
@@ -2513,20 +2595,20 @@ static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer cal
static s7_pointer out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr);
static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr);
-/* putting off the type description until s7_error via the sc->GC_NIL marker below makes it possible
+/* putting off the type description until s7_error via the sc->gc_nil marker below makes it possible
* for gcc to speed up the functions that call these as tail-calls. 1-2% overall speedup!
*/
#define simple_wrong_type_argument(Sc, Caller, Arg, Desired_Type) \
- simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->GC_NIL, prepackaged_type_names[Desired_Type])
+ simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->gc_nil, prepackaged_type_names[Desired_Type])
#define wrong_type_argument(Sc, Caller, Num, Arg, Desired_Type) \
- wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->GC_NIL, prepackaged_type_names[Desired_Type])
+ wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->gc_nil, prepackaged_type_names[Desired_Type])
#define simple_wrong_type_argument_with_type(Sc, Caller, Arg, Type) \
- simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->GC_NIL, Type)
+ simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->gc_nil, Type)
#define wrong_type_argument_with_type(Sc, Caller, Num, Arg, Type) \
- wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->GC_NIL, Type)
+ wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->gc_nil, Type)
#define simple_out_of_range(Sc, Caller, Arg, Description) \
@@ -2536,16 +2618,20 @@ static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointe
out_of_range_error_prepackaged(Sc, symbol_name_cell(Caller), Arg_Num, Arg, Description)
-static s7_pointer CAR_A_LIST, CDR_A_LIST;
-static s7_pointer CAAR_A_LIST, CADR_A_LIST, CDAR_A_LIST, CDDR_A_LIST;
-static s7_pointer CAAAR_A_LIST, CAADR_A_LIST, CADAR_A_LIST, CADDR_A_LIST, CDAAR_A_LIST, CDADR_A_LIST, CDDAR_A_LIST, CDDDR_A_LIST;
-static s7_pointer A_LIST, AN_ASSOCIATION_LIST, AN_OUTPUT_PORT, AN_INPUT_PORT, AN_OPEN_PORT, A_NORMAL_REAL, A_RATIONAL, A_BOOLEAN;
-static s7_pointer A_NUMBER, A_LET, A_PROCEDURE, A_PROPER_LIST, A_THUNK, SOMETHING_APPLICABLE, A_SYMBOL, A_NON_NEGATIVE_INTEGER;
-static s7_pointer A_FORMAT_PORT, AN_UNSIGNED_BYTE, A_BINDING, A_NON_CONSTANT_SYMBOL, AN_EQ_FUNC, A_SEQUENCE, ITS_TOO_SMALL, A_NORMAL_PROCEDURE;
-static s7_pointer ITS_TOO_LARGE, ITS_NEGATIVE, RESULT_IS_TOO_LARGE, ITS_NAN, ITS_INFINITE, TOO_MANY_INDICES, A_VALID_RADIX;
-static s7_pointer AN_INPUT_STRING_PORT, AN_INPUT_FILE_PORT, AN_OUTPUT_STRING_PORT, AN_OUTPUT_FILE_PORT, A_RANDOM_STATE_OBJECT;
+static s7_pointer car_a_list_string, cdr_a_list_string, caar_a_list_string, cadr_a_list_string, cdar_a_list_string,
+ cddr_a_list_string, caaar_a_list_string, caadr_a_list_string, cadar_a_list_string, caddr_a_list_string,
+ cdaar_a_list_string, cdadr_a_list_string, cddar_a_list_string, cdddr_a_list_string, a_list_string,
+ an_association_list_string, an_output_port_string, an_input_port_string, an_open_port_string,
+ a_normal_real_string, a_rational_string, a_boolean_string, a_number_string, a_let_string,
+ a_procedure_string, a_proper_list_string, a_thunk_string, something_applicable_string, a_symbol_string,
+ a_non_negative_integer_string, a_format_port_string, an_unsigned_byte_string, a_binding_string,
+ a_non_constant_symbol_string, an_eq_func_string, a_sequence_string, its_too_small_string,
+ a_normal_procedure_string, its_too_large_string, its_negative_string, result_is_too_large_string,
+ its_nan_string, its_infinite_string, too_many_indices_string, a_valid_radix_string, an_input_string_port_string,
+ an_input_file_port_string, an_output_string_port_string, an_output_file_port_string, a_random_state_object_string;
+
#if (!HAVE_COMPLEX_NUMBERS)
-static s7_pointer NO_COMPLEX_NUMBERS;
+static s7_pointer no_complex_numbers_string;
#endif
@@ -2562,9 +2648,9 @@ enum {OP_NO_OP,
OP_AND, OP_AND1, OP_OR, OP_OR1,
OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION,
OP_CASE, OP_CASE1, OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE,
- OP_READ_QUASIQUOTE, OP_READ_QUASIQUOTE_VECTOR, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES,
+ OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES,
OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_DONE,
- OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_STRING, OP_EVAL_DONE,
+ OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE,
OP_CATCH, OP_DYNAMIC_WIND, OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1,
OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT,
OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT, OP_UNWIND_INPUT, OP_UNWIND_OUTPUT,
@@ -2625,6 +2711,8 @@ enum {OP_NO_OP,
OP_SAFE_C_ZZZ_1, OP_SAFE_C_ZZZ_2, OP_SAFE_C_ZZZ_3,
OP_SAFE_C_opSq_P_1, OP_SAFE_C_opSq_P_MV, OP_C_P_1, OP_C_P_2, OP_C_SP_1, OP_C_SP_2,
OP_CLOSURE_P_1, OP_CLOSURE_P_2, OP_SAFE_CLOSURE_P_1,
+
+ OP_SET_WITH_LET_1, OP_SET_WITH_LET_2,
OP_MAX_DEFINED_1};
#define OP_MAX_DEFINED (OP_MAX_DEFINED_1 + 1)
@@ -2664,6 +2752,7 @@ enum {OP_SAFE_C_C, HOP_SAFE_C_C, OP_SAFE_C_S, HOP_SAFE_C_S,
OP_SAFE_C_S_op_opSSq_opSSqq, HOP_SAFE_C_S_op_opSSq_opSSqq,
OP_SAFE_C_op_opSq_q, HOP_SAFE_C_op_opSq_q, OP_SAFE_C_C_op_S_opCqq, HOP_SAFE_C_C_op_S_opCqq,
OP_SAFE_C_op_S_opSq_q, HOP_SAFE_C_op_S_opSq_q,
+ OP_SAFE_C_opSq_Q, HOP_SAFE_C_opSq_Q, OP_SAFE_C_opSq_Q_S, HOP_SAFE_C_opSq_Q_S,
OP_SAFE_C_Z, HOP_SAFE_C_Z, OP_SAFE_C_ZZ, HOP_SAFE_C_ZZ, OP_SAFE_C_SZ, HOP_SAFE_C_SZ, OP_SAFE_C_ZS, HOP_SAFE_C_ZS,
OP_SAFE_C_CZ, HOP_SAFE_C_CZ, OP_SAFE_C_ZC, HOP_SAFE_C_ZC,
@@ -2718,7 +2807,7 @@ enum {OP_SAFE_C_C, HOP_SAFE_C_C, OP_SAFE_C_S, HOP_SAFE_C_S,
OP_UNKNOWN_G, HOP_UNKNOWN_G, OP_UNKNOWN_GG, HOP_UNKNOWN_GG, OP_UNKNOWN_A, HOP_UNKNOWN_A, OP_UNKNOWN_AA, HOP_UNKNOWN_AA,
OP_SAFE_C_PP, HOP_SAFE_C_PP,
- OP_SAFE_C_opSq_P, HOP_SAFE_C_opSq_P,
+ OP_SAFE_C_opSq_P, HOP_SAFE_C_opSq_P,
OP_SAFE_C_SP, HOP_SAFE_C_SP, OP_SAFE_C_CP, HOP_SAFE_C_CP, OP_SAFE_C_QP, HOP_SAFE_C_QP, OP_SAFE_C_AP, HOP_SAFE_C_AP,
OP_SAFE_C_PS, HOP_SAFE_C_PS, OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_PQ, HOP_SAFE_C_PQ,
OP_SAFE_C_SSP, HOP_SAFE_C_SSP,
@@ -2739,9 +2828,9 @@ static const char *op_names[OP_MAX_DEFINED_1] = {
"and", "and1", "or", "or1",
"define_macro", "define_macro_star", "define_expansion",
"case", "case1", "read_list", "read_next", "read_dot", "read_quote",
- "read_quasiquote", "read_quasiquote_vector", "read_unquote", "read_apply_values",
+ "read_quasiquote", "read_unquote", "read_apply_values",
"read_vector", "read_byte_vector", "read_done",
- "load_return_if_eof", "load_close_and_pop_if_eof", "eval_string", "eval_done",
+ "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done",
"catch", "dynamic_wind", "define_constant", "define_constant1",
"do", "do_end", "do_end1", "do_step", "do_step2", "do_init",
"define_star", "lambda_star", "lambda_star_default", "error_quit", "unwind_input", "unwind_output",
@@ -2803,6 +2892,8 @@ static const char *op_names[OP_MAX_DEFINED_1] = {
"safe_c_opsq_p_1", "safe_c_opsq_p_mv", "c_p_1", "c_p_2", "c_sp_1", "c_sp_2",
"closure_p_1", "closure_p_2", "safe_closure_p_1",
+
+ "set-with-let-1", "set-with-let-2",
};
static const char* opt_names[OPT_MAX_DEFINED] =
@@ -2839,6 +2930,7 @@ static const char* opt_names[OPT_MAX_DEFINED] =
"safe_c_s_op_opssq_opssqq", "h_safe_c_s_op_opssq_opssqq",
"safe_c_op_opsq_q", "h_safe_c_op_opsq_q", "safe_c_c_op_s_opcqq", "h_safe_c_c_op_s_opcqq",
"safe_c_op_s_opsq_q", "h_safe_c_op_s_opsq_q",
+ "safe_c_opsq_q", "h_safe_c_opsq_q", "safe_c_opsq_q_s", "h_safe_c_opsq_q_s",
"safe_c_z", "h_safe_c_z", "safe_c_zz", "h_safe_c_zz", "safe_c_sz", "h_safe_c_sz", "safe_c_zs", "h_safe_c_zs",
"safe_c_cz", "h_safe_c_cz", "safe_c_zc", "h_safe_c_zc",
@@ -2891,7 +2983,7 @@ static const char* opt_names[OPT_MAX_DEFINED] =
"unknown_g", "h_unknown_g", "unknown_gg", "h_unknown_gg", "unknown_a", "h_unknown_a", "unknown_aa", "h_unknown_aa",
"safe_c_pp", "h_safe_c_pp",
- "safe_c_opsq_p", "h_safe_c_opsq_p",
+ "safe_c_opsq_p", "h_safe_c_opsq_p",
"safe_c_sp", "h_safe_c_sp", "safe_c_cp", "h_safe_c_cp", "safe_c_qp", "h_safe_c_qp", "safe_c_ap", "h_safe_c_ap",
"safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", "safe_c_pq", "h_safe_c_pq",
"safe_c_ssp", "h_safe_c_ssp",
@@ -2913,13 +3005,6 @@ static bool is_h_optimized(s7_pointer p)
#define is_h_safe_c_s(P) ((is_optimized(P)) && (optimize_op(P) == HOP_SAFE_C_S))
#define is_safe_c_s(P) ((is_optimized(P)) && (op_no_hop(P) == OP_SAFE_C_S))
-
-#define WITH_COUNTS 0
-#if WITH_COUNTS
- #include "profile.h"
-#endif
-
-
static int position_of(s7_pointer p, s7_pointer args)
{
int i;
@@ -2931,7 +3016,7 @@ s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
if (has_methods(obj))
return(find_method(sc, find_let(sc, obj), method));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
@@ -2941,7 +3026,7 @@ s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
#define check_method(Sc, Obj, Method, Args) \
{ \
s7_pointer func; \
- if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->UNDEFINED)) \
+ if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
return(s7_apply_function(Sc, func, Args)); \
}
@@ -2950,14 +3035,14 @@ s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{ \
s7_pointer func; \
func = find_method(Sc, find_let(Sc, Obj), Method1); \
- if ((func == Sc->UNDEFINED) && (Method1 != Method2) && (Method2)) func = find_method(Sc, find_let(Sc, Obj), Method2); \
- if (func != Sc->UNDEFINED) return(s7_apply_function(Sc, func, Args)); \
+ if ((func == Sc->undefined) && (Method1 != Method2) && (Method2)) func = find_method(Sc, find_let(Sc, Obj), Method2); \
+ if (func != Sc->undefined) return(s7_apply_function(Sc, func, Args)); \
}
static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
- check_method(sc, obj, sc->VALUES, args);
- return(sc->GC_NIL);
+ check_method(sc, obj, sc->values_symbol, args);
+ return(sc->gc_nil);
}
/* unfortunately, in the simplest cases, where a function (like number?) accepts any argument,
@@ -2982,7 +3067,7 @@ static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
s7_pointer p, func; \
p = find_symbol_checked(Sc, cadar(Args)); \
if (Checker(p)) return(Sc->F); \
- if ((has_methods(p)) && ((func = find_method(Sc, find_let(Sc, p), Method)) != Sc->UNDEFINED) && \
+ if ((has_methods(p)) && ((func = find_method(Sc, find_let(Sc, p), Method)) != Sc->undefined) && \
(s7_apply_function(Sc, func, list_1(Sc, p)) != Sc->F)) \
return(Sc->F); \
return(Sc->T); \
@@ -2991,7 +3076,7 @@ static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
#define method_or_bust(Sc, Obj, Method, Args, Type, Num) \
{ \
s7_pointer func; \
- if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->UNDEFINED)) \
+ if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
return(s7_apply_function(Sc, func, Args)); \
if (Num == 0) return(simple_wrong_type_argument(Sc, Method, Obj, Type)); \
return(wrong_type_argument(Sc, Method, Num, Obj, Type)); \
@@ -3000,7 +3085,7 @@ static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
#define method_or_bust_with_type(Sc, Obj, Method, Args, Type, Num) \
{ \
s7_pointer func; \
- if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->UNDEFINED)) \
+ if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
return(s7_apply_function(Sc, func, Args)); \
if (Num == 0) return(simple_wrong_type_argument_with_type(Sc, Method, Obj, Type)); \
return(wrong_type_argument_with_type(Sc, Method, Num, Obj, Type)); \
@@ -3011,19 +3096,19 @@ static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
do {static s7_pointer _Err_ = NULL; if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
return(s7_error(Sc, ErrType, set_elist_2(Sc, _Err_, Obj)));} while (0)
-#define eval_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->SYNTAX_ERROR, ErrMsg, Obj)
-#define eval_type_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->WRONG_TYPE_ARG, ErrMsg, Obj)
-#define eval_range_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->OUT_OF_RANGE, ErrMsg, Obj)
+#define eval_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->syntax_error_symbol, ErrMsg, Obj)
+#define eval_type_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->wrong_type_arg_symbol, ErrMsg, Obj)
+#define eval_range_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->out_of_range_symbol, ErrMsg, Obj)
#define eval_error_no_return(Sc, ErrType, ErrMsg, Obj) \
do {static s7_pointer _Err_ = NULL; \
if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
- s7_error(Sc, ErrType, set_elist_2(Sc, _Err_, Obj));} while (0)
+ s7_error(Sc, ErrType, set_elist_2(Sc, _Err_, Obj));} while (0)
#define eval_error_with_caller(Sc, ErrMsg, Caller, Obj) \
do {static s7_pointer _Err_ = NULL; \
if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
- return(s7_error(Sc, Sc->SYNTAX_ERROR, set_elist_3(Sc, _Err_, Caller, Obj)));} while (0)
+ return(s7_error(Sc, Sc->syntax_error_symbol, set_elist_3(Sc, _Err_, Caller, Obj)));} while (0)
static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1)
{
@@ -3110,9 +3195,6 @@ static s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_po
return(set_wlist_3(sc, sc->plist_3, x1, x2, x3));
}
-/* an experiment */
-s7_pointer s7_set_plist_1(s7_scheme *sc, s7_pointer x1) {return(set_plist_1(sc, x1));}
-
/* -------------------------------- constants -------------------------------- */
@@ -3130,7 +3212,7 @@ s7_pointer s7_t(s7_scheme *sc)
s7_pointer s7_nil(s7_scheme *sc)
{
- return(sc->NIL);
+ return(sc->nil);
}
@@ -3142,13 +3224,13 @@ bool s7_is_null(s7_scheme *sc, s7_pointer p)
s7_pointer s7_undefined(s7_scheme *sc)
{
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
s7_pointer s7_unspecified(s7_scheme *sc)
{
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
@@ -3160,7 +3242,7 @@ bool s7_is_unspecified(s7_scheme *sc, s7_pointer val)
s7_pointer s7_eof_object(s7_scheme *sc) /* returns #<eof> -- not equivalent to "eof-object?" */
{
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
}
@@ -3194,7 +3276,7 @@ static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args)
{
#define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f"
#define Q_is_boolean pl_bt
- check_boolean_method(sc, s7_is_boolean, sc->IS_BOOLEAN, args);
+ check_boolean_method(sc, s7_is_boolean, sc->is_boolean_symbol, args);
}
@@ -3212,7 +3294,7 @@ static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args)
{
#define H_is_constant "(constant? obj) returns #t if obj is a constant (unsettable): (constant? pi) -> #t"
#define Q_is_constant pl_bt
- check_boolean_method(sc, s7_is_constant, sc->IS_CONSTANT, args);
+ check_boolean_method(sc, s7_is_constant, sc->is_constant_symbol, args);
}
@@ -3222,7 +3304,7 @@ static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args)
* (an int array growable, with a current top and size or whatever)
*/
-#define is_gc_nil(p) ((p) == sc->GC_NIL)
+#define is_gc_nil(p) ((p) == sc->gc_nil)
unsigned int s7_gc_protect(s7_scheme *sc, s7_pointer x)
{
@@ -3253,7 +3335,7 @@ unsigned int s7_gc_protect(s7_scheme *sc, s7_pointer x)
vector_elements(sc->protected_objects) = (s7_pointer *)realloc(vector_elements(sc->protected_objects), new_size * sizeof(s7_pointer));
vector_length(sc->protected_objects) = new_size;
for (i = size; i < new_size; i++)
- vector_element(sc->protected_objects, i) = sc->GC_NIL;
+ vector_element(sc->protected_objects, i) = sc->gc_nil;
sc->protected_objects_size = new_size;
sc->protected_objects_loc = size;
@@ -3268,7 +3350,7 @@ void s7_gc_unprotect(s7_scheme *sc, s7_pointer x)
for (i = 0; i < sc->protected_objects_size; i++)
if (vector_element(sc->protected_objects, i) == x)
{
- vector_element(sc->protected_objects, i) = sc->GC_NIL;
+ vector_element(sc->protected_objects, i) = sc->gc_nil;
sc->protected_objects_loc = i;
return;
}
@@ -3279,7 +3361,7 @@ void s7_gc_unprotect_at(s7_scheme *sc, unsigned int loc)
{
if (loc < sc->protected_objects_size)
{
- vector_element(sc->protected_objects, loc) = sc->GC_NIL;
+ vector_element(sc->protected_objects, loc) = sc->gc_nil;
sc->protected_objects_loc = loc;
}
}
@@ -3289,12 +3371,12 @@ s7_pointer s7_gc_protected_at(s7_scheme *sc, unsigned int loc)
{
s7_pointer obj;
- obj = sc->UNSPECIFIED;
+ obj = sc->unspecified;
if (loc < sc->protected_objects_size)
obj = vector_element(sc->protected_objects, loc);
- if (obj == sc->GC_NIL)
- return(sc->UNSPECIFIED);
+ if (obj == sc->gc_nil)
+ return(sc->unspecified);
return(obj);
}
@@ -4194,7 +4276,7 @@ static int gc(s7_scheme *sc)
check_types = true;
#endif
S7_MARK(sc->code);
- S7_MARK(sc->cur_code);
+ mark_current_code(sc);
mark_stack_1(sc->stack, s7_stack_top(sc));
S7_MARK(sc->v);
S7_MARK(sc->w);
@@ -4225,17 +4307,17 @@ static int gc(s7_scheme *sc)
mark_pair(sc->temp_cell_1);
mark_pair(sc->temp_cell_2);
- S7_MARK(car(sc->T1_1));
- S7_MARK(car(sc->T2_1));
- S7_MARK(car(sc->T2_2));
- S7_MARK(car(sc->T3_1));
- S7_MARK(car(sc->T3_2));
- S7_MARK(car(sc->T3_3));
-
- S7_MARK(car(sc->A4_1));
- S7_MARK(car(sc->A4_2));
- S7_MARK(car(sc->A4_3));
- S7_MARK(car(sc->A4_4));
+ S7_MARK(car(sc->t1_1));
+ S7_MARK(car(sc->t2_1));
+ S7_MARK(car(sc->t2_2));
+ S7_MARK(car(sc->t3_1));
+ S7_MARK(car(sc->t3_2));
+ S7_MARK(car(sc->t3_3));
+
+ S7_MARK(car(sc->a4_1));
+ S7_MARK(car(sc->a4_2));
+ S7_MARK(car(sc->a4_3));
+ S7_MARK(car(sc->a4_4));
S7_MARK(car(sc->plist_1));
S7_MARK(car(sc->plist_2));
@@ -4537,19 +4619,19 @@ static s7_pointer g_gc(s7_scheme *sc, s7_pointer args)
{
#define H_gc "(gc (on #t)) runs the garbage collector. If 'on' is supplied, it turns the GC on or off. \
Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!"
- #define Q_gc s7_make_signature(sc, 2, sc->T, sc->IS_BOOLEAN)
+ #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol)
if (is_not_null(args))
{
if (!s7_is_boolean(car(args)))
- method_or_bust(sc, car(args), sc->GC, args, T_BOOLEAN, 0);
+ method_or_bust(sc, car(args), sc->gc_symbol, args, T_BOOLEAN, 0);
sc->gc_off = (car(args) == sc->F);
if (sc->gc_off)
return(sc->F);
}
gc(sc);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
@@ -4640,7 +4722,7 @@ static void s7_remove_from_heap(s7_scheme *sc, s7_pointer x)
heap_location(p) = loc;
#if 0
/* this code fixes the problem above, but at some cost (gc + mark_pair up by about 2% in the worst case (snd-test.scm)) */
- if ((car(x) == sc->QUOTE) &&
+ if ((car(x) == sc->quote_symbol) &&
(is_pair(cadr(x))))
{
add_permanent_object(sc, cdr(x));
@@ -4682,12 +4764,13 @@ static void s7_remove_from_heap(s7_scheme *sc, s7_pointer x)
* continues to be valid. symbol_hmap is abs(heap_location), and the possible overlap with other not-in-heap
* ints is not problematic (they'll just hash to the same location).
*/
- for (i = 0; i < sc->gensyms_loc; i++)
+ for (i = 0; i < sc->gensyms_loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */
if (sc->gensyms[i] == x)
{
unsigned int j;
- for (j = i + 1; i < sc->gensyms_loc; i++, j++)
+ for (j = i + 1; i < sc->gensyms_loc - 1; i++, j++)
sc->gensyms[i] = sc->gensyms[j];
+ sc->gensyms[i] = NULL;
sc->gensyms_loc--;
if (sc->gensyms_loc == 0) mark_function[T_SYMBOL] = mark_noop;
break;
@@ -4762,7 +4845,7 @@ static void initialize_op_stack(s7_scheme *sc)
sc->op_stack_now = sc->op_stack;
sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
for (i = 0; i < OP_STACK_INITIAL_SIZE; i++)
- sc->op_stack[i] = sc->NIL;
+ sc->op_stack[i] = sc->nil;
}
@@ -4773,7 +4856,7 @@ static void resize_op_stack(s7_scheme *sc)
new_size = sc->op_stack_size * 2;
sc->op_stack = (s7_pointer *)realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer));
for (i = sc->op_stack_size; i < new_size; i++)
- sc->op_stack[i] = sc->NIL;
+ sc->op_stack[i] = sc->nil;
sc->op_stack_size = new_size;
sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc);
sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
@@ -4902,7 +4985,8 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c
static void stack_reset(s7_scheme *sc)
{
sc->stack_end = sc->stack_start;
- push_stack(sc, OP_BARRIER, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_DONE, sc->nil, sc->nil);
+ push_stack(sc, OP_BARRIER, sc->nil, sc->nil);
}
@@ -4925,7 +5009,7 @@ static void resize_stack(s7_scheme *sc)
s7_error(sc, s7_make_symbol(sc, "stack-too-big"), set_elist_1(sc, make_string_wrapper(sc, "no room to expand stack?")));
for (i = sc->stack_size; i < new_size; i++)
- vector_element(sc->stack, i) = sc->NIL;
+ vector_element(sc->stack, i) = sc->nil;
vector_length(sc->stack) = new_size;
sc->stack_size = new_size;
@@ -4979,7 +5063,7 @@ static s7_pointer new_symbol(s7_scheme *sc, const char *name, unsigned int len,
unsigned char *base, *val;
if (sc->symbol_table_is_locked)
- return(s7_error(sc, sc->ERROR, sc->NIL));
+ return(s7_error(sc, sc->error_symbol, sc->nil));
base = (unsigned char *)malloc(sizeof(s7_cell) * 3 + len + 1);
x = (s7_pointer)base;
@@ -4999,9 +5083,9 @@ static s7_pointer new_symbol(s7_scheme *sc, const char *name, unsigned int len,
unheap(x);
typeflag(x) = T_SYMBOL;
set_symbol_name_cell(x, str);
- global_slot(x) = sc->UNDEFINED; /* was sc->NIL; */
- initial_slot(x) = sc->UNDEFINED;
- symbol_set_local(x, 0LL, sc->NIL);
+ global_slot(x) = sc->undefined; /* was sc->nil; */
+ initial_slot(x) = sc->undefined;
+ symbol_set_local(x, 0LL, sc->nil);
symbol_tag(x) = 0;
if (symbol_name_length(x) > 1) /* not 0, otherwise : is a keyword */
@@ -5010,7 +5094,7 @@ static s7_pointer new_symbol(s7_scheme *sc, const char *name, unsigned int len,
{
typeflag(x) |= (T_IMMUTABLE | T_KEYWORD);
keyword_symbol(x) = make_symbol_with_length(sc, (char *)(name + 1), len - 1);
- global_slot(x) = s7_make_slot(sc, sc->NIL, x, x);
+ global_slot(x) = s7_make_slot(sc, sc->nil, x, x);
}
else
{
@@ -5027,7 +5111,7 @@ static s7_pointer new_symbol(s7_scheme *sc, const char *name, unsigned int len,
kstr[klen] = 0;
typeflag(x) |= (T_IMMUTABLE | T_KEYWORD);
keyword_symbol(x) = make_symbol_with_length(sc, kstr, klen);
- global_slot(x) = s7_make_slot(sc, sc->NIL, x, x);
+ global_slot(x) = s7_make_slot(sc, sc->nil, x, x);
free(kstr);
}
}
@@ -5092,7 +5176,7 @@ static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, uns
if ((hash == pair_raw_hash(x)) &&
(strings_are_equal(name, pair_raw_name(x))))
return(car(x));
- return(sc->NIL);
+ return(sc->nil);
}
@@ -5118,7 +5202,7 @@ s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name)
static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_table "(symbol-table) returns a vector containing the current symbol-table symbols"
- #define Q_symbol_table s7_make_signature(sc, 1, sc->IS_VECTOR)
+ #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol)
s7_pointer lst, x;
s7_pointer *els;
@@ -5145,7 +5229,7 @@ static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer args)
els[j++] = car(x);
lst = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(lst);
}
@@ -5229,7 +5313,7 @@ s7_pointer s7_gensym(s7_scheme *sc, const char *prefix)
len = safe_strlen(prefix) + 32;
tmpbuf_malloc(name, len);
/* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */
- len = snprintf(name, len, "{%s}-%d", prefix, sc->gensym_counter++);
+ len = snprintf(name, len, "{%s}-%u", prefix, sc->gensym_counter++);
hash = raw_string_hash((const unsigned char *)name, len);
location = hash % SYMBOL_TABLE_SIZE;
x = new_symbol(sc, name, len, hash, location); /* not T_GENSYM -- might be called from outside */
@@ -5245,7 +5329,7 @@ static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args)
#define H_is_gensym "(gensym? sym) returns #t if sym is a gensym"
#define Q_is_gensym pl_bt
- check_boolean_method(sc, s7_is_gensym, sc->IS_GENSYM, args);
+ check_boolean_method(sc, s7_is_gensym, sc->is_gensym_symbol, args);
}
@@ -5267,7 +5351,7 @@ static char *pos_int_to_str(s7_int num, unsigned int *len, char endc)
static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args)
{
#define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol"
- #define Q_gensym s7_make_signature(sc, 2, sc->IS_GENSYM, sc->IS_STRING)
+ #define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol)
const char *prefix;
char *name, *p;
@@ -5281,7 +5365,7 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args)
s7_pointer name;
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->GENSYM, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->gensym_symbol, args, T_STRING, 0);
prefix = string_value(name);
}
else prefix = "gensym";
@@ -5315,9 +5399,9 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args)
/* allocate the symbol in the heap so GC'd when inaccessible */
new_cell(sc, x, T_SYMBOL | T_GENSYM);
set_symbol_name_cell(x, str);
- global_slot(x) = sc->UNDEFINED;
- initial_slot(x) = sc->UNDEFINED;
- symbol_set_local(x, 0LL, sc->NIL);
+ global_slot(x) = sc->undefined;
+ initial_slot(x) = sc->undefined;
+ symbol_set_local(x, 0LL, sc->nil);
/* place new symbol in symbol-table, but using calloc so we can easily free it (remove it from the table) in GC sweep */
stc = (s7_cell *)malloc(sizeof(s7_cell)); /* was calloc? */
@@ -5361,7 +5445,7 @@ static s7_pointer g_is_symbol(s7_scheme *sc, s7_pointer args)
#define H_is_symbol "(symbol? obj) returns #t if obj is a symbol"
#define Q_is_symbol pl_bt
- check_boolean_method(sc, is_symbol, sc->IS_SYMBOL, args);
+ check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args);
}
@@ -5374,12 +5458,12 @@ const char *s7_symbol_name(s7_pointer p)
static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string"
- #define Q_symbol_to_string s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_SYMBOL)
+ #define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol)
s7_pointer sym;
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_TO_STRING, args, T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL, 0);
/* s7_make_string uses strlen which stops at an embedded null */
return(s7_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */
}
@@ -5391,7 +5475,7 @@ static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args)
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_TO_STRING, args, T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL, 0);
return(symbol_name_cell(sym));
}
@@ -5411,16 +5495,16 @@ static s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer
static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args)
{
#define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol"
- #define Q_string_to_symbol s7_make_signature(sc, 2, sc->IS_SYMBOL, sc->IS_STRING)
- return(g_string_to_symbol_1(sc, car(args), sc->STRING_TO_SYMBOL));
+ #define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
+ return(g_string_to_symbol_1(sc, car(args), sc->string_to_symbol_symbol));
}
static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args)
{
#define H_symbol "(symbol str) returns the string str converted to a symbol"
- #define Q_symbol s7_make_signature(sc, 2, sc->IS_SYMBOL, sc->IS_STRING)
- return(g_string_to_symbol_1(sc, car(args), sc->SYMBOL));
+ #define Q_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
+ return(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol));
}
@@ -5441,7 +5525,7 @@ static s7_pointer add_sym_to_list(s7_scheme *sc, s7_pointer sym)
s7_pointer _x_; \
new_cell(Sc, _x_, T_LET); \
let_id(_x_) = ++sc->let_number; \
- let_set_slots(_x_, Sc->NIL); \
+ let_set_slots(_x_, Sc->nil); \
set_outlet(_x_, Old_Env); \
New_Env = _x_; \
} while (0)
@@ -5449,11 +5533,11 @@ static s7_pointer add_sym_to_list(s7_scheme *sc, s7_pointer sym)
static s7_pointer new_frame_in_env(s7_scheme *sc, s7_pointer old_env)
{
- /* return(cons(sc, sc->NIL, old_env)); */
+ /* return(cons(sc, sc->nil, old_env)); */
s7_pointer x;
new_cell(sc, x, T_LET);
let_id(x) = ++sc->let_number;
- let_set_slots(x, sc->NIL);
+ let_set_slots(x, sc->nil);
set_outlet(x, old_env);
return(x);
}
@@ -5464,7 +5548,7 @@ static s7_pointer make_simple_let(s7_scheme *sc)
s7_pointer frame;
new_cell(sc, frame, T_LET);
let_id(frame) = sc->let_number + 1;
- let_set_slots(frame, sc->NIL);
+ let_set_slots(frame, sc->nil);
set_outlet(frame, sc->envir);
return(frame);
}
@@ -5511,7 +5595,7 @@ static s7_pointer make_simple_let(s7_scheme *sc)
slot_set_symbol(_slot_, _sym_); \
slot_set_value(_slot_, _val_); \
symbol_set_local(_sym_, sc->let_number, _slot_); \
- next_slot(_slot_) = sc->NIL; \
+ next_slot(_slot_) = sc->nil; \
let_set_slots(_x_, _slot_); \
} while (0)
@@ -5534,7 +5618,7 @@ static s7_pointer make_simple_let(s7_scheme *sc)
slot_set_symbol(_x_, _sym2_); \
slot_set_value(_x_, _val2_); \
symbol_set_local(_sym2_, sc->let_number, _x_); \
- next_slot(_x_) = sc->NIL; \
+ next_slot(_x_) = sc->nil; \
next_slot(_slot_) = _x_; \
} while (0)
@@ -5542,7 +5626,7 @@ static s7_pointer make_simple_let(s7_scheme *sc)
static s7_pointer old_frame_in_env(s7_scheme *sc, s7_pointer frame, s7_pointer next_frame)
{
set_type(frame, T_LET);
- let_set_slots(frame, sc->NIL);
+ let_set_slots(frame, sc->nil);
set_outlet(frame, next_frame);
let_id(frame) = ++sc->let_number;
return(frame);
@@ -5640,7 +5724,7 @@ static s7_pointer find_let(s7_scheme *sc, s7_pointer obj)
case T_C_OBJECT:
return(c_object_let(obj));
}
- return(sc->NIL);
+ return(sc->nil);
}
@@ -5660,7 +5744,7 @@ static s7_pointer free_let(s7_scheme *sc, s7_pointer e)
free_cell(sc, p);
#endif
free_cell(sc, e);
- return(sc->NIL);
+ return(sc->nil);
}
@@ -5668,7 +5752,7 @@ static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
s7_pointer x;
if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */
- return(sc->UNDEFINED);
+ return(sc->undefined);
/* I think the symbol_id is in sync with let_id, so the standard search should work */
if (let_id(env) == symbol_id(symbol))
@@ -5686,7 +5770,7 @@ static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
if (slot_symbol(y) == symbol)
return(slot_value(y));
}
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
@@ -5702,8 +5786,8 @@ static int let_length(s7_scheme *sc, s7_pointer e)
if (has_methods(e))
{
s7_pointer length_func;
- length_func = find_method(sc, e, sc->LENGTH);
- if (length_func != sc->UNDEFINED)
+ length_func = find_method(sc, e, sc->length_symbol);
+ if (length_func != sc->undefined)
{
p = s7_apply_function(sc, length_func, list_1(sc, e));
if (s7_is_integer(p))
@@ -5766,13 +5850,13 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_poi
vector_length(ge) *= 2;
vector_elements(ge) = (s7_pointer *)realloc(vector_elements(ge), vector_length(ge) * sizeof(s7_pointer));
for (i = sc->rootlet_entries; i < vector_length(ge); i++)
- vector_element(ge, i) = sc->NIL;
+ vector_element(ge, i) = sc->nil;
}
global_slot(symbol) = slot;
if (symbol_id(symbol) == 0) /* never defined locally? */
{
- if (initial_slot(symbol) == sc->UNDEFINED)
+ if (initial_slot(symbol) == sc->undefined)
initial_slot(symbol) = permanent_slot(symbol, value);
local_slot(symbol) = slot;
set_global(symbol);
@@ -5812,7 +5896,7 @@ static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args)
#define H_is_let "(let? obj) returns #t if obj is a let (an environment)."
#define Q_is_let pl_bt
- check_boolean_method(sc, is_let, sc->IS_LET, args);
+ check_boolean_method(sc, is_let, sc->is_let_symbol, args);
}
@@ -5833,7 +5917,7 @@ static void save_unlet(s7_scheme *sc)
vector_getter(sc->unlet) = default_vector_getter;
vector_setter(sc->unlet) = default_vector_setter;
inits = vector_elements(sc->unlet);
- s7_vector_fill(sc, sc->unlet, sc->NIL);
+ s7_vector_fill(sc, sc->unlet, sc->nil);
unheap(sc->unlet);
for (i = 0; i < vector_length(sc->symbol_table); i++)
@@ -5861,7 +5945,7 @@ static s7_pointer g_unlet(s7_scheme *sc, s7_pointer args)
{
/* add sc->unlet bindings to the current environment */
#define H_unlet "(unlet) establishes the original bindings of all the predefined functions"
- #define Q_unlet s7_make_signature(sc, 1, sc->IS_LET)
+ #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol)
/* slightly confusing:
* :((unlet) 'abs)
@@ -5896,7 +5980,7 @@ static s7_pointer g_unlet(s7_scheme *sc, s7_pointer args)
else
{
if ((is_syntax(x)) &&
- (local_slot(sym) != sc->NIL))
+ (local_slot(sym) != sc->nil))
make_slot_1(sc, sc->w, sym, x);
}
}
@@ -5906,7 +5990,7 @@ static s7_pointer g_unlet(s7_scheme *sc, s7_pointer args)
*/
x = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(x);
}
@@ -5923,7 +6007,7 @@ static s7_pointer g_is_openlet(s7_scheme *sc, s7_pointer args)
#define Q_is_openlet pl_bt
/* if car(args) is not a let (or possibly have one), should this raise an error? */
- check_method(sc, car(args), sc->IS_OPENLET, args);
+ check_method(sc, car(args), sc->is_openlet_symbol, args);
return(make_boolean(sc, has_methods(car(args))));
}
@@ -5942,15 +6026,15 @@ static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args)
s7_pointer e;
e = car(args);
- check_method(sc, e, sc->OPENLET, args);
+ check_method(sc, e, sc->openlet_symbol, args);
if (((is_let(e)) && (e != sc->rootlet)) ||
(has_closure_let(e)) ||
- ((is_c_object(e)) && (c_object_let(e) != sc->NIL)))
+ ((is_c_object(e)) && (c_object_let(e) != sc->nil)))
{
set_has_methods(e);
return(e);
}
- return(simple_wrong_type_argument_with_type(sc, sc->OPENLET, e, A_LET));
+ return(simple_wrong_type_argument_with_type(sc, sc->openlet_symbol, e, a_let_string));
}
@@ -5958,15 +6042,15 @@ static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args)
static s7_pointer c_coverlet(s7_scheme *sc, s7_pointer e)
{
sc->temp3 = e;
- check_method(sc, e, sc->COVERLET, list_1(sc, e));
+ check_method(sc, e, sc->coverlet_symbol, list_1(sc, e));
if (((is_let(e)) && (e != sc->rootlet)) ||
(has_closure_let(e)) ||
- ((is_c_object(e)) && (c_object_let(e) != sc->NIL)))
+ ((is_c_object(e)) && (c_object_let(e) != sc->nil)))
{
clear_has_methods(e);
return(e);
}
- return(simple_wrong_type_argument_with_type(sc, sc->COVERLET, e, A_LET));
+ return(simple_wrong_type_argument_with_type(sc, sc->coverlet_symbol, e, a_let_string));
}
static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args)
@@ -6009,7 +6093,7 @@ static s7_pointer check_c_obj_env(s7_scheme *sc, s7_pointer old_e, s7_pointer ca
if (is_c_object(old_e))
old_e = c_object_let(old_e);
if (!is_let(old_e))
- return(simple_wrong_type_argument_with_type(sc, caller, old_e, A_LET));
+ return(simple_wrong_type_argument_with_type(sc, caller, old_e, a_let_string));
return(old_e);
}
@@ -6017,7 +6101,7 @@ static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args)
{
#define H_varlet "(varlet env ...) adds its arguments (an environment, a cons: symbol . value, or a pair of arguments, the symbol and its value) \
to the environment env, and returns the environment."
- #define Q_varlet s7_make_circular_signature(sc, 2, 3, sc->IS_LET, sc->IS_LET, sc->T)
+ #define Q_varlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->T)
s7_pointer x, e, sym, val, p;
@@ -6026,9 +6110,9 @@ to the environment env, and returns the environment."
e = sc->rootlet;
else
{
- check_method(sc, e, sc->VARLET, args);
+ check_method(sc, e, sc->varlet_symbol, args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->VARLET, 1, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 1, e, a_let_string));
}
for (x = cdr(args); is_pair(x); x = cdr(x))
@@ -6041,7 +6125,7 @@ to the environment env, and returns the environment."
sym = keyword_symbol(p);
else sym = p;
if (!is_pair(cdr(x)))
- return(wrong_type_argument_with_type(sc, sc->VARLET, position_of(x, args), p, A_BINDING));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_binding_string));
x = cdr(x);
val = car(x);
break;
@@ -6049,27 +6133,27 @@ to the environment env, and returns the environment."
case T_PAIR:
sym = car(p);
if (!is_symbol(sym))
- return(wrong_type_argument_with_type(sc, sc->VARLET, position_of(x, args), p, A_SYMBOL));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string));
val = cdr(p);
break;
case T_LET:
- append_let(sc, e, check_c_obj_env(sc, p, sc->VARLET));
+ append_let(sc, e, check_c_obj_env(sc, p, sc->varlet_symbol));
continue;
default:
- return(wrong_type_argument_with_type(sc, sc->VARLET, position_of(x, args), p, A_SYMBOL));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string));
}
if (is_immutable_symbol(sym))
- return(wrong_type_argument_with_type(sc, sc->VARLET, position_of(x, args), sym, A_NON_CONSTANT_SYMBOL));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string));
if (e == sc->rootlet)
{
if (is_slot(global_slot(sym)))
{
if (is_syntax(slot_value(global_slot(sym))))
- return(wrong_type_argument_with_type(sc, sc->VARLET, position_of(x, args), p, make_string_wrapper(sc, "a non-syntactic keyword")));
+ return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, make_string_wrapper(sc, "a non-syntactic keyword")));
/* without this check we can end up turning our code into gibberish:
* :(set! quote 1)
* ;can't set! quote
@@ -6096,7 +6180,7 @@ to the environment env, and returns the environment."
static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args)
{
#define H_cutlet "(cutlet e symbol ...) removes symbols from the environment e."
- #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->IS_LET, sc->IS_LET, sc->IS_SYMBOL)
+ #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol)
s7_pointer e, syms;
#define THE_UN_ID ++sc->let_number
@@ -6106,9 +6190,9 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args)
e = sc->rootlet;
else
{
- check_method(sc, e, sc->CUTLET, args);
+ check_method(sc, e, sc->cutlet_symbol, args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->CUTLET, 1, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->cutlet_symbol, 1, e, a_let_string));
}
/* besides removing the slot we have to make sure the symbol_id does not match else
* let-ref and others will use the old slot! What's the un-id? Perhaps the next one?
@@ -6118,14 +6202,19 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args)
{
s7_pointer sym, slot;
sym = car(syms);
+
if (!is_symbol(sym))
- return(wrong_type_argument_with_type(sc, sc->CUTLET, position_of(syms, args), sym, A_SYMBOL));
+ return(wrong_type_argument_with_type(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string));
+
+ if (is_keyword(sym))
+ sym = keyword_symbol(sym);
+
if (e == sc->rootlet)
{
if (is_slot(global_slot(sym)))
{
symbol_set_id(sym, THE_UN_ID);
- slot_set_value(global_slot(sym), sc->UNDEFINED);
+ slot_set_value(global_slot(sym), sc->undefined);
}
}
else
@@ -6165,7 +6254,7 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
s7_pointer new_e;
if (e == sc->rootlet)
- new_e = new_frame_in_env(sc, sc->NIL);
+ new_e = new_frame_in_env(sc, sc->nil);
else new_e = new_frame_in_env(sc, e);
set_all_methods(new_e, e);
@@ -6186,7 +6275,7 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
sym = keyword_symbol(p);
else sym = p;
if (!is_pair(cdr(x)))
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, A_BINDING));
+ return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_binding_string));
x = cdr(x);
val = car(x);
break;
@@ -6194,7 +6283,7 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
case T_PAIR:
sym = car(p);
if (!is_symbol(sym))
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, A_SYMBOL));
+ return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
val = cdr(p);
break;
@@ -6203,30 +6292,30 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
continue;
default:
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, A_SYMBOL));
+ return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
}
if (is_immutable_symbol(sym))
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), sym, A_NON_CONSTANT_SYMBOL));
+ return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), sym, a_non_constant_symbol_string));
/* here we know new_e is a let and is not rootlet */
make_slot_1(sc, new_e, sym, val);
- if (sym == sc->LET_REF_FALLBACK)
+ if (sym == sc->let_ref_fallback_symbol)
set_has_ref_fallback(new_e);
else
{
- if (sym == sc->LET_SET_FALLBACK)
+ if (sym == sc->let_set_fallback_symbol)
set_has_set_fallback(new_e);
}
}
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
}
return(new_e);
}
s7_pointer s7_sublet(s7_scheme *sc, s7_pointer e, s7_pointer bindings)
{
- return(sublet_1(sc, e, bindings, sc->SUBLET));
+ return(sublet_1(sc, e, bindings, sc->sublet_symbol));
}
static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args)
@@ -6234,7 +6323,7 @@ static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args)
#define H_sublet "(sublet env ...) adds its \
arguments (each an environment or a cons: symbol . value) to the environment env, and returns the \
new environment."
- #define Q_sublet s7_make_circular_signature(sc, 2, 3, sc->IS_LET, s7_make_signature(sc, 2, sc->IS_LET, sc->IS_NULL), sc->T)
+ #define Q_sublet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), sc->T)
s7_pointer e;
@@ -6243,11 +6332,11 @@ new environment."
e = sc->rootlet;
else
{
- check_method(sc, e, sc->SUBLET, args);
+ check_method(sc, e, sc->sublet_symbol, args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->SUBLET, 1, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->sublet_symbol, 1, e, a_let_string));
}
- return(sublet_1(sc, e, cdr(args), sc->SUBLET));
+ return(sublet_1(sc, e, cdr(args), sc->sublet_symbol));
}
@@ -6257,9 +6346,9 @@ s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args)
#define H_inlet "(inlet ...) adds its \
arguments, each an environment, a cons: '(symbol . value), or a keyword/value pair, to a new environment, and returns the \
new environment."
- #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->IS_LET, sc->T)
+ #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T)
- return(sublet_1(sc, sc->rootlet, args, sc->INLET));
+ return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol));
}
#define g_inlet s7_inlet
@@ -6271,7 +6360,7 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env)
s7_pointer x;
sc->temp3 = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
if (env == sc->rootlet)
{
@@ -6295,9 +6384,9 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env)
s7_pointer iter, func;
/* need to check make-iterator method before dropping into let->list */
- if ((has_methods(env)) && ((func = find_method(sc, env, sc->MAKE_ITERATOR)) != sc->UNDEFINED))
+ if ((has_methods(env)) && ((func = find_method(sc, env, sc->make_iterator_symbol)) != sc->undefined))
iter = s7_apply_function(sc, func, list_1(sc, env));
- else iter = sc->NIL;
+ else iter = sc->nil;
if (is_null(iter))
{
@@ -6318,7 +6407,7 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env)
}
x = sc->w;
sc->w = sc->temp3;
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
return(x);
}
@@ -6326,17 +6415,17 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env)
static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args)
{
#define H_let_to_list "(let->list env) returns env's bindings as a list of cons's: '(symbol . value)."
- #define Q_let_to_list s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_LET)
+ #define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol)
s7_pointer env;
env = car(args);
- check_method(sc, env, sc->LET_TO_LIST, args);
+ check_method(sc, env, sc->let_to_list_symbol, args);
if (!is_let(env))
{
if (is_c_object(env))
env = c_object_let(env);
if (!is_let(env))
- return(simple_wrong_type_argument_with_type(sc, sc->LET_TO_LIST, env, A_LET));
+ return(simple_wrong_type_argument_with_type(sc, sc->let_to_list_symbol, env, a_let_string));
}
return(s7_let_to_list(sc, env));
}
@@ -6350,12 +6439,15 @@ static s7_pointer let_ref_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
/* (let ((a 1)) ((curlet) 'a))
* ((rootlet) 'abs)
*/
+ if (is_keyword(symbol))
+ symbol = keyword_symbol(symbol);
+
if (env == sc->rootlet)
{
y = global_slot(symbol);
if (is_slot(y))
return(slot_value(y));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
if (let_id(env) == symbol_id(symbol))
@@ -6372,22 +6464,22 @@ static s7_pointer let_ref_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
* get into infinite recursion. So, 'let-ref-fallback...
*/
if (has_ref_fallback(env))
- check_method(sc, env, sc->LET_REF_FALLBACK, sc->w = list_2(sc, env, symbol));
+ check_method(sc, env, sc->let_ref_fallback_symbol, sc->w = list_2(sc, env, symbol));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
if (!is_let(env))
- return(wrong_type_argument_with_type(sc, sc->LET_REF, 1, env, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, env, a_let_string));
if (!is_symbol(symbol))
{
- check_method(sc, env, sc->LET_REF, sc->w = list_2(sc, env, symbol));
+ check_method(sc, env, sc->let_ref_symbol, sc->w = list_2(sc, env, symbol));
if (has_ref_fallback(env))
- check_method(sc, env, sc->LET_REF_FALLBACK, sc->w = list_2(sc, env, symbol));
- return(wrong_type_argument_with_type(sc, sc->LET_REF, 2, symbol, A_SYMBOL));
+ check_method(sc, env, sc->let_ref_fallback_symbol, sc->w = list_2(sc, env, symbol));
+ return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string));
}
return(let_ref_1(sc, env, symbol));
}
@@ -6395,20 +6487,20 @@ s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args)
{
#define H_let_ref "(let-ref env sym) returns the value of the symbol sym in the environment env"
- #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->IS_LET, sc->IS_SYMBOL)
+ #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
s7_pointer e, s;
e = car(args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->LET_REF, 1, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, e, a_let_string));
s = cadr(args);
if (!is_symbol(s))
{
- check_method(sc, e, sc->LET_REF, args);
+ check_method(sc, e, sc->let_ref_symbol, args);
if (has_ref_fallback(e))
- check_method(sc, e, sc->LET_REF_FALLBACK, args);
- return(wrong_type_argument_with_type(sc, sc->LET_REF, 2, s, A_SYMBOL));
+ check_method(sc, e, sc->let_ref_fallback_symbol, args);
+ return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, s, a_symbol_string));
}
return(let_ref_1(sc, e, s));
}
@@ -6419,16 +6511,16 @@ static s7_pointer call_accessor(s7_scheme *sc, s7_pointer slot, s7_pointer old_v
{
s7_pointer func, new_value;
- new_value = sc->ERROR;
+ new_value = sc->error_symbol;
func = slot_accessor(slot);
if (is_procedure_or_macro(func))
{
if (is_c_function(func))
{
- car(sc->T2_1) = slot_symbol(slot);
- car(sc->T2_2) = old_value;
- new_value = c_function_call(func)(sc, sc->T2_1);
+ car(sc->t2_1) = slot_symbol(slot);
+ car(sc->t2_2) = old_value;
+ new_value = c_function_call(func)(sc, sc->t2_1);
}
else
{
@@ -6441,8 +6533,8 @@ static s7_pointer call_accessor(s7_scheme *sc, s7_pointer slot, s7_pointer old_v
}
else return(old_value);
- if (new_value == sc->ERROR)
- return(s7_error(sc, sc->ERROR, set_elist_3(sc, make_string_wrapper(sc, "can't set! ~S to ~S"), slot_symbol(slot), old_value)));
+ if (new_value == sc->error_symbol)
+ return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't set! ~S to ~S"), slot_symbol(slot), old_value)));
return(new_value);
}
@@ -6450,10 +6542,13 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7
{
s7_pointer x, y;
+ if (is_keyword(symbol))
+ symbol = keyword_symbol(symbol);
+
if (env == sc->rootlet)
{
- if (is_immutable_symbol(symbol)) /* (let-set! (rootlet) :key #f) */
- return(wrong_type_argument_with_type(sc, sc->LET_SET, 2, symbol, A_NON_CONSTANT_SYMBOL));
+ if (is_immutable_symbol(symbol)) /* (let-set! (rootlet) :rest #f) */
+ return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string));
y = global_slot(symbol);
if (is_slot(y))
{
@@ -6462,7 +6557,7 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7
else slot_set_value(y, value);
return(slot_value(y));
}
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
for (x = env; is_let(x); x = outlet(x))
@@ -6476,21 +6571,21 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7
}
if (has_set_fallback(env))
- check_method(sc, env, sc->LET_SET_FALLBACK, sc->w = list_3(sc, env, symbol, value));
- return(sc->UNDEFINED);
+ check_method(sc, env, sc->let_set_fallback_symbol, sc->w = list_3(sc, env, symbol, value));
+ return(sc->undefined);
}
s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
if (!is_let(env))
- return(wrong_type_argument_with_type(sc, sc->LET_SET, 1, env, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, env, a_let_string));
if (!is_symbol(symbol))
{
- check_method(sc, env, sc->LET_SET, sc->w = list_3(sc, env, symbol, value));
+ check_method(sc, env, sc->let_set_symbol, sc->w = list_3(sc, env, symbol, value));
if (has_set_fallback(env))
- check_method(sc, env, sc->LET_SET_FALLBACK, sc->w = list_3(sc, env, symbol, value));
- return(wrong_type_argument_with_type(sc, sc->LET_SET, 2, symbol, A_SYMBOL));
+ check_method(sc, env, sc->let_set_fallback_symbol, sc->w = list_3(sc, env, symbol, value));
+ return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 2, symbol, a_symbol_string));
}
return(let_set_1(sc, env, symbol, value));
@@ -6500,7 +6595,7 @@ static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args)
{
/* (let ((a 1)) (set! ((curlet) 'a) 32) a) */
#define H_let_set "(let-set! env sym val) sets the symbol sym's value in the environment env to val"
- #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->IS_LET, sc->IS_SYMBOL, sc->T)
+ #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T)
return(s7_let_set(sc, car(args), cadr(args), caddr(args)));
}
@@ -6509,7 +6604,7 @@ static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args)
static s7_pointer reverse_slots(s7_scheme *sc, s7_pointer list)
{
s7_pointer p = list, result, q;
- result = sc->NIL;
+ result = sc->nil;
while (is_slot(p))
{
@@ -6555,7 +6650,7 @@ static s7_pointer let_copy(s7_scheme *sc, s7_pointer env)
if (is_slot(let_slots(new_e)))
next_slot(y) = z;
else let_set_slots(new_e, z);
- next_slot(z) = sc->NIL; /* in case GC runs during this loop */
+ next_slot(z) = sc->nil; /* in case GC runs during this loop */
y = z;
}
}
@@ -6563,10 +6658,10 @@ static s7_pointer let_copy(s7_scheme *sc, s7_pointer env)
* match the unshadowed slot, not the last in the list:
* (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a)))))
*/
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
return(new_e);
}
- return(sc->NIL);
+ return(sc->nil);
}
@@ -6574,7 +6669,7 @@ static s7_pointer let_copy(s7_scheme *sc, s7_pointer env)
static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer ignore)
{
#define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)."
- #define Q_rootlet s7_make_signature(sc, 1, sc->IS_LET)
+ #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol)
return(sc->rootlet);
}
/* as with the symbol-table, this function can lead to disaster -- user could
@@ -6603,7 +6698,7 @@ s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let)
static s7_pointer g_curlet(s7_scheme *sc, s7_pointer args)
{
#define H_curlet "(curlet) returns the current definitions (symbol bindings)"
- #define Q_curlet s7_make_signature(sc, 1, sc->IS_LET)
+ #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol)
sc->capture_let_counter++;
if (is_let(sc->envir))
@@ -6648,12 +6743,12 @@ s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e)
static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args)
{
#define H_outlet "(outlet env) is the environment that contains env."
- #define Q_outlet s7_make_signature(sc, 2, sc->IS_LET, sc->IS_LET)
+ #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol)
s7_pointer env;
env = car(args);
if (!is_let(env))
- method_or_bust_with_type(sc, env, sc->OUTLET, args, A_LET, 0);
+ method_or_bust_with_type(sc, env, sc->outlet_symbol, args, a_let_string, 0);
if ((env == sc->rootlet) ||
(is_null(outlet(env))))
@@ -6668,13 +6763,13 @@ static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args)
env = car(args);
if (!is_let(env))
- method_or_bust_with_type(sc, env, sc->OUTLET, args, A_LET, 0);
+ return(s7_wrong_type_arg_error(sc, "set! outlet", 1, env, "a let"));
new_outer = cadr(args);
if (!is_let(new_outer))
- return(wrong_type_argument_with_type(sc, sc->OUTLET, 2, new_outer, A_LET));
+ return(s7_wrong_type_arg_error(sc, "set! outlet", 2, new_outer, "a let"));
if (new_outer == sc->rootlet)
- new_outer = sc->NIL;
+ new_outer = sc->nil;
if (env != sc->rootlet)
set_outlet(env, new_outer);
@@ -6706,10 +6801,15 @@ static s7_pointer find_symbol(s7_scheme *sc, s7_pointer symbol)
return(global_slot(symbol));
}
-
+#if WITH_GCC && DEBUGGING
+static s7_pointer find_symbol_unchecked_1(s7_scheme *sc, s7_pointer symbol)
+#else
static s7_pointer find_symbol_unchecked(s7_scheme *sc, s7_pointer symbol) /* find_symbol_checked includes the unbound_variable call */
+#endif
{
s7_pointer x;
+
+ /* fprintf(stderr, "let_id: %lld, %s id: %lld\n", let_id(sc->envir), DISPLAY(symbol), symbol_id(symbol)); */
if (let_id(sc->envir) == symbol_id(symbol))
return(slot_value(local_slot(symbol)));
@@ -6788,7 +6888,7 @@ static s7_pointer find_local_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer
if (slot_symbol(y) == symbol)
return(y);
}
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
@@ -6810,7 +6910,7 @@ s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym)
if (is_slot(x))
return(slot_value(x));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
@@ -6839,24 +6939,24 @@ static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_to_value "(symbol->value sym (env (curlet))) returns the binding of (the value associated with) the \
symbol sym in the given environment: (let ((x 32)) (symbol->value 'x)) -> 32"
- #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->IS_SYMBOL, sc->IS_LET)
+ #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
s7_pointer sym;
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_TO_VALUE, args, T_SYMBOL, 1);
+ method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, T_SYMBOL, 1);
if (is_not_null(cdr(args)))
{
s7_pointer local_env;
local_env = cadr(args);
- if (local_env == sc->UNLET)
- return((is_slot(initial_slot(sym))) ? slot_value(initial_slot(sym)) : sc->UNDEFINED);
+ if (local_env == sc->unlet_symbol)
+ return((is_slot(initial_slot(sym))) ? slot_value(initial_slot(sym)) : sc->undefined);
if (!is_let(local_env))
- method_or_bust_with_type(sc, local_env, sc->SYMBOL_TO_VALUE, args, A_LET, 2);
+ method_or_bust_with_type(sc, local_env, sc->symbol_to_value_symbol, args, a_let_string, 2);
if (local_env == sc->rootlet)
{
@@ -6864,7 +6964,7 @@ symbol sym in the given environment: (let ((x 32)) (symbol->value 'x)) -> 32"
x = global_slot(sym);
if (is_slot(x))
return(slot_value(x));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
return(s7_symbol_local_value(sc, sym, local_env));
}
@@ -6908,14 +7008,14 @@ static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym
return(slot_value(y));
}
}
- return(sc->GC_NIL);
+ return(sc->gc_nil);
}
static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym"
- #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->IS_SYMBOL)
+ #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
s7_pointer sym, val;
long long int top_id;
@@ -6923,7 +7023,7 @@ static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args)
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_TO_DYNAMIC_VALUE, args, T_SYMBOL, 1);
+ method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, T_SYMBOL, 1);
if (is_global(sym))
return(slot_value(global_slot(sym)));
@@ -6940,13 +7040,13 @@ static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args)
{
s7_pointer cur_val;
cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id);
- if (cur_val != sc->GC_NIL)
+ if (cur_val != sc->gc_nil)
val = cur_val;
if (top_id == symbol_id(sym))
return(val);
}
- if (val == sc->GC_NIL)
+ if (val == sc->gc_nil)
return(s7_symbol_value(sc, sym));
return(val);
}
@@ -6996,7 +7096,6 @@ static bool pair_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e)
}
-
/* make macros and closures */
static s7_pointer make_macro(s7_scheme *sc)
@@ -7047,8 +7146,8 @@ static s7_pointer make_macro(s7_scheme *sc)
slot_set_value(cx, mac);
else s7_make_slot(sc, sc->envir, sc->code, mac); /* was current but we've checked immutable already */
- optimize(sc, closure_body(mac), 0, sc->NIL);
- sc->temp6 = sc->NIL;
+ optimize(sc, closure_body(mac), 0, sc->nil);
+ sc->temp6 = sc->nil;
return(mac);
}
@@ -7123,8 +7222,8 @@ static int closure_length(s7_scheme *sc, s7_pointer e)
* changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not environments.
*/
s7_pointer length_func;
- length_func = find_method(sc, closure_let(e), sc->LENGTH);
- if (length_func != sc->UNDEFINED)
+ length_func = find_method(sc, closure_let(e), sc->length_symbol);
+ if (length_func != sc->undefined)
return((int)s7_integer(s7_apply_function(sc, length_func, list_1(sc, e))));
/* there are cases where this should raise a wrong-type-arg error, but for now... */
@@ -7142,7 +7241,6 @@ static int closure_length(s7_scheme *sc, s7_pointer e)
return(slot_value(val)); \
}
-
static s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree)
{
#if WITH_GCC
@@ -7185,7 +7283,7 @@ static s7_pointer copy_body(s7_scheme *sc, s7_pointer p)
sc->w = copy_tree(sc, p);
annotate_expansion(sc->w);
p = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(p);
}
@@ -7211,7 +7309,7 @@ static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc)
static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
{
#define H_is_defined "(defined? obj (env (curlet)) ignore-globals) returns #t if obj has a binding (a value) in the environment env"
- #define Q_is_defined s7_make_signature(sc, 4, sc->IS_BOOLEAN, sc->IS_SYMBOL, sc->IS_LET, sc->IS_BOOLEAN)
+ #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, sc->is_let_symbol, sc->is_boolean_symbol)
s7_pointer sym;
@@ -7222,20 +7320,20 @@ static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->IS_DEFINED, args, T_SYMBOL, 1);
+ method_or_bust(sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1);
if (is_pair(cdr(args)))
{
s7_pointer e, b, x;
e = cadr(args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->IS_DEFINED, 2, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->is_defined_symbol, 2, e, a_let_string));
if (is_pair(cddr(args)))
{
b = caddr(args);
if (!s7_is_boolean(b))
- method_or_bust_with_type(sc, b, sc->IS_DEFINED, args, A_BOOLEAN, 3);
+ method_or_bust_with_type(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3);
}
else b = sc->F;
@@ -7291,7 +7389,7 @@ bool s7_is_defined(s7_scheme *sc, const char *name)
void s7_define(s7_scheme *sc, s7_pointer envir, s7_pointer symbol, s7_pointer value)
{
s7_pointer x;
- if ((envir == sc->NIL) ||
+ if ((envir == sc->nil) ||
(envir == sc->rootlet))
envir = sc->shadow_rootlet;
x = find_local_symbol(sc, symbol, envir);
@@ -7314,7 +7412,7 @@ s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value)
{
s7_pointer sym;
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, value);
+ s7_define(sc, sc->nil, sym, value);
return(sym);
}
@@ -7333,7 +7431,7 @@ s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value)
{
s7_pointer sym;
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, value);
+ s7_define(sc, sc->nil, sym, value);
set_immutable(sym);
return(sym);
}
@@ -7348,7 +7446,7 @@ s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name
sym = s7_define_constant(sc, name, value);
symbol_set_has_help(sym);
symbol_help(sym) = copy_string(help);
- return(value);
+ return(value); /* inconsistent with variable above, but consistent with define_function? */
}
@@ -7385,9 +7483,9 @@ bool s7_is_keyword(s7_pointer obj)
static s7_pointer g_is_keyword(s7_scheme *sc, s7_pointer args)
{
- #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :key) -> #t"
+ #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t"
#define Q_is_keyword pl_bt
- check_boolean_method(sc, is_keyword, sc->IS_KEYWORD, args);
+ check_boolean_method(sc, is_keyword, sc->is_keyword_symbol, args);
}
@@ -7410,18 +7508,22 @@ s7_pointer s7_make_keyword(s7_scheme *sc, const char *key)
static s7_pointer g_make_keyword(s7_scheme *sc, s7_pointer args)
{
+ /* this should be keyword, not make-keyword, but the latter is in use elsewhere, and in s7.h
+ * (string->)symbol is s7_make_symbol. string->symbol is redundant.
+ * Either use symbol/keyword/gensym, or string->symbol/string->keyword/string->gensym?
+ */
#define H_make_keyword "(make-keyword str) prepends ':' to str and defines that as a keyword"
- #define Q_make_keyword s7_make_signature(sc, 2, sc->IS_KEYWORD, sc->IS_STRING)
+ #define Q_make_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol)
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->MAKE_KEYWORD, args, T_STRING, 0);
+ method_or_bust(sc, car(args), sc->make_keyword_symbol, args, T_STRING, 0);
return(s7_make_keyword(sc, string_value(car(args))));
}
static s7_pointer c_make_keyword(s7_scheme *sc, s7_pointer x)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->MAKE_KEYWORD, list_1(sc, x), T_STRING, 0);
+ method_or_bust(sc, x, sc->make_keyword_symbol, list_1(sc, x), T_STRING, 0);
return(s7_make_keyword(sc, string_value(x)));
}
@@ -7430,19 +7532,19 @@ static s7_pointer c_make_keyword(s7_scheme *sc, s7_pointer x)
static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args)
{
#define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon"
- #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->IS_SYMBOL, sc->IS_KEYWORD)
+ #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol)
s7_pointer sym;
sym = car(args);
if (!is_keyword(sym))
- method_or_bust_with_type(sc, sym, sc->KEYWORD_TO_SYMBOL, args, make_string_wrapper(sc, "a keyword"), 0);
+ method_or_bust_with_type(sc, sym, sc->keyword_to_symbol_symbol, args, make_string_wrapper(sc, "a keyword"), 0);
return(keyword_symbol(sym));
}
static s7_pointer c_keyword_to_symbol(s7_scheme *sc, s7_pointer sym)
{
if (!is_keyword(sym))
- method_or_bust_with_type(sc, sym, sc->KEYWORD_TO_SYMBOL, list_1(sc, sym), make_string_wrapper(sc, "a keyword"), 0);
+ method_or_bust_with_type(sc, sym, sc->keyword_to_symbol_symbol, list_1(sc, sym), make_string_wrapper(sc, "a keyword"), 0);
return(keyword_symbol(sym));
}
@@ -7451,17 +7553,17 @@ static s7_pointer c_keyword_to_symbol(s7_scheme *sc, s7_pointer sym)
static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended"
- #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->IS_KEYWORD, sc->IS_SYMBOL)
+ #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol)
if (!is_symbol(car(args)))
- method_or_bust(sc, car(args), sc->SYMBOL_TO_KEYWORD, args, T_SYMBOL, 0);
+ method_or_bust(sc, car(args), sc->symbol_to_keyword_symbol, args, T_SYMBOL, 0);
return(s7_make_keyword(sc, symbol_name(car(args))));
}
static s7_pointer c_symbol_to_keyword(s7_scheme *sc, s7_pointer sym)
{
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_TO_KEYWORD, list_1(sc, sym), T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->symbol_to_keyword_symbol, list_1(sc, sym), T_SYMBOL, 0);
return(s7_make_keyword(sc, symbol_name(sym)));
}
@@ -7502,7 +7604,7 @@ static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args)
#define H_is_c_pointer "(c-pointer? obj) returns #t if obj is a C pointer being held in s7."
#define Q_is_c_pointer pl_bt
- check_boolean_method(sc, s7_is_c_pointer, sc->IS_C_POINTER, args);
+ check_boolean_method(sc, s7_is_c_pointer, sc->is_c_pointer_symbol, args);
}
@@ -7510,7 +7612,7 @@ static s7_pointer c_c_pointer(s7_scheme *sc, s7_pointer arg)
{
ptr_int p;
if (!s7_is_integer(arg))
- method_or_bust(sc, arg, sc->C_POINTER, list_1(sc, arg), T_INTEGER, 1);
+ method_or_bust(sc, arg, sc->c_pointer_symbol, list_1(sc, arg), T_INTEGER, 1);
p = (ptr_int)s7_integer(arg); /* (c-pointer (bignum "1234")) */
return(s7_make_c_pointer(sc, (void *)p));
}
@@ -7518,7 +7620,7 @@ static s7_pointer c_c_pointer(s7_scheme *sc, s7_pointer arg)
static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args)
{
#define H_c_pointer "(c-pointer int) returns a c-pointer object."
- #define Q_c_pointer s7_make_signature(sc, 2, sc->IS_C_POINTER, sc->IS_INTEGER)
+ #define Q_c_pointer s7_make_signature(sc, 2, sc->is_c_pointer_symbol, sc->is_integer_symbol)
return(c_c_pointer(sc, car(args)));
}
@@ -8947,9 +9049,9 @@ PF_0(current_input_port, s7_current_input_port)
PF_0(current_output_port, s7_current_output_port)
PF_0(current_error_port, s7_current_error_port)
-static s7_pointer c_unlet(s7_scheme *sc) {return(g_unlet(sc, sc->NIL));}
+static s7_pointer c_unlet(s7_scheme *sc) {return(g_unlet(sc, sc->nil));}
PF_0(unlet, c_unlet)
-static s7_pointer c_gc(s7_scheme *sc) {return(g_gc(sc, sc->NIL));}
+static s7_pointer c_gc(s7_scheme *sc) {return(g_gc(sc, sc->nil));}
PF_0(gc, c_gc)
@@ -9011,52 +9113,52 @@ PF_TO_PF(coverlet, c_coverlet)
s7_pointer func; \
if (Checker(p)) return(sc->T); \
if ((has_methods(p)) && \
- ((func = find_method(sc, find_let(sc, p), Method)) != sc->UNDEFINED)) \
+ ((func = find_method(sc, find_let(sc, p), Method)) != sc->undefined)) \
return(s7_apply_function(sc, func, list_1(sc, p))); \
return(sc->F); \
} \
PF_TO_PF(Name, c_ ## Name)
-bool_with_method(is_char, s7_is_character, sc->IS_CHAR)
-bool_with_method(is_boolean, s7_is_boolean, sc->IS_BOOLEAN)
-bool_with_method(is_byte_vector, is_byte_vector, sc->IS_BYTE_VECTOR)
-bool_with_method(is_complex, is_number, sc->IS_COMPLEX)
-bool_with_method(is_constant, s7_is_constant, sc->IS_CONSTANT)
-bool_with_method(is_continuation, is_continuation, sc->IS_CONTINUATION)
-bool_with_method(is_c_pointer, s7_is_c_pointer, sc->IS_C_POINTER)
-bool_with_method(is_dilambda, s7_is_dilambda, sc->IS_DILAMBDA)
-bool_with_method(is_eof_object, is_eof, sc->IS_EOF_OBJECT)
-bool_with_method(is_float_vector, is_float_vector, sc->IS_FLOAT_VECTOR)
-bool_with_method(is_gensym, is_gensym, sc->IS_GENSYM)
-bool_with_method(is_hash_table, is_hash_table, sc->IS_HASH_TABLE)
-bool_with_method(is_input_port, is_input_port, sc->IS_INPUT_PORT)
-bool_with_method(is_integer, is_integer, sc->IS_INTEGER)
-bool_with_method(is_int_vector, is_int_vector, sc->IS_INT_VECTOR)
-bool_with_method(is_iterator, is_iterator, sc->IS_ITERATOR)
-bool_with_method(is_keyword, is_keyword, sc->IS_KEYWORD)
-bool_with_method(is_let, is_let, sc->IS_LET)
-bool_with_method(is_macro, is_macro, sc->IS_MACRO)
-bool_with_method(is_null, is_null, sc->IS_NULL)
-bool_with_method(is_number, is_number, sc->IS_NUMBER)
-bool_with_method(is_openlet, s7_is_openlet, sc->IS_OPENLET)
-bool_with_method(is_output_port, is_output_port, sc->IS_OUTPUT_PORT)
-bool_with_method(is_pair, is_pair, sc->IS_PAIR)
-bool_with_method(is_procedure, is_procedure, sc->IS_PROCEDURE)
-bool_with_method(is_rational, is_rational, sc->IS_RATIONAL)
-bool_with_method(is_real, is_real, sc->IS_REAL)
-bool_with_method(is_string, is_string, sc->IS_STRING)
-bool_with_method(is_symbol, is_symbol, sc->IS_SYMBOL)
-bool_with_method(is_vector, s7_is_vector, sc->IS_VECTOR)
+bool_with_method(is_char, s7_is_character, sc->is_char_symbol)
+bool_with_method(is_boolean, s7_is_boolean, sc->is_boolean_symbol)
+bool_with_method(is_byte_vector, is_byte_vector, sc->is_byte_vector_symbol)
+bool_with_method(is_complex, is_number, sc->is_complex_symbol)
+bool_with_method(is_constant, s7_is_constant, sc->is_constant_symbol)
+bool_with_method(is_continuation, is_continuation, sc->is_continuation_symbol)
+bool_with_method(is_c_pointer, s7_is_c_pointer, sc->is_c_pointer_symbol)
+bool_with_method(is_dilambda, s7_is_dilambda, sc->is_dilambda_symbol)
+bool_with_method(is_eof_object, is_eof, sc->is_eof_object_symbol)
+bool_with_method(is_float_vector, is_float_vector, sc->is_float_vector_symbol)
+bool_with_method(is_gensym, is_gensym, sc->is_gensym_symbol)
+bool_with_method(is_hash_table, is_hash_table, sc->is_hash_table_symbol)
+bool_with_method(is_input_port, is_input_port, sc->is_input_port_symbol)
+bool_with_method(is_integer, is_integer, sc->is_integer_symbol)
+bool_with_method(is_int_vector, is_int_vector, sc->is_int_vector_symbol)
+bool_with_method(is_iterator, is_iterator, sc->is_iterator_symbol)
+bool_with_method(is_keyword, is_keyword, sc->is_keyword_symbol)
+bool_with_method(is_let, is_let, sc->is_let_symbol)
+bool_with_method(is_macro, is_macro, sc->is_macro_symbol)
+bool_with_method(is_null, is_null, sc->is_null_symbol)
+bool_with_method(is_number, is_number, sc->is_number_symbol)
+bool_with_method(is_openlet, s7_is_openlet, sc->is_openlet_symbol)
+bool_with_method(is_output_port, is_output_port, sc->is_output_port_symbol)
+bool_with_method(is_pair, is_pair, sc->is_pair_symbol)
+bool_with_method(is_procedure, is_procedure, sc->is_procedure_symbol)
+bool_with_method(is_rational, is_rational, sc->is_rational_symbol)
+bool_with_method(is_real, is_real, sc->is_real_symbol)
+bool_with_method(is_string, is_string, sc->is_string_symbol)
+bool_with_method(is_symbol, is_symbol, sc->is_symbol_symbol)
+bool_with_method(is_vector, s7_is_vector, sc->is_vector_symbol)
#define opt_is_list(p) s7_is_list(sc, p)
-bool_with_method(is_list, opt_is_list, sc->IS_LIST)
-bool_with_method(iterator_is_at_end, iterator_is_at_end, sc->ITERATOR_IS_AT_END)
-bool_with_method(is_random_state, is_random_state, sc->IS_RANDOM_STATE)
+bool_with_method(is_list, opt_is_list, sc->is_list_symbol)
+bool_with_method(iterator_is_at_end, iterator_is_at_end, sc->iterator_is_at_end_symbol)
+bool_with_method(is_random_state, is_random_state, sc->is_random_state_symbol)
PF_TO_PF(make_keyword, c_make_keyword)
PF_TO_PF(keyword_to_symbol, c_keyword_to_symbol)
PF_TO_PF(symbol_to_keyword, c_symbol_to_keyword)
-static s7_pointer c_symbol(s7_scheme *sc, s7_pointer x) {return(g_string_to_symbol_1(sc, x, sc->SYMBOL));}
+static s7_pointer c_symbol(s7_scheme *sc, s7_pointer x) {return(g_string_to_symbol_1(sc, x, sc->symbol_symbol));}
PF_TO_PF(symbol, c_symbol)
#if 0
@@ -9066,7 +9168,7 @@ static s7_pointer symbol_pf_p(s7_scheme *sc, s7_pointer **p)
s7_pointer x;
f = (s7_pf_t)(**p); (*p)++;
x = f(sc, p);
- return(g_string_to_symbol_1(sc, x, sc->SYMBOL));
+ return(g_string_to_symbol_1(sc, x, sc->symbol_symbol));
}
#endif
@@ -9077,7 +9179,7 @@ static s7_pointer string_to_symbol_pf_p(s7_scheme *sc, s7_pointer **p)
s7_pointer x;
f = (s7_pf_t)(**p); (*p)++;
x = f(sc, p);
- return(g_string_to_symbol_1(sc, x, sc->STRING_TO_SYMBOL));
+ return(g_string_to_symbol_1(sc, x, sc->string_to_symbol_symbol));
}
static s7_pointer number_to_string_pf_p(s7_scheme *sc, s7_pointer **p);
@@ -9398,7 +9500,7 @@ static s7_pointer pif_pf_pp(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
pf = (s7_pf_t)(**p); (*p)++;
y = pf(sc, p);
if (!is_integer(y))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
return(fnc(sc, x, integer(y)));
}
@@ -9410,7 +9512,7 @@ static s7_pointer pif_pf_sp(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
pf = (s7_pf_t)(**p); (*p)++;
y = pf(sc, p);
if (!is_integer(y))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
return(fnc(sc, x, integer(y)));
}
@@ -10014,7 +10116,7 @@ static s7_pointer if_pf_xx(s7_scheme *sc, s7_pointer **p)
val = test(sc, p);
if (val != sc->F)
val = t(sc, p);
- else val = sc->UNSPECIFIED;
+ else val = sc->unspecified;
(*p) = rc_go(sc, e1);
return(val);
@@ -10033,7 +10135,7 @@ static s7_pointer if_pf_not_xx(s7_scheme *sc, s7_pointer **p)
val = test(sc, p);
if (val == sc->F)
val = t(sc, p);
- else val = sc->UNSPECIFIED;
+ else val = sc->unspecified;
(*p) = rc_go(sc, e1);
return(val);
@@ -10061,7 +10163,7 @@ static s7_pointer if_pf_not_equal_2(s7_scheme *sc, s7_pointer **p)
if (c_equal_2(sc, x, y) == sc->F)
val = t(sc, p);
- else val = sc->UNSPECIFIED;
+ else val = sc->unspecified;
(*p) = rc_go(sc, e1);
return(val);
@@ -10105,7 +10207,7 @@ static s7_pf_t if_pf(s7_scheme *sc, s7_pointer expr)
if ((is_null(cdr(expr))) || (is_null(cddr(expr)))) return(NULL);
test = cadr(expr);
- if ((is_pair(test)) && (car(test) == sc->NOT))
+ if ((is_pair(test)) && (car(test) == sc->not_symbol))
{
not_case = true;
test = cadr(test);
@@ -10308,7 +10410,7 @@ static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args)
#define H_is_continuation "(continuation? obj) returns #t if obj is a continuation"
#define Q_is_continuation pl_bt
- check_boolean_method(sc, is_continuation, sc->IS_CONTINUATION, args);
+ check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args);
/* is this the right thing? It returns #f for call-with-exit ("goto") because
* that form of continuation can't continue (via a jump back to its context).
* how to recognize the call-with-exit function? "goto" is an internal name.
@@ -10320,7 +10422,7 @@ static s7_pointer protected_list_copy(s7_scheme *sc, s7_pointer a)
{
s7_pointer slow, fast, p;
- sc->w = cons(sc, car(a), sc->NIL);
+ sc->w = cons(sc, car(a), sc->nil);
p = sc->w;
slow = fast = cdr(a);
@@ -10334,7 +10436,7 @@ static s7_pointer protected_list_copy(s7_scheme *sc, s7_pointer a)
return(sc->w);
}
- cdr(p) = cons(sc, car(fast), sc->NIL);
+ cdr(p) = cons(sc, car(fast), sc->nil);
p = cdr(p);
fast = cdr(fast);
@@ -10346,7 +10448,7 @@ static s7_pointer protected_list_copy(s7_scheme *sc, s7_pointer a)
return(sc->w);
}
/* if unrolled further, it's a lot slower? */
- cdr(p) = cons(sc, car(fast), sc->NIL);
+ cdr(p) = cons(sc, car(fast), sc->nil);
p = cdr(p);
fast = cdr(fast);
@@ -10385,6 +10487,7 @@ static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj)
counter_list(nobj) = counter_list(obj);
counter_capture(nobj) = counter_capture(obj);
counter_set_let(nobj, counter_let(obj));
+ counter_slots(nobj) = counter_slots(obj);
return(nobj);
}
@@ -10496,18 +10599,18 @@ static s7_pointer make_baffle(s7_scheme *sc)
static bool find_baffle(s7_scheme *sc, int key)
{
- /* search backwards through sc->envir for sc->BAFFLE with key as value
+ /* search backwards through sc->envir for sc->baffle_symbol with key as value
*/
s7_pointer x, y;
for (x = sc->envir; is_let(x); x = outlet(x))
for (y = let_slots(x); is_slot(y); y = next_slot(y))
- if ((slot_symbol(y) == sc->BAFFLE) &&
+ if ((slot_symbol(y) == sc->baffle_symbol) &&
(baffle_key(slot_value(y)) == key))
return(true);
- if ((is_slot(global_slot(sc->BAFFLE))) &&
- (is_baffle(slot_value(global_slot(sc->BAFFLE)))))
- return(baffle_key(slot_value(global_slot(sc->BAFFLE))) == key);
+ if ((is_slot(global_slot(sc->baffle_symbol))) &&
+ (is_baffle(slot_value(global_slot(sc->baffle_symbol)))))
+ return(baffle_key(slot_value(global_slot(sc->baffle_symbol))) == key);
return(false);
}
@@ -10515,19 +10618,19 @@ static bool find_baffle(s7_scheme *sc, int key)
static int find_any_baffle(s7_scheme *sc)
{
- /* search backwards through sc->envir for any sc->BAFFLE
+ /* search backwards through sc->envir for any sc->baffle_symbol
*/
if (sc->baffle_ctr > 0)
{
s7_pointer x, y;
for (x = sc->envir; is_let(x); x = outlet(x))
for (y = let_slots(x); is_slot(y); y = next_slot(y))
- if (slot_symbol(y) == sc->BAFFLE)
+ if (slot_symbol(y) == sc->baffle_symbol)
return(baffle_key(slot_value(y)));
- if ((is_slot(global_slot(sc->BAFFLE))) &&
- (is_baffle(slot_value(global_slot(sc->BAFFLE)))))
- return(baffle_key(slot_value(global_slot(sc->BAFFLE))));
+ if ((is_slot(global_slot(sc->baffle_symbol))) &&
+ (is_baffle(slot_value(global_slot(sc->baffle_symbol)))))
+ return(baffle_key(slot_value(global_slot(sc->baffle_symbol))));
}
return(-1);
}
@@ -10591,7 +10694,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
if (dynamic_wind_out(x) != sc->F)
{
push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->code = dynamic_wind_out(x);
eval(sc, OP_APPLY);
}
@@ -10629,7 +10732,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
* I can't find any fool-proof way to catch this problem.
*/
push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->code = dynamic_wind_in(x);
eval(sc, OP_APPLY);
}
@@ -10677,7 +10780,7 @@ static bool call_with_current_continuation(s7_scheme *sc)
}
if (is_null(sc->args))
- sc->value = sc->NIL;
+ sc->value = sc->nil;
else
{
if (is_null(cdr(sc->args)))
@@ -10697,7 +10800,7 @@ static void call_with_exit(s7_scheme *sc)
static s7_pointer call_with_exit_error = NULL;
if (!call_with_exit_error)
call_with_exit_error = s7_make_permanent_string("call-with-exit escape procedure called outside its block");
- s7_error(sc, sc->INVALID_ESCAPE_FUNCTION, set_elist_1(sc, call_with_exit_error));
+ s7_error(sc, sc->invalid_escape_function_symbol, set_elist_1(sc, call_with_exit_error));
}
call_exit_active(sc->code) = false;
@@ -10722,7 +10825,7 @@ static void call_with_exit(s7_scheme *sc)
if (dynamic_wind_out(lx) != sc->F)
{
push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->code = dynamic_wind_out(lx);
eval(sc, OP_APPLY);
}
@@ -10773,7 +10876,7 @@ static void call_with_exit(s7_scheme *sc)
/* the return value should have an implicit values call, just as in call/cc */
if (is_null(sc->args))
- sc->value = sc->NIL;
+ sc->value = sc->nil;
else
{
if (is_null(cdr(sc->args)))
@@ -10786,10 +10889,10 @@ static void call_with_exit(s7_scheme *sc)
if (sc->longjmp_ok)
{
pop_stack(sc);
- longjmp(sc->goto_start, 1);
+ longjmp(sc->goto_start, CALL_WITH_EXIT_JUMP);
}
for (i = 0; i < quit; i++)
- push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_DONE, sc->nil, sc->nil);
}
}
@@ -10797,24 +10900,24 @@ static void call_with_exit(s7_scheme *sc)
static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args)
{
#define H_call_cc "(call-with-current-continuation func) is always a mistake!"
- #define Q_call_cc s7_make_signature(sc, 2, sc->VALUES, sc->IS_PROCEDURE)
- /* I think the intent is that sc->VALUES as the proc-sig return type indicates multiple values are possible (otherwise use #t). */
+ #define Q_call_cc s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)
+ /* I think the intent is that sc->values_symbol as the proc-sig return type indicates multiple values are possible (otherwise use #t). */
s7_pointer p;
p = car(args); /* this is the procedure passed to call/cc */
if (!is_procedure(p)) /* this includes continuations */
{
- check_two_methods(sc, p, sc->CALL_CC, sc->CALL_WITH_CURRENT_CONTINUATION, args);
- return(simple_wrong_type_argument_with_type(sc, sc->CALL_CC, p, A_PROCEDURE));
+ check_two_methods(sc, p, sc->call_cc_symbol, sc->call_with_current_continuation_symbol, args);
+ return(simple_wrong_type_argument_with_type(sc, sc->call_cc_symbol, p, a_procedure_string));
}
if (!s7_is_aritable(sc, p, 1))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "call/cc procedure, ~A, should take one argument"), p)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "call/cc procedure, ~A, should take one argument"), p)));
sc->w = s7_make_continuation(sc);
push_stack(sc, OP_APPLY, list_1(sc, sc->w), p);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
- return(sc->NIL);
+ return(sc->nil);
}
/* we can't naively optimize call/cc to call-with-exit if the continuation is only
@@ -10826,23 +10929,23 @@ static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args)
static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args)
{
#define H_call_with_exit "(call-with-exit func) is call/cc without the ability to jump back into a previous computation."
- #define Q_call_with_exit s7_make_signature(sc, 2, sc->VALUES, sc->IS_PROCEDURE)
+ #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)
s7_pointer p, x;
/* (call-with-exit (lambda (return) ...)) */
p = car(args);
if (!is_procedure(p)) /* this includes continuations */
- method_or_bust_with_type(sc, p, sc->CALL_WITH_EXIT, args, A_PROCEDURE, 0);
+ method_or_bust_with_type(sc, p, sc->call_with_exit_symbol, args, a_procedure_string, 0);
x = make_goto(sc);
push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */
- push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->NIL), p);
+ push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p);
/* if the lambda body calls the argument as a function,
* it is applied to its arguments, apply notices that it is a goto, and...
*
* (conceptually...) sc->stack_top = call_exit_goto_loc(sc->code);
- * s_pop(sc, (is_not_null(sc->args)) ? car(sc->args) : sc->NIL);
+ * s_pop(sc, (is_not_null(sc->args)) ? car(sc->args) : sc->nil);
*
* which jumps to the point of the goto returning car(args).
*
@@ -10866,7 +10969,7 @@ static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args)
* I think call-with-exit could be based on catch, but it's a simpler notion,
* and certainly at the source level it is easier to read.
*/
- return(sc->NIL);
+ return(sc->nil);
}
@@ -11359,7 +11462,6 @@ static s7_pointer make_permanent_integer(s7_int i)
if (i == CLOSURE_ARITY_NOT_SET) return(arity_not_set);
if (i == -1) return(minus_one);
if (i == -2) return(minus_two);
-
/* a few -3 */
return(make_permanent_integer_unchecked(i));
@@ -11504,7 +11606,7 @@ static s7_pointer exact_to_inexact(s7_scheme *sc, s7_pointer x)
case T_REAL:
case T_COMPLEX: return(x); /* apparently (exact->inexact 1+i) is not an error */
default:
- method_or_bust_with_type(sc, x, sc->EXACT_TO_INEXACT, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->exact_to_inexact_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -11525,16 +11627,16 @@ static s7_pointer inexact_to_exact(s7_scheme *sc, s7_pointer x, bool with_error)
if ((is_inf(val)) || (is_NaN(val)))
{
if (with_error)
- return(simple_wrong_type_argument_with_type(sc, sc->INEXACT_TO_EXACT, x, A_NORMAL_REAL));
- return(sc->NIL);
+ return(simple_wrong_type_argument_with_type(sc, sc->inexact_to_exact_symbol, x, a_normal_real_string));
+ return(sc->nil);
}
if ((val > s7_int_max) ||
(val < s7_int_min))
{
if (with_error)
- return(simple_out_of_range(sc, sc->INEXACT_TO_EXACT, x, ITS_TOO_LARGE));
- return(sc->NIL);
+ return(simple_out_of_range(sc, sc->inexact_to_exact_symbol, x, its_too_large_string));
+ return(sc->nil);
}
if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom))
@@ -11543,8 +11645,8 @@ static s7_pointer inexact_to_exact(s7_scheme *sc, s7_pointer x, bool with_error)
default:
if (with_error)
- method_or_bust(sc, x, sc->INEXACT_TO_EXACT, list_1(sc, x), T_REAL, 0);
- return(sc->NIL);
+ method_or_bust(sc, x, sc->inexact_to_exact_symbol, list_1(sc, x), T_REAL, 0);
+ return(sc->nil);
}
return(x);
}
@@ -11563,7 +11665,8 @@ s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char
case T_REAL: return(real(x));
#if WITH_GMP
case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(big_integer(x)));
- case T_BIG_RATIO: return((s7_double)((long double)big_integer_to_s7_int(mpq_numref(big_ratio(x))) / (long double)big_integer_to_s7_int(mpq_denref(big_ratio(x)))));
+ case T_BIG_RATIO: return((s7_double)((long double)big_integer_to_s7_int(mpq_numref(big_ratio(x))) /
+ (long double)big_integer_to_s7_int(mpq_denref(big_ratio(x)))));
case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), GMP_RNDN));
#endif
}
@@ -11737,7 +11840,7 @@ static s7_pointer s7_invert(s7_scheme *sc, s7_pointer p) /* s7_ to be consi
}
default:
- return(wrong_type_argument_with_type(sc, sc->DIVIDE, 1, p, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->divide_symbol, 1, p, a_number_string));
}
}
@@ -12305,7 +12408,7 @@ static void prepare_temporary_string(s7_scheme *sc, int len, int which)
static s7_pointer g_number_to_string_1(s7_scheme *sc, s7_pointer args, bool temporary)
{
#define H_number_to_string "(number->string num (radix 10)) converts the number num into a string."
- #define Q_number_to_string s7_make_signature(sc, 3, sc->IS_STRING, sc->IS_NUMBER, sc->IS_INTEGER)
+ #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol)
s7_int radix = 10;
int size, nlen = 0;
@@ -12314,7 +12417,7 @@ static s7_pointer g_number_to_string_1(s7_scheme *sc, s7_pointer args, bool temp
x = car(args);
if (!s7_is_number(x))
- method_or_bust_with_type(sc, x, sc->NUMBER_TO_STRING, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->number_to_string_symbol, args, a_number_string, 1);
if (is_pair(cdr(args)))
{
@@ -12322,9 +12425,9 @@ static s7_pointer g_number_to_string_1(s7_scheme *sc, s7_pointer args, bool temp
y = cadr(args);
if (s7_is_integer(y))
radix = s7_integer(y);
- else method_or_bust(sc, y, sc->NUMBER_TO_STRING, args, T_INTEGER, 2);
+ else method_or_bust(sc, y, sc->number_to_string_symbol, args, T_INTEGER, 2);
if ((radix < 2) || (radix > 16))
- return(out_of_range(sc, sc->NUMBER_TO_STRING, small_int(2), y, A_VALID_RADIX));
+ return(out_of_range(sc, sc->number_to_string_symbol, small_int(2), y, a_valid_radix_string));
}
#if WITH_GMP
@@ -12542,7 +12645,7 @@ static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
{
if (args == sc->F)
args = list_1(sc, s7_make_string(sc, name));
- /* args is GC protected by s7_apply_function (placed on the stack */
+ /* args is GC protected by s7_apply_function?? (placed on the stack) */
value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */
if (value != sc->F)
break;
@@ -12566,12 +12669,12 @@ static s7_pointer g_sharp_readers_set(s7_scheme *sc, s7_pointer args)
if ((!is_pair(car(x))) ||
(!s7_is_character(caar(x))) ||
(!s7_is_procedure(cdar(x))))
- return(sc->ERROR);
+ return(sc->error_symbol);
}
if (is_null(x))
return(cadr(args));
}
- return(sc->ERROR);
+ return(sc->error_symbol);
}
@@ -12614,6 +12717,18 @@ static bool is_abnormal(s7_pointer x)
}
}
+static s7_pointer unknown_sharp_constant(s7_scheme *sc, char *name)
+{
+ /* check *read-error-hook* */
+ if (hook_has_functions(sc->read_error_hook))
+ {
+ s7_pointer result;
+ result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->T, make_string_wrapper(sc, name)));
+ if (result != sc->unspecified)
+ return(result);
+ }
+ return(sc->nil);
+}
#define NESTED_SHARP false
#define UNNESTED_SHARP true
@@ -12623,7 +12738,7 @@ static bool is_abnormal(s7_pointer x)
static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, int radix, bool with_error)
{
- /* name is the stuff after the '#', return sc->NIL if not a recognized #... entity */
+ /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */
int len;
s7_pointer x;
@@ -12644,22 +12759,22 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
len = safe_strlen5(name); /* just count up to 5 */
if (len < 2)
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
switch (name[0])
{
/* -------- #< ... > -------- */
case '<':
if (strings_are_equal(name, "<unspecified>"))
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
if (strings_are_equal(name, "<undefined>"))
- return(sc->UNDEFINED);
+ return(sc->undefined);
if (strings_are_equal(name, "<eof>"))
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
/* -------- #o #d #x #b -------- */
@@ -12675,16 +12790,16 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
if (name[1] == '#')
{
if (!at_top)
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
if ((len > 2) && ((name[2] == 'e') || (name[2] == 'i'))) /* r6rs includes caps here */
{
if ((len > 3) && (name[3] == '#'))
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
to_inexact = (name[2] == 'i');
to_exact = (name[2] == 'e');
num_at = 3;
}
- else return(sc->NIL);
+ else return(unknown_sharp_constant(sc, name));
}
#endif
/* the #b or whatever overrides any radix passed in earlier */
@@ -12696,14 +12811,14 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
* #x#e1+i should also be an error, but #e1+0i is not an error I guess since there actually isn't any imaginary part
*/
if (is_abnormal(x))
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if (!WITH_PURE_S7)
if ((!to_exact) && (!to_inexact))
return(x);
if ((s7_imag_part(x) != 0.0) && (to_exact)) /* #x#e1+i */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if WITH_GMP
if (s7_is_bignum(x))
@@ -12736,24 +12851,24 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
if ((name[2] == 'e') || /* #i#e1 -- assume these aren't redefinable? */
(name[2] == 'i'))
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
x = make_sharp_constant(sc, (char *)(name + 2), NESTED_SHARP, radix, with_error);
if (s7_is_number(x))
{
if (is_abnormal(x))
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if WITH_GMP
if (s7_is_bignum(x)) /* (string->number "#b#e-11e+111") */
return(big_exact_to_inexact(sc, set_plist_1(sc, x)));
#endif
return(exact_to_inexact(sc, x));
}
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
}
x = make_atom(sc, (char *)(name + 1), radix, NO_SYMBOLS, with_error);
if (!s7_is_number(x)) /* not is_abnormal(x) -- #i0/0 -> nan etc */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if WITH_GMP
if (s7_is_bignum(x))
return(big_exact_to_inexact(sc, set_plist_1(sc, x)));
@@ -12767,21 +12882,21 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
{
if ((name[2] == 'e') || /* #e#e1 */
(name[2] == 'i'))
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
x = make_sharp_constant(sc, (char *)(name + 2), NESTED_SHARP, radix, with_error);
if (s7_is_number(x))
{
if (is_abnormal(x)) /* (string->number "#e#b0/0") */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
if (!s7_is_real(x)) /* (string->number "#e#b1+i") */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if WITH_GMP
return(big_inexact_to_exact(sc, set_plist_1(sc, x)));
#endif
return(inexact_to_exact(sc, x, with_error));
}
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
}
x = make_atom(sc, (char *)(name + 1), radix, NO_SYMBOLS, with_error);
@@ -12791,9 +12906,9 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
return(big_inexact_to_exact(sc, set_plist_1(sc, x)));
#endif
if (is_abnormal(x)) /* (string->number "#e0/0") */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
if (!s7_is_real(x)) /* (string->number "#e1+i") */
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
#if WITH_GMP
/* there are non-big floats that are greater than most-positive-fixnum:
@@ -12814,8 +12929,8 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
sym = make_symbol(sc, (char *)(name + 1));
if (is_slot(initial_slot(sym)))
return(slot_value(initial_slot(sym)));
- return(s7_error(sc, sc->SYNTAX_ERROR, set_elist_2(sc, make_string_wrapper(sc, "#~A is undefined"), make_string_wrapper(sc, name))));
- /* return(sc->UNDEFINED); */
+ return(s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "#~A is undefined"), make_string_wrapper(sc, name))));
+ /* return(sc->undefined); */
}
@@ -12912,7 +13027,7 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, in
break;
}
}
- return(sc->NIL);
+ return(unknown_sharp_constant(sc, name));
}
@@ -13439,13 +13554,14 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int radix, bool want_symbol,
/* -------- exponent marker -------- */
- case 'e': case 'E':
#if WITH_EXTRA_EXPONENT_MARKERS
+ /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */
case 's': case 'S':
case 'd': case 'D':
case 'f': case 'F':
case 'l': case 'L':
#endif
+ case 'e': case 'E':
if (current_radix > 10)
return((want_symbol) ? make_symbol(sc, q) : sc->F);
/* see note above */
@@ -13741,7 +13857,7 @@ static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointe
#define H_string_to_number "(string->number str (radix 10)) converts str into a number. \
If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \
the 'radix' it is ignored: (string->number \"#x11\" 2) -> 17 not 3."
- #define Q_string_to_number s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->IS_NUMBER, sc->IS_BOOLEAN), sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_string_to_number s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_boolean_symbol), sc->is_string_symbol, sc->is_integer_symbol)
s7_int radix = 0;
char *str;
@@ -13762,7 +13878,7 @@ the 'radix' it is ignored: (string->number \"#x11\" 2) -> 17 not 3."
radix = s7_integer(rad);
if ((radix < 2) || /* what about negative int as base (Knuth), reals such as phi, and some complex like -1+i */
(radix > 16)) /* the only problem here is printing the number; perhaps put each digit in "()" in base 10: (123)(0)(34) */
- return(out_of_range(sc, caller, small_int(2), rad, A_VALID_RADIX));
+ return(out_of_range(sc, caller, small_int(2), rad, a_valid_radix_string));
}
else radix = 10;
@@ -13798,12 +13914,12 @@ the 'radix' it is ignored: (string->number \"#x11\" 2) -> 17 not 3."
static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args)
{
- return(g_string_to_number_1(sc, args, sc->STRING_TO_NUMBER));
+ return(g_string_to_number_1(sc, args, sc->string_to_number_symbol));
}
static s7_pointer c_string_to_number(s7_scheme *sc, s7_pointer n)
{
- return(g_string_to_number_1(sc, set_plist_1(sc, n), sc->STRING_TO_NUMBER));
+ return(g_string_to_number_1(sc, set_plist_1(sc, n), sc->string_to_number_symbol));
}
PF_TO_PF(string_to_number, c_string_to_number)
@@ -13853,9 +13969,9 @@ static bool is_rational_via_method(s7_scheme *sc, s7_pointer p)
if (has_methods(p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->IS_RATIONAL);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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))));
}
return(false);
}
@@ -13866,7 +13982,7 @@ static bool is_rational_via_method(s7_scheme *sc, s7_pointer p)
static s7_pointer g_abs(s7_scheme *sc, s7_pointer args)
{
#define H_abs "(abs x) returns the absolute value of the real number x"
- #define Q_abs s7_make_signature(sc, 2, sc->IS_REAL, sc->IS_REAL)
+ #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
s7_pointer x;
x = car(args);
@@ -13898,7 +14014,7 @@ static s7_pointer g_abs(s7_scheme *sc, s7_pointer args)
return(x);
default:
- method_or_bust(sc, x, sc->ABS, args, T_REAL, 0);
+ method_or_bust(sc, x, sc->abs_symbol, args, T_REAL, 0);
}
}
@@ -13914,7 +14030,7 @@ DIRECT_RF_TO_RF(fabs)
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, sc->IS_NUMBER)
+ #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer x;
x = car(args);
@@ -13946,7 +14062,7 @@ static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
return(make_real(sc, hypot(imag_part(x), real_part(x))));
default:
- method_or_bust_with_type(sc, x, sc->MAGNITUDE, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->magnitude_symbol, args, a_number_string, 0);
}
}
@@ -13959,24 +14075,24 @@ RF_TO_RF(magnitude, c_abs_r)
static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
{
#define H_rationalize "(rationalize x err) returns the ratio with lowest denominator within err of x"
- #define Q_rationalize s7_make_signature(sc, 3, sc->IS_RATIONAL, sc->IS_REAL, sc->IS_REAL)
+ #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
s7_double err;
s7_pointer x;
x = car(args);
if (!s7_is_real(x))
- method_or_bust(sc, x, sc->RATIONALIZE, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->rationalize_symbol, args, T_REAL, 1);
if (is_not_null(cdr(args)))
{
s7_pointer ex;
ex = cadr(args);
if (!s7_is_real(ex))
- method_or_bust(sc, ex, sc->RATIONALIZE, args, T_REAL, 2);
+ method_or_bust(sc, ex, sc->rationalize_symbol, args, T_REAL, 2);
err = real_to_double(sc, ex, "rationalize");
if (is_NaN(err))
- return(out_of_range(sc, sc->RATIONALIZE, small_int(2), cadr(args), ITS_NAN));
+ return(out_of_range(sc, sc->rationalize_symbol, small_int(2), cadr(args), its_nan_string));
if (err < 0.0) err = -err;
}
else err = sc->default_rationalize_error;
@@ -14009,13 +14125,13 @@ static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
rat = real_to_double(sc, x, "rationalize");
if ((is_NaN(rat)) || (is_inf(rat)))
- return(wrong_type_argument_with_type(sc, sc->RATIONALIZE, 1, x, A_NORMAL_REAL));
+ return(wrong_type_argument_with_type(sc, sc->rationalize_symbol, 1, x, a_normal_real_string));
if (err >= fabs(rat))
return(small_int(0));
if ((rat > 9.2233720368548e+18) || (rat < -9.2233720368548e+18))
- return(out_of_range(sc, sc->RATIONALIZE, small_int(1), x, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->rationalize_symbol, small_int(1), x, its_too_large_string));
if ((fabs(rat) + fabs(err)) < 1.0e-18)
err = 1.0e-18;
@@ -14043,7 +14159,7 @@ PF_TO_PF(rationalize, c_rats)
static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
{
#define H_angle "(angle z) returns the angle of z"
- #define Q_angle s7_make_signature(sc, 2, sc->IS_REAL, sc->IS_NUMBER)
+ #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer x;
/* (angle inf+infi) -> 0.78539816339745 ?
* I think this should be -pi < ang <= pi
@@ -14072,7 +14188,7 @@ static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
return(make_real(sc, atan2(imag_part(x), real_part(x))));
default:
- method_or_bust_with_type(sc, x, sc->ANGLE, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->angle_symbol, args, a_number_string, 0);
}
}
@@ -14084,7 +14200,7 @@ static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
s7_pointer x, y;
s7_double ang, mag;
#define H_make_polar "(make-polar mag ang) returns a complex number with magnitude mag and angle ang"
- #define Q_make_polar s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_REAL, sc->IS_REAL)
+ #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
x = car(args);
y = cadr(args);
@@ -14117,7 +14233,7 @@ static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust(sc, y, sc->MAKE_POLAR, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
}
break;
@@ -14145,7 +14261,7 @@ static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust(sc, y, sc->MAKE_POLAR, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
}
break;
@@ -14173,12 +14289,12 @@ static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust(sc, y, sc->MAKE_POLAR, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
}
break;
default:
- method_or_bust(sc, x, sc->MAKE_POLAR, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->make_polar_symbol, args, T_REAL, 1);
}
return(s7_make_complex(sc, mag * cos(ang), mag * sin(ang)));
@@ -14198,7 +14314,7 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
{
s7_pointer x, y;
#define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
- #define Q_complex s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_REAL, sc->IS_REAL)
+ #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
x = car(args);
y = cadr(args);
@@ -14221,7 +14337,7 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, real(x), (s7_double)integer(y)));
default:
- method_or_bust(sc, x, sc->COMPLEX, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
}
case T_RATIO:
@@ -14231,7 +14347,7 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
case T_RATIO: return(s7_make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y)));
case T_REAL: return(s7_make_complex(sc, real(x), (s7_double)fraction(y)));
default:
- method_or_bust(sc, x, sc->COMPLEX, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
}
case T_REAL:
@@ -14250,11 +14366,11 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, real(x), real(y)));
default:
- method_or_bust(sc, x, sc->COMPLEX, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
}
default:
- method_or_bust(sc, (is_let(x)) ? x : y, sc->COMPLEX, args, T_REAL, 2);
+ method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, args, T_REAL, 2);
}
}
@@ -14290,11 +14406,11 @@ static s7_pointer g_exp(s7_scheme *sc, s7_pointer args)
* (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i
*/
#else
- return(out_of_range(sc, sc->EXP, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->exp_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->EXP, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->exp_symbol, args, a_number_string, 0);
}
}
@@ -14317,7 +14433,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args)
s7_pointer x;
x = car(args);
if (!s7_is_number(x))
- method_or_bust_with_type(sc, x, sc->LOG, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->log_symbol, args, a_number_string, 1);
if (is_pair(cdr(args)))
{
@@ -14325,7 +14441,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args)
y = cadr(args);
if (!(s7_is_number(y)))
- method_or_bust_with_type(sc, y, sc->LOG, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->log_symbol, args, a_number_string, 2);
if (y == small_int(2))
{
@@ -14368,7 +14484,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args)
if ((y == small_int(0)) &&
(x == small_int(1)))
return(y);
- return(out_of_range(sc, sc->LOG, small_int(2), y, make_string_wrapper(sc, "can't be 0")));
+ return(out_of_range(sc, sc->log_symbol, small_int(2), y, make_string_wrapper(sc, "can't be 0")));
}
if (s7_is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */
@@ -14433,11 +14549,11 @@ static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, csin(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->SIN, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->sin_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->SIN, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->sin_symbol, args, a_number_string, 0);
}
/* sin is totally inaccurate over about 1e18. There's a way to get true results,
@@ -14479,11 +14595,11 @@ static s7_pointer g_cos(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, ccos(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->COS, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->cos_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->COS, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->cos_symbol, args, a_number_string, 0);
}
}
@@ -14518,11 +14634,11 @@ static s7_pointer g_tan(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, 0.0, -1.0));
return(s7_from_c_complex(sc, ctan(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->TAN, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->tan_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->TAN, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->tan_symbol, args, a_number_string, 0);
}
}
@@ -14579,11 +14695,11 @@ static s7_pointer g_asin_1(s7_scheme *sc, s7_pointer n)
}
return(s7_from_c_complex(sc, casin(as_c_complex(n))));
#else
- return(out_of_range(sc, sc->ASIN, small_int(1), n, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->asin_symbol, small_int(1), n, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, n, sc->ASIN, list_1(sc, n), A_NUMBER, 0);
+ method_or_bust_with_type(sc, n, sc->asin_symbol, list_1(sc, n), a_number_string, 0);
}
}
@@ -14647,11 +14763,11 @@ static s7_pointer g_acos_1(s7_scheme *sc, s7_pointer n)
}
return(s7_from_c_complex(sc, cacos(s7_to_c_complex(n))));
#else
- return(out_of_range(sc, sc->ACOS, small_int(1), n, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->acos_symbol, small_int(1), n, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, n, sc->ACOS, list_1(sc, n), A_NUMBER, 0);
+ method_or_bust_with_type(sc, n, sc->acos_symbol, list_1(sc, n), a_number_string, 0);
}
}
@@ -14675,7 +14791,7 @@ static s7_double c_atan(s7_scheme *sc, s7_double x, s7_double y)
static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
{
#define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
- #define Q_atan s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_NUMBER, sc->IS_REAL)
+ #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
/* actually if there are two args, both should be real, but how to express that in the signature? */
s7_pointer x, y;
s7_double x1, x2;
@@ -14698,20 +14814,20 @@ static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, catan(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->ATAN, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->atan_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->ATAN, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->atan_symbol, args, a_number_string, 0);
}
}
if (!s7_is_real(x))
- method_or_bust(sc, x, sc->ATAN, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->atan_symbol, args, T_REAL, 1);
y = cadr(args);
if (!s7_is_real(y))
- method_or_bust(sc, y, sc->ATAN, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->atan_symbol, args, T_REAL, 2);
x1 = real_to_double(sc, x, "atan");
x2 = real_to_double(sc, y, "atan");
@@ -14742,11 +14858,11 @@ static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, csinh(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->SINH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->sinh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->SINH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->sinh_symbol, args, a_number_string, 0);
}
}
@@ -14782,11 +14898,11 @@ static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, ccosh(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->COSH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->cosh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->COSH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->cosh_symbol, args, a_number_string, 0);
}
}
@@ -14818,11 +14934,11 @@ static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args)
return(make_real(sc, -1.0)); /* closer than ctanh's -0.0 */
return(s7_from_c_complex(sc, ctanh(as_c_complex(x))));
#else
- return(out_of_range(sc, sc->TANH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->tanh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->TANH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->tanh_symbol, args, a_number_string, 0);
}
}
@@ -14852,11 +14968,11 @@ static s7_pointer c_asinh_1(s7_scheme *sc, s7_pointer x)
return(s7_from_c_complex(sc, casinh(as_c_complex(x))));
#endif
#else
- return(out_of_range(sc, sc->ASINH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->asinh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->ASINH, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->asinh_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -14902,11 +15018,11 @@ static s7_pointer c_acosh_1(s7_scheme *sc, s7_pointer x)
#endif
#else
/* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
- return(out_of_range(sc, sc->ACOSH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->acosh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->ACOSH, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->acosh_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -14956,11 +15072,11 @@ static s7_pointer c_atanh_1(s7_scheme *sc, s7_pointer x)
return(s7_from_c_complex(sc, catanh(s7_to_c_complex(x))));
#endif
#else
- return(out_of_range(sc, sc->ATANH, small_int(1), x, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->atanh_symbol, small_int(1), x, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, x, sc->ATANH, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->atanh_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -15049,11 +15165,11 @@ static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args)
#if HAVE_COMPLEX_NUMBERS
return(s7_from_c_complex(sc, csqrt(as_c_complex(n))));
#else
- return(out_of_range(sc, sc->SQRT, small_int(1), n, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->sqrt_symbol, small_int(1), n, no_complex_numbers_string));
#endif
default:
- method_or_bust_with_type(sc, n, sc->SQRT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, n, sc->sqrt_symbol, args, a_number_string, 0);
}
}
@@ -15104,11 +15220,11 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
n = car(args);
if (!s7_is_number(n))
- method_or_bust_with_type(sc, n, sc->EXPT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, n, sc->expt_symbol, args, a_number_string, 1);
pw = cadr(args);
if (!s7_is_number(pw))
- method_or_bust_with_type(sc, pw, sc->EXPT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, pw, sc->expt_symbol, args, a_number_string, 2);
/* this provides more than 2 args to expt:
* if (is_not_null(cddr(args)))
@@ -15130,7 +15246,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
if (s7_is_real(pw))
{
if (s7_is_negative(pw)) /* (expt 0 -1) */
- return(division_by_zero_error(sc, sc->EXPT, args));
+ return(division_by_zero_error(sc, sc->expt_symbol, args));
/* (Clisp gives divide-by-zero error here, Guile returns inf.0) */
if ((!s7_is_rational(pw)) && /* (expt 0 most-positive-fixnum) */
@@ -15140,7 +15256,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
else
{ /* (expt 0 a+bi) */
if (real_part(pw) < 0.0) /* (expt 0 -1+i) */
- return(division_by_zero_error(sc, sc->EXPT, args));
+ return(division_by_zero_error(sc, sc->expt_symbol, args));
if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */
(is_NaN(imag_part(pw))))
return(real_NaN);
@@ -15268,7 +15384,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
}
}
#else
- return(out_of_range(sc, sc->EXPT, small_int(2), n, NO_COMPLEX_NUMBERS));
+ return(out_of_range(sc, sc->expt_symbol, small_int(2), n, no_complex_numbers_string));
#endif
break;
}
@@ -15351,7 +15467,7 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
if (!is_pair(cdr(args)))
{
if (!is_rational(car(args)))
- method_or_bust_with_type(sc, car(args), sc->LCM, args, A_RATIONAL, 1);
+ method_or_bust_with_type(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1);
return(g_abs(sc, args));
}
@@ -15388,14 +15504,14 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust_with_type(sc, x, sc->LCM, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), A_RATIONAL, position_of(p, args));
+ method_or_bust_with_type(sc, x, sc->lcm_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args));
}
- if (n < 0) return(simple_out_of_range(sc, sc->LCM, args, RESULT_IS_TOO_LARGE));
+ if (n < 0) return(simple_out_of_range(sc, sc->lcm_symbol, args, result_is_too_large_string));
if (n == 0)
{
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_rational_via_method(sc, car(p)))
- return(wrong_type_argument_with_type(sc, sc->LCM, position_of(p, args), x, A_RATIONAL));
+ return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string));
return(small_int(0));
}
}
@@ -15430,7 +15546,7 @@ static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
if (!is_pair(cdr(args)))
{
if (!is_rational(car(args)))
- method_or_bust_with_type(sc, car(args), sc->GCD, args, A_RATIONAL, 1);
+ method_or_bust_with_type(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1);
return(g_abs(sc, args));
}
@@ -15450,13 +15566,13 @@ static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
b = s7_denominator(x);
if (b < 0) b = -b;
d = (d / c_gcd(d, b)) * b;
- if (d < 0) return(simple_out_of_range(sc, sc->GCD, args, RESULT_IS_TOO_LARGE));
+ if (d < 0) return(simple_out_of_range(sc, sc->gcd_symbol, args, result_is_too_large_string));
break;
default:
- method_or_bust_with_type(sc, x, sc->GCD, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), A_RATIONAL, position_of(p, args));
+ method_or_bust_with_type(sc, x, sc->gcd_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args));
}
- if (n < 0) return(simple_out_of_range(sc, sc->GCD, args, RESULT_IS_TOO_LARGE));
+ if (n < 0) return(simple_out_of_range(sc, sc->gcd_symbol, args, result_is_too_large_string));
}
if (d <= 1)
@@ -15473,7 +15589,7 @@ static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf)
{
if ((xf > s7_int_max) ||
(xf < s7_int_min))
- return(simple_out_of_range(sc, caller, make_real(sc, xf), ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, caller, make_real(sc, xf), its_too_large_string));
if (xf > 0.0)
return(make_integer(sc, (s7_int)floor(xf)));
@@ -15483,9 +15599,9 @@ static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf)
static s7_int c_quo_int(s7_scheme *sc, s7_int x, s7_int y)
{
if (y == 0)
- division_by_zero_error(sc, sc->QUOTIENT, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
+ division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
if ((y == -1) && (x == s7_int_min)) /* (quotient most-negative-fixnum -1) */
- simple_out_of_range(sc, sc->QUOTIENT, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)), ITS_TOO_LARGE);
+ simple_out_of_range(sc, sc->quotient_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)), its_too_large_string);
return(x / y);
}
@@ -15494,14 +15610,14 @@ static s7_double c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y)
s7_double xf;
if (y == 0.0)
- division_by_zero_error(sc, sc->QUOTIENT, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
+ division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
if ((is_inf(y)) || (is_NaN(y)))
- wrong_type_argument_with_type(sc, sc->QUOTIENT, 2, make_real(sc, y), A_NORMAL_REAL);
+ wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, make_real(sc, y), a_normal_real_string);
xf = x / y;
if ((xf > s7_int_max) ||
(xf < s7_int_min))
- simple_out_of_range(sc, sc->QUOTIENT, make_real(sc, xf), ITS_TOO_LARGE);
+ simple_out_of_range(sc, sc->quotient_symbol, make_real(sc, xf), its_too_large_string);
if (xf > 0.0)
return(floor(xf));
@@ -15537,13 +15653,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, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, args));
if ((is_inf(real(y))) || (is_NaN(real(y))))
- return(wrong_type_argument_with_type(sc, sc->QUOTIENT, 2, y, A_NORMAL_REAL));
- return(s7_truncate(sc, sc->QUOTIENT, (s7_double)integer(x) / 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)));
default:
- method_or_bust(sc, y, sc->QUOTIENT, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
}
case T_RATIO:
@@ -15551,7 +15667,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, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, args));
n1 = numerator(x);
d1 = denominator(x);
n2 = integer(y);
@@ -15577,30 +15693,30 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
s7_int n1d2, n2d1;
if ((multiply_overflow(n1, d2, &n1d2)) ||
(multiply_overflow(n2, d1, &n2d1)))
- return(s7_truncate(sc, sc->QUOTIENT, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
+ return(s7_truncate(sc, sc->quotient_symbol, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
return(make_integer(sc, n1d2 / n2d1));
}
#else
if ((integer_length(n1) + integer_length(d2) >= s7_int_bits) ||
(integer_length(n2) + integer_length(d1) >= s7_int_bits))
- return(s7_truncate(sc, sc->QUOTIENT, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
+ return(s7_truncate(sc, sc->quotient_symbol, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
return(make_integer(sc, (n1 * d2) / (n2 * d1)));
#endif
case T_REAL:
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->QUOTIENT, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, args));
if ((is_inf(real(y))) || (is_NaN(real(y))))
- return(wrong_type_argument_with_type(sc, sc->QUOTIENT, 2, y, A_NORMAL_REAL));
- return(s7_truncate(sc, sc->QUOTIENT, (s7_double)fraction(x) / 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:
- method_or_bust(sc, y, sc->QUOTIENT, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
}
case T_REAL:
if ((is_inf(real(x))) || (is_NaN(real(x))))
- return(wrong_type_argument_with_type(sc, sc->QUOTIENT, 1, x, A_NORMAL_REAL));
+ return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 1, x, a_normal_real_string));
/* if infs allowed we need to return infs/nans, else:
* (quotient inf.0 1e-309) -> -9223372036854775808
@@ -15611,21 +15727,21 @@ 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, args));
- return(s7_truncate(sc, sc->QUOTIENT, real(x) / (s7_double)integer(y)));
+ return(division_by_zero_error(sc, sc->quotient_symbol, args));
+ return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)integer(y)));
case T_RATIO:
- return(s7_truncate(sc, sc->QUOTIENT, real(x) / (s7_double)fraction(y)));
+ return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y)));
case T_REAL:
return(make_real(sc, c_quo_dbl(sc, real(x), real(y))));
default:
- method_or_bust(sc, y, sc->QUOTIENT, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
}
default:
- method_or_bust(sc, x, sc->QUOTIENT, args, T_REAL, 2);
+ method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 2);
}
}
@@ -15637,7 +15753,7 @@ RF2_TO_RF(quotient, c_quo_dbl)
static s7_int c_rem_int(s7_scheme *sc, s7_int x, s7_int y)
{
if (y == 0)
- division_by_zero_error(sc, sc->REMAINDER, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
+ division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
if ((y == 1) || (y == -1)) /* (remainder most-negative-fixnum -1) will segfault with arithmetic exception */
return(0);
return(x % y);
@@ -15648,13 +15764,13 @@ static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y)
s7_int quo;
s7_double pre_quo;
if (y == 0.0)
- division_by_zero_error(sc, sc->REMAINDER, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
+ division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
if ((is_inf(y)) || (is_NaN(y)))
- wrong_type_argument_with_type(sc, sc->REMAINDER, 2, set_elist_1(sc, make_real(sc, y)), A_NORMAL_REAL);
+ wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, set_elist_1(sc, make_real(sc, y)), a_normal_real_string);
pre_quo = x / y;
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- simple_out_of_range(sc, sc->REMAINDER, set_elist_2(sc, make_real(sc, x), make_real(sc, y)), ITS_TOO_LARGE);
+ simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)), its_too_large_string);
if (pre_quo > 0.0)
quo = (s7_int)floor(pre_quo);
else quo = (s7_int)ceil(pre_quo);
@@ -15665,7 +15781,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
#define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1"
#define Q_remainder pcl_r
- /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib */
+ /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */
s7_pointer x, y;
s7_int quo, d1, d2, n1, n2;
@@ -15691,18 +15807,18 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
case T_REAL:
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->REMAINDER, args));
+ return(division_by_zero_error(sc, sc->remainder_symbol, args));
if ((is_inf(real(y))) || (is_NaN(real(y))))
- return(wrong_type_argument_with_type(sc, sc->REMAINDER, 2, y, A_NORMAL_REAL));
+ return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string));
pre_quo = (s7_double)integer(x) / real(y);
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
return(make_real(sc, integer(x) - real(y) * quo));
default:
- method_or_bust(sc, y, sc->REMAINDER, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
}
case T_RATIO:
@@ -15711,7 +15827,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
case T_INTEGER:
n2 = integer(y);
if (n2 == 0)
- return(division_by_zero_error(sc, sc->REMAINDER, args));
+ return(division_by_zero_error(sc, sc->remainder_symbol, args));
n1 = numerator(x);
d1 = denominator(x);
d2 = 1;
@@ -15738,7 +15854,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
pre_quo = ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1);
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
}
else quo = n1d2 / n2d1;
@@ -15748,7 +15864,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
pre_quo = ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1);
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
}
else quo = (n1 * d2) / (n2 * d1);
@@ -15784,39 +15900,39 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
(integer_length(n2) + integer_length(d1) + integer_length(quo) < s7_int_bits))
return(s7_make_ratio(sc, n1 * d2 - n2 * d1 * quo, d1 * d2));
#endif
- return(simple_out_of_range(sc, sc->REMAINDER, args, make_string_wrapper(sc, "intermediate (a/b) is too large")));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, make_string_wrapper(sc, "intermediate (a/b) is too large")));
case T_REAL:
{
s7_double frac;
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->REMAINDER, args));
+ return(division_by_zero_error(sc, sc->remainder_symbol, args));
if ((is_inf(real(y))) || (is_NaN(real(y))))
- return(wrong_type_argument_with_type(sc, sc->REMAINDER, 2, y, A_NORMAL_REAL));
+ return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string));
frac = (s7_double)fraction(x);
pre_quo = frac / real(y);
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
return(make_real(sc, frac - real(y) * quo));
}
default:
- method_or_bust(sc, y, sc->REMAINDER, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
}
case T_REAL:
if ((is_inf(real(x))) || (is_NaN(real(x))))
- return(wrong_type_argument_with_type(sc, sc->REMAINDER, 1, x, A_NORMAL_REAL));
+ return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 1, x, a_normal_real_string));
switch (type(y))
{
case T_INTEGER:
if (integer(y) == 0)
- return(division_by_zero_error(sc, sc->REMAINDER, args));
+ return(division_by_zero_error(sc, sc->remainder_symbol, args));
pre_quo = real(x) / (s7_double)integer(y);
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
return(make_real(sc, real(x) - integer(y) * quo));
/* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */
@@ -15830,7 +15946,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
frac = (s7_double)fraction(y);
pre_quo = real(x) / frac;
if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
- return(simple_out_of_range(sc, sc->REMAINDER, args, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
return(make_real(sc, real(x) - frac * quo));
}
@@ -15848,11 +15964,11 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
*/
default:
- method_or_bust(sc, y, sc->REMAINDER, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
}
default:
- method_or_bust(sc, x, sc->REMAINDER, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->remainder_symbol, args, T_REAL, 1);
}
}
@@ -15870,7 +15986,7 @@ RF2_TO_RF(remainder, c_rem_dbl)
static s7_pointer g_floor(s7_scheme *sc, s7_pointer args)
{
#define H_floor "(floor x) returns the integer closest to x toward -inf"
- #define Q_floor s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
s7_pointer x;
@@ -15896,16 +16012,16 @@ static s7_pointer g_floor(s7_scheme *sc, s7_pointer args)
s7_double z;
z = real(x);
if (is_NaN(z))
- return(simple_out_of_range(sc, sc->FLOOR, x, ITS_NAN));
+ return(simple_out_of_range(sc, sc->floor_symbol, x, its_nan_string));
if (fabs(z) > REAL_TO_INT_LIMIT)
- return(simple_out_of_range(sc, sc->FLOOR, x, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->floor_symbol, x, its_too_large_string));
return(make_integer(sc, (s7_int)floor(z)));
/* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */
}
case T_COMPLEX:
default:
- method_or_bust(sc, x, sc->FLOOR, args, T_REAL, 0);
+ method_or_bust(sc, x, sc->floor_symbol, args, T_REAL, 0);
}
}
@@ -15917,7 +16033,7 @@ RF_TO_IF(floor, c_floor)
static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
{
#define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
- #define Q_ceiling s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
s7_pointer x;
@@ -15941,17 +16057,17 @@ static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
s7_double z;
z = real(x);
if (is_NaN(z))
- return(simple_out_of_range(sc, sc->CEILING, x, ITS_NAN));
+ return(simple_out_of_range(sc, sc->ceiling_symbol, x, its_nan_string));
if ((is_inf(z)) ||
(z > REAL_TO_INT_LIMIT) ||
(z < -REAL_TO_INT_LIMIT))
- return(simple_out_of_range(sc, sc->CEILING, x, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->ceiling_symbol, x, its_too_large_string));
return(make_integer(sc, (s7_int)ceil(real(x))));
}
case T_COMPLEX:
default:
- method_or_bust(sc, x, sc->CEILING, args, T_REAL, 0);
+ method_or_bust(sc, x, sc->ceiling_symbol, args, T_REAL, 0);
}
}
@@ -15963,7 +16079,7 @@ RF_TO_IF(ceiling, c_ceiling)
static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args)
{
#define H_truncate "(truncate x) returns the integer closest to x toward 0"
- #define Q_truncate s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
s7_pointer x;
x = car(args);
@@ -15980,22 +16096,22 @@ static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args)
s7_double z;
z = real(x);
if (is_NaN(z))
- return(simple_out_of_range(sc, sc->TRUNCATE, x, ITS_NAN));
+ return(simple_out_of_range(sc, sc->truncate_symbol, x, its_nan_string));
if (is_inf(z))
- return(simple_out_of_range(sc, sc->TRUNCATE, x, ITS_INFINITE));
- return(s7_truncate(sc, sc->TRUNCATE, real(x)));
+ return(simple_out_of_range(sc, sc->truncate_symbol, x, its_infinite_string));
+ return(s7_truncate(sc, sc->truncate_symbol, real(x)));
}
case T_COMPLEX:
default:
- method_or_bust(sc, x, sc->TRUNCATE, args, T_REAL, 0);
+ method_or_bust(sc, x, sc->truncate_symbol, args, T_REAL, 0);
}
}
static s7_int c_trunc(s7_scheme *sc, s7_double x)
{
if ((x > s7_int_max) || (x < s7_int_min))
- simple_out_of_range(sc, sc->TRUNCATE, make_real(sc, x), ITS_TOO_LARGE);
+ simple_out_of_range(sc, sc->truncate_symbol, make_real(sc, x), its_too_large_string);
if (x > 0.0)
return((s7_int)floor(x));
return((s7_int)ceil(x));
@@ -16023,7 +16139,7 @@ static s7_double round_per_R5RS(s7_double x)
static s7_pointer g_round(s7_scheme *sc, s7_pointer args)
{
#define H_round "(round x) returns the integer closest to x"
- #define Q_round s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
s7_pointer x;
x = car(args);
@@ -16057,17 +16173,17 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args)
s7_double z;
z = real(x);
if (is_NaN(z))
- return(simple_out_of_range(sc, sc->ROUND, x, ITS_NAN));
+ return(simple_out_of_range(sc, sc->round_symbol, x, its_nan_string));
if ((is_inf(z)) ||
(z > REAL_TO_INT_LIMIT) ||
(z < -REAL_TO_INT_LIMIT))
- return(simple_out_of_range(sc, sc->ROUND, x, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->round_symbol, x, its_too_large_string));
return(make_integer(sc, (s7_int)round_per_R5RS(z)));
}
case T_COMPLEX:
default:
- method_or_bust(sc, x, sc->ROUND, args, T_REAL, 0);
+ method_or_bust(sc, x, sc->round_symbol, args, T_REAL, 0);
}
}
@@ -16129,7 +16245,7 @@ static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
return(make_real(sc, a - b * (s7_int)floor(a / b)));
default:
- method_or_bust(sc, y, sc->MODULO, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
}
case T_RATIO:
@@ -16145,7 +16261,7 @@ static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x);
if (n2 == s7_int_min)
- return(simple_out_of_range(sc, sc->MODULO, y, make_string_wrapper(sc, "intermediate (a/b) is too large")));
+ return(simple_out_of_range(sc, sc->modulo_symbol, y, make_string_wrapper(sc, "intermediate (a/b) is too large")));
/* the problem here is that (modulo 3/2 most-negative-fixnum)
* will segfault with signal SIGFPE, Arithmetic exception, so try to trap it.
*/
@@ -16222,7 +16338,7 @@ static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
* (modulo 9223372036 1/9223372036) -> error, not 0?
* (modulo 1 1/9223372036854775807) -> error, not 0?
*/
- return(simple_out_of_range(sc, sc->MODULO, x, make_string_wrapper(sc, "intermediate (a/b) is too large")));
+ return(simple_out_of_range(sc, sc->modulo_symbol, x, make_string_wrapper(sc, "intermediate (a/b) is too large")));
case T_REAL:
b = real(y);
@@ -16233,7 +16349,7 @@ static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
return(make_real(sc, a - b * (s7_int)floor(a / b)));
default:
- method_or_bust(sc, y, sc->MODULO, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
}
case T_REAL:
@@ -16264,11 +16380,11 @@ static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
return(make_real(sc, a - b * (s7_int)floor(a / b)));
default:
- method_or_bust(sc, y, sc->MODULO, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
}
default:
- method_or_bust(sc, x, sc->MODULO, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->modulo_symbol, args, T_REAL, 1);
}
}
@@ -16308,7 +16424,7 @@ static s7_pointer g_mod_si(s7_scheme *sc, s7_pointer args)
if (s7_is_ratio(x))
return(g_modulo(sc, set_plist_2(sc, x, cadr(args))));
- method_or_bust(sc, x, sc->MODULO, list_2(sc, x, cadr(args)), T_REAL, 1);
+ method_or_bust(sc, x, sc->modulo_symbol, list_2(sc, x, cadr(args)), T_REAL, 1);
}
static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args);
@@ -16333,10 +16449,10 @@ static s7_pointer g_mod_si_is_zero(s7_scheme *sc, s7_pointer args)
{
s7_pointer func;
- if ((func = find_method(sc, find_let(sc, x), sc->MODULO)) != sc->UNDEFINED)
+ if ((func = find_method(sc, find_let(sc, x), sc->modulo_symbol)) != sc->undefined)
return(g_is_zero(sc, set_plist_1(sc, s7_apply_function(sc, func, list_2(sc, x, caddar(args))))));
}
- return(wrong_type_argument(sc, sc->MODULO, 1, x, T_REAL));
+ return(wrong_type_argument(sc, sc->modulo_symbol, 1, x, T_REAL));
}
#endif
/* !WITH_GMP */
@@ -16415,7 +16531,7 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
if (is_null(p))
{
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->ADD, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 0);
return(x);
}
@@ -16520,7 +16636,7 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
goto ADD_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->ADD, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -16642,7 +16758,7 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
goto ADD_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->ADD, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -16677,7 +16793,7 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
goto ADD_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->ADD, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -16715,12 +16831,12 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
goto ADD_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->ADD, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
default:
- method_or_bust_with_type(sc, x, sc->ADD, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
}
}
@@ -16796,8 +16912,8 @@ static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
case T_COMPLEX: return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
default:
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->ADD, args, A_NUMBER, 1);
- method_or_bust_with_type(sc, y, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
+ method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
}
}
}
@@ -16812,7 +16928,7 @@ static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, integer(x) + real(y)));
case T_COMPLEX: return(make_complex(sc, integer(x) + real_part(y), imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
}
case T_RATIO:
@@ -16823,7 +16939,7 @@ static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, fraction(x) + real(y)));
case T_COMPLEX: return(s7_make_complex(sc, fraction(x) + real_part(y), imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
}
case T_REAL:
@@ -16834,7 +16950,7 @@ static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + real(y)));
case T_COMPLEX: return(make_complex(sc, real(x) + real_part(y), imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
}
case T_COMPLEX:
@@ -16845,11 +16961,11 @@ static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(s7_make_complex(sc, real_part(x) + real(y), imag_part(x)));
case T_COMPLEX: return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
}
default:
- method_or_bust_with_type(sc, x, sc->ADD, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
}
return(x);
}
@@ -16873,7 +16989,7 @@ static s7_pointer g_add_s1_1(s7_scheme *sc, s7_pointer x, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + 1.0));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->ADD, cons(sc, x, cdr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, x, cdr(args)), a_number_string, 1);
}
return(x);
}
@@ -16918,7 +17034,7 @@ static s7_pointer g_add_1s(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + 1.0));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->ADD, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 2);
}
return(x);
}
@@ -16948,7 +17064,7 @@ static s7_pointer g_add_si(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->ADD, list_2(sc, x, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
}
return(x);
}
@@ -16967,7 +17083,7 @@ static s7_pointer g_add_sf(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->ADD, list_2(sc, x, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
}
return(x);
}
@@ -16986,7 +17102,7 @@ static s7_pointer g_add_fs(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) + n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->ADD, list_2(sc, x, car(args)), A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, car(args)), a_number_string, 2);
}
return(x);
}
@@ -17015,9 +17131,9 @@ static s7_pointer g_add_f_sf(s7_scheme *sc, s7_pointer args)
default:
{
s7_pointer func;
- if ((func = find_method(sc, find_let(sc, s), sc->MULTIPLY)) != sc->UNDEFINED)
+ if ((func = find_method(sc, find_let(sc, s), sc->multiply_symbol)) != sc->undefined)
return(g_add_2(sc, set_plist_2(sc, car(args), s7_apply_function(sc, func, list_2(sc, s, cadr(vargs))))));
- return(wrong_type_argument_with_type(sc, sc->MULTIPLY, 1, s, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 1, s, a_number_string));
}
}
return(s);
@@ -17519,7 +17635,7 @@ static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
if (is_null(p))
{
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 0);
return(s7_negate(sc, x));
}
#endif
@@ -17617,7 +17733,7 @@ static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
goto SUBTRACT_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -17737,7 +17853,7 @@ static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
goto SUBTRACT_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -17772,7 +17888,7 @@ static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
goto SUBTRACT_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -17810,12 +17926,12 @@ static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
goto SUBTRACT_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
}
}
@@ -17847,7 +17963,7 @@ static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, -real_part(p), -imag_part(p)));
default:
- method_or_bust_with_type(sc, p, sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, p, sc->subtract_symbol, args, a_number_string, 1);
}
}
@@ -17882,8 +17998,8 @@ static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
case T_COMPLEX: return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
default:
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 1);
- method_or_bust_with_type(sc, y, sc->SUBTRACT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
+ method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
}
}
}
@@ -17898,7 +18014,7 @@ static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, integer(x) - real(y)));
case T_COMPLEX: return(make_complex(sc, integer(x) - real_part(y), -imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->SUBTRACT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
}
case T_RATIO:
@@ -17909,7 +18025,7 @@ static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, fraction(x) - real(y)));
case T_COMPLEX: return(s7_make_complex(sc, fraction(x) - real_part(y), -imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->SUBTRACT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
}
case T_REAL:
@@ -17920,7 +18036,7 @@ static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - real(y)));
case T_COMPLEX: return(make_complex(sc, real(x) - real_part(y), -imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->SUBTRACT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
}
case T_COMPLEX:
@@ -17931,11 +18047,11 @@ static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(s7_make_complex(sc, real_part(x) - real(y), imag_part(x)));
case T_COMPLEX: return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->SUBTRACT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
}
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
}
return(x);
}
@@ -17965,7 +18081,7 @@ static s7_pointer g_subtract_cs1(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - 1.0));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - 1.0, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, list_2(sc, x, small_int(1)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, small_int(1)), a_number_string, 1);
}
return(x);
}
@@ -17992,7 +18108,7 @@ static s7_pointer g_subtract_s1(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - 1.0));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - 1.0, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
}
return(x);
}
@@ -18024,7 +18140,7 @@ static s7_pointer g_subtract_csn(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, list_2(sc, x, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
}
return(x);
}
@@ -18044,7 +18160,7 @@ static s7_pointer g_subtract_sf(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, list_2(sc, x, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
}
return(x);
}
@@ -18064,7 +18180,7 @@ static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) - n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
}
return(x);
}
@@ -18084,7 +18200,7 @@ static s7_pointer g_subtract_fs(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, n - real(x)));
case T_COMPLEX: return(s7_make_complex(sc, n - real_part(x), -imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->SUBTRACT, list_2(sc, car(args), x), A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, car(args), x), a_number_string, 2);
}
return(x);
}
@@ -18112,9 +18228,9 @@ static s7_pointer g_subtract_f_sqr(s7_scheme *sc, s7_pointer args)
*/
{
s7_pointer func;
- if ((func = find_method(sc, find_let(sc, x), sc->MULTIPLY)) != sc->UNDEFINED)
+ if ((func = find_method(sc, find_let(sc, x), sc->multiply_symbol)) != sc->undefined)
return(g_subtract_2(sc, set_plist_2(sc, car(args), s7_apply_function(sc, func, list_2(sc, x, x)))));
- return(wrong_type_argument_with_type(sc, sc->MULTIPLY, 1, x, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 1, x, a_number_string));
}
}
return(x);
@@ -18593,7 +18709,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
if (is_null(p))
{
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->MULTIPLY, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 0);
return(x);
}
@@ -18687,7 +18803,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
goto MULTIPLY_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -18804,7 +18920,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -18839,7 +18955,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
goto MULTIPLY_COMPLEX;
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -18892,12 +19008,12 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
}
}
@@ -18942,8 +19058,8 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
}
default:
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->MULTIPLY, args, A_NUMBER, 1);
- method_or_bust_with_type(sc, y, sc->MULTIPLY, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
+ method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
}
}
}
@@ -18958,7 +19074,7 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, integer(x) * real(y)));
case T_COMPLEX: return(s7_make_complex(sc, integer(x) * real_part(y), integer(x) * imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->MULTIPLY, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
}
case T_RATIO:
@@ -18974,7 +19090,7 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, frac * real_part(y), frac * imag_part(y)));
}
default:
- method_or_bust_with_type(sc, y, sc->MULTIPLY, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
}
case T_REAL:
@@ -18985,7 +19101,7 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * real(y)));
case T_COMPLEX: return(s7_make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y)));
default:
- method_or_bust_with_type(sc, y, sc->MULTIPLY, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
}
case T_COMPLEX:
@@ -19009,11 +19125,11 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
return(s7_make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
}
default:
- method_or_bust_with_type(sc, y, sc->MULTIPLY, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
}
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
}
return(x);
}
@@ -19055,7 +19171,7 @@ static s7_pointer g_multiply_si(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, list_2(sc, x, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
}
return(x);
}
@@ -19092,7 +19208,7 @@ static s7_pointer g_multiply_is(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * n));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, list_2(sc, car(args), x), A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, car(args), x), a_number_string, 2);
}
return(x);
}
@@ -19112,7 +19228,7 @@ static s7_pointer g_multiply_fs(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * scl));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * scl, imag_part(x) * scl));
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, list_2(sc, car(args), x), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, car(args), x), a_number_string, 1);
}
return(x);
}
@@ -19132,7 +19248,7 @@ static s7_pointer g_multiply_sf(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * scl));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * scl, imag_part(x) * scl));
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, list_2(sc, x, cadr(args)), A_NUMBER, 2);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, cadr(args)), a_number_string, 2);
}
return(x);
}
@@ -19168,7 +19284,7 @@ static s7_pointer g_sqr_ss(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_real(sc, real(x) * real(x)));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
default:
- method_or_bust_with_type(sc, x, sc->MULTIPLY, list_2(sc, x, x), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, x), a_number_string, 1);
}
return(x);
}
@@ -19199,16 +19315,16 @@ static s7_pointer g_mul_1ss(s7_scheme *sc, s7_pointer args)
if (!is_number(x))
{
s7_pointer func;
- if ((func = find_method(sc, find_let(sc, x), sc->SUBTRACT)) != sc->UNDEFINED)
+ if ((func = find_method(sc, find_let(sc, x), sc->subtract_symbol)) != sc->undefined)
return(g_multiply_2(sc, set_plist_2(sc, s7_apply_function(sc, func, list_2(sc, real_one, x)), y)));
- return(wrong_type_argument_with_type(sc, sc->SUBTRACT, 2, x, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->subtract_symbol, 2, x, a_number_string));
}
if (!is_number(y))
{
s7_pointer func;
- if ((func = find_method(sc, find_let(sc, y), sc->MULTIPLY)) != sc->UNDEFINED)
+ if ((func = find_method(sc, find_let(sc, y), sc->multiply_symbol)) != sc->undefined)
return(s7_apply_function(sc, func, list_2(sc, g_subtract(sc, list_2(sc, real_one, x)), y)));
- return(wrong_type_argument_with_type(sc, sc->MULTIPLY, 2, y, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 2, y, a_number_string));
}
r1 = 1.0 - s7_real_part(x);
@@ -19714,9 +19830,9 @@ static bool is_number_via_method(s7_scheme *sc, s7_pointer p)
if (has_methods(p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->IS_NUMBER);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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);
}
@@ -19735,9 +19851,9 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
if (is_null(p))
{
if (!is_number(x))
- method_or_bust_with_type(sc, x, sc->DIVIDE, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, args, a_number_string, 0);
if (s7_is_zero(x))
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
return(s7_invert(sc, x));
}
@@ -19756,10 +19872,10 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
n = check_values(sc, n, p);
if (!s7_is_number(n))
- return(wrong_type_argument_with_type(sc, sc->DIVIDE, position_of(p, args), n, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->divide_symbol, position_of(p, args), n, a_number_string));
}
if (s7_is_zero(n))
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
if (type(n) > T_RATIO)
{
return_real_zero = true;
@@ -19787,7 +19903,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
case T_INTEGER:
if (integer(x) == 0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
/* to be consistent, I suppose we should search first for NaNs in the divisor list.
* (* 0 0/0) is NaN, so (/ 1 0 0/0) should equal (/ 1 0/0) = NaN. But the whole
@@ -19832,7 +19948,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
case T_REAL:
rl_a = (s7_double)num_a;
if (real(x) == 0.0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
if (is_null(p)) return(make_real(sc, rl_a / real(x)));
rl_a /= real(x);
goto DIVIDE_REALS;
@@ -19856,7 +19972,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->DIVIDE, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -19877,7 +19993,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
case T_INTEGER:
if (integer(x) == 0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
#if HAVE_OVERFLOW_CHECKS
{
s7_int dn;
@@ -19967,7 +20083,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
s7_double r1;
if (real(x) == 0.0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
r1 = ((long double)num_a / (long double)den_a);
if (is_null(p)) return(make_real(sc, r1 / real(x)));
rl_a = r1 / real(x);
@@ -19989,7 +20105,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->DIVIDE, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -20006,10 +20122,10 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
n = check_values(sc, n, p);
if (!s7_is_number(n))
- return(wrong_type_argument_with_type(sc, sc->DIVIDE, position_of(p, args), n, A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->divide_symbol, position_of(p, args), n, a_number_string));
}
if (s7_is_zero(n))
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
if ((is_t_real(n)) &&
(is_NaN(real(n))))
return_nan = true;
@@ -20027,7 +20143,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
case T_INTEGER:
if (integer(x) == 0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
if (is_null(p)) return(make_real(sc, rl_a / integer(x)));
rl_a /= (s7_double)integer(x);
goto DIVIDE_REALS;
@@ -20039,7 +20155,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
case T_REAL:
if (real(x) == 0.0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
if (is_null(p)) return(make_real(sc, rl_a / real(x)));
rl_a /= real(x);
goto DIVIDE_REALS;
@@ -20058,7 +20174,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->DIVIDE, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
@@ -20076,7 +20192,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
s7_double r1;
if (integer(x) == 0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
r1 = 1.0 / (s7_double)integer(x);
if (is_null(p)) return(s7_make_complex(sc, rl_a * r1, im_a * r1));
rl_a *= r1;
@@ -20098,7 +20214,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
s7_double r1;
if (real(x) == 0.0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
r1 = 1.0 / real(x);
if (is_null(p)) return(s7_make_complex(sc, rl_a * r1, im_a * r1));
rl_a *= r1;
@@ -20122,12 +20238,12 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, x, sc->DIVIDE, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
break;
default:
- method_or_bust_with_type(sc, x, sc->DIVIDE, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->divide_symbol, args, a_number_string, 1);
}
}
@@ -20144,7 +20260,7 @@ static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args)
case T_INTEGER:
if (integer(p) != 0)
return(s7_make_ratio(sc, 1, integer(p))); /* a already checked, not 0 */
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
case T_RATIO:
return(s7_make_ratio(sc, denominator(p), numerator(p)));
@@ -20152,7 +20268,7 @@ static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args)
case T_REAL:
if (real(p) != 0.0)
return(make_real(sc, 1.0 / real(p)));
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
case T_COMPLEX:
{
@@ -20164,7 +20280,7 @@ static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, p, sc->DIVIDE, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, p, sc->divide_symbol, args, a_number_string, 1);
}
}
@@ -20177,7 +20293,7 @@ static s7_pointer g_divide_1r(s7_scheme *sc, s7_pointer args)
s7_double rl;
rl = real_to_double(sc, cadr(args), "/");
if (rl == 0.0)
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
return(make_real(sc, 1.0 / rl));
}
return(g_divide(sc, args));
@@ -20186,13 +20302,13 @@ static s7_pointer g_divide_1r(s7_scheme *sc, s7_pointer args)
static s7_double c_dbl_invert(s7_scheme *sc, s7_double x)
{
- if (x == 0.0) division_by_zero_error(sc, sc->DIVIDE, set_elist_1(sc, real_zero));
+ if (x == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_1(sc, real_zero));
return(1.0 / x);
}
static s7_double c_dbl_divide_2(s7_scheme *sc, s7_double x, s7_double y)
{
- if (y == 0.0) division_by_zero_error(sc, sc->DIVIDE, set_elist_2(sc, make_real(sc, x), real_zero));
+ if (y == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, make_real(sc, x), real_zero));
return(x / y);
}
@@ -20200,7 +20316,7 @@ static s7_double c_dbl_divide_3(s7_scheme *sc, s7_double x, s7_double y, s7_doub
{
s7_double d;
d = y * z;
- if (d == 0.0) division_by_zero_error(sc, sc->DIVIDE, set_elist_3(sc, make_real(sc, x), make_real(sc, y), make_real(sc, z)));
+ if (d == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_3(sc, make_real(sc, x), make_real(sc, y), make_real(sc, z)));
return(x / d);
}
@@ -20213,9 +20329,9 @@ RF_3_TO_RF(divide, c_dbl_invert, c_dbl_divide_2, c_dbl_divide_3)
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);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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);
}
@@ -20240,6 +20356,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
if (is_null(p)) return(x);
y = car(p);
p = cdr(p);
+ /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(x), DISPLAY(y)); */
switch (type(y))
{
@@ -20259,7 +20376,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
if (integer(x) < real(y))
@@ -20270,7 +20387,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
goto MAX_INTEGERS;
default:
- method_or_bust(sc, y, sc->MAX, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -20279,6 +20396,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
if (is_null(p)) return(x);
y = car(p);
p = cdr(p);
+ /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(x), DISPLAY(y)); */
switch (type(y))
{
@@ -20317,37 +20435,46 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
* (max #i9223372036854776/9223372036854775807 9223372036854775/9223372036854775000)
* I guess if the user is using "inexact" numbers (#i...), he accepts their inexactness.
*/
-
- if (den_a == den_b)
- {
- if (num_a < num_b)
- x = y;
- }
+
+ if ((num_a < 0) && (num_b >= 0)) /* x < 0, y >= 0 -> y */
+ x = y;
else
{
- if (num_a == num_b)
- {
- if (((num_a >= 0) &&
- (den_a > den_b)) ||
- ((num_a < 0) &&
- (den_a < den_b)))
- x = y;
- }
- else
+ if ((num_a < 0) || (num_b >= 0))
{
- s7_int vala, valb;
- vala = num_a / den_a;
- valb = num_b / den_b;
-
- if (!((vala > valb) ||
- ((vala == valb) && (is_t_integer(y)))))
+ if (den_a == den_b)
{
- if ((valb > vala) ||
- ((vala == valb) && (is_t_integer(x))) ||
- /* sigh -- both are ratios and the int parts are equal */
- (((long double)(num_a % den_a) / (long double)den_a) <= ((long double)(num_b % den_b) / (long double)den_b)))
+ if (num_a < num_b)
x = y;
}
+ else
+ {
+ if (num_a == num_b)
+ {
+ if (((num_a >= 0) &&
+ (den_a > den_b)) ||
+ ((num_a < 0) &&
+ (den_a < den_b)))
+ x = y;
+ }
+ else
+ {
+ s7_int vala, valb;
+ vala = num_a / den_a;
+ valb = num_b / den_b;
+ /* fprintf(stderr, "val: %lld %lld %d %d\n", vala, valb, -1/2, 0); */
+
+ if (!((vala > valb) ||
+ ((vala == valb) && (is_t_integer(y)))))
+ {
+ if ((valb > vala) ||
+ ((vala == valb) && (is_t_integer(x))) ||
+ /* sigh -- both are ratios and the int parts are equal */
+ (((long double)(num_a % den_a) / (long double)den_a) <= ((long double)(num_b % den_b) / (long double)den_b)))
+ x = y;
+ }
+ }
+ }
}
}
if (is_t_ratio(x))
@@ -20360,7 +20487,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
@@ -20372,7 +20499,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
goto MAX_RATIOS;
default:
- method_or_bust(sc, y, sc->MAX, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -20381,7 +20508,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
return(x);
}
@@ -20413,18 +20540,18 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
if (real(x) < real(y)) x = y;
goto MAX_REALS;
default:
- method_or_bust(sc, y, sc->MAX, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->MAX, cons(sc, x, p), T_REAL, 1);
+ method_or_bust(sc, x, sc->max_symbol, cons(sc, x, p), T_REAL, 1);
}
}
@@ -20439,7 +20566,7 @@ static s7_pointer g_max_f2(s7_scheme *sc, s7_pointer args)
return((real(x) >= real(y)) ? x : y);
if (is_real(y))
return((real(x) >= real_to_double(sc, y, "max")) ? x : y);
- method_or_bust(sc, y, sc->MAX, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->max_symbol, args, T_REAL, 2);
}
#endif
@@ -20480,7 +20607,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
if (integer(x) > real(y))
@@ -20491,7 +20618,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
goto MIN_INTEGERS;
default:
- method_or_bust(sc, y, sc->MIN, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -20517,37 +20644,45 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
den_b = denominator(y);
RATIO_MIN_RATIO:
- if (den_a == den_b)
- {
- if (num_a > num_b)
- x = y;
- }
- else
- {
- if (num_a == num_b)
- {
- if (((num_a >= 0) &&
- (den_a < den_b)) ||
- ((num_a < 0) &&
- (den_a > den_b)))
- x = y;
- }
- else
- {
- s7_int vala, valb;
- vala = num_a / den_a;
- valb = num_b / den_b;
-
- if (!((vala < valb) ||
- ((vala == valb) && (is_t_integer(x)))))
- {
- if ((valb < vala) ||
- ((vala == valb) && (is_t_integer(y))) ||
- (((long double)(num_a % den_a) / (long double)den_a) >= ((long double)(num_b % den_b) / (long double)den_b)))
- x = y;
- }
- }
- }
+ if ((num_a >= 0) && (num_b < 0))
+ x = y;
+ else
+ {
+ if ((num_a >= 0) || (num_b < 0))
+ {
+ if (den_a == den_b)
+ {
+ if (num_a > num_b)
+ x = y;
+ }
+ else
+ {
+ if (num_a == num_b)
+ {
+ if (((num_a >= 0) &&
+ (den_a < den_b)) ||
+ ((num_a < 0) &&
+ (den_a > den_b)))
+ x = y;
+ }
+ else
+ {
+ s7_int vala, valb;
+ vala = num_a / den_a;
+ valb = num_b / den_b;
+
+ if (!((vala < valb) ||
+ ((vala == valb) && (is_t_integer(x)))))
+ {
+ if ((valb < vala) ||
+ ((vala == valb) && (is_t_integer(y))) ||
+ (((long double)(num_a % den_a) / (long double)den_a) >= ((long double)(num_b % den_b) / (long double)den_b)))
+ x = y;
+ }
+ }
+ }
+ }
+ }
if (is_t_ratio(x))
goto MIN_RATIOS;
goto MIN_INTEGERS;
@@ -20558,7 +20693,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
if (fraction(x) > real(y))
@@ -20569,7 +20704,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
goto MIN_RATIOS;
default:
- method_or_bust(sc, y, sc->MIN, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -20578,7 +20713,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
return(x);
}
@@ -20610,18 +20745,18 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
for (; is_not_null(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
return(y);
}
if (real(x) > real(y)) x = y;
goto MIN_REALS;
default:
- method_or_bust(sc, y, sc->MIN, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->MIN, cons(sc, x, p), T_REAL, 1);
+ method_or_bust(sc, x, sc->min_symbol, cons(sc, x, p), T_REAL, 1);
}
}
@@ -20636,7 +20771,7 @@ static s7_pointer g_min_f2(s7_scheme *sc, s7_pointer args)
return((real(x) <= real(y)) ? x : y);
if (is_real(y))
return((real(x) <= real_to_double(sc, y, "min")) ? x : y);
- method_or_bust(sc, y, sc->MIN, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->min_symbol, args, T_REAL, 2);
}
static s7_int c_max_i1(s7_scheme *sc, s7_int x) {return(x);}
@@ -20667,7 +20802,7 @@ RF_3_TO_RF(min, c_min_r1, c_min_r2, c_min_r3)
static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
{
#define H_equal "(= z1 ...) returns #t if all its arguments are equal"
- #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_NUMBER)
+ #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)
s7_pointer x, p;
s7_int num_a, den_a;
s7_double rl_a, im_a;
@@ -20698,7 +20833,7 @@ static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust_with_type(sc, x, sc->EQ, cons(sc, make_integer(sc, num_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
if (is_null(p))
return(sc->T);
@@ -20729,7 +20864,7 @@ static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust_with_type(sc, x, sc->EQ, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
if (is_null(p))
return(sc->T);
@@ -20763,7 +20898,7 @@ static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
goto NOT_EQUAL;
default:
- method_or_bust_with_type(sc, x, sc->EQ, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
if (is_null(p))
return(sc->T);
@@ -20790,20 +20925,20 @@ static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust_with_type(sc, x, sc->EQ, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), A_NUMBER, position_of(p, args) - 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
}
if (is_null(p))
return(sc->T);
}
default:
- method_or_bust_with_type(sc, x, sc->EQ, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, args, a_number_string, 1);
}
NOT_EQUAL:
for (; is_pair(p); p = cdr(p))
if (!is_number_via_method(sc, car(p)))
- return(wrong_type_argument_with_type(sc, sc->EQ, position_of(p, args), car(p), A_NUMBER));
+ return(wrong_type_argument_with_type(sc, sc->eq_symbol, position_of(p, args), car(p), a_number_string));
return(sc->F);
}
@@ -20827,7 +20962,7 @@ static s7_pointer g_equal_s_ic(s7_scheme *sc, s7_pointer args)
case T_REAL: return(make_boolean(sc, real(val) == y));
case T_COMPLEX: return(sc->F);
default:
- method_or_bust_with_type(sc, val, sc->EQ, list_2(sc, val, cadr(args)), A_NUMBER, 1);
+ method_or_bust_with_type(sc, val, sc->eq_symbol, list_2(sc, val, cadr(args)), a_number_string, 1);
}
return(sc->T);
}
@@ -20858,7 +20993,7 @@ static s7_pointer g_equal_length_ic(s7_scheme *sc, s7_pointer args)
case T_VECTOR: return(make_boolean(sc, vector_length(val) == ilen));
case T_CLOSURE:
case T_CLOSURE_STAR: if (has_methods(val)) return(make_boolean(sc, closure_length(sc, val) == ilen));
- default: return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, val, A_SEQUENCE));
+ default: return(simple_wrong_type_argument_with_type(sc, sc->length_symbol, val, a_sequence_string));
/* here we already lost because we checked for the length above */
}
return(sc->F);
@@ -20878,7 +21013,7 @@ static s7_pointer c_equal_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
case T_REAL: return(make_boolean(sc, integer(x) == real(y)));
case T_COMPLEX: return(sc->F);
default:
- method_or_bust_with_type(sc, y, sc->EQ, list_2(sc, x, y), A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
}
break;
@@ -20890,7 +21025,7 @@ static s7_pointer c_equal_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
case T_REAL: return(make_boolean(sc, fraction(x) == real(y))); /* this could avoid the divide via numerator == denominator * x */
case T_COMPLEX: return(sc->F);
default:
- method_or_bust_with_type(sc, y, sc->EQ, list_2(sc, x, y), A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
}
break;
@@ -20902,7 +21037,7 @@ static s7_pointer c_equal_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
case T_REAL: return(make_boolean(sc, real(x) == real(y)));
case T_COMPLEX: return(sc->F);
default:
- method_or_bust_with_type(sc, y, sc->EQ, list_2(sc, x, y), A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
}
break;
@@ -20922,12 +21057,12 @@ static s7_pointer c_equal_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
if ((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))) return(sc->T); else return(sc->F);
#endif
default:
- method_or_bust_with_type(sc, y, sc->EQ, list_2(sc, x, y), A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
}
break;
default:
- method_or_bust_with_type(sc, x, sc->EQ, list_2(sc, x, y), A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->eq_symbol, list_2(sc, x, y), a_number_string, 1);
}
return(sc->F);
}
@@ -21057,7 +21192,7 @@ static s7_pf_t equal_pf(s7_scheme *sc, s7_pointer expr)
static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
{
#define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
- #define Q_less s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x, y, p;
@@ -21110,7 +21245,7 @@ static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
goto REAL_LESS;
default:
- method_or_bust(sc, y, sc->LT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21215,7 +21350,7 @@ static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
goto REAL_LESS;
default:
- method_or_bust(sc, y, sc->LT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21247,17 +21382,17 @@ static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
goto REAL_LESS;
default:
- method_or_bust(sc, y, sc->LT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->LT, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
}
NOT_LESS:
for (; is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->LT, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->lt_symbol, position_of(p, args), car(p), T_REAL));
return(sc->F);
}
@@ -21266,7 +21401,7 @@ static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
{
#define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in increasing order"
- #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x, y, p;
@@ -21319,7 +21454,7 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_LEQ;
default:
- method_or_bust(sc, y, sc->LEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21412,7 +21547,7 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_LEQ;
default:
- method_or_bust(sc, y, sc->LEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21444,17 +21579,17 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_LEQ;
default:
- method_or_bust(sc, y, sc->LEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->LEQ, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1);
}
NOT_LEQ:
for (; is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->LEQ, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->leq_symbol, position_of(p, args), car(p), T_REAL));
return(sc->F);
}
@@ -21463,7 +21598,7 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
{
#define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
- #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x, y, p;
x = car(args);
@@ -21515,7 +21650,7 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
goto REAL_GREATER;
default:
- method_or_bust(sc, y, sc->GT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21619,7 +21754,7 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
goto REAL_GREATER;
default:
- method_or_bust(sc, y, sc->GT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21651,17 +21786,17 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
goto REAL_GREATER;
default:
- method_or_bust(sc, y, sc->GT, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->GT, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->gt_symbol, args, T_REAL, 1);
}
NOT_GREATER:
for (; is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->GT, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->gt_symbol, position_of(p, args), car(p), T_REAL));
return(sc->F);
}
@@ -21670,7 +21805,7 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
{
#define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in decreasing order"
- #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
/* (>= 1+i 1+i) is an error which seems unfortunate */
s7_pointer x, y, p;
@@ -21723,7 +21858,7 @@ static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_GEQ;
default:
- method_or_bust(sc, y, sc->GEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21816,7 +21951,7 @@ static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_GEQ;
default:
- method_or_bust(sc, y, sc->GEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
@@ -21848,17 +21983,17 @@ static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
goto REAL_GEQ;
default:
- method_or_bust(sc, y, sc->GEQ, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
+ method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
}
default:
- method_or_bust(sc, x, sc->GEQ, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1);
}
NOT_GEQ:
for (; is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
- return(wrong_type_argument(sc, sc->GEQ, position_of(p, args), car(p), T_REAL));
+ return(wrong_type_argument(sc, sc->geq_symbol, position_of(p, args), car(p), T_REAL));
return(sc->F);
@@ -21874,7 +22009,7 @@ static s7_pointer g_less_s0(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, integer(x) < 0));
if (is_real(x))
return(make_boolean(sc, s7_is_negative(x)));
- method_or_bust(sc, x, sc->LT, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
}
static s7_pointer g_less_s_ic(s7_scheme *sc, s7_pointer args)
@@ -21906,7 +22041,7 @@ static s7_pointer g_less_s_ic(s7_scheme *sc, s7_pointer args)
case T_COMPLEX:
default:
- method_or_bust(sc, x, sc->LT, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
}
return(sc->T);
}
@@ -21925,7 +22060,7 @@ static s7_pointer g_less_length_ic(s7_scheme *sc, s7_pointer args)
case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) < ilen));
case T_NIL: return(make_boolean(sc, ilen > 0));
case T_STRING: return(make_boolean(sc, string_length(val) < ilen));
- case T_HASH_TABLE: return(make_boolean(sc, hash_table_mask(val) <= ilen));
+ case T_HASH_TABLE: return(make_boolean(sc, hash_table_mask(val) < ilen)); /* was <=? -- changed 15-Dec-15 */
case T_ITERATOR: return(make_boolean(sc, iterator_length(val) < ilen));
case T_C_OBJECT: return(make_boolean(sc, object_length_to_int(sc, val) < ilen));
case T_LET: return(make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */
@@ -21934,7 +22069,7 @@ static s7_pointer g_less_length_ic(s7_scheme *sc, s7_pointer args)
case T_VECTOR: return(make_boolean(sc, vector_length(val) < ilen));
case T_CLOSURE:
case T_CLOSURE_STAR: if (has_methods(val)) return(make_boolean(sc, closure_length(sc, val) < ilen));
- default: return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, val, A_SEQUENCE)); /* no check method here because we checked above */
+ default: return(simple_wrong_type_argument_with_type(sc, sc->length_symbol, val, a_sequence_string)); /* no check method here because we checked above */
}
return(sc->F);
}
@@ -21957,7 +22092,7 @@ static s7_pointer c_less_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, integer(x) < real(y)));
default:
- method_or_bust(sc, y, sc->LT, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->lt_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
@@ -21981,12 +22116,12 @@ static s7_pointer c_less_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, real(x) < real(y)));
default:
- method_or_bust(sc, y, sc->LT, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->lt_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
default:
- method_or_bust(sc, x, sc->LT, list_2(sc, x, y), T_REAL, 1);
+ method_or_bust(sc, x, sc->lt_symbol, list_2(sc, x, y), T_REAL, 1);
}
return(sc->T);
}
@@ -22061,7 +22196,7 @@ static s7_pointer g_leq_s_ic(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, real(x) <= y));
default:
- method_or_bust(sc, x, sc->LEQ, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1);
}
return(sc->T);
}
@@ -22085,7 +22220,7 @@ static s7_pointer c_leq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, integer(x) <= real(y)));
default:
- method_or_bust(sc, y, sc->LEQ, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->leq_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
@@ -22109,12 +22244,12 @@ static s7_pointer c_leq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, real(x) <= real(y)));
default:
- method_or_bust(sc, y, sc->LEQ, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->leq_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
default:
- method_or_bust(sc, x, sc->LEQ, list_2(sc, x, y), T_REAL, 1);
+ method_or_bust(sc, x, sc->leq_symbol, list_2(sc, x, y), T_REAL, 1);
}
return(sc->T);
}
@@ -22184,7 +22319,7 @@ static s7_pointer g_greater_s_ic(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, real(x) > y));
default:
- method_or_bust_with_type(sc, x, sc->GT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->gt_symbol, args, a_number_string, 1);
}
return(sc->T);
}
@@ -22215,7 +22350,7 @@ static s7_pointer g_greater_s_fc(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, real(x) > y));
default:
- method_or_bust_with_type(sc, x, sc->GT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->gt_symbol, args, a_number_string, 1);
}
return(sc->T);
}
@@ -22239,7 +22374,7 @@ static s7_pointer c_greater_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, integer(x) > real(y)));
default:
- method_or_bust(sc, y, sc->GT, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->gt_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
@@ -22263,12 +22398,12 @@ static s7_pointer c_greater_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, real(x) > real(y)));
default:
- method_or_bust(sc, y, sc->GT, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->gt_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
default:
- method_or_bust(sc, x, sc->GT, list_2(sc, x, y), T_REAL, 1);
+ method_or_bust(sc, x, sc->gt_symbol, list_2(sc, x, y), T_REAL, 1);
}
return(sc->T);
}
@@ -22341,7 +22476,7 @@ static s7_pointer c_geq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, integer(x) >= real(y)));
default:
- method_or_bust(sc, y, sc->GEQ, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->geq_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
@@ -22365,12 +22500,12 @@ static s7_pointer c_geq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(make_boolean(sc, real(x) >= real(y)));
default:
- method_or_bust(sc, y, sc->GEQ, list_2(sc, x, y), T_REAL, 2);
+ method_or_bust(sc, y, sc->geq_symbol, list_2(sc, x, y), T_REAL, 2);
}
break;
default:
- method_or_bust(sc, x, sc->GEQ, list_2(sc, x, y), T_REAL, 1);
+ method_or_bust(sc, x, sc->geq_symbol, list_2(sc, x, y), T_REAL, 1);
}
return(sc->T);
}
@@ -22474,7 +22609,7 @@ static s7_pointer g_geq_s_ic(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, real(x) >= y));
default:
- method_or_bust(sc, x, sc->GEQ, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1);
}
return(sc->T);
}
@@ -22518,7 +22653,7 @@ s7_double s7_imag_part(s7_pointer x)
static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
{
#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, sc->IS_NUMBER)
+ #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer p;
p = car(args);
@@ -22552,7 +22687,7 @@ static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
#endif
default:
- method_or_bust_with_type(sc, p, sc->REAL_PART, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->real_part_symbol, args, a_number_string, 0);
}
}
@@ -22565,7 +22700,7 @@ PF_TO_RF(real_part, c_real_part)
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, sc->IS_NUMBER)
+ #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 */
@@ -22603,7 +22738,7 @@ static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
#endif
default:
- method_or_bust_with_type(sc, p, sc->IMAG_PART, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->imag_part_symbol, args, a_number_string, 0);
}
}
@@ -22618,7 +22753,7 @@ PF_TO_RF(imag_part, c_imag_part)
static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args)
{
#define H_numerator "(numerator rat) returns the numerator of the rational number rat"
- #define Q_numerator s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_RATIONAL)
+ #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
s7_pointer x;
x = car(args);
@@ -22630,7 +22765,7 @@ static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args)
case T_BIG_INTEGER: return(x);
case T_BIG_RATIO: return(mpz_to_big_integer(sc, mpq_numref(big_ratio(x))));
#endif
- default: method_or_bust_with_type(sc, x, sc->NUMERATOR, args, A_RATIONAL, 0);
+ default: method_or_bust_with_type(sc, x, sc->numerator_symbol, args, a_rational_string, 0);
}
}
@@ -22643,7 +22778,7 @@ PF_TO_IF(numerator, c_numerator)
static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
{
#define H_denominator "(denominator rat) returns the denominator of the rational number rat"
- #define Q_denominator s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_RATIONAL)
+ #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
s7_pointer x;
x = car(args);
@@ -22655,7 +22790,7 @@ static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
case T_BIG_INTEGER: return(small_int(1));
case T_BIG_RATIO: return(mpz_to_big_integer(sc, mpq_denref(big_ratio(x))));
#endif
- default: method_or_bust_with_type(sc, x, sc->DENOMINATOR, args, A_RATIONAL, 0);
+ default: method_or_bust_with_type(sc, x, sc->denominator_symbol, args, a_rational_string, 0);
}
}
@@ -22699,7 +22834,7 @@ static s7_pointer g_is_nan(s7_scheme *sc, s7_pointer args)
#endif
default:
- method_or_bust_with_type(sc, x, sc->IS_NAN, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->is_nan_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -22743,7 +22878,7 @@ static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args)
#endif
default:
- method_or_bust_with_type(sc, x, sc->IS_INFINITE, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->is_infinite_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -22759,7 +22894,7 @@ static s7_pointer g_is_number(s7_scheme *sc, s7_pointer args)
{
#define H_is_number "(number? obj) returns #t if obj is a number"
#define Q_is_number pl_bt
- check_boolean_method(sc, s7_is_number, sc->IS_NUMBER, args); /* we need the s7_* versions here for the GMP case */
+ check_boolean_method(sc, s7_is_number, sc->is_number_symbol, args); /* we need the s7_* versions here for the GMP case */
}
@@ -22767,7 +22902,7 @@ static s7_pointer g_is_integer(s7_scheme *sc, s7_pointer args)
{
#define H_is_integer "(integer? obj) returns #t if obj is an integer"
#define Q_is_integer pl_bt
- check_boolean_method(sc, s7_is_integer, sc->IS_INTEGER, args);
+ check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args);
}
@@ -22775,7 +22910,7 @@ static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args)
{
#define H_is_real "(real? obj) returns #t if obj is a real number"
#define Q_is_real pl_bt
- check_boolean_method(sc, s7_is_real, sc->IS_REAL, args);
+ check_boolean_method(sc, s7_is_real, sc->is_real_symbol, args);
}
@@ -22783,7 +22918,7 @@ static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args)
{
#define H_is_complex "(complex? obj) returns #t if obj is a number"
#define Q_is_complex pl_bt
- check_boolean_method(sc, s7_is_number, sc->IS_COMPLEX, args);
+ check_boolean_method(sc, s7_is_number, sc->is_complex_symbol, args);
}
@@ -22791,7 +22926,7 @@ static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args)
{
#define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)"
#define Q_is_rational pl_bt
- check_boolean_method(sc, s7_is_rational, sc->IS_RATIONAL, args);
+ check_boolean_method(sc, s7_is_rational, sc->is_rational_symbol, args);
/* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t
* and similarly for exact? etc.
*/
@@ -22803,7 +22938,7 @@ static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args)
static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args)
{
#define H_is_even "(even? int) returns #t if the integer int is even"
- #define Q_is_even s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_INTEGER)
+ #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
s7_pointer p;
p = car(args);
@@ -22813,7 +22948,7 @@ static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args)
#if WITH_GMP
case T_BIG_INTEGER: return(make_boolean(sc, mpz_even_p(big_integer(p))));
#endif
- default: method_or_bust(sc, p, sc->IS_EVEN, list_1(sc, p), T_INTEGER, 0);
+ default: method_or_bust(sc, p, sc->is_even_symbol, list_1(sc, p), T_INTEGER, 0);
}
}
@@ -22826,7 +22961,7 @@ IF_TO_PF(is_even, c_is_even)
static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args)
{
#define H_is_odd "(odd? int) returns #t if the integer int is odd"
- #define Q_is_odd s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_INTEGER)
+ #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
s7_pointer p;
p = car(args);
@@ -22836,7 +22971,7 @@ static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args)
#if WITH_GMP
case T_BIG_INTEGER: return(make_boolean(sc, mpz_odd_p(big_integer(p))));
#endif
- default: method_or_bust(sc, p, sc->IS_ODD, list_1(sc, p), T_INTEGER, 0);
+ default: method_or_bust(sc, p, sc->is_odd_symbol, list_1(sc, p), T_INTEGER, 0);
}
}
@@ -22862,7 +22997,7 @@ static s7_pointer c_is_zero(s7_scheme *sc, s7_pointer x)
case T_BIG_COMPLEX: return(sc->F);
#endif
default:
- method_or_bust_with_type(sc, x, sc->IS_ZERO, list_1(sc, x), A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->is_zero_symbol, list_1(sc, x), a_number_string, 0);
}
}
@@ -22893,14 +23028,14 @@ static s7_pointer c_is_positive(s7_scheme *sc, s7_pointer x)
case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) > 0)));
#endif
default:
- method_or_bust(sc, x, sc->IS_POSITIVE, list_1(sc, x), T_REAL, 0);
+ method_or_bust(sc, x, sc->is_positive_symbol, list_1(sc, x), T_REAL, 0);
}
}
static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args)
{
#define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)"
- #define Q_is_positive s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
return(c_is_positive(sc, car(args)));
}
@@ -22924,14 +23059,14 @@ static s7_pointer c_is_negative(s7_scheme *sc, s7_pointer x)
case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) < 0)));
#endif
default:
- method_or_bust(sc, x, sc->IS_NEGATIVE, list_1(sc, x), T_REAL, 0);
+ method_or_bust(sc, x, sc->is_negative_symbol, list_1(sc, x), T_REAL, 0);
}
}
static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args)
{
#define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)"
- #define Q_is_negative s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
return(c_is_negative(sc, car(args)));
}
@@ -22998,7 +23133,7 @@ static s7_pointer g_exact_to_inexact(s7_scheme *sc, s7_pointer args)
static s7_pointer g_inexact_to_exact(s7_scheme *sc, s7_pointer args)
{
#define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2"
- #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->IS_RATIONAL, sc->IS_REAL)
+ #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_rational_symbol, sc->is_real_symbol)
return(inexact_to_exact(sc, car(args), WITH_OVERFLOW_ERROR));
}
#endif
@@ -23025,7 +23160,7 @@ static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args)
case T_BIG_COMPLEX: return(sc->F);
#endif
default:
- method_or_bust_with_type(sc, x, sc->IS_EXACT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->is_exact_symbol, args, a_number_string, 0);
}
}
@@ -23050,7 +23185,7 @@ static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args)
case T_BIG_COMPLEX: return(sc->T);
#endif
default:
- method_or_bust_with_type(sc, x, sc->IS_INEXACT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, x, sc->is_inexact_symbol, args, a_number_string, 0);
}
}
@@ -23067,7 +23202,7 @@ static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_integer(p))
- method_or_bust(sc, p, sc->INTEGER_LENGTH, args, T_INTEGER, 0);
+ method_or_bust(sc, p, sc->integer_length_symbol, args, T_INTEGER, 0);
x = s7_integer(p);
@@ -23087,7 +23222,7 @@ static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args)
{
#define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \
sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)"
- #define Q_integer_decode_float s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_FLOAT)
+ #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol)
/* no matter what s7_double is, integer-decode-float acts as if x is a C double */
@@ -23115,7 +23250,7 @@ sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)"
#endif
default:
- method_or_bust_with_type(sc, x, sc->INTEGER_DECODE_FLOAT, args, make_string_wrapper(sc, "a non-rational real"), 0);
+ method_or_bust_with_type(sc, x, sc->integer_decode_float_symbol, args, make_string_wrapper(sc, "a non-rational real"), 0);
}
if (num.value.fx == 0.0)
@@ -23139,7 +23274,7 @@ static s7_pointer g_logior(s7_scheme *sc, s7_pointer args)
for (x = args; is_not_null(x); x = cdr(x))
{
if (!s7_is_integer(car(x)))
- method_or_bust(sc, car(x), sc->LOGIOR, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->logior_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
result |= s7_integer(car(x));
}
return(make_integer(sc, result));
@@ -23162,7 +23297,7 @@ static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args)
for (x = args; is_not_null(x); x = cdr(x))
{
if (!s7_is_integer(car(x)))
- method_or_bust(sc, car(x), sc->LOGXOR, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->logxor_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
result ^= s7_integer(car(x));
}
return(make_integer(sc, result));
@@ -23185,7 +23320,7 @@ static s7_pointer g_logand(s7_scheme *sc, s7_pointer args)
for (x = args; is_not_null(x); x = cdr(x))
{
if (!s7_is_integer(car(x)))
- method_or_bust(sc, car(x), sc->LOGAND, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->logand_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
result &= s7_integer(car(x));
}
return(make_integer(sc, result));
@@ -23204,7 +23339,7 @@ static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args)
#define H_lognot "(lognot num) returns the bitwise negation (the complement, the bits that are not on) in num: (lognot 0) -> -1"
#define Q_lognot pcl_i
if (!s7_is_integer(car(args)))
- method_or_bust(sc, car(args), sc->LOGNOT, args, T_INTEGER, 0);
+ method_or_bust(sc, car(args), sc->lognot_symbol, args, T_INTEGER, 0);
return(make_integer(sc, ~s7_integer(car(args))));
}
@@ -23223,7 +23358,7 @@ static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args)
{
#define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \
order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))."
- #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_INTEGER)
+ #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
s7_pointer x, y;
s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */
@@ -23232,13 +23367,13 @@ order here follows gmp, and is the opposite of the CL convention. (logbit? int
y = cadr(args);
if (!s7_is_integer(x))
- method_or_bust(sc, x, sc->LOGBIT, args, T_INTEGER, 1);
+ method_or_bust(sc, x, sc->logbit_symbol, args, T_INTEGER, 1);
if (!s7_is_integer(y))
- method_or_bust(sc, y, sc->LOGBIT, args, T_INTEGER, 2);
+ method_or_bust(sc, y, sc->logbit_symbol, args, T_INTEGER, 2);
index = s7_integer(y);
if (index < 0)
- return(out_of_range(sc, sc->LOGBIT, small_int(2), y, ITS_NEGATIVE));
+ return(out_of_range(sc, sc->logbit_symbol, small_int(2), y, its_negative_string));
#if WITH_GMP
if (is_t_big_integer(x))
@@ -23263,7 +23398,7 @@ static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2)
if (arg1 == 0) return(0);
if (arg2 >= s7_int_bits)
- out_of_range(sc, sc->ASH, small_int(2), make_integer(sc, arg2), ITS_TOO_LARGE);
+ out_of_range(sc, sc->ash_symbol, small_int(2), make_integer(sc, arg2), its_too_large_string);
if (arg2 < -s7_int_bits)
{
@@ -23294,11 +23429,11 @@ static s7_pointer g_ash(s7_scheme *sc, s7_pointer args)
x = car(args);
if (!s7_is_integer(x))
- method_or_bust(sc, x, sc->ASH, args, T_INTEGER, 1);
+ method_or_bust(sc, x, sc->ash_symbol, args, T_INTEGER, 1);
y = cadr(args);
if (!s7_is_integer(y))
- method_or_bust(sc, y, sc->ASH, args, T_INTEGER, 2);
+ method_or_bust(sc, y, sc->ash_symbol, args, T_INTEGER, 2);
return(make_integer(sc, c_ash(sc, s7_integer(x), s7_integer(y))));
}
@@ -23326,17 +23461,17 @@ s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args)
#define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \
Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
(let ((seed (random-state 1234))) (random 1.0 seed))"
- #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->IS_RANDOM_STATE, sc->IS_INTEGER)
+ #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)
s7_pointer r1, r2, p;
s7_int i1, i2;
r1 = car(args);
if (!s7_is_integer(r1))
- method_or_bust(sc, r1, sc->RANDOM_STATE, args, T_INTEGER, 1);
+ method_or_bust(sc, r1, sc->random_state_symbol, args, T_INTEGER, 1);
i1 = s7_integer(r1);
if (i1 < 0)
- return(out_of_range(sc, sc->RANDOM_STATE, small_int(1), r1, ITS_NEGATIVE));
+ return(out_of_range(sc, sc->random_state_symbol, small_int(1), r1, its_negative_string));
if (is_null(cdr(args)))
{
@@ -23348,10 +23483,10 @@ Pass this as the second argument to 'random' to get a repeatable random number s
r2 = cadr(args);
if (!s7_is_integer(r2))
- method_or_bust(sc, r2, sc->RANDOM_STATE, args, T_INTEGER, 2);
+ method_or_bust(sc, r2, sc->random_state_symbol, args, T_INTEGER, 2);
i2 = s7_integer(r2);
if (i2 < 0)
- return(out_of_range(sc, sc->RANDOM_STATE, small_int(2), r2, ITS_NEGATIVE));
+ return(out_of_range(sc, sc->random_state_symbol, small_int(2), r2, its_negative_string));
new_cell(sc, p, T_RANDOM_STATE);
random_seed(p) = (unsigned long long int)i1;
@@ -23389,20 +23524,20 @@ static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args)
{
#define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)."
#define Q_is_random_state pl_bt
- check_boolean_method(sc, is_random_state, sc->IS_RANDOM_STATE, args);
+ check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args);
}
s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args)
{
#define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\
You can later apply random-state to this list to continue a random number sequence from any point."
- #define Q_random_state_to_list s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_RANDOM_STATE)
+ #define Q_random_state_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_random_state_symbol)
#if WITH_GMP
if ((is_pair(args)) &&
(!is_random_state(car(args))))
- method_or_bust_with_type(sc, car(args), sc->RANDOM_STATE_TO_LIST, args, A_RANDOM_STATE_OBJECT, 1);
- return(sc->NIL);
+ method_or_bust_with_type(sc, car(args), sc->random_state_to_list_symbol, args, a_random_state_object_string, 1);
+ return(sc->nil);
#else
s7_pointer r;
if (is_null(args))
@@ -23411,7 +23546,7 @@ You can later apply random-state to this list to continue a random number sequen
{
r = car(args);
if (!is_random_state(r))
- method_or_bust_with_type(sc, r, sc->RANDOM_STATE_TO_LIST, args, A_RANDOM_STATE_OBJECT, 1);
+ method_or_bust_with_type(sc, r, sc->random_state_to_list_symbol, args, a_random_state_object_string, 1);
}
return(list_2(sc, make_integer(sc, random_seed(r)), make_integer(sc, random_carry(r))));
#endif
@@ -23476,18 +23611,18 @@ s7_double s7_random(s7_scheme *sc, s7_pointer state)
static s7_pointer g_random(s7_scheme *sc, s7_pointer args)
{
#define H_random "(random num (state #f)) returns a random number between 0 and num (0 if num=0)."
- #define Q_random s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_NUMBER, sc->IS_RANDOM_STATE)
+ #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
s7_pointer r, num;
num = car(args);
if (!s7_is_number(num))
- method_or_bust_with_type(sc, num, sc->RANDOM, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, num, sc->random_symbol, args, a_number_string, 1);
if (is_not_null(cdr(args)))
{
r = cadr(args);
if (!is_random_state(r))
- method_or_bust_with_type(sc, r, sc->RANDOM, args, A_RANDOM_STATE_OBJECT, 2);
+ method_or_bust_with_type(sc, r, sc->random_symbol, args, a_random_state_object_string, 2);
}
else r = sc->default_rng;
@@ -23613,17 +23748,17 @@ static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int args, s7_point
static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args)
{
#define H_char_to_integer "(char->integer c) converts the character c to an integer"
- #define Q_char_to_integer s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_CHAR)
+ #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_TO_INTEGER, args, T_CHARACTER, 0);
+ method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, T_CHARACTER, 0);
return(small_int(character(car(args))));
}
#define int_method_or_bust(Sc, Obj, Method, Args, Type, Num) \
{ \
s7_pointer func; \
- if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->UNDEFINED)) \
+ if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
return(integer(s7_apply_function(Sc, func, Args))); \
if (Num == 0) simple_wrong_type_argument(Sc, Method, Obj, Type); \
wrong_type_argument(Sc, Method, Num, Obj, Type); \
@@ -23632,7 +23767,7 @@ static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args)
static s7_int c_char_to_integer(s7_scheme *sc, s7_pointer p)
{
if (!s7_is_character(p))
- int_method_or_bust(sc, p, sc->CHAR_TO_INTEGER, set_plist_1(sc, p), T_CHARACTER, 0);
+ int_method_or_bust(sc, p, sc->char_to_integer_symbol, set_plist_1(sc, p), T_CHARACTER, 0);
return(character(p));
}
@@ -23642,7 +23777,7 @@ PF_TO_IF(char_to_integer, c_char_to_integer)
static s7_pointer c_int_to_char(s7_scheme *sc, s7_int ind)
{
if ((ind < 0) || (ind >= NUM_CHARS))
- return(simple_wrong_type_argument_with_type(sc, sc->INTEGER_TO_CHAR, make_integer(sc, ind),
+ return(simple_wrong_type_argument_with_type(sc, sc->integer_to_char_symbol, make_integer(sc, ind),
make_string_wrapper(sc, "an integer that can represent a character")));
return(s7_make_character(sc, (unsigned char)ind));
}
@@ -23651,17 +23786,17 @@ static s7_pointer c_integer_to_char(s7_scheme *sc, s7_pointer x)
{
s7_int ind;
if (!s7_is_integer(x))
- method_or_bust(sc, x, sc->INTEGER_TO_CHAR, list_1(sc, x), T_INTEGER, 0);
+ method_or_bust(sc, x, sc->integer_to_char_symbol, list_1(sc, x), T_INTEGER, 0);
ind = s7_integer(x);
if ((ind < 0) || (ind >= NUM_CHARS))
- return(simple_wrong_type_argument_with_type(sc, sc->INTEGER_TO_CHAR, x, make_string_wrapper(sc, "an integer that can represent a character")));
+ return(simple_wrong_type_argument_with_type(sc, sc->integer_to_char_symbol, x, make_string_wrapper(sc, "an integer that can represent a character")));
return(s7_make_character(sc, (unsigned char)ind));
}
static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args)
{
#define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character"
- #define Q_integer_to_char s7_make_signature(sc, 2, sc->IS_CHAR, sc->IS_INTEGER)
+ #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)
return(c_integer_to_char(sc, car(args)));
}
@@ -23682,7 +23817,7 @@ static void init_uppers(void)
static s7_pointer c_char_upcase(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->CHAR_UPCASE, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->char_upcase_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(s7_make_character(sc, upper_character(arg)));
}
@@ -23691,7 +23826,7 @@ static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args)
#define H_char_upcase "(char-upcase c) converts the character c to upper case"
#define Q_char_upcase pcl_c
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_UPCASE, args, T_CHARACTER, 0);
+ method_or_bust(sc, car(args), sc->char_upcase_symbol, args, T_CHARACTER, 0);
return(s7_make_character(sc, upper_character(car(args))));
}
@@ -23701,7 +23836,7 @@ PF_TO_PF(char_upcase, c_char_upcase)
static s7_pointer c_char_downcase(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->CHAR_DOWNCASE, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->char_downcase_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(s7_make_character(sc, lowers[(int)character(arg)]));
}
@@ -23710,7 +23845,7 @@ static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args)
#define H_char_downcase "(char-downcase c) converts the character c to lower case"
#define Q_char_downcase pcl_c
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_DOWNCASE, args, T_CHARACTER, 0);
+ method_or_bust(sc, car(args), sc->char_downcase_symbol, args, T_CHARACTER, 0);
return(s7_make_character(sc, lowers[character(car(args))]));
}
@@ -23720,7 +23855,7 @@ PF_TO_PF(char_downcase, c_char_downcase)
static s7_pointer c_is_char_alphabetic(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->IS_CHAR_ALPHABETIC, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->is_char_alphabetic_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(make_boolean(sc, is_char_alphabetic(arg)));
}
@@ -23729,7 +23864,7 @@ static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args)
#define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic"
#define Q_is_char_alphabetic pl_bc
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->IS_CHAR_ALPHABETIC, args, T_CHARACTER, 0);
+ method_or_bust(sc, car(args), sc->is_char_alphabetic_symbol, args, T_CHARACTER, 0);
return(make_boolean(sc, is_char_alphabetic(car(args))));
/* isalpha returns #t for (integer->char 226) and others in that range */
@@ -23741,7 +23876,7 @@ PF_TO_PF(is_char_alphabetic, c_is_char_alphabetic)
static s7_pointer c_is_char_numeric(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->IS_CHAR_NUMERIC, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->is_char_numeric_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(make_boolean(sc, is_char_numeric(arg)));
}
@@ -23758,7 +23893,7 @@ PF_TO_PF(is_char_numeric, c_is_char_numeric)
static s7_pointer c_is_char_whitespace(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->IS_CHAR_WHITESPACE, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->is_char_whitespace_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(make_boolean(sc, is_char_whitespace(arg)));
}
@@ -23775,7 +23910,7 @@ PF_TO_PF(is_char_whitespace, c_is_char_whitespace)
static s7_pointer c_is_char_upper_case(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->IS_CHAR_UPPER_CASE, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->is_char_upper_case_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(make_boolean(sc, is_char_uppercase(arg)));
}
@@ -23792,7 +23927,7 @@ PF_TO_PF(is_char_upper_case, c_is_char_upper_case)
static s7_pointer c_is_char_lower_case(s7_scheme *sc, s7_pointer arg)
{
if (!s7_is_character(arg))
- method_or_bust(sc, arg, sc->IS_CHAR_LOWER_CASE, set_plist_1(sc, arg), T_CHARACTER, 0);
+ method_or_bust(sc, arg, sc->is_char_lower_case_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
return(make_boolean(sc, is_char_lowercase(arg)));
}
@@ -23811,7 +23946,7 @@ static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args)
{
#define H_is_char "(char? obj) returns #t if obj is a character"
#define Q_is_char pl_bt
- check_boolean_method(sc, s7_is_character, sc->IS_CHAR, args);
+ check_boolean_method(sc, s7_is_character, sc->is_char_symbol, args);
}
@@ -23850,9 +23985,9 @@ static bool is_character_via_method(s7_scheme *sc, s7_pointer p)
if (has_methods(p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->IS_CHAR);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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))));
}
return(false);
}
@@ -23919,18 +24054,18 @@ static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args)
y = car(args);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_EQ, args, T_CHARACTER, 1);
+ method_or_bust(sc, y, sc->char_eq_symbol, args, T_CHARACTER, 1);
for (x = cdr(args); is_pair(x); x = cdr(x))
{
if (!s7_is_character(car(x)))
- method_or_bust(sc, car(x), sc->CHAR_EQ, cons(sc, y, x), T_CHARACTER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->char_eq_symbol, cons(sc, y, x), T_CHARACTER, position_of(x, args));
if (car(x) != y)
{
for (y = cdr(x); is_pair(y); y = cdr(y))
if (!is_character_via_method(sc, car(y)))
- return(wrong_type_argument(sc, sc->CHAR_EQ, position_of(y, args), car(y), T_CHARACTER));
+ return(wrong_type_argument(sc, sc->char_eq_symbol, position_of(y, args), car(y), T_CHARACTER));
return(sc->F);
}
}
@@ -23943,7 +24078,7 @@ static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args)
#define H_chars_are_less "(char<? char ...) returns #t if all the character arguments are increasing"
#define Q_chars_are_less pcl_bc
- return(g_char_cmp(sc, args, -1, sc->CHAR_LT));
+ return(g_char_cmp(sc, args, -1, sc->char_lt_symbol));
}
@@ -23952,7 +24087,7 @@ static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args)
#define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing"
#define Q_chars_are_greater pcl_bc
- return(g_char_cmp(sc, args, 1, sc->CHAR_GT));
+ return(g_char_cmp(sc, args, 1, sc->char_gt_symbol));
}
@@ -23961,7 +24096,7 @@ static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args)
#define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing"
#define Q_chars_are_geq pcl_bc
- return(g_char_cmp_not(sc, args, -1, sc->CHAR_GEQ));
+ return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol));
}
@@ -23970,7 +24105,7 @@ static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args)
#define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing"
#define Q_chars_are_leq pcl_bc
- return(g_char_cmp_not(sc, args, 1, sc->CHAR_LEQ));
+ return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol));
}
static s7_pointer simple_char_eq;
@@ -23982,9 +24117,9 @@ static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args)
static s7_pointer c_char_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_EQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_eq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_EQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_eq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, x == y));
}
@@ -23996,7 +24131,7 @@ static bool char_check(s7_scheme *sc, s7_pointer obj)
{
s7_pointer sig;
sig = s7_procedure_signature(sc, s7_symbol_value(sc, car(obj)));
- return((sig) && (is_pair(sig)) && (car(sig) == sc->IS_CHAR));
+ return((sig) && (is_pair(sig)) && (car(sig) == sc->is_char_symbol));
}
return(false);
}
@@ -24013,17 +24148,17 @@ static s7_pointer g_char_equal_s_ic(s7_scheme *sc, s7_pointer args)
return(sc->T);
if (s7_is_character(c))
return(sc->F);
- method_or_bust(sc, c, sc->CHAR_EQ, list_2(sc, c, cadr(args)), T_CHARACTER, 1);
+ method_or_bust(sc, c, sc->char_eq_symbol, list_2(sc, c, cadr(args)), T_CHARACTER, 1);
}
static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_EQ, args, T_CHARACTER, 1);
+ method_or_bust(sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1);
if (car(args) == cadr(args))
return(sc->T);
if (!s7_is_character(cadr(args)))
- method_or_bust(sc, cadr(args), sc->CHAR_EQ, args, T_CHARACTER, 2);
+ method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER, 2);
return(sc->F);
}
@@ -24032,25 +24167,25 @@ static s7_pointer char_less_s_ic, char_less_2;
static s7_pointer g_char_less_s_ic(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_LT, args, T_CHARACTER, 1);
+ method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1);
return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}
static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_LT, args, T_CHARACTER, 1);
+ method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1);
if (!s7_is_character(cadr(args)))
- method_or_bust(sc, cadr(args), sc->CHAR_LT, args, T_CHARACTER, 2);
+ method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, T_CHARACTER, 2);
return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}
static s7_pointer c_char_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_LT, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_lt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_LT, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_lt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, character(x) < character(y)));
}
@@ -24066,25 +24201,25 @@ static s7_pointer char_greater_s_ic, char_greater_2;
static s7_pointer g_char_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_GT, args, T_CHARACTER, 1);
+ method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1);
return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}
static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_character(car(args)))
- method_or_bust(sc, car(args), sc->CHAR_GT, args, T_CHARACTER, 1);
+ method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1);
if (!s7_is_character(cadr(args)))
- method_or_bust(sc, cadr(args), sc->CHAR_GT, args, T_CHARACTER, 2);
+ method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, T_CHARACTER, 2);
return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}
static s7_pointer c_char_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_GT, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_gt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_GT, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_gt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, character(x) > character(y)));
}
@@ -24099,9 +24234,9 @@ PF2_TO_PF_X(char_gt, char_check, c_char_gt, c_cgt)
static s7_pointer c_char_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_GEQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_geq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_GEQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_geq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, character(x) >= character(y)));
}
@@ -24111,9 +24246,9 @@ PF2_TO_PF(char_geq, c_char_geq)
static s7_pointer c_char_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_LEQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_leq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_LEQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_leq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, character(x) <= character(y)));
}
@@ -24175,15 +24310,15 @@ static s7_pointer g_chars_are_ci_equal(s7_scheme *sc, s7_pointer args)
#define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case"
#define Q_chars_are_ci_equal pcl_bc
- return(g_char_cmp_ci(sc, args, 0, sc->CHAR_CI_EQ));
+ return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol));
}
static s7_pointer c_char_ci_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_CI_EQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_ci_eq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_CI_EQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_ci_eq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, upper_character(x) == upper_character(y)));
}
@@ -24195,15 +24330,15 @@ static s7_pointer g_chars_are_ci_less(s7_scheme *sc, s7_pointer args)
#define H_chars_are_ci_less "(char-ci<? char ...) returns #t if all the character arguments are increasing, ignoring case"
#define Q_chars_are_ci_less pcl_bc
- return(g_char_cmp_ci(sc, args, -1, sc->CHAR_CI_LT));
+ return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol));
}
static s7_pointer c_char_ci_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_CI_LT, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_ci_lt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_CI_LT, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_ci_lt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, upper_character(x) < upper_character(y)));
}
@@ -24215,15 +24350,15 @@ static s7_pointer g_chars_are_ci_greater(s7_scheme *sc, s7_pointer args)
#define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case"
#define Q_chars_are_ci_greater pcl_bc
- return(g_char_cmp_ci(sc, args, 1, sc->CHAR_CI_GT));
+ return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol));
}
static s7_pointer c_char_ci_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_CI_GT, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_ci_gt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_CI_GT, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_ci_gt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, upper_character(x) > upper_character(y)));
}
@@ -24235,15 +24370,15 @@ static s7_pointer g_chars_are_ci_geq(s7_scheme *sc, s7_pointer args)
#define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case"
#define Q_chars_are_ci_geq pcl_bc
- return(g_char_cmp_ci_not(sc, args, -1, sc->CHAR_CI_GEQ));
+ return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol));
}
static s7_pointer c_char_ci_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_CI_GEQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_ci_geq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_CI_GEQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_ci_geq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, upper_character(x) >= upper_character(y)));
}
@@ -24255,15 +24390,15 @@ static s7_pointer g_chars_are_ci_leq(s7_scheme *sc, s7_pointer args)
#define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case"
#define Q_chars_are_ci_leq pcl_bc
- return(g_char_cmp_ci_not(sc, args, 1, sc->CHAR_CI_LEQ));
+ return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol));
}
static s7_pointer c_char_ci_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!s7_is_character(x))
- method_or_bust(sc, x, sc->CHAR_CI_LEQ, list_2(sc, x, y), T_CHARACTER, 1);
+ method_or_bust(sc, x, sc->char_ci_leq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
if (!s7_is_character(y))
- method_or_bust(sc, y, sc->CHAR_CI_LEQ, list_2(sc, x, y), T_CHARACTER, 2);
+ method_or_bust(sc, y, sc->char_ci_leq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
return(make_boolean(sc, upper_character(x) <= upper_character(y)));
}
@@ -24274,7 +24409,7 @@ PF2_TO_PF(char_ci_leq, c_char_ci_leq)
static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
{
#define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f"
- #define Q_char_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_BOOLEAN), s7_make_signature(sc, 2, sc->IS_CHAR, sc->IS_STRING), sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_char_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_boolean_symbol), s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_integer_symbol)
const char *porig, *p, *pset;
s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */
@@ -24283,11 +24418,11 @@ static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
arg1 = car(args);
if ((!s7_is_character(arg1)) &&
(!is_string(arg1)))
- method_or_bust(sc, arg1, sc->CHAR_POSITION, args, T_CHARACTER, 1);
+ method_or_bust(sc, arg1, sc->char_position_symbol, args, T_CHARACTER, 1);
arg2 = cadr(args);
if (!is_string(arg2))
- method_or_bust(sc, arg2, sc->CHAR_POSITION, args, T_STRING, 2);
+ method_or_bust(sc, arg2, sc->char_position_symbol, args, T_STRING, 2);
porig = string_value(arg2);
len = string_length(arg2);
@@ -24300,12 +24435,12 @@ static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
if (!s7_is_integer(p = check_values(sc, arg3, cddr(args))))
- method_or_bust(sc, arg3, sc->CHAR_POSITION, args, T_INTEGER, 3);
+ method_or_bust(sc, arg3, sc->char_position_symbol, args, T_INTEGER, 3);
arg3 = p;
}
start = s7_integer(arg3);
if (start < 0)
- return(wrong_type_argument_with_type(sc, sc->CHAR_POSITION, 3, arg3, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string));
}
else start = 0;
if (start >= len) return(sc->F);
@@ -24370,7 +24505,7 @@ static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args)
return(g_char_position(sc, args));
start = s7_integer(arg3);
if (start < 0)
- return(wrong_type_argument_with_type(sc, sc->CHAR_POSITION, 3, arg3, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string));
if (start >= len) return(sc->F);
}
else start = 0;
@@ -24386,18 +24521,18 @@ static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args)
static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args)
{
#define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f"
- #define Q_string_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_BOOLEAN), sc->IS_STRING, sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_string_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_boolean_symbol), sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
const char *s1, *s2, *p2;
s7_int start = 0;
s7_pointer s1p, s2p;
s1p = car(args);
if (!is_string(s1p))
- method_or_bust(sc, s1p, sc->STRING_POSITION, args, T_STRING, 1);
+ method_or_bust(sc, s1p, sc->string_position_symbol, args, T_STRING, 1);
s2p = cadr(args);
if (!is_string(s2p))
- method_or_bust(sc, s2p, sc->STRING_POSITION, args, T_STRING, 2);
+ method_or_bust(sc, s2p, sc->string_position_symbol, args, T_STRING, 2);
if (is_pair(cddr(args)))
{
@@ -24407,12 +24542,12 @@ static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
if (!s7_is_integer(p = check_values(sc, arg3, cddr(args))))
- method_or_bust(sc, arg3, sc->STRING_POSITION, args, T_INTEGER, 3);
+ method_or_bust(sc, arg3, sc->string_position_symbol, args, T_INTEGER, 3);
arg3 = p;
}
start = s7_integer(arg3);
if (start < 0)
- return(wrong_type_argument_with_type(sc, sc->STRING_POSITION, 3, arg3, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->string_position_symbol, 3, arg3, a_non_negative_integer_string));
}
if (string_length(s1p) == 0)
@@ -24573,7 +24708,7 @@ static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args)
#define H_is_string "(string? obj) returns #t if obj is a string"
#define Q_is_string pl_bt
- check_boolean_method(sc, is_string, sc->IS_STRING, args);
+ check_boolean_method(sc, is_string, sc->is_string_symbol, args);
}
@@ -24581,7 +24716,7 @@ static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args)
static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args)
{
#define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)"
- #define Q_make_string s7_make_signature(sc, 3, sc->IS_STRING, sc->IS_INTEGER, sc->IS_CHAR)
+ #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)
s7_pointer n;
s7_int len;
@@ -24590,18 +24725,18 @@ static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args)
n = car(args);
if (!s7_is_integer(n))
{
- check_two_methods(sc, n, sc->MAKE_STRING, sc->MAKE_BYTE_VECTOR, args);
- return(wrong_type_argument(sc, sc->MAKE_STRING, 1, n, T_INTEGER));
+ check_two_methods(sc, n, sc->make_string_symbol, sc->make_byte_vector_symbol, args);
+ return(wrong_type_argument(sc, sc->make_string_symbol, 1, n, T_INTEGER));
}
len = s7_integer(n);
if ((len < 0) || (len > sc->max_string_length))
- return(out_of_range(sc, sc->MAKE_STRING, small_int(1), n, (len < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_string_symbol, small_int(1), n, (len < 0) ? its_negative_string : its_too_large_string));
if (is_not_null(cdr(args)))
{
if (!s7_is_character(cadr(args)))
- method_or_bust(sc, cadr(args), sc->MAKE_STRING, args, T_CHARACTER, 2);
+ method_or_bust(sc, cadr(args), sc->make_string_symbol, args, T_CHARACTER, 2);
fill = s7_character(cadr(args));
}
n = make_empty_string(sc, (int)len, fill);
@@ -24618,18 +24753,18 @@ IF_TO_PF(make_string, c_make_string)
static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args)
{
#define H_string_length "(string-length str) returns the length of the string str"
- #define Q_string_length s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_STRING)
+ #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
s7_pointer p;
p = car(args);
if (!is_string(p))
- method_or_bust(sc, p, sc->STRING_LENGTH, args, T_STRING, 0);
+ method_or_bust(sc, p, sc->string_length_symbol, args, T_STRING, 0);
return(make_integer(sc, string_length(p)));
}
static s7_int c_string_length(s7_scheme *sc, s7_pointer p)
{
if (!is_string(p))
- int_method_or_bust(sc, p, sc->STRING_LENGTH, set_plist_1(sc, p), T_STRING, 0);
+ int_method_or_bust(sc, p, sc->string_length_symbol, set_plist_1(sc, p), T_STRING, 0);
return(string_length(p));
}
@@ -24647,7 +24782,7 @@ static s7_pointer c_string_downcase(s7_scheme *sc, s7_pointer p)
sc->temp3 = p;
if (!is_string(p))
- method_or_bust(sc, p, sc->STRING_DOWNCASE, list_1(sc, p), T_STRING, 0);
+ method_or_bust(sc, p, sc->string_downcase_symbol, list_1(sc, p), T_STRING, 0);
len = string_length(p);
newstr = make_empty_string(sc, len, 0);
@@ -24678,7 +24813,7 @@ static s7_pointer c_string_upcase(s7_scheme *sc, s7_pointer p)
sc->temp3 = p;
if (!is_string(p))
- method_or_bust(sc, p, sc->STRING_UPCASE, list_1(sc, p), T_STRING, 0);
+ method_or_bust(sc, p, sc->string_upcase_symbol, list_1(sc, p), T_STRING, 0);
len = string_length(p);
newstr = make_empty_string(sc, len, 0);
@@ -24716,15 +24851,15 @@ static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index
if (!s7_is_integer(index))
{
s7_pointer p;
- if (!s7_is_integer(p = check_values(sc, index, cons(sc, index, sc->NIL))))
- method_or_bust(sc, index, sc->STRING_REF, list_2(sc, strng, index), T_INTEGER, 2);
+ if (!s7_is_integer(p = check_values(sc, index, cons(sc, index, sc->nil))))
+ method_or_bust(sc, index, sc->string_ref_symbol, list_2(sc, strng, index), T_INTEGER, 2);
index = p;
}
ind = s7_integer(index);
if (ind < 0)
- return(wrong_type_argument_with_type(sc, sc->STRING_REF, 2, index, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, index, a_non_negative_integer_string));
if (ind >= string_length(strng))
- return(out_of_range(sc, sc->STRING_REF, small_int(2), index, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->string_ref_symbol, small_int(2), index, its_too_large_string));
str = string_value(strng);
return(s7_make_character(sc, ((unsigned char *)str)[ind]));
@@ -24738,24 +24873,24 @@ static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args)
s7_int ind;
#define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str"
- #define Q_string_ref s7_make_signature(sc, 3, sc->IS_CHAR, sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)
strng = car(args);
if (!is_string(strng))
- method_or_bust(sc, strng, sc->STRING_REF, args, T_STRING, 1);
+ method_or_bust(sc, strng, sc->string_ref_symbol, args, T_STRING, 1);
index = cadr(args);
if (!s7_is_integer(index))
{
if (!s7_is_integer(p = check_values(sc, index, cdr(args))))
- method_or_bust(sc, index, sc->STRING_REF, args, T_INTEGER, 2);
+ method_or_bust(sc, index, sc->string_ref_symbol, args, T_INTEGER, 2);
index = p;
}
ind = s7_integer(index);
if (ind < 0)
- return(wrong_type_argument_with_type(sc, sc->STRING_REF, 2, index, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, index, a_non_negative_integer_string));
if (ind >= string_length(strng))
- return(out_of_range(sc, sc->STRING_REF, small_int(2), index, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->string_ref_symbol, small_int(2), index, its_too_large_string));
str = string_value(strng);
return(s7_make_character(sc, ((unsigned char *)str)[ind]));
@@ -24764,11 +24899,11 @@ static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args)
static s7_pointer c_string_ref(s7_scheme *sc, s7_pointer str, s7_int ind)
{
if (!is_string(str))
- method_or_bust(sc, str, sc->STRING_REF, list_2(sc, str, make_integer(sc, ind)), T_STRING, 1);
+ method_or_bust(sc, str, sc->string_ref_symbol, list_2(sc, str, make_integer(sc, ind)), T_STRING, 1);
if (ind < 0)
- return(wrong_type_argument_with_type(sc, sc->STRING_REF, 2, make_integer(sc, ind), A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, make_integer(sc, ind), a_non_negative_integer_string));
if (ind >= string_length(str))
- return(out_of_range(sc, sc->STRING_REF, small_int(2), make_integer(sc, ind), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->string_ref_symbol, small_int(2), make_integer(sc, ind), its_too_large_string));
return(s7_make_character(sc, ((unsigned char *)string_value(str))[ind]));
}
@@ -24779,7 +24914,7 @@ PIF_TO_PF(string_ref, c_string_ref)
static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
{
#define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr"
- #define Q_string_set s7_make_signature(sc, 4, sc->IS_CHAR, sc->IS_STRING, sc->IS_INTEGER, sc->IS_CHAR)
+ #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)
s7_pointer x, c, index;
char *str;
@@ -24787,21 +24922,21 @@ static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
x = car(args);
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_SET, args, T_STRING, 1);
+ method_or_bust(sc, x, sc->string_set_symbol, args, T_STRING, 1);
index = cadr(args);
if (!s7_is_integer(index))
{
s7_pointer p;
if (!s7_is_integer(p = check_values(sc, index, cdr(args))))
- method_or_bust(sc, index, sc->STRING_SET, args, T_INTEGER, 2);
+ method_or_bust(sc, index, sc->string_set_symbol, args, T_INTEGER, 2);
index = p;
}
ind = s7_integer(index);
if (ind < 0)
- return(wrong_type_argument_with_type(sc, sc->STRING_SET, 2, index, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->string_set_symbol, 2, index, a_non_negative_integer_string));
if (ind >= string_length(x))
- return(out_of_range(sc, sc->STRING_SET, small_int(2), index, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->string_set_symbol, small_int(2), index, its_too_large_string));
str = string_value(_TSet(x));
c = caddr(args);
@@ -24813,11 +24948,11 @@ static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
s7_int ic; /* not int here! */
ic = s7_integer(c);
if ((ic < 0) || (ic > 255))
- return(wrong_type_argument_with_type(sc, sc->STRING_SET, 3, c, AN_UNSIGNED_BYTE));
+ return(wrong_type_argument_with_type(sc, sc->string_set_symbol, 3, c, an_unsigned_byte_string));
str[ind] = (char)ic;
return(c);
}
- method_or_bust(sc, c, sc->STRING_SET, list_3(sc, x, index, c), T_CHARACTER, 3);
+ method_or_bust(sc, c, sc->string_set_symbol, list_3(sc, x, index, c), T_CHARACTER, 3);
}
str[ind] = (char)s7_character(c);
@@ -24864,10 +24999,10 @@ static int c_string_tester(s7_scheme *sc, s7_pointer expr)
static s7_pointer c_string_set_s(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
if (!s7_is_character(val))
- method_or_bust(sc, val, sc->STRING_SET, list_3(sc, vec, make_integer(sc, index), val), T_CHARACTER, 3);
+ method_or_bust(sc, val, sc->string_set_symbol, list_3(sc, vec, make_integer(sc, index), val), T_CHARACTER, 3);
if ((index < 0) ||
(index >= string_length(vec)))
- return(out_of_range(sc, sc->STRING_SET, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->string_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));
string_value(vec)[index] = (char)character(val);
return(val);
@@ -24876,7 +25011,7 @@ static s7_pointer c_string_set_s(s7_scheme *sc, s7_pointer vec, s7_int index, s7
static s7_pointer c_string_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
if (!s7_is_string(vec))
- method_or_bust(sc, vec, sc->STRING_SET, set_plist_3(sc, vec, make_integer(sc, index), val), T_STRING, 1);
+ method_or_bust(sc, vec, sc->string_set_symbol, set_plist_3(sc, vec, make_integer(sc, index), val), T_STRING, 1);
return(c_string_set_s(sc, vec, index, val));
}
@@ -24904,8 +25039,8 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, bool use_tem
if (has_methods(p))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, p), sc->STRING_APPEND);
- if (func != sc->UNDEFINED)
+ func = find_method(sc, find_let(sc, p), sc->string_append_symbol);
+ if (func != sc->undefined)
{
s7_pointer y;
if (len == 0)
@@ -24916,7 +25051,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, bool use_tem
return(s7_apply_function(sc, func, cons(sc, newstr, x)));
}
}
- return(wrong_type_argument(sc, sc->STRING_APPEND, position_of(x, args), p, T_STRING));
+ return(wrong_type_argument(sc, sc->string_append_symbol, position_of(x, args), p, T_STRING));
}
len += string_length(p);
}
@@ -24960,11 +25095,11 @@ static s7_pointer g_string_append_to_temp(s7_scheme *sc, s7_pointer args)
static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args)
{
#define H_string_copy "(string-copy str) returns a copy of its string argument"
- #define Q_string_copy pcl_s
+ #define Q_string_copy s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_string_symbol)
s7_pointer p;
p = car(args);
if (!is_string(p))
- method_or_bust(sc, p, sc->STRING_COPY, args, T_STRING, 1);
+ method_or_bust(sc, p, sc->string_copy_symbol, args, T_STRING, 1);
return(s7_make_string_with_length(sc, string_value(p), string_length(p)));
}
#endif
@@ -24984,7 +25119,7 @@ static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer fal
if (is_null(start_and_end_args))
{
fprintf(stderr, "start_and_end args is null\n");
- return(sc->GC_NIL);
+ return(sc->gc_nil);
}
#endif
@@ -25002,11 +25137,11 @@ static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer fal
index = s7_integer(pstart);
if ((index < 0) ||
(index > *end)) /* *end == length here */
- return(out_of_range(sc, caller, small_int(position), pstart, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, caller, small_int(position), pstart, (index < 0) ? its_negative_string : its_too_large_string));
*start = index;
if (is_null(cdr(start_and_end_args)))
- return(sc->GC_NIL);
+ return(sc->gc_nil);
pend = cadr(start_and_end_args);
if (!s7_is_integer(pend))
@@ -25022,9 +25157,9 @@ static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer fal
index = s7_integer(pend);
if ((index < *start) ||
(index > *end))
- return(out_of_range(sc, caller, small_int(position + 1), pend, (index < *start) ? ITS_TOO_SMALL : ITS_TOO_LARGE));
+ return(out_of_range(sc, caller, small_int(position + 1), pend, (index < *start) ? its_too_small_string : its_too_large_string));
*end = index;
- return(sc->GC_NIL);
+ return(sc->gc_nil);
}
@@ -25032,7 +25167,7 @@ static s7_pointer g_substring(s7_scheme *sc, s7_pointer args)
{
#define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \
end: (substring \"01234\" 1 2) -> \"1\""
- #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->IS_STRING, sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
s7_pointer x, str;
s7_int start = 0, end;
@@ -25041,13 +25176,13 @@ end: (substring \"01234\" 1 2) -> \"1\""
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->SUBSTRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->substring_symbol, args, T_STRING, 1);
end = string_length(str);
if (!is_null(cdr(args)))
{
- x = start_and_end(sc, sc->SUBSTRING, NULL, cdr(args), args, 2, &start, &end);
- if (x != sc->GC_NIL) return(x);
+ x = start_and_end(sc, sc->substring_symbol, NULL, cdr(args), args, 2, &start, &end);
+ if (x != sc->gc_nil) return(x);
}
s = string_value(str);
len = (int)(end - start);
@@ -25065,14 +25200,14 @@ static s7_pointer g_substring_to_temp(s7_scheme *sc, s7_pointer args)
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->SUBSTRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->substring_symbol, args, T_STRING, 1);
end = string_length(str);
if (!is_null(cdr(args)))
{
s7_pointer x;
- x = start_and_end(sc, sc->SUBSTRING, NULL, cdr(args), args, 2, &start, &end);
- if (x != sc->GC_NIL) return(x);
+ x = start_and_end(sc, sc->substring_symbol, NULL, cdr(args), args, 2, &start, &end);
+ if (x != sc->gc_nil) return(x);
}
return(make_temporary_string(sc, (const char *)(string_value(str) + start), (int)(end - start)));
}
@@ -25083,7 +25218,7 @@ static use_write_t write_choice(s7_scheme *sc, s7_pointer arg)
{
if (arg == sc->F) return(USE_DISPLAY);
if (arg == sc->T) return(USE_WRITE);
- if (arg == sc->KEY_READABLE) return(USE_READABLE_WRITE);
+ if (arg == sc->key_readable_symbol) return(USE_READABLE_WRITE);
return(USE_WRITE_WRONG);
}
@@ -25094,7 +25229,7 @@ static char *s7_object_to_c_string_1(s7_scheme *sc, s7_pointer obj, use_write_t
static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args)
{
#define H_object_to_string "(object->string obj (write #t)) returns a string representation of obj."
- #define Q_object_to_string s7_make_signature(sc, 3, sc->IS_STRING, sc->T, s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_KEYWORD))
+ #define Q_object_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->T, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol))
use_write_t choice;
char *str;
@@ -25105,13 +25240,13 @@ static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args)
{
choice = write_choice(sc, cadr(args));
if (choice == USE_WRITE_WRONG)
- method_or_bust(sc, cadr(args), sc->OBJECT_TO_STRING, args, T_BOOLEAN, 2);
+ method_or_bust(sc, cadr(args), sc->object_to_string_symbol, args, T_BOOLEAN, 2);
}
else choice = USE_WRITE;
/* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */
obj = car(args);
- check_method(sc, obj, sc->OBJECT_TO_STRING, args);
+ check_method(sc, obj, sc->object_to_string_symbol, args);
str = s7_object_to_c_string_1(sc, obj, choice, &len);
if (str)
return(make_string_uncopied_with_length(sc, str, len));
@@ -25166,9 +25301,9 @@ static bool is_string_via_method(s7_scheme *sc, s7_pointer p)
if (has_methods(p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->IS_STRING);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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))));
}
return(false);
}
@@ -25243,7 +25378,7 @@ static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
y = car(args);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_EQ, args, T_STRING, 1);
+ method_or_bust(sc, y, sc->string_eq_symbol, args, T_STRING, 1);
for (x = cdr(args); is_pair(x); x = cdr(x))
{
@@ -25252,7 +25387,7 @@ static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
if (y != p)
{
if (!is_string(p))
- method_or_bust(sc, p, sc->STRING_EQ, cons(sc, y, x), T_STRING, position_of(x, args));
+ method_or_bust(sc, p, sc->string_eq_symbol, cons(sc, y, x), T_STRING, position_of(x, args));
if (happy)
happy = scheme_strings_are_equal(p, y);
}
@@ -25265,9 +25400,9 @@ static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
static s7_pointer c_string_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_EQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_eq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_EQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_eq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, ((string_length(x) == string_length(y)) &&
(strings_are_equal_with_length(string_value(x), string_value(y), string_length(x))))));
}
@@ -25280,15 +25415,15 @@ static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args)
#define H_strings_are_less "(string<? str ...) returns #t if all the string arguments are increasing"
#define Q_strings_are_less pcl_bs
- return(g_string_cmp(sc, args, -1, sc->STRING_LT));
+ return(g_string_cmp(sc, args, -1, sc->string_lt_symbol));
}
static s7_pointer c_string_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_LT, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_lt_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_LT, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_lt_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(x, y) == -1));
}
@@ -25300,15 +25435,15 @@ static s7_pointer g_strings_are_greater(s7_scheme *sc, s7_pointer args)
#define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing"
#define Q_strings_are_greater pcl_bs
- return(g_string_cmp(sc, args, 1, sc->STRING_GT));
+ return(g_string_cmp(sc, args, 1, sc->string_gt_symbol));
}
static s7_pointer c_string_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_GT, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_gt_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_GT, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_gt_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(x, y) == 1));
}
@@ -25320,15 +25455,15 @@ static s7_pointer g_strings_are_geq(s7_scheme *sc, s7_pointer args)
#define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing"
#define Q_strings_are_geq pcl_bs
- return(g_string_cmp_not(sc, args, -1, sc->STRING_GEQ));
+ return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol));
}
static s7_pointer c_string_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_GEQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_geq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_GEQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_geq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(x, y) != -1));
}
@@ -25340,15 +25475,15 @@ static s7_pointer g_strings_are_leq(s7_scheme *sc, s7_pointer args)
#define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing"
#define Q_strings_are_leq pcl_bs
- return(g_string_cmp_not(sc, args, 1, sc->STRING_LEQ));
+ return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol));
}
static s7_pointer c_string_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_LEQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_leq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_LEQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_leq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(x, y) != 1));
}
@@ -25359,16 +25494,16 @@ static s7_pointer string_equal_s_ic, string_equal_2;
static s7_pointer g_string_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->STRING_EQ, args, T_STRING, 1);
+ method_or_bust(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1);
return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}
static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args)
{
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->STRING_EQ, args, T_STRING, 1);
+ method_or_bust(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1);
if (!is_string(cadr(args)))
- method_or_bust(sc, cadr(args), sc->STRING_EQ, args, T_STRING, 2);
+ method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, T_STRING, 2);
return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}
@@ -25377,9 +25512,9 @@ static s7_pointer string_less_2;
static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args)
{
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->STRING_LT, args, T_STRING, 1);
+ method_or_bust(sc, car(args), sc->string_lt_symbol, args, T_STRING, 1);
if (!is_string(cadr(args)))
- method_or_bust(sc, cadr(args), sc->STRING_LT, args, T_STRING, 2);
+ method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
}
@@ -25388,9 +25523,9 @@ static s7_pointer string_greater_2;
static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args)
{
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->STRING_GT, args, T_STRING, 1);
+ method_or_bust(sc, car(args), sc->string_gt_symbol, args, T_STRING, 1);
if (!is_string(cadr(args)))
- method_or_bust(sc, cadr(args), sc->STRING_GT, args, T_STRING, 2);
+ method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, T_STRING, 2);
return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
}
@@ -25518,15 +25653,15 @@ static s7_pointer g_strings_are_ci_equal(s7_scheme *sc, s7_pointer args)
{
#define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case"
#define Q_strings_are_ci_equal pcl_bs
- return(g_string_ci_cmp(sc, args, 0, sc->STRING_CI_EQ));
+ return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol));
}
static s7_pointer c_string_ci_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_CI_EQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_ci_eq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_CI_EQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_ci_eq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcasecmp(x, y) == 0));
}
@@ -25537,15 +25672,15 @@ static s7_pointer g_strings_are_ci_less(s7_scheme *sc, s7_pointer args)
{
#define H_strings_are_ci_less "(string-ci<? str ...) returns #t if all the string arguments are increasing, ignoring case"
#define Q_strings_are_ci_less pcl_bs
- return(g_string_ci_cmp(sc, args, -1, sc->STRING_CI_LT));
+ return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol));
}
static s7_pointer c_string_ci_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_CI_LT, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_ci_lt_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_CI_LT, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_ci_lt_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcasecmp(x, y) == -1));
}
@@ -25556,15 +25691,15 @@ static s7_pointer g_strings_are_ci_greater(s7_scheme *sc, s7_pointer args)
{
#define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case"
#define Q_strings_are_ci_greater pcl_bs
- return(g_string_ci_cmp(sc, args, 1, sc->STRING_CI_GT));
+ return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol));
}
static s7_pointer c_string_ci_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_CI_GT, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_ci_gt_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_CI_GT, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_ci_gt_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcasecmp(x, y) == 1));
}
@@ -25575,15 +25710,15 @@ static s7_pointer g_strings_are_ci_geq(s7_scheme *sc, s7_pointer args)
{
#define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case"
#define Q_strings_are_ci_geq pcl_bs
- return(g_string_ci_cmp_not(sc, args, -1, sc->STRING_CI_GEQ));
+ return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol));
}
static s7_pointer c_string_ci_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_CI_GEQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_ci_geq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_CI_GEQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_ci_geq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcasecmp(x, y) != -1));
}
@@ -25594,15 +25729,15 @@ static s7_pointer g_strings_are_ci_leq(s7_scheme *sc, s7_pointer args)
{
#define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case"
#define Q_strings_are_ci_leq pcl_bs
- return(g_string_ci_cmp_not(sc, args, 1, sc->STRING_CI_LEQ));
+ return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol));
}
static s7_pointer c_string_ci_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_CI_LEQ, list_2(sc, x, y), T_STRING, 1);
+ method_or_bust(sc, x, sc->string_ci_leq_symbol, list_2(sc, x, y), T_STRING, 1);
if (!is_string(y))
- method_or_bust(sc, y, sc->STRING_CI_LEQ, list_2(sc, x, y), T_STRING, 2);
+ method_or_bust(sc, y, sc->string_ci_leq_symbol, list_2(sc, x, y), T_STRING, 2);
return(make_boolean(sc, scheme_strcasecmp(x, y) != 1));
}
@@ -25613,42 +25748,42 @@ PF2_TO_PF(string_ci_leq, c_string_ci_leq)
static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args)
{
#define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr"
- #define Q_string_fill s7_make_circular_signature(sc, 3, 4, s7_make_signature(sc, 2, sc->IS_CHAR, sc->IS_INTEGER), sc->IS_STRING, sc->IS_CHAR, sc->IS_INTEGER)
+ #define Q_string_fill s7_make_circular_signature(sc, 3, 4, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol)
s7_pointer x, chr;
s7_int start = 0, end, byte = 0;
x = car(args);
if (!is_string(x))
- method_or_bust(sc, x, sc->STRING_FILL, args, T_STRING, 1); /* not two methods here */
+ method_or_bust(sc, x, sc->string_fill_symbol, args, T_STRING, 1); /* not two methods here */
chr = cadr(args);
if (!is_byte_vector(x))
{
if (!s7_is_character(chr))
{
- check_two_methods(sc, chr, sc->STRING_FILL, sc->FILL, args);
- return(wrong_type_argument(sc, sc->STRING_FILL, 2, chr, T_CHARACTER));
+ check_two_methods(sc, chr, sc->string_fill_symbol, sc->fill_symbol, args);
+ return(wrong_type_argument(sc, sc->string_fill_symbol, 2, chr, T_CHARACTER));
}
}
else
{
if (!is_integer(chr))
{
- check_two_methods(sc, chr, sc->STRING_FILL, sc->FILL, args);
- return(wrong_type_argument(sc, sc->FILL, 2, chr, T_INTEGER));
+ check_two_methods(sc, chr, sc->string_fill_symbol, sc->fill_symbol, args);
+ return(wrong_type_argument(sc, sc->fill_symbol, 2, chr, T_INTEGER));
}
byte = integer(chr);
if ((byte < 0) || (byte > 255))
- return(simple_wrong_type_argument_with_type(sc, sc->STRING_FILL, chr, AN_UNSIGNED_BYTE));
+ return(simple_wrong_type_argument_with_type(sc, sc->string_fill_symbol, chr, an_unsigned_byte_string));
}
end = string_length(x);
if (!is_null(cddr(args)))
{
s7_pointer p;
- p = start_and_end(sc, sc->STRING_FILL, sc->FILL, cddr(args), args, 3, &start, &end);
- if (p != sc->GC_NIL) return(p);
+ p = start_and_end(sc, sc->string_fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
+ if (p != sc->gc_nil) return(p);
if (start == end) return(chr);
}
if (end == 0) return(chr);
@@ -25683,7 +25818,7 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
s7_pointer func;
func = find_method(sc, find_let(sc, p), sym);
- if (func != sc->UNDEFINED)
+ if (func != sc->undefined)
{
s7_pointer y;
if (len == 0)
@@ -25710,25 +25845,25 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
static s7_pointer g_string(s7_scheme *sc, s7_pointer args)
{
#define H_string "(string chr...) appends all its character arguments into one string"
- #define Q_string s7_make_circular_signature(sc, 1, 2, sc->IS_STRING, sc->IS_CHAR)
+ #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol)
if (is_null(args)) /* (string) but not (string ()) */
return(s7_make_string_with_length(sc, "", 0));
- return(g_string_1(sc, args, sc->STRING));
+ return(g_string_1(sc, args, sc->string_symbol));
}
#if (!WITH_PURE_S7)
static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args)
{
#define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)"
- #define Q_list_to_string s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_PROPER_LIST)
+ #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol)
if (is_null(car(args)))
return(s7_make_string_with_length(sc, "", 0));
if (!is_proper_list(sc, car(args)))
- method_or_bust_with_type(sc, car(args), sc->LIST_TO_STRING, args, make_string_wrapper(sc, "a (proper, non-circular) list of characters"), 0);
- return(g_string_1(sc, car(args), sc->LIST_TO_STRING));
+ method_or_bust_with_type(sc, car(args), sc->list_to_string_symbol, args, make_string_wrapper(sc, "a (proper, non-circular) list of characters"), 0);
+ return(g_string_1(sc, car(args), sc->list_to_string_symbol));
}
#endif
@@ -25738,7 +25873,7 @@ static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, int len)
s7_pointer result;
if (len == 0)
- return(sc->NIL);
+ return(sc->nil);
if (len >= (sc->free_heap_top - sc->free_heap))
{
gc(sc);
@@ -25746,11 +25881,11 @@ static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, int len)
resize_heap(sc);
}
- sc->v = sc->NIL;
+ sc->v = sc->nil;
for (i = len - 1; i >= 0; i--)
sc->v = cons_unchecked(sc, s7_make_character(sc, ((unsigned char)str[i])), sc->v);
result = sc->v;
- sc->v = sc->NIL;
+ sc->v = sc->nil;
return(result);
}
@@ -25758,35 +25893,35 @@ static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, int len)
static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args)
{
#define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)"
- #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->IS_LIST, sc->IS_STRING, sc->IS_INTEGER)
+ #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol)
s7_int i, start = 0, end;
s7_pointer p, str;
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->STRING_TO_LIST, args, T_STRING, 0);
+ method_or_bust(sc, str, sc->string_to_list_symbol, args, T_STRING, 0);
end = string_length(str);
if (!is_null(cdr(args)))
{
- p = start_and_end(sc, sc->STRING_TO_LIST, NULL, cdr(args), args, 2, &start, &end);
- if (p != sc->GC_NIL) return(p);
- if (start == end) return(sc->NIL);
+ p = start_and_end(sc, sc->string_to_list_symbol, NULL, cdr(args), args, 2, &start, &end);
+ if (p != sc->gc_nil) return(p);
+ if (start == end) return(sc->nil);
}
else
{
- if (end == 0) return(sc->NIL);
+ if (end == 0) return(sc->nil);
}
if ((start == 0) && (end == string_length(str)))
return(s7_string_to_list(sc, string_value(str), string_length(str)));
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = end - 1; i >= start; i--)
sc->w = cons(sc, s7_make_character(sc, ((unsigned char)string_value(str)[i])), sc->w);
p = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(p);
}
@@ -25807,14 +25942,14 @@ static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args)
#define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector"
#define Q_is_byte_vector pl_bt
- check_boolean_method(sc, s7_is_byte_vector, sc->IS_BYTE_VECTOR, args);
+ check_boolean_method(sc, s7_is_byte_vector, sc->is_byte_vector_symbol, args);
}
static s7_pointer g_to_byte_vector(s7_scheme *sc, s7_pointer args)
{
#define H_to_byte_vector "(->byte-vector obj) turns a string into a byte-vector."
- #define Q_to_byte_vector s7_make_signature(sc, 2, sc->IS_BYTE_VECTOR, sc->IS_STRING)
+ #define Q_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol)
s7_pointer str;
str = car(args);
if (is_integer(str))
@@ -25822,7 +25957,7 @@ static s7_pointer g_to_byte_vector(s7_scheme *sc, s7_pointer args)
else
{
if (!is_string(str))
- method_or_bust(sc, str, sc->TO_BYTE_VECTOR, set_plist_1(sc, str), T_STRING, 1);
+ method_or_bust(sc, str, sc->to_byte_vector_symbol, set_plist_1(sc, str), T_STRING, 1);
}
set_byte_vector(str);
return(str);
@@ -25836,7 +25971,7 @@ PF_TO_PF(to_byte_vector, c_to_byte_vector)
static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
{
#define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte."
- #define Q_make_byte_vector s7_make_circular_signature(sc, 1, 2, sc->IS_BYTE_VECTOR, sc->IS_INTEGER)
+ #define Q_make_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_integer_symbol)
s7_pointer str;
if (is_null(cdr(args)))
@@ -25851,15 +25986,15 @@ static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
s7_int b;
len = car(args);
if (!is_integer(len))
- method_or_bust(sc, len, sc->MAKE_BYTE_VECTOR, args, T_INTEGER, 1);
+ method_or_bust(sc, len, sc->make_byte_vector_symbol, args, T_INTEGER, 1);
byte = cadr(args);
if (!s7_is_integer(byte))
- method_or_bust(sc, byte, sc->MAKE_BYTE_VECTOR, args, T_INTEGER, 2);
+ method_or_bust(sc, byte, sc->make_byte_vector_symbol, args, T_INTEGER, 2);
b = s7_integer(byte);
if ((b < 0) || (b > 255))
- return(simple_wrong_type_argument_with_type(sc, sc->MAKE_BYTE_VECTOR, byte, AN_UNSIGNED_BYTE));
+ return(simple_wrong_type_argument_with_type(sc, sc->make_byte_vector_symbol, byte, an_unsigned_byte_string));
str = g_make_string(sc, set_plist_2(sc, len, chars[b]));
}
set_byte_vector(str);
@@ -25870,7 +26005,7 @@ static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
{
#define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments"
- #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->IS_BYTE_VECTOR, sc->IS_INTEGER)
+ #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_integer_symbol)
s7_int i, len;
s7_pointer vec, x;
@@ -25890,8 +26025,8 @@ static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
if (has_methods(byte))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, byte), sc->BYTE_VECTOR);
- if (func != sc->UNDEFINED)
+ func = find_method(sc, find_let(sc, byte), sc->byte_vector_symbol);
+ if (func != sc->undefined)
{
if (i == 0)
return(s7_apply_function(sc, func, args));
@@ -25901,11 +26036,11 @@ static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
return(vec);
}
}
- return(wrong_type_argument(sc, sc->BYTE_VECTOR, i + 1, byte, T_INTEGER));
+ return(wrong_type_argument(sc, sc->byte_vector_symbol, i + 1, byte, T_INTEGER));
}
b = s7_integer(byte);
if ((b < 0) || (b > 255))
- return(simple_wrong_type_argument_with_type(sc, sc->BYTE_VECTOR, byte, AN_UNSIGNED_BYTE));
+ return(simple_wrong_type_argument_with_type(sc, sc->byte_vector_symbol, byte, an_unsigned_byte_string));
str[i] = (unsigned char)b;
}
set_byte_vector(vec);
@@ -25916,12 +26051,12 @@ static s7_pointer byte_vector_to_list(s7_scheme *sc, const char *str, int len)
{
int i;
s7_pointer p;
- if (len == 0) return(sc->NIL);
- sc->w = sc->NIL;
+ if (len == 0) return(sc->nil);
+ sc->w = sc->nil;
for (i = len - 1; i >= 0; i--)
sc->w = cons(sc, small_int((unsigned int)((unsigned char)(str[i]))), sc->w); /* extra cast is not redundant! */
p = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(p);
}
@@ -25946,7 +26081,7 @@ static s7_pointer g_is_port_closed(s7_scheme *sc, s7_pointer args)
if ((is_input_port(x)) || (is_output_port(x)))
return(make_boolean(sc, port_is_closed(x)));
- method_or_bust_with_type(sc, x, sc->IS_PORT_CLOSED, args, make_string_wrapper(sc, "a port"), 0);
+ method_or_bust_with_type(sc, x, sc->is_port_closed_symbol, args, make_string_wrapper(sc, "a port"), 0);
}
@@ -25954,16 +26089,16 @@ static s7_pointer c_port_line_number(s7_scheme *sc, s7_pointer x)
{
if ((!(is_input_port(x))) ||
(port_is_closed(x)))
- method_or_bust_with_type(sc, x, sc->PORT_LINE_NUMBER, list_1(sc, x), AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, x, sc->port_line_number_symbol, list_1(sc, x), an_input_port_string, 0);
return(make_integer(sc, port_line_number(x)));
}
static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args)
{
#define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port"
- #define Q_port_line_number s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_INPUT_PORT)
+ #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_null_symbol))
- if (is_null(args))
+ if ((is_null(args)) || (is_null(car(args))))
return(c_port_line_number(sc, sc->input_port));
return(c_port_line_number(sc, car(args)));
}
@@ -25977,6 +26112,27 @@ int s7_port_line_number(s7_pointer p)
return(0);
}
+static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p, line;
+
+ if ((is_null(car(args))) ||
+ ((is_null(cdr(args))) && (is_integer(car(args)))))
+ p = sc->input_port;
+ else
+ {
+ p = car(args);
+ if (!(is_input_port(p)))
+ return(s7_wrong_type_arg_error(sc, "set! port-line-number", 1, p, "an input port"));
+ }
+
+ line = (is_null(cdr(args)) ? car(args) : cadr(args));
+ if (!is_integer(line))
+ return(s7_wrong_type_arg_error(sc, "set! port-line-number", 2, line, "an integer"));
+ port_line_number(p) = integer(line);
+ return(line);
+}
+
const char *s7_port_filename(s7_pointer x)
{
@@ -25999,13 +26155,13 @@ static s7_pointer c_port_filename(s7_scheme *sc, s7_pointer x)
return(s7_make_string_with_length(sc, "", 0));
/* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
}
- method_or_bust_with_type(sc, x, sc->PORT_FILENAME, list_1(sc, x), AN_OPEN_PORT, 0);
+ method_or_bust_with_type(sc, x, sc->port_filename_symbol, list_1(sc, x), an_open_port_string, 0);
}
static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args)
{
#define H_port_filename "(port-filename file-port) returns the filename associated with port"
- #define Q_port_filename s7_make_signature(sc, 2, sc->IS_STRING, sc->T)
+ #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, sc->T)
if (is_null(args))
return(c_port_filename(sc, sc->input_port));
@@ -26025,7 +26181,7 @@ static s7_pointer g_is_input_port(s7_scheme *sc, s7_pointer args)
{
#define H_is_input_port "(input-port? p) returns #t if p is an input port"
#define Q_is_input_port pl_bt
- check_boolean_method(sc, is_input_port, sc->IS_INPUT_PORT, args);
+ check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, args);
}
@@ -26039,7 +26195,7 @@ static s7_pointer g_is_output_port(s7_scheme *sc, s7_pointer args)
{
#define H_is_output_port "(output-port? p) returns #t if p is an output port"
#define Q_is_output_port pl_bt
- check_boolean_method(sc, is_output_port, sc->IS_OUTPUT_PORT, args);
+ check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, args);
}
@@ -26052,7 +26208,7 @@ s7_pointer s7_current_input_port(s7_scheme *sc)
static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer args)
{
#define H_current_input_port "(current-input-port) returns the current input port"
- #define Q_current_input_port s7_make_signature(sc, 1, sc->IS_INPUT_PORT)
+ #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol)
return(sc->input_port);
}
@@ -26060,7 +26216,7 @@ static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer args)
static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args)
{
#define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port"
- #define Q_set_current_input_port s7_make_signature(sc, 2, sc->IS_INPUT_PORT, sc->IS_INPUT_PORT)
+ #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol)
s7_pointer old_port, port;
old_port = sc->input_port;
@@ -26104,7 +26260,7 @@ s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port)
static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer args)
{
#define H_current_output_port "(current-output-port) returns the current output port"
- #define Q_current_output_port s7_make_signature(sc, 1, sc->IS_OUTPUT_PORT)
+ #define Q_current_output_port s7_make_signature(sc, 1, sc->is_output_port_symbol)
return(sc->output_port);
}
@@ -26112,7 +26268,7 @@ static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer args)
static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args)
{
#define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
- #define Q_set_current_output_port s7_make_signature(sc, 2, sc->IS_OUTPUT_PORT, sc->IS_OUTPUT_PORT)
+ #define Q_set_current_output_port s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_output_port_symbol)
s7_pointer old_port, port;
old_port = sc->output_port;
@@ -26148,7 +26304,7 @@ s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port)
static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer args)
{
#define H_current_error_port "(current-error-port) returns the current error port"
- #define Q_current_error_port s7_make_signature(sc, 1, sc->IS_OUTPUT_PORT)
+ #define Q_current_error_port s7_make_signature(sc, 1, sc->is_output_port_symbol)
return(sc->error_port);
}
@@ -26156,7 +26312,7 @@ static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer args)
static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args)
{
#define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port"
- #define Q_set_current_error_port s7_make_signature(sc, 2, sc->IS_OUTPUT_PORT, sc->IS_OUTPUT_PORT)
+ #define Q_set_current_error_port s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_output_port_symbol)
s7_pointer old_port, port;
old_port = sc->error_port;
@@ -26178,14 +26334,14 @@ static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args)
static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args)
{
#define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port"
- #define Q_is_char_ready s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_INPUT_PORT)
+ #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol)
if (is_not_null(args))
{
s7_pointer pt = car(args);
if (!is_input_port(pt))
- method_or_bust_with_type(sc, pt, sc->IS_CHAR_READY, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, pt, sc->is_char_ready_symbol, args, an_input_port_string, 0);
if (port_is_closed(pt))
- return(simple_wrong_type_argument_with_type(sc, sc->IS_CHAR_READY, pt, AN_OPEN_PORT));
+ return(simple_wrong_type_argument_with_type(sc, sc->is_char_ready_symbol, pt, an_open_port_string));
if (is_function_port(pt))
return((*(port_input_function(pt)))(sc, S7_IS_CHAR_READY, pt));
@@ -26200,7 +26356,7 @@ static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args)
{
#define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object"
#define Q_is_eof_object pl_bt
- check_boolean_method(sc, is_eof, sc->IS_EOF_OBJECT, args);
+ check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args);
}
@@ -26263,16 +26419,16 @@ void s7_close_input_port(s7_scheme *sc, s7_pointer p)
static s7_pointer c_close_input_port(s7_scheme *sc, s7_pointer pt)
{
if (!is_input_port(pt))
- method_or_bust_with_type(sc, pt, sc->CLOSE_INPUT_PORT, set_plist_1(sc, pt), AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, pt, sc->close_input_port_symbol, set_plist_1(sc, pt), an_input_port_string, 0);
if (!is_immutable_port(pt))
s7_close_input_port(sc, pt);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args)
{
#define H_close_input_port "(close-input-port port) closes the port"
- #define Q_close_input_port s7_make_signature(sc, 2, sc->T, sc->IS_INPUT_PORT)
+ #define Q_close_input_port s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)
return(c_close_input_port(sc, car(args)));
}
@@ -26303,7 +26459,7 @@ void s7_flush_output_port(s7_scheme *sc, s7_pointer p)
static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
{
#define H_flush_output_port "(flush-output-port port) flushes the port"
- #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, sc->IS_OUTPUT_PORT)
+ #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
s7_pointer pt;
if (is_null(args))
@@ -26313,13 +26469,13 @@ static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
if (!is_output_port(pt))
{
if (pt == sc->F) return(pt);
- method_or_bust_with_type(sc, pt, sc->FLUSH_OUTPUT_PORT, args, AN_OUTPUT_PORT, 0);
+ method_or_bust_with_type(sc, pt, sc->flush_output_port_symbol, args, an_output_port_string, 0);
}
s7_flush_output_port(sc, pt);
return(pt);
}
-static s7_pointer c_flush_output_port(s7_scheme *sc) {return(g_flush_output_port(sc, sc->NIL));}
+static s7_pointer c_flush_output_port(s7_scheme *sc) {return(g_flush_output_port(sc, sc->nil));}
PF_0(flush_output_port, c_flush_output_port)
static void close_output_port(s7_scheme *sc, s7_pointer p)
@@ -26380,18 +26536,18 @@ static s7_pointer c_close_output_port(s7_scheme *sc, s7_pointer pt)
{
if (!is_output_port(pt))
{
- if (pt == sc->F) return(sc->UNSPECIFIED);
- method_or_bust_with_type(sc, pt, sc->CLOSE_OUTPUT_PORT, set_plist_1(sc, pt), AN_OUTPUT_PORT, 0);
+ if (pt == sc->F) return(sc->unspecified);
+ method_or_bust_with_type(sc, pt, sc->close_output_port_symbol, set_plist_1(sc, pt), an_output_port_string, 0);
}
if (!(is_immutable_port(pt)))
s7_close_output_port(sc, pt);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args)
{
#define H_close_output_port "(close-output-port port) closes the port"
- #define Q_close_output_port s7_make_signature(sc, 2, sc->T, sc->IS_OUTPUT_PORT)
+ #define Q_close_output_port s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
return(c_close_output_port(sc, car(args)));
}
@@ -26422,14 +26578,14 @@ static int string_read_char(s7_scheme *sc, s7_pointer port)
static int output_read_char(s7_scheme *sc, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_INPUT_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, an_input_port_string);
return(0);
}
static int closed_port_read_char(s7_scheme *sc, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_OPEN_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, an_open_port_string);
return(0);
}
@@ -26439,13 +26595,13 @@ static int closed_port_read_char(s7_scheme *sc, s7_pointer port)
static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol, bool copied)
{
- return(simple_wrong_type_argument_with_type(sc, sc->READ_LINE, port, AN_INPUT_PORT));
+ return(simple_wrong_type_argument_with_type(sc, sc->read_line_symbol, port, an_input_port_string));
}
static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol, bool copied)
{
- return(simple_wrong_type_argument_with_type(sc, sc->READ_LINE, port, AN_OPEN_PORT));
+ return(simple_wrong_type_argument_with_type(sc, sc->read_line_symbol, port, an_open_port_string));
}
@@ -26490,7 +26646,7 @@ static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol,
p = fgets(buf, read_size, port_file(port));
if (!p)
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
rtn = strchr(buf, (int)'\n');
if (rtn)
@@ -26511,7 +26667,7 @@ static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol,
previous_size -= 1;
buf = (char *)(sc->read_line_buf + previous_size);
}
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
}
@@ -26537,7 +26693,7 @@ static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol
i = port_data_size(port);
port_position(port) = i;
if (i <= port_start) /* the < part can happen -- if not caught we try to create a string of length -1 -> segfault */
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
if (copied)
return(s7_make_string_with_length(sc, (const char *)start, i - port_start));
@@ -26594,13 +26750,13 @@ static void file_write_char(s7_scheme *sc, int c, s7_pointer port)
static void input_write_char(s7_scheme *sc, int c, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE_CHAR, port, AN_OUTPUT_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_output_port_string);
}
static void closed_port_write_char(s7_scheme *sc, int c, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE_CHAR, port, AN_OPEN_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_open_port_string);
}
@@ -26609,24 +26765,24 @@ static void closed_port_write_char(s7_scheme *sc, int c, s7_pointer port)
static void input_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OUTPUT_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_output_port_string);
}
static void closed_port_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OPEN_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_open_port_string);
}
static void input_display(s7_scheme *sc, const char *s, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OUTPUT_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_output_port_string);
}
static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port)
{
- simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OPEN_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_open_port_string);
}
static void stdout_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
@@ -26749,13 +26905,13 @@ static void stderr_display(s7_scheme *sc, const char *s, s7_pointer port)
static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args)
{
#define H_write_string "(write-string str port start end) writes str to port."
- #define Q_write_string s7_make_circular_signature(sc, 3, 4, sc->IS_STRING, sc->IS_STRING, sc->IS_OUTPUT_PORT, sc->IS_INTEGER)
+ #define Q_write_string s7_make_circular_signature(sc, 3, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_output_port_symbol, sc->is_integer_symbol)
s7_pointer str, port;
s7_int start = 0, end;
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->WRITE_STRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->write_string_symbol, args, T_STRING, 1);
end = string_length(str);
if (!is_null(cdr(args)))
@@ -26766,8 +26922,8 @@ static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args)
if (!is_null(inds))
{
s7_pointer p;
- p = start_and_end(sc, sc->WRITE_STRING, NULL, inds, args, 3, &start, &end);
- if (p != sc->GC_NIL) return(p);
+ p = start_and_end(sc, sc->write_string_symbol, NULL, inds, args, 3, &start, &end);
+ if (p != sc->gc_nil) return(p);
}
}
else port = sc->output_port;
@@ -26784,7 +26940,7 @@ static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args)
string_value(x)[len] = 0;
return(x);
}
- method_or_bust_with_type(sc, port, sc->WRITE_STRING, args, AN_OUTPUT_PORT, 2);
+ method_or_bust_with_type(sc, port, sc->write_string_symbol, args, an_output_port_string, 2);
}
if (start == 0)
@@ -27066,7 +27222,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, long max_
port_loc = s7_gc_protect(sc, port);
port_port(port) = alloc_port(sc);
port_is_closed(port) = false;
- port_original_input_string(port) = sc->NIL;
+ port_original_input_string(port) = sc->nil;
port_write_character(port) = input_write_char;
port_write_string(port) = input_write_string;
@@ -27231,11 +27387,11 @@ s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode)
static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args)
{
#define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading"
- #define Q_open_input_file s7_make_signature(sc, 3, sc->IS_INPUT_PORT, sc->IS_STRING, sc->IS_STRING)
+ #define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
s7_pointer name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->OPEN_INPUT_FILE, args, T_STRING, 1);
+ method_or_bust(sc, name, sc->open_input_file_symbol, args, T_STRING, 1);
/* what if the file name is a byte-vector? currently we accept it */
if (is_pair(cdr(args)))
@@ -27243,7 +27399,7 @@ static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args)
s7_pointer mode;
mode = cadr(args);
if (!is_string(mode))
- method_or_bust_with_type(sc, mode, sc->OPEN_INPUT_FILE, args, make_string_wrapper(sc, "a string (a mode such as \"r\")"), 2);
+ method_or_bust_with_type(sc, mode, sc->open_input_file_symbol, args, make_string_wrapper(sc, "a string (a mode such as \"r\")"), 2);
/* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */
return(open_input_file_1(sc, string_value(name), string_value(mode), "open-input-file"));
}
@@ -27304,7 +27460,7 @@ static void make_standard_ports(s7_scheme *sc)
port_port(x) = (port_t *)calloc(1, sizeof(port_t));
port_type(x) = FILE_PORT;
port_is_closed(x) = false;
- port_original_input_string(x) = sc->NIL;
+ port_original_input_string(x) = sc->nil;
port_filename_length(x) = 7;
port_filename(x) = copy_string_with_length("*stdin*", 7);
port_file_number(x) = remember_file_name(sc, port_filename(x));
@@ -27376,16 +27532,16 @@ s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode
static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args)
{
#define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing"
- #define Q_open_output_file s7_make_signature(sc, 3, sc->IS_OUTPUT_PORT, sc->IS_STRING, sc->IS_STRING)
+ #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
s7_pointer name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->OPEN_OUTPUT_FILE, args, T_STRING, 1);
+ method_or_bust(sc, name, sc->open_output_file_symbol, args, T_STRING, 1);
if (is_pair(cdr(args)))
{
if (!is_string(cadr(args)))
- method_or_bust_with_type(sc, cadr(args), sc->OPEN_OUTPUT_FILE, args, make_string_wrapper(sc, "a string (a mode such as \"w\")"), 2);
+ method_or_bust_with_type(sc, cadr(args), sc->open_output_file_symbol, args, make_string_wrapper(sc, "a string (a mode such as \"w\")"), 2);
return(s7_open_output_file(sc, string_value(name), string_value(cadr(args))));
}
return(s7_open_output_file(sc, string_value(name), "w"));
@@ -27399,7 +27555,7 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, int
port_port(x) = alloc_port(sc);
port_type(x) = STRING_PORT;
port_is_closed(x) = false;
- port_original_input_string(x) = sc->NIL;
+ port_original_input_string(x) = sc->nil;
port_data(x) = (unsigned char *)input_string;
port_data_size(x) = len;
port_position(x) = 0;
@@ -27445,12 +27601,12 @@ s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string)
static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args)
{
#define H_open_input_string "(open-input-string str) opens an input port reading str"
- #define Q_open_input_string s7_make_signature(sc, 2, sc->IS_INPUT_PORT, sc->IS_STRING)
+ #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol)
s7_pointer input_string, port;
input_string = car(args);
if (!is_string(input_string))
- method_or_bust(sc, input_string, sc->OPEN_INPUT_STRING, args, T_STRING, 0);
+ method_or_bust(sc, input_string, sc->open_input_string_symbol, args, T_STRING, 0);
port = open_and_protect_input_string(sc, input_string);
return(port);
}
@@ -27492,7 +27648,7 @@ s7_pointer s7_open_output_string(s7_scheme *sc)
static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer args)
{
#define H_open_output_string "(open-output-string) opens an output string port"
- #define Q_open_output_string s7_make_signature(sc, 1, sc->IS_OUTPUT_PORT)
+ #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol)
return(s7_open_output_string(sc));
}
@@ -27508,7 +27664,7 @@ static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
{
#define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port. \
If the optional 'clear-port' is #t, the current string is flushed."
- #define Q_get_output_string s7_make_signature(sc, 3, sc->IS_STRING, sc->IS_OUTPUT_PORT, sc->IS_BOOLEAN)
+ #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_output_port_symbol, sc->is_boolean_symbol)
s7_pointer p, result;
bool clear_port = false;
@@ -27517,7 +27673,7 @@ If the optional 'clear-port' is #t, the current string is flushed."
{
p = cadr(args);
if (!s7_is_boolean(p))
- return(wrong_type_argument(sc, sc->GET_OUTPUT_STRING, 2, p, T_BOOLEAN));
+ return(wrong_type_argument(sc, sc->get_output_string_symbol, 2, p, T_BOOLEAN));
clear_port = (p == sc->T);
}
p = car(args);
@@ -27525,10 +27681,10 @@ If the optional 'clear-port' is #t, the current string is flushed."
(!is_string_port(p)))
{
if (p == sc->F) return(make_empty_string(sc, 0, 0));
- method_or_bust_with_type(sc, p, sc->GET_OUTPUT_STRING, args, make_string_wrapper(sc, "an output string port"), 0);
+ method_or_bust_with_type(sc, p, sc->get_output_string_symbol, args, make_string_wrapper(sc, "an output string port"), 0);
}
if (port_is_closed(p))
- return(simple_wrong_type_argument_with_type(sc, sc->GET_OUTPUT_STRING, p, make_string_wrapper(sc, "an active (open) string port")));
+ return(simple_wrong_type_argument_with_type(sc, sc->get_output_string_symbol, p, make_string_wrapper(sc, "an active (open) string port")));
result = s7_make_string_with_length(sc, (const char *)port_data(p), port_position(p));
if (clear_port)
@@ -27547,7 +27703,7 @@ s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_schem
port_port(x) = alloc_port(sc);
port_type(x) = FUNCTION_PORT;
port_is_closed(x) = false;
- port_original_input_string(x) = sc->NIL;
+ port_original_input_string(x) = sc->nil;
port_needs_free(x) = false;
port_input_function(x) = function;
port_read_character(x) = function_read_char;
@@ -27585,7 +27741,7 @@ static void push_input_port(s7_scheme *sc, s7_pointer new_port)
sc->temp6 = sc->input_port;
sc->input_port = new_port;
sc->input_port_stack = cons(sc, sc->temp6, sc->input_port_stack);
- sc->temp6 = sc->NIL;
+ sc->temp6 = sc->nil;
}
@@ -27683,7 +27839,7 @@ static s7_pointer input_port_if_not_loading(s7_scheme *sc)
static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
{
#define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port"
- #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->IS_CHAR, sc->IS_EOF_OBJECT), sc->IS_INPUT_PORT)
+ #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port;
if (is_not_null(args))
@@ -27691,10 +27847,10 @@ static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
else
{
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
}
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ_CHAR, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->read_char_symbol, args, an_input_port_string, 0);
return(chars[port_read_character(port)(sc, port)]);
}
@@ -27706,7 +27862,7 @@ static s7_pointer g_read_char_0(s7_scheme *sc, s7_pointer args)
port = input_port_if_not_loading(sc);
if (port)
return(chars[port_read_character(port)(sc, port)]);
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
}
@@ -27715,7 +27871,7 @@ static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
s7_pointer port;
port = car(args);
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ_CHAR, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->read_char_symbol, args, an_input_port_string, 0);
return(chars[port_read_character(port)(sc, port)]);
}
@@ -27724,10 +27880,10 @@ static s7_pointer c_read_char(s7_scheme *sc)
int c;
s7_pointer port;
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
c = port_read_character(port)(sc, port);
if (c == EOF)
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
return(chars[c]);
}
@@ -27747,19 +27903,19 @@ static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int args, s7_po
static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args)
{
#define H_write_char "(write-char char (port (current-output-port))) writes char to the output port"
- #define Q_write_char s7_make_signature(sc, 3, sc->IS_CHAR, sc->IS_CHAR, sc->IS_OUTPUT_PORT)
+ #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, sc->is_output_port_symbol)
s7_pointer port, chr;
chr = car(args);
if (!s7_is_character(chr))
- method_or_bust(sc, chr, sc->WRITE_CHAR, args, T_CHARACTER, 1);
+ method_or_bust(sc, chr, sc->write_char_symbol, args, T_CHARACTER, 1);
if (is_pair(cdr(args)))
port = cadr(args);
else port = sc->output_port;
if (port == sc->F) return(chr);
if (!is_output_port(port))
- method_or_bust_with_type(sc, port, sc->WRITE_CHAR, args, AN_OUTPUT_PORT, 2);
+ method_or_bust_with_type(sc, port, sc->write_char_symbol, args, an_output_port_string, 2);
port_write_character(port)(sc, s7_character(chr), port);
return(chr);
@@ -27768,7 +27924,7 @@ static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args)
static s7_pointer c_write_char(s7_scheme *sc, s7_pointer chr)
{
if (!s7_is_character(chr))
- method_or_bust(sc, chr, sc->WRITE_CHAR, set_plist_1(sc, chr), T_CHARACTER, 1);
+ method_or_bust(sc, chr, sc->write_char_symbol, set_plist_1(sc, chr), T_CHARACTER, 1);
if (sc->output_port == sc->F) return(chr);
port_write_character(sc->output_port)(sc, s7_character(chr), sc->output_port);
return(chr);
@@ -27797,7 +27953,7 @@ static s7_pointer write_char_chooser(s7_scheme *sc, s7_pointer f, int args, s7_p
static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args)
{
#define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream"
- #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->IS_CHAR, sc->IS_EOF_OBJECT), sc->IS_INPUT_PORT)
+ #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port;
if (is_not_null(args))
@@ -27805,9 +27961,9 @@ static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args)
else port = sc->input_port;
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->PEEK_CHAR, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->peek_char_symbol, args, an_input_port_string, 0);
if (port_is_closed(port))
- return(simple_wrong_type_argument_with_type(sc, sc->PEEK_CHAR, port, AN_OPEN_PORT));
+ return(simple_wrong_type_argument_with_type(sc, sc->peek_char_symbol, port, an_open_port_string));
if (is_function_port(port))
return((*(port_input_function(port)))(sc, S7_PEEK_CHAR, port));
@@ -27821,7 +27977,7 @@ PF_0(peek_char, c_peek_char)
static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args)
{
#define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port"
- #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_EOF_OBJECT), sc->IS_INPUT_PORT)
+ #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port;
int c;
@@ -27830,14 +27986,14 @@ static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args)
else
{
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
}
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ_BYTE, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->read_byte_symbol, args, an_input_port_string, 0);
c = port_read_character(port)(sc, port);
if (c == EOF)
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
return(small_int(c));
}
@@ -27846,10 +28002,10 @@ static s7_pointer c_read_byte(s7_scheme *sc)
int c;
s7_pointer port;
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
c = port_read_character(port)(sc, port);
if (c == EOF)
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
return(small_int(c));
}
@@ -27859,17 +28015,17 @@ PF_0(read_byte, c_read_byte)
static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
{
#define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port"
- #define Q_write_byte s7_make_signature(sc, 3, sc->IS_INTEGER, sc->IS_INTEGER, sc->IS_OUTPUT_PORT)
+ #define Q_write_byte s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_output_port_symbol)
s7_pointer port, b;
s7_int val;
b = car(args);
if (!s7_is_integer(b))
- method_or_bust(sc, car(args), sc->WRITE_BYTE, args, T_INTEGER, 1);
+ method_or_bust(sc, car(args), sc->write_byte_symbol, args, T_INTEGER, 1);
val = s7_integer(b);
if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */
- return(wrong_type_argument_with_type(sc, sc->WRITE_BYTE, 1, b, AN_UNSIGNED_BYTE));
+ return(wrong_type_argument_with_type(sc, sc->write_byte_symbol, 1, b, an_unsigned_byte_string));
if (is_pair(cdr(args)))
port = cadr(args);
@@ -27878,7 +28034,7 @@ static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
if (!is_output_port(port))
{
if (port == sc->F) return(car(args));
- method_or_bust_with_type(sc, port, sc->WRITE_BYTE, args, AN_OUTPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->write_byte_symbol, args, an_output_port_string, 0);
}
s7_write_char(sc, (int)(s7_integer(b)), port);
@@ -27888,7 +28044,7 @@ static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
static s7_int c_write_byte(s7_scheme *sc, s7_int x)
{
if ((x < 0) || (x > 255))
- wrong_type_argument_with_type(sc, sc->WRITE_BYTE, 1, make_integer(sc, x), AN_UNSIGNED_BYTE);
+ wrong_type_argument_with_type(sc, sc->write_byte_symbol, 1, make_integer(sc, x), an_unsigned_byte_string);
s7_write_char(sc, (int)x, sc->output_port);
return(x);
}
@@ -27900,7 +28056,7 @@ static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args)
{
#define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #<eof>.\
If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
- #define Q_read_line s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_EOF_OBJECT), sc->IS_INPUT_PORT, sc->IS_BOOLEAN)
+ #define Q_read_line s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol, sc->is_boolean_symbol)
s7_pointer port;
bool with_eol = false;
@@ -27909,7 +28065,7 @@ If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
{
port = car(args);
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ_LINE, args, AN_INPUT_PORT, 1);
+ method_or_bust_with_type(sc, port, sc->read_line_symbol, args, an_input_port_string, 1);
if (is_not_null(cdr(args)))
with_eol = (cadr(args) != sc->F);
@@ -27917,12 +28073,12 @@ If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
else
{
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
}
return(port_read_line(port)(sc, port, with_eol, true));
}
-static s7_pointer c_read_line(s7_scheme *sc) {return(g_read_line(sc, sc->NIL));}
+static s7_pointer c_read_line(s7_scheme *sc) {return(g_read_line(sc, sc->nil));}
PF_0(read_line, c_read_line)
@@ -27947,13 +28103,13 @@ static s7_pointer c_read_string(s7_scheme *sc, s7_int chars, s7_pointer port)
unsigned char *str;
if (chars < 0)
- return(wrong_type_argument_with_type(sc, sc->READ_STRING, 1, make_integer(sc, chars), A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->read_string_symbol, 1, make_integer(sc, chars), a_non_negative_integer_string));
if (chars > sc->max_string_length)
- return(out_of_range(sc, sc->READ_STRING, small_int(1), make_integer(sc, chars), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->read_string_symbol, small_int(1), make_integer(sc, chars), its_too_large_string));
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ_STRING, list_2(sc, make_integer(sc, chars), port), AN_INPUT_PORT, 2);
+ method_or_bust_with_type(sc, port, sc->read_string_symbol, list_2(sc, make_integer(sc, chars), port), an_input_port_string, 2);
if (chars == 0)
return(make_empty_string(sc, 0, 0));
@@ -27967,7 +28123,7 @@ static s7_pointer c_read_string(s7_scheme *sc, s7_int chars, s7_pointer port)
if (c == EOF)
{
if (i == 0)
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
string_length(s) = i;
return(s);
}
@@ -27979,12 +28135,12 @@ static s7_pointer c_read_string(s7_scheme *sc, s7_int chars, s7_pointer port)
static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
{
#define H_read_string "(read-string k port) reads k characters from port into a new string and returns it."
- #define Q_read_string s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_EOF_OBJECT), sc->IS_INTEGER, sc->IS_INPUT_PORT)
+ #define Q_read_string s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_integer_symbol, sc->is_input_port_symbol)
s7_pointer k, port;
k = car(args);
if (!s7_is_integer(k))
- method_or_bust(sc, k, sc->READ_STRING, args, T_INTEGER, 1);
+ method_or_bust(sc, k, sc->read_string_symbol, args, T_INTEGER, 1);
if (!is_null(cdr(args)))
port = cadr(args);
@@ -27995,42 +28151,72 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
static s7_pointer c_read_string_1(s7_scheme *sc, s7_int chars) {return(c_read_string(sc, chars, input_port_if_not_loading(sc)));}
IF_TO_PF(read_string, c_read_string_1)
+#define declare_jump_info() bool old_longjmp; int old_jump_loc, jump_loc; jmp_buf old_goto_start
+
+#define store_jump_info(Sc) \
+ do { \
+ old_longjmp = Sc->longjmp_ok; \
+ old_jump_loc = Sc->setjmp_loc; \
+ memcpy((void *)old_goto_start, (void *)(Sc->goto_start), sizeof(jmp_buf));\
+ } while (0)
+
+#define restore_jump_info(Sc) \
+ do { \
+ Sc->longjmp_ok = old_longjmp; \
+ Sc->setjmp_loc = old_jump_loc; \
+ memcpy((void *)(Sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));\
+ if ((jump_loc == ERROR_JUMP) &&\
+ (sc->longjmp_ok))\
+ longjmp(sc->goto_start, ERROR_JUMP);\
+ } while (0)
+
+#define set_jump_info(Sc, Tag) \
+ do { \
+ sc->longjmp_ok = true; \
+ sc->setjmp_loc = Tag; \
+ jump_loc = setjmp(sc->goto_start); \
+ } while (0)
+
s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
{
if (is_input_port(port))
{
- bool old_longjmp;
s7_pointer old_envir;
+ declare_jump_info();
+
old_envir = sc->envir;
- sc->envir = sc->NIL;
- if (sc->longjmp_ok)
- {
- push_input_port(sc, port);
- push_stack(sc, OP_BARRIER, port, sc->NIL);
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- eval(sc, OP_READ_INTERNAL);
- pop_input_port(sc);
- sc->envir = old_envir;
- return(sc->value);
- }
- stack_reset(sc);
- push_stack(sc, OP_EVAL_DONE, old_envir, sc->NIL); /* GC protect envir */
+ sc->envir = sc->nil;
push_input_port(sc, port);
- old_longjmp = sc->longjmp_ok;
- if (!sc->longjmp_ok)
+
+ store_jump_info(sc);
+ set_jump_info(sc, READ_SET_JUMP);
+ if (jump_loc != NO_JUMP)
{
- sc->longjmp_ok = true;
- if (setjmp(sc->goto_start) != 0)
+ if (jump_loc != ERROR_JUMP)
eval(sc, sc->op);
- else eval(sc, OP_READ_INTERNAL);
}
- sc->longjmp_ok = old_longjmp;
+ else
+ {
+ push_stack(sc, OP_BARRIER, port, sc->nil);
+ push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+
+ eval(sc, OP_READ_INTERNAL);
+
+ if (sc->tok == TOKEN_EOF)
+ sc->value = sc->eof_object;
+
+ if ((sc->op == OP_EVAL_DONE) &&
+ (stack_op(sc->stack, s7_stack_top(sc) - 1) == OP_BARRIER))
+ pop_stack(sc);
+ }
pop_input_port(sc);
sc->envir = old_envir;
+
+ restore_jump_info(sc);
return(sc->value);
}
- return(simple_wrong_type_argument_with_type(sc, sc->READ, port, AN_INPUT_PORT));
+ return(simple_wrong_type_argument_with_type(sc, sc->read_symbol, port, an_input_port_string));
}
@@ -28046,7 +28232,7 @@ static s7_pointer g_read(s7_scheme *sc, s7_pointer args)
* (eval, eval-string and load already have an env arg)
*/
#define H_read "(read (port (current-input-port))) returns the next object in the input port, or #<eof> at the end"
- #define Q_read s7_make_signature(sc, 2, sc->T, sc->IS_INPUT_PORT)
+ #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)
s7_pointer port;
if (is_not_null(args))
@@ -28054,27 +28240,27 @@ static s7_pointer g_read(s7_scheme *sc, s7_pointer args)
else
{
port = input_port_if_not_loading(sc);
- if (!port) return(sc->EOF_OBJECT);
+ if (!port) return(sc->eof_object);
}
if (!is_input_port(port))
- method_or_bust_with_type(sc, port, sc->READ, args, AN_INPUT_PORT, 0);
+ method_or_bust_with_type(sc, port, sc->read_symbol, args, an_input_port_string, 0);
if (is_function_port(port))
return((*(port_input_function(port)))(sc, S7_READ, port));
if ((is_string_port(port)) &&
(port_data_size(port) <= port_position(port)))
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
push_input_port(sc, port);
- push_stack(sc, OP_READ_DONE, sc->NIL, sc->NIL); /* this stops the internal read process so we only get one form */
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_READ_DONE, sc->nil, sc->nil); /* this stops the internal read process so we only get one form */
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
return(port);
}
-static s7_pointer c_read(s7_scheme *sc) {return(g_read(sc, sc->NIL));}
+static s7_pointer c_read(s7_scheme *sc) {return(g_read(sc, sc->nil));}
PF_0(read, c_read)
@@ -28103,11 +28289,12 @@ static FILE *search_load_path(s7_scheme *sc, const char *name)
}
-static s7_pointer s7_load_1(s7_scheme *sc, const char *filename, s7_pointer e)
+s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e)
{
s7_pointer port;
FILE *fp;
char *new_filename = NULL;
+ declare_jump_info();
fp = fopen(filename, "r");
if (!fp)
@@ -28119,7 +28306,7 @@ static s7_pointer s7_load_1(s7_scheme *sc, const char *filename, s7_pointer e)
if (!fp)
return(file_error(sc, "load", "can't open", filename));
- if (is_pair(s7_hook_functions(sc, sc->load_hook)))
+ if (hook_has_functions(sc->load_hook))
s7_call(sc, sc->load_hook, list_1(sc, sc->temp4 = s7_make_string(sc, filename)));
port = read_file(sc, fp, (new_filename) ? (const char *)new_filename : filename, -1, "load"); /* -1 means always read its contents into a local string */
@@ -28134,31 +28321,29 @@ static s7_pointer s7_load_1(s7_scheme *sc, const char *filename, s7_pointer e)
sc->envir = e;
push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
- if (!sc->longjmp_ok)
+ store_jump_info(sc);
+ set_jump_info(sc, LOAD_SET_JUMP);
+ if (jump_loc != NO_JUMP)
{
- bool old_longjmp;
- old_longjmp = sc->longjmp_ok;
- if (!sc->longjmp_ok)
- {
- sc->longjmp_ok = true;
- if (setjmp(sc->goto_start) != 0)
- eval(sc, sc->op);
- else eval(sc, OP_READ_INTERNAL);
- }
- sc->longjmp_ok = old_longjmp;
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->op);
}
else eval(sc, OP_READ_INTERNAL);
pop_input_port(sc);
if (is_input_port(port))
s7_close_input_port(sc, port);
- return(sc->value);
+
+ restore_jump_info(sc);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
}
s7_pointer s7_load(s7_scheme *sc, const char *filename)
{
- return(s7_load_1(sc, filename, sc->NIL));
+ return(s7_load_with_environment(sc, filename, sc->nil));
}
@@ -28187,7 +28372,7 @@ static s7_pointer g_load(s7_scheme *sc, s7_pointer args)
{
#define H_load "(load file (env (rootlet))) loads the scheme file 'file'. The 'env' argument \
defaults to the rootlet. To load into the current environment instead, pass (curlet)."
- #define Q_load s7_make_signature(sc, 3, sc->VALUES, sc->IS_STRING, sc->IS_LET)
+ #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
FILE *fp = NULL;
s7_pointer name, port;
@@ -28195,26 +28380,26 @@ defaults to the rootlet. To load into the current environment instead, pass (cu
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->LOAD, args, T_STRING, 1);
+ method_or_bust(sc, name, sc->load_symbol, args, T_STRING, 1);
if (is_not_null(cdr(args)))
{
s7_pointer e;
e = cadr(args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->LOAD, 2, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->load_symbol, 2, e, a_let_string));
if (e == sc->rootlet)
- sc->envir = sc->NIL;
+ sc->envir = sc->nil;
else sc->envir = e;
}
- else sc->envir = sc->NIL;
+ else sc->envir = sc->nil;
fname = string_value(name);
if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */
- return(s7_error(sc, sc->OUT_OF_RANGE, set_elist_2(sc, make_string_wrapper(sc, "load's first argument, ~S, should be a filename"), name)));
+ return(s7_error(sc, sc->out_of_range_symbol, set_elist_2(sc, make_string_wrapper(sc, "load's first argument, ~S, should be a filename"), name)));
if (is_directory(fname))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "load argument, ~S, is a directory"), name)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "load argument, ~S, is a directory"), name)));
#if WITH_C_LOADER
/* if fname ends in .so, try loading it as a c shared object
@@ -28305,34 +28490,34 @@ defaults to the rootlet. To load into the current environment instead, pass (cu
set_loader_port(port);
push_input_port(sc, port);
- push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->NIL, sc->NIL); /* was pushing args and code, but I don't think they're used later */
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->nil, sc->nil); /* was pushing args and code, but I don't think they're used later */
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
/* now we've opened and moved to the file to be loaded, and set up the stack to return
* to where we were. Call *load-hook* if it is a procedure.
*/
- if (is_not_null(s7_hook_functions(sc, sc->load_hook)))
+ if (hook_has_functions(sc->load_hook))
s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp4 = s7_make_string(sc, fname)));
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
s7_pointer s7_load_path(s7_scheme *sc)
{
- return(s7_symbol_value(sc, sc->LOAD_PATH));
+ return(s7_symbol_value(sc, sc->load_path_symbol));
}
s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir)
{
s7_symbol_set_value(sc,
- sc->LOAD_PATH,
+ sc->load_path_symbol,
cons(sc,
s7_make_string(sc, dir),
- s7_symbol_value(sc, sc->LOAD_PATH)));
- return(s7_symbol_value(sc, sc->LOAD_PATH));
+ s7_symbol_value(sc, sc->load_path_symbol)));
+ return(s7_symbol_value(sc, sc->load_path_symbol));
}
@@ -28345,11 +28530,23 @@ static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args)
s7_pointer x;
for (x = cadr(args); is_pair(x); x = cdr(x))
if (!is_string(car(x)))
- return(sc->ERROR);
+ return(sc->error_symbol);
if (is_null(x))
return(cadr(args));
}
- return(sc->ERROR);
+ return(sc->error_symbol);
+}
+
+static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer cl_dir;
+ cl_dir = cadr(args);
+ if (!is_string(cl_dir))
+ return(sc->error_symbol);
+ s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir);
+ if (safe_strlen(string_value(cl_dir)) > 0)
+ s7_add_to_load_path(sc, (const char *)(string_value(cl_dir)));
+ return(cl_dir);
}
@@ -28473,7 +28670,7 @@ static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args)
If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \
the function. The function takes one argument, the calling environment. Presumably the symbol is defined \
in the file, or by the function."
- #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->IS_SYMBOL, sc->T)
+ #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T)
s7_pointer sym, value;
@@ -28486,7 +28683,7 @@ in the file, or by the function."
}
if (!is_symbol(sym))
{
- check_method(sc, sym, sc->AUTOLOAD, args);
+ check_method(sc, sym, sc->autoload_symbol, args);
return(s7_wrong_type_arg_error(sc, "autoload", 1, sym, "a string (symbol-name) or a symbol"));
}
if (is_keyword(sym))
@@ -28499,7 +28696,7 @@ in the file, or by the function."
(s7_is_aritable(sc, value, 1)))
return(s7_autoload(sc, sym, value));
- check_method(sc, value, sc->AUTOLOAD, args);
+ check_method(sc, value, sc->autoload_symbol, args);
return(s7_wrong_type_arg_error(sc, "autoload", 2, value, "a string (file-name) or a thunk"));
}
@@ -28507,13 +28704,13 @@ in the file, or by the function."
static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args)
{
#define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f."
- #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->IS_SYMBOL)
+ #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
s7_pointer sym;
sym = car(args);
if (!is_symbol(sym))
{
- check_method(sc, sym, sc->AUTOLOADER, args);
+ check_method(sc, sym, sc->autoloader_symbol, args);
return(s7_wrong_type_arg_error(sc, "*autoload*", 1, sym, "a symbol"));
}
if (sc->autoload_names)
@@ -28535,7 +28732,7 @@ static s7_pointer g_require(s7_scheme *sc, s7_pointer args)
{
#define H_require "(require . symbols) loads each file associated with each symbol if it has not been loaded already.\
The symbols refer to the argument to \"provide\"."
- #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->IS_SYMBOL)
+ #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol)
s7_pointer p;
sc->temp5 = cons(sc, args, sc->temp5);
@@ -28548,10 +28745,10 @@ The symbols refer to the argument to \"provide\"."
s7_pointer f;
f = g_autoloader(sc, p);
if (is_string(f))
- s7_load_1(sc, string_value(f), sc->envir);
+ s7_load_with_environment(sc, string_value(f), sc->envir);
else
{
- sc->temp5 = sc->NIL;
+ sc->temp5 = sc->nil;
return(s7_error(sc, make_symbol(sc, "autoload-error"),
set_elist_2(sc, make_string_wrapper(sc, "require: no autoload info for ~S"), car(p))));
}
@@ -28559,10 +28756,10 @@ The symbols refer to the argument to \"provide\"."
}
else
{
- sc->temp5 = sc->NIL;
- if ((is_pair(car(p))) && (caar(p) == sc->QUOTE))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "require: don't quote ~S"), car(p))));
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "require: ~S is not a symbol"), car(p))));
+ sc->temp5 = sc->nil;
+ if ((is_pair(car(p))) && (caar(p) == sc->quote_symbol))
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "require: don't quote ~S"), car(p))));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "require: ~S is not a symbol"), car(p))));
}
}
sc->temp5 = cdr(sc->temp5);
@@ -28572,95 +28769,39 @@ The symbols refer to the argument to \"provide\"."
/* -------------------------------- eval-string -------------------------------- */
-static s7_pointer eval_string_1(s7_scheme *sc, const char *str)
-{
- s7_pointer port;
-
- port = s7_open_input_string(sc, str);
- push_input_port(sc, port);
-
- push_stack(sc, OP_BARRIER, port, sc->NIL);
- /* we're being called directly from C here, not as part of a scheme program.
- * Use this op to protect the port, I guess.
- */
- push_stack(sc, OP_EVAL_STRING, sc->args, sc->code);
- /* eval-string is not tail-recursive because it pushes markers in eval to catch
- * multiple statements in one eval-string call.
- */
- eval(sc, OP_READ_INTERNAL);
-
- pop_input_port(sc);
- s7_close_input_port(sc, port);
- if (is_multiple_value(sc->value)) /* (+ 1 (eval-string "(values 2 3)")) */
- sc->value = splice_in_values(sc, multiple_value(sc->value));
-
- return(sc->value);
-}
-
-
s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e)
{
- bool old_longjmp;
- s7_pointer port, old_envir;
- /* this can be called recursively via s7_call */
-
- sc->v = sc->envir; /* old envir needs GC protection even given the push_stack below */
- old_envir = sc->envir;
- sc->envir = e;
- if (sc->longjmp_ok)
- {
- s7_pointer result;
- result = eval_string_1(sc, str);
- sc->envir = old_envir;
- return(result);
- }
-
- stack_reset(sc);
- push_stack(sc, OP_EVAL_STRING, old_envir, sc->NIL); /* GC protect envir */
-
+ s7_pointer code, port;
port = s7_open_input_string(sc, str);
- push_input_port(sc, port);
-
- old_longjmp = sc->longjmp_ok;
- if (!sc->longjmp_ok)
- {
- sc->longjmp_ok = true;
- if (setjmp(sc->goto_start) != 0)
- eval(sc, sc->op);
- else eval(sc, OP_READ_INTERNAL);
- }
-
- sc->longjmp_ok = old_longjmp;
- pop_input_port(sc);
+ code = s7_read(sc, port);
s7_close_input_port(sc, port);
- sc->envir = old_envir;
- return(sc->value);
+ return(s7_eval(sc, _NFre(code), e));
}
s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str)
{
- return(s7_eval_c_string_with_environment(sc, str, sc->NIL));
+ return(s7_eval_c_string_with_environment(sc, str, sc->nil));
}
static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args)
{
#define H_eval_string "(eval-string str (env (curlet))) returns the result of evaluating the string str as Scheme code"
- #define Q_eval_string s7_make_signature(sc, 3, sc->VALUES, sc->IS_STRING, sc->IS_LET)
+ #define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
s7_pointer port, str;
-
+
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->EVAL_STRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->eval_string_symbol, args, T_STRING, 1);
if (is_not_null(cdr(args)))
{
s7_pointer e;
e = cadr(args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->EVAL_STRING, 2, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->eval_string_symbol, 2, e, a_let_string));
if (e == sc->rootlet)
- sc->envir = sc->NIL;
+ sc->envir = sc->nil;
else sc->envir = e;
}
@@ -28669,7 +28810,7 @@ static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args)
sc->temp3 = sc->args;
push_stack(sc, OP_EVAL_STRING_1, args, sc->code);
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
return(sc->F);
}
@@ -28703,18 +28844,18 @@ static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args)
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->CALL_WITH_INPUT_STRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->call_with_input_string_symbol, args, T_STRING, 1);
proc = cadr(args);
if (is_let(proc))
- check_method(sc, proc, sc->CALL_WITH_INPUT_STRING, args);
+ check_method(sc, proc, sc->call_with_input_string_symbol, args);
if (!s7_is_aritable(sc, proc, 1))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_STRING, 2, proc,
+ return(wrong_type_argument_with_type(sc, sc->call_with_input_string_symbol, 2, proc,
make_string_wrapper(sc, "a procedure of one argument (the port)")));
if ((is_continuation(proc)) || (is_goto(proc)))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_STRING, 2, proc, A_NORMAL_PROCEDURE));
+ return(wrong_type_argument_with_type(sc, sc->call_with_input_string_symbol, 2, proc, a_normal_procedure_string));
return(call_with_input(sc, open_and_protect_input_string(sc, str), args));
}
@@ -28733,14 +28874,14 @@ static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args)
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->CALL_WITH_INPUT_FILE, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->call_with_input_file_symbol, args, T_STRING, 1);
proc = cadr(args);
if (!s7_is_aritable(sc, proc, 1))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_FILE, 2, proc,
+ return(wrong_type_argument_with_type(sc, sc->call_with_input_file_symbol, 2, proc,
make_string_wrapper(sc, "a procedure of one argument (the port)")));
if ((is_continuation(proc)) || (is_goto(proc)))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_FILE, 2, proc, A_NORMAL_PROCEDURE));
+ return(wrong_type_argument_with_type(sc, sc->call_with_input_file_symbol, 2, proc, a_normal_procedure_string));
return(call_with_input(sc, open_input_file_1(sc, string_value(str), "r", "call-with-input-file"), args));
}
@@ -28757,7 +28898,7 @@ static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
port_original_input_string(port) = car(args);
push_stack(sc, OP_UNWIND_INPUT, old_input_port, port);
p = cadr(args);
- push_stack(sc, OP_APPLY, sc->NIL, p);
+ push_stack(sc, OP_APPLY, sc->nil, p);
return(sc->F);
}
@@ -28772,10 +28913,10 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args)
str = car(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->WITH_INPUT_FROM_STRING, args, T_STRING, 1);
+ method_or_bust(sc, str, sc->with_input_from_string_symbol, args, T_STRING, 1);
if (!is_thunk(sc, cadr(args)))
- method_or_bust_with_type(sc, cadr(args), sc->WITH_INPUT_FROM_STRING, args, A_THUNK, 2);
+ method_or_bust_with_type(sc, cadr(args), sc->with_input_from_string_symbol, args, a_thunk_string, 2);
/* since the arguments are evaluated before we get here, we can get some confusing situations:
* (with-input-from-string "#x2.1" (read))
@@ -28797,10 +28938,10 @@ static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args)
#define Q_with_input_from_file pl_sf
if (!is_string(car(args)))
- method_or_bust(sc, car(args), sc->WITH_INPUT_FROM_FILE, args, T_STRING, 1);
+ method_or_bust(sc, car(args), sc->with_input_from_file_symbol, args, T_STRING, 1);
if (!is_thunk(sc, cadr(args)))
- method_or_bust_with_type(sc, cadr(args), sc->WITH_INPUT_FROM_FILE, args, A_THUNK, 2);
+ method_or_bust_with_type(sc, cadr(args), sc->with_input_from_file_symbol, args, a_thunk_string, 2);
return(with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "with-input-from-file"), args));
}
@@ -28820,8 +28961,8 @@ static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args)
x = car(args);
if (is_iterator(x)) return(sc->T);
- check_closure_for(sc, x, sc->IS_ITERATOR);
- check_boolean_method(sc, is_iterator, sc->IS_ITERATOR, args);
+ check_closure_for(sc, x, sc->is_iterator_symbol);
+ check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args);
return(sc->F);
}
@@ -28877,7 +29018,7 @@ static s7_pointer rootlet_iterate(s7_scheme *sc, s7_pointer iterator)
iterator_position(iterator)++;
iterator_current(iterator) = vector_element(sc->rootlet, iterator_position(iterator));
}
- else iterator_current(iterator) = sc->NIL;
+ else iterator_current(iterator) = sc->nil;
return(cons(sc, slot_symbol(slot), slot_value(slot)));
}
iterator_next(iterator) = iterator_finished;
@@ -28976,7 +29117,7 @@ static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj)
static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj)
{
s7_pointer result;
- result = s7_apply_function(sc, iterator_sequence(obj), sc->NIL);
+ result = s7_apply_function(sc, iterator_sequence(obj), sc->nil);
if (result == sc->ITERATOR_END)
iterator_next(obj) = iterator_finished;
return(result);
@@ -29005,12 +29146,12 @@ static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj)
s7_pointer result, p, cur;
p = iterator_sequence(obj);
cur = iterator_current(obj);
- car(sc->Z2_1) = sc->x;
- car(sc->Z2_2) = sc->z; /* is this necessary? */
+ car(sc->z2_1) = sc->x;
+ car(sc->z2_2) = sc->z; /* is this necessary? */
car(cur) = make_integer(sc, iterator_position(obj));
result = (*(c_object_ref(p)))(sc, p, cur);
- sc->x = car(sc->Z2_1);
- sc->z = car(sc->Z2_2);
+ sc->x = car(sc->z2_1);
+ sc->z = car(sc->z2_2);
iterator_position(obj)++;
if (result == sc->ITERATOR_END)
iterator_next(obj) = iterator_finished;
@@ -29065,12 +29206,12 @@ static s7_pointer iterator_method(s7_scheme *sc, s7_pointer e)
{
s7_pointer func;
if ((has_methods(e)) &&
- ((func = find_method(sc, find_let(sc, e), sc->MAKE_ITERATOR)) != sc->UNDEFINED))
+ ((func = find_method(sc, find_let(sc, e), sc->make_iterator_symbol)) != sc->undefined))
{
s7_pointer it;
it = s7_apply_function(sc, func, list_1(sc, e));
if (!is_iterator(it))
- return(s7_error(sc, sc->ERROR, set_elist_2(sc, make_string_wrapper(sc, "make-iterator method must return an interator: ~S"), it)));
+ return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "make-iterator method must return an interator: ~S"), it)));
return(it);
}
return(NULL);
@@ -29097,7 +29238,7 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
s7_pointer f;
sc->temp6 = iter;
f = iterator_method(sc, e);
- sc->temp6 = sc->NIL;
+ sc->temp6 = sc->nil;
if (f) {free_cell(sc, iter); return(f);}
iterator_let_current(iter) = let_slots(e);
iterator_next(iter) = let_iterate;
@@ -29145,7 +29286,7 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
case T_CLOSURE: case T_CLOSURE_STAR:
{
s7_pointer p;
- p = cons(sc, e, sc->NIL);
+ p = cons(sc, e, sc->nil);
if (g_is_iterator(sc, p) != sc->F)
{
car(p) = small_int(0);
@@ -29159,7 +29300,7 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
else
{
free_cell(sc, iter);
- return(simple_wrong_type_argument_with_type(sc, sc->MAKE_ITERATOR, e, make_string_wrapper(sc, "a closure/macro with an 'iterator local that is not #f")));
+ return(simple_wrong_type_argument_with_type(sc, sc->make_iterator_symbol, e, make_string_wrapper(sc, "a closure/macro with an 'iterator local that is not #f")));
}
}
break;
@@ -29176,16 +29317,16 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
s7_pointer f;
sc->temp6 = iter;
f = iterator_method(sc, e);
- sc->temp6 = sc->NIL;
+ sc->temp6 = sc->nil;
if (f) {free_cell(sc, iter); return(f);}
- iterator_current(iter) = cons(sc, small_int(0), sc->NIL);
+ iterator_current(iter) = cons(sc, small_int(0), sc->nil);
set_mark_seq(iter);
iterator_next(iter) = c_object_iterate;
}
break;
default:
- return(simple_wrong_type_argument_with_type(sc, sc->MAKE_ITERATOR, e, A_SEQUENCE));
+ return(simple_wrong_type_argument_with_type(sc, sc->make_iterator_symbol, e, a_sequence_string));
}
return(iter);
}
@@ -29195,7 +29336,7 @@ static s7_pointer g_make_iterator(s7_scheme *sc, s7_pointer args)
{
#define H_make_iterator "(make-iterator sequence) returns an iterator object that \
returns the next value in the sequence each time it is called. When it reaches the end, it returns " ITERATOR_END_NAME "."
- #define Q_make_iterator s7_make_signature(sc, 3, sc->IS_ITERATOR, sc->IS_SEQUENCE, sc->IS_PAIR)
+ #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol)
s7_pointer seq;
seq = car(args);
@@ -29221,7 +29362,7 @@ returns the next value in the sequence each time it is called. When it reaches
return(iter);
}
}
- else return(simple_wrong_type_argument(sc, sc->MAKE_ITERATOR, cadr(args), T_PAIR));
+ else return(simple_wrong_type_argument(sc, sc->make_iterator_symbol, cadr(args), T_PAIR));
}
return(s7_make_iterator(sc, seq));
}
@@ -29232,19 +29373,19 @@ PF_TO_PF(make_iterator, s7_make_iterator)
static s7_pointer c_iterate(s7_scheme *sc, s7_pointer iter)
{
if (!is_iterator(iter))
- method_or_bust(sc, iter, sc->ITERATE, list_1(sc, iter), T_ITERATOR, 0);
+ method_or_bust(sc, iter, sc->iterate_symbol, list_1(sc, iter), T_ITERATOR, 0);
return((iterator_next(iter))(sc, iter));
}
static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args)
{
#define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "."
- #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->IS_ITERATOR)
+ #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol)
s7_pointer iter;
iter = car(args);
if (!is_iterator(iter))
- method_or_bust(sc, iter, sc->ITERATE, args, T_ITERATOR, 0);
+ method_or_bust(sc, iter, sc->iterate_symbol, args, T_ITERATOR, 0);
return((iterator_next(iter))(sc, iter));
}
@@ -29328,20 +29469,20 @@ bool s7_iterator_is_at_end(s7_pointer obj)
static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args)
{
#define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing."
- #define Q_iterator_sequence s7_make_signature(sc, 2, sc->IS_SEQUENCE, sc->IS_ITERATOR)
+ #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol)
s7_pointer iter;
iter = car(args);
if (!is_iterator(iter))
- return(simple_wrong_type_argument(sc, sc->ITERATOR_SEQUENCE, iter, T_ITERATOR));
+ return(simple_wrong_type_argument(sc, sc->iterator_sequence_symbol, iter, T_ITERATOR));
return(iterator_sequence(iter));
}
static s7_pointer c_iterator_sequence(s7_scheme *sc, s7_pointer iter)
{
if (!is_iterator(iter))
- return(simple_wrong_type_argument(sc, sc->ITERATOR_SEQUENCE, iter, T_ITERATOR));
+ return(simple_wrong_type_argument(sc, sc->iterator_sequence_symbol, iter, T_ITERATOR));
return(iterator_sequence(iter));
}
@@ -29351,12 +29492,12 @@ PF_TO_PF(iterator_sequence, c_iterator_sequence)
static s7_pointer g_iterator_is_at_end(s7_scheme *sc, s7_pointer args)
{
#define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence."
- #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_ITERATOR)
+ #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol)
s7_pointer iter;
iter = car(args);
if (!is_iterator(iter))
- return(simple_wrong_type_argument(sc, sc->ITERATOR_IS_AT_END, iter, T_ITERATOR));
+ return(simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, iter, T_ITERATOR));
return(make_boolean(sc, iterator_is_at_end(iter)));
}
@@ -29712,23 +29853,23 @@ static s7_pointer cyclic_sequences(s7_scheme *sc, s7_pointer obj, bool return_li
{
int i;
s7_pointer lst;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = 0; i < ci->top; i++)
sc->w = cons(sc, ci->objs[i], sc->w);
lst = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(lst);
}
else return(sc->T);
}
}
- return(sc->NIL);
+ return(sc->nil);
}
static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args)
{
#define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic."
- #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->IS_LIST, sc->T)
+ #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T)
return(cyclic_sequences(sc, car(args), true));
}
@@ -30178,7 +30319,7 @@ static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, u
{
len = snprintf(do_str, DO_STR_LEN, "(let ((port (open-input-file \"%s\")))", filename);
port_write_string(port)(sc, do_str, len, port);
- len = snprintf(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i %d) port)))",
+ len = snprintf(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i %u) port)))",
port_position(obj) - 1);
}
else len = snprintf(do_str, DO_STR_LEN, "(open-input-file \"%s\")", filename);
@@ -30463,8 +30604,8 @@ static void list_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
else len = true_len;
}
- if (((car(lst) == sc->QUOTE) ||
- (car(lst) == sc->QUOTE_UNCHECKED)) && /* this can happen (see lint.scm) */
+ if (((car(lst) == sc->quote_symbol) ||
+ (car(lst) == sc->quote_unchecked_symbol)) && /* this can happen (see lint.scm) */
(true_len == 2))
{
/* len == 1 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird
@@ -30678,25 +30819,30 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port,
}
-static void slot_to_port_1(s7_scheme *sc, s7_pointer x, s7_pointer port, use_write_t use_write, shared_info *ci)
+static int slot_to_port_1(s7_scheme *sc, s7_pointer x, s7_pointer port, use_write_t use_write, shared_info *ci, int n)
{
if (is_slot(x))
{
- slot_to_port_1(sc, next_slot(x), port, use_write, ci);
- port_write_character(port)(sc, ' ', port);
- object_to_port_with_circle_check(sc, x, port, use_write, ci);
+ n = slot_to_port_1(sc, next_slot(x), port, use_write, ci, n);
+ if (n <= sc->print_length)
+ {
+ port_write_character(port)(sc, ' ', port);
+ object_to_port_with_circle_check(sc, x, port, use_write, ci);
+ }
+ if (n == (sc->print_length + 1))
+ port_write_string(port)(sc, " ...", 4, port);
}
+ return(n + 1);
}
static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
{
- /* if outer env points to (say) method list, the object needs to specialize object->string itself
- */
+ /* if outer env points to (say) method list, the object needs to specialize object->string itself */
if (has_methods(obj))
{
s7_pointer print_func;
- print_func = find_method(sc, obj, sc->OBJECT_TO_STRING);
- if (print_func != sc->UNDEFINED)
+ print_func = find_method(sc, obj, sc->object_to_string_symbol);
+ if (print_func != sc->undefined)
{
s7_pointer p;
/* what needs to be protected here? for one, the function might not return a string! */
@@ -30704,7 +30850,7 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ
clear_has_methods(obj);
if (use_write == USE_WRITE)
p = s7_apply_function(sc, print_func, list_1(sc, obj));
- else p = s7_apply_function(sc, print_func, list_2(sc, obj, (use_write == USE_DISPLAY) ? sc->F : sc->KEY_READABLE));
+ else p = s7_apply_function(sc, print_func, list_2(sc, obj, (use_write == USE_DISPLAY) ? sc->F : sc->key_readable_symbol));
set_has_methods(obj);
if ((is_string(p)) &&
@@ -30717,43 +30863,48 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ
port_write_string(port)(sc, "(rootlet)", 9, port);
else
{
- /* circles can happen here:
- * (let () (let ((b (curlet))) (curlet)))
- * #<let 'b #<let>>
- * or (let ((b #f)) (set! b (curlet)) (curlet))
- * #1=#<let 'b #1#>
- */
- if ((use_write == USE_READABLE_WRITE) &&
- (ci) &&
- (peek_shared_ref(ci, obj) != 0))
+ if (sc->short_print)
+ port_write_string(port)(sc, "#<let>", 6, port);
+ else
{
- s7_pointer x;
- port_write_string(port)(sc, "(let (({e} (inlet))) ", 21, port);
- if ((ci) &&
- (shared_ref(ci, obj) < 0))
+ /* circles can happen here:
+ * (let () (let ((b (curlet))) (curlet)))
+ * #<let 'b #<let>>
+ * or (let ((b #f)) (set! b (curlet)) (curlet))
+ * #1=#<let 'b #1#>
+ */
+ if ((use_write == USE_READABLE_WRITE) &&
+ (ci) &&
+ (peek_shared_ref(ci, obj) != 0))
{
- int plen;
- char buf[64];
- plen = snprintf(buf, 64, "(set! {%d} {e}) ", -shared_ref(ci, obj));
- port_write_string(port)(sc, buf, plen, port);
+ s7_pointer x;
+ port_write_string(port)(sc, "(let (({e} (inlet))) ", 21, port);
+ if ((ci) &&
+ (shared_ref(ci, obj) < 0))
+ {
+ int plen;
+ char buf[64];
+ plen = snprintf(buf, 64, "(set! {%d} {e}) ", -shared_ref(ci, obj));
+ port_write_string(port)(sc, buf, plen, port);
+ }
+
+ port_write_string(port)(sc, "(apply varlet {e} (reverse (list ", 33, port);
+ for (x = let_slots(obj); is_slot(x); x = next_slot(x))
+ {
+ port_write_string(port)(sc, "(cons ", 6, port);
+ symbol_to_port(sc, slot_symbol(x), port, use_write);
+ port_write_character(port)(sc, ' ', port);
+ object_to_port_with_circle_check(sc, slot_value(x), port, use_write, ci);
+ port_write_character(port)(sc, ')', port);
+ }
+ port_write_string(port)(sc, "))) {e})", 8, port);
}
-
- port_write_string(port)(sc, "(apply varlet {e} (reverse (list ", 33, port);
- for (x = let_slots(obj); is_slot(x); x = next_slot(x))
+ else
{
- port_write_string(port)(sc, "(cons ", 6, port);
- symbol_to_port(sc, slot_symbol(x), port, use_write);
- port_write_character(port)(sc, ' ', port);
- object_to_port_with_circle_check(sc, slot_value(x), port, use_write, ci);
+ port_write_string(port)(sc, "(inlet", 6, port);
+ slot_to_port_1(sc, let_slots(obj), port, use_write, ci, 0);
port_write_character(port)(sc, ')', port);
}
- port_write_string(port)(sc, "))) {e})", 8, port);
- }
- else
- {
- port_write_string(port)(sc, "(inlet", 6, port);
- slot_to_port_1(sc, let_slots(obj), port, use_write, ci);
- port_write_character(port)(sc, ')', port);
}
}
}
@@ -30867,7 +31018,7 @@ static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer cur
if (slot_value(y) == closure)
return(slot_symbol(y));
}
- return(sc->NIL);
+ return(sc->nil);
}
static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port)
@@ -30946,7 +31097,7 @@ static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer por
y = car(y);
else
{
- if (y == sc->KEY_REST)
+ if (y == sc->key_rest_symbol)
{
port_write_string(port)(sc, ":rest ", 6, port);
args = cdr(args);
@@ -30980,8 +31131,8 @@ static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure)
if (is_symbol(x))
return(x);
- if (is_pair(sc->cur_code))
- return(sc->cur_code);
+ if (is_pair(current_code(sc)))
+ return(current_code(sc));
return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */
}
@@ -30999,9 +31150,9 @@ static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer a
if ((is_pair(arglist)) &&
(allows_other_keys(arglist)))
{
- sc->temp9 = s7_append(sc, arglist, cons(sc, sc->KEY_ALLOW_OTHER_KEYS, sc->NIL));
+ sc->temp9 = s7_append(sc, arglist, cons(sc, sc->key_allow_other_keys_symbol, sc->nil));
object_out(sc, sc->temp9, port, USE_WRITE);
- sc->temp9 = sc->NIL;
+ sc->temp9 = sc->nil;
}
else object_out(sc, arglist, port, USE_WRITE); /* here we just want the straight output (a b) not (list 'a 'b) */
@@ -31025,7 +31176,7 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por
arglist = closure_args(obj);
pe = closure_let(obj); /* perhaps check for documentation? */
- gc_loc = s7_gc_protect(sc, sc->NIL);
+ gc_loc = s7_gc_protect(sc, sc->nil);
collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here */
if (s7_is_dilambda(obj))
{
@@ -31317,6 +31468,11 @@ static s7_pointer check_nref(s7_pointer p, const char *func, int line)
fprintf(stderr, "%s%s[%d]: attempt to use cleared type%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT);
if (stop_at_error) abort();
}
+ if ((typ < 0) || (typ >= NUM_TYPES))
+ {
+ fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", BOLD_TEXT, func, line, typ, UNBOLD_TEXT);
+ if (stop_at_error) abort();
+ }
return(p);
}
@@ -31390,11 +31546,13 @@ static void set_s_hash_1(s7_scheme *sc, s7_pointer p, unsigned long long int x,
set_opt1_is_set(p);
}
-static void show_opt2_bits(s7_scheme *sc, s7_pointer p, const char *func, int line)
+static void show_opt2_bits(s7_scheme *sc, s7_pointer p, const char *func, int line, unsigned int role)
{
- fprintf(stderr, "%s%s[%d]: opt2: %p->%p %x%s%s%s%s%s%s%s%s%s%s%s\n", BOLD_TEXT, func, line, p, p->object.cons.opt2, p->debugger_bits,
+ fprintf(stderr, "%s%s[%d]: opt2: %p->%p is %x%s%s%s%s%s%s%s%s%s but expects %x%s%s%s%s%s%s%s%s%s%s\n",
+ BOLD_TEXT, func, line, p, p->object.cons.opt2,
+
+ p->debugger_bits,
((p->debugger_bits & F_SET) != 0) ? " f-set" : "",
- ((p->debugger_bits & F_C_CALL) != 0) ? " c-call" : "",
((p->debugger_bits & F_KEY) != 0) ? " key" : "",
((p->debugger_bits & F_SLOW) != 0) ? " slow" : "",
((p->debugger_bits & F_SYM) != 0) ? " sym" : "",
@@ -31403,6 +31561,18 @@ static void show_opt2_bits(s7_scheme *sc, s7_pointer p, const char *func, int li
((p->debugger_bits & F_CALL) != 0) ? " call" : "",
((p->debugger_bits & F_LAMBDA) != 0) ? " lambda" : "",
((p->debugger_bits & S_NAME) != 0) ? " raw-name" : "",
+
+ role,
+ ((role & F_SET) != 0) ? " f-set" : "",
+ ((role & F_KEY) != 0) ? " key" : "",
+ ((role & F_SLOW) != 0) ? " slow" : "",
+ ((role & F_SYM) != 0) ? " sym" : "",
+ ((role & F_PAIR) != 0) ? " pair" : "",
+ ((role & F_CON) != 0) ? " con" : "",
+ ((role & F_CALL) != 0) ? " call" : "",
+ ((role & F_LAMBDA) != 0) ? " lambda" : "",
+ ((role & S_NAME) != 0) ? " raw-name" : "",
+
UNBOLD_TEXT);
}
@@ -31411,7 +31581,8 @@ static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, unsigned int role, const c
if ((!opt2_is_set(p)) ||
(!opt2_role_matches(p, role)))
{
- show_opt2_bits(sc, p, func, line);
+ show_opt2_bits(sc, p, func, line, role);
+ fprintf(stderr, "p: %s\n", DISPLAY(p));
if (stop_at_error) abort();
}
return(p->object.cons.opt2);
@@ -31429,7 +31600,7 @@ static const char *s_name_1(s7_scheme *sc, s7_pointer p, const char *func, int l
if ((!opt2_is_set(p)) ||
(!opt2_role_matches(p, S_NAME)))
{
- show_opt2_bits(sc, p, func, line);
+ show_opt2_bits(sc, p, func, line, (unsigned int)S_NAME);
if (stop_at_error) abort();
}
return(p->object.sym_cons.fstr);
@@ -31596,6 +31767,16 @@ static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port
else port_write_string(port)(sc, str, nlen, port);
tmpbuf_free(str, len);
}
+
+static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int line, const char *func)
+{
+ if (!p)
+ {
+ fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, symbol_name(sym), UNBOLD_TEXT);
+ if (stop_at_error) abort();
+ }
+ return(p);
+}
#endif
static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
@@ -31678,12 +31859,10 @@ static void rng_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ
port_write_string(port)(sc, buf, nlen, port);
}
-
static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
{
int nlen;
char *str;
-
switch (type(obj))
{
case T_FLOAT_VECTOR:
@@ -31714,7 +31893,7 @@ static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w
case T_UNIQUE:
/* if file has #<eof> it causes read to return #<eof> -> end of read! what is readable version? */
if ((use_write == USE_READABLE_WRITE) &&
- (obj == sc->EOF_OBJECT))
+ (obj == sc->eof_object))
port_write_string(port)(sc, "(begin #<eof>)", 14, port);
else port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
break;
@@ -31811,8 +31990,8 @@ static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w
* can't use recursion on closure_let here because then the fallback name is #<let>.
*/
s7_pointer print_func;
- print_func = find_method(sc, closure_let(obj), sc->OBJECT_TO_STRING);
- if (print_func != sc->UNDEFINED)
+ print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol);
+ if (print_func != sc->undefined)
{
s7_pointer p;
p = s7_apply_function(sc, print_func, list_1(sc, obj));
@@ -32097,7 +32276,7 @@ void s7_newline(s7_scheme *sc, s7_pointer port)
static s7_pointer g_newline(s7_scheme *sc, s7_pointer args)
{
#define H_newline "(newline (port (current-output-port))) writes a carriage return to the port"
- #define Q_newline s7_make_signature(sc, 2, sc->T, sc->IS_OUTPUT_PORT)
+ #define Q_newline s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
s7_pointer port;
if (is_not_null(args))
@@ -32105,14 +32284,14 @@ static s7_pointer g_newline(s7_scheme *sc, s7_pointer args)
else port = sc->output_port;
if (!is_output_port(port))
{
- if (port == sc->F) return(sc->UNSPECIFIED);
- method_or_bust_with_type(sc, port, sc->NEWLINE, args, AN_OUTPUT_PORT, 0);
+ if (port == sc->F) return(sc->unspecified);
+ method_or_bust_with_type(sc, port, sc->newline_symbol, args, an_output_port_string, 0);
}
s7_newline(sc, port);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
-static s7_pointer c_newline(s7_scheme *sc) {s7_newline(sc, sc->output_port); return(sc->UNSPECIFIED);}
+static s7_pointer c_newline(s7_scheme *sc) {s7_newline(sc, sc->output_port); return(sc->unspecified);}
PF_0(newline, c_newline)
@@ -32131,7 +32310,7 @@ void s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port)
static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
{
#define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port"
- #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, sc->IS_OUTPUT_PORT)
+ #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, sc->is_output_port_symbol)
s7_pointer port;
if (is_pair(cdr(args)))
@@ -32140,7 +32319,7 @@ static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
if (!is_output_port(port))
{
if (port == sc->F) return(car(args));
- method_or_bust_with_type(sc, port, sc->WRITE, args, AN_OUTPUT_PORT, 2);
+ method_or_bust_with_type(sc, port, sc->write_symbol, args, an_output_port_string, 2);
}
if (port_is_closed(port))
return(s7_wrong_type_arg_error(sc, "write", 2, port, "an open output port"));
@@ -32168,7 +32347,7 @@ void s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port)
static s7_pointer g_display(s7_scheme *sc, s7_pointer args)
{
#define H_display "(display obj (port (current-output-port))) prints obj"
- #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, sc->IS_OUTPUT_PORT)
+ #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, sc->is_output_port_symbol)
s7_pointer port;
if (is_pair(cdr(args)))
@@ -32177,7 +32356,7 @@ static s7_pointer g_display(s7_scheme *sc, s7_pointer args)
if (!is_output_port(port))
{
if (port == sc->F) return(car(args));
- method_or_bust_with_type(sc, port, sc->DISPLAY, args, AN_OUTPUT_PORT, 2);
+ method_or_bust_with_type(sc, port, sc->display_symbol, args, an_output_port_string, 2);
}
if (port_is_closed(port))
return(s7_wrong_type_arg_error(sc, "display", 2, port, "an open output port"));
@@ -32192,17 +32371,17 @@ PF_TO_PF(display, c_display)
static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args)
{
#define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output"
- #define Q_call_with_output_string s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_PROCEDURE)
+ #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
s7_pointer port, proc;
proc = car(args);
if (is_let(proc))
- check_method(sc, proc, sc->CALL_WITH_OUTPUT_STRING, args);
+ check_method(sc, proc, sc->call_with_output_string_symbol, args);
if (!s7_is_aritable(sc, proc, 1))
- method_or_bust_with_type(sc, proc, sc->CALL_WITH_OUTPUT_STRING, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 1);
+ method_or_bust_with_type(sc, proc, sc->call_with_output_string_symbol, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 1);
if ((is_continuation(proc)) || (is_goto(proc)))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_STRING, 1, proc, A_NORMAL_PROCEDURE));
+ return(wrong_type_argument_with_type(sc, sc->call_with_output_string_symbol, 1, proc, a_normal_procedure_string));
port = s7_open_output_string(sc);
push_stack(sc, OP_GET_OUTPUT_STRING_1, sc->F, port);
@@ -32223,14 +32402,14 @@ static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args)
file = car(args);
if (!is_string(file))
- method_or_bust(sc, file, sc->CALL_WITH_OUTPUT_FILE, args, T_STRING, 1);
+ method_or_bust(sc, file, sc->call_with_output_file_symbol, args, T_STRING, 1);
proc = cadr(args);
if (!s7_is_aritable(sc, proc, 1))
- method_or_bust_with_type(sc, proc, sc->CALL_WITH_OUTPUT_FILE, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 2);
+ method_or_bust_with_type(sc, proc, sc->call_with_output_file_symbol, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 2);
if ((is_continuation(proc)) || is_goto(proc))
- return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_FILE, 2, proc, A_NORMAL_PROCEDURE));
+ return(wrong_type_argument_with_type(sc, sc->call_with_output_file_symbol, 2, proc, a_normal_procedure_string));
port = s7_open_output_file(sc, string_value(file), "w");
push_stack(sc, OP_UNWIND_OUTPUT, sc->F, port);
@@ -32246,18 +32425,18 @@ PF_TO_PF(call_with_output_file, c_call_with_output_file)
static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args)
{
#define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, calls thunk, then returns the collected output"
- #define Q_with_output_to_string s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_PROCEDURE)
+ #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
s7_pointer old_output_port, p;
p = car(args);
if (!is_thunk(sc, p))
- method_or_bust_with_type(sc, p, sc->WITH_OUTPUT_TO_STRING, args, A_THUNK, 1);
+ method_or_bust_with_type(sc, p, sc->with_output_to_string_symbol, args, a_thunk_string, 1);
old_output_port = sc->output_port;
sc->output_port = s7_open_output_string(sc);
push_stack(sc, OP_GET_OUTPUT_STRING_1, old_output_port, sc->output_port);
- push_stack(sc, OP_APPLY, sc->NIL, p);
+ push_stack(sc, OP_APPLY, sc->nil, p);
return(sc->F);
}
@@ -32278,17 +32457,17 @@ static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args)
file = car(args);
if (!is_string(file))
- method_or_bust(sc, file, sc->WITH_OUTPUT_TO_FILE, args, T_STRING, 1);
+ method_or_bust(sc, file, sc->with_output_to_file_symbol, args, T_STRING, 1);
proc = cadr(args);
if (!is_thunk(sc, proc))
- method_or_bust_with_type(sc, proc, sc->WITH_OUTPUT_TO_FILE, args, A_THUNK, 2);
+ method_or_bust_with_type(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2);
old_output_port = sc->output_port;
sc->output_port = s7_open_output_file(sc, string_value(file), "w");
push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, sc->output_port);
- push_stack(sc, OP_APPLY, sc->NIL, proc);
+ push_stack(sc, OP_APPLY, sc->nil, proc);
return(sc->F);
}
@@ -32332,7 +32511,7 @@ static s7_pointer format_error_1(s7_scheme *sc, s7_pointer msg, const char *str,
close_format_port(sc, fdat->port);
fdat->port = NULL;
}
- return(s7_error(sc, sc->FORMAT_ERROR, x));
+ return(s7_error(sc, sc->format_error_symbol, x));
}
#define format_error(Sc, Msg, Str, Args, Fdat) \
@@ -32494,7 +32673,7 @@ static bool format_method(s7_scheme *sc, const char *str, format_data *fdat, s7_
obj = car(fdat->args);
if ((has_methods(obj)) &&
- ((func = find_method(sc, find_let(sc, obj), sc->FORMAT)) != sc->UNDEFINED))
+ ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) != sc->undefined))
{
s7_pointer ctrl_str;
if (fdat->orig_str)
@@ -32514,24 +32693,41 @@ static bool format_method(s7_scheme *sc, const char *str, format_data *fdat, s7_
}
+#define MAX_FORMAT_NUMERIC_ARG 10000
+static int format_n_arg(s7_scheme *sc, const char *str, int str_len, format_data *fdat, s7_pointer args)
+{
+ int n;
+
+ if (is_null(fdat->args)) /* (format #f "~nT") */
+ just_format_error(sc, "~~N: missing argument", str, args, fdat);
+ if (!s7_is_integer(car(fdat->args)))
+ just_format_error(sc, "~~N: integer argument required", str, args, fdat);
+ n = (int)s7_integer(car(fdat->args));
+
+ if (n < 0)
+ just_format_error(sc, "~~N value is negative?", str, args, fdat);
+ else
+ {
+ if (n > MAX_FORMAT_NUMERIC_ARG)
+ just_format_error(sc, "~~N value is too big", str, args, fdat);
+ }
+
+ fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */
+ return(n);
+}
+
+
static int format_numeric_arg(s7_scheme *sc, const char *str, int str_len, format_data *fdat, s7_pointer args, int *i)
{
- #define MAX_FORMAT_WIDTH 10000
int width;
- if ((str[*i] == 'n') || (str[*i] == 'N'))
- {
- *i = *i + 1;
- if (is_null(fdat->args)) /* (format #f "~nT") */
- just_format_error(sc, "~~N: missing argument", str, args, fdat);
- if (!s7_is_integer(car(fdat->args)))
- just_format_error(sc, "~~N: integer argument required", str, args, fdat);
- width = (int)s7_integer(car(fdat->args));
- fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */
- }
- else width = format_read_integer(sc, i, str_len, str, args, fdat);
- if ((width < 0) || /* maybe overflow somewhere? */
- (width > MAX_FORMAT_WIDTH))
- just_format_error(sc, "width argument too big", str, args, fdat);
+ width = format_read_integer(sc, i, str_len, str, args, fdat);
+ if (width < 0)
+ just_format_error(sc, "width value is negative?", str, fdat->args, fdat);
+ else
+ {
+ if (width > MAX_FORMAT_NUMERIC_ARG)
+ just_format_error(sc, "width value is too big", str, fdat->args, fdat);
+ }
return(width);
}
@@ -32565,7 +32761,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
static s7_pointer null_err = NULL;
if (!null_err)
null_err = s7_make_permanent_string("format control string is null, but there are arguments: ~S");
- return(s7_error(sc, sc->FORMAT_ERROR, set_elist_2(sc, null_err, args)));
+ return(s7_error(sc, sc->format_error_symbol, set_elist_2(sc, null_err, args)));
}
if (with_result)
return(make_string_wrapper_with_length(sc, "", 0));
@@ -32605,7 +32801,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
fdat->loc = 0;
fdat->args = args;
fdat->orig_str = orig_str;
- fdat->curly_arg = sc->NIL;
+ fdat->curly_arg = sc->nil;
/* choose whether to write to a temporary string port, or simply use the in-coming port
* if with_result, returned string is wanted.
@@ -32646,6 +32842,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
break;
case '&': /* -------- conditional newline -------- */
+ /* this only works if all output goes through format -- display/write for example do not update format_column */
if (sc->format_column > 0)
format_append_newline(sc, fdat, port);
i++;
@@ -32672,12 +32869,12 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
fdat->args = cdr(fdat->args);
break;
- case '|': /* -------- exit if args nil or ctr > *vector-print-length* -------- */
+ case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */
if ((is_pair(fdat->args)) &&
(fdat->ctr >= sc->print_length))
{
format_append_string(sc, fdat, " ...", 4, port);
- fdat->args = sc->NIL;
+ fdat->args = sc->nil;
}
/* fall through */
@@ -32746,7 +32943,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
fdat->curly_arg = curly_arg;
if (curly_arg != car(fdat->args))
orig_arg = curly_arg;
- else orig_arg = sc->NIL;
+ else orig_arg = sc->nil;
if (curly_len > fdat->curly_len)
{
@@ -32768,16 +32965,16 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
*/
while (is_not_null(curly_arg))
{
- s7_pointer new_arg = sc->NIL;
+ s7_pointer new_arg = sc->nil;
format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL);
if (curly_arg == new_arg)
{
- fdat->curly_arg = sc->NIL;
+ fdat->curly_arg = sc->nil;
format_error(sc, "'{...}' doesn't consume any arguments!", str, args, fdat);
}
curly_arg = new_arg;
}
- fdat->curly_arg = sc->NIL;
+ fdat->curly_arg = sc->nil;
while (is_pair(orig_arg))
{
s7_pointer p;
@@ -32862,25 +33059,39 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
char pad = ' ';
i++; /* str[i] == '~' */
- if ((isdigit((int)(str[i]))) ||
- (str[i] == 'N') || (str[i] == 'n')) /* this is faster than the equivalent strchr */
- width = format_numeric_arg(sc, str, str_len, fdat, args, &i);
+ if (isdigit((int)(str[i])))
+ width = format_numeric_arg(sc, str, str_len, fdat, args, &i);
+ else
+ {
+ if ((str[i] == 'N') || (str[i] == 'n'))
+ {
+ i++;
+ width = format_n_arg(sc, str, str_len, fdat, args);
+ }
+ }
if (str[i] == ',')
{
i++; /* is (format #f "~12,12D" 1) an error? The precision has no use here. */
- if ((isdigit((int)(str[i]))) ||
- (str[i] == 'N') || (str[i] == 'n'))
- precision = format_numeric_arg(sc, str, str_len, fdat, args, &i);
+ if (isdigit((int)(str[i])))
+ precision = format_numeric_arg(sc, str, str_len, fdat, args, &i);
else
{
- if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
+ if ((str[i] == 'N') || (str[i] == 'n'))
{
- pad = str[i + 1];
- i += 2;
- if (i >= str_len) /* (format #f "~,'") */
- format_error(sc, "incomplete numeric argument", str, args, fdat);
+ i++;
+ precision = format_n_arg(sc, str, str_len, fdat, args);
+ }
+ else
+ {
+ if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
+ {
+ pad = str[i + 1];
+ i += 2;
+ if (i >= str_len) /* (format #f "~,'") */
+ format_error(sc, "incomplete numeric argument", str, args, fdat);
+ }
+ /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */
}
- /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */
}
}
@@ -33149,11 +33360,11 @@ static s7_pointer g_format_1(s7_scheme *sc, s7_pointer args)
if (!((s7_is_boolean(pt)) || /* #f or #t */
((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */
(!port_is_closed(pt)))))
- method_or_bust_with_type(sc, pt, sc->FORMAT, args, AN_OUTPUT_PORT, 1);
+ method_or_bust_with_type(sc, pt, sc->format_symbol, args, an_output_port_string, 1);
str = cadr(args);
if (!is_string(str))
- method_or_bust(sc, str, sc->FORMAT, args, T_STRING, 2);
+ method_or_bust(sc, str, sc->format_symbol, args, T_STRING, 2);
return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt,
string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str));
@@ -33181,7 +33392,7 @@ spacing (and spacing character) and precision. ~{ starts an embedded format dir
If the 'out' it is not an output port, the resultant string is returned. If it \
is #t, the string is also sent to the current-output-port."
- #define Q_format s7_make_circular_signature(sc, 1, 2, s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_BOOLEAN), sc->T)
+ #define Q_format s7_make_circular_signature(sc, 1, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
return(g_format_1(sc, args));
}
@@ -33205,12 +33416,12 @@ const char *s7_format(s7_scheme *sc, s7_pointer args)
static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args)
{
#define H_is_directory "(directory? str) returns #t if str is the name of a directory"
- #define Q_is_directory s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_STRING)
+ #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
s7_pointer name;
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->IS_DIRECTORY, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->is_directory_symbol, args, T_STRING, 0);
return(s7_make_boolean(sc, is_directory(string_value(name))));
}
@@ -33232,13 +33443,13 @@ static bool file_probe(const char *arg)
static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args)
{
#define H_file_exists "(file-exists? filename) returns #t if the file exists"
- #define Q_file_exists s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_STRING)
+ #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
s7_pointer name;
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->FILE_EXISTS, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->file_exists_symbol, args, T_STRING, 0);
return(s7_make_boolean(sc, file_probe(string_value(name))));
}
@@ -33246,13 +33457,13 @@ static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args)
static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args)
{
#define H_delete_file "(delete-file filename) deletes the file filename."
- #define Q_delete_file s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_STRING)
+ #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
s7_pointer name;
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->DELETE_FILE, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->delete_file_symbol, args, T_STRING, 0);
return(make_integer(sc, unlink(string_value(name))));
}
@@ -33266,7 +33477,7 @@ static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args)
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->GETENV, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->getenv_symbol, args, T_STRING, 0);
return(s7_make_string(sc, getenv(string_value(name))));
}
@@ -33275,13 +33486,13 @@ static s7_pointer g_system(s7_scheme *sc, s7_pointer args)
{
#define H_system "(system command) executes the command. If the optional second it is #t, \
system captures the output as a string and returns it."
- #define Q_system s7_make_signature(sc, 3, sc->T, sc->IS_STRING, sc->IS_BOOLEAN)
+ #define Q_system s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, sc->is_boolean_symbol)
s7_pointer name;
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->SYSTEM, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->system_symbol, args, T_STRING, 0);
if ((is_pair(cdr(args))) &&
(cadr(args) == sc->T))
@@ -33327,9 +33538,9 @@ static s7_pointer c_directory_to_list(s7_scheme *sc, s7_pointer name)
s7_pointer result;
if (!is_string(name))
- method_or_bust(sc, name, sc->DIRECTORY_TO_LIST, list_1(sc, name), T_STRING, 0);
+ method_or_bust(sc, name, sc->directory_to_list_symbol, list_1(sc, name), T_STRING, 0);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
if ((dpos = opendir(string_value(name))) != NULL)
{
struct dirent *dirp;
@@ -33339,14 +33550,14 @@ static s7_pointer c_directory_to_list(s7_scheme *sc, s7_pointer name)
}
result = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(result);
}
static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args)
{
#define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)."
- #define Q_directory_to_list s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_STRING)
+ #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_string_symbol)
return(c_directory_to_list(sc, car(args)));
}
@@ -33356,7 +33567,7 @@ PF_TO_PF(directory_to_list, c_directory_to_list)
static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args)
{
#define H_file_mtime "(file-mtime file): return the write date of file"
- #define Q_file_mtime s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_STRING)
+ #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
struct stat statbuf;
int err;
@@ -33364,7 +33575,7 @@ static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args)
name = car(args);
if (!is_string(name))
- method_or_bust(sc, name, sc->FILE_MTIME, args, T_STRING, 0);
+ method_or_bust(sc, name, sc->file_mtime_symbol, args, T_STRING, 0);
err = stat(string_value(name), &statbuf);
if (err < 0)
@@ -33416,9 +33627,9 @@ static s7_pointer permanent_list(s7_scheme *sc, int len)
{
int j;
s7_pointer p;
- p = sc->NIL;
+ p = sc->nil;
for (j = 0; j < len; j++)
- p = permanent_cons(sc->NIL, p, T_PAIR | T_IMMUTABLE);
+ p = permanent_cons(sc->nil, p, T_PAIR | T_IMMUTABLE);
return(p);
}
@@ -33616,7 +33827,7 @@ s7_pointer s7_apply_n_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_poin
{
if (is_pair(args))
return(f1(car(args)));
- return(f1(sc->UNDEFINED));
+ return(f1(sc->undefined));
}
s7_pointer s7_apply_n_2(s7_scheme *sc, s7_pointer args, s7_pointer (*f2)(s7_pointer a1, s7_pointer a2))
@@ -33625,9 +33836,9 @@ s7_pointer s7_apply_n_2(s7_scheme *sc, s7_pointer args, s7_pointer (*f2)(s7_poin
{
if (is_pair(cdr(args)))
return(f2(car(args), cadr(args)));
- return(f2(car(args), sc->UNDEFINED));
+ return(f2(car(args), sc->undefined));
}
- return(f2(sc->UNDEFINED, sc->UNDEFINED));
+ return(f2(sc->undefined, sc->undefined));
}
s7_pointer s7_apply_n_3(s7_scheme *sc, s7_pointer args, s7_pointer (*f3)(s7_pointer a1, s7_pointer a2, s7_pointer a3))
@@ -33642,11 +33853,11 @@ s7_pointer s7_apply_n_3(s7_scheme *sc, s7_pointer args, s7_pointer (*f3)(s7_poin
a2 = car(args);
if (is_pair(cdr(args)))
return(f3(a1, a2, cadr(args)));
- return(f3(a1, a2, sc->UNDEFINED));
+ return(f3(a1, a2, sc->undefined));
}
- return(f3(a1, sc->UNDEFINED, sc->UNDEFINED));
+ return(f3(a1, sc->undefined, sc->undefined));
}
- return(f3(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f3(sc->undefined, sc->undefined, sc->undefined));
}
s7_pointer s7_apply_n_4(s7_scheme *sc, s7_pointer args, s7_pointer (*f4)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4))
@@ -33665,13 +33876,13 @@ s7_pointer s7_apply_n_4(s7_scheme *sc, s7_pointer args, s7_pointer (*f4)(s7_poin
a3 = car(args);
if (is_pair(cdr(args)))
return(f4(a1, a2, a3, cadr(args)));
- return(f4(a1, a2, a3, sc->UNDEFINED));
+ return(f4(a1, a2, a3, sc->undefined));
}
- return(f4(a1, a2, sc->UNDEFINED, sc->UNDEFINED));
+ return(f4(a1, a2, sc->undefined, sc->undefined));
}
- return(f4(a1, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f4(a1, sc->undefined, sc->undefined, sc->undefined));
}
- return(f4(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f4(sc->undefined, sc->undefined, sc->undefined, sc->undefined));
}
s7_pointer s7_apply_n_5(s7_scheme *sc, s7_pointer args,
@@ -33695,22 +33906,22 @@ s7_pointer s7_apply_n_5(s7_scheme *sc, s7_pointer args,
a4 = car(args);
if (is_pair(cdr(args)))
return(f5(a1, a2, a3, a4, cadr(args)));
- return(f5(a1, a2, a3, a4, sc->UNDEFINED));
+ return(f5(a1, a2, a3, a4, sc->undefined));
}
- return(f5(a1, a2, a3, sc->UNDEFINED, sc->UNDEFINED));
+ return(f5(a1, a2, a3, sc->undefined, sc->undefined));
}
- return(f5(a1, a2, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f5(a1, a2, sc->undefined, sc->undefined, sc->undefined));
}
- return(f5(a1, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f5(a1, sc->undefined, sc->undefined, sc->undefined, sc->undefined));
}
- return(f5(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
+ return(f5(sc->undefined, sc->undefined, sc->undefined, sc->undefined, sc->undefined));
}
s7_pointer s7_apply_n_6(s7_scheme *sc, s7_pointer args,
s7_pointer (*f6)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6))
{
s7_pointer a1, a2, a3, a4, a5, a6;
- a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; a6 = sc->UNDEFINED;
+ a1 = sc->undefined; a2 = sc->undefined; a3 = sc->undefined; a4 = sc->undefined; a5 = sc->undefined; a6 = sc->undefined;
if (is_pair(args))
{
a1 = car(args); args = cdr(args);
@@ -33736,8 +33947,8 @@ s7_pointer s7_apply_n_7(s7_scheme *sc, s7_pointer args,
s7_pointer a5, s7_pointer a6, s7_pointer a7))
{
s7_pointer a1, a2, a3, a4, a5, a6, a7;
- a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED;
- a6 = sc->UNDEFINED, a7 = sc->UNDEFINED;
+ a1 = sc->undefined; a2 = sc->undefined; a3 = sc->undefined; a4 = sc->undefined; a5 = sc->undefined;
+ a6 = sc->undefined, a7 = sc->undefined;
if (is_pair(args))
{
a1 = car(args); args = cdr(args);
@@ -33766,8 +33977,8 @@ s7_pointer s7_apply_n_8(s7_scheme *sc, s7_pointer args,
s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8))
{
s7_pointer a1, a2, a3, a4, a5, a6, a7, a8;
- a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED;
- a6 = sc->UNDEFINED, a7 = sc->UNDEFINED; a8 = sc->UNDEFINED;
+ a1 = sc->undefined; a2 = sc->undefined; a3 = sc->undefined; a4 = sc->undefined; a5 = sc->undefined;
+ a6 = sc->undefined, a7 = sc->undefined; a8 = sc->undefined;
if (is_pair(args))
{
a1 = car(args); args = cdr(args);
@@ -33800,8 +34011,8 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
s7_pointer a9))
{
s7_pointer a1, a2, a3, a4, a5, a6, a7, a8, a9;
- a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED;
- a6 = sc->UNDEFINED, a7 = sc->UNDEFINED; a8 = sc->UNDEFINED; a9 = sc->UNDEFINED;
+ a1 = sc->undefined; a2 = sc->undefined; a3 = sc->undefined; a4 = sc->undefined; a5 = sc->undefined;
+ a6 = sc->undefined, a7 = sc->undefined; a8 = sc->undefined; a9 = sc->undefined;
if (is_pair(args))
{
a1 = car(args); args = cdr(args);
@@ -33842,7 +34053,7 @@ s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, int num)
for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
if ((i == num) && (is_pair(x)))
return(car(x));
- return(sc->NIL);
+ return(sc->nil);
}
@@ -33853,7 +34064,7 @@ s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, int num, s7_pointer val)
for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
if ((i == num) &&
(is_pair(x)))
- car(x) = val;
+ car(x) = _NFre(val);
return(val);
}
@@ -33917,7 +34128,7 @@ s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a)
{
if (is_not_null(cdr(a)))
return(cons(sc, cdr(a), car(a)));
- return(cons(sc, car(a), sc->NIL)); /* don't return 'a' itself */
+ return(cons(sc, car(a), sc->nil)); /* don't return 'a' itself */
}
sc->w = list_1(sc, car(a));
@@ -33937,7 +34148,7 @@ s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a)
p = cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */
else p = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(p);
}
@@ -33955,7 +34166,7 @@ static s7_pointer reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer li
q = cdr(p);
if ((!is_pair(q)) &&
(is_not_null(q)))
- return(sc->NIL); /* improper list? */
+ return(sc->nil); /* improper list? */
cdr(p) = result;
result = p;
p = q;
@@ -33988,7 +34199,7 @@ static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_
static s7_pointer safe_reverse_in_place(s7_scheme *sc, s7_pointer list) /* "safe" here means we guarantee this list is unproblematic */
{
s7_pointer p = list, result, q;
- result = sc->NIL;
+ result = sc->nil;
while (is_not_null(p))
{
@@ -34029,12 +34240,12 @@ s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
s7_pointer p, tp, np;
if (is_null(a)) return(b);
- tp = cons(sc, car(a), sc->NIL);
+ tp = cons(sc, car(a), sc->nil);
sc->y = tp;
for (p = cdr(a), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
- cdr(np) = cons(sc, car(p), sc->NIL);
+ cdr(np) = cons(sc, car(p), sc->nil);
cdr(np) = b;
- sc->y = sc->NIL;
+ sc->y = sc->nil;
return(tp);
}
@@ -34043,12 +34254,12 @@ s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
static s7_pointer copy_list(s7_scheme *sc, s7_pointer lst)
{
s7_pointer p, tp, np;
- if (!is_pair(lst)) return(sc->NIL);
- tp = cons(sc, car(lst), sc->NIL);
+ if (!is_pair(lst)) return(sc->nil);
+ tp = cons(sc, car(lst), sc->nil);
sc->y = tp;
for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
- cdr(np) = cons(sc, car(p), sc->NIL);
- sc->y = sc->NIL;
+ cdr(np) = cons(sc, car(p), sc->nil);
+ sc->y = sc->nil;
return(tp);
}
@@ -34056,16 +34267,16 @@ static s7_pointer copy_list(s7_scheme *sc, s7_pointer lst)
static s7_pointer copy_list_with_arglist_error(s7_scheme *sc, s7_pointer lst)
{
s7_pointer p, tp, np;
- if (is_null(lst)) return(sc->NIL);
+ if (is_null(lst)) return(sc->nil);
if (!is_pair(lst))
- s7_error(sc, sc->SYNTAX_ERROR, set_elist_2(sc, make_string_wrapper(sc, "stray dot?: ~S"), lst));
- tp = cons(sc, car(lst), sc->NIL);
+ s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "stray dot?: ~S"), lst));
+ tp = cons(sc, car(lst), sc->nil);
sc->y = tp;
for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
- cdr(np) = cons(sc, car(p), sc->NIL);
- sc->y = sc->NIL;
+ cdr(np) = cons(sc, car(p), sc->nil);
+ sc->y = sc->nil;
if (!is_null(p))
- s7_error(sc, sc->SYNTAX_ERROR, set_elist_2(sc, make_string_wrapper(sc, "improper list of arguments: ~S"), lst));
+ s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "improper list of arguments: ~S"), lst));
return(tp);
}
@@ -34140,7 +34351,7 @@ static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args)
{
#define H_is_null "(null? obj) returns #t if obj is the empty list"
#define Q_is_null pl_bt
- check_boolean_method(sc, is_null, sc->IS_NULL, args);
+ check_boolean_method(sc, is_null, sc->is_null_symbol, args);
/* as a generic this could be: has_structure and length == 0 */
}
@@ -34149,7 +34360,7 @@ static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args)
{
#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)"
#define Q_is_pair pl_bt
- check_boolean_method(sc, is_pair, sc->IS_PAIR, args);
+ check_boolean_method(sc, is_pair, sc->is_pair_symbol, args);
}
@@ -34163,6 +34374,7 @@ bool s7_is_list(s7_scheme *sc, s7_pointer p)
static bool is_proper_list(s7_scheme *sc, s7_pointer lst)
{
+ /* #t if () or undotted/non-circular pair */
s7_pointer slow, fast;
fast = lst;
@@ -34191,7 +34403,7 @@ static s7_pointer g_is_list(s7_scheme *sc, s7_pointer args)
#define H_is_list "(list? obj) returns #t if obj is a pair or null"
#define Q_is_list pl_bt
#define is_a_list(p) s7_is_list(sc, p)
- check_boolean_method(sc, is_a_list, sc->IS_LIST, args);
+ check_boolean_method(sc, is_a_list, sc->is_list_symbol, args);
}
@@ -34200,17 +34412,17 @@ static s7_pointer make_list(s7_scheme *sc, int len, s7_pointer init)
{
switch (len)
{
- case 0: return(sc->NIL);
- case 1: return(cons(sc, init, sc->NIL));
- case 2: return(cons_unchecked(sc, init, cons(sc, init, sc->NIL)));
- case 3: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL))));
- case 4: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL)))));
+ case 0: return(sc->nil);
+ case 1: return(cons(sc, init, sc->nil));
+ case 2: return(cons_unchecked(sc, init, cons(sc, init, sc->nil)));
+ case 3: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))));
+ case 4: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))));
case 5: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init,
- cons_unchecked(sc, init, cons(sc, init, sc->NIL))))));
+ cons_unchecked(sc, init, cons(sc, init, sc->nil))))));
case 6: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init,
- cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL)))))));
+ cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))));
case 7: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init,
- cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL))))))));
+ cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))));
default:
{
s7_pointer result;
@@ -34223,35 +34435,35 @@ static s7_pointer make_list(s7_scheme *sc, int len, s7_pointer init)
resize_heap(sc);
}
- sc->v = sc->NIL;
+ sc->v = sc->nil;
for (i = 0; i < len; i++)
sc->v = cons_unchecked(sc, init, sc->v);
result = sc->v;
- sc->v = sc->NIL;
+ sc->v = sc->nil;
return(result);
}
}
- return(sc->NIL); /* never happens, I hope */
+ return(sc->nil); /* never happens, I hope */
}
static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args)
{
#define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'."
- #define Q_make_list s7_make_signature(sc, 3, sc->IS_LIST, sc->IS_INTEGER, sc->T)
+ #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T)
s7_pointer init;
s7_int len;
if (!s7_is_integer(car(args)))
- method_or_bust(sc, car(args), sc->MAKE_LIST, args, T_INTEGER, 1);
+ method_or_bust(sc, car(args), sc->make_list_symbol, args, T_INTEGER, 1);
len = s7_integer(car(args)); /* needs to be s7_int here so that (make-list most-negative-fixnum) is handled correctly */
if (len < 0)
- return(out_of_range(sc, sc->MAKE_LIST, small_int(1), car(args), ITS_NEGATIVE));
- if (len == 0) return(sc->NIL); /* what about (make-list 0 123)? */
+ return(out_of_range(sc, sc->make_list_symbol, small_int(1), car(args), its_negative_string));
+ if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */
if (len > sc->max_list_length)
- return(out_of_range(sc, sc->MAKE_LIST, small_int(1), car(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_list_symbol, small_int(1), car(args), its_too_large_string));
if (is_pair(cdr(args)))
init = cadr(args);
@@ -34272,7 +34484,7 @@ static s7_pointer g_list_ref_ic(s7_scheme *sc, s7_pointer args)
lst = car(args);
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->LIST_REF, args, T_PAIR, 1);
+ method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1);
index = s7_integer(cadr(args));
@@ -34281,8 +34493,8 @@ static s7_pointer g_list_ref_ic(s7_scheme *sc, s7_pointer args)
if (!is_pair(p))
{
if (is_null(p))
- return(out_of_range(sc, sc->LIST_REF, small_int(2), cadr(args), ITS_TOO_LARGE));
- return(wrong_type_argument_with_type(sc, sc->LIST_REF, 1, lst, A_PROPER_LIST));
+ return(out_of_range(sc, sc->list_ref_symbol, small_int(2), cadr(args), its_too_large_string));
+ return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string));
}
return(car(p));
}
@@ -34295,21 +34507,21 @@ static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
if (!s7_is_integer(ind))
{
- if (!s7_is_integer(p = check_values(sc, ind, cons(sc, ind, sc->NIL))))
- method_or_bust(sc, ind, sc->LIST_REF, list_2(sc, lst, ind), T_INTEGER, 2);
+ if (!s7_is_integer(p = check_values(sc, ind, cons(sc, ind, sc->nil))))
+ method_or_bust(sc, ind, sc->list_ref_symbol, list_2(sc, lst, ind), T_INTEGER, 2);
ind = p;
}
index = s7_integer(ind);
if ((index < 0) || (index > sc->max_list_length))
- return(out_of_range(sc, sc->LIST_REF, small_int(2), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->list_ref_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string));
for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
if (!is_pair(p))
{
if (is_null(p))
- return(out_of_range(sc, sc->LIST_REF, small_int(2), ind, ITS_TOO_LARGE));
- return(wrong_type_argument_with_type(sc, sc->LIST_REF, 1, lst, A_PROPER_LIST));
+ return(out_of_range(sc, sc->list_ref_symbol, small_int(2), ind, its_too_large_string));
+ return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string));
}
return(car(p));
}
@@ -34318,7 +34530,7 @@ static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args)
{
#define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list"
- #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->IS_PAIR, sc->IS_INTEGER)
+ #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol)
/* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2))
@@ -34331,7 +34543,7 @@ static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args)
lst = car(args);
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->LIST_REF, args, T_PAIR, 1);
+ method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1);
inds = cdr(args);
while (true)
@@ -34350,15 +34562,15 @@ static s7_pointer c_list_ref(s7_scheme *sc, s7_pointer x, s7_int index)
int i;
s7_pointer p;
if (!s7_is_pair(x))
- method_or_bust(sc, x, sc->LIST_REF, list_2(sc, x, make_integer(sc, index)), T_PAIR, 1);
+ method_or_bust(sc, x, sc->list_ref_symbol, list_2(sc, x, make_integer(sc, index)), T_PAIR, 1);
if (index < 0)
- return(out_of_range(sc, sc->LIST_REF, small_int(2), make_integer(sc, index), ITS_NEGATIVE));
+ return(out_of_range(sc, sc->list_ref_symbol, small_int(2), make_integer(sc, index), its_negative_string));
for (i = 0, p = x; (i < index) && is_pair(p); i++, p = cdr(p)) {}
if (!is_pair(p))
{
if (is_null(p))
- return(out_of_range(sc, sc->LIST_REF, small_int(2), make_integer(sc, index), ITS_TOO_LARGE));
- return(wrong_type_argument_with_type(sc, sc->LIST_REF, 1, x, A_PROPER_LIST));
+ return(out_of_range(sc, sc->list_ref_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
+ return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, x, a_proper_list_string));
}
return(car(p));
}
@@ -34370,7 +34582,7 @@ PIF_TO_PF(list_ref, c_list_ref)
static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int arg_num)
{
#define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val"
- #define Q_list_set s7_make_circular_signature(sc, 2, 3, sc->T, sc->IS_PAIR, sc->T)
+ #define Q_list_set s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->T)
int i;
s7_int index;
@@ -34379,26 +34591,26 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i
/* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->LIST_SET, cons(sc, lst, args), T_PAIR, 1);
+ method_or_bust(sc, lst, sc->list_set_symbol, cons(sc, lst, args), T_PAIR, 1);
ind = car(args);
if (!s7_is_integer(ind))
{
if (!s7_is_integer(p = check_values(sc, ind, args)))
- method_or_bust(sc, ind, sc->LIST_SET, cons(sc, lst, args), T_INTEGER, arg_num);
+ method_or_bust(sc, ind, sc->list_set_symbol, cons(sc, lst, args), T_INTEGER, arg_num);
ind = p;
}
index = s7_integer(ind);
if ((index < 0) || (index > sc->max_list_length))
- return(out_of_range(sc, sc->LIST_SET, small_int(arg_num), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->list_set_symbol, small_int(arg_num), ind, (index < 0) ? its_negative_string : its_too_large_string));
for (i = 0, p = _TSet(lst); (i < index) && is_pair(p); i++, p = cdr(p)) {}
if (!is_pair(p))
{
if (is_null(p))
- return(out_of_range(sc, sc->LIST_SET, small_int(arg_num), ind, ITS_TOO_LARGE));
- return(wrong_type_argument_with_type(sc, sc->LIST_SET, 1, lst, A_PROPER_LIST));
+ return(out_of_range(sc, sc->list_set_symbol, small_int(arg_num), ind, its_too_large_string));
+ return(wrong_type_argument_with_type(sc, sc->list_set_symbol, 1, lst, a_proper_list_string));
}
if (is_null(cddr(args)))
car(p) = cadr(args);
@@ -34455,14 +34667,14 @@ static s7_pointer c_list_set_s(s7_scheme *sc, s7_pointer lst, s7_int index, s7_p
s7_pointer p;
if ((index < 0) || (index > sc->max_list_length))
- return(out_of_range(sc, sc->LIST_SET, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->list_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));
for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
if (!is_pair(p))
{
if (is_null(p))
- return(out_of_range(sc, sc->LIST_SET, small_int(2), make_integer(sc, index), ITS_TOO_LARGE));
- return(wrong_type_argument_with_type(sc, sc->LIST_SET, 1, lst, A_PROPER_LIST));
+ return(out_of_range(sc, sc->list_set_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
+ return(wrong_type_argument_with_type(sc, sc->list_set_symbol, 1, lst, a_proper_list_string));
}
car(p) = val;
return(val);
@@ -34471,7 +34683,7 @@ static s7_pointer c_list_set_s(s7_scheme *sc, s7_pointer lst, s7_int index, s7_p
static s7_pointer c_list_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
if (!s7_is_pair(vec))
- method_or_bust(sc, vec, sc->LIST_SET, set_plist_3(sc, vec, make_integer(sc, index), val), T_PAIR, 1);
+ method_or_bust(sc, vec, sc->list_set_symbol, set_plist_3(sc, vec, make_integer(sc, index), val), T_PAIR, 1);
return(c_list_set_s(sc, vec, index, val));
}
@@ -34483,7 +34695,7 @@ static s7_pointer g_list_set_ic(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->LIST_SET, args, T_PAIR, 1);
+ method_or_bust(sc, lst, sc->list_set_symbol, args, T_PAIR, 1);
return(c_list_set_s(sc, lst, s7_integer(cadr(args)), caddr(args)));
}
@@ -34495,21 +34707,21 @@ static s7_pointer c_list_tail(s7_scheme *sc, s7_pointer lst, s7_int index)
s7_pointer p;
if (!s7_is_list(sc, lst))
- method_or_bust_with_type(sc, lst, sc->LIST_TAIL, list_2(sc, lst, make_integer(sc, index)), A_LIST, 1);
+ method_or_bust_with_type(sc, lst, sc->list_tail_symbol, list_2(sc, lst, make_integer(sc, index)), a_list_string, 1);
if ((index < 0) || (index > sc->max_list_length))
- return(out_of_range(sc, sc->LIST_TAIL, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->list_tail_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));
for (i = 0, p = lst; (i < index) && (is_pair(p)); i++, p = cdr(p)) {}
if (i < index)
- return(out_of_range(sc, sc->LIST_TAIL, small_int(2), make_integer(sc, index), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->list_tail_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
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->IS_LIST, sc->IS_PAIR, sc->IS_INTEGER)
+ #define Q_list_tail s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_pair_symbol, sc->is_integer_symbol)
s7_pointer p;
p = cadr(args);
@@ -34517,7 +34729,7 @@ static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
{
s7_pointer p1;
if (!s7_is_integer(p1 = check_values(sc, p, cdr(args))))
- method_or_bust(sc, p, sc->LIST_TAIL, args, T_INTEGER, 2);
+ method_or_bust(sc, p, sc->list_tail_symbol, args, T_INTEGER, 2);
p = p1;
}
return(c_list_tail(sc, car(args), s7_integer(p)));
@@ -34534,7 +34746,7 @@ static s7_pointer g_cons(s7_scheme *sc, s7_pointer args)
/* (set! (cadr (cons 1 2 3)) 4) -> (1 4 . 3) */
#define H_cons "(cons a b) returns a pair containing a and b"
- #define Q_cons s7_make_signature(sc, 3, sc->IS_PAIR, sc->T, sc->T)
+ #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T)
/* cdr(args) = cadr(args);
* this is not safe -- it changes a variable's value directly:
@@ -34552,61 +34764,61 @@ PF2_TO_PF(cons, s7_cons)
static void init_car_a_list(void)
{
- CAR_A_LIST = s7_make_permanent_string("a list whose car is also a list");
- CDR_A_LIST = s7_make_permanent_string("a list whose cdr is also a list");
-
- CAAR_A_LIST = s7_make_permanent_string("a list whose caar is also a list");
- CADR_A_LIST = s7_make_permanent_string("a list whose cadr is also a list");
- CDAR_A_LIST = s7_make_permanent_string("a list whose cdar is also a list");
- CDDR_A_LIST = s7_make_permanent_string("a list whose cddr is also a list");
-
- CAAAR_A_LIST = s7_make_permanent_string("a list whose caaar is also a list");
- CAADR_A_LIST = s7_make_permanent_string("a list whose caadr is also a list");
- CADAR_A_LIST = s7_make_permanent_string("a list whose cadar is also a list");
- CADDR_A_LIST = s7_make_permanent_string("a list whose caddr is also a list");
- CDAAR_A_LIST = s7_make_permanent_string("a list whose cdaar is also a list");
- CDADR_A_LIST = s7_make_permanent_string("a list whose cdadr is also a list");
- CDDAR_A_LIST = s7_make_permanent_string("a list whose cddar is also a list");
- CDDDR_A_LIST = s7_make_permanent_string("a list whose cdddr is also a list");
-
- A_LIST = s7_make_permanent_string("a list");
- AN_EQ_FUNC = s7_make_permanent_string("a procedure that can take 2 arguments");
- AN_ASSOCIATION_LIST = s7_make_permanent_string("an association list");
- A_NORMAL_REAL = s7_make_permanent_string("a normal real");
- A_RATIONAL = s7_make_permanent_string("an integer or a ratio");
- A_NUMBER = s7_make_permanent_string("a number");
- A_PROCEDURE = s7_make_permanent_string("a procedure");
- A_NORMAL_PROCEDURE = s7_make_permanent_string("a normal procedure (not a continuation)");
- A_LET = s7_make_permanent_string("a let (environment)");
- A_PROPER_LIST = s7_make_permanent_string("a proper list");
- A_BOOLEAN = s7_make_permanent_string("a boolean");
- AN_INPUT_PORT = s7_make_permanent_string("an input port");
- AN_OPEN_PORT = s7_make_permanent_string("an open port");
- AN_OUTPUT_PORT = s7_make_permanent_string("an output port");
- AN_INPUT_STRING_PORT = s7_make_permanent_string("an input string port");
- AN_INPUT_FILE_PORT = s7_make_permanent_string("an input file port");
- AN_OUTPUT_STRING_PORT = s7_make_permanent_string("an output string port");
- AN_OUTPUT_FILE_PORT = s7_make_permanent_string("an output file port");
- A_THUNK = s7_make_permanent_string("a thunk");
- A_SYMBOL = s7_make_permanent_string("a symbol");
- A_NON_NEGATIVE_INTEGER = s7_make_permanent_string("a non-negative integer");
- AN_UNSIGNED_BYTE = s7_make_permanent_string("an unsigned byte");
- SOMETHING_APPLICABLE = s7_make_permanent_string("a procedure or something applicable");
- A_RANDOM_STATE_OBJECT = s7_make_permanent_string("a random-state object");
- A_FORMAT_PORT = s7_make_permanent_string("#f, #t, or an open output port");
- A_BINDING = s7_make_permanent_string("a pair whose car is a symbol: '(symbol . value)");
- A_NON_CONSTANT_SYMBOL = s7_make_permanent_string("a non-constant symbol");
- A_SEQUENCE = s7_make_permanent_string("a sequence");
- A_VALID_RADIX = s7_make_permanent_string("should be between 2 and 16");
- RESULT_IS_TOO_LARGE = s7_make_permanent_string("result is too large");
- ITS_TOO_LARGE = s7_make_permanent_string("it is too large");
- ITS_TOO_SMALL = s7_make_permanent_string("it is less than the start position");
- ITS_NEGATIVE = s7_make_permanent_string("it is negative");
- ITS_NAN = s7_make_permanent_string("NaN usually indicates a numerical error");
- ITS_INFINITE = s7_make_permanent_string("it is infinite");
- TOO_MANY_INDICES = s7_make_permanent_string("too many indices");
+ car_a_list_string = s7_make_permanent_string("a list whose car is also a list");
+ cdr_a_list_string = s7_make_permanent_string("a list whose cdr is also a list");
+
+ caar_a_list_string = s7_make_permanent_string("a list whose caar is also a list");
+ cadr_a_list_string = s7_make_permanent_string("a list whose cadr is also a list");
+ cdar_a_list_string = s7_make_permanent_string("a list whose cdar is also a list");
+ cddr_a_list_string = s7_make_permanent_string("a list whose cddr is also a list");
+
+ caaar_a_list_string = s7_make_permanent_string("a list whose caaar is also a list");
+ caadr_a_list_string = s7_make_permanent_string("a list whose caadr is also a list");
+ cadar_a_list_string = s7_make_permanent_string("a list whose cadar is also a list");
+ caddr_a_list_string = s7_make_permanent_string("a list whose caddr is also a list");
+ cdaar_a_list_string = s7_make_permanent_string("a list whose cdaar is also a list");
+ cdadr_a_list_string = s7_make_permanent_string("a list whose cdadr is also a list");
+ cddar_a_list_string = s7_make_permanent_string("a list whose cddar is also a list");
+ cdddr_a_list_string = s7_make_permanent_string("a list whose cdddr is also a list");
+
+ a_list_string = s7_make_permanent_string("a list");
+ an_eq_func_string = s7_make_permanent_string("a procedure that can take 2 arguments");
+ an_association_list_string = s7_make_permanent_string("an association list");
+ a_normal_real_string = s7_make_permanent_string("a normal real");
+ a_rational_string = s7_make_permanent_string("an integer or a ratio");
+ a_number_string = s7_make_permanent_string("a number");
+ a_procedure_string = s7_make_permanent_string("a procedure");
+ a_normal_procedure_string = s7_make_permanent_string("a normal procedure (not a continuation)");
+ a_let_string = s7_make_permanent_string("a let (environment)");
+ a_proper_list_string = s7_make_permanent_string("a proper list");
+ a_boolean_string = s7_make_permanent_string("a boolean");
+ an_input_port_string = s7_make_permanent_string("an input port");
+ an_open_port_string = s7_make_permanent_string("an open port");
+ an_output_port_string = s7_make_permanent_string("an output port");
+ an_input_string_port_string = s7_make_permanent_string("an input string port");
+ an_input_file_port_string = s7_make_permanent_string("an input file port");
+ an_output_string_port_string = s7_make_permanent_string("an output string port");
+ an_output_file_port_string = s7_make_permanent_string("an output file port");
+ a_thunk_string = s7_make_permanent_string("a thunk");
+ a_symbol_string = s7_make_permanent_string("a symbol");
+ a_non_negative_integer_string = s7_make_permanent_string("a non-negative integer");
+ an_unsigned_byte_string = s7_make_permanent_string("an unsigned byte");
+ something_applicable_string = s7_make_permanent_string("a procedure or something applicable");
+ a_random_state_object_string = s7_make_permanent_string("a random-state object");
+ a_format_port_string = s7_make_permanent_string("#f, #t, or an open output port");
+ a_binding_string = s7_make_permanent_string("a pair whose car is a symbol: '(symbol . value)");
+ a_non_constant_symbol_string = s7_make_permanent_string("a non-constant symbol");
+ a_sequence_string = s7_make_permanent_string("a sequence");
+ a_valid_radix_string = s7_make_permanent_string("should be between 2 and 16");
+ result_is_too_large_string = s7_make_permanent_string("result is too large");
+ its_too_large_string = s7_make_permanent_string("it is too large");
+ its_too_small_string = s7_make_permanent_string("it is less than the start position");
+ its_negative_string = s7_make_permanent_string("it is negative");
+ its_nan_string = s7_make_permanent_string("NaN usually indicates a numerical error");
+ its_infinite_string = s7_make_permanent_string("it is infinite");
+ too_many_indices_string = s7_make_permanent_string("too many indices");
#if (!HAVE_COMPLEX_NUMBERS)
- NO_COMPLEX_NUMBERS = s7_make_permanent_string("this version of s7 does not support complex numbers");
+ no_complex_numbers_string = s7_make_permanent_string("this version of s7 does not support complex numbers");
#endif
}
@@ -34615,7 +34827,7 @@ static void init_car_a_list(void)
static s7_pointer g_car_1(s7_scheme *sc, s7_pointer lst)
{
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->CAR, set_plist_1(sc, lst), T_PAIR, 0);
+ method_or_bust(sc, lst, sc->car_symbol, set_plist_1(sc, lst), T_PAIR, 0);
return(car(lst));
}
@@ -34627,7 +34839,7 @@ static s7_pointer g_car(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->CAR, args, T_PAIR, 0);
+ method_or_bust(sc, lst, sc->car_symbol, args, T_PAIR, 0);
return(car(lst));
}
@@ -34637,12 +34849,12 @@ PF_TO_PF(car, g_car_1)
static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args)
{
#define H_set_car "(set-car! pair val) sets the pair's first element to val"
- #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->IS_PAIR, sc->T)
+ #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
s7_pointer p;
p = car(args);
if (!is_pair(p))
- method_or_bust(sc, p, sc->SET_CAR, args, T_PAIR, 1);
+ method_or_bust(sc, p, sc->set_car_symbol, args, T_PAIR, 1);
car(p) = cadr(args);
return(car(p));
@@ -34651,7 +34863,7 @@ static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args)
static s7_pointer c_set_car(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_pair(x))
- method_or_bust(sc, x, sc->SET_CAR, set_plist_2(sc, x, y), T_PAIR, 1);
+ method_or_bust(sc, x, sc->set_car_symbol, set_plist_2(sc, x, y), T_PAIR, 1);
car(x) = y;
return(y);
}
@@ -34663,7 +34875,7 @@ PF2_TO_PF(set_car, c_set_car)
static s7_pointer g_cdr_1(s7_scheme *sc, s7_pointer lst)
{
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->CDR, set_plist_1(sc, lst), T_PAIR, 0);
+ method_or_bust(sc, lst, sc->cdr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
return(cdr(lst));
}
@@ -34675,7 +34887,7 @@ static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
if (!is_pair(lst))
- method_or_bust(sc, lst, sc->CDR, args, T_PAIR, 0);
+ method_or_bust(sc, lst, sc->cdr_symbol, args, T_PAIR, 0);
return(cdr(lst));
}
@@ -34685,12 +34897,12 @@ PF_TO_PF(cdr, g_cdr_1)
static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args)
{
#define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val"
- #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->IS_PAIR, sc->T)
+ #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
s7_pointer p;
p = car(args);
if (!is_pair(p))
- method_or_bust(sc, p, sc->SET_CDR, args, T_PAIR, 1);
+ method_or_bust(sc, p, sc->set_cdr_symbol, args, T_PAIR, 1);
cdr(p) = cadr(args);
return(cdr(p));
@@ -34699,7 +34911,7 @@ static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args)
static s7_pointer c_set_cdr(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_pair(x))
- method_or_bust(sc, x, sc->SET_CDR, set_plist_2(sc, x, y), T_PAIR, 1);
+ method_or_bust(sc, x, sc->set_cdr_symbol, set_plist_2(sc, x, y), T_PAIR, 1);
cdr(x) = y;
return(y);
}
@@ -34711,8 +34923,8 @@ PF2_TO_PF(set_cdr, c_set_cdr)
/* -------- caar --------*/
static s7_pointer g_caar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAR, lst, CAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst, car_a_list_string));
/* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
return(caar(lst));
}
@@ -34724,8 +34936,8 @@ static s7_pointer g_caar(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAAR, args, T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAR, lst, CAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caar_symbol, args, T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst, car_a_list_string));
/* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
return(caar(lst));
}
@@ -34736,8 +34948,8 @@ PF_TO_PF(caar, g_caar_1)
/* -------- cadr --------*/
static s7_pointer g_cadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADR, lst, CDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst, cdr_a_list_string));
return(cadr(lst));
}
@@ -34748,8 +34960,8 @@ static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADR, args, T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADR, lst, CDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadr_symbol, args, T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst, cdr_a_list_string));
return(cadr(lst));
}
@@ -34759,8 +34971,8 @@ PF_TO_PF(cadr, g_cadr_1)
/* -------- cdar -------- */
static s7_pointer g_cdar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAR, lst, CAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst, car_a_list_string));
return(cdar(lst));
}
@@ -34771,8 +34983,8 @@ static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDAR, args, T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAR, lst, CAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdar_symbol, args, T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst, car_a_list_string));
return(cdar(lst));
}
@@ -34782,8 +34994,8 @@ PF_TO_PF(cdar, g_cdar_1)
/* -------- cddr -------- */
static s7_pointer g_cddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDR, lst, CDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst, cdr_a_list_string));
return(cddr(lst));
}
@@ -34794,8 +35006,8 @@ static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args)
s7_pointer lst;
lst = car(args);
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDR, args, T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDR, lst, CDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddr_symbol, args, T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst, cdr_a_list_string));
return(cddr(lst));
}
@@ -34805,9 +35017,9 @@ PF_TO_PF(cddr, g_cddr_1)
/* -------- caaar -------- */
static s7_pointer g_caaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAR, lst, CAR_A_LIST));
- if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAR, lst, CAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, car_a_list_string));
+ if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, caar_a_list_string));
return(caaar(lst));
}
@@ -34825,9 +35037,9 @@ PF_TO_PF(caaar, g_caaar_1)
/* -------- caadr -------- */
static s7_pointer g_caadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADR, lst, CDR_A_LIST));
- if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CAADR, lst, CADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst, cadr_a_list_string));
return(caadr(lst));
}
@@ -34845,9 +35057,9 @@ PF_TO_PF(caadr, g_caadr_1)
/* -------- cadar -------- */
static s7_pointer g_cadar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAR, lst, CAR_A_LIST));
- if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CADAR, lst, CDAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst, cdar_a_list_string));
return(cadar(lst));
}
@@ -34865,9 +35077,9 @@ PF_TO_PF(cadar, g_cadar_1)
/* -------- cdaar -------- */
static s7_pointer g_cdaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAR, lst, CAR_A_LIST));
- if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAR, lst, CAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, car_a_list_string));
+ if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, caar_a_list_string));
return(cdaar(lst));
}
@@ -34885,9 +35097,9 @@ PF_TO_PF(cdaar, g_cdaar_1)
/* -------- caddr -------- */
static s7_pointer g_caddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDR, lst, CDR_A_LIST));
- if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CADDR, lst, CDDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst, cddr_a_list_string));
return(caddr(lst));
}
@@ -34905,9 +35117,9 @@ PF_TO_PF(caddr, g_caddr_1)
/* -------- cdddr -------- */
static s7_pointer g_cdddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDR, lst, CDR_A_LIST));
- if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDR, lst, CDDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst, cddr_a_list_string));
return(cdddr(lst));
}
@@ -34925,9 +35137,9 @@ PF_TO_PF(cdddr, g_cdddr_1)
/* -------- cdadr -------- */
static s7_pointer g_cdadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADR, lst, CDR_A_LIST));
- if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDADR, lst, CADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst, cadr_a_list_string));
return(cdadr(lst));
}
@@ -34945,9 +35157,9 @@ PF_TO_PF(cdadr, g_cdadr_1)
/* -------- cddar -------- */
static s7_pointer g_cddar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAR, lst, CAR_A_LIST));
- if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAR, lst, CDAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, cdar_a_list_string));
return(cddar(lst));
}
@@ -34965,10 +35177,10 @@ PF_TO_PF(cddar, g_cddar_1)
/* -------- caaaar -------- */
static s7_pointer g_caaaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAAAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAR_A_LIST));
- if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAAR_A_LIST));
- if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, car_a_list_string));
+ if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, caar_a_list_string));
+ if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, caaar_a_list_string));
return(caaaar(lst));
}
@@ -34986,10 +35198,10 @@ PF_TO_PF(caaaar, g_caaaar_1)
/* -------- caaadr -------- */
static s7_pointer g_caaadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAAADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CDR_A_LIST));
- if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CADR_A_LIST));
- if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CAADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, cadr_a_list_string));
+ if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, caadr_a_list_string));
return(caaadr(lst));
}
@@ -35007,10 +35219,10 @@ PF_TO_PF(caaadr, g_caaadr_1)
/* -------- caadar -------- */
static s7_pointer g_caadar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAADAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CAR_A_LIST));
- if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CDAR_A_LIST));
- if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CADAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, cdar_a_list_string));
+ if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, cadar_a_list_string));
return(caadar(lst));
}
@@ -35028,10 +35240,10 @@ PF_TO_PF(caadar, g_caadar_1)
/* -------- cadaar -------- */
static s7_pointer g_cadaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CAR_A_LIST));
- if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CAAR_A_LIST));
- if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CDAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, car_a_list_string));
+ if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, caar_a_list_string));
+ if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, cdaar_a_list_string));
return(cadaar(lst));
}
@@ -35049,10 +35261,10 @@ PF_TO_PF(cadaar, g_cadaar_1)
/* -------- caaddr -------- */
static s7_pointer g_caaddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CAADDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CDR_A_LIST));
- if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CDDR_A_LIST));
- if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CADDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, cddr_a_list_string));
+ if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, caddr_a_list_string));
return(caaddr(lst));
}
@@ -35070,10 +35282,10 @@ PF_TO_PF(caaddr, g_caaddr_1)
/* -------- cadddr -------- */
static s7_pointer g_cadddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADDDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDR_A_LIST));
- if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDDR_A_LIST));
- if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDDDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cddr_a_list_string));
+ if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cdddr_a_list_string));
return(cadddr(lst));
}
@@ -35091,10 +35303,10 @@ PF_TO_PF(cadddr, g_cadddr_1)
/* -------- cadadr -------- */
static s7_pointer g_cadadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CDR_A_LIST));
- if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CADR_A_LIST));
- if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CDADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cadr_a_list_string));
+ if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cdadr_a_list_string));
return(cadadr(lst));
}
@@ -35112,10 +35324,10 @@ PF_TO_PF(cadadr, g_cadadr_1)
/* -------- caddar -------- */
static s7_pointer g_caddar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CADDAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CAR_A_LIST));
- if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CDAR_A_LIST));
- if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CDDAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, cdar_a_list_string));
+ if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, cddar_a_list_string));
return(caddar(lst));
}
@@ -35133,10 +35345,10 @@ PF_TO_PF(caddar, g_caddar_1)
/* -------- cdaaar -------- */
static s7_pointer g_cdaaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDAAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAR_A_LIST));
- if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAAR_A_LIST));
- if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, car_a_list_string));
+ if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, caar_a_list_string));
+ if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, caaar_a_list_string));
return(cdaaar(lst));
}
@@ -35154,10 +35366,10 @@ PF_TO_PF(cdaaar, g_cdaaar_1)
/* -------- cdaadr -------- */
static s7_pointer g_cdaadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDAADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CDR_A_LIST));
- if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CADR_A_LIST));
- if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CAADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, cadr_a_list_string));
+ if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, caadr_a_list_string));
return(cdaadr(lst));
}
@@ -35175,10 +35387,10 @@ PF_TO_PF(cdaadr, g_cdaadr_1)
/* -------- cdadar -------- */
static s7_pointer g_cdadar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDADAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CAR_A_LIST));
- if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CDAR_A_LIST));
- if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CADAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, cdar_a_list_string));
+ if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, cadar_a_list_string));
return(cdadar(lst));
}
@@ -35196,10 +35408,10 @@ PF_TO_PF(cdadar, g_cdadar_1)
/* -------- cddaar -------- */
static s7_pointer g_cddaar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDAAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CAR_A_LIST));
- if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CAAR_A_LIST));
- if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CDAAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, car_a_list_string));
+ if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, caar_a_list_string));
+ if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, cdaar_a_list_string));
return(cddaar(lst));
}
@@ -35217,10 +35429,10 @@ PF_TO_PF(cddaar, g_cddaar_1)
/* -------- cdaddr -------- */
static s7_pointer g_cdaddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDADDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CDR_A_LIST));
- if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CDDR_A_LIST));
- if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CADDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, cddr_a_list_string));
+ if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, caddr_a_list_string));
return(cdaddr(lst));
}
@@ -35238,10 +35450,10 @@ PF_TO_PF(cdaddr, g_cdaddr_1)
/* -------- cddddr -------- */
static s7_pointer g_cddddr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDDDR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDR_A_LIST));
- if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDDR_A_LIST));
- if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDDDR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cddr_a_list_string));
+ if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cdddr_a_list_string));
return(cddddr(lst));
}
@@ -35258,10 +35470,10 @@ PF_TO_PF(cddddr, g_cddddr_1)
/* -------- cddadr -------- */
static s7_pointer g_cddadr_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDADR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CDR_A_LIST));
- if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CADR_A_LIST));
- if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CDADR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cdr_a_list_string));
+ if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cadr_a_list_string));
+ if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cdadr_a_list_string));
return(cddadr(lst));
}
@@ -35278,10 +35490,10 @@ PF_TO_PF(cddadr, g_cddadr_1)
/* -------- cdddar -------- */
static s7_pointer g_cdddar_1(s7_scheme *sc, s7_pointer lst)
{
- if (!is_pair(lst)) method_or_bust(sc, lst, sc->CDDDAR, set_plist_1(sc, lst), T_PAIR, 0);
- if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CAR_A_LIST));
- if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CDAR_A_LIST));
- if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CDDAR_A_LIST));
+ if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
+ if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, car_a_list_string));
+ if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, cdar_a_list_string));
+ if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, cddar_a_list_string));
return(cdddar(lst));
}
@@ -35340,13 +35552,12 @@ s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
return(sc->F); /* not reached */
}
-#if (!WITH_PURE_S7)
static s7_pointer c_assq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_pair(y))
{
if (is_null(y)) return(sc->F);
- method_or_bust_with_type(sc, y, sc->ASSQ, list_2(sc, x, y), AN_ASSOCIATION_LIST, 2);
+ method_or_bust_with_type(sc, y, sc->assq_symbol, list_2(sc, x, y), an_association_list_string, 2);
}
/* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc:
* (assq #f '(#f 2 . 3)) -> #f
@@ -35358,12 +35569,11 @@ static s7_pointer c_assq(s7_scheme *sc, s7_pointer x, s7_pointer y)
static s7_pointer g_assq(s7_scheme *sc, s7_pointer args)
{
#define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist"
- #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_BOOLEAN), sc->T, sc->IS_LIST)
+ #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol)
return(c_assq(sc, car(args), cadr(args)));
}
PF2_TO_PF(assq, c_assq)
-#endif
static s7_pointer c_assv(s7_scheme *sc, s7_pointer x, s7_pointer y)
@@ -35372,7 +35582,7 @@ static s7_pointer c_assv(s7_scheme *sc, s7_pointer x, s7_pointer y)
if (!is_pair(y))
{
if (is_null(y)) return(sc->F);
- method_or_bust_with_type(sc, y, sc->ASSV, list_2(sc, x, y), AN_ASSOCIATION_LIST, 2);
+ method_or_bust_with_type(sc, y, sc->assv_symbol, list_2(sc, x, y), an_association_list_string, 2);
}
if (is_simple(x))
@@ -35403,9 +35613,7 @@ static s7_pointer g_assv(s7_scheme *sc, s7_pointer args) /* g_assv is cal
return(c_assv(sc, car(args), cadr(args)));
}
-#if (!WITH_PURE_S7)
PF2_TO_PF(assv, c_assv)
-#endif
static s7_pointer all_x_c_ss(s7_scheme *sc, s7_pointer arg);
static s7_pointer all_x_c_uu(s7_scheme *sc, s7_pointer arg);
@@ -35416,7 +35624,7 @@ static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args)
{
#define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\
If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
- #define Q_assoc s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_BOOLEAN), sc->T, sc->IS_LIST, sc->IS_PROCEDURE)
+ #define Q_assoc s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)
s7_pointer x, y, obj, eq_func = NULL;
@@ -35424,10 +35632,10 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of
if (!is_null(x))
{
if (!is_pair(x))
- method_or_bust_with_type(sc, x, sc->ASSOC, args, AN_ASSOCIATION_LIST, 2);
+ method_or_bust_with_type(sc, x, sc->assoc_symbol, args, an_association_list_string, 2);
if ((is_pair(x)) && (!is_pair(car(x))))
- return(wrong_type_argument_with_type(sc, sc->ASSOC, 2, x, AN_ASSOCIATION_LIST)); /* we're assuming caar below so it better exist */
+ return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, x, an_association_list_string)); /* we're assuming caar below so it better exist */
}
if (is_not_null(cddr(args)))
@@ -35436,10 +35644,10 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of
eq_func = caddr(args);
if (type(eq_func) < T_GOTO)
- method_or_bust_with_type(sc, eq_func, sc->ASSOC, args, A_PROCEDURE, 0);
+ method_or_bust_with_type(sc, eq_func, sc->assoc_symbol, args, a_procedure_string, 0);
if (!s7_is_aritable(sc, eq_func, 2))
- return(wrong_type_argument_with_type(sc, sc->ASSOC, 3, eq_func, AN_EQ_FUNC));
+ return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string));
}
if (is_null(x)) return(sc->F);
@@ -35456,19 +35664,19 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of
func = c_function_call(eq_func);
if (func == g_is_eq) return(s7_assq(sc, car(args), x));
if (func == g_is_eqv) return(g_assv(sc, args));
- car(sc->T2_1) = car(args);
+ car(sc->t2_1) = car(args);
for (; is_pair(x); x = cdr(x))
{
if (is_pair(car(x)))
{
- car(sc->T2_2) = caar(x);
- if (is_true(sc, func(sc, sc->T2_1)))
+ car(sc->t2_2) = caar(x);
+ if (is_true(sc, func(sc, sc->t2_1)))
return(car(x));
/* I wonder if the assoc equality function should get the cons, not just caar?
*/
}
- else return(wrong_type_argument_with_type(sc, sc->ASSOC, 2, cadr(args), AN_ASSOCIATION_LIST));
+ else return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string));
}
return(sc->F);
}
@@ -35503,12 +35711,12 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of
}
/* sc->value = sc->F; */
- y = cons(sc, args, sc->NIL);
+ y = cons(sc, args, sc->nil);
set_opt_fast(y, x);
set_opt_slow(y, x);
push_stack(sc, OP_ASSOC_IF, y, eq_func);
push_stack(sc, OP_APPLY, list_2(sc, car(args), caar(x)), eq_func);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
x = cadr(args);
@@ -35600,13 +35808,13 @@ s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
return(sc->F);
}
-#if (!WITH_PURE_S7)
+
static s7_pointer c_memq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
if (!is_pair(y))
{
if (is_null(y)) return(sc->F);
- method_or_bust_with_type(sc, y, sc->MEMQ, list_2(sc, x, y), A_LIST, 2);
+ method_or_bust_with_type(sc, y, sc->memq_symbol, list_2(sc, x, y), a_list_string, 2);
}
return(s7_memq(sc, x, y));
}
@@ -35614,12 +35822,12 @@ static s7_pointer c_memq(s7_scheme *sc, s7_pointer x, s7_pointer y)
static s7_pointer g_memq(s7_scheme *sc, s7_pointer args)
{
#define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?"
- #define Q_memq pl_tp
+ #define Q_memq pl_tl
return(c_memq(sc, car(args), cadr(args)));
}
PF2_TO_PF(memq, c_memq)
-#endif
+
/* I think (memq 'c '(a b . c)) should return #f because otherwise
* (memq () ...) would return the () at the end.
*/
@@ -35706,10 +35914,10 @@ static s7_pointer g_memq_car(s7_scheme *sc, s7_pointer args)
{
s7_pointer func;
if ((has_methods(obj)) &&
- ((func = find_method(sc, find_let(sc, obj), sc->CAR)) != sc->UNDEFINED))
+ ((func = find_method(sc, find_let(sc, obj), sc->car_symbol)) != sc->undefined))
obj = s7_apply_function(sc, func, list_1(sc, obj));
if (!is_pair(obj))
- return(simple_wrong_type_argument(sc, sc->CAR, obj, T_PAIR));
+ return(simple_wrong_type_argument(sc, sc->car_symbol, obj, T_PAIR));
}
obj = car(obj);
x = cadr(cadr(args));
@@ -35730,7 +35938,7 @@ static s7_pointer g_memq_car(s7_scheme *sc, s7_pointer args)
static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
if ((is_pair(caddr(expr))) &&
- (car(caddr(expr)) == sc->QUOTE) &&
+ (car(caddr(expr)) == sc->quote_symbol) &&
(is_pair(cadr(caddr(expr)))))
{
int len;
@@ -35788,7 +35996,7 @@ static s7_pointer c_memv(s7_scheme *sc, s7_pointer x, s7_pointer y)
if (!is_pair(y))
{
if (is_null(y)) return(sc->F);
- method_or_bust_with_type(sc, y, sc->MEMV, list_2(sc, x, y), A_LIST, 2);
+ method_or_bust_with_type(sc, y, sc->memv_symbol, list_2(sc, x, y), a_list_string, 2);
}
if (is_simple(x)) return(s7_memq(sc, x, y));
@@ -35814,14 +36022,13 @@ static s7_pointer c_memv(s7_scheme *sc, s7_pointer x, s7_pointer y)
static s7_pointer g_memv(s7_scheme *sc, s7_pointer args)
{
#define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?"
- #define Q_memv pl_tp
+ #define Q_memv pl_tl
return(c_memv(sc, car(args), cadr(args)));
}
-#if (!WITH_PURE_S7)
PF2_TO_PF(memv, c_memv)
-#endif
+
static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x)
{
@@ -35880,7 +36087,7 @@ static s7_pointer g_member(s7_scheme *sc, s7_pointer args)
{
#define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \
member uses equal? If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
- #define Q_member s7_make_signature(sc, 4, sc->T, sc->T, sc->IS_LIST, sc->IS_PROCEDURE)
+ #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)
/* this could be extended to accept sequences:
* (member #\a "123123abnfc" char=?) -> "abnfc"
@@ -35896,7 +36103,7 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
x = cadr(args);
if ((!is_pair(x)) && (!is_null(x)))
- method_or_bust_with_type(sc, x, sc->MEMBER, args, A_LIST, 2);
+ method_or_bust_with_type(sc, x, sc->member_symbol, args, a_list_string, 2);
if (is_not_null(cddr(args)))
{
@@ -35904,10 +36111,10 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
eq_func = caddr(args);
if (type(eq_func) < T_GOTO)
- method_or_bust_with_type(sc, eq_func, sc->MEMBER, args, A_PROCEDURE, 3);
+ method_or_bust_with_type(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3);
if (!s7_is_aritable(sc, eq_func, 2))
- return(wrong_type_argument_with_type(sc, sc->MEMBER, 3, eq_func, AN_EQ_FUNC));
+ return(wrong_type_argument_with_type(sc, sc->member_symbol, 3, eq_func, an_eq_func_string));
}
if (is_null(x)) return(sc->F);
@@ -35924,12 +36131,12 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
func = c_function_call(eq_func);
if (func == g_is_eq) return(s7_memq(sc, car(args), x));
if (func == g_is_eqv) return(g_memv(sc, args));
- car(sc->T2_1) = car(args);
+ car(sc->t2_1) = car(args);
for (; is_pair(x); x = cdr(x))
{
- car(sc->T2_2) = car(x);
- if (is_true(sc, func(sc, sc->T2_1)))
+ car(sc->t2_2) = car(x);
+ if (is_true(sc, func(sc, sc->t2_1)))
return(x);
}
return(sc->F);
@@ -35953,12 +36160,12 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
(cadar(body) == car(closure_args(eq_func))) &&
(caddar(body) == cadr(closure_args(eq_func))))
{
- car(sc->T2_1) = car(args);
+ car(sc->t2_1) = car(args);
func = c_callee(car(body));
for (; is_pair(x); x = cdr(x))
{
- car(sc->T2_2) = car(x);
- if (is_true(sc, func(sc, sc->T2_1)))
+ car(sc->t2_2) = car(x);
+ if (is_true(sc, func(sc, sc->t2_1)))
return(x);
}
}
@@ -35980,14 +36187,14 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
}
}
- y = cons(sc, args, sc->NIL); /* this could probably be handled with a counter cell (cdr here is unused) */
+ y = cons(sc, args, sc->nil); /* this could probably be handled with a counter cell (cdr here is unused) */
set_opt_fast(y, x);
set_opt_slow(y, x);
push_stack(sc, OP_MEMBER_IF, y, eq_func);
- car(sc->T2_1) = car(args);
- car(sc->T2_2) = car(x);
- push_stack(sc, OP_APPLY, sc->T2_1, eq_func);
- return(sc->UNSPECIFIED);
+ car(sc->t2_1) = car(args);
+ car(sc->t2_2) = car(x);
+ push_stack(sc, OP_APPLY, sc->t2_1, eq_func);
+ return(sc->unspecified);
}
obj = car(args);
@@ -36031,7 +36238,7 @@ static s7_pointer g_member_num_s(s7_scheme *sc, s7_pointer args)
if (!is_pair(lst))
{
if (is_null(lst)) return(sc->F);
- method_or_bust_with_type(sc, lst, sc->MEMBER, list_2(sc, car(args), lst), A_LIST, 2);
+ method_or_bust_with_type(sc, lst, sc->member_symbol, list_2(sc, car(args), lst), a_list_string, 2);
}
return(memv_number(sc, car(args), lst));
}
@@ -36046,7 +36253,7 @@ static s7_pointer g_member_ss(s7_scheme *sc, s7_pointer args)
if (!is_pair(x))
{
if (is_null(x)) return(sc->F);
- method_or_bust_with_type(sc, x, sc->MEMBER, list_2(sc, obj, x), A_LIST, 2);
+ method_or_bust_with_type(sc, x, sc->member_symbol, list_2(sc, obj, x), a_list_string, 2);
}
if (is_simple(obj))
@@ -36080,7 +36287,7 @@ static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int args, s7_point
{
if ((is_symbol(cadr(expr))) &&
(is_pair(caddr(expr))) &&
- (car(caddr(expr)) == sc->QUOTE) &&
+ (car(caddr(expr)) == sc->quote_symbol) &&
(is_pair(cadr(caddr(expr)))))
{
set_optimize_op(expr, HOP_SAFE_C_C);
@@ -36091,7 +36298,7 @@ static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int args, s7_point
if ((args == 3) &&
(is_symbol(cadddr(expr))) &&
- (cadddr(expr) == sc->IS_EQ))
+ (cadddr(expr) == sc->is_eq_symbol))
return(memq_chooser(sc, f, 2, expr));
return(f);
@@ -36113,25 +36320,25 @@ static s7_pointer c_is_provided(s7_scheme *sc, s7_pointer sym)
s7_pointer topf, x;
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->IS_PROVIDED, list_1(sc, sym), T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->is_provided_symbol, list_1(sc, sym), T_SYMBOL, 0);
/* here the *features* list is spread out (or can be anyway) along the curlet chain,
* so we need to travel back all the way to the top level checking each *features* list in turn.
* Since *features* grows via cons (newest first), we can stop the scan if we hit the shared
* top-level at least.
*/
- topf = slot_value(global_slot(sc->S7_FEATURES));
+ topf = slot_value(global_slot(sc->features_symbol));
if (is_memq(sym, topf))
return(sc->T);
- if (is_global(sc->S7_FEATURES))
+ if (is_global(sc->features_symbol))
return(sc->F);
- for (x = sc->envir; symbol_id(sc->S7_FEATURES) < let_id(x); x = outlet(x));
+ for (x = sc->envir; symbol_id(sc->features_symbol) < let_id(x); x = outlet(x));
for (; is_let(x); x = outlet(x))
{
s7_pointer y;
for (y = let_slots(x); is_slot(y); y = next_slot(y))
- if (slot_symbol(y) == sc->S7_FEATURES)
+ if (slot_symbol(y) == sc->features_symbol)
{
if ((slot_value(y) != topf) &&
(is_memq(sym, slot_value(y))))
@@ -36144,14 +36351,14 @@ static s7_pointer c_is_provided(s7_scheme *sc, s7_pointer sym)
static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args)
{
#define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list"
- #define Q_is_provided s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_SYMBOL)
+ #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol)
return(c_is_provided(sc, car(args)));
}
bool s7_is_provided(s7_scheme *sc, const char *feature)
{
- return(is_memq(s7_make_symbol(sc, feature), s7_symbol_value(sc, sc->S7_FEATURES))); /* this goes from local outward */
+ return(is_memq(s7_make_symbol(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */
}
PF_TO_PF(is_provided, c_is_provided)
@@ -36164,13 +36371,13 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym)
*/
s7_pointer p, lst;
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->PROVIDE, list_1(sc, sym), T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->provide_symbol, list_1(sc, sym), T_SYMBOL, 0);
- p = find_local_symbol(sc, sc->S7_FEATURES, sc->envir); /* if sc->envir is nil, this returns the global slot, else local slot */
- lst = slot_value(find_symbol(sc, sc->S7_FEATURES)); /* in either case, we want the current *feartures* list */
+ p = find_local_symbol(sc, sc->features_symbol, sc->envir); /* if sc->envir is nil, this returns the global slot, else local slot */
+ lst = slot_value(find_symbol(sc, sc->features_symbol)); /* in either case, we want the current *features* list */
- if (p == sc->UNDEFINED)
- make_slot_1(sc, sc->envir, sc->S7_FEATURES, cons(sc, sym, lst));
+ if (p == sc->undefined)
+ make_slot_1(sc, sc->envir, sc->features_symbol, cons(sc, sym, lst));
else
{
if (!is_memq(sym, lst))
@@ -36185,7 +36392,7 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym)
static s7_pointer g_provide(s7_scheme *sc, s7_pointer args)
{
#define H_provide "(provide symbol) adds symbol to the *features* list"
- #define Q_provide s7_make_signature(sc, 2, sc->IS_SYMBOL, sc->IS_SYMBOL)
+ #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol)
return(c_provide(sc, car(args)));
}
@@ -36202,34 +36409,34 @@ static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args)
/* symbol_access for set/let of *features* which can only be changed via provide */
if (s7_is_list(sc, cadr(args)))
return(cadr(args));
- return(sc->ERROR);
+ return(sc->error_symbol);
}
static s7_pointer g_list(s7_scheme *sc, s7_pointer args)
{
#define H_list "(list ...) returns its arguments in a list"
- #define Q_list s7_make_circular_signature(sc, 1, 2, sc->IS_PAIR, sc->T)
+ #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T)
return(copy_list(sc, args));
}
-static s7_pointer c_list_1(s7_scheme *sc, s7_pointer x) {return(cons(sc, x, sc->NIL));}
+static s7_pointer c_list_1(s7_scheme *sc, s7_pointer x) {return(cons(sc, x, sc->nil));}
PF_TO_PF(list, c_list_1)
static s7_pointer list_0, list_1, list_2;
static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args)
{
- return(sc->NIL);
+ return(sc->nil);
}
static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args)
{
- return(cons(sc, car(args), sc->NIL));
+ return(cons(sc, car(args), sc->nil));
}
static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args)
{
- return(cons_unchecked(sc, car(args), cons(sc, cadr(args), sc->NIL)));
+ return(cons_unchecked(sc, car(args), cons(sc, cadr(args), sc->nil)));
}
static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
@@ -36251,17 +36458,23 @@ s7_pointer s7_list(s7_scheme *sc, int num_values, ...)
s7_pointer p;
if (num_values == 0)
- return(sc->NIL);
+ return(sc->nil);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
va_start(ap, num_values);
for (i = 0; i < num_values; i++)
sc->w = cons(sc, va_arg(ap, s7_pointer), sc->w);
va_end(ap);
p = sc->w;
- sc->w = sc->NIL;
-
+ sc->w = sc->nil;
+#if DEBUGGING
+ {
+ s7_pointer x;
+ for (x = p; is_pair(x); x = cdr(x))
+ _NFre(car(x));
+ }
+#endif
return(safe_reverse_in_place(sc, p));
}
@@ -36272,13 +36485,13 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
s7_pointer y, tp, np = NULL, pp;
/* we know here that args is a pair and cdr(args) is a pair */
- tp = sc->NIL;
+ tp = sc->nil;
for (y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */
{
s7_pointer p;
p = car(y);
- check_method(sc, p, sc->APPEND, (is_null(tp)) ? args : cons(sc, tp, y));
+ check_method(sc, p, sc->append_symbol, (is_null(tp)) ? args : cons(sc, tp, y));
if (is_null(cdr(y)))
{
@@ -36299,12 +36512,12 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
cdr(np) = p;
}
}
- sc->y = sc->NIL;
+ sc->y = sc->nil;
return(tp);
}
if (!is_sequence(p))
- return(wrong_type_argument_with_type(sc, sc->APPEND, position_of(y, args), p, A_SEQUENCE));
+ return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string));
if (!is_null(p))
{
@@ -36312,8 +36525,8 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
{
if (!is_proper_list(sc, p))
{
- sc->y = sc->NIL;
- return(wrong_type_argument_with_type(sc, sc->APPEND, position_of(y, args), p, A_PROPER_LIST));
+ sc->y = sc->nil;
+ return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string));
}
/* is this error correct?
* (append '(3) '(1 . 2)) -> '(3 1 . 2) ; (old) guile also returns this
@@ -36322,14 +36535,14 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
if (is_null(tp))
{
- tp = cons(sc, car(p), sc->NIL);
+ tp = cons(sc, car(p), sc->nil);
np = tp;
sc->y = tp; /* GC protect? */
pp = cdr(p);
}
else pp = p;
for (; is_pair(pp); pp = cdr(pp), np = cdr(np))
- cdr(np) = cons(sc, car(pp), sc->NIL);
+ cdr(np) = cons(sc, car(pp), sc->nil);
}
else
{
@@ -36349,7 +36562,7 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
else
{
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->APPEND, position_of(y, args), p, A_SEQUENCE));
+ return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string));
}
}
}
@@ -36431,9 +36644,9 @@ static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, unsigned
{
s7_pointer x;
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, 1, make_integer(sc, len), A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, make_integer(sc, len), a_non_negative_integer_string));
if (len > sc->max_vector_length)
- return(out_of_range(sc, sc->MAKE_VECTOR, small_int(1), make_integer(sc, len), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_vector_symbol, small_int(1), make_integer(sc, len), its_too_large_string));
/* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */
new_cell(sc, x, typ | T_SAFE_PROCEDURE); /* (v 0) as vector-ref is safe */
@@ -36451,7 +36664,7 @@ static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, unsigned
return(s7_error(sc, make_symbol(sc, "out-of-memory"), set_elist_1(sc, make_string_wrapper(sc, "make-vector allocation failed!"))));
vector_getter(x) = default_vector_getter;
vector_setter(x) = default_vector_setter;
- if (filled) s7_vector_fill(sc, x, sc->NIL); /* make_hash_table assumes nil as the default value */
+ if (filled) s7_vector_fill(sc, x, sc->nil); /* make_hash_table assumes nil as the default value */
}
else
{
@@ -36700,7 +36913,7 @@ static void vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
{
#define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val"
- #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->IS_VECTOR, sc->T, sc->IS_INTEGER)
+ #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol)
s7_pointer x, fill;
s7_int start = 0, end;
@@ -36708,11 +36921,11 @@ static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
x = car(args);
if (!s7_is_vector(x))
{
- check_method(sc, x, sc->VECTOR_FILL, args);
+ check_method(sc, x, sc->vector_fill_symbol, args);
/* not two_methods (and fill!) here else we get stuff like:
* (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa"
*/
- return(wrong_type_argument(sc, sc->VECTOR_FILL, 1, x, T_VECTOR));
+ return(wrong_type_argument(sc, sc->vector_fill_symbol, 1, x, T_VECTOR));
}
fill = cadr(args);
@@ -36720,7 +36933,7 @@ static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_real(fill)) /* possibly a bignum */
{
- check_two_methods(sc, fill, sc->VECTOR_FILL, sc->FILL, args);
+ check_two_methods(sc, fill, sc->vector_fill_symbol, sc->fill_symbol, args);
s7_wrong_type_arg_error(sc, "(float) vector-fill!", 2, fill, "a real");
}
}
@@ -36730,7 +36943,7 @@ static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
{
if (!s7_is_integer(fill))
{
- check_two_methods(sc, fill, sc->VECTOR_FILL, sc->FILL, args);
+ check_two_methods(sc, fill, sc->vector_fill_symbol, sc->fill_symbol, args);
s7_wrong_type_arg_error(sc, "(int) vector-fill!", 2, fill, "an integer");
}
}
@@ -36740,8 +36953,8 @@ static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
if (!is_null(cddr(args)))
{
s7_pointer p;
- p = start_and_end(sc, sc->VECTOR_FILL, sc->FILL, cddr(args), args, 3, &start, &end);
- if (p != sc->GC_NIL) return(p);
+ p = start_and_end(sc, sc->vector_fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
+ if (p != sc->gc_nil) return(p);
if (start == end) return(fill);
}
if (end == 0) return(fill);
@@ -36814,7 +37027,7 @@ PF2_TO_PF(vector_fill, c_vector_fill)
s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index)
{
if (index >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), make_integer(sc, index), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
return(vector_getter(vec)(sc, vec, index));
}
@@ -36823,9 +37036,9 @@ s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index)
s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a)
{
if (index >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), make_integer(sc, index), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
- vector_setter(vec)(sc, vec, index, a);
+ vector_setter(vec)(sc, vec, index, _NFre(a));
return(a);
}
@@ -36897,8 +37110,8 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
if (has_methods(x))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, x), sc->VECTOR_APPEND);
- if (func != sc->UNDEFINED)
+ func = find_method(sc, find_let(sc, x), sc->vector_append_symbol);
+ if (func != sc->undefined)
{
int k;
s7_pointer v, y;
@@ -36910,11 +37123,11 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
car(v) = car(y);
v = g_vector_append(sc, sc->temp9);
y = s7_apply_function(sc, func, cons(sc, v, p));
- sc->temp9 = sc->NIL;
+ sc->temp9 = sc->nil;
return(y);
}
}
- return(wrong_type_argument(sc, sc->VECTOR_APPEND, i, x, T_VECTOR));
+ return(wrong_type_argument(sc, sc->vector_append_symbol, i, x, T_VECTOR));
}
}
return(vector_append(sc, args, type(car(args))));
@@ -36955,7 +37168,7 @@ s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, int indices, ...)
(ind >= dimensions[i]))
{
va_end(ap);
- return(out_of_range(sc, sc->VECTOR_REF, small_int(i), make_integer(sc, ind), (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(i), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string));
}
index += (ind * offsets[i]);
}
@@ -37021,7 +37234,7 @@ s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect)
len = vector_length(vect);
if (len == 0)
- return(sc->NIL);
+ return(sc->nil);
if (len >= (sc->free_heap_top - sc->free_heap))
{
gc(sc);
@@ -37029,11 +37242,11 @@ s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect)
resize_heap(sc);
}
- sc->v = sc->NIL;
+ sc->v = sc->nil;
for (i = len - 1; i >= 0; i--)
sc->v = cons_unchecked(sc, vector_getter(vect)(sc, vect, i), sc->v);
result = sc->v;
- sc->v = sc->NIL;
+ sc->v = sc->nil;
return(result);
}
@@ -37042,7 +37255,7 @@ static s7_pointer c_vector_to_list(s7_scheme *sc, s7_pointer vec)
{
sc->temp3 = vec;
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_TO_LIST, list_1(sc, vec), T_VECTOR, 0);
+ method_or_bust(sc, vec, sc->vector_to_list_symbol, list_1(sc, vec), T_VECTOR, 0);
return(s7_vector_to_list(sc, vec));
}
@@ -37051,27 +37264,27 @@ static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args)
s7_int i, start = 0, end;
s7_pointer p, vec;
#define H_vector_to_list "(vector->list v start end) returns the elements of the vector v as a list; (map values v)"
- #define Q_vector_to_list s7_make_circular_signature(sc, 2, 3, sc->IS_LIST, sc->IS_VECTOR, sc->IS_INTEGER)
+ #define Q_vector_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol)
vec = car(args);
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_TO_LIST, args, T_VECTOR, 0);
+ method_or_bust(sc, vec, sc->vector_to_list_symbol, args, T_VECTOR, 0);
end = vector_length(vec);
if (!is_null(cdr(args)))
{
- p = start_and_end(sc, sc->VECTOR_TO_LIST, NULL, cdr(args), args, 2, &start, &end);
- if (p != sc->GC_NIL) return(p);
- if (start == end) return(sc->NIL);
+ p = start_and_end(sc, sc->vector_to_list_symbol, NULL, cdr(args), args, 2, &start, &end);
+ if (p != sc->gc_nil) return(p);
+ if (start == end) return(sc->nil);
}
if ((start == 0) && (end == vector_length(vec)))
return(s7_vector_to_list(sc, vec));
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = end - 1; i >= start; i--)
sc->w = cons(sc, vector_getter(vec)(sc, vec, i), sc->w);
p = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(p);
}
@@ -37090,7 +37303,7 @@ s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill)
static s7_pointer g_vector(s7_scheme *sc, s7_pointer args)
{
#define H_vector "(vector ...) returns a vector whose elements are the arguments"
- #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->IS_VECTOR, sc->T)
+ #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T)
s7_int len;
s7_pointer vec;
@@ -37113,15 +37326,15 @@ PF_TO_PF(vector, c_vector_1)
static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogenous float vector"
+ #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector"
#define Q_is_float_vector pl_bt
- check_boolean_method(sc, s7_is_float_vector, sc->IS_FLOAT_VECTOR, args);
+ check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args);
}
static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_float_vector "(float-vector ...) returns an homogenous float vector whose elements are the arguments"
- #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->IS_FLOAT_VECTOR, sc->IS_REAL)
+ #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments"
+ #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol)
s7_int len;
s7_pointer vec;
@@ -37136,7 +37349,7 @@ static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args)
{
if (s7_is_real(car(x))) /* bignum is ok here */
float_vector_element(vec, i) = real_to_double(sc, car(x), "float-vector");
- else return(simple_wrong_type_argument(sc, sc->FLOAT_VECTOR, car(x), T_REAL));
+ else return(simple_wrong_type_argument(sc, sc->float_vector_symbol, car(x), T_REAL));
}
}
return(vec);
@@ -37148,15 +37361,15 @@ PF_TO_PF(float_vector, c_float_vector_1)
static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogenous int vector"
+ #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous int vector"
#define Q_is_int_vector pl_bt
- check_boolean_method(sc, is_int_vector, sc->IS_INT_VECTOR, args);
+ check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args);
}
static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_int_vector "(int-vector ...) returns an homogenous int vector whose elements are the arguments"
- #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->IS_INT_VECTOR, sc->IS_INTEGER)
+ #define H_int_vector "(int-vector ...) returns an homogeneous int vector whose elements are the arguments"
+ #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol)
s7_int len;
s7_pointer vec;
@@ -37171,7 +37384,7 @@ static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args)
{
if (is_integer(car(x)))
int_vector_element(vec, i) = integer(car(x));
- else return(simple_wrong_type_argument(sc, sc->INT_VECTOR, car(x), T_INTEGER));
+ else return(simple_wrong_type_argument(sc, sc->int_vector_symbol, car(x), T_INTEGER));
}
}
return(vec);
@@ -37189,7 +37402,7 @@ static s7_pointer c_list_to_vector(s7_scheme *sc, s7_pointer p)
return(s7_make_vector(sc, 0));
if (!is_proper_list(sc, p))
- method_or_bust_with_type(sc, p, sc->LIST_TO_VECTOR, list_1(sc, p), A_PROPER_LIST, 0);
+ method_or_bust_with_type(sc, p, sc->list_to_vector_symbol, list_1(sc, p), a_proper_list_string, 0);
return(g_vector(sc, p));
}
@@ -37197,7 +37410,7 @@ static s7_pointer c_list_to_vector(s7_scheme *sc, s7_pointer p)
static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args)
{
#define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)"
- #define Q_list_to_vector s7_make_signature(sc, 2, sc->IS_VECTOR, sc->IS_PROPER_LIST)
+ #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol)
return(c_list_to_vector(sc, car(args)));
}
@@ -37208,11 +37421,11 @@ static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args)
{
s7_pointer vec;
#define H_vector_length "(vector-length v) returns the length of vector v"
- #define Q_vector_length s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_VECTOR)
+ #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
vec = car(args);
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_LENGTH, args, T_VECTOR, 0);
+ method_or_bust(sc, vec, sc->vector_length_symbol, args, T_VECTOR, 0);
return(make_integer(sc, vector_length(vec)));
}
@@ -37220,7 +37433,7 @@ static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args)
static s7_int c_vector_length(s7_scheme *sc, s7_pointer vec)
{
if (!s7_is_vector(vec))
- int_method_or_bust(sc, vec, sc->VECTOR_LENGTH, set_plist_1(sc, vec), T_VECTOR, 0);
+ int_method_or_bust(sc, vec, sc->vector_length_symbol, set_plist_1(sc, vec), T_VECTOR, 0);
return(vector_length(vec));
}
@@ -37276,7 +37489,7 @@ static s7_pointer g_make_shared_vector(s7_scheme *sc, s7_pointer args)
{
#define H_make_shared_vector "(make-shared-vector original-vector new-dimensions (offset 0)) returns \
a vector that points to the same elements as the original-vector but with different dimensional info."
- #define Q_make_shared_vector s7_make_signature(sc, 4, sc->IS_VECTOR, sc->IS_VECTOR, s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_INTEGER), sc->IS_INTEGER)
+ #define Q_make_shared_vector s7_make_signature(sc, 4, sc->is_vector_symbol, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_integer_symbol), sc->is_integer_symbol)
/* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (make-shared-vector v1 '(6)))) v2)) -> #(1 2 3 4 5 6)
* (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (make-shared-vector v1 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6))
@@ -37289,7 +37502,7 @@ a vector that points to the same elements as the original-vector but with differ
orig = car(args);
if (!s7_is_vector(orig))
- method_or_bust(sc, orig, sc->MAKE_SHARED_VECTOR, args, T_VECTOR, 1);
+ method_or_bust(sc, orig, sc->make_shared_vector_symbol, args, T_VECTOR, 1);
orig_len = vector_length(orig);
@@ -37302,9 +37515,9 @@ a vector that points to the same elements as the original-vector but with differ
offset = s7_integer(off);
if ((offset < 0) ||
(offset >= orig_len)) /* we need this if, for example, offset == 9223372036854775807 */
- return(out_of_range(sc, sc->MAKE_SHARED_VECTOR, small_int(3), off, (offset < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(3), off, (offset < 0) ? its_negative_string : its_too_large_string));
}
- else method_or_bust(sc, off, sc->MAKE_SHARED_VECTOR, args, T_INTEGER, 3);
+ else method_or_bust(sc, off, sc->make_shared_vector_symbol, args, T_INTEGER, 3);
}
dims = cadr(args);
@@ -37312,20 +37525,20 @@ a vector that points to the same elements as the original-vector but with differ
{
if ((s7_integer(dims) < 0) ||
(s7_integer(dims) >= orig_len))
- return(out_of_range(sc, sc->MAKE_SHARED_VECTOR, small_int(2), dims, (s7_integer(dims) < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(2), dims, (s7_integer(dims) < 0) ? its_negative_string : its_too_large_string));
dims = list_1(sc, dims);
}
else
{
if ((is_null(dims)) ||
(!is_proper_list(sc, dims)))
- method_or_bust(sc, dims, sc->MAKE_SHARED_VECTOR, args, T_PAIR, 2);
+ method_or_bust(sc, dims, sc->make_shared_vector_symbol, args, T_PAIR, 2);
for (y = dims; is_pair(y); y = cdr(y))
if ((!s7_is_integer(car(y))) || /* (make-shared-vector v '((1 2) (3 4))) */
(s7_integer(car(y)) > orig_len) ||
(s7_integer(car(y)) < 0))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_1(sc, make_string_wrapper(sc, "a list of integers that fits the original vector"))));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_1(sc, make_string_wrapper(sc, "a list of integers that fits the original vector"))));
}
v = (vdims_t *)malloc(sizeof(vdims_t));
@@ -37353,7 +37566,7 @@ a vector that points to the same elements as the original-vector but with differ
free(v->dims);
free(v->offsets);
free(v);
- return(out_of_range(sc, sc->MAKE_SHARED_VECTOR, small_int(2), dims, make_string_wrapper(sc, "a shared vector has to fit in the original vector")));
+ return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(2), dims, make_string_wrapper(sc, "a shared vector has to fit in the original vector")));
}
new_cell(sc, x, typeflag(orig) | T_SAFE_PROCEDURE);
@@ -37425,7 +37638,7 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice
{
s7_int index = 0;
if (vector_length(vect) == 0)
- return(out_of_range(sc, sc->VECTOR_REF, small_int(1), vect, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(1), vect, its_too_large_string));
if (vector_rank(vect) > 1)
{
@@ -37439,20 +37652,20 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice
if (!s7_is_integer(p))
{
if (!s7_is_integer(p1 = check_values(sc, p, x)))
- method_or_bust(sc, p, sc->VECTOR_REF, cons(sc, vect, indices), T_INTEGER, i + 2);
+ method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, i + 2);
p = p1;
}
n = s7_integer(p);
if ((n < 0) ||
(n >= vector_dimension(vect, i)))
- return(out_of_range(sc, sc->VECTOR_REF, make_integer(sc, i + 2), p, (n < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, make_integer(sc, i + 2), p, (n < 0) ? its_negative_string : its_too_large_string));
index += n * vector_offset(vect, i);
}
if (is_not_null(x))
{
if (type(vect) != T_VECTOR)
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), indices, TOO_MANY_INDICES));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), indices, too_many_indices_string));
return(implicit_index(sc, vector_element(vect, index), x));
}
@@ -37469,18 +37682,18 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice
if (!s7_is_integer(p))
{
if (!s7_is_integer(p1 = check_values(sc, p, indices)))
- method_or_bust(sc, p, sc->VECTOR_REF, cons(sc, vect, indices), T_INTEGER, 2);
+ method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, 2);
p = p1;
}
index = s7_integer(p);
if ((index < 0) ||
(index >= vector_length(vect)))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), p, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string));
if (is_not_null(cdr(indices))) /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */
{
if (type(vect) != T_VECTOR)
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), indices, TOO_MANY_INDICES));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), indices, too_many_indices_string));
return(implicit_index(sc, vector_element(vect, index), cdr(indices)));
}
}
@@ -37491,13 +37704,13 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice
static s7_pointer g_vector_ref(s7_scheme *sc, s7_pointer args)
{
#define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v."
- #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->IS_VECTOR, sc->IS_INTEGER)
+ #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol)
s7_pointer vec;
vec = car(args);
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_REF, args, T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1);
return(vector_ref_1(sc, vec, cdr(args)));
}
@@ -37506,14 +37719,14 @@ static s7_pointer g_vector_ref_ic_n(s7_scheme *sc, s7_pointer args, s7_int index
s7_pointer vec;
vec = find_symbol_checked(sc, car(args));
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_REF, list_2(sc, vec, cadr(args)), T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, cadr(args)), T_VECTOR, 1);
if (index >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
if (vector_rank(vec) > 1)
{
if (index >= vector_dimension(vec, 0))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
}
return(vector_getter(vec)(sc,vec, index));
@@ -37625,19 +37838,19 @@ static s7_pointer g_vector_ref_gs(s7_scheme *sc, s7_pointer args)
x = find_symbol_checked(sc, cadr(args));
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_REF, list_2(sc, vec, x), T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, x), T_VECTOR, 1);
if (!s7_is_integer(x))
- method_or_bust(sc, x, sc->VECTOR_REF, list_2(sc, vec, x), T_INTEGER, 2);
+ method_or_bust(sc, x, sc->vector_ref_symbol, list_2(sc, vec, x), T_INTEGER, 2);
index = s7_integer(x);
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));
if (vector_rank(vec) > 1)
{
if (index >= vector_dimension(vec, 0))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
}
return(vector_getter(vec)(sc, vec, index));
@@ -37654,20 +37867,20 @@ static s7_pointer g_vector_ref_add1(s7_scheme *sc, s7_pointer args)
x = find_symbol_checked(sc, cadr(cadr(args)));
if (!s7_is_integer(x))
- method_or_bust(sc, x, sc->VECTOR_REF, list_2(sc, vec, x), T_INTEGER, 2);
+ method_or_bust(sc, x, sc->vector_ref_symbol, list_2(sc, vec, x), T_INTEGER, 2);
index = s7_integer(x) + 1;
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_REF, list_2(sc, vec, s7_make_integer(sc, index)), T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, s7_make_integer(sc, index)), T_VECTOR, 1);
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));
if (vector_rank(vec) > 1)
{
if (index >= vector_dimension(vec, 0))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
}
return(vector_getter(vec)(sc, vec, index));
@@ -37686,7 +37899,7 @@ static s7_pointer g_constant_vector_ref_gs(s7_scheme *sc, s7_pointer args)
index = s7_integer(x);
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));
return(vector_element(vec, index));
}
@@ -37697,18 +37910,18 @@ static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args)
vec = car(args);
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_REF, args, T_VECTOR, 1); /* should be ok because we go to g_vector_ref below */
+ method_or_bust(sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1); /* should be ok because we go to g_vector_ref below */
if (vector_rank(vec) > 1)
return(g_vector_ref(sc, args));
ind = cadr(args);
if (!s7_is_integer(ind))
- method_or_bust(sc, ind, sc->VECTOR_REF, args, T_INTEGER, 2);
+ method_or_bust(sc, ind, sc->vector_ref_symbol, args, T_INTEGER, 2);
index = s7_integer(ind);
if ((index < 0) || (index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string));
return(vector_getter(vec)(sc, vec, index));
}
@@ -37718,17 +37931,17 @@ static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args)
static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args)
{
#define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value."
- #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->IS_VECTOR, sc->IS_INTEGER, sc->IS_INTEGER_OR_ANY_AT_END)
+ #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)
s7_pointer vec, val;
s7_int index;
vec = car(args);
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_SET, args, T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_set_symbol, args, T_VECTOR, 1);
if (vector_length(_TSet(vec)) == 0)
- return(out_of_range(sc, sc->VECTOR_SET, small_int(1), vec, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(1), vec, its_too_large_string));
if (vector_rank(vec) > 1)
{
@@ -37743,13 +37956,13 @@ static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args)
if (!s7_is_integer(p))
{
if (!s7_is_integer(p1 = check_values(sc, p, x)))
- method_or_bust(sc, p, sc->VECTOR_SET, args, T_INTEGER, i + 2);
+ method_or_bust(sc, p, sc->vector_set_symbol, args, T_INTEGER, i + 2);
p = p1;
}
n = s7_integer(p);
if ((n < 0) ||
(n >= vector_dimension(vec, i)))
- return(out_of_range(sc, sc->VECTOR_SET, make_integer(sc, i + 2), p, (n < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, make_integer(sc, i + 2), p, (n < 0) ? its_negative_string : its_too_large_string));
index += n * vector_offset(vec, i);
}
@@ -37768,13 +37981,13 @@ static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args)
if (!s7_is_integer(p))
{
if (!s7_is_integer(p1 = check_values(sc, p, cdr(args))))
- method_or_bust(sc, p, sc->VECTOR_SET, args, T_INTEGER, 2);
+ method_or_bust(sc, p, sc->vector_set_symbol, args, T_INTEGER, 2);
p = p1;
}
index = s7_integer(p);
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), p, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string));
if (is_not_null(cdddr(args)))
{
@@ -37799,7 +38012,7 @@ static s7_pointer g_vector_set_ic(s7_scheme *sc, s7_pointer args)
vec = find_symbol_checked(sc, car(args));
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_SET, list_3(sc, vec, cadr(args), find_symbol_checked(sc, caddr(args))), T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_set_symbol, list_3(sc, vec, cadr(args), find_symbol_checked(sc, caddr(args))), T_VECTOR, 1);
/* the list_3 happens only if we find the method */
if (vector_rank(vec) > 1)
@@ -37807,7 +38020,7 @@ static s7_pointer g_vector_set_ic(s7_scheme *sc, s7_pointer args)
index = s7_integer(cadr(args));
if (index >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), cadr(args), ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), cadr(args), its_too_large_string));
val = find_symbol_checked(sc, caddr(args));
vector_setter(vec)(sc, vec, index, val);
@@ -37834,11 +38047,11 @@ static s7_pointer g_vector_set_vref(s7_scheme *sc, s7_pointer args)
index1 = s7_integer(val1);
if (index1 >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), val1, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), val1, its_too_large_string));
index2 = s7_integer(val2);
if (index2 >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), val2, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), val2, its_too_large_string));
vector_setter(vec)(sc, vec, index1, val1 = vector_getter(vec)(sc, vec, index2));
return(val1);
@@ -37866,7 +38079,7 @@ static s7_pointer g_vector_set_vector_ref(s7_scheme *sc, s7_pointer args)
index1 = s7_integer(val);
if (index1 >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), val, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), val, its_too_large_string));
if (val2 != cadr(args))
{
@@ -37875,18 +38088,18 @@ static s7_pointer g_vector_set_vector_ref(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
if (!s7_is_integer(p = check_values(sc, val2, list_1(sc, val2))))
- return(wrong_type_argument(sc, sc->VECTOR_REF, 2, val2, T_INTEGER));
+ return(wrong_type_argument(sc, sc->vector_ref_symbol, 2, val2, T_INTEGER));
else val2 = p;
}
index2 = s7_integer(val2);
if (index2 >= vector_length(vec))
- return(out_of_range(sc, sc->VECTOR_REF, small_int(2), val, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), val, its_too_large_string));
}
else index2 = index1;
- car(sc->Z2_1) = vector_getter(vec)(sc, vec, index2);
- car(sc->Z2_2) = tc;
- vector_setter(vec)(sc, vec, index1, tc = c_call(arg3)(sc, sc->Z2_1));
+ car(sc->z2_1) = vector_getter(vec)(sc, vec, index2);
+ car(sc->z2_2) = tc;
+ vector_setter(vec)(sc, vec, index1, tc = c_call(arg3)(sc, sc->z2_1));
return(tc);
}
@@ -37895,14 +38108,14 @@ static s7_pointer c_vector_set_3(s7_scheme *sc, s7_pointer vec, s7_int index, s7
/* (vector-set! vec ind val) where are all predigested */
if (!s7_is_vector(vec))
- method_or_bust(sc, vec, sc->VECTOR_SET, list_3(sc, vec, make_integer(sc, index), val), T_VECTOR, 1);
+ method_or_bust(sc, vec, sc->vector_set_symbol, list_3(sc, vec, make_integer(sc, index), val), T_VECTOR, 1);
if (vector_rank(vec) > 1)
return(g_vector_set(sc, list_3(sc, vec, make_integer(sc, index), val)));
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));
vector_setter(vec)(sc, vec, index, val);
return(val);
@@ -37913,7 +38126,7 @@ static s7_pointer c_vector_set_s(s7_scheme *sc, s7_pointer vec, s7_int index, s7
/* (vector-set! vec ind val) where are all predigested, vector is prechecked */
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, sc->VECTOR_SET, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));
vector_elements(vec)[index] = val;
return(val);
@@ -37928,7 +38141,7 @@ static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
if (!s7_is_integer(p = check_values(sc, ind, cdr(args))))
- return(wrong_type_argument(sc, sc->VECTOR_SET, 2, ind, T_INTEGER));
+ return(wrong_type_argument(sc, sc->vector_set_symbol, 2, ind, T_INTEGER));
else ind = p;
}
return(c_vector_set_3(sc, car(args), s7_integer(ind), caddr(args)));
@@ -37939,32 +38152,32 @@ PIPF_TO_PF(vector_set, c_vector_set_s, c_vector_set_3, c_vector_tester)
static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_make_vector "(make-vector len (value #f) (homogenous #f)) returns a vector of len elements initialized to value. \
+ #define H_make_vector "(make-vector len (value #f) (homogeneous #f)) returns a vector of len elements initialized to value. \
To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \
(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \
-returns a 2 dimensional vector of 6 total elements, all initialized to 1.0. If homogenous is #t, and value is either an integer \
+returns a 2 dimensional vector of 6 total elements, all initialized to 1.0. If homogeneous is #t, and value is either an integer \
or a real, the vector can only hold numbers of that type (s7_int or s7_double)."
- #define Q_make_vector s7_make_signature(sc, 4, sc->IS_VECTOR, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_PAIR), sc->T, sc->IS_BOOLEAN)
+ #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, sc->is_boolean_symbol)
s7_int len;
s7_pointer x, fill, vec;
int result_type = T_VECTOR;
- fill = sc->UNSPECIFIED;
+ fill = sc->unspecified;
x = car(args);
if (s7_is_integer(x))
{
len = s7_integer(x);
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, 1, x, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, x, a_non_negative_integer_string));
}
else
{
if (!(is_pair(x)))
- method_or_bust_with_type(sc, x, sc->MAKE_VECTOR, args, make_string_wrapper(sc, "an integer or a list of integers"), 1);
+ method_or_bust_with_type(sc, x, sc->make_vector_symbol, args, make_string_wrapper(sc, "an integer or a list of integers"), 1);
if (!s7_is_integer(car(x)))
- return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, 1, car(x),
+ return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, car(x),
make_string_wrapper(sc, "each dimension should be an integer")));
if (is_null(cdr(x)))
len = s7_integer(car(x));
@@ -37975,17 +38188,17 @@ or a real, the vector can only hold numbers of that type (s7_int or s7_double)."
dims = s7_list_length(sc, x);
if (dims <= 0) /* 0 if circular, negative if dotted */
- return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, 1, x, A_PROPER_LIST));
+ return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, x, a_proper_list_string));
if (dims > sc->max_vector_dimensions)
- return(out_of_range(sc, sc->MAKE_VECTOR, small_int(1), x, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_vector_symbol, small_int(1), x, its_too_large_string));
for (len = 1, y = x; is_not_null(y); y = cdr(y))
{
if (!s7_is_integer(car(y)))
- return(wrong_type_argument(sc, sc->MAKE_VECTOR, position_of(y, x), car(y), T_INTEGER));
+ return(wrong_type_argument(sc, sc->make_vector_symbol, position_of(y, x), car(y), T_INTEGER));
len *= s7_integer(car(y));
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, position_of(y, x), car(y), A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, position_of(y, x), car(y), a_non_negative_integer_string));
}
}
}
@@ -38004,13 +38217,13 @@ or a real, the vector can only hold numbers of that type (s7_int or s7_double)."
{
if (s7_is_real(fill)) /* might be gmp with big_real by accident (? see above) */
result_type = T_FLOAT_VECTOR;
- else method_or_bust_with_type(sc, fill, sc->MAKE_VECTOR, args, make_string_wrapper(sc, "an integer or a real since 'homogenous' is #t"), 2);
+ else method_or_bust_with_type(sc, fill, sc->make_vector_symbol, args, make_string_wrapper(sc, "an integer or a real since 'homogeneous' is #t"), 2);
}
}
else
{
if (caddr(args) != sc->F)
- method_or_bust_with_type(sc, caddr(args), sc->MAKE_VECTOR, args, A_BOOLEAN, 3);
+ method_or_bust_with_type(sc, caddr(args), sc->make_vector_symbol, args, a_boolean_string, 3);
}
}
}
@@ -38053,7 +38266,7 @@ IF_TO_PF(make_vector, s7_make_vector)
static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
{
#define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector."
- #define Q_make_float_vector s7_make_signature(sc, 3, sc->IS_FLOAT_VECTOR, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_PAIR), sc->IS_REAL)
+ #define Q_make_float_vector s7_make_signature(sc, 3, sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol)
s7_int len;
s7_pointer x, p;
s7_double *arr;
@@ -38067,7 +38280,7 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
{
init = cadr(args);
if (!s7_is_real(init))
- method_or_bust(sc, init, sc->MAKE_FLOAT_VECTOR, args, T_REAL, 2);
+ method_or_bust(sc, init, sc->make_float_vector_symbol, args, T_REAL, 2);
#if WITH_GMP
if (s7_is_bignum(init))
return(g_make_vector(sc, set_plist_3(sc, p, make_real(sc, real_to_double(sc, init, "make-float-vector")), sc->T)));
@@ -38081,9 +38294,9 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
len = s7_integer(p);
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->MAKE_FLOAT_VECTOR, 1, p, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->make_float_vector_symbol, 1, p, a_non_negative_integer_string));
if (len > sc->max_vector_length)
- return(out_of_range(sc, sc->MAKE_FLOAT_VECTOR, small_int(1), p, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_float_vector_symbol, small_int(1), p, its_too_large_string));
if (len > 0)
arr = (s7_double *)calloc(len, sizeof(s7_double));
@@ -38107,7 +38320,7 @@ IF_TO_PF(make_float_vector, c_make_float_vector)
static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
{
#define H_make_int_vector "(make-int-vector len (init 0.0)) returns an int-vector."
- #define Q_make_int_vector s7_make_signature(sc, 3, sc->IS_INT_VECTOR, s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_PAIR), sc->IS_INTEGER)
+ #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol)
s7_int len;
s7_pointer x, p;
@@ -38122,7 +38335,7 @@ static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
{
init = cadr(args);
if (!is_integer(init))
- method_or_bust(sc, init, sc->MAKE_INT_VECTOR, args, T_INTEGER, 2);
+ method_or_bust(sc, init, sc->make_int_vector_symbol, args, T_INTEGER, 2);
}
else init = small_int(0);
return(g_make_vector(sc, set_plist_3(sc, p, init, sc->T)));
@@ -38130,9 +38343,9 @@ static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
len = s7_integer(p);
if (len < 0)
- return(wrong_type_argument_with_type(sc, sc->MAKE_INT_VECTOR, 1, p, A_NON_NEGATIVE_INTEGER));
+ return(wrong_type_argument_with_type(sc, sc->make_int_vector_symbol, 1, p, a_non_negative_integer_string));
if (len > sc->max_vector_length)
- return(out_of_range(sc, sc->MAKE_INT_VECTOR, small_int(1), p, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->make_int_vector_symbol, small_int(1), p, its_too_large_string));
if (len > 0)
arr = (s7_int *)calloc(len, sizeof(s7_int));
@@ -38157,7 +38370,7 @@ static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args)
{
#define H_is_vector "(vector? obj) returns #t if obj is a vector"
#define Q_is_vector pl_bt
- check_boolean_method(sc, s7_is_vector, sc->IS_VECTOR, args);
+ check_boolean_method(sc, s7_is_vector, sc->is_vector_symbol, args);
}
@@ -38172,21 +38385,21 @@ static s7_pointer g_vector_dimensions(s7_scheme *sc, s7_pointer args)
#define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions. In srfi-63 terms:\n\
(define array-dimensions vector-dimensions)\n\
(define (array-rank v) (length (vector-dimensions v)))"
- #define Q_vector_dimensions s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_VECTOR)
+ #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol)
s7_pointer x;
x = car(args);
if (!s7_is_vector(x))
- method_or_bust(sc, x, sc->VECTOR_DIMENSIONS, args, T_VECTOR, 0);
+ method_or_bust(sc, x, sc->vector_dimensions_symbol, args, T_VECTOR, 0);
if (vector_rank(x) > 1)
{
int i;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = vector_ndims(x) - 1; i >= 0; i--)
sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w);
x = sc->w;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(x);
}
return(list_1(sc, make_integer(sc, vector_length(x))));
@@ -38229,7 +38442,7 @@ static int traverse_vector_data(s7_scheme *sc, s7_pointer vec, int flat_ref, int
static s7_pointer s7_multivector_error(s7_scheme *sc, const char *message, s7_pointer data)
{
- return(s7_error(sc, sc->READ_ERROR,
+ return(s7_error(sc, sc->read_error_symbol,
set_elist_3(sc, make_string_wrapper(sc, "reading constant vector, ~A: ~A"), make_string_wrapper(sc, message), data)));
}
@@ -38260,7 +38473,7 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
if (dims > sc->max_vector_dimensions)
return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, make_integer(sc, dims), "must be < 512")); /* sc->max_vector_dimensions=512 currently */
- sc->w = sc->NIL;
+ sc->w = sc->nil;
if (is_null(data)) /* dims are already 0 (calloc above) */
return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, small_int(0)))));
@@ -38280,7 +38493,7 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
vec = g_make_vector(sc, set_plist_1(sc, sc->w = safe_reverse_in_place(sc, sc->w)));
vec_loc = s7_gc_protect(sc, vec);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
/* now fill the vector checking that all the lists match */
err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data);
@@ -38294,15 +38507,6 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
}
-static s7_pointer g_qq_multivector(s7_scheme *sc, s7_pointer args)
-{
- /* `#2d((1 2) ,(list 3 4)) */
- #define H_qq_multivector "quasiquote internal support for multidimensional vector constants"
- #define Q_qq_multivector s7_make_signature(sc, 2, sc->IS_VECTOR, sc->T)
- return(g_multivector(sc, s7_integer(car(args)), cdr(args)));
-}
-
-
s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect)
{
s7_int len;
@@ -38348,7 +38552,7 @@ static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, bool flt)
s7_int ind;
int typ;
- caller = (flt) ? sc->FLOAT_VECTOR_REF : sc->INT_VECTOR_REF;
+ caller = (flt) ? sc->float_vector_ref_symbol : sc->int_vector_ref_symbol;
typ = (flt) ? T_FLOAT_VECTOR : T_INT_VECTOR;
v = car(args);
@@ -38368,9 +38572,9 @@ static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, bool flt)
}
ind = s7_integer(index);
if ((ind < 0) || (ind >= vector_length(v)))
- return(simple_out_of_range(sc, caller, index, (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, caller, index, (ind < 0) ? its_negative_string : its_too_large_string));
if (!is_null(cddr(args)))
- return(out_of_range(sc, caller, small_int(2), cdr(args), TOO_MANY_INDICES));
+ return(out_of_range(sc, caller, small_int(2), cdr(args), too_many_indices_string));
}
else
{
@@ -38390,12 +38594,12 @@ static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, bool flt)
else n = s7_integer(car(x));
if ((n < 0) ||
(n >= vector_dimension(v, i)))
- return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? its_negative_string : its_too_large_string));
ind += n * vector_offset(v, i);
}
if (is_not_null(x))
- return(out_of_range(sc, caller, small_int(2), cdr(args), TOO_MANY_INDICES));
+ return(out_of_range(sc, caller, small_int(2), cdr(args), too_many_indices_string));
/* if not enough indices, return a shared vector covering whatever is left */
if (i < vector_ndims(v))
@@ -38413,7 +38617,7 @@ static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, bool flt)
s7_int index;
int typ;
- caller = (flt) ? sc->FLOAT_VECTOR_SET : sc->INT_VECTOR_SET;
+ caller = (flt) ? sc->float_vector_set_symbol : sc->int_vector_set_symbol;
typ = (flt) ? T_FLOAT_VECTOR : T_INT_VECTOR;
vec = car(args);
@@ -38438,7 +38642,7 @@ static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, bool flt)
else n = s7_integer(car(x));
if ((n < 0) ||
(n >= vector_dimension(vec, i)))
- return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? its_negative_string : its_too_large_string));
index += n * vector_offset(vec, i);
}
@@ -38462,7 +38666,7 @@ static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, bool flt)
else index = s7_integer(cadr(args));
if ((index < 0) ||
(index >= vector_length(vec)))
- return(out_of_range(sc, caller, small_int(2), cadr(args), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE));
+ return(out_of_range(sc, caller, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));
if (is_not_null(cdddr(args)))
return(s7_wrong_number_of_args_error(sc, "too many args: ~S", args));
@@ -38489,7 +38693,7 @@ static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, bool flt)
static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args)
{
#define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v."
- #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, sc->IS_FLOAT, sc->IS_FLOAT_VECTOR, sc->IS_INTEGER)
+ #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol)
return(univect_ref(sc, args, true));
}
@@ -38497,21 +38701,21 @@ static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args)
static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args)
{
#define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value."
- #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, sc->IS_REAL, sc->IS_FLOAT_VECTOR, sc->IS_INTEGER, sc->IS_INTEGER_OR_REAL_AT_END)
+ #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol)
return(univect_set(sc, args, true));
}
static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args)
{
#define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v."
- #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, sc->IS_INTEGER, sc->IS_INT_VECTOR, sc->IS_INTEGER)
+ #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
return(univect_ref(sc, args, false));
}
static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args)
{
#define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value."
- #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->IS_INTEGER, sc->IS_INT_VECTOR, sc->IS_INTEGER)
+ #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
return(univect_set(sc, args, false));
}
@@ -38525,11 +38729,11 @@ static s7_int int_vector_ref_if_a(s7_scheme *sc, s7_pointer **p)
s7_int y;
x = (**p); (*p)++;
if (!is_int_vector(x))
- wrong_type_argument(sc, sc->INT_VECTOR_REF, 1, x, T_INT_VECTOR);
+ wrong_type_argument(sc, sc->int_vector_ref_symbol, 1, x, T_INT_VECTOR);
xf = (s7_if_t)(**p); (*p)++;
y = xf(sc, p);
if ((y < 0) || (y >= vector_length(x)))
- out_of_range(sc, sc->INT_VECTOR_REF, small_int(2), make_integer(sc, y), (y < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->int_vector_ref_symbol, small_int(2), make_integer(sc, y), (y < 0) ? its_negative_string : its_too_large_string);
return(int_vector_elements(x)[y]);
}
@@ -38569,11 +38773,11 @@ static s7_int int_vector_set_if_a(s7_scheme *sc, s7_pointer **p)
s7_int y, z;
x = (**p); (*p)++;
if (!is_int_vector(x))
- wrong_type_argument(sc, sc->INT_VECTOR_SET, 1, x, T_INT_VECTOR);
+ wrong_type_argument(sc, sc->int_vector_set_symbol, 1, x, T_INT_VECTOR);
xf = (s7_if_t)(**p); (*p)++;
y = xf(sc, p);
if ((y < 0) || (y >= vector_length(x)))
- out_of_range(sc, sc->INT_VECTOR_SET, small_int(2), make_integer(sc, y), (y < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->int_vector_set_symbol, small_int(2), make_integer(sc, y), (y < 0) ? its_negative_string : its_too_large_string);
xf = (s7_if_t)(**p); (*p)++;
z = xf(sc, p);
int_vector_elements(x)[y] = z;
@@ -38616,10 +38820,10 @@ static s7_double fv_set_rf_checked(s7_scheme *sc, s7_pointer **p)
fv = **p; (*p)++;
ind = slot_value(**p); (*p)++;
if (!is_integer(ind))
- wrong_type_argument(sc, sc->FLOAT_VECTOR_SET, 2, ind, T_INTEGER);
+ wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
index = integer(ind);
if ((index < 0) || (index >= vector_length(fv)))
- out_of_range(sc, sc->FLOAT_VECTOR_SET, small_int(2), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
rf = (s7_rf_t)(**p); (*p)++;
val = rf(sc, p);
float_vector_element(fv, index) = val;
@@ -38634,10 +38838,10 @@ static s7_double fv_set_rf_r(s7_scheme *sc, s7_pointer **p)
fv = **p; (*p)++;
ind = slot_value(**p); (*p)++;
if (!is_integer(ind))
- wrong_type_argument(sc, sc->FLOAT_VECTOR_SET, 2, ind, T_INTEGER);
+ wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
index = integer(ind);
if ((index < 0) || (index >= vector_length(fv)))
- out_of_range(sc, sc->FLOAT_VECTOR_SET, small_int(2), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
x = **p; (*p)++;
val = real_to_double(sc, x, "float-vector-set!");
float_vector_element(fv, index) = val;
@@ -38652,10 +38856,10 @@ static s7_double fv_set_rf_s(s7_scheme *sc, s7_pointer **p)
fv = **p; (*p)++;
ind = slot_value(**p); (*p)++;
if (!is_integer(ind))
- wrong_type_argument(sc, sc->FLOAT_VECTOR_SET, 2, ind, T_INTEGER);
+ wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
index = integer(ind);
if ((index < 0) || (index >= vector_length(fv)))
- out_of_range(sc, sc->FLOAT_VECTOR_SET, small_int(2), ind, (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
x = slot_value(**p); (*p)++;
val = real_to_double(sc, x, "float-vector-set!");
float_vector_element(fv, index) = val;
@@ -38689,7 +38893,7 @@ static s7_double fv_set_rf_if(s7_scheme *sc, s7_pointer **p)
xf = (s7_if_t)(**p); (*p)++;
index = xf(sc, p);
if ((index < 0) || (index >= vector_length(fv)))
- out_of_range(sc, sc->FLOAT_VECTOR_SET, small_int(2), make_integer(sc, index), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string);
rf = (s7_rf_t)(**p); (*p)++;
val = rf(sc, p);
float_vector_element(fv, index) = val;
@@ -38775,7 +38979,7 @@ static s7_double fv_ref_rf_ss(s7_scheme *sc, s7_pointer **p)
s2 = slot_value(**p); (*p)++;
ind = s7_integer(s2);
if ((ind < 0) || (ind >= vector_length(s1)))
- out_of_range(sc, sc->FLOAT_VECTOR_REF, small_int(2), s2, (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), s2, (ind < 0) ? its_negative_string : its_too_large_string);
return(float_vector_elements(s1)[ind]);
}
@@ -38787,7 +38991,7 @@ static s7_double fv_ref_rf_si(s7_scheme *sc, s7_pointer **p)
s2 = (**p); (*p)++;
ind = s7_integer(s2);
if ((ind < 0) || (ind >= vector_length(s1)))
- out_of_range(sc, sc->FLOAT_VECTOR_REF, small_int(2), s2, (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), s2, (ind < 0) ? its_negative_string : its_too_large_string);
return(float_vector_elements(s1)[ind]);
}
@@ -38800,7 +39004,7 @@ static s7_double fv_ref_rf_sx(s7_scheme *sc, s7_pointer **p)
i1 = (s7_if_t)(**p); (*p)++;
ind = i1(sc, p);
if ((ind < 0) || (ind >= vector_length(s1)))
- out_of_range(sc, sc->FLOAT_VECTOR_REF, small_int(2), make_integer(sc, ind), (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string);
return(float_vector_elements(s1)[ind]);
}
@@ -38813,11 +39017,11 @@ static s7_double fv_ref_rf_pf(s7_scheme *sc, s7_pointer **p)
fv = (s7_pf_t)(**p); (*p)++;
s1 = fv(sc, p);
if (!is_float_vector(s1))
- wrong_type_argument(sc, sc->FLOAT_VECTOR_REF, 1, s1, T_FLOAT_VECTOR);
+ wrong_type_argument(sc, sc->float_vector_ref_symbol, 1, s1, T_FLOAT_VECTOR);
i1 = (s7_if_t)(**p); (*p)++;
ind = i1(sc, p);
if ((ind < 0) || (ind >= vector_length(s1)))
- out_of_range(sc, sc->FLOAT_VECTOR_REF, small_int(2), make_integer(sc, ind), (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string);
return(float_vector_elements(s1)[ind]);
}
@@ -38970,7 +39174,11 @@ static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
p = car(x);
if (is_global(p)) p = slot_value(global_slot(p)); else p = find_symbol_unchecked(sc, p);
- /* this is nearly always global and p == opt_cfunc(x) */
+ /* this is nearly always global and p == opt_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 == opt_any1(x)) ||
((is_any_c_function(p)) && (opt_cfunc(x)) &&
(c_function_class(p) == c_function_class(opt_cfunc(x)))));
@@ -38986,7 +39194,7 @@ static bool arglist_has_rest(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
- if (car(p) == sc->KEY_REST)
+ if (car(p) == sc->key_rest_symbol)
return(true);
return(false);
}
@@ -39105,7 +39313,7 @@ static int closure_compare_begin(const void *v1, const void *v2)
static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
{
#define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements."
- #define Q_sort s7_make_signature(sc, 3, sc->T, sc->IS_SEQUENCE, sc->IS_PROCEDURE)
+ #define Q_sort s7_make_signature(sc, 3, sc->T, sc->is_sequence_symbol, sc->is_procedure_symbol)
s7_pointer data, lessp, lx;
s7_int len = 0, n, k;
@@ -39123,24 +39331,24 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
/* (apply sort! () #f) should be an error I think */
lessp = cadr(args);
if (type(lessp) < T_GOTO)
- method_or_bust_with_type(sc, lessp, sc->SORT, args, A_PROCEDURE, 2);
+ method_or_bust_with_type(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2);
if (!s7_is_aritable(sc, lessp, 2))
- return(wrong_type_argument_with_type(sc, sc->SORT, 2, lessp, AN_EQ_FUNC));
- return(sc->NIL);
+ return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, an_eq_func_string));
+ return(sc->nil);
}
lessp = cadr(args);
if (type(lessp) < T_GOTO)
- method_or_bust_with_type(sc, lessp, sc->SORT, args, A_PROCEDURE, 2);
+ method_or_bust_with_type(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2);
if (!s7_is_aritable(sc, lessp, 2))
- return(wrong_type_argument_with_type(sc, sc->SORT, 2, lessp, AN_EQ_FUNC));
+ return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, an_eq_func_string));
if ((is_continuation(lessp)) || is_goto(lessp))
- return(wrong_type_argument_with_type(sc, sc->SORT, 2, lessp, A_NORMAL_PROCEDURE));
+ return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, a_normal_procedure_string));
sort_func = vector_compare;
compare_func = NULL;
- compare_args = sc->T2_1;
+ compare_args = sc->t2_1;
compare_sc = sc;
if ((is_safe_procedure(lessp)) && /* (sort! a <) */
@@ -39150,8 +39358,8 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
sig = c_function_signature(lessp);
if ((sig) &&
(is_pair(sig)) &&
- (car(sig) != sc->IS_BOOLEAN))
- return(wrong_type_argument_with_type(sc, sc->SORT, 2, lessp, make_string_wrapper(sc, "sort! function should return a boolean")));
+ (car(sig) != sc->is_boolean_symbol))
+ return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, make_string_wrapper(sc, "sort! function should return a boolean")));
compare_func = c_function_call(lessp);
}
else
@@ -39251,7 +39459,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
if (len <= 0)
{
if (sort_func == pf_compare) s7_xf_free(sc);
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "sort! argument 1 should be a proper list: ~S"), data)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "sort! argument 1 should be a proper list: ~S"), data)));
}
if (len < 2)
{
@@ -39416,7 +39624,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
return(data);
}
- push_stack(sc, OP_SORT_VECTOR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original homogenous vector and func */
+ push_stack(sc, OP_SORT_VECTOR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original homogeneous vector and func */
car(args) = vec;
s7_gc_unprotect_at(sc, gc_loc);
}
@@ -39467,7 +39675,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
break;
default:
- method_or_bust_with_type(sc, data, sc->SORT, args, A_SEQUENCE, 1);
+ method_or_bust_with_type(sc, data, sc->sort_symbol, args, a_sequence_string, 1);
}
if (sort_func == pf_compare) s7_xf_free(sc);
@@ -39623,7 +39831,7 @@ static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args)
{
#define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table"
#define Q_is_hash_table pl_bt
- check_boolean_method(sc, is_hash_table, sc->IS_HASH_TABLE, args);
+ check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args);
}
@@ -39631,17 +39839,17 @@ static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args)
static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj"
- #define Q_hash_table_entries s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_HASH_TABLE)
+ #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol)
if (!is_hash_table(car(args)))
- method_or_bust(sc, car(args), sc->HASH_TABLE_ENTRIES, args, T_HASH_TABLE, 0);
+ method_or_bust(sc, car(args), sc->hash_table_entries_symbol, args, T_HASH_TABLE, 0);
return(make_integer(sc, hash_table_entries(car(args))));
}
static s7_int c_hash_table_entries(s7_scheme *sc, s7_pointer p)
{
if (!is_hash_table(p))
- int_method_or_bust(sc, p, sc->HASH_TABLE_ENTRIES, set_plist_1(sc, p), T_HASH_TABLE, 0);
+ int_method_or_bust(sc, p, sc->hash_table_entries_symbol, set_plist_1(sc, p), T_HASH_TABLE, 0);
return(hash_table_entries(p));
}
@@ -39820,8 +40028,8 @@ static unsigned int hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_poin
{
s7_function f;
f = c_function_call(hash_table_procedures_mapper(table));
- car(sc->T1_1) = key;
- return(integer(f(sc, sc->T1_1)));
+ car(sc->t1_1) = key;
+ return(integer(f(sc, sc->t1_1)));
}
static unsigned int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key)
@@ -40140,11 +40348,11 @@ static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer
hash_len = hash_table_mask(table);
loc = hash_loc(sc, table, key) & hash_len;
- car(sc->T2_1) = key;
+ car(sc->t2_1) = key;
for (x = hash_table_element(table, loc); x; x = x->next)
{
- car(sc->T2_2) = x->key;
- if (is_true(sc, f(sc, sc->T2_1)))
+ car(sc->t2_2) = x->key;
+ if (is_true(sc, f(sc, sc->t2_1)))
return(x);
}
return(NULL);
@@ -40344,7 +40552,7 @@ static s7_pointer g_is_morally_equal(s7_scheme *sc, s7_pointer args);
static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
{
#define H_make_hash_table "(make-hash-table (size 511) eq-func) returns a new hash table"
- #define Q_make_hash_table s7_make_signature(sc, 3, sc->IS_HASH_TABLE, sc->IS_INTEGER, sc->IS_PAIR)
+ #define Q_make_hash_table s7_make_signature(sc, 3, sc->is_hash_table_symbol, sc->is_integer_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_pair_symbol))
s7_int size;
size = sc->default_hash_table_length;
@@ -40357,14 +40565,14 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
{
s7_pointer p1;
if (!s7_is_integer(p1 = check_values(sc, p, args)))
- method_or_bust(sc, p, sc->MAKE_HASH_TABLE, args, T_INTEGER, 1);
+ method_or_bust(sc, p, sc->make_hash_table_symbol, args, T_INTEGER, 1);
p = p1;
}
size = s7_integer(p);
if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */
- return(simple_out_of_range(sc, sc->MAKE_HASH_TABLE, p, make_string_wrapper(sc, "should be a positive integer")));
+ return(simple_out_of_range(sc, sc->make_hash_table_symbol, p, make_string_wrapper(sc, "should be a positive integer")));
if (size > sc->max_vector_length)
- return(simple_out_of_range(sc, sc->MAKE_HASH_TABLE, p, ITS_TOO_LARGE));
+ return(simple_out_of_range(sc, sc->make_hash_table_symbol, p, its_too_large_string));
if (is_not_null(cdr(args)))
{
@@ -40374,7 +40582,7 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
if (is_c_function(proc))
{
if (!s7_is_aritable(sc, proc, 2))
- return(wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, 3, proc, AN_EQ_FUNC));
+ return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, an_eq_func_string));
ht = s7_make_hash_table(sc, size);
if (c_function_call(proc) == g_is_equal)
@@ -40440,7 +40648,7 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
hash_table_checker(ht) = hash_morally_equal;
hash_table_mapper(ht) = morally_equal_hash_map;
}
- else return(wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, 3, proc,
+ else return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc,
make_string_wrapper(sc, "a hash function")));
}}}}}
#if (!WITH_PURE_S7)
@@ -40469,8 +40677,8 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
sig = c_function_signature(checker);
if ((sig) &&
(is_pair(sig)) &&
- (car(sig) != sc->IS_BOOLEAN))
- return(wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, 3, proc,
+ (car(sig) != sc->is_boolean_symbol))
+ return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc,
make_string_wrapper(sc, "equality function should return a boolean")));
hash_table_checker(ht) = hash_c_function;
}
@@ -40480,8 +40688,8 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
sig = c_function_signature(mapper);
if ((sig) &&
(is_pair(sig)) &&
- (car(sig) != sc->IS_INTEGER))
- return(wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, 3, proc,
+ (car(sig) != sc->is_integer_symbol))
+ return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc,
make_string_wrapper(sc, "mapping function should return an integer")));
hash_table_mapper(ht) = c_function_hash_map;
}
@@ -40490,7 +40698,7 @@ static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
return(ht);
}
}
- return(wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, 3, proc,
+ return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc,
make_string_wrapper(sc, "a cons of two functions")));
}
}
@@ -40646,12 +40854,12 @@ s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key)
static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
- #define Q_hash_table_ref s7_make_signature(sc, 3, sc->T, sc->IS_HASH_TABLE, sc->T)
+ #define Q_hash_table_ref s7_make_signature(sc, 3, sc->T, sc->is_hash_table_symbol, sc->T)
s7_pointer table;
table = car(args);
if (!is_hash_table(table))
- method_or_bust(sc, table, sc->HASH_TABLE_REF, args, T_HASH_TABLE, 1);
+ method_or_bust(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, 1);
/*
(define (href H . args)
(if (null? (cdr args))
@@ -40672,7 +40880,7 @@ static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args)
table = car(args);
if (!is_hash_table(table))
- method_or_bust(sc, table, sc->HASH_TABLE_REF, args, T_HASH_TABLE, 1);
+ method_or_bust(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, 1);
x = (*hash_table_checker(table))(sc, table, cadr(args));
if (x) return(x->value);
@@ -40687,7 +40895,7 @@ static s7_pointer g_hash_table_ref_ss(s7_scheme *sc, s7_pointer args)
table = find_symbol_checked(sc, car(args));
if (!is_hash_table(table))
- method_or_bust(sc, table, sc->HASH_TABLE_REF, list_2(sc, table, find_symbol_checked(sc, cadr(args))), T_HASH_TABLE, 1);
+ method_or_bust(sc, table, sc->hash_table_ref_symbol, list_2(sc, table, find_symbol_checked(sc, cadr(args))), T_HASH_TABLE, 1);
x = (*hash_table_checker(table))(sc, table, find_symbol_checked(sc, cadr(args)));
if (x) return(x->value);
@@ -40702,11 +40910,11 @@ static s7_pointer g_hash_table_ref_car(s7_scheme *sc, s7_pointer args)
table = find_symbol_checked(sc, car(args));
if (!is_hash_table(table))
- method_or_bust(sc, table, sc->HASH_TABLE_REF, list_2(sc, table, car(find_symbol_checked(sc, cadadr(args)))), T_HASH_TABLE, 1);
+ method_or_bust(sc, table, sc->hash_table_ref_symbol, list_2(sc, table, car(find_symbol_checked(sc, cadadr(args)))), T_HASH_TABLE, 1);
y = find_symbol_checked(sc, cadadr(args));
if (!is_pair(y))
- return(simple_wrong_type_argument(sc, sc->CAR, y, T_PAIR));
+ return(simple_wrong_type_argument(sc, sc->car_symbol, y, T_PAIR));
x = (*hash_table_checker(table))(sc, table, car(y));
if (x) return(x->value);
@@ -40830,7 +41038,7 @@ s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7
{
if (value == sc->F)
return(remove_from_hash_table(sc, table, key, x));
- x->value = value;
+ x->value = _NFre(value);
}
else
{
@@ -40857,7 +41065,7 @@ s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7
p = hash_free_list;
hash_free_list = p->next;
p->key = key;
- p->value = value;
+ p->value = _NFre(value);
p->raw_hash = raw_hash;
loc = raw_hash & hash_len;
@@ -40969,12 +41177,12 @@ static s7_pf_t hash_table_set_pf(s7_scheme *sc, s7_pointer expr)
static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value"
- #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->IS_HASH_TABLE, sc->T, sc->T)
+ #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T)
s7_pointer table;
table = car(args);
if (!is_hash_table(table))
- method_or_bust(sc, table, sc->HASH_TABLE_SET, args,T_HASH_TABLE, 1);
+ method_or_bust(sc, table, sc->hash_table_set_symbol, args,T_HASH_TABLE, 1);
return(s7_hash_table_set(sc, table, cadr(args), caddr(args)));
}
@@ -40984,7 +41192,7 @@ static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table "(hash-table ...) returns a hash-table containing the cons's passed as its arguments. \
That is, (hash-table '(\"hi\" . 3) (\"ho\" . 32)) returns a new hash-table with the two key/value pairs preinstalled."
- #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->IS_HASH_TABLE, sc->IS_LIST)
+ #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->is_list_symbol)
int len;
s7_pointer x, ht;
@@ -40993,7 +41201,7 @@ That is, (hash-table '(\"hi\" . 3) (\"ho\" . 32)) returns a new hash-table with
for (len = 0, x = args; is_pair(x); x = cdr(x), len++)
if ((!is_pair(car(x))) &&
(!is_null(car(x))))
- return(wrong_type_argument(sc, sc->HASH_TABLE, position_of(x, args), car(x), T_PAIR));
+ return(wrong_type_argument(sc, sc->hash_table_symbol, position_of(x, args), car(x), T_PAIR));
ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length);
if (len > 0)
@@ -41014,14 +41222,14 @@ static s7_pointer g_hash_table_star(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table_star "(hash-table* ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \
That is, (hash-table* 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled."
- #define Q_hash_table_star s7_make_circular_signature(sc, 1, 2, sc->IS_HASH_TABLE, sc->T)
+ #define Q_hash_table_star s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T)
int len;
s7_pointer ht;
len = safe_list_length(sc, args);
if (len & 1)
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_2(sc, make_string_wrapper(sc, "hash-table* got an odd number of arguments: ~S"), args)));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, make_string_wrapper(sc, "hash-table* got an odd number of arguments: ~S"), args)));
len /= 2;
ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length);
@@ -41301,7 +41509,7 @@ static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args)
x = car(args);
if ((!is_procedure(x)) || (is_c_object(x)))
{
- check_method(sc, x, sc->IS_PROCEDURE, args);
+ check_method(sc, x, sc->is_procedure_symbol, args);
return(sc->F);
}
typ = type(x);
@@ -41334,7 +41542,7 @@ s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p)
{
if (has_closure_let(p))
return(closure_body(p));
- return(sc->NIL);
+ return(sc->nil);
}
@@ -41342,7 +41550,7 @@ s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p)
{
if (has_closure_let(p))
return(closure_let(p));
- return(sc->NIL);
+ return(sc->nil);
}
@@ -41350,7 +41558,7 @@ s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p)
{
if (has_closure_let(p))
return(closure_args(p));
- return(sc->NIL);
+ return(sc->nil);
}
@@ -41360,33 +41568,35 @@ static s7_pointer c_procedure_source(s7_scheme *sc, s7_pointer p)
if (is_symbol(p))
{
p = s7_symbol_value(sc, p);
- if (p == sc->UNDEFINED)
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "procedure-source arg, '~S, is unbound"), p)));
+ if (p == sc->undefined)
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "procedure-source arg, '~S, is unbound"), p)));
}
if ((is_c_function(p)) || (is_c_macro(p)))
- return(sc->NIL);
+ return(sc->nil);
- check_method(sc, p, sc->PROCEDURE_SOURCE, list_1(sc, p));
+ check_method(sc, p, sc->procedure_source_symbol, list_1(sc, p));
if (has_closure_let(p))
{
s7_pointer body;
body = closure_body(p);
if (is_safe_closure(body))
clear_safe_closure(body);
- return(append_in_place(sc, list_2(sc, ((is_closure_star(p)) || (is_macro_star(p)) || (is_bacro_star(p))) ? sc->LAMBDA_STAR : sc->LAMBDA, closure_args(p)), body));
+ return(append_in_place(sc, list_2(sc, ((is_closure_star(p)) ||
+ (is_macro_star(p)) ||
+ (is_bacro_star(p))) ? sc->lambda_star_symbol : sc->lambda_symbol,
+ closure_args(p)), body));
}
if (!is_procedure(p))
- return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_SOURCE, p, make_string_wrapper(sc, "a procedure or a macro")));
-
- return(sc->NIL);
+ return(simple_wrong_type_argument_with_type(sc, sc->procedure_source_symbol, p, make_string_wrapper(sc, "a procedure or a macro")));
+ return(sc->nil);
}
static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
{
#define H_procedure_source "(procedure-source func) tries to return the definition of func"
- #define Q_procedure_source s7_make_signature(sc, 2, sc->IS_LIST, sc->IS_PROCEDURE)
+ #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_procedure_symbol)
return(c_procedure_source(sc, car(args)));
}
@@ -41405,7 +41615,7 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args)
{
s7_pointer p, e;
#define H_funclet "(funclet func) tries to return an object's environment"
- #define Q_funclet s7_make_signature(sc, 2, sc->IS_LET, sc->IS_PROCEDURE)
+ #define Q_funclet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_procedure_symbol)
/* this procedure gives direct access to a function's closure -- see s7test.scm
* for some wild examples. At least it provides a not-too-kludgey way for several functions
@@ -41416,13 +41626,13 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args)
if (is_symbol(p))
{
p = s7_symbol_value(sc, p);
- if (p == sc->UNDEFINED)
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "funclet arg, '~S, is unbound"), car(args)))); /* not p here */
+ if (p == sc->undefined)
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "funclet arg, '~S, is unbound"), car(args)))); /* not p here */
}
- check_method(sc, p, sc->FUNCLET, args);
+ check_method(sc, p, sc->funclet_symbol, args);
if (!is_procedure_or_macro(p))
- return(simple_wrong_type_argument_with_type(sc, sc->FUNCLET, p, make_string_wrapper(sc, "a procedure or a macro")));
+ return(simple_wrong_type_argument_with_type(sc, sc->funclet_symbol, p, make_string_wrapper(sc, "a procedure or a macro")));
e = find_let(sc, p);
if ((is_null(e)) &&
@@ -41439,7 +41649,7 @@ s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc,
s7_pointer func, sym;
func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
return(sym);
}
@@ -41451,7 +41661,7 @@ s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function
s7_pointer func, sym;
func = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
return(sym);
}
@@ -41464,7 +41674,7 @@ s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function
s7_pointer func, sym;
func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature);
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
return(sym);
}
@@ -41478,7 +41688,7 @@ static s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *nam
func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
if (signature) c_function_signature(func) = signature;
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
return(sym);
}
@@ -41490,7 +41700,7 @@ s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc,
func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
set_type(func, T_C_MACRO | T_DONT_EVAL_ARGS); /* this used to include T_PROCEDURE */
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
return(sym);
}
@@ -41505,7 +41715,7 @@ static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args)
{
#define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro"
#define Q_is_macro pl_bt
- check_boolean_method(sc, is_any_macro, sc->IS_MACRO, args);
+ check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args);
}
@@ -41522,7 +41732,7 @@ static void define_function_star_1(s7_scheme *sc, const char *name, s7_function
local_args = s7_eval_c_string(sc, internal_arglist);
gc_loc = s7_gc_protect(sc, local_args);
tmpbuf_free(internal_arglist, len);
- n_args = safe_list_length(sc, local_args); /* currently rest arg not supported, and we don't notice :key :allow-other-keys etc */
+ n_args = safe_list_length(sc, local_args); /* currently rest arg not supported, and we don't notice :allow-other-keys etc */
func = s7_make_function(sc, name, fnc, 0, n_args, false, doc);
if (safe)
@@ -41533,7 +41743,7 @@ static void define_function_star_1(s7_scheme *sc, const char *name, s7_function
s7_remove_from_heap(sc, c_function_call_args(func));
sym = make_symbol(sc, name);
- s7_define(sc, sc->NIL, sym, func);
+ s7_define(sc, sc->nil, sym, func);
names = (s7_pointer *)malloc(n_args * sizeof(s7_pointer));
c_function_arg_names(func) = names;
@@ -41577,7 +41787,7 @@ void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function f
}
-s7_pointer set_c_function_call_args(s7_scheme *sc)
+static s7_pointer set_c_function_call_args(s7_scheme *sc)
{
int i, j, n_args;
s7_pointer arg, par, call_args, func;
@@ -41600,7 +41810,7 @@ s7_pointer set_c_function_call_args(s7_scheme *sc)
if (!is_keyword(car(arg)))
{
if (is_checked(par))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(par), sc->args)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(par), sc->args)));
set_checked(par);
car(par) = car(arg);
}
@@ -41611,9 +41821,9 @@ s7_pointer set_c_function_call_args(s7_scheme *sc)
if (df[j] == car(arg))
break;
if (j == n_args)
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "~A: not a parameter name?"), car(arg))));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A: not a parameter name?"), car(arg))));
if (is_checked(p))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(p), sc->args)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(p), sc->args)));
set_checked(p);
arg = cdr(arg);
car(p) = car(arg);
@@ -41621,7 +41831,7 @@ s7_pointer set_c_function_call_args(s7_scheme *sc)
}
if (!is_null(arg))
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, func, sc->args)));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, func, sc->args)));
if (!has_simple_defaults(func))
for (i = 0, par = call_args; i < n_args; i++, par = cdr(par))
@@ -41632,7 +41842,7 @@ s7_pointer set_c_function_call_args(s7_scheme *sc)
else
{
if (is_pair(car(par)))
- car(par) = s7_eval_form(sc, car(par), sc->NIL);
+ car(par) = s7_eval(sc, car(par), sc->nil);
}
}
return(call_args);
@@ -41642,7 +41852,7 @@ s7_pointer set_c_function_call_args(s7_scheme *sc)
/* -------------------------------- procedure-documentation -------------------------------- */
static s7_pointer get_doc(s7_scheme *sc, s7_pointer x)
{
- check_closure_for(sc, x, sc->DOCUMENTATION);
+ check_closure_for(sc, x, sc->documentation_symbol);
return(NULL);
}
@@ -41678,10 +41888,10 @@ static s7_pointer c_procedure_documentation(s7_scheme *sc, s7_pointer p)
p = s7_symbol_value(sc, p);
}
- check_method(sc, p, sc->PROCEDURE_DOCUMENTATION, list_1(sc, p));
+ check_method(sc, p, sc->procedure_documentation_symbol, list_1(sc, p));
if ((!is_procedure(p)) &&
(!s7_is_macro(sc, p)))
- return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_DOCUMENTATION, p, A_PROCEDURE));
+ return(simple_wrong_type_argument_with_type(sc, sc->procedure_documentation_symbol, p, a_procedure_string));
return(s7_make_string(sc, s7_procedure_documentation(sc, p)));
}
@@ -41689,7 +41899,7 @@ static s7_pointer c_procedure_documentation(s7_scheme *sc, s7_pointer p)
static s7_pointer g_procedure_documentation(s7_scheme *sc, s7_pointer args)
{
#define H_procedure_documentation "(procedure-documentation func) returns func's documentation string"
- #define Q_procedure_documentation s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_PROCEDURE)
+ #define Q_procedure_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
return(c_procedure_documentation(sc, car(args)));
}
@@ -41721,10 +41931,10 @@ const char *s7_help(s7_scheme *sc, s7_pointer obj)
static s7_pointer g_help(s7_scheme *sc, s7_pointer args)
{
#define H_help "(help obj) returns obj's documentation"
- #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->IS_STRING, sc->IS_BOOLEAN), sc->T)
+ #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
const char *doc;
- check_method(sc, car(args), sc->HELP, args);
+ check_method(sc, car(args), sc->help_symbol, args);
doc = s7_help(sc, car(args));
if (!doc)
return(sc->F);
@@ -41738,7 +41948,7 @@ PF_TO_PF(help, c_help)
/* -------------------------------- procedure-signature -------------------------------- */
static s7_pointer get_signature(s7_scheme *sc, s7_pointer x)
{
- check_closure_for(sc, x, sc->SIGNATURE);
+ check_closure_for(sc, x, sc->signature_symbol);
return(sc->F);
}
@@ -41755,10 +41965,10 @@ static s7_pointer c_procedure_signature(s7_scheme *sc, s7_pointer p)
if (is_symbol(p))
{
p = s7_symbol_value(sc, p);
- if (p == sc->UNDEFINED)
+ if (p == sc->undefined)
return(sc->F);
}
- check_method(sc, p, sc->PROCEDURE_SIGNATURE, list_1(sc, p));
+ check_method(sc, p, sc->procedure_signature_symbol, list_1(sc, p));
if (!is_procedure(p))
return(sc->F);
@@ -41768,7 +41978,7 @@ static s7_pointer c_procedure_signature(s7_scheme *sc, s7_pointer p)
static s7_pointer g_procedure_signature(s7_scheme *sc, s7_pointer args)
{
#define H_procedure_signature "(procedure-signature func) returns func's signature"
- #define Q_procedure_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->IS_PAIR, sc->IS_BOOLEAN), sc->T)
+ #define Q_procedure_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T)
return(c_procedure_signature(sc, car(args)));
}
@@ -41826,7 +42036,7 @@ static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args)
p = car(args);
if (is_c_object(p))
return(make_integer(sc, c_object_type(p))); /* this is the object_types table index = tag */
- check_method(sc, p, sc->IS_C_OBJECT, args);
+ check_method(sc, p, sc->is_c_object_symbol, args);
return(sc->F);
/* <1> (*s7* 'c-types)
("<random-number-generator>")
@@ -41974,7 +42184,7 @@ s7_pointer s7_make_object(s7_scheme *sc, int type, void *value)
*/
c_object_type(x) = type;
c_object_value(x) = value;
- c_object_set_let(x, sc->NIL);
+ c_object_set_let(x, sc->nil);
add_c_object(sc, x);
return(x);
}
@@ -42034,7 +42244,7 @@ static s7_pointer object_copy(s7_scheme *sc, s7_pointer args)
{
s7_pointer obj;
obj = car(args);
- check_method(sc, obj, sc->COPY, args);
+ check_method(sc, obj, sc->copy_symbol, args);
if (c_object_copy(obj))
return((*(c_object_copy(obj)))(sc, args));
eval_error(sc, "attempt to copy ~S?", obj);
@@ -42062,7 +42272,7 @@ s7_pointer s7_dilambda(s7_scheme *sc,
snprintf(internal_set_name, len, "[set-%s]", name);
get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation);
- s7_define(sc, sc->NIL, make_symbol(sc, name), get_func);
+ s7_define(sc, sc->nil, make_symbol(sc, name), get_func);
set_func = s7_make_function(sc, internal_set_name, setter, set_req_args, set_opt_args, false, documentation);
c_function_setter(get_func) = set_func;
@@ -42099,7 +42309,59 @@ static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args)
{
#define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter."
#define Q_is_dilambda pl_bt
- check_boolean_method(sc, s7_is_dilambda, sc->IS_DILAMBDA, args);
+ check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args);
+}
+
+static s7_pointer c_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter)
+{
+ switch (type(p))
+ {
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ closure_setter(p) = setter;
+ break;
+
+ case T_C_FUNCTION:
+ case T_C_ANY_ARGS_FUNCTION:
+ case T_C_OPT_ARGS_FUNCTION:
+ case T_C_RST_ARGS_FUNCTION:
+ c_function_setter(p) = setter;
+ if (is_any_closure(setter))
+ add_setter(sc, p, setter);
+ break;
+
+ case T_C_FUNCTION_STAR:
+ c_function_setter(p) = setter;
+ if (is_any_closure(setter))
+ add_setter(sc, p, setter);
+ break;
+
+ case T_C_MACRO:
+ if (is_any_closure(setter))
+ add_setter(sc, p, setter);
+ c_macro_setter(p) = setter;
+ break;
+ }
+ return(setter);
+}
+
+static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args)
+{
+ #define H_dilambda "(dilambda getter setter) sets getter's procedure-setter to be setter."
+ #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol)
+ s7_pointer getter, setter;
+
+ getter = car(args);
+ if (!is_any_procedure(getter))
+ return(wrong_type_argument_with_type(sc, sc->dilambda_symbol, 1, getter, make_string_wrapper(sc, "a procedure or macro")));
+
+ setter = cadr(args);
+ if (!is_any_procedure(setter))
+ return(wrong_type_argument_with_type(sc, sc->dilambda_symbol, 2, setter, make_string_wrapper(sc, "a procedure or macro")));
+
+ c_set_setter(sc, getter, setter);
+ return(getter);
}
@@ -42111,11 +42373,10 @@ s7_pointer s7_procedure_setter(s7_scheme *sc, s7_pointer obj)
return(closure_setter(obj));
}
-
static s7_pointer g_procedure_setter(s7_scheme *sc, s7_pointer args)
{
#define H_procedure_setter "(procedure-setter obj) returns the setter associated with obj, or #f"
- #define Q_procedure_setter s7_make_signature(sc, 2, sc->T, sc->IS_PROCEDURE)
+ #define Q_procedure_setter s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol)
s7_pointer p;
p = car(args);
@@ -42153,18 +42414,17 @@ static s7_pointer g_procedure_setter(s7_scheme *sc, s7_pointer args)
return(s7_wrong_type_arg_error(sc, "procedure-setter", 0, p, "a procedure or a reasonable facsimile thereof"));
}
-
static s7_pointer g_procedure_set_setter(s7_scheme *sc, s7_pointer args)
{
s7_pointer p, setter;
p = car(args);
- if (!is_procedure_or_macro(p))
+ if (!is_any_procedure(p))
return(s7_wrong_type_arg_error(sc, "set! procedure-setter procedure", 1, p, "a procedure"));
setter = cadr(args);
if ((setter != sc->F) &&
- (!is_procedure_or_macro(setter)))
+ (!is_any_procedure(setter)))
return(s7_wrong_type_arg_error(sc, "set! procedure-setter setter", 2, setter, "a procedure or #f"));
/* should we check that p != setter?
@@ -42176,43 +42436,7 @@ static s7_pointer g_procedure_set_setter(s7_scheme *sc, s7_pointer args)
* #t
* can this make sense?
*/
-
- switch (type(p))
- {
- case T_MACRO: case T_MACRO_STAR:
- case T_BACRO: case T_BACRO_STAR:
- case T_CLOSURE: case T_CLOSURE_STAR:
- closure_setter(p) = setter;
- break;
-
- case T_C_FUNCTION:
- case T_C_ANY_ARGS_FUNCTION:
- case T_C_OPT_ARGS_FUNCTION:
- case T_C_RST_ARGS_FUNCTION:
- c_function_setter(p) = setter;
- if (is_any_closure(setter))
- add_setter(sc, p, setter);
- break;
-
- case T_C_FUNCTION_STAR:
- c_function_setter(p) = setter;
- if (is_any_closure(setter))
- add_setter(sc, p, setter);
- break;
-
- case T_C_MACRO:
- if (is_any_closure(setter))
- add_setter(sc, p, setter);
- c_macro_setter(p) = setter;
- break;
-
- case T_GOTO:
- return(s7_wrong_type_arg_error(sc, "set! procedure-setter", 1, p, "a normal procedure (not a call-with-exit exit procedure)"));
-
- case T_CONTINUATION:
- return(s7_wrong_type_arg_error(sc, "set! procedure-setter", 1, p, "a normal procedure"));
- }
- return(setter);
+ return(c_set_setter(sc, p, setter));
}
@@ -42222,7 +42446,6 @@ void s7_define_function_with_setter(s7_scheme *sc, const char *name, s7_function
}
-
/* -------------------------------- arity -------------------------------- */
static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
@@ -42260,7 +42483,7 @@ static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args)
{
s7_pointer arg;
arg = car(p);
- if (arg == sc->KEY_REST)
+ if (arg == sc->key_rest_symbol)
break;
i++;
}
@@ -42349,11 +42572,11 @@ s7_pointer s7_arity(s7_scheme *sc, s7_pointer x)
return(sc->F);
case T_LET:
- /* check_method(sc, x, sc->ARITY, args); */
+ /* check_method(sc, x, sc->arity_symbol, args); */
return(s7_cons(sc, small_int(1), small_int(1)));
case T_C_OBJECT:
- /* check_method(sc, x, sc->ARITY, args); */
+ /* check_method(sc, x, sc->arity_symbol, args); */
if (is_procedure(x))
return(s7_cons(sc, small_int(0), max_arity));
return(sc->F);
@@ -42382,7 +42605,7 @@ static s7_pointer g_arity(s7_scheme *sc, s7_pointer args)
{
#define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f."
#define Q_arity pcl_t
- /* check_method(sc, p, sc->ARITY, args); */
+ /* check_method(sc, p, sc->arity_symbol, args); */
return(s7_arity(sc, car(args)));
}
@@ -42461,7 +42684,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args)
(string_length(x) > 0)); /* ("" 0) -> error */
case T_C_OBJECT:
- /* check_method(sc, x, sc->IS_ARITABLE, list_2(sc, x, s7_make_integer(sc, args))); -- see below */
+ /* check_method(sc, x, sc->is_aritable_symbol, list_2(sc, x, s7_make_integer(sc, args))); -- see below */
return(is_procedure(x)); /* i.e. is_applicable */
case T_INT_VECTOR:
@@ -42472,7 +42695,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args)
((unsigned int)args <= vector_rank(x)));
case T_LET:
- /* check_method(sc, x, sc->IS_ARITABLE, list_2(sc, x, s7_make_integer(sc, args))); */
+ /* check_method(sc, x, sc->is_aritable_symbol, list_2(sc, x, s7_make_integer(sc, args))); */
/* this slows us down a lot */
case T_HASH_TABLE:
case T_PAIR:
@@ -42490,18 +42713,18 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args)
static s7_pointer g_is_aritable(s7_scheme *sc, s7_pointer args)
{
#define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments."
- #define Q_is_aritable s7_make_signature(sc, 3, sc->IS_BOOLEAN, sc->T, sc->IS_INTEGER)
+ #define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol)
s7_pointer n;
s7_int num;
n = cadr(args);
if (!s7_is_integer(n)) /* remember gmp case! */
- method_or_bust(sc, n, sc->IS_ARITABLE, args, T_INTEGER, 2);
+ method_or_bust(sc, n, sc->is_aritable_symbol, args, T_INTEGER, 2);
num = s7_integer(n);
if (num < 0)
- return(out_of_range(sc, sc->IS_ARITABLE, small_int(2), n, ITS_NEGATIVE));
+ return(out_of_range(sc, sc->is_aritable_symbol, small_int(2), n, its_negative_string));
if (num > MAX_ARITY) num = MAX_ARITY;
return(make_boolean(sc, s7_is_aritable(sc, car(args), (int)num)));
@@ -42537,7 +42760,7 @@ static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args)
{
#define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)"
#define Q_is_sequence pl_bt
- check_boolean_method(sc, is_simple_sequence, sc->IS_SEQUENCE, args);
+ check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, args);
}
@@ -42555,7 +42778,7 @@ static unsigned int protect_accessor(s7_scheme *sc, s7_pointer acc)
vector_elements(sc->protected_accessors) = (s7_pointer *)realloc(vector_elements(sc->protected_accessors), new_size * sizeof(s7_pointer));
vector_length(sc->protected_accessors) = new_size;
for (i = size; i < new_size; i++)
- vector_element(sc->protected_accessors, i) = sc->GC_NIL;
+ vector_element(sc->protected_accessors, i) = sc->gc_nil;
sc->protected_accessors_size = new_size;
}
loc = sc->protected_accessors_loc++;
@@ -42568,7 +42791,9 @@ s7_pointer s7_symbol_access(s7_scheme *sc, s7_pointer sym)
/* these refer to the rootlet */
if ((is_slot(global_slot(sym))) &&
(slot_has_accessor(global_slot(sym))))
- return(s7_gc_protected_at(sc, symbol_global_accessor_index(sym)));
+ /* return(s7_gc_protected_at(sc, symbol_global_accessor_index(sym))); */ /* 26-Feb-16 */
+ return(vector_element(sc->protected_accessors, symbol_global_accessor_index(sym)));
+
return(sc->F);
}
@@ -42603,12 +42828,12 @@ s7_pointer s7_symbol_set_access(s7_scheme *sc, s7_pointer symbol, s7_pointer fun
static s7_pointer g_symbol_access(s7_scheme *sc, s7_pointer args)
{
#define H_symbol_access "(symbol-access sym (env (curlet))) is the function called when the symbol is set!."
- #define Q_symbol_access s7_make_signature(sc, 3, sc->T, sc->IS_SYMBOL, sc->IS_LET)
+ #define Q_symbol_access s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
s7_pointer sym, p, e;
sym = car(args);
if (!is_symbol(sym))
- method_or_bust(sc, sym, sc->SYMBOL_ACCESS, args, T_SYMBOL, 0);
+ method_or_bust(sc, sym, sc->symbol_access_symbol, args, T_SYMBOL, 0);
if (is_keyword(sym))
return(sc->F);
@@ -42616,12 +42841,12 @@ static s7_pointer g_symbol_access(s7_scheme *sc, s7_pointer args)
{
e = cadr(args);
if (!is_let(e))
- return(wrong_type_argument(sc, sc->SYMBOL_ACCESS, 2, e, T_LET));
+ return(wrong_type_argument(sc, sc->symbol_access_symbol, 2, e, T_LET));
}
else e = sc->envir;
if ((e == sc->rootlet) ||
- (e == sc->NIL))
+ (e == sc->nil))
return(s7_symbol_access(sc, sym));
if (is_null(cdr(args)))
@@ -42631,6 +42856,7 @@ static s7_pointer g_symbol_access(s7_scheme *sc, s7_pointer args)
if ((is_slot(p)) &&
(slot_has_accessor(p)))
return(slot_accessor(p));
+
return(sc->F);
}
@@ -42665,7 +42891,7 @@ static s7_pointer g_symbol_set_access(s7_scheme *sc, s7_pointer args)
return(s7_wrong_type_arg_error(sc, "set! symbol-access", 3, func, "a function or #f"));
if ((e == sc->rootlet) ||
- (e == sc->NIL))
+ (e == sc->nil))
{
if (!is_slot(global_slot(sym)))
return(sc->F);
@@ -42704,18 +42930,18 @@ static s7_pointer bind_accessed_symbol(s7_scheme *sc, opcode_t op, s7_pointer sy
{
s7_pointer old_value;
old_value = new_value;
- car(sc->T2_1) = symbol;
- car(sc->T2_2) = new_value;
- new_value = c_function_call(func)(sc, sc->T2_1);
- if (new_value == sc->ERROR)
- return(s7_error(sc, sc->ERROR, set_elist_3(sc, make_string_wrapper(sc, "can't bind ~S to ~S"), symbol, old_value)));
+ car(sc->t2_1) = symbol;
+ car(sc->t2_2) = new_value;
+ new_value = c_function_call(func)(sc, sc->t2_1);
+ if (new_value == sc->error_symbol)
+ return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't bind ~S to ~S"), symbol, old_value)));
}
else
{
sc->args = list_2(sc, symbol, new_value);
push_stack(sc, op, sc->args, sc->code);
sc->code = func;
- return(sc->NO_VALUE); /* this means the accessor in set! needs to goto APPLY to get the new value */
+ return(sc->no_value); /* this means the accessor in set! needs to goto APPLY to get the new value */
}
}
return(new_value);
@@ -42727,14 +42953,14 @@ static s7_pointer bind_accessed_symbol(s7_scheme *sc, opcode_t op, s7_pointer sy
s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook)
{
- return(s7_symbol_local_value(sc, sc->BODY, closure_let(hook)));
+ return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook)));
}
s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions)
{
if (s7_is_list(sc, functions))
- s7_let_set(sc, closure_let(hook), sc->BODY, functions);
+ s7_let_set(sc, closure_let(hook), sc->body_symbol, functions);
return(functions);
}
@@ -42894,8 +43120,8 @@ static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i
if ((morally) && (has_methods(y)))
{
s7_pointer equal_func;
- equal_func = find_method(sc, find_let(sc, y), sc->IS_MORALLY_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
}
return(false);
@@ -42972,14 +43198,14 @@ static bool let_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci
s7_pointer equal_func;
if (has_methods(x))
{
- equal_func = find_method(sc, find_let(sc, x), sc->IS_MORALLY_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, find_let(sc, x), sc->is_morally_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
}
if (has_methods(y))
{
- equal_func = find_method(sc, find_let(sc, y), sc->IS_MORALLY_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
}
}
@@ -43044,8 +43270,8 @@ static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info
(has_methods(y)))
{
s7_pointer equal_func;
- equal_func = find_method(sc, closure_let(x), (morally) ? sc->IS_MORALLY_EQUAL : sc->IS_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, closure_let(x), (morally) ? sc->is_morally_equal_symbol : sc->is_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
}
/* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y))
@@ -43069,8 +43295,8 @@ static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *c
if ((morally) && (has_methods(y)))
{
s7_pointer equal_func;
- equal_func = find_method(sc, find_let(sc, y), sc->IS_MORALLY_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
}
return(false);
@@ -43131,8 +43357,8 @@ static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info
if ((morally) && (has_methods(y)))
{
s7_pointer equal_func;
- equal_func = find_method(sc, find_let(sc, y), sc->IS_MORALLY_EQUAL);
- if (equal_func != sc->UNDEFINED)
+ equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
+ if (equal_func != sc->undefined)
return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
}
return(false);
@@ -43557,11 +43783,11 @@ static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst)
return(make_integer(sc, hash_table_mask(lst) + 1));
case T_C_OBJECT:
- check_method(sc, lst, sc->LENGTH, list_1(sc, lst));
+ check_method(sc, lst, sc->length_symbol, list_1(sc, lst));
return(object_length(sc, lst));
case T_LET:
- check_method(sc, lst, sc->LENGTH, list_1(sc, lst));
+ check_method(sc, lst, sc->length_symbol, list_1(sc, lst));
return(make_integer(sc, let_length(sc, lst)));
case T_CLOSURE:
@@ -43586,7 +43812,7 @@ static s7_pointer g_length(s7_scheme *sc, s7_pointer args)
#define H_length "(length obj) returns the length of obj, which can be a list, vector, string, or hash-table. \
The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \
list has infinite length. Length of anything else returns #f."
- #define Q_length pcl_t
+ #define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_boolean_symbol), sc->T)
return(s7_length(sc, car(args)));
}
@@ -43627,7 +43853,7 @@ static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_po
#endif
car(sc->elist_3) = copy_to_string_error;
caddr(sc->elist_3) = val;
- return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->elist_3));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}
static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val)
@@ -43638,7 +43864,7 @@ static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc,
byte = s7_integer(val);
if ((byte >= 0) && (byte < 256))
string_value(str)[loc] = (unsigned char)byte;
- else return(simple_wrong_type_argument_with_type(sc, sc->COPY, val, AN_UNSIGNED_BYTE));
+ else return(simple_wrong_type_argument_with_type(sc, sc->copy_symbol, val, an_unsigned_byte_string));
return(val);
}
#if DEBUGGING
@@ -43646,7 +43872,7 @@ static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc,
#endif
car(sc->elist_3) = copy_to_byte_vector_error;
caddr(sc->elist_3) = val;
- return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->elist_3));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}
static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_int loc)
@@ -43661,15 +43887,15 @@ static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer str, s7_int loc)
static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val)
{
- car(sc->T2_1) = make_integer(sc, loc);
- car(sc->T2_2) = val;
- return((*(c_object_set(obj)))(sc, obj, sc->T2_1));
+ car(sc->t2_1) = make_integer(sc, loc);
+ car(sc->t2_2) = val;
+ return((*(c_object_set(obj)))(sc, obj, sc->t2_1));
}
static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_int loc)
{
- car(sc->T1_1) = make_integer(sc, loc);
- return((*(c_object_ref(obj)))(sc, obj, sc->T1_1));
+ car(sc->t1_1) = make_integer(sc, loc);
+ return((*(c_object_ref(obj)))(sc, obj, sc->t1_1));
}
static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val)
@@ -43683,13 +43909,13 @@ static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer
if (!is_pair(val))
{
if (!ls_err) ls_err = s7_make_permanent_string("(cons symbol value)");
- return(wrong_type_argument_with_type(sc, sc->COPY, 3, e, ls_err));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 3, e, ls_err));
}
sym = car(val);
if (!is_symbol(sym))
{
if (!ls_err) ls_err = s7_make_permanent_string("(cons symbol value)");
- return(wrong_type_argument_with_type(sc, sc->COPY, 3, e, ls_err));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 3, e, ls_err));
}
if ((symbol_id(sym) < let_id(e)) ||
(s7_let_set(sc, e, sym, cdr(val)) != cdr(val)))
@@ -43704,7 +43930,7 @@ static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_
* if key is already in e, its value is changed, otherwise a new slot is added to e
*/
if (!is_pair(val))
- return(wrong_type_argument_with_type(sc, sc->COPY, 1, e, A_LIST));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, e, a_list_string));
return(s7_hash_table_set(sc, e, car(val), cdr(val)));
}
@@ -43712,7 +43938,7 @@ static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_
s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
{
#define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end."
- #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->IS_SEQUENCE, sc->IS_SEQUENCE, sc->IS_INTEGER)
+ #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol)
s7_pointer source, dest;
s7_int i, j, dest_len, start, end, source_len;
@@ -43758,13 +43984,13 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
return(iterator_copy(sc, source));
case T_LET:
- check_method(sc, source, sc->COPY, args);
+ check_method(sc, source, sc->copy_symbol, args);
return(let_copy(sc, source)); /* this copies only the local env and points to outer envs */
case T_CLOSURE: case T_CLOSURE_STAR:
case T_MACRO: case T_MACRO_STAR:
case T_BACRO: case T_BACRO_STAR:
- check_method(sc, source, sc->COPY, args);
+ check_method(sc, source, sc->copy_symbol, args);
return(copy_closure(sc, source));
case T_INT_VECTOR:
@@ -43818,7 +44044,7 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
switch (type(source))
{
case T_PAIR:
- if (dest == sc->KEY_READABLE) /* a kludge, but I can't think of anything less stupid */
+ if (dest == sc->key_readable_symbol) /* a kludge, but I can't think of anything less stupid */
return(copy_body(sc, source));
end = s7_list_length(sc, source);
@@ -43849,7 +44075,7 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
break;
case T_C_OBJECT:
- check_method(sc, source, sc->COPY, args);
+ check_method(sc, source, sc->copy_symbol, args);
{
s7_pointer x;
x = object_copy(sc, args);
@@ -43863,9 +44089,9 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
break;
case T_LET:
- check_method(sc, source, sc->COPY, args);
+ check_method(sc, source, sc->copy_symbol, args);
if (source == sc->rootlet)
- return(wrong_type_argument_with_type(sc, sc->COPY, 1, source, make_string_wrapper(sc, "a sequence other than the rootlet")));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, source, make_string_wrapper(sc, "a sequence other than the rootlet")));
end = let_length(sc, source);
break;
@@ -43875,7 +44101,7 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
break;
default:
- return(wrong_type_argument_with_type(sc, sc->COPY, 1, source, A_SEQUENCE));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, source, a_sequence_string));
/* copy doesn't have to duplicate fill!, so (copy 1 #(...)) need not be supported */
}
@@ -43883,8 +44109,8 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
if (have_indices)
{
s7_pointer p;
- p = start_and_end(sc, sc->COPY, NULL, cddr(args), args, 3, &start, &end);
- if (p != sc->GC_NIL) return(p);
+ p = start_and_end(sc, sc->copy_symbol, NULL, cddr(args), args, 3, &start, &end);
+ if (p != sc->gc_nil) return(p);
}
if ((start == 0) && (source == dest))
return(dest);
@@ -43930,16 +44156,16 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
case T_LET:
if (dest == sc->rootlet)
- return(wrong_type_argument_with_type(sc, sc->COPY, 2, dest, make_string_wrapper(sc, "a sequence other than the rootlet")));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 2, dest, make_string_wrapper(sc, "a sequence other than the rootlet")));
set = let_setter;
dest_len = source_len; /* grows via set, so dest_len isn't relevant */
break;
case T_NIL:
- return(sc->NIL);
+ return(sc->nil);
default:
- return(wrong_type_argument_with_type(sc, sc->COPY, 2, dest, A_SEQUENCE));
+ return(wrong_type_argument_with_type(sc, sc->copy_symbol, 2, dest, a_sequence_string));
}
if ((source_len == 0) || (dest_len == 0))
@@ -44003,10 +44229,10 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
{
integer(mi) = i;
integer(mj) = j;
- car(sc->T1_1) = mi;
- car(sc->T2_2) = ref(sc, source, sc->T1_1);
- car(sc->T2_1) = mj;
- set(sc, dest, sc->T2_1);
+ car(sc->t1_1) = mi;
+ car(sc->t2_2) = ref(sc, source, sc->t1_1);
+ car(sc->t2_1) = mj;
+ set(sc, dest, sc->t2_1);
}
s7_gc_unprotect_at(sc, gc_loc1);
s7_gc_unprotect_at(sc, gc_loc2);
@@ -44226,18 +44452,18 @@ static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args)
{
#define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order. reverse \
also accepts a string or vector argument."
- #define Q_reverse s7_make_signature(sc, 2, sc->IS_SEQUENCE, sc->IS_SEQUENCE)
+ #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)
s7_pointer p, np;
p = car(args);
sc->temp3 = p;
- np = sc->NIL;
+ np = sc->nil;
switch (type(p))
{
case T_NIL:
- return(sc->NIL);
+ return(sc->nil);
case T_PAIR:
return(s7_reverse(sc, p));
@@ -44308,13 +44534,13 @@ also accepts a string or vector argument."
return(hash_table_reverse(sc, p));
case T_C_OBJECT:
- check_method(sc, p, sc->REVERSE, args);
+ check_method(sc, p, sc->reverse_symbol, args);
if (c_object_reverse(p))
return((*(c_object_reverse(p)))(sc, args));
eval_error(sc, "attempt to reverse ~S?", p);
default:
- method_or_bust_with_type(sc, p, sc->REVERSE, args, A_SEQUENCE, 0);
+ method_or_bust_with_type(sc, p, sc->reverse_symbol, args, a_sequence_string, 0);
}
return(np);
}
@@ -44327,14 +44553,14 @@ static s7_pointer c_reverse_in_place(s7_scheme *sc, s7_pointer p)
switch (type(p))
{
case T_NIL:
- return(sc->NIL);
+ return(sc->nil);
case T_PAIR:
{
s7_pointer np;
- np = reverse_in_place(sc, sc->NIL, p);
+ np = reverse_in_place(sc, sc->nil, p);
if (is_null(np))
- return(simple_wrong_type_argument_with_type(sc, sc->REVERSEB, p, A_PROPER_LIST));
+ return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, a_proper_list_string));
return(np);
}
break;
@@ -44342,7 +44568,7 @@ static s7_pointer c_reverse_in_place(s7_scheme *sc, s7_pointer p)
* so in a sense this is different from the other cases: it assumes (set! p (reverse! p))
* To make (reverse! p) direct:
* for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l;
- * if (!is_null(r)) return(simple_wrong_type_argument_with_type(sc, sc->REVERSEB, p, A_PROPER_LIST));
+ * if (!is_null(r)) return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, a_proper_list_string));
* for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); car(l) = car(r); car(r) = t; if (cdr(l) != r) r = opt1(r);}
*/
@@ -44397,8 +44623,8 @@ static s7_pointer c_reverse_in_place(s7_scheme *sc, s7_pointer p)
default:
if ((is_simple_sequence(p)) &&
(!has_methods(p)))
- return(simple_wrong_type_argument_with_type(sc, sc->REVERSEB, p, make_string_wrapper(sc, "a vector, string, or list")));
- method_or_bust_with_type(sc, p, sc->REVERSEB, list_1(sc, p), A_SEQUENCE, 0);
+ return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, make_string_wrapper(sc, "a vector, string, or list")));
+ method_or_bust_with_type(sc, p, sc->reverseb_symbol, list_1(sc, p), a_sequence_string, 0);
}
return(p);
}
@@ -44406,7 +44632,7 @@ static s7_pointer c_reverse_in_place(s7_scheme *sc, s7_pointer p)
static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args)
{
#define H_reverse_in_place "(reverse! lst) reverses lst in place"
- #define Q_reverse_in_place s7_make_signature(sc, 2, sc->IS_SEQUENCE, sc->IS_SEQUENCE)
+ #define Q_reverse_in_place s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)
return(c_reverse_in_place(sc, car(args)));
}
@@ -44430,8 +44656,8 @@ static s7_pointer list_fill(s7_scheme *sc, s7_pointer args)
if (!is_null(cddr(args)))
{
s7_pointer p;
- p = start_and_end(sc, sc->FILL, sc->FILL, cddr(args), args, 3, &start, &end);
- if (p != sc->GC_NIL) return(p);
+ p = start_and_end(sc, sc->fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
+ if (p != sc->gc_nil) return(p);
if (start == end) return(val);
}
@@ -44467,7 +44693,7 @@ static s7_pointer list_fill(s7_scheme *sc, s7_pointer args)
s7_pointer s7_fill(s7_scheme *sc, s7_pointer args)
{
#define H_fill "(fill! obj val (start 0) end) fills obj with val"
- #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->IS_SEQUENCE, sc->T, sc->IS_INTEGER)
+ #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol)
s7_pointer p;
p = car(args);
@@ -44491,15 +44717,15 @@ s7_pointer s7_fill(s7_scheme *sc, s7_pointer args)
return(hash_table_fill(sc, args));
case T_C_OBJECT:
- check_method(sc, p, sc->FILL, args);
+ check_method(sc, p, sc->fill_symbol, args);
if (c_object_fill(p))
return((*(c_object_fill(p)))(sc, args));
eval_error(sc, "attempt to fill ~S?", p);
default:
- check_method(sc, p, sc->FILL, args);
+ check_method(sc, p, sc->fill_symbol, args);
}
- return(wrong_type_argument_with_type(sc, sc->FILL, 1, p, A_SEQUENCE)); /* (fill! 1 0) */
+ return(wrong_type_argument_with_type(sc, sc->fill_symbol, 1, p, a_sequence_string)); /* (fill! 1 0) */
}
#define g_fill s7_fill
@@ -44556,12 +44782,12 @@ static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer c
n = sequence_length(sc, seq);
if ((n > 0) && (typ != T_FREE) && ((type(seq) == T_HASH_TABLE) || (type(seq) == T_LET)))
{
- wrong_type_argument(sc, sc->APPEND, i, seq, typ);
+ wrong_type_argument(sc, sc->append_symbol, i, seq, typ);
return(0);
}
if (n < 0)
{
- wrong_type_argument_with_type(sc, sc->APPEND, i, seq, (is_pair(seq)) ? A_PROPER_LIST : A_SEQUENCE);
+ wrong_type_argument_with_type(sc, sc->append_symbol, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string);
return(0);
}
len += n;
@@ -44574,7 +44800,7 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, int typ)
s7_pointer new_vec;
s7_int len;
- len = total_sequence_length(sc, args, sc->VECTOR_APPEND, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER));
+ len = total_sequence_length(sc, args, sc->vector_append_symbol, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER));
new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here */
if (len > 0)
@@ -44608,9 +44834,9 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, int typ)
}
}
}
- set_plist_2(sc, sc->NIL, sc->NIL);
- sc->temp9 = sc->NIL;
- sc->temp10 = sc->NIL;
+ set_plist_2(sc, sc->nil, sc->nil);
+ sc->temp9 = sc->nil;
+ sc->temp10 = sc->nil;
vector_length(sv) = 0;
}
return(new_vec);
@@ -44621,7 +44847,7 @@ static s7_pointer string_append(s7_scheme *sc, s7_pointer args)
s7_pointer new_str;
s7_int len;
- len = total_sequence_length(sc, args, sc->STRING_APPEND, (is_byte_vector(car(args))) ? T_INTEGER : T_CHARACTER);
+ len = total_sequence_length(sc, args, sc->string_append_symbol, (is_byte_vector(car(args))) ? T_INTEGER : T_CHARACTER);
new_str = make_empty_string(sc, len, 0);
if (is_byte_vector(car(args)))
set_byte_vector(new_str);
@@ -44651,9 +44877,9 @@ static s7_pointer string_append(s7_scheme *sc, s7_pointer args)
string_value(sv) = (char *)(string_value(new_str) + i);
}
}
- set_plist_2(sc, sc->NIL, sc->NIL);
- sc->temp9 = sc->NIL;
- sc->temp10 = sc->NIL;
+ set_plist_2(sc, sc->nil, sc->nil);
+ sc->temp9 = sc->nil;
+ sc->temp10 = sc->nil;
string_length(sv) = 0;
}
@@ -44666,7 +44892,7 @@ static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args)
new_hash = s7_make_hash_table(sc, sc->default_hash_table_length);
for (p = args; is_pair(p); p = cdr(p))
s7_copy(sc, set_plist_2(sc, car(p), new_hash));
- set_plist_2(sc, sc->NIL, sc->NIL);
+ set_plist_2(sc, sc->nil, sc->nil);
return(new_hash);
}
@@ -44675,11 +44901,11 @@ static s7_pointer let_append(s7_scheme *sc, s7_pointer args)
s7_pointer new_let, p, e;
e = car(args);
- check_method(sc, e, sc->APPEND, args);
- new_let = new_frame_in_env(sc, sc->NIL);
+ check_method(sc, e, sc->append_symbol, args);
+ new_let = new_frame_in_env(sc, sc->nil);
for (p = args; is_pair(p); p = cdr(p))
s7_copy(sc, set_plist_2(sc, car(p), new_let));
- set_plist_2(sc, sc->NIL, sc->NIL);
+ set_plist_2(sc, sc->nil, sc->nil);
return(new_let);
}
@@ -44689,7 +44915,7 @@ static s7_pointer g_append(s7_scheme *sc, s7_pointer args)
#define Q_append s7_make_circular_signature(sc, 0, 1, sc->T)
s7_pointer a1;
- if (is_null(args)) return(sc->NIL); /* (append) -> () */
+ if (is_null(args)) return(sc->nil); /* (append) -> () */
a1 = car(args); /* first arg determines result type unless all args but last are empty (sigh) */
if (is_null(cdr(args))) return(a1); /* (append <anything>) -> <anything> */
@@ -44714,9 +44940,9 @@ static s7_pointer g_append(s7_scheme *sc, s7_pointer args)
return(let_append(sc, args));
default:
- check_method(sc, a1, sc->APPEND, args);
+ check_method(sc, a1, sc->append_symbol, args);
}
- return(wrong_type_argument_with_type(sc, sc->APPEND, 1, a1, A_SEQUENCE)); /* (append 1 0) */
+ return(wrong_type_argument_with_type(sc, sc->append_symbol, 1, a1, a_sequence_string)); /* (append 1 0) */
}
static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
@@ -44740,7 +44966,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
s7_pointer x, iterator;
iterator = s7_make_iterator(sc, obj);
sc->temp8 = iterator;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
while (true)
{
x = s7_iterate(sc, iterator);
@@ -44748,15 +44974,15 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
sc->w = cons(sc, x, sc->w);
}
x = sc->w;
- sc->w = sc->NIL;
- sc->temp8 = sc->NIL;
+ sc->w = sc->nil;
+ sc->temp8 = sc->nil;
return(x);
}
- return(sc->NIL);
+ return(sc->nil);
case T_LET:
#if (!WITH_PURE_S7)
- check_method(sc, obj, sc->LET_TO_LIST, list_1(sc, obj));
+ check_method(sc, obj, sc->let_to_list_symbol, list_1(sc, obj));
#endif
return(s7_let_to_list(sc, obj));
@@ -44764,7 +44990,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
{
s7_pointer result, p = NULL;
int results = 0;
- result = sc->NIL;
+ result = sc->nil;
while (true)
{
s7_pointer val;
@@ -44772,7 +44998,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
if ((val == sc->ITERATOR_END) &&
(iterator_is_at_end(obj)))
{
- sc->temp8 = sc->NIL;
+ sc->temp8 = sc->nil;
return(result);
}
if (sc->safety > 0)
@@ -44784,7 +45010,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
results = S7_LONG_MIN;
}
}
- if (val != sc->NO_VALUE)
+ if (val != sc->no_value)
{
if (is_null(result))
{
@@ -44796,7 +45022,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
}
else
{
- result = cons(sc, val, sc->NIL);
+ result = cons(sc, val, sc->nil);
p = result;
}
sc->temp8 = result;
@@ -44811,7 +45037,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
}
else
{
- cdr(p) = cons(sc, val, sc->NIL);
+ cdr(p) = cons(sc, val, sc->nil);
p = cdr(p);
}
}
@@ -44833,24 +45059,24 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
if (len < 0)
return(sc->F);
if (len == 0)
- return(sc->NIL);
+ return(sc->nil);
- result = make_list(sc, len, sc->NIL);
+ result = make_list(sc, len, sc->nil);
sc->temp8 = result;
z = list_1(sc, sc->F);
gc_z = s7_gc_protect(sc, z);
- car(sc->Z2_1) = sc->x;
- car(sc->Z2_2) = sc->z;
+ car(sc->z2_1) = sc->x;
+ car(sc->z2_2) = sc->z;
for (i = 0, x = result; i < len; i++, x = cdr(x))
{
car(z) = make_integer(sc, i);
car(x) = (*(c_object_ref(obj)))(sc, obj, z);
}
- sc->x = car(sc->Z2_1);
- sc->z = car(sc->Z2_2);
+ sc->x = car(sc->z2_1);
+ sc->z = car(sc->z2_2);
s7_gc_unprotect_at(sc, gc_z);
- sc->temp8 = sc->NIL;
+ sc->temp8 = sc->nil;
return(result);
}
}
@@ -44904,7 +45130,7 @@ static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym)
f = s7_symbol_value(sc, sym);
return((is_procedure(f)) &&
(is_procedure(sc->error_hook)) &&
- (is_pair(s7_hook_functions(sc, sc->error_hook))) &&
+ (hook_has_functions(sc->error_hook)) &&
(direct_memq(f, s7_hook_functions(sc, sc->error_hook))));
}
return(false);
@@ -44929,7 +45155,7 @@ static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e,
gc_protected_at(sc, gc_syms) = syms;
val = s7_symbol_local_value(sc, code, e);
- if ((val) && (val != sc->UNDEFINED) &&
+ if ((val) && (val != sc->undefined) &&
(!is_any_macro(val)))
{
int typ;
@@ -44940,15 +45166,21 @@ static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e,
char *objstr, *str;
const char *spaces;
int objlen, new_note_len, notes_max, cur_line_len = 0, spaces_len;
- bool new_notes_line = false;
+ bool new_notes_line = false, old_short_print;
+ s7_int old_len;
spaces = " ";
spaces_len = strlen(spaces);
if (notes_start_col < 0) notes_start_col = 50;
notes_max = total_cols - notes_start_col;
+
+ old_short_print = sc->short_print;
+ sc->short_print = true;
+ old_len = sc->print_length;
+ if (sc->print_length > 4) sc->print_length = 4;
objstr = s7_object_to_c_string(sc, val);
- objlen = strlen(objstr);
+ objlen = safe_strlen(objstr);
if (objlen > notes_max)
{
objstr[notes_max - 4] = '.';
@@ -44957,6 +45189,8 @@ static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e,
objstr[notes_max - 1] = '\0';
objlen = notes_max;
}
+ sc->short_print = old_short_print;
+ sc->print_length = old_len;
new_note_len = symbol_name_length(code) + 3 + objlen;
/* we want to append this much info to the notes, but does it need a new line?
@@ -45077,7 +45311,7 @@ static char *stacktrace_1(s7_scheme *sc, int frames_max, int code_cols, int tota
char *str;
int loc, top, frames = 0, gc_syms;
- gc_syms = s7_gc_protect(sc, sc->NIL);
+ gc_syms = s7_gc_protect(sc, sc->nil);
str = NULL;
top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not s7_stack_top! */
@@ -45183,7 +45417,7 @@ a stacktrace as a string. Each line has two portions, the code being evaluated
the value of local variables in that code. The first argument sets how many lines are displayed. \
The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \
line to be preceded by a semicolon."
- #define Q_stacktrace s7_make_signature(sc, 6, sc->IS_STRING, sc->IS_INTEGER, sc->IS_INTEGER, sc->IS_INTEGER, sc->IS_INTEGER, sc->IS_BOOLEAN)
+ #define Q_stacktrace s7_make_signature(sc, 6, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol)
s7_int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50;
bool as_comment = false;
@@ -45225,19 +45459,19 @@ line to be preceded by a semicolon."
{
if (s7_is_boolean(car(args)))
as_comment = s7_boolean(sc, car(args));
- else return(wrong_type_argument(sc, sc->STACKTRACE, 5, car(args), T_BOOLEAN));
+ else return(wrong_type_argument(sc, sc->stacktrace_symbol, 5, car(args), T_BOOLEAN));
}
}
- else return(wrong_type_argument(sc, sc->STACKTRACE, 4, car(args), T_INTEGER));
+ else return(wrong_type_argument(sc, sc->stacktrace_symbol, 4, car(args), T_INTEGER));
}
}
- else return(wrong_type_argument(sc, sc->STACKTRACE, 3, car(args), T_INTEGER));
+ else return(wrong_type_argument(sc, sc->stacktrace_symbol, 3, car(args), T_INTEGER));
}
}
- else return(wrong_type_argument(sc, sc->STACKTRACE, 2, car(args), T_INTEGER));
+ else return(wrong_type_argument(sc, sc->stacktrace_symbol, 2, car(args), T_INTEGER));
}
}
- else method_or_bust(sc, car(args), sc->STACKTRACE, args, T_INTEGER, 1);
+ else method_or_bust(sc, car(args), sc->stacktrace_symbol, args, T_INTEGER, 1);
}
str = stacktrace_1(sc, (int)max_frames, (int)code_cols, (int)total_cols, (int)notes_start_col, as_comment);
return(make_string_uncopied_with_length(sc, str, safe_strlen(str)));
@@ -45384,7 +45618,7 @@ static const char *type_name(s7_scheme *sc, s7_pointer arg, int article)
if (has_methods(arg))
{
s7_pointer class_name;
- class_name = find_method(sc, arg, sc->CLASS_NAME);
+ class_name = find_method(sc, arg, sc->class_name_symbol);
if (is_symbol(class_name))
return(make_type_name(sc, symbol_name(class_name), article));
}
@@ -45406,7 +45640,7 @@ static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x)
if (has_methods(x))
{
- p = find_method(sc, find_let(sc, x), sc->CLASS_NAME);
+ p = find_method(sc, find_let(sc, x), sc->class_name_symbol);
if (is_symbol(p))
return(symbol_name_cell(p));
}
@@ -45417,8 +45651,8 @@ static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x)
switch (type(x))
{
case T_C_OBJECT: return(object_types[c_object_type(x)]->scheme_name);
- case T_INPUT_PORT: return((is_file_port(x)) ? AN_INPUT_FILE_PORT : ((is_string_port(x)) ? AN_INPUT_STRING_PORT : AN_INPUT_PORT));
- case T_OUTPUT_PORT: return((is_file_port(x)) ? AN_OUTPUT_FILE_PORT : ((is_string_port(x)) ? AN_OUTPUT_STRING_PORT : AN_OUTPUT_PORT));
+ case T_INPUT_PORT: return((is_file_port(x)) ? an_input_file_port_string : ((is_string_port(x)) ? an_input_string_port_string : an_input_port_string));
+ case T_OUTPUT_PORT: return((is_file_port(x)) ? an_output_file_port_string : ((is_string_port(x)) ? an_output_string_port_string : an_output_port_string));
}
return(make_string_wrapper(sc, "unknown type!"));
}
@@ -45442,17 +45676,17 @@ static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer cal
car(p) = caller; p = cdr(p);
car(p) = arg_n; p = cdr(p);
car(p) = arg; p = cdr(p);
- car(p) = (typnam == sc->GC_NIL) ? prepackaged_type_name(sc, arg) : typnam;
+ car(p) = (typnam == sc->gc_nil) ? prepackaged_type_name(sc, arg) : typnam;
p = cdr(p);
car(p) = descr;
- return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->wrong_type_arg_info));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info));
}
static s7_pointer simple_wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typnam, s7_pointer descr)
{
- set_wlist_4(sc, cdr(sc->simple_wrong_type_arg_info), caller, arg, (typnam == sc->GC_NIL) ? prepackaged_type_name(sc, arg) : typnam, descr);
- return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->simple_wrong_type_arg_info));
+ set_wlist_4(sc, cdr(sc->simple_wrong_type_arg_info), caller, arg, (typnam == sc->gc_nil) ? prepackaged_type_name(sc, arg) : typnam, descr);
+ return(s7_error(sc, sc->wrong_type_arg_symbol, sc->simple_wrong_type_arg_info));
}
@@ -45474,14 +45708,14 @@ static s7_pointer out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer calle
{
/* info list is '(format_string caller arg_n arg descr) */
set_wlist_4(sc, cdr(sc->out_of_range_info), caller, arg_n, arg, descr);
- return(s7_error(sc, sc->OUT_OF_RANGE, sc->out_of_range_info));
+ return(s7_error(sc, sc->out_of_range_symbol, sc->out_of_range_info));
}
static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr)
{
set_wlist_3(sc, cdr(sc->simple_out_of_range_info), caller, arg, descr);
- return(s7_error(sc, sc->OUT_OF_RANGE, sc->simple_out_of_range_info));
+ return(s7_error(sc, sc->out_of_range_symbol, sc->simple_out_of_range_info));
}
@@ -45498,19 +45732,19 @@ s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, int arg_n, s
s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args)
{
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_2(sc, make_string_wrapper(sc, caller), args))); /* "caller" includes the format directives */
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, make_string_wrapper(sc, caller), args))); /* "caller" includes the format directives */
}
static s7_pointer division_by_zero_error(s7_scheme *sc, s7_pointer caller, s7_pointer arg)
{
- return(s7_error(sc, sc->DIVISION_BY_ZERO, set_elist_3(sc, sc->DIVISION_BY_ZERO_ERROR, caller, arg)));
+ return(s7_error(sc, sc->division_by_zero_symbol, set_elist_3(sc, sc->division_by_zero_error_string, caller, arg)));
}
static s7_pointer file_error(s7_scheme *sc, const char *caller, const char *descr, const char *name)
{
- return(s7_error(sc, sc->IO_ERROR,
+ return(s7_error(sc, sc->io_error_symbol,
set_elist_4(sc, make_string_wrapper(sc, "~A: ~A ~S"),
make_string_wrapper(sc, caller),
make_string_wrapper(sc, descr),
@@ -45525,7 +45759,7 @@ static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer p)
body = closure_body(p);
if (is_pair(cdr(body))) return(p);
if (!is_pair(car(body))) return(sc->F);
- if (caar(body) == sc->QUOTE) return(sc->F);
+ if (caar(body) == sc->quote_symbol) return(sc->F);
return(p);
}
@@ -45534,16 +45768,16 @@ static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args)
{
#define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \
each a function of no arguments, guaranteeing that finish is called even if body is exited"
- #define Q_dynamic_wind s7_make_circular_signature(sc, 1, 2, sc->VALUES, sc->IS_PROCEDURE)
+ #define Q_dynamic_wind s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->is_procedure_symbol)
s7_pointer p;
if (!is_thunk(sc, car(args)))
- method_or_bust_with_type(sc, car(args), sc->DYNAMIC_WIND, args, A_THUNK, 1);
+ method_or_bust_with_type(sc, car(args), sc->dynamic_wind_symbol, args, a_thunk_string, 1);
if (!is_thunk(sc, cadr(args)))
- method_or_bust_with_type(sc, cadr(args), sc->DYNAMIC_WIND, args, A_THUNK, 2);
+ method_or_bust_with_type(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2);
if (!is_thunk(sc, caddr(args)))
- method_or_bust_with_type(sc, caddr(args), sc->DYNAMIC_WIND, args, A_THUNK, 3);
+ method_or_bust_with_type(sc, caddr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 3);
/* this won't work:
@@ -45569,16 +45803,16 @@ each a function of no arguments, guaranteeing that finish is called even if body
* or is a quoted thing, we just ignore that function.
*/
- push_stack(sc, OP_DYNAMIC_WIND, sc->NIL, p); /* args will be the saved result, code = s7_dynwind_t obj */
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */
if (dynamic_wind_in(p) != sc->F)
{
dynamic_wind_state(p) = DWIND_INIT;
- push_stack(sc, OP_APPLY, sc->NIL, dynamic_wind_in(p));
+ push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p));
}
else
{
dynamic_wind_state(p) = DWIND_BODY;
- push_stack(sc, OP_APPLY, sc->NIL, dynamic_wind_body(p));
+ push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(p));
}
return(sc->F);
}
@@ -45588,56 +45822,52 @@ s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_p
{
/* this is essentially s7_call with a dynamic-wind wrapper around "body" */
s7_pointer p;
- bool old_longjmp;
- jmp_buf old_goto_start;
+ declare_jump_info();
sc->temp1 = ((init == sc->F) ? finish : init);
sc->temp2 = body;
- old_longjmp = sc->longjmp_ok;
- memcpy((void *)old_goto_start, (void *)(sc->goto_start), sizeof(jmp_buf));
- sc->longjmp_ok = true;
-
- if (setjmp(sc->goto_start) != 0) /* returning from s7_error catch handler */
- {
- sc->longjmp_ok = old_longjmp;
- memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));
- if ((sc->op == OP_ERROR_QUIT) &&
- (sc->longjmp_ok))
- longjmp(sc->goto_start, 1);
- eval(sc, sc->op);
- return(sc->value);
- }
-
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->args = sc->NIL;
- new_cell(sc, p, T_DYNAMIC_WIND);
- dynamic_wind_in(p) = init;
- dynamic_wind_body(p) = body;
- dynamic_wind_out(p) = finish;
- push_stack(sc, OP_DYNAMIC_WIND, sc->NIL, p);
- if (init != sc->F)
+ store_jump_info(sc);
+ set_jump_info(sc, DYNAMIC_WIND_SET_JUMP);
+ if (jump_loc != NO_JUMP)
{
- dynamic_wind_state(p) = DWIND_INIT;
- sc->code = init;
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->op);
}
else
{
- dynamic_wind_state(p) = DWIND_BODY;
- sc->code = body;
+ push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ sc->args = sc->nil;
+
+ new_cell(sc, p, T_DYNAMIC_WIND);
+ dynamic_wind_in(p) = _NFre(init);
+ dynamic_wind_body(p) = _NFre(body);
+ dynamic_wind_out(p) = _NFre(finish);
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p);
+ if (init != sc->F)
+ {
+ dynamic_wind_state(p) = DWIND_INIT;
+ sc->code = init;
+ }
+ else
+ {
+ dynamic_wind_state(p) = DWIND_BODY;
+ sc->code = body;
+ }
+ eval(sc, OP_APPLY);
}
+ restore_jump_info(sc);
- eval(sc, OP_APPLY);
- sc->longjmp_ok = old_longjmp;
- memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));
- return(sc->value);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
}
static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
{
#define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called"
- #define Q_catch s7_make_circular_signature(sc, 2, 3, sc->VALUES, sc->T, sc->IS_PROCEDURE)
+ #define Q_catch s7_make_circular_signature(sc, 2, 3, sc->values_symbol, sc->T, sc->is_procedure_symbol)
s7_pointer p, proc, err;
@@ -45648,7 +45878,7 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
proc = cadr(args);
err = caddr(args);
- /* if (is_let(err)) check_method(sc, err, sc->CATCH, args); */ /* causes exit from s7! */
+ /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */
new_cell(sc, p, T_CATCH);
catch_tag(p) = car(args);
@@ -45662,10 +45892,10 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
/* not sure about these error checks -- they can be omitted */
if (!is_thunk(sc, proc))
- return(wrong_type_argument_with_type(sc, sc->CATCH, 2, proc, A_THUNK));
+ return(wrong_type_argument_with_type(sc, sc->catch_symbol, 2, proc, a_thunk_string));
if (!is_applicable(err))
- return(wrong_type_argument_with_type(sc, sc->CATCH, 3, err, SOMETHING_APPLICABLE));
+ return(wrong_type_argument_with_type(sc, sc->catch_symbol, 3, err, something_applicable_string));
/* should we check here for (aritable? err 2)? -- right now:
* (catch #t (lambda () 1) "hiho") -> 1
@@ -45678,7 +45908,7 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
new_frame(sc, closure_let(proc), sc->envir);
push_stack(sc, OP_BEGIN_UNCHECKED, sc->args, sc->code);
}
- else push_stack(sc, OP_APPLY, sc->NIL, proc);
+ else push_stack(sc, OP_APPLY, sc->nil, proc);
return(sc->F);
}
@@ -45735,15 +45965,23 @@ static s7_pointer init_owlet(s7_scheme *sc)
sc->error_code = make_slot_1(sc, e, make_symbol(sc, "error-code"), sc->F); /* the code that s7 thinks triggered the error */
sc->error_line = make_slot_1(sc, e, make_symbol(sc, "error-line"), sc->F); /* the line number of that code */
sc->error_file = make_slot_1(sc, e, make_symbol(sc, "error-file"), sc->F); /* the file name of that code */
+#if WITH_HISTORY
+ sc->error_history = make_slot_1(sc, e, make_symbol(sc, "error-history"), sc->F); /* buffer of previous evaluations */
+#endif
return(e);
}
static s7_pointer g_owlet(s7_scheme *sc, s7_pointer args)
{
+#if WITH_HISTORY
+ #define H_owlet "(owlet) returns the environment at the point of the last error. \
+It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history."
+#else
#define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, and error-file."
- #define Q_owlet s7_make_signature(sc, 1, sc->IS_LET)
+#endif
+ #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol)
/* if owlet is not copied, (define e (owlet)), e changes as owlet does!
*/
s7_pointer e, x;
@@ -45752,15 +45990,16 @@ It has the additional local variables: error-type, error-data, error-code, error
e = let_copy(sc, sc->owlet);
gc_loc = s7_gc_protect(sc, e);
- /* also make sure the pairs are copied: should be error-data and error-code */
+ /* also make sure the pairs are copied: should be error-data, error-code, and possibly error-history */
for (x = let_slots(e); is_slot(x); x = next_slot(x))
if (is_pair(slot_value(x)))
slot_set_value(x, protected_list_copy(sc, slot_value(x)));
+
s7_gc_unprotect_at(sc, gc_loc);
return(e);
}
-static s7_pointer c_owlet(s7_scheme *sc) {return(g_owlet(sc, sc->NIL));}
+static s7_pointer c_owlet(s7_scheme *sc) {return(g_owlet(sc, sc->nil));}
PF_0(owlet, c_owlet)
@@ -45768,7 +46007,7 @@ static s7_pointer active_catches(s7_scheme *sc)
{
int i;
s7_pointer x, lst;
- lst = sc->NIL;
+ lst = sc->nil;
for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
switch (stack_op(sc->stack, i))
{
@@ -45783,7 +46022,7 @@ static s7_pointer active_catches(s7_scheme *sc)
lst = cons(sc, catch_tag(x), lst);
break;
}
- return(reverse_in_place_unchecked(sc, sc->NIL, lst));
+ return(reverse_in_place_unchecked(sc, sc->nil, lst));
}
static s7_pointer active_exits(s7_scheme *sc)
@@ -45791,7 +46030,7 @@ static s7_pointer active_exits(s7_scheme *sc)
/* (call-with-exit (lambda (exiter) (*s7* 'exits))) */
int i;
s7_pointer lst;
- lst = sc->NIL;
+ lst = sc->nil;
for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
if (stack_op(sc->stack, i) == OP_DEACTIVATE_GOTO)
{
@@ -45803,20 +46042,20 @@ static s7_pointer active_exits(s7_scheme *sc)
lst = cons(sc, cons(sc, car(closure_args(func)), jump), lst);
else
{
- if ((is_pair(func)) && (car(func) == sc->CALL_WITH_EXIT))
+ if ((is_pair(func)) && (car(func) == sc->call_with_exit_symbol))
lst = cons(sc, cons(sc, car(cadr(cadr(func))), jump), lst); /* (call-with-exit (lambda (three) ...)) */
- else lst = cons(sc, cons(sc, sc->UNSPECIFIED, jump), lst);
+ else lst = cons(sc, cons(sc, sc->unspecified, jump), lst);
}
sc->w = lst;
}
- return(reverse_in_place_unchecked(sc, sc->NIL, lst));
+ return(reverse_in_place_unchecked(sc, sc->nil, lst));
}
static s7_pointer stack_entries(s7_scheme *sc)
{
int i;
s7_pointer lst;
- lst = sc->NIL;
+ lst = sc->nil;
for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
{
s7_pointer func, args, e;
@@ -45830,11 +46069,17 @@ static s7_pointer stack_entries(s7_scheme *sc)
(s7_is_valid(sc, e)) &&
(op < OP_MAX_DEFINED))
{
+#if DEBUGGING
+ if (op < OP_MAX_DEFINED_1)
+ lst = cons(sc, list_4(sc, func, args, e, make_string_wrapper(sc, op_names[op])), lst);
+ else lst = cons(sc, list_4(sc, func, args, e, make_integer(sc, op)), lst);
+#else
lst = cons(sc, list_4(sc, func, args, e, make_integer(sc, op)), lst);
+#endif
sc->w = lst;
}
}
- return(reverse_in_place_unchecked(sc, sc->NIL, lst));
+ return(reverse_in_place_unchecked(sc, sc->nil, lst));
}
@@ -45871,9 +46116,9 @@ static bool catch_2_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
sc->code = catch_handler(x);
- car(sc->T2_1) = type;
- car(sc->T2_2) = info;
- sc->args = sc->T2_1; /* copied in op_apply? */
+ car(sc->t2_1) = type;
+ car(sc->t2_2) = info;
+ sc->args = sc->t2_1; /* copied in op_apply? */
sc->op = OP_APPLY;
return(true);
@@ -45889,7 +46134,7 @@ static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
(catch_tag(x) == type) ||
(type == sc->T))
{
- int loc;
+ unsigned int loc;
opcode_t op;
s7_pointer catcher, error_func, body;
@@ -45927,11 +46172,11 @@ static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
body = car(body);
if (is_pair(body))
{
- if (car(body) == sc->QUOTE)
+ if (car(body) == sc->quote_symbol)
y = cadr(body);
else
{
- if ((car(body) == sc->CAR) &&
+ if ((car(body) == sc->car_symbol) &&
(is_pair(error_func)) &&
(cadr(body) == car(error_func)))
y = type;
@@ -45949,9 +46194,25 @@ static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
}
if (y)
{
- pop_stack(sc);
+ if (loc > 4)
+ pop_stack(sc);
+ /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming
+ * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE
+ * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc).
+ * If we catch an error, catch unwinds to its starting point, and the pop_stack above
+ * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE.
+ * Now we return true, ending up back in eval, because the error handler jumped out of eval,
+ * back to wherever we were in eval when we hit the error. eval jumps back to the start
+ * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least
+ * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval.
+ * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack.
+ * s7_eval doesn't know anything about the catches on the stack. We can't look back for
+ * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the
+ * end? But we want the error handler to run as a part of the calling expression, and
+ * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case).
+ */
sc->value = y;
- sc->temp4 = sc->NIL;
+ sc->temp4 = sc->nil;
return(true);
}
}
@@ -45962,7 +46223,7 @@ static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
sc->code = y;
}
else sc->code = error_func;
- sc->temp4 = sc->NIL;
+ sc->temp4 = sc->nil;
/* if user (i.e. yers truly!) copies/pastes the preceding lambda () into the
* error handler portion of the catch, he gets the inexplicable message:
@@ -45980,9 +46241,9 @@ static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer i
/* since make_closure_with_let sets needs_copied_args and we're going to OP_APPLY,
* we don't need a new list here.
*/
- car(sc->T2_1) = type;
- car(sc->T2_2) = info;
- sc->args = sc->T2_1;
+ car(sc->t2_1) = type;
+ car(sc->t2_2) = info;
+ sc->args = sc->t2_1;
sc->op = OP_APPLY;
/* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c)
@@ -46005,7 +46266,7 @@ static bool catch_dw_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer
{
push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = dynamic_wind_out(x);
- sc->args = sc->NIL;
+ 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 */
}
}
@@ -46110,12 +46371,13 @@ It looks for an existing catch with a matching tag, and jumps to it if found. O
if ((catcher) &&
(catcher(sc, i, type, info, &ignored_flag)))
{
- if (sc->longjmp_ok) longjmp(sc->goto_start, 1);
+ if (sc->longjmp_ok) longjmp(sc->goto_start, THROW_JUMP);
return(sc->value);
}
}
- if (is_let(car(args))) check_method(sc, car(args), sc->THROW, args);
- return(s7_error(sc, make_symbol(sc, "uncaught-throw"), args));
+ if (is_let(car(args))) check_method(sc, car(args), sc->throw_symbol, args);
+ return(s7_error(sc, make_symbol(sc, "uncaught-throw"),
+ set_elist_3(sc, make_string_wrapper(sc, "no catch found for (throw ~W~{~^ ~S~~})"), type, info)));
}
@@ -46162,17 +46424,26 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
fprintf(stderr, "owlet clobbered!\n");
#endif
if ((unchecked_type(sc->envir) != T_LET) &&
- (sc->envir != sc->NIL))
- sc->envir = sc->NIL; /* in reader, the envir frame is mostly ignored so it can be (and usually is) garbage */
+ (sc->envir != sc->nil))
+ sc->envir = sc->nil; /* in reader, the envir frame is mostly ignored so it can be (and usually is) garbage */
set_outlet(sc->owlet, sc->envir);
- cur_code = sc->cur_code;
+ cur_code = current_code(sc);
slot_set_value(sc->error_code, cur_code);
- if (has_line_number(cur_code))
+#if WITH_HISTORY
+ slot_set_value(sc->error_history, sc->cur_code);
+ if (sc->using_history1)
+ sc->cur_code = sc->eval_history2;
+ else sc->cur_code = sc->eval_history1;
+ sc->using_history1 = (!sc->using_history1);
+#endif
+
+ if ((is_pair(cur_code)) && /* can be () if unexpected close paren read error */
+ (has_line_number(cur_code)))
{
int line;
- line = pair_line(cur_code);
+ line = (int)pair_line(cur_code); /* cast to int (from unsigned int) for last_line */
if (line != last_line)
{
last_line = line;
@@ -46201,11 +46472,16 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
{
catch_function catcher;
catcher = catchers[stack_op(sc->stack, i)];
+ /* fprintf(stderr, "catching %s %s\n", DISPLAY(type), DISPLAY(info)); */
if ((catcher) &&
(catcher(sc, i, type, info, &reset_error_hook)))
{
- if (sc->longjmp_ok) longjmp(sc->goto_start, 1);
- return(type); /* throw returns sc->value here? */
+ if (sc->longjmp_ok) longjmp(sc->goto_start, CATCH_JUMP);
+ /* all the rest of the code expects s7_error to jump, not return,
+ * so presumably if we get here, we're in trouble -- try to send out an error message
+ */
+ /* return(type); */
+ /* fprintf(stderr, "falling through now\n"); */
}
}
}
@@ -46215,7 +46491,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
if ((!reset_error_hook) &&
(is_procedure(sc->error_hook)) &&
- (is_pair(s7_hook_functions(sc, sc->error_hook))))
+ (hook_has_functions(sc->error_hook)))
{
s7_pointer error_hook_func;
/* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */
@@ -46224,7 +46500,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
sc->error_hook = sc->F;
/* if the *error-hook* functions trigger an error, we had better not have *error-hook* still set! */
- push_stack(sc, OP_ERROR_HOOK_QUIT, sc->NIL, error_hook_func); /* restore *error-hook* upon successful (or any!) evaluation */
+ push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_func); /* restore *error-hook* upon successful (or any!) evaluation */
sc->args = list_2(sc, type, info);
sc->code = error_hook_func;
@@ -46247,19 +46523,23 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), NULL, false, 7);
else
{
- const char *carstr;
- int i, len;
+ int len = 0;
bool use_format = false;
/* it's possible that the error string is just a string -- not intended for format */
- carstr = string_value(car(info));
- len = string_length(car(info));
- for (i = 0; i < len; i++)
- if (carstr[i] == '~')
- {
- use_format = true;
- break;
- }
+ if (type != sc->format_error_symbol) /* avoid an infinite loop of format errors */
+ {
+ int i;
+ const char *carstr;
+ carstr = string_value(car(info));
+ len = string_length(car(info));
+ for (i = 0; i < len; i++)
+ if (carstr[i] == '~')
+ {
+ use_format = true;
+ break;
+ }
+ }
if (use_format)
{
@@ -46317,6 +46597,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
{
const char *call_name;
call_name = sc->s7_call_name;
+
/* sc->s7_call_name = NULL; */
if (call_name)
{
@@ -46374,11 +46655,11 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
* go into repl here with access to continuation? Or expect *error-handler* to deal with it?
*/
sc->value = type;
- stack_reset(sc);
+ /* stack_reset(sc); */
sc->op = OP_ERROR_QUIT;
}
- if (sc->longjmp_ok) longjmp(sc->goto_start, 1);
+ if (sc->longjmp_ok) longjmp(sc->goto_start, ERROR_JUMP);
return(type);
}
@@ -46390,10 +46671,10 @@ static s7_pointer apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args)
*/
static s7_pointer errstr = NULL;
if (is_null(obj))
- return(s7_error(sc, sc->SYNTAX_ERROR, set_elist_2(sc, make_string_wrapper_with_length(sc, "attempt to apply nil to ~S?", 27), args)));
+ return(s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper_with_length(sc, "attempt to apply nil to ~S?", 27), args)));
if (!errstr)
errstr = s7_make_permanent_string("attempt to apply ~A ~S to ~S?");
- return(s7_error(sc, sc->SYNTAX_ERROR, set_elist_4(sc, errstr, type_name_string(sc, obj), obj, args)));
+ return(s7_error(sc, sc->syntax_error_symbol, set_elist_4(sc, errstr, type_name_string(sc, obj), obj, args)));
}
@@ -46407,6 +46688,7 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er
int len;
s7_pointer pt;
+ /* fprintf(stderr, "read error: %s\n", errmsg); */
pt = sc->input_port;
if (!string_error)
{
@@ -46473,7 +46755,7 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er
}
if (recent_input) free(recent_input);
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
}
}
@@ -46490,10 +46772,10 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er
else len = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%d]",
errmsg, port_filename(pt), port_line_number(pt),
sc->current_file, sc->current_line);
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
}
- return(s7_error(sc, (string_error) ? sc->STRING_READ_ERROR : sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, (char *)errmsg))));
+ return(s7_error(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, (char *)errmsg))));
}
static s7_pointer read_error(s7_scheme *sc, const char *errmsg)
@@ -46518,12 +46800,12 @@ and applies it to the rest of the arguments."
{
if (is_string(car(args))) /* CL-style error? -- use tag = 'no-catch */
{
- s7_error(sc, sc->NO_CATCH, args); /* this can have trailing args (implicit format) */
- return(sc->UNSPECIFIED);
+ s7_error(sc, sc->no_catch_symbol, args); /* this can have trailing args (implicit format) */
+ return(sc->unspecified);
}
return(s7_error(sc, car(args), cdr(args)));
}
- return(s7_error(sc, sc->NIL, sc->NIL));
+ return(s7_error(sc, sc->nil, sc->nil));
}
@@ -46604,76 +46886,31 @@ static char *object_to_truncated_string(s7_scheme *sc, s7_pointer p, int len)
}
-static char *missing_close_paren_syntax_check(s7_scheme *sc, s7_pointer lst)
+static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, unsigned int line)
{
- s7_pointer p, old_hook;
- int old_hook_loc;
- char *msg = NULL;
-
- /* this can get into an infinite loop if unbound variable hook gets involved so...
- */
- old_hook = s7_hook_functions(sc, sc->unbound_variable_hook);
- old_hook_loc = s7_gc_protect(sc, old_hook);
- s7_hook_set_functions(sc, sc->unbound_variable_hook, sc->NIL);
-
- for (p = lst; is_pair(p); p = cdr(p))
+ s7_pointer tp;
+ if (!is_pair(p)) return(NULL);
+ if (has_line_number(p))
{
- if (is_pair(car(p)))
+ unsigned int x;
+ x = (unsigned int)remembered_line_number(pair_line(p));
+ if (x > 0)
{
- s7_pointer sym;
- sym = caar(p);
- if (is_symbol(sym))
- {
- int len;
-
- len = s7_list_length(sc, car(p));
- if (((sym == make_symbol_with_length(sc, "if", 2)) &&
- (len > 4)) ||
- /* some care is needed -- we can't risk autoloading the very same file we're complaining about! */
- ((is_slot(global_slot(sym))) &&
- (s7_is_procedure(slot_value(global_slot(sym)))) &&
- (!s7_is_aritable(sc, slot_value(global_slot(sym)), len))) ||
- ((sym == make_symbol_with_length(sc, "define", 6)) &&
- (is_pair(cdr(p))) &&
- (is_symbol(cadr(p))) &&
- (len > 3)))
- {
- int msg_len, form_len;
- char *form;
- /* it's very tricky to try to see other errors here, especially because 'case'
- * can have syntax names in its key lists. Even this may get fooled, but
- * I'm hoping that more often than not, it will help track down the missing
- * close paren.
- */
-
- form = object_to_truncated_string(sc, car(p), 80);
- form_len = safe_strlen(form);
- msg_len = form_len + 128;
- msg = (char *)malloc(msg_len * sizeof(char));
- snprintf(msg, msg_len, "; this looks bogus: %s", form);
- free(form);
-
- s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
- s7_gc_unprotect_at(sc, old_hook_loc);
-
- return(msg);
- }
- }
- msg = missing_close_paren_syntax_check(sc, car(p));
- if (msg)
+ if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */
+ line = x;
+ else
{
- s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
- s7_gc_unprotect_at(sc, old_hook_loc);
- return(msg);
+ if (x < line)
+ return(p);
}
}
}
- s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
- s7_gc_unprotect_at(sc, old_hook_loc);
-
- return(NULL);
+ tp = tree_descend(sc, car(p), line);
+ if (tp) return(tp);
+ return(tree_descend(sc, cdr(p), line));
}
+
static s7_pointer missing_close_paren_error(s7_scheme *sc)
{
int len;
@@ -46681,35 +46918,42 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc)
s7_pointer pt;
if ((unchecked_type(sc->envir) != T_LET) &&
- (sc->envir != sc->NIL))
- sc->envir = sc->NIL;
+ (sc->envir != sc->nil))
+ sc->envir = sc->nil;
+
+ pt = sc->input_port;
/* check *missing-close-paren-hook* */
- if (!is_null(sc->missing_close_paren_hook))
+ if (hook_has_functions(sc->missing_close_paren_hook))
{
s7_pointer result;
- result = s7_call(sc, sc->missing_close_paren_hook, sc->NIL);
- if (result != sc->UNSPECIFIED)
+ if ((port_line_number(pt) > 0) &&
+ (port_filename(pt)))
+ {
+ slot_set_value(sc->error_line, make_integer(sc, port_line_number(pt)));
+ slot_set_value(sc->error_file, make_string_wrapper(sc, port_filename(pt)));
+ }
+ result = s7_call(sc, sc->missing_close_paren_hook, sc->nil);
+ if (result != sc->unspecified)
return(g_throw(sc, list_1(sc, result)));
}
- pt = sc->input_port;
-
- /* it's hard to give a good idea here of where the missing paren is because we've already
- * popped off all the stacked info, following ')' until eof.
- * but the current incoming program code is in sc->args, reversed at its top level,
- * so it's worth looking for some problem involving too many clauses (if) or arguments, etc.
- * another gotcha: since we're in the reader, we can't depend on sc->envir!
- * this can be a hard bug to track down in a large program, so s7 really has to make an effort to help.
- */
-
if (is_pair(sc->args))
{
- s7_pointer lx;
- lx = s7_reverse(sc, sc->args);
- syntax_msg = missing_close_paren_syntax_check(sc, lx);
- /* if syntax_msg is null, we didn't find the problem, so perhaps show it indented?
- */
+ s7_pointer p;
+ p = tree_descend(sc, sc->args, 0);
+ if ((p) && (is_pair(p)) &&
+ (has_line_number(p)))
+ {
+ int msg_len, form_len;
+ char *form;
+ form = object_to_truncated_string(sc, p, 40);
+ form_len = safe_strlen(form);
+ msg_len = form_len + 128;
+ syntax_msg = (char *)malloc(msg_len * sizeof(char));
+ snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", remembered_line_number(pair_line(p)), form);
+ free(form);
+ }
}
if ((port_line_number(pt) > 0) &&
@@ -46727,7 +46971,7 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc)
else len = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%d]",
port_filename(pt), port_line_number(pt),
sc->current_file, sc->current_line);
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
}
if (syntax_msg)
@@ -46736,9 +46980,29 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc)
msg = (char *)malloc(len * sizeof(char));
len = snprintf(msg, len, "missing close paren\n%s\n", syntax_msg);
free(syntax_msg);
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ }
+
+ /* try to show the current input */
+ if ((is_input_port(pt)) &&
+ (!port_is_closed(pt)) &&
+ (port_data(pt)) &&
+ (port_position(pt) > 0))
+ {
+ const unsigned char *str;
+ int i, j, start;
+ start = (int)port_position(pt) - 40;
+ if (start < 0) start = 0;
+ msg = (char *)malloc(128 * sizeof(char));
+ len = snprintf(msg, 128, "missing close paren: ");
+ str = (const unsigned char *)port_data(pt);
+ for (i = start, j = len; i < (int)port_position(pt); i++, j++)
+ msg[j] = str[i];
+ msg[j] = '\0';
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, j))));
}
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "missing close paren"))));
+
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "missing close paren"))));
}
@@ -46747,9 +47011,9 @@ static void improper_arglist_error(s7_scheme *sc)
/* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code
* the original was `(,@(reverse args) . ,code) essentially
*/
- if (sc->args == sc->NIL) /* (abs . 1) */
- s7_error(sc, sc->SYNTAX_ERROR, set_elist_1(sc, make_string_wrapper(sc, "function call is a dotted list?")));
- else s7_error(sc, sc->SYNTAX_ERROR,
+ if (sc->args == sc->nil) /* (abs . 1) */
+ s7_error(sc, sc->syntax_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "function call is a dotted list?")));
+ else s7_error(sc, sc->syntax_error_symbol,
set_elist_2(sc, make_string_wrapper(sc, "improper list of arguments: ~S"),
append_in_place(sc, sc->args = safe_reverse_in_place(sc, sc->args), sc->code)));
}
@@ -46793,7 +47057,7 @@ static bool call_begin_hook(s7_scheme *sc)
/* set (owlet) in case we were interrupted and need to see why something was hung */
slot_set_value(sc->error_type, sc->F);
slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */
- slot_set_value(sc->error_code, sc->cur_code);
+ slot_set_value(sc->error_code, current_code(sc));
slot_set_value(sc->error_line, sc->F);
slot_set_value(sc->error_file, sc->F);
set_outlet(sc->owlet, sc->envir);
@@ -46829,13 +47093,13 @@ static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
static s7_pointer apply_list_error(s7_scheme *sc, s7_pointer lst)
{
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "apply's last argument should be a proper list: ~S"), lst)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "apply's last argument should be a proper list: ~S"), lst)));
}
static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
{
#define H_apply "(apply func ...) applies func to the rest of the arguments"
- #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->VALUES, sc->IS_PROCEDURE, sc->T)
+ #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, sc->is_procedure_symbol, sc->T)
/* can apply always be replaced with apply values?
* (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3)))
@@ -46845,7 +47109,7 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
*/
sc->code = car(args);
if (is_null(cdr(args)))
- sc->args = sc->NIL;
+ sc->args = sc->nil;
else
{
if (is_safe_procedure(sc->code))
@@ -46862,7 +47126,7 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
* but it omits the arg number check
*/
push_stack(sc, OP_APPLY, cdr(args), sc->code);
- return(sc->NIL);
+ return(sc->nil);
}
else
{
@@ -46877,11 +47141,21 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
}
push_stack(sc, OP_APPLY, sc->args, sc->code);
- return(sc->NIL);
+ return(sc->nil);
}
s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
{
+#if DEBUGGING
+ {
+ s7_pointer p;
+ int argnum;
+ _NFre(fnc);
+ for (argnum = 0, p = _NFre(args); is_pair(p); argnum++, p = _NFre(cdr(p)))
+ _NFre(car(p));
+ }
+#endif
+
if (is_c_function(fnc))
return(c_function_call(fnc)(sc, args));
@@ -46889,7 +47163,7 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
sc->args = args;
sc->code = fnc;
eval(sc, OP_APPLY);
- /* we're limited in choices here -- the caller might be (say) car(sc->T1_1) = c_call(...) where the c_call
+ /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = c_call(...) where the c_call
* happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally.
*/
return(sc->value);
@@ -46898,26 +47172,32 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->code = code;
- if ((e != sc->rootlet) &&
- (is_let(e)))
- sc->envir = e;
- else sc->envir = sc->NIL; /* can't check is_let(e) because sc->rootlet sets its type to t_env! */
- eval(sc, OP_BEGIN);
- return(sc->value);
-}
+ declare_jump_info();
+#if DEBUGGING
+ _NFre(code);
+#endif
+ store_jump_info(sc);
+ set_jump_info(sc, EVAL_SET_JUMP);
+ if (jump_loc != NO_JUMP)
+ {
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->op);
+ }
+ else
+ {
+ push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ sc->code = code;
+ if ((e != sc->rootlet) &&
+ (is_let(e)))
+ sc->envir = e;
+ else sc->envir = sc->nil;
+ eval(sc, OP_EVAL);
+ }
+ restore_jump_info(sc);
-s7_pointer s7_eval_form(s7_scheme *sc, s7_pointer form, s7_pointer e)
-{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
- sc->code = form;
- if ((e != sc->rootlet) &&
- (is_let(e)))
- sc->envir = e;
- else sc->envir = sc->NIL;
- eval(sc, OP_EVAL);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
return(sc->value);
}
@@ -46933,77 +47213,68 @@ pass (rootlet):\n\
(eval 'x (rootlet)))\n\
\n\
returns 32"
- #define Q_eval s7_make_signature(sc, 3, sc->VALUES, sc->IS_LIST, sc->IS_LET)
+ #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol)
if (is_not_null(cdr(args)))
{
s7_pointer e;
e = cadr(args);
if (!is_let(e))
- return(wrong_type_argument_with_type(sc, sc->EVAL, 2, e, A_LET));
+ return(wrong_type_argument_with_type(sc, sc->eval_symbol, 2, e, a_let_string));
if (e == sc->rootlet)
- sc->envir = sc->NIL;
+ sc->envir = sc->nil;
else sc->envir = e;
}
sc->code = car(args);
if (s7_stack_top(sc) < 12)
- push_stack(sc, OP_BARRIER, sc->NIL, sc->NIL);
+ push_stack(sc, OP_BARRIER, sc->nil, sc->nil);
push_stack(sc, OP_EVAL, sc->args, sc->code);
- return(sc->NIL);
+ return(sc->nil);
}
s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
{
- bool old_longjmp;
- jmp_buf old_goto_start;
+ declare_jump_info();
- /* this can be called while we are in the eval loop (within eval_c_string for instance),
- * and if we reset the stack, the previously running evaluation steps off the end
- * of the stack == segfault.
- */
if (is_c_function(func))
- return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? */
-
- sc->temp1 = func; /* this is just GC protection */
- sc->temp2 = args;
+ return(c_function_call(func)(sc, _NFre(args))); /* no check for wrong-number-of-args -- is that reasonable? */
- old_longjmp = sc->longjmp_ok;
- memcpy((void *)old_goto_start, (void *)(sc->goto_start), sizeof(jmp_buf));
+ sc->temp1 = _NFre(func); /* this is feeble GC protection */
+ sc->temp2 = _NFre(args);
- /* if an error occurs during s7_call, and it is caught, catch (above) wants to longjmp
- * to its caller to complete the error handler evaluation so that the C stack is
- * cleaned up -- this means we have to have the longjmp location set here, but
- * we could get here from anywhere, so we need to save and restore the incoming
- * longjmp location.
- */
-
- sc->longjmp_ok = true;
- if (setjmp(sc->goto_start) != 0) /* returning from s7_error catch handler */
+ store_jump_info(sc);
+ set_jump_info(sc, S7_CALL_SET_JUMP);
+ if (jump_loc != NO_JUMP)
{
- sc->longjmp_ok = old_longjmp;
- memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));
-
- if ((sc->op == OP_ERROR_QUIT) &&
- (sc->longjmp_ok))
- longjmp(sc->goto_start, 1); /* this is trying to clear the C stack back to some clean state */
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->op);
- eval(sc, sc->op);
- /* sc->op can be OP_APPLY if s7_call raised an error that was caught (via catch) -- we're about to go to the error handler */
- return(sc->value);
+ if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */
+ (sc->stack_end == sc->stack_start))
+ push_stack(sc, OP_ERROR_QUIT, sc->nil, sc->nil);
}
+ else
+ {
+#if DEBUGGING
+ {
+ s7_pointer p;
+ int argnum;
+ /* incoming args may be non-s7 cells -- check now before they reach the GC */
+ for (argnum = 0, p = _NFre(args); is_pair(p); argnum++, p = _NFre(cdr(p)))
+ _NFre(car(p));
+ }
+#endif
+ push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
+ sc->args = args;
+ sc->code = func;
+ /* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example */
+ eval(sc, OP_APPLY);
+ }
+ restore_jump_info(sc);
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
- sc->args = args;
- sc->code = func;
- /* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example */
-
- eval(sc, OP_APPLY);
-
- sc->longjmp_ok = old_longjmp;
- memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));
return(sc->value);
}
@@ -47048,7 +47319,7 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic
* is currently an error (too many arguments)
* it should be (((lambda (arg) arg) "hi") 0) -> #\h
*
- * this applies to non-homogenous cases, so float|int-vectors don't get here
+ * this applies to non-homogeneous cases, so float|int-vectors don't get here
*/
switch (type(obj))
@@ -47063,7 +47334,7 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic
return(small_int((unsigned int)(character(string_ref_1(sc, obj, car(indices))))));
return(string_ref_1(sc, obj, car(indices)));
}
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, obj, indices)));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, obj, indices)));
case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */
obj = list_ref_1(sc, obj, car(indices));
@@ -47096,10 +47367,6 @@ static s7_pointer g_s7_version(s7_scheme *sc, s7_pointer args)
{
#define H_s7_version "(s7-version) returns some string describing the current s7"
#define Q_s7_version pcl_s
-
-#if WITH_COUNTS
- report_counts(sc);
-#endif
return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE));
}
@@ -47107,9 +47374,10 @@ static s7_pointer g_s7_version(s7_scheme *sc, s7_pointer args)
void s7_quit(s7_scheme *sc)
{
sc->longjmp_ok = false;
+
pop_input_port(sc);
stack_reset(sc);
- push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_DONE, sc->nil, sc->nil);
}
/* -------------------------------- exit -------------------------------- */
@@ -47157,7 +47425,7 @@ static s7_function all_x_function[OPT_MAX_DEFINED];
static bool is_all_x_safe(s7_scheme *sc, s7_pointer p)
{
return((!is_pair(p)) ||
- ((car(p) == sc->QUOTE) && (is_pair(cdr(p)))) || /* (if #t (quote . -1)) */
+ ((car(p) == sc->quote_symbol) && (is_pair(cdr(p)))) || /* (if #t (quote . -1)) */
((is_optimized(p)) && (is_all_x_op(optimize_op(p)))));
}
@@ -47210,25 +47478,25 @@ static s7_pointer all_x_c_char_eq(s7_scheme *sc, s7_pointer arg)
return(sc->T);
if (s7_is_character(c))
return(sc->F);
- method_or_bust(sc, c, sc->CHAR_EQ, set_plist_2(sc, c, caddr(arg)), T_CHARACTER, 1);
+ method_or_bust(sc, c, sc->char_eq_symbol, set_plist_2(sc, c, caddr(arg)), T_CHARACTER, 1);
}
static s7_pointer all_x_c_q(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T1_1) = cadr(cadr(arg));
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = cadr(cadr(arg));
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_s(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T1_1) = find_symbol_checked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_u(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_cdr_s(s7_scheme *sc, s7_pointer arg)
@@ -47259,163 +47527,163 @@ static s7_pointer all_x_null_s(s7_scheme *sc, s7_pointer arg)
static s7_pointer all_x_c_sc(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_uc(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(arg));
- car(sc->T2_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(arg));
+ car(sc->t2_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_cs(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T2_1) = cadr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t2_1) = cadr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_ss(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_uu(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(arg));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(arg));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_sss(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_3) = find_symbol_checked(sc, cadddr(arg));
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_3) = find_symbol_checked(sc, cadddr(arg));
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_uuu(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_1) = find_symbol_unchecked(sc, cadr(arg));
- car(sc->T3_2) = find_symbol_unchecked(sc, caddr(arg));
- car(sc->T3_3) = find_symbol_unchecked(sc, cadddr(arg));
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_unchecked(sc, cadr(arg));
+ car(sc->t3_2) = find_symbol_unchecked(sc, caddr(arg));
+ car(sc->t3_3) = find_symbol_unchecked(sc, cadddr(arg));
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_scs(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_3) = find_symbol_checked(sc, cadddr(arg));
- car(sc->T3_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_3) = find_symbol_checked(sc, cadddr(arg));
+ car(sc->t3_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_css(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_3) = find_symbol_checked(sc, cadddr(arg));
- car(sc->T3_1) = cadr(arg);
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_3) = find_symbol_checked(sc, cadddr(arg));
+ car(sc->t3_1) = cadr(arg);
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_csc(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_1) = cadr(arg);
- car(sc->T3_3) = cadddr(arg);
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_1) = cadr(arg);
+ car(sc->t3_3) = cadddr(arg);
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_ssc(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_3) = cadddr(arg);
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_3) = cadddr(arg);
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_sq(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = cadr(caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = cadr(caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opcq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = c_call(largs)(sc, cdr(largs));
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = c_call(largs)(sc, cdr(largs));
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_s_opcq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T2_2) = c_call(largs)(sc, cdr(largs));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_2) = c_call(largs)(sc, cdr(largs));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_c_opcq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T2_2) = c_call(largs)(sc, cdr(largs));
- car(sc->T2_1) = cadr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_2) = c_call(largs)(sc, cdr(largs));
+ car(sc->t2_1) = cadr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opcq_s(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = c_call(largs)(sc, cdr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = c_call(largs)(sc, cdr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opcq_c(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = c_call(largs)(sc, cdr(largs));
- car(sc->T2_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = c_call(largs)(sc, cdr(largs));
+ car(sc->t2_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opcq_opcq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = c_call(largs)(sc, cdr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, cdr(largs));
largs = caddr(arg);
- car(sc->T2_2) = c_call(largs)(sc, cdr(largs));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_2) = c_call(largs)(sc, cdr(largs));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T1_1) = c_call(largs)(sc, sc->T1_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t1_1) = c_call(largs)(sc, sc->t1_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_not_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- if (c_call(largs)(sc, sc->T1_1) == sc->F)
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ if (c_call(largs)(sc, sc->t1_1) == sc->F)
return(sc->T);
return(sc->F);
}
@@ -47424,17 +47692,17 @@ static s7_pointer all_x_c_opuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T1_1) = c_call(largs)(sc, sc->T1_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t1_1) = c_call(largs)(sc, sc->t1_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_not_opuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(largs));
- if (c_call(largs)(sc, sc->T1_1) == sc->F)
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(largs));
+ if (c_call(largs)(sc, sc->t1_1) == sc->F)
return(sc->T);
return(sc->F);
}
@@ -47443,283 +47711,283 @@ static s7_pointer all_x_c_opssq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(largs));
- car(sc->T1_1) = c_call(largs)(sc, sc->T2_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(largs));
+ car(sc->t1_1) = c_call(largs)(sc, sc->t2_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_opuuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(largs));
- car(sc->T1_1) = c_call(largs)(sc, sc->T2_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(largs));
+ car(sc->t1_1) = c_call(largs)(sc, sc->t2_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_opscq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = caddr(largs);
- car(sc->T1_1) = c_call(largs)(sc, sc->T2_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = caddr(largs);
+ car(sc->t1_1) = c_call(largs)(sc, sc->t2_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_opsqq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = cadr(caddr(largs));
- car(sc->T1_1) = c_call(largs)(sc, sc->T2_1);
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = cadr(caddr(largs));
+ car(sc->t1_1) = c_call(largs)(sc, sc->t2_1);
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_opssq_s(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opuuq_u(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opssq_c(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opsq_s(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opuq_u(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opsq_c(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_1) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_2) = caddr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_1) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_2) = caddr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_s_opssq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_u_opuuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_s_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_u_opuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_c_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = caddr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_1) = cadr(arg);
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_1) = cadr(arg);
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cdr(arg);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(car(largs)));
- sc->temp3 = c_call(car(largs))(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(car(largs)));
+ sc->temp3 = c_call(car(largs))(sc, sc->t1_1);
largs = cadr(largs);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opuq_opuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cdr(arg);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(car(largs)));
- sc->temp3 = c_call(car(largs))(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(car(largs)));
+ sc->temp3 = c_call(car(largs))(sc, sc->t1_1);
largs = cadr(largs);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t1_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opssq_opssq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cdr(arg);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(largs)));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(car(largs)));
- sc->temp3 = c_call(car(largs))(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(largs)));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(car(largs)));
+ sc->temp3 = c_call(car(largs))(sc, sc->t2_1);
largs = cadr(largs);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_opuuq_opuuq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cdr(arg);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(car(largs)));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(car(largs)));
- sc->temp3 = c_call(car(largs))(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(car(largs)));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(car(largs)));
+ sc->temp3 = c_call(car(largs))(sc, sc->t2_1);
largs = cadr(largs);
- car(sc->T2_1) = find_symbol_unchecked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_unchecked(sc, caddr(largs));
- car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_unchecked(sc, cadr(largs));
+ car(sc->t2_2) = find_symbol_unchecked(sc, caddr(largs));
+ car(sc->t2_2) = c_call(largs)(sc, sc->t2_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer all_x_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = cadr(cadr(code));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->T2_1);
- car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
- car(sc->T2_2) = caddr(code);
- return(c_call(code)(sc, sc->T2_1));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->t2_1);
+ car(sc->t2_1) = c_call(cadr(code))(sc, sc->t1_1);
+ car(sc->t2_2) = caddr(code);
+ return(c_call(code)(sc, sc->t2_1));
}
static s7_pointer all_x_c_a(s7_scheme *sc, s7_pointer arg)
{
- car(sc->T1_1) = c_call(cdr(arg))(sc, cadr(arg));
- return(c_call(arg)(sc, sc->T1_1));
+ car(sc->t1_1) = c_call(cdr(arg))(sc, cadr(arg));
+ return(c_call(arg)(sc, sc->t1_1));
}
static s7_pointer all_x_c_ssa(s7_scheme *sc, s7_pointer arg)
{
sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_3) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_3) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_sas(s7_scheme *sc, s7_pointer arg)
{
sc->temp3 = c_call(cddr(arg))(sc, caddr(arg));
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_3) = find_symbol_checked(sc, cadddr(arg));
- car(sc->T3_2) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_3) = find_symbol_checked(sc, cadddr(arg));
+ car(sc->t3_2) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_sca(s7_scheme *sc, s7_pointer arg)
{
sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
- car(sc->T3_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T3_2) = caddr(arg);
- car(sc->T3_3) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t3_2) = caddr(arg);
+ car(sc->t3_3) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_csa(s7_scheme *sc, s7_pointer arg)
{
sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
- car(sc->T3_1) = cadr(arg);
- car(sc->T3_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T3_3) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = cadr(arg);
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t3_3) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t3_1));
}
static s7_pointer all_x_c_cas(s7_scheme *sc, s7_pointer arg)
{
sc->temp3 = c_call(cddr(arg))(sc, caddr(arg));
- car(sc->T3_1) = cadr(arg);
- car(sc->T3_3) = find_symbol_checked(sc, cadddr(arg));
- car(sc->T3_2) = sc->temp3;
- sc->temp3 = sc->NIL;
- return(c_call(arg)(sc, sc->T3_1));
+ car(sc->t3_1) = cadr(arg);
+ car(sc->t3_3) = find_symbol_checked(sc, cadddr(arg));
+ car(sc->t3_2) = sc->temp3;
+ sc->temp3 = sc->nil;
+ return(c_call(arg)(sc, sc->t3_1));
}
static void all_x_function_init(void)
@@ -47774,6 +48042,7 @@ static void all_x_function_init(void)
static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_sym_t *checker)
{
+ /* fprintf(stderr, "all_x_eval: %s %s\n", DISPLAY(arg), DISPLAY(e)); */
if (is_pair(arg))
{
if (is_optimized(arg))
@@ -47793,14 +48062,14 @@ static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_
return(all_x_c_c);
case HOP_SAFE_C_S:
- if (car(arg) == sc->CDR)
+ if (car(arg) == sc->cdr_symbol)
{
if (checker(sc, cadr(arg), e))
return(all_x_cdr_u);
return(all_x_cdr_s);
}
- if (car(arg) == sc->CAR) return(all_x_car_s);
- if (car(arg) == sc->IS_NULL) return(all_x_null_s);
+ if (car(arg) == sc->car_symbol) return(all_x_car_s);
+ if (car(arg) == sc->is_null_symbol) return(all_x_null_s);
if (checker(sc, cadr(arg), e)) /* all we want here is assurance it's not going to be unbound */
return(all_x_c_u);
return(all_x_c_s);
@@ -47826,11 +48095,11 @@ static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_
case HOP_SAFE_C_opSq:
if (checker(sc, cadr(cadr(arg)), e))
{
- if (car(arg) == sc->NOT)
+ if (car(arg) == sc->not_symbol)
return(all_x_c_not_opuq);
return(all_x_c_opuq);
}
- if (car(arg) == sc->NOT)
+ if (car(arg) == sc->not_symbol)
return(all_x_c_not_opsq);
return(all_x_c_opsq);
@@ -47885,7 +48154,7 @@ static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_
return(all_x_function[optimize_op(arg)]);
}
}
- if (car(arg) == sc->QUOTE)
+ if (car(arg) == sc->quote_symbol)
return(all_x_q);
return(NULL);
}
@@ -47903,7 +48172,7 @@ static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_
static s7_function cond_all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e)
{
- if (arg == sc->ELSE)
+ if (arg == sc->else_object)
return(all_x_else);
return(all_x_eval(sc, arg, e, let_symbol_is_safe));
}
@@ -47915,10 +48184,11 @@ static s7_pointer make_counter(s7_scheme *sc, s7_pointer iter)
{
s7_pointer x;
new_cell(sc, x, T_COUNTER);
- counter_result(x) = sc->NIL;
+ counter_result(x) = sc->nil;
counter_list(x) = iter; /* iterator */
counter_capture(x) = 0; /* will be capture_let_counter */
- counter_set_let(x, sc->NIL); /* will be the saved env */
+ counter_set_let(x, sc->nil); /* will be the saved env */
+ counter_slots(x) = sc->nil; /* local env slots before body is evalled */
return(x);
}
@@ -47926,7 +48196,7 @@ static s7_pointer g_for_each(s7_scheme *sc, s7_pointer args)
{
#define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \
Each object can be a list, string, vector, hash-table, or any other sequence."
- #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->T, sc->IS_PROCEDURE, sc->LENGTH)
+ #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_procedure_symbol, sc->is_sequence_symbol)
s7_pointer p, f;
int len;
@@ -47947,16 +48217,16 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
c = make_counter(sc, p);
counter_result(c) = p;
push_stack(sc, OP_FOR_EACH_2, c, f);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
if (!is_applicable(f))
- method_or_bust_with_type(sc, f, sc->FOR_EACH, args, SOMETHING_APPLICABLE, 1);
+ method_or_bust_with_type(sc, f, sc->for_each_symbol, args, something_applicable_string, 1);
for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++)
{
if ((!is_sequence(car(p))) && (!is_iterator(car(p))))
- return(simple_wrong_type_argument_with_type(sc, sc->FOR_EACH, car(p), A_SEQUENCE));
+ return(simple_wrong_type_argument_with_type(sc, sc->for_each_symbol, car(p), a_sequence_string));
if (is_null(car(p)))
got_nil = true;
}
@@ -47966,13 +48236,13 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
static s7_pointer for_each_args_error = NULL;
if (!for_each_args_error)
for_each_args_error = s7_make_permanent_string("for-each ~A: ~A args?");
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, for_each_args_error, f, small_int(len))));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, for_each_args_error, f, small_int(len))));
}
- if (got_nil) return(sc->UNSPECIFIED);
+ if (got_nil) return(sc->unspecified);
sc->temp3 = args;
- sc->z = sc->NIL; /* don't use sc->args here -- it needs GC protection until we get the iterators */
+ sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */
for (p = cdr(args); is_not_null(p); p = cdr(p))
{
s7_pointer iter;
@@ -47981,9 +48251,9 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
iter = s7_make_iterator(sc, iter);
sc->z = cons(sc, iter, sc->z);
}
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
- sc->x = make_list(sc, len, sc->NIL);
+ sc->x = make_list(sc, len, sc->nil);
sc->z = safe_reverse_in_place(sc, sc->z);
sc->z = cons(sc, sc->z, sc->x);
@@ -48000,20 +48270,20 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
s7_pointer x, y;
x = caar(sc->z);
y = cdr(sc->z);
- sc->z = sc->NIL;
+ sc->z = sc->nil;
while (true)
{
car(y) = s7_iterate(sc, x);
if (iterator_is_at_end(x))
{
pop_stack(sc);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
func(sc, y);
}
}
iters = sc->z;
- sc->z = sc->NIL;
+ sc->z = sc->nil;
while (true)
{
s7_pointer x, y;
@@ -48024,7 +48294,7 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
{
pop_stack(sc);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
}
func(sc, cdr(iters));
@@ -48048,8 +48318,8 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
s7_pointer slot, iter;
iter = caar(sc->z);
- sc->z = sc->NIL;
- push_stack(sc, OP_NO_OP, iter, f); /* temporary GC protection?? */
+ sc->z = sc->nil;
+ push_stack(sc, OP_NO_OP, iter, f);
sc->envir = new_frame_in_env(sc, sc->envir);
slot = make_slot_1(sc, sc->envir, car(closure_args(f)), sc->F);
func = all_x_eval(sc, expr, sc->envir, let_symbol_is_safe);
@@ -48064,18 +48334,18 @@ Each object can be a list, string, vector, hash-table, or any other sequence."
if (iterator_is_at_end(iter))
{
pop_stack(sc);
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
func(sc, expr);
}
}
push_stack(sc, OP_FOR_EACH_1, make_counter(sc, caar(sc->z)), f);
- sc->z = sc->NIL;
- return(sc->UNSPECIFIED);
+ sc->z = sc->nil;
+ return(sc->unspecified);
}
push_stack(sc, OP_FOR_EACH, sc->z, f);
- sc->z = sc->NIL;
- return(sc->UNSPECIFIED);
+ sc->z = sc->nil;
+ return(sc->unspecified);
}
@@ -48085,7 +48355,7 @@ static s7_pointer g_map(s7_scheme *sc, s7_pointer args)
{
#define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \
a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects."
- #define Q_map s7_make_circular_signature(sc, 2, 3, sc->IS_LIST, sc->IS_PROCEDURE, sc->LENGTH)
+ #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)
s7_pointer p, f;
int len;
@@ -48093,12 +48363,12 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
f = car(args); /* the function */
if (!is_applicable(f))
- method_or_bust_with_type(sc, f, sc->MAP, args, SOMETHING_APPLICABLE, 1);
+ method_or_bust_with_type(sc, f, sc->map_symbol, args, something_applicable_string, 1);
for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++)
{
if ((!is_sequence(car(p))) && (!is_iterator(car(p))))
- return(simple_wrong_type_argument_with_type(sc, sc->MAP, car(p), A_SEQUENCE));
+ return(simple_wrong_type_argument_with_type(sc, sc->map_symbol, car(p), a_sequence_string));
if (is_null(car(p)))
got_nil = true;
}
@@ -48109,12 +48379,12 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
static s7_pointer map_args_error = NULL;
if (!map_args_error)
map_args_error = s7_make_permanent_string("map ~A: ~A args?");
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, map_args_error, f, small_int(len))));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, map_args_error, f, small_int(len))));
}
- if (got_nil) return(sc->NIL);
+ if (got_nil) return(sc->nil);
- if ((f == slot_value(global_slot(sc->VALUES))) &&
+ if ((f == slot_value(global_slot(sc->values_symbol))) &&
(is_null(cddr(args))) &&
(!has_methods(cadr(args))))
{
@@ -48124,7 +48394,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
}
sc->temp3 = args;
- sc->z = sc->NIL; /* don't use sc->args here -- it needs GC protection until we get the iterators */
+ sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */
for (p = cdr(args); is_not_null(p); p = cdr(p))
{
s7_pointer iter;
@@ -48134,7 +48404,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
sc->z = cons(sc, iter, sc->z);
}
sc->z = safe_reverse_in_place(sc, sc->z);
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
/* if function is safe c func, do the map locally */
if ((is_safe_procedure(f)) &&
@@ -48143,12 +48413,12 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
s7_function func;
s7_pointer val, val1, old_args, iter_list;
- val1 = cons(sc, sc->z, make_list(sc, len, sc->NIL));
+ val1 = cons(sc, sc->z, make_list(sc, len, sc->nil));
iter_list = sc->z;
- sc->z = sc->NIL;
old_args = sc->args;
func = c_function_call(f);
- push_stack(sc, OP_NO_OP, iter_list, val = cons(sc, sc->NIL, sc->code)); /* temporary GC protection */
+ push_stack(sc, OP_NO_OP, iter_list, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection */
+ sc->z = sc->nil;
while (true)
{
@@ -48164,8 +48434,13 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
}
}
z = func(sc, cdr(val1)); /* can this contain multiple-values? */
- if (z != sc->NO_VALUE)
+ if (z != sc->no_value)
car(val) = cons(sc, z, car(val));
+
+ /* to mimic map values handling elsewhere:
+ * ((lambda args (format *stderr* "~A~%" (map values args))) (values)): ()
+ * ((lambda args (format *stderr* "~A~%" (map values args))) (values #<unspecified>)): #<unspecified> etc
+ */
}
}
@@ -48186,11 +48461,11 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
s7_pointer slot, iter, val, z;
iter = car(sc->z);
- sc->z = sc->NIL;
- push_stack(sc, OP_NO_OP, sc->args, val = cons(sc, sc->NIL, f));
+ push_stack(sc, OP_NO_OP, sc->args, val = cons(sc, sc->nil, cons(sc, f, iter))); /* second cons is GC protection */
sc->envir = new_frame_in_env(sc, sc->envir);
slot = make_slot_1(sc, sc->envir, car(closure_args(f)), sc->F);
func = all_x_eval(sc, expr, sc->envir, let_symbol_is_safe);
+ sc->z = sc->nil;
if (func == all_x_c_c)
{
func = c_callee(expr);
@@ -48205,18 +48480,18 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
return(safe_reverse_in_place(sc, car(val)));
}
z = func(sc, expr);
- if (z != sc->NO_VALUE)
+ if (z != sc->no_value)
car(val) = cons(sc, z, car(val));
}
}
push_stack(sc, OP_MAP_1, make_counter(sc, car(sc->z)), f);
- sc->z = sc->NIL;
- return(sc->NIL);
+ sc->z = sc->nil;
+ return(sc->nil);
}
push_stack(sc, OP_MAP, make_counter(sc, sc->z), f);
- sc->z = sc->NIL;
- return(sc->NIL);
+ sc->z = sc->nil;
+ return(sc->nil);
}
@@ -48305,7 +48580,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
* set code to first and value to last
*/
if (is_null(args))
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
if (is_null(cdr(args)))
return(car(args));
@@ -48331,19 +48606,19 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
case OP_LET_ONE_1:
case OP_LET_Z_1:
set_multiple_value(args);
- eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->LET, args);
+ eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->let_symbol, args);
/* "some variable" is ugly, but the actual name is tricky to find at this point --
* it's in main_stack_args, but finding the right one is a mess. It's isn't sc->code.
*/
case OP_LET_STAR1:
set_multiple_value(args);
- eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->LET_STAR, args);
+ eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->let_star_symbol, args);
case OP_LETREC1:
case OP_LETREC_STAR1:
set_multiple_value(args);
- eval_error_with_caller(sc, "~A: can't bind some variable to ~S", (sc->op == OP_LETREC1) ? sc->LETREC : sc->LETREC_STAR, args);
+ eval_error_with_caller(sc, "~A: can't bind some variable to ~S", (sc->op == OP_LETREC1) ? sc->letrec_symbol : sc->letrec_star_symbol, args);
/* handle 'and' and 'or' specially */
case OP_AND1:
@@ -48403,12 +48678,12 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
s7_pointer s7_values(s7_scheme *sc, s7_pointer args)
{
#define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')"
- #define Q_values s7_make_circular_signature(sc, 1, 2, sc->VALUES, sc->T)
+ #define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
if (is_null(args)) /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */
- return(sc->NO_VALUE);
+ return(sc->no_value);
- /* this was sc->NIL until 16-Jun-10,
+ /* this was sc->nil until 16-Jun-10,
* nil is consistent with the implied values call in call/cc (if no args, the continuation function returns ())
* hmmm...
* Guile complains ("too few values returned to continuation") in the call/cc case, and
@@ -48445,7 +48720,7 @@ s7_pointer s7_values(s7_scheme *sc, s7_pointer args)
static s7_pointer g_qq_list(s7_scheme *sc, s7_pointer args)
{
#define H_qq_list "({list} ...) returns its arguments in a list (internal to quasiquote)"
- #define Q_qq_list pcl_t
+ #define Q_qq_list s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T)
s7_pointer x, y, px;
@@ -48453,7 +48728,7 @@ static s7_pointer g_qq_list(s7_scheme *sc, s7_pointer args)
return(args);
for (x = args; is_pair(x); x = cdr(x))
- if (car(x) == sc->NO_VALUE)
+ if (car(x) == sc->no_value)
break;
if (is_null(x))
@@ -48462,10 +48737,11 @@ static s7_pointer g_qq_list(s7_scheme *sc, s7_pointer args)
/* this is not maximally efficient, but it's not important:
* we've hit the rare special case where ({apply_values} ())) needs to be ignored
* in the splicing process (i.e. the arglist acts as if the thing never happened)
+ * ({list} ({apply_values} ())) -> (), also ({list} ({apply_values})) -> ()
*/
- px = sc->NIL;
+ px = sc->nil;
for (x = args, y = args; is_pair(y); y = cdr(y))
- if (car(y) != sc->NO_VALUE)
+ if (car(y) != sc->no_value)
{
car(x) = car(y);
px = x;
@@ -48473,14 +48749,14 @@ static s7_pointer g_qq_list(s7_scheme *sc, s7_pointer args)
}
if ((is_not_null(y)) &&
- (y != sc->NO_VALUE))
+ (y != sc->no_value))
cdr(x) = cdr(y);
else
{
sc->no_values--;
if (is_null(px))
- return(sc->NIL);
- cdr(px) = sc->NIL;
+ return(sc->nil);
+ cdr(px) = sc->nil;
}
return(args);
}
@@ -48495,7 +48771,7 @@ static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args)
if (is_null(args))
{
sc->no_values++;
- return(sc->NO_VALUE);
+ return(sc->no_value);
}
if (is_null(cdr(args)))
x = car(args);
@@ -48506,7 +48782,7 @@ static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args)
if (is_null(x))
{
sc->no_values++;
- return(sc->NO_VALUE);
+ return(sc->no_value);
}
return(g_values(sc, x));
}
@@ -48539,7 +48815,7 @@ static bool is_simple_code(s7_scheme *sc, s7_pointer form)
}
else
{
- if ((car(tmp) == sc->UNQUOTE) ||
+ if ((car(tmp) == sc->unquote_symbol) ||
((is_null(car(tmp))) && (is_null(cdr(tmp)))))
return(false);
}
@@ -48557,15 +48833,14 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
if (!is_pair(form))
{
- if (!is_symbol(form))
- {
- /* things that evaluate to themselves don't need to be quoted. */
- return(form);
- }
- return(list_2(sc, sc->QUOTE, form));
+ if ((is_symbol(form)) &&
+ (!is_keyword(form)))
+ return(list_2(sc, sc->quote_symbol, form));
+ /* things that evaluate to themselves don't need to be quoted. */
+ return(form);
}
- if (car(form) == sc->UNQUOTE)
+ if (car(form) == sc->unquote_symbol)
{
if (is_not_null(cddr(form)))
eval_error(sc, "unquote: too many arguments, ~S", form);
@@ -48578,7 +48853,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
/* if no element of the list is a list or unquote, just return the original quoted */
if (is_simple_code(sc, form))
- return(list_2(sc, sc->QUOTE, form));
+ return(list_2(sc, sc->quote_symbol, form));
{
int len, i, loc;
@@ -48589,7 +48864,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
if (len == 0)
{
/* a circular form, apparently */
- return(list_2(sc, sc->QUOTE, form));
+ return(list_2(sc, sc->quote_symbol, form));
}
if (len < 0)
{
@@ -48600,18 +48875,18 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
old_scw = sc->w;
loc = s7_gc_protect(sc, old_scw);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = 0; i <= len; i++)
- sc->w = cons(sc, sc->NIL, sc->w);
+ sc->w = cons(sc, sc->nil, sc->w);
- car(sc->w) = sc->QQ_List;
+ car(sc->w) = sc->qq_list_function;
if (!dotted)
{
for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq))
{
if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */
- (cadr(orig) == sc->UNQUOTE))
+ (cadr(orig) == sc->unquote_symbol))
{
/* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2)
* `(1 . ,@'((2 3))) -> (1 unquote ({apply_values} '((2 3)))) -> ({append} ({list} 1) ({apply_values} '((2 3)))) -> '(1 2 3)
@@ -48620,8 +48895,8 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
* `(1 . (,@'(2 3))) works in both cases, and `(1 . (,(+ 1 1)))
*/
car(bq) = g_quasiquote_1(sc, car(orig));
- cdr(bq) = sc->NIL;
- sc->w = list_3(sc, sc->QQ_Append, sc->w, caddr(orig));
+ cdr(bq) = sc->nil;
+ sc->w = list_3(sc, sc->qq_append_function, sc->w, caddr(orig));
break;
}
else car(bq) = g_quasiquote_1(sc, car(orig));
@@ -48635,7 +48910,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
car(bq) = g_quasiquote_1(sc, car(orig));
car(bq) = g_quasiquote_1(sc, car(orig));
- sc->w = list_3(sc, sc->QQ_Append, sc->w, g_quasiquote_1(sc, cdr(orig)));
+ sc->w = list_3(sc, sc->qq_append_function, sc->w, g_quasiquote_1(sc, cdr(orig)));
/* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */
}
@@ -48685,7 +48960,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
switch (c)
{
case EOF:
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected '#' at end of input")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected '#' at end of input")));
break;
case '(':
@@ -48713,14 +48988,14 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
s7_int dig;
d = inchar(pt);
if (d == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #n...")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #n...")));
dig = digits[d];
if (dig >= 10) break;
dims = dig + (dims * 10);
if ((dims <= 0) ||
(dims > S7_SHORT_MAX))
- s7_error(sc, sc->READ_ERROR, set_elist_2(sc, make_string_wrapper(sc, "overflow while reading #nD: ~A"), make_integer(sc, dims)));
+ s7_error(sc, sc->read_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "overflow while reading #nD: ~A"), make_integer(sc, dims)));
sc->strbuf[loc++] = d;
}
sc->strbuf[loc++] = d;
@@ -48728,7 +49003,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
{
d = inchar(pt);
if (d == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #nD...")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #nD...")));
sc->strbuf[loc++] = d;
if (d == '(')
{
@@ -48748,12 +49023,12 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
int d;
d = inchar(pt);
if (d == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u...")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u...")));
if (d == '8')
{
d = inchar(pt);
if (d == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u8...")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u8...")));
if (d == '(')
return(TOKEN_BYTE_VECTOR);
backchar(d, pt);
@@ -48763,7 +49038,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
}
break;
- case ':': /* turn #: into : -- this is for compatibility with Guile, #:optional in particular.
+ case ':': /* turn #: into : -- this is for compatibility with Guile, sigh.
* I just noticed that Rick is using this -- I'll just leave it alone.
* but that means : readers need to handle this case specially.
* I don't think #! is special anymore -- maybe remove that code?
@@ -48802,7 +49077,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
last_char = c;
}
if (c == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #!")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #!")));
return(token(sc));
}
@@ -48820,7 +49095,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
{
c = fgetc(port_file(pt));
if (c == EOF)
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #|")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #|")));
if ((c == '#') &&
(last_char == '|'))
break;
@@ -48844,7 +49119,7 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
if ((!p) || (p >= pend))
{
port_position(pt) = port_data_size(pt);
- s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #|")));
+ s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #|")));
}
if (p[1] == '#')
break;
@@ -48981,6 +49256,19 @@ static int read_x_char(s7_pointer pt)
}
+static s7_pointer unknown_string_constant(s7_scheme *sc, int c)
+{
+ /* check *read-error-hook* */
+ if (hook_has_functions(sc->read_error_hook))
+ {
+ s7_pointer result;
+ result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->F, s7_make_character(sc, (unsigned char)c)));
+ if (s7_is_character(result))
+ return(result);
+ }
+ return(sc->T);
+}
+
static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt)
{
/* sc->F => error
@@ -49098,15 +49386,26 @@ static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt)
{
c = read_x_char(pt);
if (c == NOT_AN_X_CHAR)
- return(sc->T);
+ {
+ s7_pointer result;
+ result = unknown_string_constant(sc, c);
+ if (s7_is_character(result))
+ sc->strbuf[i++] = character(result);
+ else return(result);
+ }
sc->strbuf[i++] = (unsigned char)c;
}
else
{
/* if (!is_white_space(c)) */ /* changed 8-Apr-12 */
if ((c != '\n') && (c != '\r'))
- return(sc->T);
-
+ {
+ s7_pointer result;
+ result = unknown_string_constant(sc, c);
+ if (s7_is_character(result))
+ sc->strbuf[i++] = character(result);
+ else return(result);
+ }
/* #f here would give confusing error message "end of input", so return #t=bad backslash.
* this is not optimal. It's easy to forget that backslash needs to be backslashed.
*
@@ -49139,10 +49438,10 @@ static s7_pointer read_expression(s7_scheme *sc)
switch (sc->tok)
{
case TOKEN_EOF:
- return(sc->EOF_OBJECT);
+ return(sc->eof_object);
case TOKEN_BYTE_VECTOR:
- push_stack_no_code(sc, OP_READ_BYTE_VECTOR, sc->NIL);
+ push_stack_no_code(sc, OP_READ_BYTE_VECTOR, sc->nil);
sc->tok = TOKEN_LEFT_PAREN;
break;
@@ -49154,7 +49453,7 @@ static s7_pointer read_expression(s7_scheme *sc)
sc->tok = token(sc);
if (sc->tok == TOKEN_RIGHT_PAREN)
- return(sc->NIL);
+ return(sc->nil);
if (sc->tok == TOKEN_DOT)
{
@@ -49166,37 +49465,29 @@ static s7_pointer read_expression(s7_scheme *sc)
if (sc->tok == TOKEN_EOF)
return(missing_close_paren_error(sc));
- push_stack_no_code(sc, OP_READ_LIST, sc->NIL);
+ push_stack_no_code(sc, OP_READ_LIST, sc->nil);
/* here we need to clear args, but code is ignored */
check_stack_size(sc);
break;
case TOKEN_QUOTE:
- push_stack_no_code(sc, OP_READ_QUOTE, sc->NIL);
+ push_stack_no_code(sc, OP_READ_QUOTE, sc->nil);
sc->tok = token(sc);
break;
case TOKEN_BACK_QUOTE:
sc->tok = token(sc);
-#if WITH_QUASIQUOTE_VECTOR
- if (sc->tok == TOKEN_VECTOR)
- {
- push_stack_no_code(sc, OP_READ_QUASIQUOTE_VECTOR, sc->w);
- sc->tok = TOKEN_LEFT_PAREN;
- }
- else
-#endif
- push_stack_no_code(sc, OP_READ_QUASIQUOTE, sc->NIL);
+ push_stack_no_code(sc, OP_READ_QUASIQUOTE, sc->nil);
break;
case TOKEN_COMMA:
- push_stack_no_code(sc, OP_READ_UNQUOTE, sc->NIL);
+ push_stack_no_code(sc, OP_READ_UNQUOTE, sc->nil);
sc->tok = token(sc);
break;
case TOKEN_AT_MARK:
- push_stack_no_code(sc, OP_READ_APPLY_VALUES, sc->NIL);
+ push_stack_no_code(sc, OP_READ_APPLY_VALUES, sc->nil);
sc->tok = token(sc);
break;
@@ -49240,7 +49531,7 @@ static s7_pointer read_expression(s7_scheme *sc)
}
}
/* we never get here */
- return(sc->NIL);
+ return(sc->nil);
}
@@ -49253,7 +49544,7 @@ static s7_pointer loaded_library(s7_scheme *sc, const char *file)
for (p = slot_value(sc->libraries); is_pair(p); p = cdr(p))
if (local_strcmp(file, string_value(caar(p))))
return(cdar(p));
- return(sc->NIL);
+ return(sc->nil);
}
static s7_pointer find_closure_let(s7_scheme *sc, s7_pointer cur_env)
@@ -49262,7 +49553,7 @@ static s7_pointer find_closure_let(s7_scheme *sc, s7_pointer cur_env)
for (e = cur_env; is_let(e); e = outlet(e))
if (is_function_env(e))
return(e);
- return(sc->NIL);
+ return(sc->nil);
}
static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
@@ -49270,13 +49561,13 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
/* this always occurs in a context where we're trying to find anything, so I'll move a couple of those checks here
*/
if (has_ref_fallback(sc->envir)) /* an experiment -- see s7test (with-let *db* (+ int (length str))) */
- check_method(sc, sc->envir, sc->LET_REF_FALLBACK, sc->w = list_2(sc, sc->envir, sym));
+ check_method(sc, sc->envir, sc->let_ref_fallback_symbol, sc->w = list_2(sc, sc->envir, sym));
/* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */
- if (sym == sc->UNQUOTE)
- eval_error(sc, "unquote (',') occurred outside quasiquote: ~S", sc->cur_code);
+ if (sym == sc->unquote_symbol)
+ eval_error(sc, "unquote (',') occurred outside quasiquote: ~S", current_code(sc));
- if (sym == sc->__FUNC__) /* __func__ is a sort of symbol macro */
+ if (sym == sc->__func___symbol) /* __func__ is a sort of symbol macro */
{
s7_pointer env;
env = find_closure_let(sc, sc->envir);
@@ -49289,7 +49580,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
return(list_3(sc, funclet_function(env), sc->file_names[let_file(env)], make_integer(sc, let_line(env))));
return(funclet_function(env));
}
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
if (safe_strcmp(symbol_name(sym), "|#"))
@@ -49299,12 +49590,12 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
*/
if ((sc->autoload_names) ||
(is_hash_table(sc->autoload_table)) ||
- (is_not_null(s7_hook_functions(sc, sc->unbound_variable_hook))))
+ (hook_has_functions(sc->unbound_variable_hook)))
{
s7_pointer result, cur_code, value, code, args, cur_env, x, z;
/* sc->args and sc->code are pushed on the stack by s7_call, then
- * restored by eval, so they are normally protected, but sc->value and sc->cur_code are
- * not protected (yet). We need sc->cur_code so that the possible eventual error
+ * restored by eval, so they are normally protected, but sc->value and current_code(sc) are
+ * not protected (yet). We need current_code(sc) so that the possible eventual error
* call can tell where the error occurred, and we need sc->value because it might
* be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered
* by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value
@@ -49314,23 +49605,24 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
args = sc->args;
code = sc->code;
value = sc->value;
- cur_code = sc->cur_code;
+ cur_code = current_code(sc);
cur_env = sc->envir;
- result = sc->UNDEFINED;
+ result = sc->undefined;
x = sc->x;
z = sc->z;
- sc->temp7 = s7_list(sc, 6, code, args, value, cur_code, x, z);
+ sc->temp7 = cons(sc, code, cons(sc, args, cons(sc, value, cons(sc, cur_code, cons(sc, x, cons(sc, z, sc->nil)))))); /* not s7_list (debugger checks) */
if (!is_pair(cur_code))
{
/* isolated typo perhaps -- no pair to hold the position info, so make one.
- * sc->cur_code is GC-protected, so this should be safe.
+ * current_code(sc) is GC-protected, so this should be safe.
*/
- cur_code = cons(sc, sym, sc->NIL); /* the error will say "(sym)" which is not too misleading */
+ cur_code = cons(sc, sym, sc->nil); /* the error will say "(sym)" which is not too misleading */
pair_set_line(cur_code, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
set_has_line_number(cur_code);
}
+#if (!DISABLE_AUTOLOAD)
/* check sc->autoload_names */
if (sc->autoload_names)
{
@@ -49349,19 +49641,21 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
if (!is_let(e))
e = s7_load(sc, file);
result = s7_symbol_value(sc, sym); /* calls find_symbol, does not trigger unbound_variable search */
- if ((result == sc->UNDEFINED) &&
+ if ((result == sc->undefined) &&
(is_let(e)))
{
result = s7_let_ref(sc, e, sym);
/* I think to be consistent we should add '(sym . result) to the global env */
- if (result != sc->UNDEFINED)
- s7_define(sc, sc->NIL, sym, result);
+ if (result != sc->undefined)
+ s7_define(sc, sc->nil, sym, result);
}
}
}
+#endif
- if (result == sc->UNDEFINED)
+ if (result == sc->undefined)
{
+#if (!DISABLE_AUTOLOAD)
/* check the *autoload* hash table */
if (is_hash_table(sc->autoload_table))
{
@@ -49375,20 +49669,21 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
else
{
if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */
- s7_call(sc, val, s7_cons(sc, sc->envir, sc->NIL));
+ s7_call(sc, val, s7_cons(sc, sc->envir, sc->nil));
}
result = s7_symbol_value(sc, sym); /* calls find_symbol, does not trigger unbound_variable search */
}
+#endif
/* check *unbound-variable-hook* */
- if ((result == sc->UNDEFINED) &&
- (is_not_null(sc->unbound_variable_hook)))
+ if ((result == sc->undefined) &&
+ (hook_has_functions(sc->unbound_variable_hook)))
{
/* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */
s7_pointer old_hook;
old_hook = sc->unbound_variable_hook;
- car(sc->Z2_1) = old_hook;
+ car(sc->z2_1) = old_hook;
sc->unbound_variable_hook = sc->error_hook; /* avoid the infinite loop mentioned above */
result = s7_call(sc, old_hook, list_1(sc, sym)); /* not s7_apply_function */
sc->unbound_variable_hook = old_hook;
@@ -49396,16 +49691,16 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
}
sc->value = _NFre(value);
- sc->cur_code = cur_code;
+ set_current_code(sc, cur_code);
sc->args = args;
sc->code = code;
sc->envir = cur_env;
sc->x = x;
sc->z = z;
- sc->temp7 = sc->NIL;
+ sc->temp7 = sc->nil;
- if ((result != sc->UNDEFINED) &&
- (result != sc->UNSPECIFIED))
+ if ((result != sc->undefined) &&
+ (result != sc->unspecified))
return(result);
}
eval_error(sc, "~A: unbound variable", sym);
@@ -49437,7 +49732,7 @@ static s7_pointer assign_syntax(s7_scheme *sc, const char *name, opcode_t op, s7
global_slot(x) = permanent_slot(x, syn);
initial_slot(x) = permanent_slot(x, syn);
typeflag(x) = SYNTACTIC_TYPE;
- symbol_set_local(x, 0LL, sc->NIL);
+ symbol_set_local(x, 0LL, sc->nil);
symbol_syntax_op(x) = op;
return(x);
}
@@ -49455,7 +49750,7 @@ static s7_pointer assign_internal_syntax(s7_scheme *sc, const char *name, opcode
unheap(x);
set_type(x, T_SYMBOL);
set_symbol_name_cell(x, str);
- symbol_set_local(x, 0LL, sc->NIL);
+ symbol_set_local(x, 0LL, sc->nil);
symbol_syntax_op(x) = op;
syn = alloc_pointer();
@@ -49480,7 +49775,7 @@ static s7_pointer assign_internal_syntax(s7_scheme *sc, const char *name, opcode
static s7_int c_pair_line_number(s7_scheme *sc, s7_pointer p)
{
if (!is_pair(p))
- int_method_or_bust(sc, p, sc->PAIR_LINE_NUMBER, set_plist_1(sc, p), T_PAIR, 0);
+ int_method_or_bust(sc, p, sc->pair_line_number_symbol, set_plist_1(sc, p), T_PAIR, 0);
if (has_line_number(p))
{
@@ -49494,13 +49789,35 @@ static s7_int c_pair_line_number(s7_scheme *sc, s7_pointer p)
static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args)
{
#define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair'"
- #define Q_pair_line_number s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_PAIR)
+ #define Q_pair_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol)
return(make_integer(sc, c_pair_line_number(sc, car(args))));
}
PF_TO_IF(pair_line_number, c_pair_line_number)
+static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args)
+{
+ #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'"
+ #define Q_pair_filename s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_pair_symbol)
+ s7_pointer p;
+ p = car(args);
+
+ if (!is_pair(p))
+ {
+ check_method(sc, p, sc->pair_filename_symbol, args);
+ return(simple_wrong_type_argument(sc, sc->pair_filename_symbol, p, T_PAIR));
+ }
+ if (has_line_number(p))
+ {
+ int x;
+ x = pair_line(p);
+ return(remembered_file_name(x));
+ }
+ return(sc->F);
+}
+
+
static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
s7_pointer x;
@@ -49511,12 +49828,12 @@ static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym,
/* x is our binding (symbol . value) */
if (is_not_checked_slot(x))
set_checked_slot(x); /* this is a special use of this bit, I think */
- else return(s7_error(sc, sc->WRONG_TYPE_ARG,
+ else return(s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, make_string_wrapper(sc, "~A: parameter set twice, ~S in ~S"), closure_name(sc, sc->code), sym, sc->args)));
slot_set_value(x, val);
return(val);
}
- return(sc->NO_VALUE);
+ return(sc->no_value);
}
@@ -49533,17 +49850,13 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
*
* for each actual arg, if it's not a keyword that matches a member of the
* template, bind it to its current (place-wise) arg, else bind it to
- * that arg. If it's the symbol :key or :optional, just go on.
- * If it's :rest bind the next arg to the trailing args at this point.
+ * that arg. If it's :rest bind the next arg to the trailing args at this point.
* All args can be accessed by their name as a keyword.
- * In other words (define* (hi (a 1)) ...) is the same as (define* (hi :key (a 1)) ...) etc.
*
* all args are optional, any arg with no default value defaults to #f.
* but the rest arg should default to ().
* I later decided to add two warnings: if a parameter is set twice and if
* an unknown keyword is seen in a keyword position and there is no rest arg.
- *
- * :key and :optional are just noise words, so these have already been spliced out of the arg list
*/
bool allow_other_keys;
@@ -49554,20 +49867,16 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
allow_other_keys = ((is_pair(cx)) && (allows_other_keys(cx)));
lx = sc->args;
- zx = sc->NIL;
+ zx = sc->nil;
while ((is_pair(cx)) &&
(is_pair(lx)))
{
- if (car(cx) == sc->KEY_REST) /* the rest arg */
+ if (car(cx) == sc->key_rest_symbol) /* the rest arg */
{
/* next arg is bound to trailing args from this point as a list */
- zx = sc->KEY_REST;
+ zx = sc->key_rest_symbol;
cx = cdr(cx);
-
- if (is_pair(car(cx)))
- lambda_star_argument_set_value(sc, caar(cx), lx);
- else lambda_star_argument_set_value(sc, car(cx), lx);
-
+ lambda_star_argument_set_value(sc, car(cx), lx); /* default arg not allowed here (see check_lambda_star_args) */
lx = cdr(lx);
cx = cdr(cx);
}
@@ -49587,7 +49896,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
s7_pointer sym;
sym = keyword_symbol(car_lx);
- if (lambda_star_argument_set_value(sc, sym, car(cdr(lx))) == sc->NO_VALUE)
+ if (lambda_star_argument_set_value(sc, sym, car(cdr(lx))) == sc->no_value)
{
/* if default value is a key, go ahead and use this value.
* (define* (f (a :b)) a) (f :c)
@@ -49619,15 +49928,15 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
}
else
{
- /* this case is not caught yet: ((lambda* (a :optional b :allow-other-keys ) a) :b 1 :c :a :a ) */
- return(s7_error(sc, sc->WRONG_TYPE_ARG,
+ /* this case is not caught yet: ((lambda* (a b :allow-other-keys ) a) :b 1 :c :a :a ) */
+ return(s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, make_string_wrapper(sc, "~A: parameter set twice, ~S in ~S"),
closure_name(sc, sc->code), lx, sc->args)));
}
}
else
{
- return(s7_error(sc, sc->WRONG_TYPE_ARG,
+ return(s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, make_string_wrapper(sc, "~A: unknown key: ~S in ~S"),
closure_name(sc, sc->code), lx, sc->args)));
}
@@ -49635,7 +49944,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
}
else
{
- return(s7_error(sc, sc->WRONG_TYPE_ARG,
+ return(s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, make_string_wrapper(sc, "~A: unknown key: ~S in ~S"),
closure_name(sc, sc->code), lx, sc->args)));
}
@@ -49666,7 +49975,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
if (is_not_null(lx))
{
if ((is_not_null(cx)) ||
- (zx == sc->KEY_REST))
+ (zx == sc->key_rest_symbol))
{
if (is_symbol(cx))
make_slot_1(sc, sc->envir, cx, lx);
@@ -49674,7 +49983,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
else
{
if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */
- return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, closure_name(sc, sc->code), sc->args)));
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, closure_name(sc, sc->code), sc->args)));
else
{
/* check trailing args for repeated keys or keys with no values or values with no keys */
@@ -49682,19 +49991,18 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
{
if ((!is_keyword(car(lx))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */
(!is_pair(cdr(lx)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */
- return(s7_error(sc, sc->WRONG_TYPE_ARG,
+ return(s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc, make_string_wrapper(sc, "~A: not a key/value pair: ~S"), closure_name(sc, sc->code), lx)));
/* errors not caught?
* ((lambda* (a :allow-other-keys) a) :a 1 :a 2)
* ((lambda* (:allow-other-keys ) #f) :b :a :a :b)
- * ((lambda* (:key b :allow-other-keys ) b) 1 :b 2)
*/
lx = cddr(lx);
}
}
}
}
- return(sc->NIL);
+ return(sc->nil);
}
@@ -49802,7 +50110,7 @@ static s7_pointer g_format_just_newline(s7_scheme *sc, s7_pointer args)
if ((!is_output_port(pt)) ||
(port_is_closed(pt)))
- method_or_bust_with_type(sc, pt, sc->FORMAT, args, A_FORMAT_PORT, 1);
+ method_or_bust_with_type(sc, pt, sc->format_symbol, args, a_format_port_string, 1);
port_write_string(pt)(sc, string_value(str), string_length(str), pt);
return(sc->F);
@@ -49818,7 +50126,7 @@ static s7_pointer g_format_allg_no_column(s7_scheme *sc, s7_pointer args)
if (!((s7_is_boolean(pt)) ||
((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */
(!port_is_closed(pt)))))
- method_or_bust_with_type(sc, pt, sc->FORMAT, args, A_FORMAT_PORT, 1);
+ method_or_bust_with_type(sc, pt, sc->format_symbol, args, a_format_port_string, 1);
str = cadr(args);
sc->format_column = 0;
@@ -49899,9 +50207,10 @@ static s7_pointer g_is_eq_car_q(s7_scheme *sc, s7_pointer args)
static s7_pointer g_is_eq_caar_q(s7_scheme *sc, s7_pointer args)
{
+ /* (eq? (caar x) 'y), but x is not guaranteed to be list(list) */
s7_pointer lst;
lst = find_symbol_checked(sc, cadar(args));
- if (!is_pair(lst))
+ if ((!is_pair(lst)) || (!is_pair(car(lst))))
return(g_is_eq(sc, set_plist_2(sc, g_caar(sc, set_plist_1(sc, lst)), cadr(cadr(args)))));
return(make_boolean(sc, caar(lst) == cadr(cadr(args))));
}
@@ -49917,7 +50226,7 @@ static s7_pointer is_eq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointe
return(is_eq_car);
}
if ((is_pair(caddr(expr))) &&
- (caaddr(expr) == sc->QUOTE))
+ (caaddr(expr) == sc->quote_symbol))
{
if (c_callee(cadr(expr)) == g_car)
{
@@ -49940,14 +50249,14 @@ static s7_pointer is_eq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointe
static s7_pointer not_is_pair, not_is_symbol, not_is_null, not_is_list, not_is_number;
static s7_pointer not_is_char, not_is_string, not_is_zero, not_is_eq_sq, not_is_eq_ss;
-static s7_pointer g_not_is_pair(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_pair, sc->IS_PAIR, args);}
-static s7_pointer g_not_is_null(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_null, sc->IS_NULL, args);}
-static s7_pointer g_not_is_symbol(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_symbol, sc->IS_SYMBOL, args);}
-static s7_pointer g_not_is_number(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_number, sc->IS_NUMBER, args);}
-static s7_pointer g_not_is_char(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_character, sc->IS_CHAR, args);}
-static s7_pointer g_not_is_string(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_string, sc->IS_STRING, args);}
-static s7_pointer g_not_is_zero(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_zero, sc->IS_ZERO, args);}
-static s7_pointer g_not_is_list(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, opt_is_list, sc->IS_LIST, args);}
+static s7_pointer g_not_is_pair(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_pair, sc->is_pair_symbol, args);}
+static s7_pointer g_not_is_null(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_null, sc->is_null_symbol, args);}
+static s7_pointer g_not_is_symbol(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_symbol, sc->is_symbol_symbol, args);}
+static s7_pointer g_not_is_number(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_number, sc->is_number_symbol, args);}
+static s7_pointer g_not_is_char(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_character, sc->is_char_symbol, args);}
+static s7_pointer g_not_is_string(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, is_string, sc->is_string_symbol, args);}
+static s7_pointer g_not_is_zero(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, s7_is_zero, sc->is_zero_symbol, args);}
+static s7_pointer g_not_is_list(s7_scheme *sc, s7_pointer args) {check_boolean_not_method(sc, opt_is_list, sc->is_list_symbol, args);}
/* eq? does not check for methods */
static s7_pointer g_not_is_eq_sq(s7_scheme *sc, s7_pointer args)
@@ -50007,7 +50316,7 @@ static s7_pointer not_chooser(s7_scheme *sc, s7_pointer g, int args, s7_pointer
set_optimize_op(expr, HOP_SAFE_C_C);
return(not_is_list);
}
- /* g_is_number is c_function_call(slot_value(global_slot(sc->IS_NUMBER)))
+ /* g_is_number is c_function_call(slot_value(global_slot(sc->is_number_symbol)))
* so if this is changed (via openlet??) the latter is perhaps better??
* but user might have (#_number? e), so we can't change later and catch this.
*/
@@ -50362,7 +50671,7 @@ static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int args, s7_poi
}
if ((is_pair(arg1)) &&
(is_symbol(arg2)) &&
- (car(arg1) == sc->SUBTRACT) &&
+ (car(arg1) == sc->subtract_symbol) &&
(is_t_real(cadr(arg1))) &&
(real(cadr(arg1)) == 1.0) &&
(is_symbol(caddr(arg1))) &&
@@ -50374,12 +50683,12 @@ static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int args, s7_poi
if ((is_symbol(arg1)) &&
(is_optimized(arg2)) &&
- ((car(arg2) == sc->SIN) || (car(arg2) == sc->COS)) &&
+ ((car(arg2) == sc->sin_symbol) || (car(arg2) == sc->cos_symbol)) &&
(is_symbol(cadr(arg2))))
{
set_optimize_op(expr, HOP_SAFE_C_C);
clear_unsafe(expr);
- if (car(arg2) == sc->SIN)
+ if (car(arg2) == sc->sin_symbol)
return(mul_s_sin_s);
return(mul_s_cos_s);
}
@@ -50397,7 +50706,7 @@ static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int args, s7_poi
if ((is_t_real(arg1)) &&
(is_symbol(arg2)) &&
(is_pair(arg3)) &&
- (car(arg3) == sc->COS) &&
+ (car(arg3) == sc->cos_symbol) &&
(is_symbol(cadr(arg3))))
{
set_optimize_op(expr, HOP_SAFE_C_C);
@@ -50696,7 +51005,7 @@ static bool returns_char(s7_scheme *sc, s7_pointer arg)
sig = c_function_signature(opt_cfunc(arg));
return((sig) &&
(is_pair(sig)) &&
- (car(sig) == sc->IS_CHAR));
+ (car(sig) == sc->is_char_symbol));
}
return(false);
}
@@ -50797,11 +51106,11 @@ static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr)
(is_safely_optimized(arg)))
{
if (c_callee(arg) == g_substring_to_temp)
- set_c_function(arg, slot_value(global_slot(sc->SUBSTRING)));
+ set_c_function(arg, slot_value(global_slot(sc->substring_symbol)));
else
{
if (c_callee(arg) == g_string_append_to_temp)
- set_c_function(arg, slot_value(global_slot(sc->STRING_APPEND)));
+ set_c_function(arg, slot_value(global_slot(sc->string_append_symbol)));
}
}
}
@@ -50920,7 +51229,7 @@ static s7_pointer g_if_direct(s7_scheme *sc, s7_pointer args)
{
if (!is_null(cddr(args)))
p = caddr(args);
- else return(sc->UNSPECIFIED);
+ else return(sc->unspecified);
}
if (is_symbol(p))
return(find_symbol_checked(sc, p));
@@ -50955,12 +51264,12 @@ static s7_pointer g_or_all_x_2s(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
p = car(args);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(p));
- p = c_call(p)(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(p));
+ p = c_call(p)(sc, sc->t1_1);
if (p != sc->F) return(p);
p = cadr(args);
- car(sc->T1_1) = find_symbol_unchecked(sc, cadr(p));
- return(c_call(p)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_unchecked(sc, cadr(p));
+ return(c_call(p)(sc, sc->t1_1));
}
@@ -50993,7 +51302,7 @@ static s7_pointer g_if_all_x1(s7_scheme *sc, s7_pointer args)
s7_pointer p;
if (is_true(sc, c_call(args)(sc, car(args))))
p = cdr(args);
- else return(sc->UNSPECIFIED);
+ else return(sc->unspecified);
return(c_call(p)(sc, car(p)));
}
@@ -51014,7 +51323,7 @@ static s7_pointer g_if_all_not_x1(s7_scheme *sc, s7_pointer args)
s7_pointer p;
if (is_false(sc, c_call(args)(sc, cadar(args))))
p = cdr(args);
- else return(sc->UNSPECIFIED);
+ else return(sc->unspecified);
return(c_call(p)(sc, car(p)));
}
@@ -51051,11 +51360,11 @@ static s7_pointer or_s_direct;
static s7_pointer g_or_s_direct(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
- car(sc->T1_1) = find_symbol_checked(sc, cadar(args));
+ car(sc->t1_1) = find_symbol_checked(sc, cadar(args));
for (p = args; is_pair(p); p = cdr(p))
{
s7_pointer x;
- x = c_call(car(p))(sc, sc->T1_1);
+ x = c_call(car(p))(sc, sc->t1_1);
if (is_true(sc, x))
return(x);
}
@@ -51067,10 +51376,10 @@ static s7_pointer and_s_direct;
static s7_pointer g_and_s_direct(s7_scheme *sc, s7_pointer args)
{
s7_pointer p, x = sc->T;
- car(sc->T1_1) = find_symbol_checked(sc, cadar(args));
+ car(sc->t1_1) = find_symbol_checked(sc, cadar(args));
for (p = args; is_pair(p); p = cdr(p))
{
- x = c_call(car(p))(sc, sc->T1_1);
+ x = c_call(car(p))(sc, sc->t1_1);
if (is_false(sc, x))
return(x);
}
@@ -51082,16 +51391,16 @@ static s7_pointer if_s_direct;
static s7_pointer g_if_s_direct(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
- car(sc->T1_1) = find_symbol_checked(sc, cadar(args));
- if (is_true(sc, c_call(car(args))(sc, sc->T1_1)))
+ car(sc->t1_1) = find_symbol_checked(sc, cadar(args));
+ if (is_true(sc, c_call(car(args))(sc, sc->t1_1)))
p = cdr(args);
else
{
p = cddr(args);
if (is_null(p))
- return(sc->UNSPECIFIED);
+ return(sc->unspecified);
}
- return(c_call(car(p))(sc, sc->T1_1));
+ return(c_call(car(p))(sc, sc->t1_1));
}
@@ -51121,351 +51430,351 @@ static void init_choosers(s7_scheme *sc)
s7_pointer f;
#if (!WITH_GMP)
- s7_if_set_function(slot_value(global_slot(sc->MODULO)), modulo_if);
- s7_rf_set_function(slot_value(global_slot(sc->MODULO)), modulo_rf);
- s7_rf_set_function(slot_value(global_slot(sc->REMAINDER)), remainder_rf);
- s7_if_set_function(slot_value(global_slot(sc->REMAINDER)), remainder_if);
- s7_rf_set_function(slot_value(global_slot(sc->QUOTIENT)), quotient_rf);
- s7_if_set_function(slot_value(global_slot(sc->QUOTIENT)), quotient_if);
- s7_if_set_function(slot_value(global_slot(sc->NUMERATOR)), numerator_if);
- s7_if_set_function(slot_value(global_slot(sc->DENOMINATOR)), denominator_if);
- s7_rf_set_function(slot_value(global_slot(sc->REAL_PART)), real_part_rf);
- s7_rf_set_function(slot_value(global_slot(sc->IMAG_PART)), imag_part_rf);
- s7_gf_set_function(slot_value(global_slot(sc->RATIONALIZE)), rationalize_pf);
-
- s7_if_set_function(slot_value(global_slot(sc->CEILING)), ceiling_if);
- s7_if_set_function(slot_value(global_slot(sc->TRUNCATE)), truncate_if);
- s7_if_set_function(slot_value(global_slot(sc->ROUND)), round_if);
- s7_if_set_function(slot_value(global_slot(sc->FLOOR)), floor_if);
- s7_if_set_function(slot_value(global_slot(sc->LOGIOR)), logior_if);
- s7_if_set_function(slot_value(global_slot(sc->LOGAND)), logand_if);
- s7_if_set_function(slot_value(global_slot(sc->LOGXOR)), logxor_if);
- s7_if_set_function(slot_value(global_slot(sc->LOGNOT)), lognot_if);
- s7_if_set_function(slot_value(global_slot(sc->ASH)), ash_if);
- s7_if_set_function(slot_value(global_slot(sc->GCD)), gcd_if);
- s7_if_set_function(slot_value(global_slot(sc->LCM)), lcm_if);
- s7_rf_set_function(slot_value(global_slot(sc->MAX)), max_rf);
- s7_if_set_function(slot_value(global_slot(sc->MAX)), max_if);
- s7_rf_set_function(slot_value(global_slot(sc->MIN)), min_rf);
- s7_if_set_function(slot_value(global_slot(sc->MIN)), min_if);
-
- s7_rf_set_function(slot_value(global_slot(sc->DIVIDE)), divide_rf);
- s7_if_set_function(slot_value(global_slot(sc->MULTIPLY)), multiply_if);
- s7_rf_set_function(slot_value(global_slot(sc->MULTIPLY)), multiply_rf);
- s7_rf_set_function(slot_value(global_slot(sc->ADD)), add_rf);
- s7_if_set_function(slot_value(global_slot(sc->ADD)), add_if);
- s7_rf_set_function(slot_value(global_slot(sc->SUBTRACT)), subtract_rf);
- s7_if_set_function(slot_value(global_slot(sc->SUBTRACT)), subtract_if);
+ s7_if_set_function(slot_value(global_slot(sc->modulo_symbol)), modulo_if);
+ s7_rf_set_function(slot_value(global_slot(sc->modulo_symbol)), modulo_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->remainder_symbol)), remainder_rf);
+ s7_if_set_function(slot_value(global_slot(sc->remainder_symbol)), remainder_if);
+ s7_rf_set_function(slot_value(global_slot(sc->quotient_symbol)), quotient_rf);
+ s7_if_set_function(slot_value(global_slot(sc->quotient_symbol)), quotient_if);
+ s7_if_set_function(slot_value(global_slot(sc->numerator_symbol)), numerator_if);
+ s7_if_set_function(slot_value(global_slot(sc->denominator_symbol)), denominator_if);
+ s7_rf_set_function(slot_value(global_slot(sc->real_part_symbol)), real_part_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->imag_part_symbol)), imag_part_rf);
+ s7_gf_set_function(slot_value(global_slot(sc->rationalize_symbol)), rationalize_pf);
+
+ s7_if_set_function(slot_value(global_slot(sc->ceiling_symbol)), ceiling_if);
+ s7_if_set_function(slot_value(global_slot(sc->truncate_symbol)), truncate_if);
+ s7_if_set_function(slot_value(global_slot(sc->round_symbol)), round_if);
+ s7_if_set_function(slot_value(global_slot(sc->floor_symbol)), floor_if);
+ s7_if_set_function(slot_value(global_slot(sc->logior_symbol)), logior_if);
+ s7_if_set_function(slot_value(global_slot(sc->logand_symbol)), logand_if);
+ s7_if_set_function(slot_value(global_slot(sc->logxor_symbol)), logxor_if);
+ s7_if_set_function(slot_value(global_slot(sc->lognot_symbol)), lognot_if);
+ s7_if_set_function(slot_value(global_slot(sc->ash_symbol)), ash_if);
+ s7_if_set_function(slot_value(global_slot(sc->gcd_symbol)), gcd_if);
+ s7_if_set_function(slot_value(global_slot(sc->lcm_symbol)), lcm_if);
+ s7_rf_set_function(slot_value(global_slot(sc->max_symbol)), max_rf);
+ s7_if_set_function(slot_value(global_slot(sc->max_symbol)), max_if);
+ s7_rf_set_function(slot_value(global_slot(sc->min_symbol)), min_rf);
+ s7_if_set_function(slot_value(global_slot(sc->min_symbol)), min_if);
+
+ s7_rf_set_function(slot_value(global_slot(sc->divide_symbol)), divide_rf);
+ s7_if_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_if);
+ s7_rf_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->add_symbol)), add_rf);
+ s7_if_set_function(slot_value(global_slot(sc->add_symbol)), add_if);
+ s7_rf_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_rf);
+ s7_if_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_if);
#if WITH_ADD_PF
- s7_gf_set_function(slot_value(global_slot(sc->MULTIPLY)), multiply_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ADD)), add_pf);
- s7_gf_set_function(slot_value(global_slot(sc->SUBTRACT)), subtract_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->add_symbol)), add_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_pf);
#endif
- s7_rf_set_function(slot_value(global_slot(sc->SIN)), sin_rf);
- s7_rf_set_function(slot_value(global_slot(sc->COS)), cos_rf);
- s7_rf_set_function(slot_value(global_slot(sc->TAN)), tan_rf);
- s7_rf_set_function(slot_value(global_slot(sc->SINH)), sinh_rf);
- s7_rf_set_function(slot_value(global_slot(sc->COSH)), cosh_rf);
- s7_rf_set_function(slot_value(global_slot(sc->TANH)), tanh_rf);
- s7_rf_set_function(slot_value(global_slot(sc->ATAN)), atan_rf);
- s7_rf_set_function(slot_value(global_slot(sc->EXP)), exp_rf);
-
- s7_gf_set_function(slot_value(global_slot(sc->ASIN)), asin_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ACOS)), acos_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ASINH)), asinh_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ACOSH)), acosh_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ATANH)), atanh_pf);
-
- s7_rf_set_function(slot_value(global_slot(sc->RANDOM)), random_rf);
- s7_if_set_function(slot_value(global_slot(sc->RANDOM)), random_if);
-
- s7_gf_set_function(slot_value(global_slot(sc->EXPT)), expt_pf);
- s7_gf_set_function(slot_value(global_slot(sc->NUMBER_TO_STRING)), number_to_string_pf);
- s7_gf_set_function(slot_value(global_slot(sc->STRING_TO_NUMBER)), string_to_number_pf);
-
- s7_rf_set_function(slot_value(global_slot(sc->ABS)), fabs_rf);
- s7_if_set_function(slot_value(global_slot(sc->ABS)), abs_if);
+ s7_rf_set_function(slot_value(global_slot(sc->sin_symbol)), sin_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->cos_symbol)), cos_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->tan_symbol)), tan_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->sinh_symbol)), sinh_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->cosh_symbol)), cosh_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->tanh_symbol)), tanh_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->atan_symbol)), atan_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->exp_symbol)), exp_rf);
+
+ s7_gf_set_function(slot_value(global_slot(sc->asin_symbol)), asin_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->acos_symbol)), acos_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->asinh_symbol)), asinh_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->acosh_symbol)), acosh_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->atanh_symbol)), atanh_pf);
+
+ s7_rf_set_function(slot_value(global_slot(sc->random_symbol)), random_rf);
+ s7_if_set_function(slot_value(global_slot(sc->random_symbol)), random_if);
+
+ s7_gf_set_function(slot_value(global_slot(sc->expt_symbol)), expt_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->number_to_string_symbol)), number_to_string_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->string_to_number_symbol)), string_to_number_pf);
+
+ s7_rf_set_function(slot_value(global_slot(sc->abs_symbol)), fabs_rf);
+ s7_if_set_function(slot_value(global_slot(sc->abs_symbol)), abs_if);
#if (!WITH_PURE_S7)
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_RECTANGULAR)), make_complex_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_POLAR)), make_polar_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_rectangular_symbol)), make_complex_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_polar_symbol)), make_polar_pf);
#endif
- s7_rf_set_function(slot_value(global_slot(sc->MAGNITUDE)), magnitude_rf);
- s7_if_set_function(slot_value(global_slot(sc->MAGNITUDE)), magnitude_if);
- s7_gf_set_function(slot_value(global_slot(sc->COMPLEX)), make_complex_pf); /* actually complex */
-
- s7_pf_set_function(slot_value(global_slot(sc->EQ)), equal_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LT)), less_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LEQ)), leq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->GEQ)), geq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->GT)), gt_pf);
+ s7_rf_set_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_rf);
+ s7_if_set_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_if);
+ s7_gf_set_function(slot_value(global_slot(sc->complex_symbol)), make_complex_pf); /* actually complex */
+
+ s7_pf_set_function(slot_value(global_slot(sc->eq_symbol)), equal_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->lt_symbol)), less_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->leq_symbol)), leq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->geq_symbol)), geq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->gt_symbol)), gt_pf);
#endif /* !gmp */
- s7_if_set_function(slot_value(global_slot(sc->PAIR_LINE_NUMBER)), pair_line_number_if);
- s7_if_set_function(slot_value(global_slot(sc->HASH_TABLE_ENTRIES)), hash_table_entries_if);
+ s7_if_set_function(slot_value(global_slot(sc->pair_line_number_symbol)), pair_line_number_if);
+ s7_if_set_function(slot_value(global_slot(sc->hash_table_entries_symbol)), hash_table_entries_if);
#if (!WITH_PURE_S7)
#if (!WITH_GMP)
- s7_if_set_function(slot_value(global_slot(sc->INTEGER_LENGTH)), integer_length_if);
+ s7_if_set_function(slot_value(global_slot(sc->integer_length_symbol)), integer_length_if);
#endif
- s7_if_set_function(slot_value(global_slot(sc->VECTOR_LENGTH)), vector_length_if);
- s7_if_set_function(slot_value(global_slot(sc->STRING_LENGTH)), string_length_if);
+ s7_if_set_function(slot_value(global_slot(sc->vector_length_symbol)), vector_length_if);
+ s7_if_set_function(slot_value(global_slot(sc->string_length_symbol)), string_length_if);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_FILL)), string_fill_pf);
- s7_pf_set_function(slot_value(global_slot(sc->VECTOR_FILL)), vector_fill_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_fill_symbol)), string_fill_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->vector_fill_symbol)), vector_fill_pf);
#endif
- s7_pf_set_function(slot_value(global_slot(sc->LENGTH)), length_pf);
- s7_pf_set_function(slot_value(global_slot(sc->FILL)), fill_pf);
- s7_gf_set_function(slot_value(global_slot(sc->COPY)), copy_pf);
- s7_gf_set_function(slot_value(global_slot(sc->REVERSE)), reverse_pf);
- s7_pf_set_function(slot_value(global_slot(sc->NOT)), not_pf);
-
- s7_if_set_function(slot_value(global_slot(sc->CHAR_TO_INTEGER)), char_to_integer_if);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_EQ)), char_eq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_GT)), char_gt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_GEQ)), char_geq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_LT)), char_lt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_LEQ)), char_leq_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->STRING_EQ)), string_eq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_LT)), string_lt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_LEQ)), string_leq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_GT)), string_gt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_GEQ)), string_geq_pf);
-
- s7_gf_set_function(slot_value(global_slot(sc->STRING_UPCASE)), string_upcase_pf);
- s7_gf_set_function(slot_value(global_slot(sc->STRING_DOWNCASE)), string_downcase_pf);
- s7_gf_set_function(slot_value(global_slot(sc->CHAR_POSITION)), char_position_pf);
- s7_gf_set_function(slot_value(global_slot(sc->STRING_POSITION)), string_position_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->length_symbol)), length_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->fill_symbol)), fill_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->copy_symbol)), copy_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->reverse_symbol)), reverse_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->not_symbol)), not_pf);
+
+ s7_if_set_function(slot_value(global_slot(sc->char_to_integer_symbol)), char_to_integer_if);
+ s7_pf_set_function(slot_value(global_slot(sc->char_eq_symbol)), char_eq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_gt_symbol)), char_gt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_geq_symbol)), char_geq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_lt_symbol)), char_lt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_leq_symbol)), char_leq_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->string_eq_symbol)), string_eq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_lt_symbol)), string_lt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_leq_symbol)), string_leq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_gt_symbol)), string_gt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_geq_symbol)), string_geq_pf);
+
+ s7_gf_set_function(slot_value(global_slot(sc->string_upcase_symbol)), string_upcase_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->string_downcase_symbol)), string_downcase_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->char_position_symbol)), char_position_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->string_position_symbol)), string_position_pf);
#if (!WITH_PURE_S7)
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_CI_EQ)), char_ci_eq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_CI_GT)), char_ci_gt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_CI_GEQ)), char_ci_geq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_CI_LT)), char_ci_lt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_CI_LEQ)), char_ci_leq_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->STRING_CI_EQ)), string_ci_eq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_CI_LT)), string_ci_lt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_CI_LEQ)), string_ci_leq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_CI_GT)), string_ci_gt_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_CI_GEQ)), string_ci_geq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_ci_eq_symbol)), char_ci_eq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_ci_gt_symbol)), char_ci_gt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_ci_geq_symbol)), char_ci_geq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_ci_lt_symbol)), char_ci_lt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_ci_leq_symbol)), char_ci_leq_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->string_ci_eq_symbol)), string_ci_eq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_ci_lt_symbol)), string_ci_lt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_ci_leq_symbol)), string_ci_leq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_ci_gt_symbol)), string_ci_gt_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_ci_geq_symbol)), string_ci_geq_pf);
#endif
#if (!WITH_GMP)
- s7_pf_set_function(slot_value(global_slot(sc->IS_EVEN)), is_even_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_ODD)), is_odd_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_NAN)), is_nan_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_INFINITE)), is_infinite_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_even_symbol)), is_even_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_odd_symbol)), is_odd_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_nan_symbol)), is_nan_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_infinite_symbol)), is_infinite_pf);
#endif
- s7_pf_set_function(slot_value(global_slot(sc->IS_ZERO)), is_zero_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_POSITIVE)), is_positive_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_NEGATIVE)), is_negative_pf);
- s7_pf_set_function(slot_value(global_slot(sc->HASH_TABLE_REF)), hash_table_ref_pf);
- s7_pf_set_function(slot_value(global_slot(sc->HASH_TABLE_SET)), hash_table_set_pf);
- s7_pf_set_function(slot_value(global_slot(sc->VECTOR_REF)), vector_ref_pf);
- s7_pf_set_function(slot_value(global_slot(sc->VECTOR_SET)), vector_set_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_REF)), string_ref_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_SET)), string_set_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LIST_REF)), list_ref_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LIST_SET)), list_set_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LET_REF)), let_ref_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LET_SET)), let_set_pf);
- s7_pf_set_function(slot_value(global_slot(sc->TO_BYTE_VECTOR)), to_byte_vector_pf);
-
- s7_rf_set_function(slot_value(global_slot(sc->FLOAT_VECTOR_REF)), float_vector_ref_rf);
- s7_rf_set_function(slot_value(global_slot(sc->FLOAT_VECTOR_SET)), float_vector_set_rf);
-
- s7_if_set_function(slot_value(global_slot(sc->INT_VECTOR_REF)), int_vector_ref_if);
- s7_if_set_function(slot_value(global_slot(sc->INT_VECTOR_SET)), int_vector_set_if);
-
- s7_pf_set_function(slot_value(global_slot(sc->CAAAAR)), caaaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAAADR)), caaadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAAAR)), caaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAADAR)), caadar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAADDR)), caaddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAADR)), caadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAAR)), caar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADAAR)), cadaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADADR)), cadadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADAR)), cadar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADDAR)), caddar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADDDR)), cadddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADDR)), caddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CADR)), cadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CAR)), car_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDAAAR)), cdaaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDAADR)), cdaadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDAAR)), cdaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDADAR)), cdadar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDADDR)), cdaddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDADR)), cdadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDAR)), cdar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDAAR)), cddaar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDADR)), cddadr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDAR)), cddar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDDAR)), cdddar_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDDDR)), cddddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDDR)), cdddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDDR)), cddr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CDR)), cdr_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->SET_CAR)), set_car_pf);
- s7_pf_set_function(slot_value(global_slot(sc->SET_CDR)), set_cdr_pf);
- s7_pf_set_function(slot_value(global_slot(sc->LIST_TAIL)), list_tail_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ASSOC)), assoc_pf);
- s7_pf_set_function(slot_value(global_slot(sc->MEMBER)), member_pf);
-
- s7_gf_set_function(slot_value(global_slot(sc->CONS)), cons_pf);
- s7_gf_set_function(slot_value(global_slot(sc->LIST)), list_pf);
- s7_gf_set_function(slot_value(global_slot(sc->INT_VECTOR)), int_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->FLOAT_VECTOR)), float_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->VECTOR)), vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->C_POINTER)), c_pointer_pf);
- s7_gf_set_function(slot_value(global_slot(sc->VECTOR_DIMENSIONS)), vector_dimensions_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_SHARED_VECTOR)), make_shared_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_VECTOR)), make_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_FLOAT_VECTOR)), make_float_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_INT_VECTOR)), make_int_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_LIST)), make_list_pf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_STRING)), make_string_pf);
-
+ s7_pf_set_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->hash_table_ref_symbol)), hash_table_ref_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->hash_table_set_symbol)), hash_table_set_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->vector_ref_symbol)), vector_ref_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->vector_set_symbol)), vector_set_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_ref_symbol)), string_ref_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_set_symbol)), string_set_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->list_ref_symbol)), list_ref_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->list_set_symbol)), list_set_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->let_ref_symbol)), let_ref_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->let_set_symbol)), let_set_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->to_byte_vector_symbol)), to_byte_vector_pf);
+
+ s7_rf_set_function(slot_value(global_slot(sc->float_vector_ref_symbol)), float_vector_ref_rf);
+ s7_rf_set_function(slot_value(global_slot(sc->float_vector_set_symbol)), float_vector_set_rf);
+
+ s7_if_set_function(slot_value(global_slot(sc->int_vector_ref_symbol)), int_vector_ref_if);
+ s7_if_set_function(slot_value(global_slot(sc->int_vector_set_symbol)), int_vector_set_if);
+
+ s7_pf_set_function(slot_value(global_slot(sc->caaaar_symbol)), caaaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caaadr_symbol)), caaadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caaar_symbol)), caaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caadar_symbol)), caadar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caaddr_symbol)), caaddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caadr_symbol)), caadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caar_symbol)), caar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cadaar_symbol)), cadaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cadadr_symbol)), cadadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cadar_symbol)), cadar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caddar_symbol)), caddar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cadddr_symbol)), cadddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->caddr_symbol)), caddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cadr_symbol)), cadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->car_symbol)), car_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdaaar_symbol)), cdaaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdaadr_symbol)), cdaadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdaar_symbol)), cdaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdadar_symbol)), cdadar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdaddr_symbol)), cdaddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdadr_symbol)), cdadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdar_symbol)), cdar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cddaar_symbol)), cddaar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cddadr_symbol)), cddadr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cddar_symbol)), cddar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdddar_symbol)), cdddar_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cddddr_symbol)), cddddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdddr_symbol)), cdddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cddr_symbol)), cddr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cdr_symbol)), cdr_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->set_car_symbol)), set_car_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->set_cdr_symbol)), set_cdr_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->list_tail_symbol)), list_tail_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->assoc_symbol)), assoc_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->member_symbol)), member_pf);
+
+ s7_gf_set_function(slot_value(global_slot(sc->cons_symbol)), cons_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->list_symbol)), list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->int_vector_symbol)), int_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->float_vector_symbol)), float_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->vector_symbol)), vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->c_pointer_symbol)), c_pointer_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->vector_dimensions_symbol)), vector_dimensions_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_shared_vector_symbol)), make_shared_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_vector_symbol)), make_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_float_vector_symbol)), make_float_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_int_vector_symbol)), make_int_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_list_symbol)), make_list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_string_symbol)), make_string_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->memq_symbol)), memq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->memv_symbol)), memv_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->assq_symbol)), assq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->assv_symbol)), assv_pf);
#if (!WITH_PURE_S7)
- s7_pf_set_function(slot_value(global_slot(sc->MEMQ)), memq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->MEMV)), memv_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ASSQ)), assq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ASSV)), assv_pf);
- s7_gf_set_function(slot_value(global_slot(sc->LIST_TO_VECTOR)), list_to_vector_pf);
- s7_gf_set_function(slot_value(global_slot(sc->VECTOR_TO_LIST)), vector_to_list_pf);
- s7_gf_set_function(slot_value(global_slot(sc->STRING_TO_LIST)), string_to_list_pf);
- s7_gf_set_function(slot_value(global_slot(sc->LET_TO_LIST)), let_to_list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->list_to_vector_symbol)), list_to_vector_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->vector_to_list_symbol)), vector_to_list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->string_to_list_symbol)), string_to_list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->let_to_list_symbol)), let_to_list_pf);
#endif
- s7_gf_set_function(slot_value(global_slot(sc->RANDOM_STATE_TO_LIST)), random_state_to_list_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->IS_ARITABLE)), is_aritable_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_BOOLEAN)), is_boolean_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_BYTE_VECTOR)), is_byte_vector_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR)), is_char_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_COMPLEX)), is_complex_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CONSTANT)), is_constant_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CONTINUATION)), is_continuation_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_C_POINTER)), is_c_pointer_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_DILAMBDA)), is_dilambda_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_EOF_OBJECT)), is_eof_object_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_FLOAT_VECTOR)), is_float_vector_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_GENSYM)), is_gensym_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_HASH_TABLE)), is_hash_table_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_INPUT_PORT)), is_input_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_INTEGER)), is_integer_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_INT_VECTOR)), is_int_vector_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_KEYWORD)), is_keyword_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_LET)), is_let_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_LIST)), is_list_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_MACRO)), is_macro_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_NULL)), is_null_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_NUMBER)), is_number_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_OUTPUT_PORT)), is_output_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_PAIR)), is_pair_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_PROCEDURE)), is_procedure_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_PROVIDED)), is_provided_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_RANDOM_STATE)), is_random_state_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_RATIONAL)), is_rational_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_REAL)), is_real_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_STRING)), is_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_SYMBOL)), is_symbol_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_VECTOR)), is_vector_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->IS_ITERATOR)), is_iterator_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ITERATOR_IS_AT_END)), iterator_is_at_end_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ITERATOR_SEQUENCE)), iterator_sequence_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ITERATE)), iterate_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ITERATE)), iterate_gf);
- s7_gf_set_function(slot_value(global_slot(sc->MAKE_ITERATOR)), make_iterator_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->random_state_to_list_symbol)), random_state_to_list_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->is_aritable_symbol)), is_aritable_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_boolean_symbol)), is_boolean_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_byte_vector_symbol)), is_byte_vector_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_symbol)), is_char_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_complex_symbol)), is_complex_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_constant_symbol)), is_constant_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_continuation_symbol)), is_continuation_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_c_pointer_symbol)), is_c_pointer_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_dilambda_symbol)), is_dilambda_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_eof_object_symbol)), is_eof_object_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_float_vector_symbol)), is_float_vector_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_gensym_symbol)), is_gensym_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_hash_table_symbol)), is_hash_table_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_input_port_symbol)), is_input_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_integer_symbol)), is_integer_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_int_vector_symbol)), is_int_vector_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_keyword_symbol)), is_keyword_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_let_symbol)), is_let_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_list_symbol)), is_list_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_macro_symbol)), is_macro_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_null_symbol)), is_null_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_number_symbol)), is_number_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_output_port_symbol)), is_output_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_pair_symbol)), is_pair_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_procedure_symbol)), is_procedure_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_provided_symbol)), is_provided_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_random_state_symbol)), is_random_state_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_rational_symbol)), is_rational_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_real_symbol)), is_real_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_string_symbol)), is_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_symbol_symbol)), is_symbol_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_vector_symbol)), is_vector_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->is_iterator_symbol)), is_iterator_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->iterator_is_at_end_symbol)), iterator_is_at_end_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->iterator_sequence_symbol)), iterator_sequence_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->iterate_symbol)), iterate_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->iterate_symbol)), iterate_gf);
+ s7_gf_set_function(slot_value(global_slot(sc->make_iterator_symbol)), make_iterator_pf);
#if (!WITH_GMP)
- s7_gf_set_function(slot_value(global_slot(sc->RANDOM_STATE)), random_state_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->random_state_symbol)), random_state_pf);
#endif
- s7_pf_set_function(slot_value(global_slot(sc->REVERSEB)), reverse_in_place_pf);
- s7_gf_set_function(slot_value(global_slot(sc->SORT)), sort_pf);
- s7_pf_set_function(slot_value(global_slot(sc->PROVIDE)), provide_pf);
- s7_pf_set_function(slot_value(global_slot(sc->SYMBOL)), symbol_pf);
- s7_pf_set_function(slot_value(global_slot(sc->STRING_TO_SYMBOL)), string_to_symbol_pf);
- s7_gf_set_function(slot_value(global_slot(sc->SYMBOL_TO_STRING)), symbol_to_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->MAKE_KEYWORD)), make_keyword_pf);
- s7_pf_set_function(slot_value(global_slot(sc->KEYWORD_TO_SYMBOL)), keyword_to_symbol_pf);
- s7_pf_set_function(slot_value(global_slot(sc->SYMBOL_TO_KEYWORD)), symbol_to_keyword_pf);
- s7_pf_set_function(slot_value(global_slot(sc->SYMBOL_TO_VALUE)), symbol_to_value_pf);
- s7_gf_set_function(slot_value(global_slot(sc->GENSYM)), gensym_pf);
- s7_gf_set_function(slot_value(global_slot(sc->ARITY)), arity_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->IS_OPENLET)), is_openlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CURLET)), curlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->OWLET)), owlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->ROOTLET)), rootlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->OUTLET)), outlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->OPENLET)), openlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->COVERLET)), coverlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->FUNCLET)), funclet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CUTLET)), cutlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->VARLET)), varlet_pf);
- s7_pf_set_function(slot_value(global_slot(sc->UNLET)), unlet_pf);
- s7_gf_set_function(slot_value(global_slot(sc->INLET)), inlet_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->GC)), gc_pf);
- s7_gf_set_function(slot_value(global_slot(sc->HELP)), help_pf);
- s7_gf_set_function(slot_value(global_slot(sc->PROCEDURE_SOURCE)), procedure_source_pf);
- s7_gf_set_function(slot_value(global_slot(sc->PROCEDURE_DOCUMENTATION)), procedure_documentation_pf);
- s7_gf_set_function(slot_value(global_slot(sc->PROCEDURE_SIGNATURE)), procedure_signature_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR_ALPHABETIC)), is_char_alphabetic_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR_LOWER_CASE)), is_char_lower_case_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR_NUMERIC)), is_char_numeric_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR_UPPER_CASE)), is_char_upper_case_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_CHAR_WHITESPACE)), is_char_whitespace_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_UPCASE)), char_upcase_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CHAR_DOWNCASE)), char_downcase_pf);
- s7_pf_set_function(slot_value(global_slot(sc->INTEGER_TO_CHAR)), integer_to_char_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->CURRENT_INPUT_PORT)), current_input_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CURRENT_OUTPUT_PORT)), current_output_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CURRENT_ERROR_PORT)), current_error_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CLOSE_INPUT_PORT)), close_input_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CLOSE_OUTPUT_PORT)), close_output_port_pf);
- s7_pf_set_function(slot_value(global_slot(sc->FLUSH_OUTPUT_PORT)), flush_output_port_pf);
- s7_gf_set_function(slot_value(global_slot(sc->PORT_FILENAME)), port_filename_pf);
- s7_gf_set_function(slot_value(global_slot(sc->PORT_LINE_NUMBER)), port_line_number_pf);
- s7_pf_set_function(slot_value(global_slot(sc->WITH_INPUT_FROM_FILE)), with_input_from_file_pf);
- s7_pf_set_function(slot_value(global_slot(sc->WITH_INPUT_FROM_STRING)), with_input_from_string_pf);
- s7_gf_set_function(slot_value(global_slot(sc->WITH_OUTPUT_TO_STRING)), with_output_to_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->WITH_OUTPUT_TO_FILE)), with_output_to_file_pf);
- s7_gf_set_function(slot_value(global_slot(sc->CALL_WITH_OUTPUT_STRING)), call_with_output_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CALL_WITH_OUTPUT_FILE)), call_with_output_file_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CALL_WITH_INPUT_STRING)), call_with_input_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->CALL_WITH_INPUT_FILE)), call_with_input_file_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->reverseb_symbol)), reverse_in_place_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->sort_symbol)), sort_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->provide_symbol)), provide_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->symbol_symbol)), symbol_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->string_to_symbol_symbol)), string_to_symbol_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->symbol_to_string_symbol)), symbol_to_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->make_keyword_symbol)), make_keyword_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->keyword_to_symbol_symbol)), keyword_to_symbol_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->symbol_to_keyword_symbol)), symbol_to_keyword_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->symbol_to_value_symbol)), symbol_to_value_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->gensym_symbol)), gensym_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->arity_symbol)), arity_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->is_openlet_symbol)), is_openlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->curlet_symbol)), curlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->owlet_symbol)), owlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->rootlet_symbol)), rootlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->outlet_symbol)), outlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->openlet_symbol)), openlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->coverlet_symbol)), coverlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->funclet_symbol)), funclet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->cutlet_symbol)), cutlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->varlet_symbol)), varlet_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->unlet_symbol)), unlet_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->inlet_symbol)), inlet_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->gc_symbol)), gc_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->help_symbol)), help_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->procedure_source_symbol)), procedure_source_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->procedure_documentation_symbol)), procedure_documentation_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->procedure_signature_symbol)), procedure_signature_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_alphabetic_symbol)), is_char_alphabetic_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_lower_case_symbol)), is_char_lower_case_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_numeric_symbol)), is_char_numeric_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_upper_case_symbol)), is_char_upper_case_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_char_whitespace_symbol)), is_char_whitespace_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_upcase_symbol)), char_upcase_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->char_downcase_symbol)), char_downcase_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->integer_to_char_symbol)), integer_to_char_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->current_input_port_symbol)), current_input_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->current_output_port_symbol)), current_output_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->current_error_port_symbol)), current_error_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->close_input_port_symbol)), close_input_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->close_output_port_symbol)), close_output_port_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->flush_output_port_symbol)), flush_output_port_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->port_filename_symbol)), port_filename_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->port_line_number_symbol)), port_line_number_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->with_input_from_file_symbol)), with_input_from_file_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->with_input_from_string_symbol)), with_input_from_string_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->with_output_to_string_symbol)), with_output_to_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->with_output_to_file_symbol)), with_output_to_file_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->call_with_output_string_symbol)), call_with_output_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->call_with_output_file_symbol)), call_with_output_file_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->call_with_input_string_symbol)), call_with_input_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->call_with_input_file_symbol)), call_with_input_file_pf);
#if WITH_SYSTEM_EXTRAS
- s7_gf_set_function(slot_value(global_slot(sc->DIRECTORY_TO_LIST)), directory_to_list_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->directory_to_list_symbol)), directory_to_list_pf);
#endif
- s7_if_set_function(slot_value(global_slot(sc->WRITE_BYTE)), write_byte_if);
- s7_pf_set_function(slot_value(global_slot(sc->WRITE_CHAR)), write_char_pf);
- s7_pf_set_function(slot_value(global_slot(sc->READ_BYTE)), read_byte_pf);
- s7_pf_set_function(slot_value(global_slot(sc->READ_CHAR)), read_char_pf);
- s7_pf_set_function(slot_value(global_slot(sc->PEEK_CHAR)), peek_char_pf);
- s7_pf_set_function(slot_value(global_slot(sc->NEWLINE)), newline_pf);
- s7_pf_set_function(slot_value(global_slot(sc->WRITE)), write_pf);
- s7_pf_set_function(slot_value(global_slot(sc->WRITE_STRING)), write_string_pf);
- s7_gf_set_function(slot_value(global_slot(sc->READ_STRING)), read_string_pf);
- s7_pf_set_function(slot_value(global_slot(sc->DISPLAY)), display_pf);
- s7_gf_set_function(slot_value(global_slot(sc->READ)), read_pf);
- s7_gf_set_function(slot_value(global_slot(sc->READ_LINE)), read_line_pf);
- s7_gf_set_function(slot_value(global_slot(sc->OBJECT_TO_STRING)), object_to_string_pf);
-
- s7_pf_set_function(slot_value(global_slot(sc->IS_EQ)), is_eq_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_EQV)), is_eqv_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_EQUAL)), is_equal_pf);
- s7_pf_set_function(slot_value(global_slot(sc->IS_MORALLY_EQUAL)), is_morally_equal_pf);
+ s7_if_set_function(slot_value(global_slot(sc->write_byte_symbol)), write_byte_if);
+ s7_pf_set_function(slot_value(global_slot(sc->write_char_symbol)), write_char_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->read_byte_symbol)), read_byte_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->read_char_symbol)), read_char_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->peek_char_symbol)), peek_char_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->newline_symbol)), newline_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->write_symbol)), write_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->write_string_symbol)), write_string_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->read_string_symbol)), read_string_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->display_symbol)), display_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->read_symbol)), read_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->read_line_symbol)), read_line_pf);
+ s7_gf_set_function(slot_value(global_slot(sc->object_to_string_symbol)), object_to_string_pf);
+
+ s7_pf_set_function(slot_value(global_slot(sc->is_eq_symbol)), is_eq_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_eqv_symbol)), is_eqv_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_pf);
+ s7_pf_set_function(slot_value(global_slot(sc->is_morally_equal_symbol)), is_morally_equal_pf);
/* + */
- f = set_function_chooser(sc, sc->ADD, add_chooser);
+ f = set_function_chooser(sc, sc->add_symbol, add_chooser);
sc->add_class = c_function_class(f);
add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false, "+ opt");
@@ -51479,7 +51788,7 @@ static void init_choosers(s7_scheme *sc)
add_f_sf = make_function_with_class(sc, f, "+", g_add_f_sf, 2, 0, false, "+ opt");
/* - */
- f = set_function_chooser(sc, sc->SUBTRACT, subtract_chooser);
+ f = set_function_chooser(sc, sc->subtract_symbol, subtract_chooser);
sc->subtract_class = c_function_class(f);
subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false, "- opt");
subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false, "- opt");
@@ -51497,7 +51806,7 @@ static void init_choosers(s7_scheme *sc)
/* * */
- f = set_function_chooser(sc, sc->MULTIPLY, multiply_chooser);
+ f = set_function_chooser(sc, sc->multiply_symbol, multiply_chooser);
sc->multiply_class = c_function_class(f);
#if (!WITH_GMP)
multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false, "* opt");
@@ -51514,28 +51823,28 @@ static void init_choosers(s7_scheme *sc)
#endif
/* / */
- f = set_function_chooser(sc, sc->DIVIDE, divide_chooser);
+ f = set_function_chooser(sc, sc->divide_symbol, divide_chooser);
#if (!WITH_GMP)
invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false, "/ opt");
divide_1r = make_function_with_class(sc, f, "/", g_divide_1r, 2, 0, false, "/ opt");
/* modulo */
- f = set_function_chooser(sc, sc->MODULO, modulo_chooser);
+ f = set_function_chooser(sc, sc->modulo_symbol, modulo_chooser);
mod_si = make_function_with_class(sc, f, "modulo", g_mod_si, 2, 0, false, "modulo opt");
/* max */
- f = set_function_chooser(sc, sc->MAX, max_chooser);
+ f = set_function_chooser(sc, sc->max_symbol, max_chooser);
max_f2 = make_function_with_class(sc, f, "max", g_max_f2, 2, 0, false, "max opt");
/* min */
- f = set_function_chooser(sc, sc->MIN, min_chooser);
+ f = set_function_chooser(sc, sc->min_symbol, min_chooser);
min_f2 = make_function_with_class(sc, f, "min", g_min_f2, 2, 0, false, "min opt");
/* zero? */
- set_function_chooser(sc, sc->IS_ZERO, is_zero_chooser);
+ set_function_chooser(sc, sc->is_zero_symbol, is_zero_chooser);
/* = */
- f = set_function_chooser(sc, sc->EQ, equal_chooser);
+ f = set_function_chooser(sc, sc->eq_symbol, equal_chooser);
sc->equal_class = c_function_class(f);
equal_s_ic = make_function_with_class(sc, f, "=", g_equal_s_ic, 2, 0, false, "= opt");
@@ -51544,7 +51853,7 @@ static void init_choosers(s7_scheme *sc)
mod_si_is_zero = make_function_with_class(sc, f, "=", g_mod_si_is_zero, 2, 0, false, "= opt");
/* < */
- f = set_function_chooser(sc, sc->LT, less_chooser);
+ f = set_function_chooser(sc, sc->lt_symbol, less_chooser);
less_s_ic = make_function_with_class(sc, f, "<", g_less_s_ic, 2, 0, false, "< opt");
less_s0 = make_function_with_class(sc, f, "<", g_less_s0, 2, 0, false, "< opt");
@@ -51552,102 +51861,102 @@ static void init_choosers(s7_scheme *sc)
less_length_ic = make_function_with_class(sc, f, "<", g_less_length_ic, 2, 0, false, "< opt");
/* > */
- f = set_function_chooser(sc, sc->GT, greater_chooser);
+ f = set_function_chooser(sc, sc->gt_symbol, greater_chooser);
greater_s_ic = make_function_with_class(sc, f, ">", g_greater_s_ic, 2, 0, false, "> opt");
greater_s_fc = make_function_with_class(sc, f, ">", g_greater_s_fc, 2, 0, false, "> opt");
greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false, "> opt");
greater_2_f = make_function_with_class(sc, f, ">", g_greater_2_f, 2, 0, false, "> opt");
/* <= */
- f = set_function_chooser(sc, sc->LEQ, leq_chooser);
+ f = set_function_chooser(sc, sc->leq_symbol, leq_chooser);
leq_s_ic = make_function_with_class(sc, f, "<=", g_leq_s_ic, 2, 0, false, "<= opt");
leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false, "<= opt");
/* >= */
- f = set_function_chooser(sc, sc->GEQ, geq_chooser);
+ f = set_function_chooser(sc, sc->geq_symbol, geq_chooser);
geq_s_ic = make_function_with_class(sc, f, ">=", g_geq_s_ic, 2, 0, false, ">= opt");
geq_s_fc = make_function_with_class(sc, f, ">=", g_geq_s_fc, 2, 0, false, ">= opt");
geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false, ">= opt");
geq_length_ic = make_function_with_class(sc, f, ">=", g_geq_length_ic, 2, 0, false, ">= opt");
/* random */
- f = set_function_chooser(sc, sc->RANDOM, random_chooser);
+ f = set_function_chooser(sc, sc->random_symbol, random_chooser);
random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false, "random opt");
random_ic = make_function_with_class(sc, f, "random", g_random_ic, 1, 0, false, "random opt");
random_rc = make_function_with_class(sc, f, "random", g_random_rc, 1, 0, false, "random opt");
#endif
/* list */
- f = set_function_chooser(sc, sc->LIST, list_chooser);
+ f = set_function_chooser(sc, sc->list_symbol, list_chooser);
list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false, "list opt");
list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false, "list opt");
list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false, "list opt");
/* aritable? */
- f = set_function_chooser(sc, sc->IS_ARITABLE, is_aritable_chooser);
+ f = set_function_chooser(sc, sc->is_aritable_symbol, is_aritable_chooser);
is_aritable_ic = make_function_with_class(sc, f, "aritable?", g_is_aritable_ic, 2, 0, false, "aritable? opt");
/* char=? */
- f = set_function_chooser(sc, sc->CHAR_EQ, char_equal_chooser);
+ f = set_function_chooser(sc, sc->char_eq_symbol, char_equal_chooser);
simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false, "char=? opt");
char_equal_s_ic = make_function_with_class(sc, f, "char=?", g_char_equal_s_ic, 2, 0, false, "char=? opt");
char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false, "char=? opt");
/* char>? */
- f = set_function_chooser(sc, sc->CHAR_GT, char_greater_chooser);
+ f = set_function_chooser(sc, sc->char_gt_symbol, char_greater_chooser);
char_greater_s_ic = make_function_with_class(sc, f, "char>?", g_char_greater_s_ic, 2, 0, false, "char>? opt");
char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false, "char>? opt");
/* char<? */
- f = set_function_chooser(sc, sc->CHAR_LT, char_less_chooser);
+ f = set_function_chooser(sc, sc->char_lt_symbol, char_less_chooser);
char_less_s_ic = make_function_with_class(sc, f, "char<?", g_char_less_s_ic, 2, 0, false, "char<? opt");
char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false, "char<? opt");
/* char-position */
- f = set_function_chooser(sc, sc->CHAR_POSITION, char_position_chooser);
+ f = set_function_chooser(sc, sc->char_position_symbol, char_position_chooser);
char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false, "char-position opt");
/* string->symbol */
- set_function_chooser(sc, sc->STRING_TO_SYMBOL, string_to_symbol_chooser);
+ set_function_chooser(sc, sc->string_to_symbol_symbol, string_to_symbol_chooser);
/* string=? */
- f = set_function_chooser(sc, sc->STRING_EQ, string_equal_chooser);
+ f = set_function_chooser(sc, sc->string_eq_symbol, string_equal_chooser);
string_equal_s_ic = make_function_with_class(sc, f, "string=?", g_string_equal_s_ic, 2, 0, false, "string=? opt");
string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false, "string=? opt");
/* substring */
substring_to_temp = s7_make_function(sc, "substring", g_substring_to_temp, 2, 1, false, "substring opt");
- s7_function_set_class(substring_to_temp, slot_value(global_slot(sc->SUBSTRING)));
+ s7_function_set_class(substring_to_temp, slot_value(global_slot(sc->substring_symbol)));
/* number->string */
number_to_string_temp = s7_make_function(sc, "number->string", g_number_to_string_temp, 1, 1, false, "number->string opt");
- s7_function_set_class(number_to_string_temp, slot_value(global_slot(sc->NUMBER_TO_STRING)));
+ s7_function_set_class(number_to_string_temp, slot_value(global_slot(sc->number_to_string_symbol)));
/* string>? */
- f = set_function_chooser(sc, sc->STRING_GT, string_greater_chooser);
+ f = set_function_chooser(sc, sc->string_gt_symbol, string_greater_chooser);
string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false, "string>? opt");
/* string<? */
- f = set_function_chooser(sc, sc->STRING_LT, string_less_chooser);
+ f = set_function_chooser(sc, sc->string_lt_symbol, string_less_chooser);
string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false, "string<? opt");
/* string-ref */
- set_function_chooser(sc, sc->STRING_REF, string_ref_chooser);
+ set_function_chooser(sc, sc->string_ref_symbol, string_ref_chooser);
/* string-set! */
- set_function_chooser(sc, sc->STRING_SET, string_set_chooser);
+ set_function_chooser(sc, sc->string_set_symbol, string_set_chooser);
/* string-append */
- f = set_function_chooser(sc, sc->STRING_APPEND, string_append_chooser);
+ f = set_function_chooser(sc, sc->string_append_symbol, string_append_chooser);
string_append_to_temp = make_function_with_class(sc, f, "string-append", g_string_append_to_temp, 0, 0, true, "string-append opt");
/* symbol->string */
- f = slot_value(global_slot(sc->SYMBOL_TO_STRING));
+ f = slot_value(global_slot(sc->symbol_to_string_symbol));
symbol_to_string_uncopied = s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, "symbol->string opt");
s7_function_set_class(symbol_to_string_uncopied, f);
/* vector-ref */
- f = set_function_chooser(sc, sc->VECTOR_REF, vector_ref_chooser);
+ f = set_function_chooser(sc, sc->vector_ref_symbol, vector_ref_chooser);
vector_ref_ic = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic, 2, 0, false, "vector-ref opt");
vector_ref_ic_0 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_0, 1, 0, false, "vector-ref opt");
vector_ref_ic_1 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_1, 1, 0, false, "vector-ref opt");
@@ -51659,34 +51968,34 @@ static void init_choosers(s7_scheme *sc)
constant_vector_ref_gs = make_function_with_class(sc, f, "vector-ref", g_constant_vector_ref_gs, 2, 0, false, "vector-ref opt");
/* vector-set! */
- f = set_function_chooser(sc, sc->VECTOR_SET, vector_set_chooser);
+ f = set_function_chooser(sc, sc->vector_set_symbol, vector_set_chooser);
vector_set_ic = make_function_with_class(sc, f, "vector-set!", g_vector_set_ic, 3, 0, false, "vector-set! opt");
vector_set_vref = make_function_with_class(sc, f, "vector-set!", g_vector_set_vref, 3, 0, false, "vector-set! opt");
vector_set_vector_ref = make_function_with_class(sc, f, "vector-set!", g_vector_set_vector_ref, 3, 0, false, "vector-set! opt");
vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false, "vector-set! opt");
/* list-ref */
- f = set_function_chooser(sc, sc->LIST_REF, list_ref_chooser);
+ f = set_function_chooser(sc, sc->list_ref_symbol, list_ref_chooser);
list_ref_ic = make_function_with_class(sc, f, "list-ref", g_list_ref_ic, 2, 0, false, "list-ref opt");
/* list-set! */
- f = set_function_chooser(sc, sc->LIST_SET, list_set_chooser);
+ f = set_function_chooser(sc, sc->list_set_symbol, list_set_chooser);
list_set_ic = make_function_with_class(sc, f, "list-set!", g_list_set_ic, 3, 0, false, "list-set! opt");
/* hash-table-ref */
- f = set_function_chooser(sc, sc->HASH_TABLE_REF, hash_table_ref_chooser);
+ f = set_function_chooser(sc, sc->hash_table_ref_symbol, hash_table_ref_chooser);
hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false, "hash-table-ref opt");
hash_table_ref_ss = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_ss, 2, 0, false, "hash-table-ref opt");
hash_table_ref_car = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_car, 2, 0, false, "hash-table-ref opt");
/* format */
- f = set_function_chooser(sc, sc->FORMAT, format_chooser);
+ f = set_function_chooser(sc, sc->format_symbol, format_chooser);
format_allg = make_function_with_class(sc, f, "format", g_format_allg, 1, 0, true, "format opt");
format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true, "format opt");
format_just_newline = make_function_with_class(sc, f, "format", g_format_just_newline, 2, 0, false, "format opt");
/* not */
- f = set_function_chooser(sc, sc->NOT, not_chooser);
+ f = set_function_chooser(sc, sc->not_symbol, not_chooser);
not_is_pair = make_function_with_class(sc, f, "not", g_not_is_pair, 1, 0, false, "not opt");
not_is_null = make_function_with_class(sc, f, "not", g_not_is_null, 1, 0, false, "not opt");
not_is_list = make_function_with_class(sc, f, "not", g_not_is_list, 1, 0, false, "not opt");
@@ -51701,55 +52010,53 @@ static void init_choosers(s7_scheme *sc)
not_c_c = make_function_with_class(sc, f, "not", g_not_c_c, 1, 0, false, "not opt");
/* pair? */
- f = set_function_chooser(sc, sc->IS_PAIR, is_pair_chooser);
+ f = set_function_chooser(sc, sc->is_pair_symbol, is_pair_chooser);
is_pair_car = make_function_with_class(sc, f, "pair?", g_is_pair_car, 1, 0, false, "pair? opt");
is_pair_cdr = make_function_with_class(sc, f, "pair?", g_is_pair_cdr, 1, 0, false, "pair? opt");
is_pair_cadr = make_function_with_class(sc, f, "pair?", g_is_pair_cadr, 1, 0, false, "pair? opt");
/* null? */
- f = set_function_chooser(sc, sc->IS_NULL, is_null_chooser);
+ f = set_function_chooser(sc, sc->is_null_symbol, is_null_chooser);
is_null_cdr = make_function_with_class(sc, f, "null?", g_is_null_cdr, 1, 0, false, "null? opt");
/* eq? */
- f = set_function_chooser(sc, sc->IS_EQ, is_eq_chooser);
+ f = set_function_chooser(sc, sc->is_eq_symbol, is_eq_chooser);
is_eq_car = make_function_with_class(sc, f, "eq?", g_is_eq_car, 2, 0, false, "eq? opt");
is_eq_car_q = make_function_with_class(sc, f, "eq?", g_is_eq_car_q, 2, 0, false, "eq? opt");
is_eq_caar_q = make_function_with_class(sc, f, "eq?", g_is_eq_caar_q, 2, 0, false, "eq? opt");
/* member */
- f = set_function_chooser(sc, sc->MEMBER, member_chooser);
+ f = set_function_chooser(sc, sc->member_symbol, member_chooser);
member_ss = make_function_with_class(sc, f, "member", g_member_ss, 2, 0, false, "member opt");
member_sq = make_function_with_class(sc, f, "member", g_member_sq, 2, 0, false, "member opt");
member_num_s = make_function_with_class(sc, f, "member", g_member_num_s, 2, 0, false, "member opt");
/* memq */
-#if (!WITH_PURE_S7)
- f = set_function_chooser(sc, sc->MEMQ, memq_chooser);
+ f = set_function_chooser(sc, sc->memq_symbol, memq_chooser);
/* is pure-s7, use member here */
-#endif
memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false, "memq opt");
memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false, "memq opt");
memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false, "memq opt");
memq_car = make_function_with_class(sc, f, "memq", g_memq_car, 2, 0, false, "memq opt");
/* read-char */
- f = set_function_chooser(sc, sc->READ_CHAR, read_char_chooser);
+ f = set_function_chooser(sc, sc->read_char_symbol, read_char_chooser);
read_char_0 = make_function_with_class(sc, f, "read-char", g_read_char_0, 0, 0, false, "read-char opt");
read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false, "read-char opt");
/* write-char */
- f = set_function_chooser(sc, sc->WRITE_CHAR, write_char_chooser);
+ f = set_function_chooser(sc, sc->write_char_symbol, write_char_chooser);
write_char_1 = make_function_with_class(sc, f, "write-char", g_write_char_1, 1, 0, false, "write-char opt");
/* read-line */
read_line_uncopied = s7_make_function(sc, "read-line", g_read_line_uncopied, 1, 1, false, "read-line opt");
- s7_function_set_class(read_line_uncopied, slot_value(global_slot(sc->READ_LINE)));
+ s7_function_set_class(read_line_uncopied, slot_value(global_slot(sc->read_line_symbol)));
/* write-string */
- set_function_chooser(sc, sc->WRITE_STRING, write_string_chooser);
+ set_function_chooser(sc, sc->write_string_symbol, write_string_chooser);
/* eval-string */
- set_function_chooser(sc, sc->EVAL_STRING, eval_string_chooser);
+ set_function_chooser(sc, sc->eval_string_symbol, eval_string_chooser);
/* or and if simple cases */
or_direct = s7_make_function(sc, "or", g_or_direct, 0, 0, true, "or opt");
@@ -51834,7 +52141,7 @@ static bool optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
if (typesflag(car(body)) != SYNTACTIC_PAIR)
{
pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
- set_type(car(body), SYNTACTIC_PAIR);
+ set_syntactic_pair(car(body));
}
}
}
@@ -52064,7 +52371,7 @@ static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
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 sc->envir is sc->nil, we're at the top-level, but the global_slot check should suffice for that */
set_c_call(arg, all_x_eval(sc, car(arg), e, (s7_is_list(sc, e)) ? pair_symbol_is_safe : let_symbol_is_safe));
}
@@ -52077,10 +52384,10 @@ static void opt_generator(s7_scheme *sc, s7_pointer func, s7_pointer expr, int h
s7_pointer body;
body = closure_body(func);
if ((s7_list_length(sc, body) == 2) &&
- (caar(body) == sc->LET_SET) &&
+ (caar(body) == sc->let_set_symbol) &&
(is_optimized(car(body))) &&
(optimize_op(car(body)) == HOP_SAFE_C_SQS) &&
- (caadr(body) == sc->WITH_LET) &&
+ (caadr(body) == sc->with_let_symbol) &&
(is_symbol(cadr(cadr(body)))))
{
s7_pointer args;
@@ -52101,7 +52408,7 @@ static void opt_generator(s7_scheme *sc, s7_pointer func, s7_pointer expr, int h
static bool is_lambda(s7_scheme *sc, s7_pointer sym)
{
- return((sym == sc->LAMBDA) && (symbol_id(sym) == 0));
+ return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0));
/* symbol_id==0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */
}
@@ -52129,7 +52436,6 @@ static bool optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fun
if (func_is_safe) /* safe c function */
{
set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_C : OP_SAFE_C_S));
-
/* we can't simply check is_global here to forego symbol value lookup later because we aren't
* tracking local vars, so the global bit may be on right now, but won't be when
* this code is evaluated. But memq(sym, e) would catch such cases.
@@ -52137,7 +52443,6 @@ static bool optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fun
* But global symbols are rare, and I don't see a huge savings in the lookup time --
* in callgrind it's about 7/lookup in both cases.
*/
-
choose_c_function(sc, expr, func, 1);
return(true);
}
@@ -52287,7 +52592,7 @@ static bool optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fun
if (typesflag(car(body)) != SYNTACTIC_PAIR)
{
pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
- set_type(car(body), SYNTACTIC_PAIR);
+ set_syntactic_pair(car(body));
}
}
}
@@ -52426,7 +52731,7 @@ static s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7
if ((symbol_tag(symbol) == sc->syms_tag) &&
(rdirect_memq(sc, symbol, e))) /* it's probably a local variable reference */
- return(sc->NIL);
+ return(sc->nil);
if (is_global(symbol))
return(global_slot(symbol));
@@ -52809,6 +53114,12 @@ static bool optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer fu
/* unsafe func here won't work unless we check that later and make the new arg list (for {list} etc)
* (and it has to be the last pair else the unknown_g stuff can mess up)
*/
+ if (car(arg2) == sc->quote_symbol)
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_Q);
+ choose_c_function(sc, expr, func, 2);
+ return(true);
+ }
set_unsafe_optimize_op(expr, hop + OP_SAFE_C_opSq_P);
choose_c_function(sc, expr, func, 2);
return(false);
@@ -52831,7 +53142,7 @@ static bool optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer fu
{
if (quotes == 1)
{
- if (car(arg1) == sc->QUOTE)
+ if (car(arg1) == sc->quote_symbol)
set_optimize_op(expr, hop + OP_SAFE_C_QP);
else set_optimize_op(expr, hop + OP_SAFE_C_PQ);
set_unsafely_optimized(expr);
@@ -53075,10 +53386,10 @@ static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if (pairs == quotes + all_x_count(expr))
{
set_optimized(expr);
- if ((symbols == 2) &&
- (quotes == 1))
+ if (quotes == 1)
{
- if ((is_symbol(arg1)) &&
+ if ((symbols == 2) &&
+ (is_symbol(arg1)) &&
(is_symbol(arg3)))
{
set_opt_con1(cdr(expr), cadr(arg2));
@@ -53087,6 +53398,16 @@ static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
choose_c_function(sc, expr, func, 3);
return(true);
}
+ if ((symbols == 1) &&
+ (is_symbol(arg3)) &&
+ (is_pair(arg2)) &&
+ (car(arg2) == sc->quote_symbol) &&
+ (is_safe_c_s(arg1)))
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_Q_S);
+ choose_c_function(sc, expr, func, 3);
+ return(true);
+ }
}
annotate_args(sc, cdr(expr), e);
set_arglist_length(expr, small_int(3));
@@ -53225,7 +53546,7 @@ static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if (c_function_call(func) == g_catch)
{
if (((bad_pairs == 2) && (!is_pair(arg1))) ||
- ((bad_pairs == 3) && (car(arg1) == sc->QUOTE)))
+ ((bad_pairs == 3) && (car(arg1) == sc->quote_symbol)))
{
s7_pointer body_lambda, error_lambda;
body_lambda = arg2;
@@ -53247,7 +53568,7 @@ static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if ((arg1 == sc->T) &&
(is_null(cdddr(error_lambda))) &&
(!is_symbol(error_result)) &&
- ((!is_pair(error_result)) || (car(error_result) == sc->QUOTE)))
+ ((!is_pair(error_result)) || (car(error_result) == sc->quote_symbol)))
{
set_optimize_op(expr, hop + OP_C_CATCH_ALL);
set_c_function(expr, func);
@@ -53440,13 +53761,16 @@ static bool optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, s7_pointer e)
{
opcode_t op;
- s7_pointer p;
+ s7_pointer p, orig_e, body;
if (!is_pair(cdr(expr))) /* cddr(expr) might be null if, for example, (begin (let ...)) */
return(false);
op = (opcode_t)syntax_opcode(func);
sc->w = e;
+ orig_e = e;
+ body = cdr(expr);
+
switch (op)
{
case OP_QUOTE:
@@ -53456,13 +53780,21 @@ static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
case OP_LET:
case OP_LET_STAR:
if (is_symbol(cadr(expr)))
- e = collect_collisions(sc, caddr(expr), cons(sc, add_sym_to_list(sc, cadr(expr)), e));
- else e = collect_collisions(sc, cadr(expr), e);
+ {
+ e = collect_collisions(sc, caddr(expr), cons(sc, add_sym_to_list(sc, cadr(expr)), e));
+ body = cdddr(expr);
+ }
+ else
+ {
+ e = collect_collisions(sc, cadr(expr), e);
+ body = cddr(expr);
+ }
break;
case OP_LETREC:
case OP_LETREC_STAR:
e = collect_collisions(sc, cadr(expr), e);
+ body = cddr(expr);
break;
case OP_DEFINE_MACRO:
@@ -53484,6 +53816,7 @@ static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
else e = collect_collisions_star(sc, cdr(name_args), e);
/* fprintf(stderr, "%s -> e: %s\n", DISPLAY(expr), DISPLAY(e)); */
}
+ body = cddr(expr);
break;
case OP_LAMBDA:
@@ -53491,21 +53824,25 @@ static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
if (is_symbol(cadr(expr))) /* (lambda args ...) */
e = cons(sc, add_sym_to_list(sc, cadr(expr)), e);
else e = collect_collisions_star(sc, cadr(expr), e);
+ body = cddr(expr);
break;
case OP_SET:
if (is_symbol(cadr(expr)))
e = cons(sc, add_sym_to_list(sc, cadr(expr)), e);
+ body = sc->nil;
break;
case OP_DO:
e = collect_collisions(sc, cadr(expr), e);
+ body = cddr(expr);
break;
case OP_WITH_LET:
if (sc->safety != 0)
hop = 0;
- e = sc->NIL;
+ orig_e = sc->nil;
+ e = sc->nil;
/* we can't trust anything here, so hop ought to be off. For example,
* (define (hi)
* (let ((e (sublet (curlet)
@@ -53522,8 +53859,11 @@ static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
/* fprintf(stderr, "%s -> e: %s\n", DISPLAY(expr), DISPLAY(e)); */
for (p = cdr(expr); is_pair(p); p = cdr(p))
- if ((is_pair(car(p))) && (!is_checked(car(p)))) /* ((typeflag & (0xff | T_CHECKED)) == T_PAIR) is not faster */
- optimize_expression(sc, car(p), hop, e);
+ {
+ if (p == body) orig_e = e;
+ if ((is_pair(car(p))) && (!is_checked(car(p)))) /* ((typeflag & (0xff | T_CHECKED)) == T_PAIR) is not faster */
+ optimize_expression(sc, car(p), hop, orig_e);
+ }
if ((hop == 1) &&
(symbol_id(car(expr)) == 0))
@@ -53631,7 +53971,7 @@ static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
else
{
if ((is_pair(car(test))) &&
- (caar(test) == sc->NOT))
+ (caar(test) == sc->not_symbol))
{
set_c_call(test, all_x_eval(sc, cadar(test), e, pair_symbol_is_safe));
if (is_null(b2))
@@ -53672,7 +54012,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
if (is_syntactic(car_expr))
return(optimize_syntax(sc, expr, slot_value(global_slot(car_expr)), hop, e));
- if (car_expr == sc->QUOTE)
+ if (car_expr == sc->quote_symbol)
return(false);
func = find_uncomplicated_symbol(sc, car_expr, e);
@@ -53706,7 +54046,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
* of the current function being optimized from being confused with some previous definition
* of the same name. But method lists have global names so the global bit is off even though the
* thing is actually a safe global. But no closure can be considered safe in the hop sense --
- * even a global function might be redefined at anuy time, and previous uses of it in other functions
+ * even a global function might be redefined at any time, and previous uses of it in other functions
* need to reflect its new value.
* So, closures are always checked, but built-in functions are used as if never redefined until that redefinition.
* costs: index 6/1380, t502: 2/12900, bench: 43/4134, snd-test: 22/37200
@@ -53741,7 +54081,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
if (!optimize_expression(sc, car_p, orig_hop, e))
{
bad_pairs++;
- if ((car(car_p) == sc->QUOTE) &&
+ if ((car(car_p) == sc->quote_symbol) &&
(is_pair(cdr(car_p))) &&
(is_null(cddr(car_p))))
quotes++;
@@ -53753,7 +54093,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
(is_unsafe(car_p)))
{
bad_pairs++;
- if ((car(car_p) == sc->QUOTE) &&
+ if ((car(car_p) == sc->quote_symbol) &&
(is_pair(cdr(car_p))) &&
(is_null(cddr(car_p))))
quotes++;
@@ -53779,7 +54119,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
else
{
if ((sc->undefined_identifier_warnings) &&
- (func == sc->UNDEFINED) && /* car_expr is not in e or global */
+ (func == sc->undefined) && /* car_expr is not in e or global */
(symbol_tag(car_expr) == 0)) /* and we haven't looked it up earlier */
{
s7_pointer p;
@@ -53809,7 +54149,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
if (is_pair(car_p))
{
pairs++;
- if ((hop != 0) && (car(car_p) == sc->QUOTE))
+ if ((hop != 0) && (car(car_p) == sc->quote_symbol))
quotes++;
if (!is_checked(car_p))
optimize_expression(sc, car_p, hop, e);
@@ -53825,7 +54165,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
(!is_optimized(expr)))
{
/* len=0 case is almost entirely arglists */
- set_opt_con1(expr, sc->GC_NIL);
+ set_opt_con1(expr, sc->gc_nil);
if (pairs == 0)
{
if (len == 0)
@@ -53837,7 +54177,7 @@ static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_poin
if (len == 1)
{
- if (car_expr != sc->QUOTE) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */
+ if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */
{
set_unsafe_optimize_op(expr, OP_UNKNOWN_G);
/* hooboy -- we get here in let bindings...
@@ -54161,7 +54501,7 @@ static bool form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_e
for (p = cdr(x); is_pair(p); p = cdr(p))
if ((is_pair(car(p))) &&
- (((!is_optimized(car(p))) && (caar(p) != sc->QUOTE)) ||
+ (((!is_optimized(car(p))) && (caar(p) != sc->quote_symbol)) ||
(is_unsafe(car(p))) ||
(caar(p) == func))) /* func called as arg, so not tail call */
return(false);
@@ -54182,7 +54522,7 @@ static bool form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_e
((is_possibly_safe(f)) &&
(is_pair(cdr(x))) &&
(is_pair(cddr(x))) &&
- (unsafe_is_safe(sc, f, cadr(x), caddr(x), (is_pair(cdddr(x))) ? cadddr(x) : NULL, sc->NIL))))) ||
+ (unsafe_is_safe(sc, f, cadr(x), caddr(x), (is_pair(cdddr(x))) ? cadddr(x) : NULL, sc->nil))))) ||
((is_closure(f)) &&
(is_safe_closure(f))))
{
@@ -54350,18 +54690,18 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int *ar
}
else
{
- if (car_w != sc->KEY_REST)
+ if (car_w != sc->key_rest_symbol)
{
if (s7_is_constant(car_w))
{
- if (car_w == sc->KEY_ALLOW_OTHER_KEYS)
+ if (car_w == sc->key_allow_other_keys_symbol)
{
if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */
eval_error(sc, ":allow-other-keys should be the last parameter: ~A", args);
if (w == top)
eval_error(sc, ":allow-other-keys can't be the only parameter: ~A", args);
set_allow_other_keys(top);
- cdr(v) = sc->NIL;
+ cdr(v) = sc->nil;
}
else /* (lambda* (pi) ...) */
eval_error(sc, "lambda* parameter '~A is a constant", car_w);
@@ -54384,7 +54724,7 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int *ar
else
{
if (is_immutable_symbol(cadr(w)))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), w)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), w)));
}
set_local(cadr(w));
}
@@ -54411,47 +54751,51 @@ static void check_lambda(s7_scheme *sc)
code = sc->code;
if (!is_pair(code)) /* (lambda) or (lambda . 1) */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "lambda: no args? ~A", sc->cur_code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda: no args? ~A", current_code(sc));
body = cdr(code);
if (!is_pair(body)) /* (lambda #f) */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "lambda: no body? ~A", code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda: no body? ~A", code);
/* in many cases, this is a no-op -- we already checked at define */
check_lambda_args(sc, car(code), NULL);
clear_syms_in_list(sc);
/* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...)
- * It's actually safe to ignore main_stack_op, but s7test has some dubious tests that this
- * check gets around -- need to decide about these cases!
+ * one problem the hop=0 fixes is that safe closures assume the old frame exists, so we need to check for define below
+ * I wonder about apply define...
*/
- if ((sc->safety != 0) ||
- (main_stack_op(sc) != OP_DEFINE1))
- optimize(sc, body, 0, sc->NIL);
- else optimize_lambda(sc, true, sc->GC_NIL, car(code), body); /* why was lambda the func? */
+ if ((sc->safety == 0) &&
+ ((main_stack_op(sc) == OP_DEFINE1) ||
+ (((sc->stack_end - sc->stack_start) > 4) &&
+ (((opcode_t)(sc->stack_end[-5])) == OP_DEFINE1) && /* surely if define is ok, so is define dilambda? 16-Apr-16 */
+ (sc->op_stack_now > sc->op_stack) &&
+ ((*(sc->op_stack_now - 1)) == (s7_pointer)slot_value(global_slot(sc->dilambda_symbol))))))
+ optimize_lambda(sc, true, sc->gc_nil, car(code), body); /* why was lambda the func? */
+ else optimize(sc, body, 0, sc->nil);
if ((is_overlaid(code)) &&
(has_opt_back(code)))
- pair_set_syntax_symbol(code, sc->LAMBDA_UNCHECKED);
+ pair_set_syntax_symbol(code, sc->lambda_unchecked_symbol);
}
static void check_lambda_star(s7_scheme *sc)
{
if ((!is_pair(sc->code)) ||
(!is_pair(cdr(sc->code)))) /* (lambda*) or (lambda* #f) */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "lambda*: no args or no body? ~A", sc->code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda*: no args or no body? ~A", sc->code);
car(sc->code) = check_lambda_star_args(sc, car(sc->code), NULL);
clear_syms_in_list(sc);
if ((sc->safety != 0) ||
(main_stack_op(sc) != OP_DEFINE1))
- optimize(sc, cdr(sc->code), 0, sc->NIL);
- else optimize_lambda(sc, false, sc->GC_NIL, car(sc->code), cdr(sc->code));
+ optimize(sc, cdr(sc->code), 0, sc->nil);
+ else optimize_lambda(sc, false, sc->gc_nil, car(sc->code), cdr(sc->code));
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->LAMBDA_STAR_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->lambda_star_unchecked_symbol);
}
static s7_pointer check_when(s7_scheme *sc)
@@ -54464,9 +54808,9 @@ static s7_pointer check_when(s7_scheme *sc)
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
{
- pair_set_syntax_symbol(sc->code, sc->WHEN_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->when_unchecked_symbol);
if (is_symbol(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->WHEN_S);
+ pair_set_syntax_symbol(sc->code, sc->when_s_symbol);
}
return(sc->code);
}
@@ -54482,15 +54826,13 @@ static s7_pointer check_unless(s7_scheme *sc)
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
{
- pair_set_syntax_symbol(sc->code, sc->UNLESS_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->unless_unchecked_symbol);
if (is_symbol(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->UNLESS_S);
+ pair_set_syntax_symbol(sc->code, sc->unless_s_symbol);
}
return(sc->code);
}
-/* (apply unless (list values :key #f)) */
-
static s7_pointer check_case(s7_scheme *sc)
{
@@ -54521,15 +54863,15 @@ static s7_pointer check_case(s7_scheme *sc)
if (bodies_simplest)
{
if ((is_pair(cadar(x))) &&
- (caadar(x) != sc->QUOTE))
+ (caadar(x) != sc->quote_symbol))
{
if (is_pair(caar(x)))
bodies_simplest = false;
else
{
- if ((caar(x) != sc->ELSE) && (caar(x) != sc->else_symbol) &&
+ if ((caar(x) != sc->else_object) && (caar(x) != sc->else_symbol) &&
((!is_symbol(caar(x))) ||
- (s7_symbol_value(sc, caar(x)) != sc->ELSE)))
+ (s7_symbol_value(sc, caar(x)) != sc->else_object)))
bodies_simplest = false;
}
}
@@ -54537,9 +54879,9 @@ static s7_pointer check_case(s7_scheme *sc)
y = caar(x);
if (!is_pair(y))
{
- if ((y != sc->ELSE) && (y != sc->else_symbol) && /* (case 1 (2 1)) */
+ if ((y != sc->else_object) && (y != sc->else_symbol) && /* (case 1 (2 1)) */
((!is_symbol(y)) ||
- (s7_symbol_value(sc, y) != sc->ELSE))) /* "proper list" below because: (case 1 (() 2) ... */
+ (s7_symbol_value(sc, y) != sc->else_object))) /* "proper list" below because: (case 1 (() 2) ... */
eval_error(sc, "case clause key list ~A is not a proper list or 'else'", y);
if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */
eval_error(sc, "case 'else' clause, ~A, is not the last clause", x);
@@ -54574,8 +54916,8 @@ static s7_pointer check_case(s7_scheme *sc)
}
}
y = car(x);
- if ((cadr(y) == sc->FEED_TO) &&
- (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
+ if ((cadr(y) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
{
has_feed_to = true;
if (!is_pair(cddr(y))) /* (case 1 (else =>)) */
@@ -54593,7 +54935,7 @@ static s7_pointer check_case(s7_scheme *sc)
set_opt_key(x, caar(x));
if (is_pair(opt_key(x))) set_opt_clause(x, cadar(x));
}
- pair_set_syntax_symbol(sc->code, sc->CASE_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->case_unchecked_symbol);
if ((!has_feed_to) &&
(keys_simple))
@@ -54601,7 +54943,7 @@ static s7_pointer check_case(s7_scheme *sc)
if (have_else) /* don't combine ifs ! */
{
if (is_symbol(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLE);
+ pair_set_syntax_symbol(sc->code, sc->case_simple_symbol);
}
else
{
@@ -54609,12 +54951,12 @@ static s7_pointer check_case(s7_scheme *sc)
{
if ((bodies_simple) &&
(is_symbol(car(sc->code))))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLEST);
+ pair_set_syntax_symbol(sc->code, sc->case_simplest_symbol);
else
{
if ((is_optimized(car(sc->code))) &&
(optimize_op(car(sc->code)) == HOP_SAFE_C_SS))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLEST_SS);
+ pair_set_syntax_symbol(sc->code, sc->case_simplest_ss_symbol);
}
for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
set_opt_key(x, caaar(x));
@@ -54624,18 +54966,18 @@ static s7_pointer check_case(s7_scheme *sc)
if (bodies_simple)
{
if (is_symbol(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLER_1);
+ pair_set_syntax_symbol(sc->code, sc->case_simpler_1_symbol);
else
{
if ((is_optimized(car(sc->code))) &&
(optimize_op(car(sc->code)) == HOP_SAFE_C_SS))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLER_SS);
+ pair_set_syntax_symbol(sc->code, sc->case_simpler_ss_symbol);
}
}
else
{
if (is_symbol(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->CASE_SIMPLER);
+ pair_set_syntax_symbol(sc->code, sc->case_simpler_symbol);
}
}
}
@@ -54649,7 +54991,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
{
s7_pointer binding;
- pair_set_syntax_symbol(sc->code, sc->LET_ONE);
+ pair_set_syntax_symbol(sc->code, sc->let_one_symbol);
binding = car(start);
if (is_pair(cadr(binding)))
@@ -54660,12 +55002,12 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
{
set_opt_sym2(cdr(sc->code), car(binding));
set_opt_pair2(sc->code, cadr(binding));
- pair_set_syntax_symbol(sc->code, sc->LET_Z);
+ pair_set_syntax_symbol(sc->code, sc->let_z_symbol);
if ((is_h_safe_c_s(cadr(binding))) &&
(is_pair(cadr(sc->code)))) /* one body expr is a pair */
{
- pair_set_syntax_symbol(sc->code, sc->LET_opSq_P);
+ pair_set_syntax_symbol(sc->code, sc->let_opsq_p_symbol);
set_opt_sym2(sc->code, cadr(cadr(binding)));
if ((!is_optimized(cadr(sc->code))) &&
@@ -54686,7 +55028,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
if (is_h_safe_c_s(cadr(binding)))
{
- pair_set_syntax_symbol(sc->code, sc->LET_opSq);
+ pair_set_syntax_symbol(sc->code, sc->let_opsq_symbol);
set_opt_sym2(sc->code, cadr(cadr(binding)));
return(sc->code);
}
@@ -54694,7 +55036,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
set_opt_pair2(sc->code, cadr(binding));
if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS)
{
- pair_set_syntax_symbol(sc->code, sc->LET_opSSq);
+ pair_set_syntax_symbol(sc->code, sc->let_opssq_symbol);
set_opt_sym3(sc->code, caddr(cadr(binding)));
}
else
@@ -54702,7 +55044,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
if (optimize_op(cadr(binding)) == HOP_SAFE_C_C)
{
set_opt_sym3(sc->code, car(binding));
- pair_set_syntax_symbol(sc->code, sc->LET_opCq);
+ pair_set_syntax_symbol(sc->code, sc->let_opcq_symbol);
}
/* let_all_x here is slightly slower than fallback let_z */
}
@@ -54716,12 +55058,12 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
if (is_symbol(p))
{
set_opt_sym2(sc->code, p);
- pair_set_syntax_symbol(sc->code, sc->LET_S);
+ pair_set_syntax_symbol(sc->code, sc->let_s_symbol);
}
else
{
set_opt_con2(sc->code, p);
- pair_set_syntax_symbol(sc->code, sc->LET_C);
+ pair_set_syntax_symbol(sc->code, sc->let_c_symbol);
}
}
return(sc->code);
@@ -54776,7 +55118,7 @@ static s7_pointer check_let(s7_scheme *sc)
if (is_null(cddr(sc->code))) /* (let hi () ) */
eval_error(sc, "named let has no body: ~A", sc->code);
if (is_immutable_symbol(car(sc->code)))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), sc->code)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), sc->code)));
set_local(car(sc->code));
start = cadr(sc->code);
}
@@ -54808,7 +55150,7 @@ static s7_pointer check_let(s7_scheme *sc)
eval_error(sc, "bad variable ~S in let", carx);
if (is_immutable_symbol(y))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
/* check for name collisions -- not sure this is required by Scheme */
if (symbol_tag(y) == sc->syms_tag)
@@ -54832,11 +55174,11 @@ static s7_pointer check_let(s7_scheme *sc)
s7_pointer ex;
if (is_null(start))
- pair_set_syntax_symbol(sc->code, sc->NAMED_LET_NO_VARS);
- else pair_set_syntax_symbol(sc->code, sc->NAMED_LET);
+ pair_set_syntax_symbol(sc->code, sc->named_let_no_vars_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->named_let_symbol);
/* this is (let name ...) so the initial values need to be removed from the closure arg list */
- sc->args = sc->NIL; /* sc->args is set to nil in named_let below */
+ sc->args = sc->nil; /* sc->args is set to nil in named_let below */
for (ex = start; is_pair(ex); ex = cdr(ex))
sc->args = cons(sc, caar(ex), sc->args);
optimize_lambda(sc, true, car(sc->code), sc->args = safe_reverse_in_place(sc, sc->args), cddr(sc->code));
@@ -54846,10 +55188,10 @@ static s7_pointer check_let(s7_scheme *sc)
}
if (is_null(start))
- pair_set_syntax_symbol(sc->code, sc->LET_NO_VARS);
+ pair_set_syntax_symbol(sc->code, sc->let_no_vars_symbol);
else
{
- pair_set_syntax_symbol(sc->code, sc->LET_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->let_unchecked_symbol);
if (is_null(cdr(start))) /* one binding */
check_let_one_var(sc, start);
else
@@ -54858,30 +55200,30 @@ static s7_pointer check_let(s7_scheme *sc)
{
s7_pointer p, op;
- op = sc->NIL;
+ op = sc->nil;
for (p = start; is_pair(p); p = cdr(p))
{
s7_pointer x;
x = car(p);
if (is_pair(cadr(x)))
{
- if (car(cadr(x)) == sc->QUOTE)
- op = sc->LET_ALL_X;
+ if (car(cadr(x)) == sc->quote_symbol)
+ op = sc->let_all_x_symbol;
else
{
if (is_h_safe_c_s(cadr(x)))
{
- if ((op == sc->NIL) || (op == sc->LET_ALL_opSq))
- op = sc->LET_ALL_opSq;
- else op = sc->LET_ALL_X;
+ if ((op == sc->nil) || (op == sc->let_all_opsq_symbol))
+ op = sc->let_all_opsq_symbol;
+ else op = sc->let_all_x_symbol;
}
else
{
if (is_all_x_safe(sc, cadr(x)))
- op = sc->LET_ALL_X;
+ op = sc->let_all_x_symbol;
else
{
- op = sc->LET_UNCHECKED;
+ op = sc->let_unchecked_symbol;
break;
}
}
@@ -54891,24 +55233,24 @@ static s7_pointer check_let(s7_scheme *sc)
{
if (is_symbol(cadr(x)))
{
- if ((op == sc->NIL) || (op == sc->LET_ALL_S))
- op = sc->LET_ALL_S;
- else op = sc->LET_ALL_X;
+ if ((op == sc->nil) || (op == sc->let_all_s_symbol))
+ op = sc->let_all_s_symbol;
+ else op = sc->let_all_x_symbol;
}
else
{
- if ((op == sc->NIL) || (op == sc->LET_ALL_C))
- op = sc->LET_ALL_C;
- else op = sc->LET_ALL_X;
+ if ((op == sc->nil) || (op == sc->let_all_c_symbol))
+ op = sc->let_all_c_symbol;
+ else op = sc->let_all_x_symbol;
}
}
}
pair_set_syntax_symbol(sc->code, op);
}
- else pair_set_syntax_symbol(sc->code, sc->LET_UNCHECKED);
+ else pair_set_syntax_symbol(sc->code, sc->let_unchecked_symbol);
}
}
- if (pair_syntax_symbol(sc->code) == sc->LET_ALL_X)
+ if (pair_syntax_symbol(sc->code) == sc->let_all_x_symbol)
{
s7_pointer p;
for (p = start; is_pair(p); p = cdr(p))
@@ -54939,7 +55281,7 @@ static s7_pointer check_let_star(s7_scheme *sc)
if (is_null(cddr(sc->code))) /* (let* hi () ) */
eval_error(sc, "named let* has no body: ~A", sc->code);
if (is_immutable_symbol(car(sc->code)))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), sc->code)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), sc->code)));
set_local(car(sc->code));
if ((!is_null(cadr(sc->code))) &&
((!is_pair(cadr(sc->code))) || /* (let* hi x ... ) */
@@ -54965,7 +55307,7 @@ static s7_pointer check_let_star(s7_scheme *sc)
z = car(x);
if (is_immutable_symbol(z))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
if (!is_pair(x)) /* (let* ((x)) ...) */
eval_error(sc, "let* variable declaration, but no value?: ~A", x);
@@ -55001,18 +55343,18 @@ static s7_pointer check_let_star(s7_scheme *sc)
if (named_let)
{
if (is_null(cadr(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->NAMED_LET_NO_VARS);
+ pair_set_syntax_symbol(sc->code, sc->named_let_no_vars_symbol);
else
{
- pair_set_syntax_symbol(sc->code, sc->NAMED_LET_STAR);
+ pair_set_syntax_symbol(sc->code, sc->named_let_star_symbol);
set_opt_con2(sc->code, cadr(car(cadr(sc->code))));
}
return(sc->code);
}
- pair_set_syntax_symbol(sc->code, sc->LET_STAR_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->let_star_unchecked_symbol);
if (is_null(car(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->LET_NO_VARS); /* (let* () ...) */
+ pair_set_syntax_symbol(sc->code, sc->let_no_vars_symbol); /* (let* () ...) */
else
{
if (is_null(cdar(sc->code)))
@@ -55020,7 +55362,7 @@ static s7_pointer check_let_star(s7_scheme *sc)
else /* more than one entry */
{
s7_pointer p, op;
- op = sc->LET_STAR_ALL_X;
+ op = sc->let_star_all_x_symbol;
set_opt_con2(sc->code, cadaar(sc->code));
for (p = car(sc->code); is_pair(p); p = cdr(p))
{
@@ -55029,9 +55371,9 @@ static s7_pointer check_let_star(s7_scheme *sc)
if (is_pair(cadr(x)))
{
if ((!is_all_x_safe(sc, cadr(x))) &&
- (car(cadr(x)) != sc->QUOTE))
+ (car(cadr(x)) != sc->quote_symbol))
{
- op = sc->LET_STAR2;
+ op = sc->let_star2_symbol;
break;
}
}
@@ -55039,8 +55381,8 @@ static s7_pointer check_let_star(s7_scheme *sc)
pair_set_syntax_symbol(sc->code, op);
}
}
- if ((pair_syntax_symbol(sc->code) == sc->LET_ALL_X) ||
- (pair_syntax_symbol(sc->code) == sc->LET_STAR_ALL_X))
+ if ((pair_syntax_symbol(sc->code) == sc->let_all_x_symbol) ||
+ (pair_syntax_symbol(sc->code) == sc->let_star_all_x_symbol))
{
s7_pointer p;
for (p = car(sc->code); is_pair(p); p = cdr(p))
@@ -55054,7 +55396,7 @@ static s7_pointer check_let_star(s7_scheme *sc)
static s7_pointer check_letrec(s7_scheme *sc, bool letrec)
{
s7_pointer x, caller;
- caller = (letrec) ? sc->LETREC : sc->LETREC_STAR;
+ caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol;
if ((!is_pair(sc->code)) || /* (letrec . 1) */
(!is_pair(cdr(sc->code))) || /* (letrec) */
(!s7_is_list(sc, car(sc->code)))) /* (letrec 1 ...) */
@@ -55074,7 +55416,7 @@ static s7_pointer check_letrec(s7_scheme *sc, bool letrec)
y = car(carx);
if (is_immutable_symbol(y))
- return(s7_error(sc, sc->WRONG_TYPE_ARG, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
+ return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));
if (!is_pair(cdr(carx))) /* (letrec ((x . 1))...) */
{
@@ -55096,7 +55438,7 @@ static s7_pointer check_letrec(s7_scheme *sc, bool letrec)
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
- pair_set_syntax_symbol(sc->code, (letrec) ? sc->LETREC_UNCHECKED : sc->LETREC_STAR_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, (letrec) ? sc->letrec_unchecked_symbol : sc->letrec_star_unchecked_symbol);
return(sc->code);
}
@@ -55116,7 +55458,7 @@ static s7_pointer check_quote(s7_scheme *sc)
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
{
- pair_set_syntax_symbol(sc->code, sc->QUOTE_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->quote_unchecked_symbol);
}
#endif
return(sc->code);
@@ -55151,10 +55493,10 @@ static s7_pointer check_and(s7_scheme *sc)
if ((c_callee(sc->code)) &&
(is_pair(cdr(sc->code))) &&
(is_null(cddr(sc->code))))
- pair_set_syntax_symbol(sc->code, sc->AND_P2);
- else pair_set_syntax_symbol(sc->code, sc->AND_P);
+ pair_set_syntax_symbol(sc->code, sc->and_p2_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->and_p_symbol);
}
- else pair_set_syntax_symbol(sc->code, sc->AND_UNCHECKED);
+ else pair_set_syntax_symbol(sc->code, sc->and_unchecked_symbol);
}
return(sc->code);
}
@@ -55189,10 +55531,10 @@ static s7_pointer check_or(s7_scheme *sc)
if ((c_callee(sc->code)) &&
(is_pair(cdr(sc->code))) &&
(is_null(cddr(sc->code))))
- pair_set_syntax_symbol(sc->code, sc->OR_P2);
- else pair_set_syntax_symbol(sc->code, sc->OR_P);
+ pair_set_syntax_symbol(sc->code, sc->or_p2_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->or_p_symbol);
}
- else pair_set_syntax_symbol(sc->code, sc->OR_UNCHECKED);
+ else pair_set_syntax_symbol(sc->code, sc->or_unchecked_symbol);
}
return(sc->code);
}
@@ -55225,7 +55567,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
s7_pointer test;
bool one_branch;
- pair_set_syntax_symbol(sc->code, sc->IF_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->if_unchecked_symbol);
one_branch = (is_null(cdr(cdr_code)));
test = car(sc->code);
@@ -55237,10 +55579,10 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (c_callee(test) == g_and_all_x_2)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_AND2_P : sc->IF_AND2_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_and2_p_symbol : sc->if_and2_p_p_symbol);
set_opt_and_2_test(sc->code, cddr(test));
}
- else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_CC_P : sc->IF_CC_P_P);
+ else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_cc_p_symbol : sc->if_cc_p_p_symbol);
set_opt_pair2(sc->code, cdr(test));
}
else
@@ -55248,17 +55590,17 @@ static s7_pointer check_if(s7_scheme *sc)
if (is_h_safe_c_s(test))
{
/* these miss methods? */
- if (car(test) == sc->IS_PAIR)
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_IS_PAIR_P : sc->IF_IS_PAIR_P_P);
+ if (car(test) == sc->is_pair_symbol)
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_is_pair_p_symbol : sc->if_is_pair_p_p_symbol);
else
{
- if (car(test) == sc->IS_SYMBOL)
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_IS_SYMBOL_P : sc->IF_IS_SYMBOL_P_P);
+ if (car(test) == sc->is_symbol_symbol)
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_is_symbol_p_symbol : sc->if_is_symbol_p_p_symbol);
else
{
- if (car(test) == sc->NOT)
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_NOT_S_P : sc->IF_NOT_S_P_P);
- else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_CS_P : sc->IF_CS_P_P);
+ if (car(test) == sc->not_symbol)
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_not_s_p_symbol : sc->if_not_s_p_p_symbol);
+ else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_cs_p_symbol : sc->if_cs_p_p_symbol);
}
}
set_opt_sym2(sc->code, cadr(test));
@@ -55267,7 +55609,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (optimize_op(test) == HOP_SAFE_C_SQ)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_CSQ_P : sc->IF_CSQ_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_csq_p_symbol : sc->if_csq_p_p_symbol);
set_opt_con2(sc->code, cadr(caddr(test)));
set_opt_sym3(sc->code, cadr(test));
}
@@ -55275,7 +55617,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (optimize_op(test) == HOP_SAFE_C_SS)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_CSS_P : sc->IF_CSS_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_css_p_symbol : sc->if_css_p_p_symbol);
set_opt_sym2(sc->code, caddr(test));
set_opt_sym3(sc->code, cadr(test));
}
@@ -55283,7 +55625,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (optimize_op(test) == HOP_SAFE_C_SC)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_CSC_P : sc->IF_CSC_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_csc_p_symbol : sc->if_csc_p_p_symbol);
set_opt_con2(sc->code, caddr(test));
set_opt_sym3(sc->code, cadr(test));
}
@@ -55291,7 +55633,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (optimize_op(test) == HOP_SAFE_C_S_opCq)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_S_opCq_P : sc->IF_S_opCq_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_s_opcq_p_symbol : sc->if_s_opcq_p_p_symbol);
set_opt_pair2(sc->code, caddr(test));
set_opt_sym3(sc->code, cadr(test));
}
@@ -55299,7 +55641,7 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (optimize_op(test) == HOP_SAFE_C_opSSq)
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_opSSq_P : sc->IF_opSSq_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_opssq_p_symbol : sc->if_opssq_p_p_symbol);
set_opt_pair2(sc->code, cadar(sc->code));
set_opt_sym3(sc->code, caddr(opt_pair2(sc->code)));
}
@@ -55307,12 +55649,13 @@ static s7_pointer check_if(s7_scheme *sc)
{
if (is_all_x_safe(sc, test))
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_A_P : sc->IF_A_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_a_p_symbol : sc->if_a_p_p_symbol);
set_c_call(sc->code, all_x_eval(sc, test, sc->envir, let_symbol_is_safe));
+ /* fprintf(stderr, "%s\n", DISPLAY(sc->code)); */
}
else
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_Z_P : sc->IF_Z_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_z_p_symbol : sc->if_z_p_p_symbol);
set_opt_con2(sc->code, cadr(sc->code));
}
}
@@ -55325,7 +55668,7 @@ static s7_pointer check_if(s7_scheme *sc)
}
else
{
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_P_P : sc->IF_P_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_p_p_symbol : sc->if_p_p_p_symbol);
if (is_syntactic_symbol(car(test)))
{
pair_set_syntax_op(test, symbol_syntax_op(car(test)));
@@ -55341,11 +55684,11 @@ static s7_pointer check_if(s7_scheme *sc)
new_op = symbol_syntax_op(car(test));
sc->code = old_code;
if ((new_op == OP_AND_P) || (new_op == OP_AND_P2))
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_ANDP_P : sc->IF_ANDP_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_andp_p_symbol : sc->if_andp_p_p_symbol);
else
{
if ((new_op == OP_OR_P) || (new_op == OP_OR_P2))
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_ORP_P : sc->IF_ORP_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_orp_p_symbol : sc->if_orp_p_p_symbol);
}
}
}
@@ -55354,7 +55697,7 @@ static s7_pointer check_if(s7_scheme *sc)
else /* test is symbol or constant, but constant here is nutty */
{
if (is_symbol(test))
- pair_set_syntax_symbol(sc->code, (one_branch) ? sc->IF_S_P : sc->IF_S_P_P);
+ pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_s_p_symbol : sc->if_s_p_p_symbol);
}
}
return(sc->code);
@@ -55368,7 +55711,7 @@ static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_point
len = s7_list_length(sc, body);
if (len < 0) /* (define (hi) 1 . 2) */
- eval_error_with_caller(sc, "~A: function body messed up, ~A", (unstarred_lambda) ? sc->LAMBDA : sc->LAMBDA_STAR, sc->code);
+ eval_error_with_caller(sc, "~A: function body messed up, ~A", (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, sc->code);
if (len > 0) /* i.e. not circular */
{
@@ -55377,7 +55720,7 @@ static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_point
clear_syms_in_list(sc);
if (is_symbol(func))
lst = list_1(sc, add_sym_to_list(sc, func));
- else lst = sc->NIL;
+ else lst = sc->nil;
optimize(sc, body, 1, collect_collisions_star(sc, args, lst));
/* if the body is safe, we can optimize the calling sequence */
@@ -55396,7 +55739,7 @@ static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_point
if ((is_pair(arg)) && /* has default value */
((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */
((is_pair(cadr(arg))) && /* pair as default only ok if it is (quote ...) */
- (car(cadr(arg)) != sc->QUOTE))))
+ (car(cadr(arg)) != sc->quote_symbol))))
{
happy = false;
break;
@@ -55428,14 +55771,14 @@ static s7_pointer check_define(s7_scheme *sc)
starred = (sc->op == OP_DEFINE_STAR);
if (starred)
{
- caller = sc->DEFINE_STAR;
+ caller = sc->define_star_symbol;
sc->op = OP_DEFINE_STAR_UNCHECKED;
}
else
{
if (sc->op == OP_DEFINE)
- caller = sc->DEFINE;
- else caller = sc->DEFINE_CONSTANT;
+ caller = sc->define_symbol;
+ else caller = sc->define_constant_symbol;
}
if (!is_pair(sc->code))
@@ -55467,11 +55810,11 @@ static s7_pointer check_define(s7_scheme *sc)
}
if ((is_pair(cadr(sc->code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */
- ((caadr(sc->code) == sc->LAMBDA) ||
- (caadr(sc->code) == sc->LAMBDA_STAR)) &&
+ ((caadr(sc->code) == sc->lambda_symbol) ||
+ (caadr(sc->code) == sc->lambda_star_symbol)) &&
(symbol_id(caadr(sc->code)) == 0))
/* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */
- optimize_lambda(sc, caadr(sc->code) == sc->LAMBDA, func, cadr(cadr(sc->code)), cddr(cadr(sc->code)));
+ optimize_lambda(sc, caadr(sc->code) == sc->lambda_symbol, func, cadr(cadr(sc->code)), cddr(cadr(sc->code)));
}
else
{
@@ -55498,14 +55841,14 @@ static s7_pointer check_define(s7_scheme *sc)
if ((is_pair(car(sc->code))) &&
(!symbol_has_accessor(func)) &&
(!is_immutable_symbol(func)))
- pair_set_syntax_symbol(sc->code, sc->DEFINE_FUNCHECKED);
- else pair_set_syntax_symbol(sc->code, sc->DEFINE_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->define_funchecked_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->define_unchecked_symbol);
}
else
{
if (starred)
- pair_set_syntax_symbol(sc->code, sc->DEFINE_STAR_UNCHECKED);
- else pair_set_syntax_symbol(sc->code, sc->DEFINE_CONSTANT_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->define_star_unchecked_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->define_constant_unchecked_symbol);
}
}
return(sc->code);
@@ -55539,7 +55882,7 @@ static int define_unchecked_ex(s7_scheme *sc)
sc->code = cadr(sc->code);
if (is_pair(sc->code))
{
- push_stack(sc, OP_DEFINE1, sc->NIL, x);
+ push_stack(sc, OP_DEFINE1, sc->nil, x);
return(goto_EVAL);
}
@@ -55584,13 +55927,13 @@ static void define_funchecked(s7_scheme *sc)
new_cell_no_check(sc, new_env, T_LET | T_FUNCTION_ENV);
let_id(new_env) = ++sc->let_number;
- let_set_slots(new_env, sc->NIL);
+ let_set_slots(new_env, sc->nil);
set_outlet(new_env, sc->envir);
closure_set_let(new_func, new_env);
funclet_set_function(new_env, sc->value);
for (arg = closure_args(new_func); is_pair(arg); arg = cdr(arg))
- make_slot_1(sc, new_env, car(arg), sc->NIL);
+ make_slot_1(sc, new_env, car(arg), sc->nil);
let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
}
else closure_set_let(new_func, sc->envir);
@@ -55610,7 +55953,7 @@ static int lambda_star_default(s7_scheme *sc)
z = sc->args;
if (is_slot(z))
{
- if (slot_value(z) == sc->UNDEFINED)
+ if (slot_value(z) == sc->undefined)
{
if (is_closure_star(sc->code))
{
@@ -55619,19 +55962,36 @@ static int lambda_star_default(s7_scheme *sc)
if (is_symbol(val))
{
slot_set_value(z, find_symbol_checked(sc, val));
- if (slot_value(z) == sc->UNDEFINED)
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "lambda* defaults: ~A is unbound", slot_symbol(z));
- /* but #f is default if no expr, so there's some inconsistency here */
+ if (slot_value(z) == sc->undefined)
+ {
+ /* the current environment here contains the function parameters which
+ * defaulted to #<undefined> earlier in apply_lambda_star,
+ * so (define (f f) (define* (f (f f)) f) (f)) (f 0) looks for the
+ * default f, finds itself currently undefined, and raises an error!
+ * So, before claiming it is unbound, we need to check outlet as well.
+ * But in the case above, the inner define* shadows the caller's
+ * parameter before checking the default arg values, so the default f
+ * refers to the define* -- I'm not sure this is a bug. It means
+ * that (define* (f (a f)) a) returns f: (equal? f (f)) -> #t, so
+ * any outer f needs an extra let and endless outlets:
+ * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3
+ * We want the shadowing once the define* is done, so the current mess is simplest.
+ */
+ slot_set_value(z, s7_symbol_local_value(sc, val, outlet(sc->envir)));
+ if (slot_value(z) == sc->undefined)
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* defaults: ~A is unbound", slot_symbol(z));
+ /* but #f is default if no expr, so there's some inconsistency here */
+ }
}
else
{
if (is_pair(val))
{
- if (car(val) == sc->QUOTE)
+ if (car(val) == sc->quote_symbol)
{
if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */
(is_pair(cddr(val))))
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "lambda* default: ~A is messed up", val);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* default: ~A is messed up", val);
slot_set_value(z, cadr(val));
}
else
@@ -55744,14 +56104,14 @@ static void fill_safe_closure_star(s7_scheme *sc, s7_pointer x, s7_pointer p)
static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op)
{
s7_pointer x, y, caller;
- caller = sc->DEFINE_MACRO;
+ caller = sc->define_macro_symbol;
switch (op)
{
- case OP_DEFINE_MACRO: caller = sc->DEFINE_MACRO; break;
- case OP_DEFINE_MACRO_STAR: caller = sc->DEFINE_MACRO_STAR; break;
- case OP_DEFINE_BACRO: caller = sc->DEFINE_BACRO; break;
- case OP_DEFINE_BACRO_STAR: caller = sc->DEFINE_BACRO_STAR; break;
- case OP_DEFINE_EXPANSION: caller = sc->DEFINE_EXPANSION; break;
+ case OP_DEFINE_MACRO: caller = sc->define_macro_symbol; break;
+ case OP_DEFINE_MACRO_STAR: caller = sc->define_macro_star_symbol; break;
+ case OP_DEFINE_BACRO: caller = sc->define_bacro_symbol; break;
+ case OP_DEFINE_BACRO_STAR: caller = sc->define_bacro_star_symbol; break;
+ case OP_DEFINE_EXPANSION: caller = sc->define_expansion_symbol; break;
}
if (!is_pair(sc->code)) /* (define-macro . 1) */
@@ -55778,13 +56138,13 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op)
y = cdar(sc->code); /* the arglist */
if ((!s7_is_list(sc, y)) &&
(!is_symbol(y)))
- return(s7_error(sc, sc->SYNTAX_ERROR, /* (define-macro (mac . 1) ...) */
+ return(s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */
set_elist_3(sc, make_string_wrapper(sc, "macro ~A argument list is ~S?"), x, y)));
for ( ; is_pair(y); y = cdr(y))
if ((!is_symbol(car(y))) &&
((sc->op == OP_DEFINE_MACRO) || (sc->op == OP_DEFINE_BACRO) || (sc->op == OP_DEFINE_EXPANSION)))
- return(s7_error(sc, sc->SYNTAX_ERROR, /* (define-macro (mac 1) ...) */
+ return(s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */
set_elist_3(sc, make_string_wrapper(sc, "define-macro ~A argument name is not a symbol: ~S"), x, y)));
if ((sc->op == OP_DEFINE_MACRO_STAR) || (sc->op == OP_DEFINE_BACRO_STAR))
@@ -55845,25 +56205,25 @@ static int expansion_ex(s7_scheme *sc)
if ((loc >= 3) &&
(stack_op(sc->stack, loc) != OP_READ_QUOTE) && /* '(hi 1) for example */
(stack_op(sc->stack, loc) != OP_READ_VECTOR) && /* #(reader-cond) for example */
- (caller != sc->QUOTE) && /* (quote (hi 1)) */
- (caller != sc->MACROEXPAND) && /* (macroexpand (hi 1)) */
- (caller != sc->DEFINE_EXPANSION)) /* (define-expansion ...) being reloaded/redefined */
+ (caller != sc->quote_symbol) && /* (quote (hi 1)) */
+ (caller != sc->macroexpand_symbol) && /* (macroexpand (hi 1)) */
+ (caller != sc->define_expansion_symbol)) /* (define-expansion ...) being reloaded/redefined */
{
s7_pointer symbol, slot;
/* we're playing fast and loose with sc->envir in the reader, so here we need a disaster check */
#if DEBUGGING
- if (unchecked_type(sc->envir) != T_LET) sc->envir = sc->NIL;
+ if (unchecked_type(sc->envir) != T_LET) sc->envir = sc->nil;
#else
- if (!is_let(sc->envir)) sc->envir = sc->NIL;
+ if (!is_let(sc->envir)) sc->envir = sc->nil;
#endif
symbol = car(sc->value);
if ((symbol_id(symbol) == 0) ||
- (sc->envir == sc->NIL))
+ (sc->envir == sc->nil))
slot = global_slot(symbol);
else slot = find_symbol(sc, symbol);
if (is_slot(slot))
sc->code = slot_value(slot);
- else sc->code = sc->UNDEFINED;
+ else sc->code = sc->undefined;
if (!is_expansion(sc->code))
clear_expansion(symbol);
else
@@ -55888,10 +56248,10 @@ static s7_pointer check_with_let(s7_scheme *sc)
if ((is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
{
- pair_set_syntax_symbol(sc->code, sc->WITH_LET_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->with_let_unchecked_symbol);
if ((is_symbol(car(sc->code))) &&
(is_pair(cadr(sc->code))))
- pair_set_syntax_symbol(sc->code, sc->WITH_LET_S);
+ pair_set_syntax_symbol(sc->code, sc->with_let_s_symbol);
}
return(sc->code);
}
@@ -55914,8 +56274,8 @@ static s7_pointer check_cond(s7_scheme *sc)
y = car(x);
if ((!is_pair(cdr(y))) && (!is_null(cdr(y)))) /* (cond (1 . 2)) */
eval_error(sc, "cond: stray dot? ~A", sc->code);
- if ((cadr(y) == sc->FEED_TO) &&
- (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
+ if ((cadr(y) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
{
has_feed_to = true;
if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */
@@ -55939,14 +56299,14 @@ static s7_pointer check_cond(s7_scheme *sc)
{
if (has_feed_to)
{
- pair_set_syntax_symbol(sc->code, sc->COND_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->cond_unchecked_symbol);
if (is_null(cdr(sc->code)))
{
s7_pointer expr, f;
expr = car(sc->code);
f = caddr(expr);
if ((is_pair(f)) &&
- (car(f) == sc->LAMBDA) &&
+ (car(f) == sc->lambda_symbol) &&
(is_null(cdr(cddr(f)))))
{
s7_pointer arg;
@@ -55957,7 +56317,7 @@ static s7_pointer check_cond(s7_scheme *sc)
{
/* (define (hi) (cond (#t => (lambda (s) s)))) */
set_opt_lambda2(sc->code, caddar(sc->code)); /* (lambda ...) above */
- pair_set_syntax_symbol(sc->code, sc->IF_P_FEED);
+ pair_set_syntax_symbol(sc->code, sc->if_p_feed_symbol);
}
}
}
@@ -55966,14 +56326,14 @@ static s7_pointer check_cond(s7_scheme *sc)
{
s7_pointer p, sym = NULL;
bool xopt = true, c_s_is_ok = true;
- pair_set_syntax_symbol(sc->code, sc->COND_SIMPLE);
+ pair_set_syntax_symbol(sc->code, sc->cond_simple_symbol);
for (p = sc->code; xopt && (is_pair(p)); p = cdr(p))
{
xopt = is_all_x_safe(sc, caar(p));
if ((c_s_is_ok) &&
(caar(p) != sc->T) &&
- (caar(p) != sc->ELSE))
+ (caar(p) != sc->else_object))
{
if ((!is_pair(caar(p))) ||
(!is_h_safe_c_s(caar(p))) ||
@@ -55983,17 +56343,17 @@ static s7_pointer check_cond(s7_scheme *sc)
}
}
if (c_s_is_ok)
- pair_set_syntax_symbol(sc->code, sc->COND_S);
+ pair_set_syntax_symbol(sc->code, sc->cond_s_symbol);
else
{
if (xopt)
{
int i;
- pair_set_syntax_symbol(sc->code, sc->COND_ALL_X);
+ pair_set_syntax_symbol(sc->code, sc->cond_all_x_symbol);
for (i = 0, p = sc->code; is_pair(p); i++, p = cdr(p))
set_c_call(car(p), cond_all_x_eval(sc, caar(p), sc->envir)); /* handle 'else' specially here */
if (i == 2)
- pair_set_syntax_symbol(sc->code, sc->COND_ALL_X_2);
+ pair_set_syntax_symbol(sc->code, sc->cond_all_x_2_symbol);
}
}
}
@@ -56050,7 +56410,7 @@ static s7_pointer check_set(s7_scheme *sc)
inner = car(sc->code);
value = cadr(sc->code);
- pair_set_syntax_symbol(sc->code, sc->SET_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->set_unchecked_symbol);
if (is_symbol(car(inner)))
{
if ((is_null(cdr(inner))) &&
@@ -56058,7 +56418,7 @@ static s7_pointer check_set(s7_scheme *sc)
(is_global(car(inner))) &&
(is_c_function(slot_value(global_slot(car(inner))))) &&
(c_function_required_args(slot_value(global_slot(car(inner)))) == 0))
- pair_set_syntax_symbol(sc->code, sc->SET_PWS);
+ pair_set_syntax_symbol(sc->code, sc->set_pws_symbol);
else
{
if ((is_pair(cdr(inner))) &&
@@ -56068,24 +56428,24 @@ static s7_pointer check_set(s7_scheme *sc)
{
/* (set! (f s) ...) */
if (!is_pair(value))
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_symbol);
else
{
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_P);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_p_symbol);
/* splice_in_values protects us here from values */
if (is_h_optimized(value)) /* this excludes h_unknown_g etc */
{
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_Z);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_z_symbol);
if (is_all_x_safe(sc, value))
{
s7_pointer obj;
annotate_arg(sc, cdr(sc->code), sc->envir);
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_ZA);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_za_symbol);
obj = find_symbol_checked(sc, car(inner));
if ((is_c_function(obj)) &&
(is_c_function(c_function_setter(obj))))
{
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_A);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_a_symbol);
}
}
}
@@ -56093,15 +56453,15 @@ static s7_pointer check_set(s7_scheme *sc)
}
else
{
- if ((car(cadr(inner)) == sc->QUOTE) &&
+ if ((car(cadr(inner)) == sc->quote_symbol) &&
(is_symbol(car(inner))) &&
((is_symbol(value)) || (is_all_x_safe(sc, value))))
{
if (is_symbol(value))
- pair_set_syntax_symbol(sc->code, sc->SET_LET_S);
+ pair_set_syntax_symbol(sc->code, sc->set_let_s_symbol);
else
{
- pair_set_syntax_symbol(sc->code, sc->SET_LET_ALL_X);
+ pair_set_syntax_symbol(sc->code, sc->set_let_all_x_symbol);
set_c_call(cdr(sc->code), all_x_eval(sc, value, sc->envir, let_symbol_is_safe));
}
}
@@ -56110,11 +56470,11 @@ static s7_pointer check_set(s7_scheme *sc)
if (is_h_safe_c_c(cadr(inner)))
{
if (!is_pair(value))
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_C);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_c_symbol);
else
{
/* splice_in_values protects us here from values */
- pair_set_syntax_symbol(sc->code, sc->SET_PAIR_C_P);
+ pair_set_syntax_symbol(sc->code, sc->set_pair_c_p_symbol);
}
}
}
@@ -56123,7 +56483,7 @@ static s7_pointer check_set(s7_scheme *sc)
}
}
}
- else pair_set_syntax_symbol(sc->code, sc->SET_NORMAL);
+ else pair_set_syntax_symbol(sc->code, sc->set_normal_symbol);
if (is_symbol(car(sc->code)))
{
@@ -56135,21 +56495,21 @@ static s7_pointer check_set(s7_scheme *sc)
(!is_syntactic(settee)))
{
if (is_symbol(value))
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_S);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_s_symbol);
else
{
if (!is_pair(value))
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_C);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_c_symbol);
else
{
- if (car(value) == sc->QUOTE)
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_Q);
+ if (car(value) == sc->quote_symbol)
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_q_symbol);
else
{
/* if cadr(cadr) == car, or cdr(cadr) not null and cadr(cadr) == car, and cddr(cadr) == null,
* it's (set! <var> (<op> <var> val)) or (<op> val <var>) or (<op> <var>)
* in the set code, we get the slot as usual, then in case 1 above,
- * car(sc->T2_1) = slot_value(slot), car(sc->T2_2) = increment, call <op>, set slot_value(slot)
+ * car(sc->t2_1) = slot_value(slot), car(sc->t2_2) = increment, call <op>, set slot_value(slot)
*
* this can be done in all combined cases where a symbol is repeated (do in particular)
*/
@@ -56159,20 +56519,20 @@ static s7_pointer check_set(s7_scheme *sc)
* (let () (define (hi) (let ((x 0)) (set! x (values 1 2)) x)) (catch #t hi (lambda a a)) (hi))
* which is caught in splice_in_values
*/
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_P);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_p_symbol);
if (is_h_safe_c_s(value))
{
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_opSq);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_opsq_symbol);
set_opt_sym2(sc->code, cadr(value));
}
else
{
if (is_h_optimized(value))
{
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_Z);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_z_symbol);
if (optimize_op(value) == HOP_SAFE_C_C)
{
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_opCq);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_opcq_symbol);
/* opt1 here points back? */
set_opt_pair2(sc->code, cdr(value));
}
@@ -56182,8 +56542,8 @@ static s7_pointer check_set(s7_scheme *sc)
if (optimize_op(value) == HOP_SAFE_C_SS)
{
if (settee == cadr(value))
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_SS);
- else pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_opSSq);
+ pair_set_syntax_symbol(sc->code, sc->increment_ss_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->set_symbol_opssq_symbol);
set_opt_pair2(sc->code, cdr(value));
}
else
@@ -56191,16 +56551,16 @@ static s7_pointer check_set(s7_scheme *sc)
if (optimize_op(value) == HOP_SAFE_C_SSS)
{
if ((settee == cadr(value)) &&
- (car(value) == sc->ADD))
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_SSS);
- else pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_opSSSq);
+ (car(value) == sc->add_symbol))
+ pair_set_syntax_symbol(sc->code, sc->increment_sss_symbol);
+ else pair_set_syntax_symbol(sc->code, sc->set_symbol_opsssq_symbol);
set_opt_pair2(sc->code, cdr(value));
}
else
{
if (is_all_x_safe(sc, value)) /* value = cadr(sc->code) */
{
- pair_set_syntax_symbol(sc->code, sc->SET_SYMBOL_A);
+ pair_set_syntax_symbol(sc->code, sc->set_symbol_a_symbol);
annotate_arg(sc, cdr(sc->code), sc->envir);
}
if (is_callable_c_op(optimize_op(value)))
@@ -56213,7 +56573,7 @@ static s7_pointer check_set(s7_scheme *sc)
if (is_all_x_safe(sc, caddr(value)))
{
/* this appears to give a slight savings over the SZ case */
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_SA);
+ pair_set_syntax_symbol(sc->code, sc->increment_sa_symbol);
annotate_arg(sc, cddr(value), sc->envir); /* this sets c_callee(arg) */
set_opt_pair2(sc->code, cddr(value));
}
@@ -56221,7 +56581,7 @@ static s7_pointer check_set(s7_scheme *sc)
{
if (is_optimized(caddr(value)))
{
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_SZ);
+ pair_set_syntax_symbol(sc->code, sc->increment_sz_symbol);
set_opt_pair2(sc->code, caddr(value));
}
}
@@ -56232,7 +56592,7 @@ static s7_pointer check_set(s7_scheme *sc)
(is_all_x_safe(sc, caddr(value))) &&
(is_all_x_safe(sc, cadddr(value))))
{
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_SAA);
+ pair_set_syntax_symbol(sc->code, sc->increment_saa_symbol);
annotate_arg(sc, cddr(value), sc->envir);
annotate_arg(sc, cdddr(value), sc->envir);
set_opt_pair2(sc->code, cddr(value));
@@ -56257,12 +56617,12 @@ static s7_pointer check_set(s7_scheme *sc)
{
if ((opt_cfunc(value) == add_s1) ||
(opt_cfunc(value) == add_cs1))
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_1);
+ pair_set_syntax_symbol(sc->code, sc->increment_1_symbol);
else
{
if ((opt_cfunc(value) == subtract_s1) ||
(opt_cfunc(value) == subtract_cs1))
- pair_set_syntax_symbol(sc->code, sc->DECREMENT_1);
+ pair_set_syntax_symbol(sc->code, sc->decrement_1_symbol);
}
}
else
@@ -56270,14 +56630,14 @@ static s7_pointer check_set(s7_scheme *sc)
if ((cadr(value) == small_int(1)) &&
(caddr(value) == settee) &&
(opt_cfunc(value) == add_1s))
- pair_set_syntax_symbol(sc->code, sc->INCREMENT_1);
+ pair_set_syntax_symbol(sc->code, sc->increment_1_symbol);
else
{
if ((settee == caddr(value)) &&
(is_symbol(cadr(value))) &&
- (caadr(sc->code) == sc->CONS))
+ (caadr(sc->code) == sc->cons_symbol))
{
- pair_set_syntax_symbol(sc->code, sc->SET_CONS);
+ pair_set_syntax_symbol(sc->code, sc->set_cons_symbol);
set_opt_sym2(sc->code, cadr(value));
}
}
@@ -56295,6 +56655,7 @@ static s7_pointer check_set(s7_scheme *sc)
static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value)
{
+ /* fprintf(stderr, "%s: %s %s\n", __func__, DISPLAY(arg), DISPLAY(value)); */
if (is_slot(obj))
obj = slot_value(obj);
else eval_error(sc, "no generalized set for ~A", caar(sc->code));
@@ -56302,9 +56663,9 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
switch (type(obj))
{
case T_C_OBJECT:
- car(sc->T2_1) = arg;
- car(sc->T2_2) = value;
- sc->value = (*(c_object_set(obj)))(sc, obj, sc->T2_1);
+ car(sc->t2_1) = arg;
+ car(sc->t2_2) = value;
+ sc->value = (*(c_object_set(obj)))(sc, obj, sc->t2_1);
break;
/* some of these are wasteful -- we know the object type! (list hash-table) */
@@ -56312,17 +56673,17 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
case T_FLOAT_VECTOR:
case T_VECTOR:
#if WITH_GMP
- car(sc->T3_1) = obj;
- car(sc->T3_2) = arg;
- car(sc->T3_3) = value;
- sc->value = g_vector_set(sc, sc->T3_1);
+ car(sc->t3_1) = obj;
+ car(sc->t3_2) = arg;
+ car(sc->t3_3) = value;
+ sc->value = g_vector_set(sc, sc->t3_1);
#else
if (vector_rank(obj) > 1)
{
- car(sc->T3_1) = obj;
- car(sc->T3_2) = arg;
- car(sc->T3_3) = value;
- sc->value = g_vector_set(sc, sc->T3_1);
+ car(sc->t3_1) = obj;
+ car(sc->t3_2) = arg;
+ car(sc->t3_3) = value;
+ sc->value = g_vector_set(sc, sc->t3_1);
}
else
{
@@ -56343,10 +56704,10 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
case T_STRING:
#if WITH_GMP
- car(sc->T3_1) = obj;
- car(sc->T3_2) = arg;
- car(sc->T3_3) = value;
- sc->value = g_string_set(sc, sc->T3_1);
+ car(sc->t3_1) = obj;
+ car(sc->t3_2) = arg;
+ car(sc->t3_3) = value;
+ sc->value = g_string_set(sc, sc->t3_1);
#else
{
s7_int index;
@@ -56381,10 +56742,10 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
break;
case T_PAIR:
- car(sc->T3_1) = obj;
- car(sc->T3_2) = arg;
- car(sc->T3_3) = value;
- sc->value = g_list_set(sc, sc->T3_1);
+ car(sc->t3_1) = obj;
+ car(sc->t3_2) = arg;
+ car(sc->t3_3) = value;
+ sc->value = g_list_set(sc, sc->t3_1);
break;
case T_HASH_TABLE:
@@ -56405,9 +56766,9 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
{
if (is_c_function(c_function_setter(obj)))
{
- car(sc->T2_1) = arg;
- car(sc->T2_2) = value;
- sc->value = c_function_call(c_function_setter(obj))(sc, sc->T2_1);
+ car(sc->t2_1) = arg;
+ car(sc->t2_2) = value;
+ sc->value = c_function_call(c_function_setter(obj))(sc, sc->t2_1);
}
else
{
@@ -56428,9 +56789,9 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
{
if (is_c_function(closure_setter(obj)))
{
- car(sc->T2_1) = arg;
- car(sc->T2_2) = value;
- sc->value = c_function_call(closure_setter(obj))(sc, sc->T2_1);
+ car(sc->t2_1) = arg;
+ car(sc->t2_2) = value;
+ sc->value = c_function_call(closure_setter(obj))(sc, sc->t2_1);
}
else
{
@@ -56498,7 +56859,7 @@ static int set_pair_ex(s7_scheme *sc)
cx = find_symbol(sc, caar_code);
if (is_slot(cx))
cx = slot_value(cx);
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar_code);
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
}
else cx = caar_code;
@@ -56546,7 +56907,7 @@ static int set_pair_ex(s7_scheme *sc)
* TODO: ambiguity here -- is (set! (obj a b) v) actually (set! ((obj a) b) v)?
* perhaps look at setter? c-object-set takes 1 arg -- is this a bug?
*/
- push_op_stack(sc, sc->Object_Set);
+ push_op_stack(sc, sc->object_set_function);
if (is_null(cdr(settee)))
{
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cddr(sc->code));
@@ -56571,12 +56932,12 @@ static int set_pair_ex(s7_scheme *sc)
{
if (is_symbol(val))
val = find_symbol_checked(sc, val);
- car(sc->T2_1) = index;
- car(sc->T2_2) = val;
- sc->value = (*(c_object_set(cx)))(sc, cx, sc->T2_1);
+ car(sc->t2_1) = index;
+ car(sc->t2_2) = val;
+ sc->value = (*(c_object_set(cx)))(sc, cx, sc->t2_1);
return(goto_START);
}
- push_op_stack(sc, sc->Object_Set);
+ push_op_stack(sc, sc->object_set_function);
sc->args = list_2(sc, index, cx);
sc->code = cdr(sc->code);
return(goto_EVAL_ARGS);
@@ -56584,7 +56945,7 @@ static int set_pair_ex(s7_scheme *sc)
else
{
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
- push_op_stack(sc, sc->Object_Set);
+ push_op_stack(sc, sc->object_set_function);
sc->code = cadr(settee);
}
return(goto_EVAL);
@@ -56621,7 +56982,7 @@ static int set_pair_ex(s7_scheme *sc)
(vector_rank(cx) > 1))
{
/* multi-index case -- use slow version */
- push_op_stack(sc, sc->Vector_Set);
+ push_op_stack(sc, sc->vector_set_function);
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
sc->code = cadr(settee);
return(goto_EVAL);
@@ -56635,11 +56996,11 @@ static int set_pair_ex(s7_scheme *sc)
if (is_symbol(index))
index = find_symbol_checked(sc, index);
if (!s7_is_integer(index))
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "vector-set!: index must be an integer: ~S", sc->code);
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "vector-set!: index must be an integer: ~S", sc->code);
ind = s7_integer(index);
if ((ind < 0) ||
(ind >= vector_length(cx)))
- out_of_range(sc, sc->VECTOR_SET, small_int(2), index, (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->vector_set_symbol, small_int(2), index, (ind < 0) ? its_negative_string : its_too_large_string);
val = cadr(sc->code);
if (!is_pair(val))
{
@@ -56649,7 +57010,7 @@ static int set_pair_ex(s7_scheme *sc)
sc->value = _NFre(val);
return(goto_START);
}
- push_op_stack(sc, sc->Vector_Set);
+ push_op_stack(sc, sc->vector_set_function);
sc->args = list_2(sc, index, cx);
sc->code = cdr(sc->code);
return(goto_EVAL_ARGS);
@@ -56659,7 +57020,7 @@ static int set_pair_ex(s7_scheme *sc)
/* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens
*/
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
- push_op_stack(sc, sc->Vector_Set);
+ push_op_stack(sc, sc->vector_set_function);
sc->code = cadr(settee);
}
}
@@ -56667,7 +57028,7 @@ static int set_pair_ex(s7_scheme *sc)
case T_STRING:
{
- /* sc->code = cons(sc, sc->String_Set, s7_append(sc, car(sc->code), cdr(sc->code)));
+ /* sc->code = cons(sc, sc->string_set_function, s7_append(sc, car(sc->code), cdr(sc->code)));
*
* here only one index makes sense, and it is required, so
* (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a)
@@ -56698,11 +57059,11 @@ static int set_pair_ex(s7_scheme *sc)
if (is_symbol(index))
index = find_symbol_checked(sc, index);
if (!s7_is_integer(index))
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "string-set!: index must be an integer: ~S", sc->code);
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: index must be an integer: ~S", sc->code);
ind = s7_integer(index);
if ((ind < 0) ||
(ind >= string_length(cx)))
- out_of_range(sc, sc->STRING_SET, small_int(2), index, (ind < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ out_of_range(sc, sc->string_set_symbol, small_int(2), index, (ind < 0) ? its_negative_string : its_too_large_string);
val = cadr(sc->code);
if (!is_pair(val))
@@ -56723,15 +57084,15 @@ static int set_pair_ex(s7_scheme *sc)
int ic;
ic = s7_integer(val);
if ((ic < 0) || (ic > 255))
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "string-set!: value must be a character: ~S", sc->code);
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: value must be a character: ~S", sc->code);
string_value(cx)[ind] = (char)ic;
sc->value = val;
return(goto_START);
}
}
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "string-set!: value must be a character: ~S", sc->code);
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: value must be a character: ~S", sc->code);
}
- push_op_stack(sc, sc->String_Set);
+ push_op_stack(sc, sc->string_set_function);
sc->args = list_2(sc, index, cx);
sc->code = cdr(sc->code);
return(goto_EVAL_ARGS);
@@ -56739,14 +57100,14 @@ static int set_pair_ex(s7_scheme *sc)
else
{
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
- push_op_stack(sc, sc->String_Set);
+ push_op_stack(sc, sc->string_set_function);
sc->code = cadar(sc->code);
}
}
break;
case T_PAIR:
- /* code: ((lst 1) 32) from (let ((lst '(1 2 3))) (set! (lst 1) 32)) */
+ /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (set! (lst 1) 32)) */
{
s7_pointer settee, index, val;
@@ -56775,7 +57136,7 @@ static int set_pair_ex(s7_scheme *sc)
if ((is_pair(index)) ||
(is_pair(val)))
{
- push_op_stack(sc, sc->List_Set);
+ 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 = index;
return(goto_EVAL);
@@ -56786,9 +57147,9 @@ static int set_pair_ex(s7_scheme *sc)
if (is_symbol(val))
val = find_symbol_checked(sc, val);
- car(sc->T2_1) = index;
- car(sc->T2_2) = val;
- sc->value = g_list_set_1(sc, cx, sc->T2_1, 2);
+ car(sc->t2_1) = index;
+ car(sc->t2_2) = val;
+ sc->value = g_list_set_1(sc, cx, sc->t2_1, 2);
return(goto_START);
}
break;
@@ -56828,7 +57189,7 @@ static int set_pair_ex(s7_scheme *sc)
sc->value = s7_hash_table_set(sc, cx, key, val);
return(goto_START);
}
- push_op_stack(sc, sc->Hash_Table_Set);
+ push_op_stack(sc, sc->hash_table_set_function);
sc->args = list_2(sc, key, cx);
sc->code = cdr(sc->code);
return(goto_EVAL_ARGS);
@@ -56836,7 +57197,7 @@ static int set_pair_ex(s7_scheme *sc)
else
{
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
- push_op_stack(sc, sc->Hash_Table_Set);
+ push_op_stack(sc, sc->hash_table_set_function);
sc->code = cadar(sc->code);
}
}
@@ -56844,7 +57205,7 @@ static int set_pair_ex(s7_scheme *sc)
case T_LET:
- /* sc->code = cons(sc, sc->Let_Set, s7_append(sc, car(sc->code), cdr(sc->code))); */
+ /* sc->code = cons(sc, sc->let_set_function, s7_append(sc, car(sc->code), cdr(sc->code))); */
{
s7_pointer settee, key;
/* code: ((gen 'input) input) from (set! (gen 'input) input)
@@ -56868,7 +57229,7 @@ static int set_pair_ex(s7_scheme *sc)
key = cadr(settee);
if ((is_pair(key)) &&
- (car(key) == sc->QUOTE))
+ (car(key) == sc->quote_symbol))
{
s7_pointer val;
key = cadr(key);
@@ -56880,7 +57241,7 @@ static int set_pair_ex(s7_scheme *sc)
sc->value = s7_let_set(sc, cx, key, val);
return(goto_START);
}
- push_op_stack(sc, sc->Let_Set);
+ push_op_stack(sc, sc->let_set_function);
sc->args = list_2(sc, key, cx);
sc->code = cdr(sc->code);
return(goto_EVAL_ARGS);
@@ -56888,7 +57249,7 @@ static int set_pair_ex(s7_scheme *sc)
else
{
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
- push_op_stack(sc, sc->Let_Set);
+ push_op_stack(sc, sc->let_set_function);
sc->code = cadar(sc->code);
}
}
@@ -56912,26 +57273,26 @@ static int set_pair_ex(s7_scheme *sc)
{
if (is_null(cddar(sc->code)))
{
- car(sc->T2_1) = find_symbol_checked(sc, cadar(sc->code));
- car(sc->T2_2) = find_symbol_checked(sc, cadr(sc->code));
- sc->args = sc->T2_1;
+ car(sc->t2_1) = find_symbol_checked(sc, cadar(sc->code));
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(sc->code));
+ sc->args = sc->t2_1;
sc->code = c_function_setter(cx);
return(goto_APPLY); /* check arg num etc */
}
if ((is_symbol(caddar(sc->code))) &&
(is_null(cdddar(sc->code))))
{
- car(sc->T3_1) = find_symbol_checked(sc, cadar(sc->code));
- car(sc->T3_2) = find_symbol_checked(sc, caddar(sc->code));
- car(sc->T3_3) = find_symbol_checked(sc, cadr(sc->code));
- sc->args = sc->T3_1;
+ car(sc->t3_1) = find_symbol_checked(sc, cadar(sc->code));
+ car(sc->t3_2) = find_symbol_checked(sc, caddar(sc->code));
+ car(sc->t3_3) = find_symbol_checked(sc, cadr(sc->code));
+ sc->args = sc->t3_1;
sc->code = c_function_setter(cx);
return(goto_APPLY); /* check arg num etc */
}
}
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)));
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, s7_append(sc, cddar(sc->code), cdr(sc->code)));
sc->code = cadar(sc->code);
}
else
@@ -56940,14 +57301,14 @@ static int set_pair_ex(s7_scheme *sc)
(!is_pair(cadr(sc->code))))
{
if (is_symbol(cadr(sc->code)))
- car(sc->T1_1) = find_symbol_checked(sc, cadr(sc->code));
- else car(sc->T1_1) = cadr(sc->code);
- sc->args = sc->T1_1;
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(sc->code));
+ else car(sc->t1_1) = cadr(sc->code);
+ sc->args = sc->t1_1;
sc->code = c_function_setter(cx);
return(goto_APPLY); /* check arg num etc */
}
push_op_stack(sc, c_function_setter(cx));
- push_stack(sc, OP_EVAL_ARGS1, sc->NIL, cddr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code));
sc->code = cadr(sc->code);
}
}
@@ -56962,7 +57323,7 @@ static int set_pair_ex(s7_scheme *sc)
sc->code = c_function_setter(cx);
return(goto_APPLY);
}
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar_code);
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
}
break;
@@ -56978,14 +57339,14 @@ static int set_pair_ex(s7_scheme *sc)
push_op_stack(sc, setter);
if (is_null(cdar(sc->code)))
{
- push_stack(sc, OP_EVAL_ARGS1, sc->NIL, cddr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code));
sc->code = cadr(sc->code);
}
else
{
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)));
+ 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)));
sc->code = cadar(sc->code);
}
}
@@ -56999,7 +57360,7 @@ static int set_pair_ex(s7_scheme *sc)
sc->code = setter;
return(goto_APPLY);
}
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar_code);
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
}
}
break;
@@ -57014,7 +57375,7 @@ static int set_pair_ex(s7_scheme *sc)
if (is_procedure(setter))
{
push_op_stack(sc, setter);
- push_stack(sc, OP_EVAL_ARGS1, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil);
sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */
}
else
@@ -57025,17 +57386,55 @@ static int set_pair_ex(s7_scheme *sc)
sc->code = setter;
return(goto_APPLY);
}
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar_code);
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
}
}
break;
+
+ case T_SYNTAX:
+ if (cx == slot_value(global_slot(sc->with_let_symbol)))
+ {
+ /* (set! (with-let a b) x), cx = with-let, sc->code = ((with-let a b) x)
+ * a and x are in the current env, b is in a, we need to evaluate a and x, then
+ * call (with-let a-value (set! b x-value))
+ */
+ sc->args = cdar(sc->code);
+ sc->code = cadr(sc->code);
+ push_stack(sc, OP_SET_WITH_LET_1, sc->args, sc->code);
+ return(goto_EVAL);
+ }
+ /* else fall through */
default: /* (set! (1 2) 3) */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar_code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
}
return(goto_EVAL);
}
+static void activate_let(s7_scheme *sc)
+{
+ s7_pointer e;
+ e = sc->value;
+ if (!is_let(e)) /* (with-let . "hi") */
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "with-let takes an environment argument: ~A", e);
+ if (e == sc->rootlet)
+ sc->envir = sc->nil; /* (with-let (rootlet) ...) */
+ else
+ {
+ s7_pointer p;
+ set_with_let_let(e);
+ let_id(e) = ++sc->let_number;
+ sc->envir = e;
+ for (p = let_slots(e); is_slot(p); p = next_slot(p))
+ {
+ s7_pointer sym;
+ sym = slot_symbol(p);
+ if (symbol_id(sym) != sc->let_number)
+ symbol_set_local(sym, sc->let_number, p);
+ }
+ }
+}
+
static bool tree_match(s7_scheme *sc, s7_pointer tree)
{
@@ -57097,10 +57496,10 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
if ((is_pair(cdar(vars))) &&
(!do_is_safe(sc, cdar(vars), steppers, var_list, has_set)))
{
- sc->x = sc->NIL;
+ sc->x = sc->nil;
return(false);
}
- sc->x = sc->NIL;
+ sc->x = sc->nil;
}
if (op == OP_DO)
{
@@ -57125,7 +57524,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
if ((!is_pair(settee)) ||
(!is_symbol(car(settee))))
return(false);
- setv = find_symbol_unchecked(sc, car(settee));
+ setv = find_symbol_unexamined(sc, car(settee));
if (!((setv) &&
((is_sequence(setv)) ||
((is_c_function(setv)) &&
@@ -57197,7 +57596,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
(!is_pair(cddr(expr))) ||
(!is_pair(cdddr(expr))) ||
(is_pair(cddddr(expr))) ||
- ((x == sc->HASH_TABLE_SET) &&
+ ((x == sc->hash_table_set_symbol) &&
(is_symbol(caddr(expr))) &&
(direct_memq(caddr(expr), steppers))) ||
((is_symbol(cadddr(expr))) &&
@@ -57306,7 +57705,7 @@ static s7_pointer check_do(s7_scheme *sc)
body = cddr(sc->code);
one_line = ((safe_list_length(sc, body) == 1) && (is_pair(car(body))));
- pair_set_syntax_symbol(sc->code, sc->DO_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);
/* (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (display i)) (newline)) */
/* (define (hi) (do ((i 1.5 (+ i 1))) ((= i 2.5)) (display i) (newline)))
@@ -57375,19 +57774,19 @@ static s7_pointer check_do(s7_scheme *sc)
(s7_is_integer(caddr(step_expr))) &&
(s7_integer(caddr(step_expr)) == 1))
{
- pair_set_syntax_symbol(sc->code, sc->SIMPLE_DO_A);
+ pair_set_syntax_symbol(sc->code, sc->simple_do_a_symbol);
if ((one_line) &&
(is_optimized(car(body))))
- pair_set_syntax_symbol(sc->code, sc->SIMPLE_DO_E);
+ pair_set_syntax_symbol(sc->code, sc->simple_do_e_symbol);
}
- else pair_set_syntax_symbol(sc->code, sc->SIMPLE_DO);
+ else pair_set_syntax_symbol(sc->code, sc->simple_do_symbol);
if ((one_line) &&
((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_C)) &&
(is_syntactic_symbol(caar(body))))
{
pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
- pair_set_syntax_symbol(sc->code, sc->SIMPLE_DO_P);
+ pair_set_syntax_symbol(sc->code, sc->simple_do_p_symbol);
set_opt_pair2(sc->code, caddr(caar(sc->code)));
if ((s7_is_integer(caddr(step_expr))) &&
@@ -57398,10 +57797,10 @@ static s7_pointer check_do(s7_scheme *sc)
*/
((c_function_class(opt_cfunc(end)) == sc->equal_class) ||
(opt_cfunc(end) == geq_2)))
- pair_set_syntax_symbol(sc->code, sc->DOTIMES_P);
+ pair_set_syntax_symbol(sc->code, sc->dotimes_p_symbol);
}
- if (do_is_safe(sc, body, sc->w = list_1(sc, car(vars)), sc->NIL, &has_set))
+ if (do_is_safe(sc, body, sc->w = list_1(sc, car(vars)), sc->nil, &has_set))
{
/* now look for the very common dotimes case
*/
@@ -57417,13 +57816,13 @@ static s7_pointer check_do(s7_scheme *sc)
/* we're stepping by +1 and going to =
* the final integer check has to wait until run time (symbol value dependent)
*/
- pair_set_syntax_symbol(sc->code, sc->SAFE_DO);
+ pair_set_syntax_symbol(sc->code, sc->safe_do_symbol);
if ((!has_set) &&
(c_function_class(opt_cfunc(end)) == sc->equal_class))
- pair_set_syntax_symbol(sc->code, sc->SAFE_DOTIMES);
+ pair_set_syntax_symbol(sc->code, sc->safe_dotimes_symbol);
}
}
- return(sc->NIL);
+ return(sc->nil);
}
}
}
@@ -57439,7 +57838,7 @@ static s7_pointer check_do(s7_scheme *sc)
/* check end expression first */
if ((is_pair(car(end))) &&
- (caar(end) != sc->QUOTE) &&
+ (caar(end) != sc->quote_symbol) &&
(is_optimized(car(end))) &&
(is_all_x_safe(sc, car(end))))
set_c_call(cdr(sc->code), all_x_eval(sc, car(end), sc->envir, let_symbol_is_safe));
@@ -57494,7 +57893,7 @@ static s7_pointer check_do(s7_scheme *sc)
}
/* end and steps look ok! */
- pair_set_syntax_symbol(sc->code, sc->DOX);
+ pair_set_syntax_symbol(sc->code, sc->dox_symbol);
set_opt_pair2(sc->code, car(end)); /* end expr */
/* each step expr is safe so not an explicit set!
@@ -57516,14 +57915,14 @@ static s7_pointer check_do(s7_scheme *sc)
step_expr = caddr(var);
set_c_call(cddr(var), all_x_eval(sc, step_expr, vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */
if ((is_pair(step_expr)) &&
- (car(step_expr) != sc->QUOTE) && /* opt_cfunc(==opt1) might not be set in this case (sigh) */
+ (car(step_expr) != sc->quote_symbol) && /* opt_cfunc(==opt1) might not be set in this case (sigh) */
(preserves_type(sc, c_function_class(opt_cfunc(step_expr)))))
set_safe_stepper(cddr(var));
}
}
}
/* there are only a couple of cases in snd-test where a multi-statement do body is completely all-x-able */
- return(sc->NIL);
+ return(sc->nil);
}
return(sc->code);
}
@@ -57641,7 +58040,7 @@ static int dox_ex(s7_scheme *sc)
expr = cadar(vars);
if (is_pair(expr))
{
- if (car(expr) == sc->QUOTE)
+ if (car(expr) == sc->quote_symbol)
val = cadr(expr);
else val = c_call(cdar(vars))(sc, expr);
}
@@ -57775,7 +58174,7 @@ static int dox_ex(s7_scheme *sc)
{
sc->op = (opcode_t)symbol_syntax_op(car(code));
pair_set_syntax_op(code, sc->op);
- set_type(code, SYNTACTIC_PAIR);
+ set_syntactic_pair(code);
}
sc->code = cdr(code);
return(goto_START_WITHOUT_POP_STACK);
@@ -57842,13 +58241,13 @@ static int simple_do_ex(s7_scheme *sc, s7_pointer code)
temp = top;
rf(sc, &temp);
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = step_var;
- slot_set_value(ctr, stepf(sc, sc->T2_1));
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = step_var;
+ slot_set_value(ctr, stepf(sc, sc->t2_1));
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = slot_value(end);
- if (is_true(sc, endf(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = slot_value(end);
+ if (is_true(sc, endf(sc, sc->t2_1)))
{
s7_xf_free(sc);
sc->code = cdr(cadr(code));
@@ -58270,7 +58669,7 @@ static int safe_dotimes_ex(s7_scheme *sc)
{
sc->op = (opcode_t)symbol_syntax_op(car(sc->code));
pair_set_syntax_op(sc->code, sc->op);
- set_type(sc->code, SYNTACTIC_PAIR);
+ set_syntactic_pair(sc->code);
}
sc->code = cdr(sc->code);
return(goto_START_WITHOUT_POP_STACK);
@@ -58339,7 +58738,7 @@ static int safe_do_ex(s7_scheme *sc)
if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val)))
{
- pair_set_syntax_symbol(sc->code, sc->DO_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);
return(goto_DO_UNCHECKED);
}
@@ -58413,7 +58812,7 @@ static int dotimes_p_ex(s7_scheme *sc)
if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val)))
{
- pair_set_syntax_symbol(sc->code, sc->DO_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);
return(goto_DO_UNCHECKED);
}
@@ -58421,9 +58820,9 @@ static int dotimes_p_ex(s7_scheme *sc)
dox_set_slot1(sc->envir, make_slot_1(sc, sc->envir, caaar(code), init_val));
dox_set_slot2(sc->envir, sc->args);
- car(sc->T2_1) = slot_value(dox_slot1(sc->envir));
- car(sc->T2_2) = slot_value(dox_slot2(sc->envir));
- if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(dox_slot1(sc->envir));
+ car(sc->t2_2) = slot_value(dox_slot2(sc->envir));
+ if (is_true(sc, c_call(caadr(code))(sc, sc->t2_1)))
{
sc->code = cdadr(code);
return(goto_DO_END_CLAUSES);
@@ -58503,7 +58902,7 @@ static int do_init_ex(s7_scheme *sc)
/* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->envir,
* also reuse the value cells as the new frame slots.
*/
- sc->value = sc->NIL;
+ sc->value = sc->nil;
y = sc->args;
for (x = car(sc->code); is_not_null(y); x = cdr(x))
{
@@ -58540,8 +58939,8 @@ static int do_init_ex(s7_scheme *sc)
#if (!WITH_GCC)
-#define closure_is_ok(Sc, Code, Type, Args) (find_symbol_unchecked(Sc, car(Code)) == opt_lambda(Code))
-#define closure_star_is_ok(Sc, Code, Type, Args) (find_symbol_unchecked(Sc, car(Code)) == opt_lambda(Code))
+#define closure_is_ok(Sc, Code, Type, Args) (find_symbol_unchecked(Sc, car(Code)) == opt_lambda_unchecked(Code))
+#define closure_star_is_ok(Sc, Code, Type, Args) (find_symbol_unchecked(Sc, car(Code)) == opt_lambda_unchecked(Code))
#else
/* it is almost never the case that we already have the value and can see it in the current environment directly,
@@ -58555,7 +58954,7 @@ static int do_init_ex(s7_scheme *sc)
* opt_lambda(_code_) here can (legitimately) be a free cell or almost anything.
*/
#define closure_is_ok(Sc, Code, Type, Args) \
- ({ s7_pointer _code_, _val_; _code_ = Code; _val_ = find_symbol_unchecked(Sc, car(_code_)); \
+ ({ s7_pointer _code_, _val_; _code_ = Code; _val_ = find_symbol_unexamined(Sc, car(_code_)); \
((_val_ == opt_any1(_code_)) || \
((_val_) && (typesflag(_val_) == (unsigned short)Type) && \
((closure_arity(_val_) == Args) || (closure_arity_to_int(Sc, _val_) == Args)) && \
@@ -58564,8 +58963,8 @@ static int do_init_ex(s7_scheme *sc)
static bool closure_is_ok(s7_scheme *sc, s7_pointer code, unsigned short type, int args)
{
s7_pointer f;
- f = find_symbol_unchecked(sc, car(code));
- return ((f == opt_lambda(code)) ||
+ f = find_symbol_unexamined(sc, car(code));
+ return ((f == opt_lambda_unchecked(code)) ||
((f) &&
(typesflag(f) == type) &&
((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) &&
@@ -58574,7 +58973,7 @@ static bool closure_is_ok(s7_scheme *sc, s7_pointer code, unsigned short type, i
#endif
#define closure_star_is_ok(Sc, Code, Type, Args) \
- ({ s7_pointer _val_; _val_ = find_symbol_unchecked(Sc, car(Code)); \
+ ({ s7_pointer _val_; _val_ = find_symbol_unexamined(Sc, car(Code)); \
((_val_ == opt_any1(Code)) || \
((_val_) && (typesflag(_val_) == (unsigned short)Type) && \
((closure_arity(_val_) >= Args) || (closure_star_arity_to_int(Sc, _val_) >= Args)) && \
@@ -58639,7 +59038,7 @@ static int unknown_ex(s7_scheme *sc, s7_pointer f)
if (typesflag(car(body)) != SYNTACTIC_PAIR)
{
pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
- set_type(car(body), SYNTACTIC_PAIR);
+ set_syntactic_pair(car(body));
}
}
}
@@ -58726,7 +59125,7 @@ static int unknown_g_ex(s7_scheme *sc, s7_pointer f)
if (typesflag(car(body)) != SYNTACTIC_PAIR)
{
pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
- set_type(car(body), SYNTACTIC_PAIR);
+ set_syntactic_pair(car(body));
}
}
}
@@ -58958,7 +59357,7 @@ static int unknown_a_ex(s7_scheme *sc, s7_pointer f)
}
if ((is_pair(cadr(code))) &&
- (caadr(code) == sc->QUOTE))
+ (caadr(code) == sc->quote_symbol))
set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_Q : OP_C_A);
else set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_A : OP_C_A);
set_c_function(code, f);
@@ -58969,7 +59368,7 @@ static int unknown_a_ex(s7_scheme *sc, s7_pointer f)
(closure_arity_to_int(sc, f) == 1))
{
if ((is_pair(cadr(code))) &&
- (caadr(code) == sc->QUOTE))
+ (caadr(code) == sc->quote_symbol))
return(fixup_unknown_op(sc, code, f, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_Q : OP_CLOSURE_Q));
if (is_safe_closure(f))
@@ -58998,7 +59397,7 @@ static int unknown_a_ex(s7_scheme *sc, s7_pointer f)
return(fixup_unknown_op(sc, code, f, OP_C_OBJECT_A));
case T_LET:
- return(fixup_unknown_op(sc, code, f, ((is_pair(cadr(code))) && (caadr(code) == sc->QUOTE)) ? OP_ENVIRONMENT_Q : OP_ENVIRONMENT_A));
+ return(fixup_unknown_op(sc, code, f, ((is_pair(cadr(code))) && (caadr(code) == sc->quote_symbol)) ? OP_ENVIRONMENT_Q : OP_ENVIRONMENT_A));
case T_HASH_TABLE:
return(fixup_unknown_op(sc, code, f, OP_HASH_TABLE_A));
@@ -59147,9 +59546,9 @@ static int dynamic_wind_ex(s7_scheme *sc)
if (dynamic_wind_state(sc->code) == DWIND_INIT)
{
dynamic_wind_state(sc->code) = DWIND_BODY;
- push_stack(sc, OP_DYNAMIC_WIND, sc->NIL, sc->code);
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, sc->code);
sc->code = dynamic_wind_body(sc->code);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
return(goto_APPLY);
}
else
@@ -59161,7 +59560,7 @@ static int dynamic_wind_ex(s7_scheme *sc)
{
push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code);
sc->code = dynamic_wind_out(sc->code);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
return(goto_APPLY);
}
else
@@ -59193,7 +59592,7 @@ static int read_s_ex(s7_scheme *sc)
}
/* I guess this port_is_closed check is needed because we're going down a level below */
if (port_is_closed(port))
- simple_wrong_type_argument_with_type(sc, sc->READ, port, AN_OPEN_PORT);
+ simple_wrong_type_argument_with_type(sc, sc->read_symbol, port, an_open_port_string);
if (is_function_port(port))
sc->value = (*(port_input_function(port)))(sc, S7_READ, port);
@@ -59201,11 +59600,11 @@ static int read_s_ex(s7_scheme *sc)
{
if ((is_string_port(port)) &&
(port_data_size(port) <= port_position(port)))
- sc->value = sc->EOF_OBJECT;
+ sc->value = sc->eof_object;
else
{
push_input_port(sc, port);
- push_stack(sc, OP_READ_DONE, sc->NIL, sc->NIL); /* this stops the internal read process so we only get one form */
+ push_stack(sc, OP_READ_DONE, sc->nil, sc->nil); /* this stops the internal read process so we only get one form */
sc->tok = token(sc);
switch (sc->tok)
{
@@ -59229,35 +59628,6 @@ static int read_s_ex(s7_scheme *sc)
return(goto_START);
}
-static void eval_string_ex(s7_scheme *sc)
-{
- /* read and evaluate string expression(s?)
- * assume caller (C via g_eval_c_string) is dealing with the string port
- */
- /* (eval-string (string-append "(list 1 2 3)" (string #\newline) (string #\newline)))
- * needs to be sure to get rid of the trailing white space before checking for EOF
- * else it tries to eval twice and gets "attempt to apply 1?, line 2"
- */
- if ((sc->tok != TOKEN_EOF) &&
- (port_position(sc->input_port) < port_data_size(sc->input_port))) /* ran past end somehow? */
- {
- unsigned char c;
- while (white_space[c = port_data(sc->input_port)[port_position(sc->input_port)++]])
- if (c == '\n')
- port_line_number(sc->input_port)++;
-
- if (c != 0)
- {
- backchar(c, sc->input_port);
- push_stack(sc, OP_EVAL_STRING, sc->NIL, sc->value);
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
- }
- else push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->value);
- }
- else push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->value);
- sc->code = sc->value;
-}
-
static void eval_string_1_ex(s7_scheme *sc)
{
if ((sc->tok != TOKEN_EOF) &&
@@ -59271,12 +59641,12 @@ static void eval_string_1_ex(s7_scheme *sc)
if (c != 0)
{
backchar(c, sc->input_port);
- push_stack(sc, OP_EVAL_STRING_1, sc->NIL, sc->value);
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_STRING_1, sc->nil, sc->value);
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
}
- else push_stack(sc, OP_EVAL_STRING_2, sc->NIL, sc->NIL);
+ else push_stack(sc, OP_EVAL_STRING_2, sc->nil, sc->nil);
}
- else push_stack(sc, OP_EVAL_STRING_2, sc->NIL, sc->NIL);
+ else push_stack(sc, OP_EVAL_STRING_2, sc->nil, sc->nil);
sc->code = sc->value;
}
@@ -59430,7 +59800,7 @@ static int vector_s_ex(s7_scheme *sc)
return(goto_START);
}
}
- sc->value = vector_ref_1(sc, v, cons(sc, ind, sc->NIL));
+ sc->value = vector_ref_1(sc, v, cons(sc, ind, sc->nil));
return(goto_START);
}
@@ -59458,36 +59828,10 @@ static int vector_a_ex(s7_scheme *sc)
}
}
}
- sc->value = vector_ref_1(sc, v, cons(sc, x, sc->NIL));
+ sc->value = vector_ref_1(sc, v, cons(sc, x, sc->nil));
return(goto_START);
}
-#if WITH_QUASIQUOTE_VECTOR
-static void read_quasiquote_vector_ex(s7_scheme *sc)
-{
- /* this works only if the quasiquoted list elements can be evaluated in the read-time environment.
- * `#(1 ,@(list 1 2) 4) -> (apply vector ({list} 1 ({apply_values} (list 1 2)) 4)) -> #(1 1 2 4)
- *
- * Originally, I used:
- * sc->value = list_3(sc, sc->Apply, sc->Vector, g_quasiquote_1(sc, sc->value));
- * goto START;
- * which means that #(...) makes a vector at read time, but `#(...) is just like (vector ...).
- * :(let ((f1 (lambda () (let ((x 32)) #(x 0))))
- * (f2 (lambda () (let ((x 32)) `#(,x 0)))))
- * (eq? (f1) (f1)))
- * #t
- * :(let ((f1 (lambda () (let ((x 32)) #(x 0))))
- * (f2 (lambda () (let ((x 32)) `#(,x 0)))))
- * (eq? (f2) (f2)))
- * #f
- * The tricky part in s7 is that we might have quasiquoted multidimensional vectors
- */
- if (sc->args == small_int(1))
- sc->code = list_3(sc, sc->Apply, sc->Vector, g_quasiquote_1(sc, sc->value)); /* qq result will be evaluated (might include {list} etc) */
- else sc->code = list_4(sc, sc->Apply, sc->Multivector, sc->args, g_quasiquote_1(sc, sc->value));
-}
-#endif
-
static void increment_1_ex(s7_scheme *sc)
{
/* ([set!] ctr (+ ctr 1)) */
@@ -59495,7 +59839,7 @@ static void increment_1_ex(s7_scheme *sc)
y = find_symbol(sc, car(sc->code));
if (!is_slot(y))
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "set! ~A: unbound variable", car(sc->code));
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", car(sc->code));
val = slot_value(y);
switch (type(val))
@@ -59533,7 +59877,7 @@ static void decrement_1_ex(s7_scheme *sc)
s7_pointer val, y;
y = find_symbol(sc, car(sc->code));
if (!is_slot(y))
- eval_error_no_return(sc, sc->WRONG_TYPE_ARG, "set! ~A: unbound variable", car(sc->code));
+ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", car(sc->code));
val = slot_value(y);
switch (type(val))
{
@@ -59575,7 +59919,7 @@ static void set_pws_ex(s7_scheme *sc)
obj = find_symbol(sc, obj);
if (is_slot(obj))
obj = slot_value(obj);
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", caar(sc->code));
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar(sc->code));
}
if ((is_c_function(obj)) &&
@@ -59586,10 +59930,10 @@ static void set_pws_ex(s7_scheme *sc)
if (is_symbol(value))
value = find_symbol_checked(sc, value);
- car(sc->T1_1) = value;
- sc->value = c_function_call(c_function_setter(obj))(sc, sc->T1_1);
+ car(sc->t1_1) = value;
+ sc->value = c_function_call(c_function_setter(obj))(sc, sc->t1_1);
}
- else eval_error_no_return(sc, sc->SYNTAX_ERROR, "no generalized set for ~A", obj);
+ else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", obj);
}
@@ -59600,9 +59944,9 @@ static void apply_c_function(s7_scheme *sc) /* -------- C-b
unsigned int len;
len = safe_list_length(sc, sc->args);
if (len < c_function_required_args(sc->code))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
if (c_function_all_args(sc->code) < len)
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
sc->value = c_function_call(sc->code)(sc, sc->args);
}
@@ -59611,7 +59955,7 @@ static void apply_c_opt_args_function(s7_scheme *sc) /* --------
unsigned int len;
len = safe_list_length(sc, sc->args);
if (c_function_all_args(sc->code) < len)
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
sc->value = c_function_call(sc->code)(sc, sc->args);
}
@@ -59620,7 +59964,7 @@ static void apply_c_rst_args_function(s7_scheme *sc) /* --------
unsigned int len;
len = safe_list_length(sc, sc->args);
if (len < c_function_required_args(sc->code))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
sc->value = c_function_call(sc->code)(sc, sc->args);
/* sc->code here need not match sc->code before the function call (map for example) */
}
@@ -59641,15 +59985,15 @@ static void apply_c_macro(s7_scheme *sc) /* -------- C-bas
len = s7_list_length(sc, sc->args);
if (len < (int)c_macro_required_args(sc->code))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
if ((int)c_macro_all_args(sc->code) < len)
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
sc->code = c_macro_call(sc->code)(sc, sc->args);
if (is_multiple_value(sc->code)) /* can this happen? s7_values splices before returning, and `(values ...) is handled later */
{
- push_stack(sc, OP_EVAL_MACRO_MV, sc->NIL, cdr(sc->code));
+ push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->code));
sc->code = car(sc->code);
}
}
@@ -59660,16 +60004,16 @@ static void apply_syntax(s7_scheme *sc) /* -------- s
if (is_pair(sc->args))
{
len = s7_list_length(sc, sc->args);
- if (len == 0) eval_error_no_return(sc, sc->SYNTAX_ERROR, "attempt to evaluate a circular list: ~A", sc->args);
+ if (len == 0) eval_error_no_return(sc, sc->syntax_error_symbol, "attempt to evaluate a circular list: ~A", sc->args);
}
else len = 0;
if (len < syntax_min_args(sc->code))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
if ((syntax_max_args(sc->code) < len) &&
(syntax_max_args(sc->code) != -1))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
sc->op = (opcode_t)syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */
/* I used to have elaborate checks here for embedded circular lists, but now i think that is the caller's problem */
@@ -59691,7 +60035,7 @@ static void apply_vector(s7_scheme *sc) /* -------- v
if ((index >= 0) &&
(index < vector_length(sc->code)))
sc->value = vector_getter(sc->code)(sc, sc->code, index);
- else out_of_range(sc, sc->VECTOR_REF, small_int(2), car(sc->args), (index < 0) ? ITS_NEGATIVE : ITS_TOO_LARGE);
+ else out_of_range(sc, sc->vector_ref_symbol, small_int(2), car(sc->args), (index < 0) ? its_negative_string : its_too_large_string);
}
else sc->value = vector_ref_1(sc, sc->code, sc->args);
}
@@ -59716,8 +60060,8 @@ static void apply_string(s7_scheme *sc) /* -------- s
sc->value = string_ref_1(sc, sc->code, car(sc->args));
return;
}
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS,
- set_elist_3(sc, (is_null(sc->args)) ? sc->NOT_ENOUGH_ARGUMENTS : sc->TOO_MANY_ARGUMENTS, sc->code, sc->args));
+ s7_error(sc, sc->wrong_number_of_args_symbol,
+ set_elist_3(sc, (is_null(sc->args)) ? sc->not_enough_arguments_string : sc->too_many_arguments_string, sc->code, sc->args));
}
static int apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */
@@ -59728,7 +60072,7 @@ static int apply_pair(s7_scheme *sc) /* -------- li
sc->x = multiple_value(sc->code); /* ((values + 1 2) 3) */
sc->code = car(sc->x);
sc->args = s7_append(sc, cdr(sc->x), sc->args);
- sc->x = sc->NIL;
+ sc->x = sc->nil;
return(goto_APPLY);
}
if (is_null(sc->args))
@@ -59781,14 +60125,19 @@ static void apply_lambda(s7_scheme *sc) /* --------
/* reuse the value cells as the new frame slots */
if (is_null(z))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->NOT_ENOUGH_ARGUMENTS, closure_name(sc, sc->code), sc->cur_code));
+ {
+ s7_pointer name, ccode;
+ name = closure_name(sc, sc->code);
+ ccode = current_code(sc);
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, (name == ccode) ? sc->code : name, ccode));
+ }
/* now that args are being reused as slots, the error message can't use sc->args,
- * so fallback on sc->cur_code in this section.
+ * so fallback on current_code(sc) in this section.
* But that can be #f, and closure_name can be confusing in this context, so we need a better error message!
*/
sym = car(x);
- val = car(z);
+ val = _NFre(car(z));
args = cdr(z);
set_type(z, T_SLOT);
slot_set_symbol(z, sym);
@@ -59801,13 +60150,18 @@ static void apply_lambda(s7_scheme *sc) /* --------
if (is_null(x))
{
if (is_not_null(z))
- s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, set_elist_3(sc, sc->TOO_MANY_ARGUMENTS, closure_name(sc, sc->code), sc->cur_code));
+ {
+ s7_pointer name, ccode;
+ name = closure_name(sc, sc->code);
+ ccode = current_code(sc);
+ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, (name == ccode) ? sc->code : name, ccode));
+ }
}
else
{
sc->temp6 = z; /* the rest arg */
make_slot_1(sc, sc->envir, x, z);
- sc->temp6 = sc->NIL;
+ sc->temp6 = sc->nil;
}
sc->code = closure_body(sc->code);
}
@@ -59824,6 +60178,7 @@ static int apply_lambda_star(s7_scheme *sc) /* -------- defin
s7_pointer z, top, nxt;
top = NULL;
nxt = NULL;
+
for (z = closure_args(sc->code); is_pair(z); z = cdr(z))
{
s7_pointer car_z;
@@ -59838,10 +60193,10 @@ static int apply_lambda_star(s7_scheme *sc) /* -------- defin
else
{
s7_pointer y;
- add_slot(sc->envir, car(car_z), sc->UNDEFINED);
+ add_slot(sc->envir, car(car_z), sc->undefined);
y = let_slots(sc->envir);
slot_expression(y) = cadr(car_z);
- slot_pending_value(y) = sc->NIL;
+ slot_pending_value(y) = sc->nil;
if (!top)
{
top = y;
@@ -59860,16 +60215,16 @@ static int apply_lambda_star(s7_scheme *sc) /* -------- defin
make_slot_1(sc, sc->envir, car_z, sc->F);
else
{
- if (car_z == sc->KEY_REST)
+ if (car_z == sc->key_rest_symbol)
{
- make_slot_1(sc, sc->envir, cadr(z), sc->NIL);
+ make_slot_1(sc, sc->envir, cadr(z), sc->nil);
z = cdr(z);
}
}
}
}
if (is_symbol(z))
- make_slot_1(sc, sc->envir, z, sc->NIL);
+ make_slot_1(sc, sc->envir, z, sc->nil);
lambda_star_set_args(sc); /* load up current arg vals */
if (top)
@@ -59880,7 +60235,6 @@ static int apply_lambda_star(s7_scheme *sc) /* -------- defin
if (lambda_star_default(sc) == goto_EVAL) return(goto_EVAL);
pop_stack_no_op(sc); /* get original args and code back */
}
-
sc->code = closure_body(sc->code);
return(goto_BEGIN1);
}
@@ -59891,7 +60245,7 @@ static void apply_continuation(s7_scheme *sc) /* -------- cont
{
static s7_pointer cc_err = NULL;
if (!cc_err) cc_err = s7_make_permanent_string("continuation can't jump into with-baffle");
- s7_error(sc, sc->BAFFLED, set_elist_1(sc, cc_err));
+ s7_error(sc, sc->baffled_symbol, set_elist_1(sc, cc_err));
}
}
@@ -59901,8 +60255,6 @@ static void apply_c_object(s7_scheme *sc) /* -------- a
}
-
-
/* -------------------------------------------------------------------------------- */
static int define1_ex(s7_scheme *sc)
@@ -59929,13 +60281,13 @@ static int define1_ex(s7_scheme *sc)
{
s7_pointer x;
if (!is_symbol(sc->code)) /* (define "pi" 3) ? */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "define: ~S is immutable", sc->code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "define: ~S is immutable", sc->code);
x = global_slot(sc->code);
if ((!is_slot(x)) ||
(type(sc->value) != unchecked_type(slot_value(x))) ||
(!s7_is_morally_equal(sc, sc->value, slot_value(x)))) /* if value is unchanged, just ignore this (re)definition */
- eval_error_no_return(sc, sc->SYNTAX_ERROR, "define: ~S is immutable", sc->code); /* can't use s7_is_equal because value might be NaN, etc */
+ eval_error_no_return(sc, sc->syntax_error_symbol, "define: ~S is immutable", sc->code); /* can't use s7_is_equal because value might be NaN, etc */
}
if (symbol_has_accessor(sc->code))
{
@@ -59945,7 +60297,7 @@ static int define1_ex(s7_scheme *sc)
(slot_has_accessor(x)))
{
sc->value = bind_accessed_symbol(sc, OP_DEFINE_WITH_ACCESSOR, sc->code, sc->value);
- if (sc->value == sc->NO_VALUE)
+ if (sc->value == sc->no_value)
return(goto_APPLY);
/* if all goes well, OP_DEFINE_WITH_ACCESSOR will jump to DEFINE2 */
}
@@ -59955,21 +60307,22 @@ static int define1_ex(s7_scheme *sc)
static void define2_ex(s7_scheme *sc)
{
- if (is_any_closure(sc->value))
+ if ((is_any_closure(sc->value)) &&
+ ((!(is_let(closure_let(sc->value)))) ||
+ (!(is_function_env(closure_let(sc->value)))))) /* otherwise it's (define f2 f1) or something similar */
{
s7_pointer new_func, new_env;
new_func = sc->value;
/* we can get here from let: (define (outer a) (let () (define (inner b) (+ a b)) (inner a)))
* but the port info is not relevant here, so restrict the __func__ list making to top-level
- * cases (via sc->envir == sc->NIL).
+ * cases (via sc->envir == sc->nil).
*/
-
new_cell_no_check(sc, new_env, T_LET | T_FUNCTION_ENV);
let_id(new_env) = ++sc->let_number;
set_outlet(new_env, closure_let(new_func));
closure_set_let(new_func, new_env);
- let_set_slots(new_env, sc->NIL);
+ let_set_slots(new_env, sc->nil);
funclet_set_function(new_env, sc->code);
if ((!is_let(sc->envir)) &&
@@ -59998,8 +60351,8 @@ static void define2_ex(s7_scheme *sc)
for (i = 0, arg = closure_args(new_func); is_pair(arg); i++, arg = cdr(arg))
{
if (is_pair(car(arg)))
- make_slot_1(sc, new_env, caar(arg), sc->NIL);
- else make_slot_1(sc, new_env, car(arg), sc->NIL);
+ make_slot_1(sc, new_env, caar(arg), sc->nil);
+ else make_slot_1(sc, new_env, car(arg), sc->nil);
}
let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
}
@@ -60034,13 +60387,14 @@ static void clear_all_optimizations(s7_scheme *sc, s7_pointer p)
*/
if (is_pair(p))
{
- if (is_optimized(p))
+ if ((is_optimized(p)) &&
+ ((optimize_op(p) & 1) == 0)) /* protect possibly shared code? Elsewhere we assume these aren't changed */
{
clear_optimized(p);
clear_optimize_op(p);
- set_opt_con1(p, sc->NIL);
- set_opt_con2(p, sc->NIL);
-
+ /* these apparently make no difference */
+ set_opt_con1(p, sc->nil);
+ set_opt_con2(p, sc->nil);
}
clear_all_optimizations(sc, cdr(p));
clear_all_optimizations(sc, car(p));
@@ -60056,7 +60410,7 @@ static bool a_is_ok(s7_scheme *sc, s7_pointer p)
if ((is_optimized(p)) &&
(!c_function_is_ok(sc, p)))
return(false);
- if (car(p) != sc->QUOTE)
+ if (car(p) != sc->quote_symbol)
return((a_is_ok(sc, car(p))) &&
(a_is_ok(sc, cdr(p))));
}
@@ -60072,6 +60426,27 @@ static bool a_is_ok(s7_scheme *sc, s7_pointer p)
#define a_is_ok_cadddr(Sc, P) ((c_function_is_ok(Sc, P)) && (a_is_ok(Sc, cadddr(P))))
+#if WITH_PROFILE
+static void profile(s7_scheme *sc, s7_pointer expr)
+{
+ if (is_null(sc->profile_info))
+ {
+ sc->profile_info = s7_make_hash_table(sc, 65536);
+ s7_gc_protect(sc, sc->profile_info);
+ }
+ if ((is_pair(expr)) &&
+ (has_line_number(expr)))
+ {
+ s7_pointer val, key;
+ key = s7_make_integer(sc, pair_line(expr));
+ val = s7_hash_table_ref(sc, sc->profile_info, key);
+ if (val == sc->F)
+ s7_hash_table_set(sc, sc->profile_info, key, cons(sc, make_mutable_integer(sc, 1), expr));
+ else integer(car(val))++;
+ }
+}
+#endif
+
/* -------------------------------- eval -------------------------------- */
@@ -60162,7 +60537,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
*/
if (port_is_closed(sc->input_port))
- return(s7_error(sc, sc->READ_ERROR, set_elist_1(sc, make_string_wrapper(sc, "our input port got clobbered!"))));
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "our input port got clobbered!"))));
sc->tok = token(sc);
switch (sc->tok)
@@ -60201,7 +60576,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
pop_input_port(sc);
if (sc->tok == TOKEN_EOF)
- sc->value = sc->EOF_OBJECT;
+ sc->value = sc->eof_object;
sc->current_file = NULL; /* this is for error handling */
break;
@@ -60212,8 +60587,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_LOAD_RETURN_IF_EOF: /* loop here until eof (via push stack below) */
if (sc->tok != TOKEN_EOF)
{
- push_stack(sc, OP_LOAD_RETURN_IF_EOF, sc->NIL, sc->NIL);
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_LOAD_RETURN_IF_EOF, sc->nil, sc->nil);
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
sc->code = sc->value;
goto EVAL; /* we read an expression, now evaluate it, and return to read the next */
}
@@ -60227,11 +60602,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_LOAD_CLOSE_AND_POP_IF_EOF:
if (sc->tok != TOKEN_EOF)
{
- push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->NIL, sc->NIL); /* was push args, code */
+ push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->nil, sc->nil); /* was push args, code */
if ((!is_string_port(sc->input_port)) ||
(port_position(sc->input_port) < port_data_size(sc->input_port)))
{
- push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
+ push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
}
else sc->tok = TOKEN_EOF;
sc->code = sc->value;
@@ -60246,10 +60621,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
break;
- case OP_EVAL_STRING:
- eval_string_ex(sc);
- goto EVAL;
-
case OP_EVAL_STRING_2:
s7_close_input_port(sc, sc->input_port);
pop_input_port(sc);
@@ -60300,9 +60671,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1));
else
{
- car(sc->T2_1) = SORT_DATA(j);
- car(sc->T2_2) = SORT_DATA(j + 1);
- sc->args = sc->T2_1;
+ car(sc->t2_1) = SORT_DATA(j);
+ car(sc->t2_2) = SORT_DATA(j + 1);
+ sc->args = sc->t2_1;
}
sc->code = lx;
goto APPLY;
@@ -60327,9 +60698,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j));
else
{
- car(sc->T2_1) = SORT_DATA(k);
- car(sc->T2_2) = SORT_DATA(j);
- sc->args = sc->T2_1;
+ car(sc->t2_1) = SORT_DATA(k);
+ car(sc->t2_2) = SORT_DATA(j);
+ sc->args = sc->t2_1;
}
sc->code = lx;
goto APPLY;
@@ -60424,7 +60795,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* -------------------------------- MAP -------------------------------- */
case OP_MAP_GATHER_1:
- if (sc->value != sc->NO_VALUE)
+ if (sc->value != sc->no_value)
{
if (is_multiple_value(sc->value))
counter_result(sc->args) = revappend(sc, multiple_value(sc->value), counter_result(sc->args));
@@ -60449,16 +60820,29 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), x);
counter_set_let(args, sc->envir);
+ counter_slots(args) = let_slots(sc->envir);
counter_capture(args) = sc->capture_let_counter;
}
- else sc->envir = old_frame_with_slot(sc, counter_let(args), x);
+ else
+ {
+ /* the counter_slots field saves the original local let slot(s) representing the function
+ * argument. If the function has internal defines, they get added to the front of the
+ * slots list, but old_frame_with_slot (maybe stupidly) assumes only the one original
+ * slot exists when it updates its symbol_id from the (possibly changed) let_id. So,
+ * a subsequent reference to the parameter name causes "unbound variable", or a segfault
+ * if the check has been optimized away. I think each function call should start with
+ * the original let slots, so counter_slots saves that pointer, and resets it here.
+ */
+ let_slots(counter_let(args)) = counter_slots(args);
+ sc->envir = old_frame_with_slot(sc, counter_let(args), x);
+ }
sc->code = closure_body(code);
goto BEGIN1;
}
case OP_MAP_GATHER:
- if (sc->value != sc->NO_VALUE) /* (map (lambda (x) (values)) (list 1)) */
+ if (sc->value != sc->no_value) /* (map (lambda (x) (values)) (list 1)) */
{
if (is_multiple_value(sc->value)) /* (map (lambda (x) (if (odd? x) (values x (* x 20)) (values))) (list 1 2 3 4)) */
counter_result(sc->args) = revappend(sc, multiple_value(sc->value), counter_result(sc->args));
@@ -60470,7 +60854,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer y, iterators;
iterators = counter_list(sc->args);
- sc->x = sc->NIL; /* can't use preset args list here (as in for-each): (map list '(a b c)) */
+ sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */
for (y = iterators; is_pair(y); y = cdr(y))
{
s7_pointer x;
@@ -60486,7 +60870,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->x = safe_reverse_in_place(sc, sc->x);
push_stack(sc, OP_MAP_GATHER, sc->args, sc->code);
sc->args = sc->x;
- sc->x = sc->NIL;
+ sc->x = sc->nil;
if (needs_copied_args(sc->code))
sc->args = copy_list(sc, sc->args);
@@ -60505,7 +60889,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
car(x) = s7_iterate(sc, car(y));
if (iterator_is_at_end(car(y)))
{
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
goto START;
}
}
@@ -60533,7 +60917,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
arg = s7_iterate(sc, p);
if (iterator_is_at_end(p))
{
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
goto START;
}
code = sc->code;
@@ -60541,9 +60925,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg);
counter_set_let(counter, sc->envir);
+ counter_slots(counter) = let_slots(sc->envir);
counter_capture(counter) = sc->capture_let_counter;
}
- else sc->envir = old_frame_with_slot(sc, counter_let(counter), arg);
+ else
+ {
+ let_slots(counter_let(counter)) = counter_slots(counter);
+ sc->envir = old_frame_with_slot(sc, counter_let(counter), arg);
+ }
push_stack(sc, OP_FOR_EACH_1, counter, code);
sc->code = closure_body(code);
goto BEGIN1;
@@ -60557,7 +60946,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
lst = counter_list(c);
if (!is_pair(lst)) /* '(1 2 . 3) as arg? */
{
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
goto START;
}
code = sc->code;
@@ -60568,7 +60957,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
counter_result(c) = cdr(counter_result(c));
if (counter_result(c) == counter_list(c))
{
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
goto START;
}
push_stack(sc, OP_FOR_EACH_2, c, code);
@@ -60578,9 +60967,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg);
counter_set_let(c, sc->envir);
+ counter_slots(c) = let_slots(sc->envir);
counter_capture(c) = sc->capture_let_counter;
}
- else sc->envir = old_frame_with_slot(sc, counter_let(c), arg);
+ else
+ {
+ let_slots(counter_let(c)) = counter_slots(c);
+ sc->envir = old_frame_with_slot(sc, counter_let(c), arg);
+ }
sc->code = closure_body(code);
goto BEGIN1;
}
@@ -60675,7 +61069,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (choice == goto_BEGIN1) goto BEGIN1;
if (choice == goto_OPT_EVAL) goto OPT_EVAL;
if (choice == goto_START_WITHOUT_POP_STACK) goto START_WITHOUT_POP_STACK;
- pair_set_syntax_symbol(sc->code, sc->SIMPLE_DO);
+ pair_set_syntax_symbol(sc->code, sc->simple_do_symbol);
goto SIMPLE_DO;
}
@@ -60719,9 +61113,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer arg;
/* no calls?? */
arg = slot_value(sc->args);
- car(sc->T2_1) = arg;
- car(sc->T2_2) = sc->value;
- c_call(opt_pair2(sc->code))(sc, sc->T2_1);
+ car(sc->t2_1) = arg;
+ car(sc->t2_2) = sc->value;
+ c_call(opt_pair2(sc->code))(sc, sc->t2_1);
numerator(arg)++;
if (numerator(arg) == denominator(arg))
@@ -60840,9 +61234,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = slot;
}
dox_set_slot2(sc->envir, sc->args);
- car(sc->T2_1) = slot_value(dox_slot1(sc->envir));
- car(sc->T2_2) = slot_value(dox_slot2(sc->envir));
- if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(dox_slot1(sc->envir));
+ car(sc->t2_2) = slot_value(dox_slot2(sc->envir));
+ if (is_true(sc, c_call(caadr(code))(sc, sc->t2_1)))
{
sc->code = cdadr(code);
goto DO_END_CLAUSES;
@@ -60892,19 +61286,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
step = caddr(caar(code));
if (is_symbol(cadr(step)))
{
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = caddr(step);
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = caddr(step);
}
else
{
- car(sc->T2_2) = slot_value(ctr);
- car(sc->T2_1) = cadr(step);
+ car(sc->t2_2) = slot_value(ctr);
+ car(sc->t2_1) = cadr(step);
}
- slot_set_value(ctr, c_call(step)(sc, sc->T2_1));
+ slot_set_value(ctr, c_call(step)(sc, sc->t2_1));
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = slot_value(end);
- if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = slot_value(end);
+ if (is_true(sc, c_call(caadr(code))(sc, sc->t2_1)))
{
sc->code = cdr(cadr(code));
goto DO_END_CLAUSES;
@@ -60914,7 +61308,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (sc->op == OP_SIMPLE_DO_STEP_P)
{
code = caddr(code);
- sc->cur_code = code;
+ set_current_code(sc, code);
sc->op = (opcode_t)pair_syntax_op(code);
sc->code = cdr(code);
goto START_WITHOUT_POP_STACK;
@@ -60952,9 +61346,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
else
{
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = end;
- if (is_true(sc, g_equal_2(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = end;
+ if (is_true(sc, g_equal_2(sc, sc->t2_1)))
{
sc->code = cdr(cadr(code));
goto DO_END_CLAUSES;
@@ -60963,11 +61357,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
else
{
- car(sc->T1_1) = val; /* add_s1 ignores cadr(args) */
- slot_set_value(ctr, g_add_s1(sc, sc->T1_1));
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = end;
- if (is_true(sc, g_equal_2(sc, sc->T2_1)))
+ car(sc->t1_1) = val; /* add_s1 ignores cadr(args) */
+ slot_set_value(ctr, g_add_s1(sc, sc->t1_1));
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = end;
+ if (is_true(sc, g_equal_2(sc, sc->t2_1)))
{
sc->code = cdr(cadr(code));
goto DO_END_CLAUSES;
@@ -61021,9 +61415,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
else
{
- car(sc->T2_1) = now;
- car(sc->T2_2) = end;
- if (is_true(sc, c_call(end_test)(sc, sc->T2_1)))
+ car(sc->t2_1) = now;
+ car(sc->t2_2) = end;
+ if (is_true(sc, c_call(end_test)(sc, sc->t2_1)))
{
sc->code = cdadr(code);
goto DO_END_CLAUSES;
@@ -61032,12 +61426,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
else
{
- car(sc->T1_1) = now;
- slot_set_value(ctr, g_add_s1(sc, sc->T1_1));
+ car(sc->t1_1) = now;
+ slot_set_value(ctr, g_add_s1(sc, sc->t1_1));
/* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */
- car(sc->T2_1) = slot_value(ctr);
- car(sc->T2_2) = end;
- if (is_true(sc, c_call(end_test)(sc, sc->T2_1)))
+ car(sc->t2_1) = slot_value(ctr);
+ car(sc->t2_2) = end;
+ if (is_true(sc, c_call(end_test)(sc, sc->t2_1)))
{
sc->code = cdadr(code);
goto DO_END_CLAUSES;
@@ -61045,7 +61439,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
code = caddr(code);
- sc->cur_code = code;
+ set_current_code(sc, code);
sc->op = (opcode_t)pair_syntax_op(code);
sc->code = cdr(code);
goto START_WITHOUT_POP_STACK;
@@ -61173,7 +61567,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
* I think not; the closure retains the current env chain, not the slots, so we need a new env.
*/
- sc->value = sc->NIL;
+ sc->value = sc->nil;
pop_stack_no_op(sc);
goto DO_END;
}
@@ -61197,13 +61591,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer op;
op = car(opt_back(sc->code));
- if (op == sc->DOX) goto DOX;
- if (op == sc->SAFE_DOTIMES) goto SAFE_DOTIMES;
- if (op == sc->DOTIMES_P) goto DOTIMES_P;
- if (op == sc->SAFE_DO) goto SAFE_DO;
- if (op == sc->SIMPLE_DO_A) goto SIMPLE_DO_A;
- if (op == sc->SIMPLE_DO_E) goto SIMPLE_DO_E;
- if (op == sc->SIMPLE_DO) goto SIMPLE_DO;
+ if (op == sc->dox_symbol) goto DOX;
+ if (op == sc->safe_dotimes_symbol) goto SAFE_DOTIMES;
+ if (op == sc->dotimes_p_symbol) goto DOTIMES_P;
+ if (op == sc->safe_do_symbol) goto SAFE_DO;
+ if (op == sc->simple_do_a_symbol) goto SIMPLE_DO_A;
+ if (op == sc->simple_do_e_symbol) goto SIMPLE_DO_E;
+ if (op == sc->simple_do_symbol) goto SIMPLE_DO;
goto SIMPLE_DO_P;
}
@@ -61212,12 +61606,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
{
sc->envir = new_frame_in_env(sc, sc->envir);
- sc->args = cons_unchecked(sc, sc->NIL, cadr(sc->code));
+ sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code));
sc->code = cddr(sc->code);
goto DO_END;
}
/* eval each init value, then set up the new frame (like let, not let*) */
- sc->args = sc->NIL; /* the evaluated var-data */
+ sc->args = sc->nil; /* the evaluated var-data */
sc->value = sc->code; /* protect it */
sc->code = car(sc->code); /* the vars */
@@ -61272,10 +61666,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
*/
sc->code = cddr(sc->args); /* result expr (a list -- implicit begin) */
free_cell(sc, sc->args);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
if (is_null(sc->code))
{
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto START;
}
}
@@ -61293,9 +61687,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
SAFE_DO_END_CLAUSES:
if (is_null(sc->code))
{
- /* sc->args = sc->NIL; */
+ /* sc->args = sc->nil; */
sc->envir = free_let(sc, sc->envir);
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto START;
}
goto DO_END_CODE;
@@ -61303,7 +61697,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
DO_END_CLAUSES:
if (is_null(sc->code))
{
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto START;
}
DO_END_CODE:
@@ -61331,13 +61725,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
(!is_null(cdr(sc->code))) &&
(is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->BEGIN_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->begin_unchecked_symbol);
case OP_BEGIN_UNCHECKED:
/* if ((sc->begin_hook) && (call_begin_hook(sc))) return(sc->F); */
if (is_null(sc->code)) /* (begin) -> () */
{
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto START;
}
@@ -61362,7 +61756,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (typesflag(sc->code) == SYNTACTIC_PAIR) /* xor is not faster here */
{
- sc->cur_code = sc->code; /* in case an error occurs, this helps tell us where we are */
+#if WITH_PROFILE
+ profile(sc, sc->code);
+#endif
+ set_current_code(sc, sc->code); /* in case an error occurs, this helps tell us where we are */
sc->op = (opcode_t)pair_syntax_op(sc->code);
sc->code = cdr(sc->code);
goto START_WITHOUT_POP_STACK; /* it is only slightly faster to use labels as values (computed gotos) here */
@@ -61374,8 +61771,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* fprintf(stderr, " %s\n", opt_names[optimize_op(sc->code)]); */
OPT_EVAL:
+#if WITH_PROFILE
+ profile(sc, sc->code);
+#endif
code = sc->code;
- sc->cur_code = code;
+ set_current_code(sc, code);
switch (optimize_op(code))
{
@@ -61392,8 +61792,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_Q:
- car(sc->T1_1) = cadr(cadr(code));
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = cadr(cadr(code));
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
@@ -61401,8 +61801,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_S:
- car(sc->T1_1) = find_symbol_checked(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
@@ -61414,9 +61814,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer val, args;
args = cdr(code);
val = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = val;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = val;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61437,7 +61837,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = sc->safe_lists[num_args];
set_list_in_use(sc->args);
}
- else sc->args = make_list(sc, num_args, sc->NIL);
+ else sc->args = make_list(sc, num_args, sc->nil);
for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
car(p) = find_symbol_checked(sc, car(args));
@@ -61454,9 +61854,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, car(args));
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61468,9 +61868,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61482,9 +61882,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = cadr(cadr(args));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, car(args));
+ car(sc->t2_2) = cadr(cadr(args));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61496,9 +61896,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = cadr(car(args));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = cadr(car(args));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61510,9 +61910,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = cadr(car(args));
- car(sc->T2_2) = cadr(cadr(args));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = cadr(car(args));
+ car(sc->t2_2) = cadr(cadr(args));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61524,9 +61924,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = car(args);
- car(sc->T2_2) = cadr(cadr(args));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = car(args);
+ car(sc->t2_2) = cadr(cadr(args));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61538,9 +61938,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = cadr(car(args));
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = cadr(car(args));
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61553,7 +61953,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_SAFE_C_Z:
check_stack_size(sc);
- push_stack(sc, OP_SAFE_C_P_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_P_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61599,7 +61999,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_SAFE_C_ZS:
check_stack_size(sc);
- push_stack(sc, OP_EVAL_ARGS_P_3, sc->NIL, code);
+ push_stack(sc, OP_EVAL_ARGS_P_3, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61611,9 +62011,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cadr(code);
- car(sc->A1_1) = c_call(cdr(arg))(sc, cadr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->A1_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->a1_1) = c_call(cdr(arg))(sc, cadr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->a1_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -61625,10 +62025,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cadr(code);
- car(sc->A2_1) = c_call(cdr(arg))(sc, cadr(arg));
- car(sc->A2_2) = c_call(cddr(arg))(sc, caddr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->A2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->a2_1) = c_call(cdr(arg))(sc, cadr(arg));
+ car(sc->a2_2) = c_call(cddr(arg))(sc, caddr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->a2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -61640,11 +62040,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cadr(code);
- car(sc->A3_1) = c_call(cdr(arg))(sc, cadr(arg));
- car(sc->A3_2) = c_call(cddr(arg))(sc, caddr(arg));
- car(sc->A3_3) = c_call(cdddr(arg))(sc, cadddr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->A3_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->a3_1) = c_call(cdr(arg))(sc, cadr(arg));
+ car(sc->a3_2) = c_call(cddr(arg))(sc, caddr(arg));
+ car(sc->a3_3) = c_call(cdddr(arg))(sc, cadddr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->a3_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -61656,10 +62056,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = caddr(code);
- car(sc->A1_1) = c_call(cdr(arg))(sc, cadr(arg));
- car(sc->T2_2) = c_call(arg)(sc, sc->A1_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->a1_1) = c_call(cdr(arg))(sc, cadr(arg));
+ car(sc->t2_2) = c_call(arg)(sc, sc->a1_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61671,11 +62071,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = caddr(code);
- car(sc->A2_1) = c_call(cdr(arg))(sc, cadr(arg));
- car(sc->A2_2) = c_call(cddr(arg))(sc, caddr(arg));
- car(sc->T2_2) = c_call(arg)(sc, sc->A2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->a2_1) = c_call(cdr(arg))(sc, cadr(arg));
+ car(sc->a2_2) = c_call(cddr(arg))(sc, caddr(arg));
+ car(sc->t2_2) = c_call(arg)(sc, sc->a2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61688,14 +62088,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer arg, p;
p = caddr(code);
arg = cdr(p);
- car(sc->A3_1) = c_call(arg)(sc, car(arg));
+ car(sc->a3_1) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_2) = c_call(arg)(sc, car(arg));
+ car(sc->a3_2) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_3) = c_call(arg)(sc, car(arg));
- car(sc->T2_2) = c_call(p)(sc, sc->A3_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->a3_3) = c_call(arg)(sc, car(arg));
+ car(sc->t2_2) = c_call(p)(sc, sc->a3_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -61724,7 +62124,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_SAFE_C_ZA:
/* here we can't use ZS order because we sometimes assume left->right arg evaluation (binary-io.scm for example) */
- push_stack(sc, OP_SAFE_C_ZA_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZA_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61736,7 +62136,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* most of the component Z's here are very complex:
* 264600: (+ (* even-amp (oscil (vector-ref evens k) (+ even-freq val))) (* odd-amp...
*/
- push_stack(sc, OP_SAFE_C_ZZ_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZZ_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61754,7 +62154,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!a_is_ok(sc, code)) break;
case HOP_SAFE_C_ZAA:
- push_stack(sc, OP_SAFE_C_ZAA_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZAA_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61791,7 +62191,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!a_is_ok(sc, code)) break;
case HOP_SAFE_C_ZZA:
- push_stack(sc, OP_SAFE_C_ZZA_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZZA_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61800,7 +62200,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!a_is_ok(sc, code)) break;
case HOP_SAFE_C_ZAZ:
- push_stack(sc, OP_SAFE_C_ZAZ_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZAZ_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61818,7 +62218,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_ZZZ:
- push_stack(sc, OP_SAFE_C_ZZZ_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_ZZZ_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -61827,8 +62227,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!a_is_ok_cadr(sc, code)) break;
case HOP_SAFE_C_A:
- car(sc->A1_1) = c_call(cdr(code))(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->A1_1);
+ car(sc->a1_1) = c_call(cdr(code))(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->a1_1);
goto START;
@@ -61836,9 +62236,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!a_is_ok(sc, code)) break;
case HOP_SAFE_C_AA:
- car(sc->A2_1) = c_call(cdr(code))(sc, cadr(code));
- car(sc->A2_2) = c_call(cddr(code))(sc, caddr(code));
- sc->value = c_call(code)(sc, sc->A2_1);
+ car(sc->a2_1) = c_call(cdr(code))(sc, cadr(code));
+ car(sc->a2_2) = c_call(cddr(code))(sc, caddr(code));
+ sc->value = c_call(code)(sc, sc->a2_1);
goto START;
@@ -61849,12 +62249,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = c_call(arg)(sc, car(arg));
+ car(sc->a3_1) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_2) = c_call(arg)(sc, car(arg));
+ car(sc->a3_2) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_3) = c_call(arg)(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_3) = c_call(arg)(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61866,12 +62266,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = find_symbol_checked(sc, car(arg));
+ car(sc->a3_1) = find_symbol_checked(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_2) = find_symbol_checked(sc, car(arg));
+ car(sc->a3_2) = find_symbol_checked(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_3) = c_call(arg)(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_3) = c_call(arg)(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61883,12 +62283,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = find_symbol_checked(sc, car(arg));
+ car(sc->a3_1) = find_symbol_checked(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_2) = c_call(arg)(sc, car(arg));
+ car(sc->a3_2) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_3) = find_symbol_checked(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_3) = find_symbol_checked(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61900,12 +62300,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = car(arg);
+ car(sc->a3_1) = car(arg);
arg = cdr(arg);
- car(sc->A3_2) = find_symbol_checked(sc, car(arg));
+ car(sc->a3_2) = find_symbol_checked(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_3) = c_call(arg)(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_3) = c_call(arg)(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61917,12 +62317,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = find_symbol_checked(sc, car(arg));
+ car(sc->a3_1) = find_symbol_checked(sc, car(arg));
arg = cdr(arg);
- car(sc->A3_2) = car(arg);
+ car(sc->a3_2) = car(arg);
arg = cdr(arg);
- car(sc->A3_3) = c_call(arg)(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_3) = c_call(arg)(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61934,11 +62334,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A3_1) = car(arg);
+ car(sc->a3_1) = car(arg);
arg = cdr(arg);
- car(sc->A3_2) = c_call(arg)(sc, car(arg));
- car(sc->A3_3) = find_symbol_checked(sc, cadr(arg));
- sc->value = c_call(code)(sc, sc->A3_1);
+ car(sc->a3_2) = c_call(arg)(sc, car(arg));
+ car(sc->a3_3) = find_symbol_checked(sc, cadr(arg));
+ sc->value = c_call(code)(sc, sc->a3_1);
goto START;
}
@@ -61950,14 +62350,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cdr(code);
- car(sc->A4_1) = c_call(arg)(sc, car(arg));
+ car(sc->a4_1) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A4_2) = c_call(arg)(sc, car(arg));
+ car(sc->a4_2) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A4_3) = c_call(arg)(sc, car(arg));
+ car(sc->a4_3) = c_call(arg)(sc, car(arg));
arg = cdr(arg);
- car(sc->A4_4) = c_call(arg)(sc, car(arg));
- sc->value = c_call(code)(sc, sc->A4_1);
+ car(sc->a4_4) = c_call(arg)(sc, car(arg));
+ sc->value = c_call(code)(sc, sc->a4_1);
goto START;
}
@@ -61978,7 +62378,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = sc->safe_lists[num_args];
set_list_in_use(sc->args);
}
- else sc->args = make_list(sc, num_args, sc->NIL);
+ else sc->args = make_list(sc, num_args, sc->nil);
for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
car(p) = c_call(args)(sc, car(args));
@@ -62002,10 +62402,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer val1, args;
args = cdr(code);
val1 = find_symbol_checked(sc, car(args));
- car(sc->T3_3) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T3_2) = opt_con1(args);
- car(sc->T3_1) = val1;
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_3) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t3_2) = opt_con1(args);
+ car(sc->t3_1) = val1;
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62020,10 +62420,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val1 = find_symbol_checked(sc, car(args));
- car(sc->T3_3) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T3_2) = opt_con1(args);
- car(sc->T3_1) = val1;
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_3) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t3_2) = opt_con1(args);
+ car(sc->t3_1) = val1;
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62038,10 +62438,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val1 = find_symbol_checked(sc, car(args));
- car(sc->T3_2) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T3_3) = opt_con2(args);
- car(sc->T3_1) = val1;
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_2) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t3_3) = opt_con2(args);
+ car(sc->t3_1) = val1;
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62055,10 +62455,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args;
args = cdr(code);
- car(sc->T3_1) = find_symbol_checked(sc, car(args));
- car(sc->T3_2) = opt_con1(args);
- car(sc->T3_3) = opt_con2(args);
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_1) = find_symbol_checked(sc, car(args));
+ car(sc->t3_2) = opt_con1(args);
+ car(sc->t3_3) = opt_con2(args);
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62071,10 +62471,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args;
args = cdr(code);
- car(sc->T3_2) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T3_1) = car(args);
- car(sc->T3_3) = opt_con2(args);
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_2) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t3_1) = car(args);
+ car(sc->t3_3) = opt_con2(args);
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62088,10 +62488,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val1 = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T3_2) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T3_3) = val1;
- car(sc->T3_1) = car(args);
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_2) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t3_3) = val1;
+ car(sc->t3_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62105,10 +62505,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
val1 = find_symbol_checked(sc, car(args));
val2 = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T3_3) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T3_1) = val1;
- car(sc->T3_2) = val2;
- sc->value = c_call(code)(sc, sc->T3_1);
+ car(sc->t3_3) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t3_1) = val1;
+ car(sc->t3_2) = val2;
+ sc->value = c_call(code)(sc, sc->t3_1);
goto START;
}
@@ -62117,8 +62517,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok_cadr(sc, code)) break;
case HOP_SAFE_C_opCq:
- car(sc->T1_1) = c_call(car(cdr(code)))(sc, cdar(cdr(code))); /* OP_SAFE_C_C can involve any number of ops */
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = c_call(car(cdr(code)))(sc, cdar(cdr(code))); /* OP_SAFE_C_C can involve any number of ops */
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
@@ -62129,9 +62529,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cadr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T1_1) = c_call(args)(sc, sc->T1_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t1_1) = c_call(args)(sc, sc->t1_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62143,10 +62543,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer outer, args;
outer = cadr(code);
args = cadr(outer);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T1_1) = c_call(args)(sc, sc->T1_1);
- car(sc->T1_1) = c_call(outer)(sc, sc->T1_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t1_1) = c_call(args)(sc, sc->t1_1);
+ car(sc->t1_1) = c_call(outer)(sc, sc->t1_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62159,11 +62559,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer outer, args;
outer = cadr(code);
args = caddr(outer);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = c_call(args)(sc, sc->T1_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(outer));
- car(sc->T1_1) = c_call(outer)(sc, sc->T2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_2) = c_call(args)(sc, sc->t1_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(outer));
+ car(sc->t1_1) = c_call(outer)(sc, sc->t2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62172,7 +62572,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_PS:
- push_stack(sc, OP_EVAL_ARGS_P_3, sc->NIL, code); /* gotta wait in this case */
+ push_stack(sc, OP_EVAL_ARGS_P_3, sc->nil, code); /* gotta wait in this case */
sc->code = cadr(code);
goto EVAL;
@@ -62235,7 +62635,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_PP:
- push_stack(sc, OP_SAFE_C_PP_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_C_PP_1, sc->nil, code);
sc->code = cadr(code);
goto EVAL;
@@ -62244,7 +62644,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_SAFE_C_SSP:
- push_stack(sc, OP_EVAL_ARGS_SSP_1, sc->NIL, code);
+ push_stack(sc, OP_EVAL_ARGS_SSP_1, sc->nil, code);
sc->code = cadddr(code);
goto EVAL;
@@ -62257,10 +62657,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val1;
args = cadr(code);
val1 = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(args));
- car(sc->T2_1) = val1;
- car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(args));
+ car(sc->t2_1) = val1;
+ car(sc->t1_1) = c_call(args)(sc, sc->t2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62272,10 +62672,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cadr(code);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = caddr(args);
- car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_2) = caddr(args);
+ car(sc->t1_1) = c_call(args)(sc, sc->t2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62287,10 +62687,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cadr(code);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(args));
- car(sc->T2_1) = cadr(args);
- car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(args));
+ car(sc->t2_1) = cadr(args);
+ car(sc->t1_1) = c_call(args)(sc, sc->t2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62302,10 +62702,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cadr(code);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = cadr(caddr(args));
- car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
- sc->value = c_call(code)(sc, sc->T1_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_2) = cadr(caddr(args));
+ car(sc->t1_1) = c_call(args)(sc, sc->t2_1);
+ sc->value = c_call(code)(sc, sc->t1_1);
goto START;
}
@@ -62318,10 +62718,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, car(args));
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
- car(sc->T2_1) = val;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t1_1);
+ car(sc->t2_1) = val;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62333,9 +62733,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = c_call(cadr(args))(sc, opt_pair1(args)); /* any number of constants here */
- car(sc->T2_1) = val;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = c_call(cadr(args))(sc, opt_pair1(args)); /* any number of constants here */
+ car(sc->t2_1) = val;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62347,10 +62747,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t1_1);
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62362,9 +62762,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_2) = c_call(cadr(args))(sc, opt_pair1(args)); /* any # of args */
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = c_call(cadr(args))(sc, opt_pair1(args)); /* any # of args */
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62376,11 +62776,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T2_1) = opt_con1(args);
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t2_1) = opt_con1(args);
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62393,11 +62793,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T2_1) = val;
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t2_1) = val;
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62409,11 +62809,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(car(args)));
- car(sc->T2_1) = cadr(car(args));
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(car(args)));
+ car(sc->t2_1) = cadr(car(args));
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62426,11 +62826,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(car(args)));
- car(sc->T2_1) = val;
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(car(args)));
+ car(sc->t2_1) = val;
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62444,11 +62844,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val = find_symbol_checked(sc, cadr(car(args)));
val1 = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(car(args)));
- car(sc->T2_1) = val;
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(car(args)));
+ car(sc->t2_1) = val;
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62461,12 +62861,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* code: (> (magnitude (- old new)) 0.001) */
s7_pointer arg;
arg = cadr(cadr(code));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->T2_1);
- car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
- car(sc->T2_2) = caddr(code);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->t2_1);
+ car(sc->t2_1) = c_call(cadr(code))(sc, sc->t1_1);
+ car(sc->t2_2) = caddr(code);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62479,12 +62879,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* code: (> (magnitude (- old new)) s) */
s7_pointer arg;
arg = cadr(cadr(code));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->T2_1);
- car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->t2_1);
+ car(sc->t2_1) = c_call(cadr(code))(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62496,11 +62896,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cadr(cadr(code));
- car(sc->T1_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->T1_1);
- car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
- car(sc->T2_2) = caddr(code);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->t1_1);
+ car(sc->t2_1) = c_call(cadr(code))(sc, sc->t1_1);
+ car(sc->t2_2) = caddr(code);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62512,11 +62912,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer arg;
arg = cadr(cadr(code));
- car(sc->T1_1) = find_symbol_checked(sc, cadr(arg));
- car(sc->T1_1) = c_call(arg)(sc, sc->T1_1);
- car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(arg));
+ car(sc->t1_1) = c_call(arg)(sc, sc->t1_1);
+ car(sc->t2_1) = c_call(cadr(code))(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62536,14 +62936,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = caddr(code); /* (* (- b c) d) */
val1 = cadr(args);
val = find_symbol_checked(sc, cadr(val1)); /* b */
- car(sc->T2_2) = find_symbol_checked(sc, caddr(val1)); /* c */
- car(sc->T2_1) = val;
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(val1)); /* c */
+ car(sc->t2_1) = val;
val = find_symbol_checked(sc, caddr(args)); /* d */
- car(sc->T2_1) = c_call(val1)(sc, sc->T2_1); /* (- b c) */
- car(sc->T2_2) = val;
- car(sc->T2_2) = c_call(args)(sc, sc->T2_1); /* (* ...) */
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code)); /* a */
- sc->value = c_call(code)(sc, sc->T2_1); /* (+ ...) */
+ car(sc->t2_1) = c_call(val1)(sc, sc->t2_1); /* (- b c) */
+ car(sc->t2_2) = val;
+ car(sc->t2_2) = c_call(args)(sc, sc->t2_1); /* (* ...) */
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code)); /* a */
+ sc->value = c_call(code)(sc, sc->t2_1); /* (+ ...) */
goto START;
}
@@ -62558,14 +62958,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = caddr(code); /* (* d (- b c)) */
val1 = caddr(args);
val = find_symbol_checked(sc, cadr(val1)); /* b */
- car(sc->T2_2) = find_symbol_checked(sc, caddr(val1)); /* c */
- car(sc->T2_1) = val;
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(val1)); /* c */
+ car(sc->t2_1) = val;
val = find_symbol_checked(sc, cadr(args)); /* d */
- car(sc->T2_2) = c_call(val1)(sc, sc->T2_1); /* (- b c) */
- car(sc->T2_1) = val;
- car(sc->T2_2) = c_call(args)(sc, sc->T2_1); /* (* ...) */
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code)); /* a */
- sc->value = c_call(code)(sc, sc->T2_1); /* (+ ...) */
+ car(sc->t2_2) = c_call(val1)(sc, sc->t2_1); /* (- b c) */
+ car(sc->t2_1) = val;
+ car(sc->t2_2) = c_call(args)(sc, sc->t2_1); /* (* ...) */
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code)); /* a */
+ sc->value = c_call(code)(sc, sc->t2_1); /* (+ ...) */
goto START;
}
@@ -62582,18 +62982,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
op1 = cadr(args);
op2 = caddr(args);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(op1));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(op1));
- f1 = c_call(op1)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(op1));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(op1));
+ f1 = c_call(op1)(sc, sc->t2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(op2));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(op2));
- car(sc->T2_2) = c_call(op2)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(op2));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(op2));
+ car(sc->t2_2) = c_call(op2)(sc, sc->t2_1);
- car(sc->T2_1) = f1;
- car(sc->T2_2) = c_call(args)(sc, sc->T2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(code));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = f1;
+ car(sc->t2_2) = c_call(args)(sc, sc->t2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62606,11 +63006,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val1;
args = cdr(code);
val1 = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = caddr(car(args));
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_2) = caddr(car(args));
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62622,11 +63022,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = caddr(car(args));
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_2) = caddr(car(args));
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62639,11 +63039,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val1;
args = cdr(code);
val1 = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = find_symbol_checked(sc, caddr(car(args)));
- car(sc->T2_1) = cadr(car(args));
- car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_2) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(car(args)));
+ car(sc->t2_1) = cadr(car(args));
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_2) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62656,11 +63056,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer val1, args;
args = cdr(code);
val1 = find_symbol_checked(sc, car(args));
- car(sc->T2_1) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = opt_con2(args);
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t2_2) = opt_con2(args);
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62672,11 +63072,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = opt_con2(args);
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, opt_sym1(args));
+ car(sc->t2_2) = opt_con2(args);
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62691,11 +63091,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val1 = find_symbol_checked(sc, car(args));
val2 = find_symbol_checked(sc, opt_sym1(args));
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym2(args));
- car(sc->T2_1) = val2;
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym2(args));
+ car(sc->t2_1) = val2;
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62709,11 +63109,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer val1, args;
args = cdr(code);
val1 = find_symbol_checked(sc, car(args)); /* a */
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym2(args)); /* b */
- car(sc->T2_1) = opt_con1(args); /* 1 */
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1); /* (- 1 b) */
- car(sc->T2_1) = val1;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym2(args)); /* b */
+ car(sc->t2_1) = opt_con1(args); /* 1 */
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1); /* (- 1 b) */
+ car(sc->t2_1) = val1;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62725,12 +63125,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(car(args)));
- sc->temp3 = c_call(car(args))(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(car(args)));
+ sc->temp3 = c_call(car(args))(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62742,13 +63142,45 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cadr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(args));
- push_stack(sc, OP_SAFE_C_opSq_P_1, c_call(args)(sc, sc->T1_1), sc->code);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(args));
+ push_stack(sc, OP_SAFE_C_opSq_P_1, c_call(args)(sc, sc->t1_1), sc->code);
sc->code = caddr(code);
goto EVAL;
}
+ case OP_SAFE_C_opSq_Q:
+ if (!c_function_is_ok_cadr(sc, code)) break;
+
+ case HOP_SAFE_C_opSq_Q:
+ {
+ s7_pointer arg1; /* (let-ref (cdr v) 'x) */
+ arg1 = cadr(code);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(arg1));
+ car(sc->t2_1) = c_call(arg1)(sc, sc->t1_1);
+ car(sc->t2_2) = cadr(caddr(code));
+ sc->value = c_call(code)(sc, sc->t2_1);
+ goto START;
+ }
+
+
+ case OP_SAFE_C_opSq_Q_S:
+ if (!c_function_is_ok_cadr(sc, code)) break;
+
+ case HOP_SAFE_C_opSq_Q_S:
+ {
+ s7_pointer arg1, arg3; /* (let-set! (cdr v) 'x y) */
+ arg1 = cadr(code);
+ arg3 = find_symbol_checked(sc, cadddr(code));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(arg1));
+ car(sc->t3_1) = c_call(arg1)(sc, sc->t1_1);
+ car(sc->t3_2) = cadr(caddr(code));
+ car(sc->t3_3) = arg3;
+ sc->value = c_call(code)(sc, sc->t3_1);
+ goto START;
+ }
+
+
case OP_SAFE_C_opCq_S:
if (!c_function_is_ok_cadr(sc, code)) break;
@@ -62757,9 +63189,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
- car(sc->T2_2) = val;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = c_call(car(args))(sc, cdr(car(args)));
+ car(sc->t2_2) = val;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62771,9 +63203,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
- car(sc->T2_2) = cadr(args); /* the second C stands for 1 arg? */
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = c_call(car(args))(sc, cdr(car(args)));
+ car(sc->t2_2) = cadr(args); /* the second C stands for 1 arg? */
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62785,10 +63217,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_1) = c_call(car(args))(sc, sc->T1_1);
- car(sc->T2_2) = cadr(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_1) = c_call(car(args))(sc, sc->t1_1);
+ car(sc->t2_2) = cadr(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62803,11 +63235,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code); /* C_op_S_opCqq */
arg1 = cadr(args); /* op_S_opCqq */
arg2 = caddr(arg1); /* opCq */
- car(sc->T2_2) = c_call(arg2)(sc, cdr(arg2));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg1));
- car(sc->T2_2) = c_call(arg1)(sc, sc->T2_1);
- car(sc->T2_1) = car(args);
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_2) = c_call(arg2)(sc, cdr(arg2));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg1));
+ car(sc->t2_2) = c_call(arg1)(sc, sc->t2_1);
+ car(sc->t2_1) = car(args);
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62819,14 +63251,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(car(args)));
- sc->temp3 = c_call(car(args))(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(car(args)));
+ sc->temp3 = c_call(car(args))(sc, sc->t1_1);
args = cadr(args);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_2) = c_call(args)(sc, sc->T1_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_2) = c_call(args)(sc, sc->t1_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62838,9 +63270,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args;
args = cdr(code);
- car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
- car(sc->T2_2) = c_call(cadr(args))(sc, cdr(cadr(args)));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = c_call(car(args))(sc, cdr(car(args)));
+ car(sc->t2_2) = c_call(cadr(args))(sc, cdr(cadr(args)));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62855,11 +63287,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
args = cdr(code);
val = c_call(car(args))(sc, cdr(car(args)));
args = cdr(args);
- car(sc->T2_1) = find_symbol_checked(sc, cadar(args));
- car(sc->T2_2) = find_symbol_checked(sc, caddar(args));
- car(sc->T2_2) = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_1) = val;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadar(args));
+ car(sc->t2_2) = find_symbol_checked(sc, caddar(args));
+ car(sc->t2_2) = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_1) = val;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62872,15 +63304,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val2;
args = cdr(code);
val2 = find_symbol_checked(sc, cadr(cadr(args)));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = caddr(car(args));
- sc->temp3 = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_1) = val2;
- car(sc->T2_2) = caddr(cadr(args));
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_2) = caddr(car(args));
+ sc->temp3 = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_1) = val2;
+ car(sc->t2_2) = caddr(cadr(args));
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62895,15 +63327,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
val3 = find_symbol_checked(sc, caddr(car(args)));
val4 = find_symbol_checked(sc, caddr(cadr(args)));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = val3;
- sc->temp3 = c_call(car(args))(sc, sc->T2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(cadr(args)));
- car(sc->T2_2) = val4;
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = sc->temp3;
- sc->temp3 = sc->NIL;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_2) = val3;
+ sc->temp3 = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(cadr(args)));
+ car(sc->t2_2) = val4;
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = sc->temp3;
+ sc->temp3 = sc->nil;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62916,13 +63348,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val3;
args = cdr(code);
val3 = find_symbol_checked(sc, caddr(car(args)));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(car(args)));
- car(sc->T2_2) = val3;
- val3 = c_call(car(args))(sc, sc->T2_1);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(cadr(args)));
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
- car(sc->T2_1) = val3;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(car(args)));
+ car(sc->t2_2) = val3;
+ val3 = c_call(car(args))(sc, sc->t2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(cadr(args)));
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t1_1);
+ car(sc->t2_1) = val3;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62934,13 +63366,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer args, val3;
args = cdr(code);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(car(args)));
- val3 = c_call(car(args))(sc, sc->T1_1);
- car(sc->T2_2) = find_symbol_checked(sc, caddr(cadr(args)));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(cadr(args)));
- car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
- car(sc->T2_1) = val3;
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(car(args)));
+ val3 = c_call(car(args))(sc, sc->t1_1);
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(cadr(args)));
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(cadr(args)));
+ car(sc->t2_2) = c_call(cadr(args))(sc, sc->t2_1);
+ car(sc->t2_1) = val3;
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62954,11 +63386,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
arg1 = cadr(code);
arg2 = caddr(code);
val3 = find_symbol_checked(sc, caddr(arg1));
- car(sc->T2_1) = find_symbol_checked(sc, cadr(arg1));
- car(sc->T2_2) = val3;
- car(sc->T2_1) = c_call(arg1)(sc, sc->T2_1);
- car(sc->T2_2) = c_call(arg2)(sc, cdr(arg2));
- sc->value = c_call(code)(sc, sc->T2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(arg1));
+ car(sc->t2_2) = val3;
+ car(sc->t2_1) = c_call(arg1)(sc, sc->t2_1);
+ car(sc->t2_2) = c_call(arg2)(sc, cdr(arg2));
+ sc->value = c_call(code)(sc, sc->t2_1);
goto START;
}
@@ -62994,7 +63426,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_C_Z:
- push_stack(sc, OP_C_P_1, sc->NIL, code);
+ push_stack(sc, OP_C_P_1, sc->nil, code);
sc->code = cadr(code);
goto OPT_EVAL;
@@ -63003,7 +63435,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!c_function_is_ok(sc, code)) break;
case HOP_C_P:
- push_stack(sc, OP_C_P_1, sc->NIL, code);
+ push_stack(sc, OP_C_P_1, sc->nil, code);
sc->code = cadr(code);
goto EVAL;
@@ -63056,8 +63488,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, val;
args = cdr(code);
val = find_symbol_checked(sc, car(args));
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym1(args));
- sc->args = list_2(sc, val, c_call(cadr(args))(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym1(args));
+ sc->args = list_2(sc, val, c_call(cadr(args))(sc, sc->t1_1));
sc->value = c_call(code)(sc, sc->args);
goto START;
}
@@ -63073,7 +63505,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->temp3 = find_symbol_checked(sc, car(args));
val = c_call(cadr(args))(sc, opt_pair1(args));
sc->args = list_2(sc, sc->temp3, val);
- sc->temp3 = sc->NIL;
+ sc->temp3 = sc->nil;
sc->value = c_call(code)(sc, sc->args);
goto START;
}
@@ -63099,7 +63531,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_C_ALL_X:
{ /* (set-cdr! lst ()) */
s7_pointer args, p;
- sc->args = make_list(sc, integer(arglist_length(code)), sc->NIL);
+ sc->args = make_list(sc, integer(arglist_length(code)), sc->nil);
for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
car(p) = c_call(args)(sc, car(args));
sc->value = c_call(code)(sc, sc->args);
@@ -63166,8 +63598,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_C_CATCH_ALL:
{
- /* (catch #t (lambda () ...) (lambda args #f)
- */
+ /* (catch #t (lambda () ...) (lambda args #f) */
s7_pointer p;
new_frame(sc, sc->envir, sc->envir);
/* catch_all needs 3 pieces of info: the goto/op locs and the result
@@ -63214,7 +63645,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_THUNK_E:
- if (find_symbol_unchecked(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
+ if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
case HOP_SAFE_THUNK_E:
sc->envir = closure_let(opt_lambda(code));
@@ -63223,7 +63654,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_THUNK_P:
- if (find_symbol_unchecked(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
+ if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
case HOP_SAFE_THUNK_P:
sc->envir = closure_let(opt_lambda(code));
@@ -63247,7 +63678,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_CLOSURE_S_P:
- if (find_symbol_unchecked(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
+ if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
case HOP_SAFE_CLOSURE_S_P:
sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
@@ -63299,7 +63730,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if ((symbol_id(car(code)) != 0) || (opt_any1(code) != slot_value(global_slot(car(code))))) break;
case HOP_SAFE_GLOSURE_P:
- push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->NIL, code);
+ push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->nil, code);
sc->code = cadr(code);
goto EVAL;
@@ -63417,7 +63848,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = sc->safe_lists[num_args];
set_list_in_use(sc->args);
}
- else sc->args = make_list(sc, num_args, sc->NIL);
+ else sc->args = make_list(sc, num_args, sc->nil);
for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
car(p) = c_call(args)(sc, car(args));
@@ -63561,7 +63992,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_CLOSURE_STAR_S0:
- if (find_symbol_unchecked(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
+ if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
case HOP_SAFE_CLOSURE_STAR_S0:
/* here we know we have (let-set! arg1 'name arg2) (with-env arg1 ...) as the safe closure body.
@@ -63572,7 +64003,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer e;
e = find_symbol_checked(sc, cadr(code)); /* S of S0 above */
if (e == sc->rootlet)
- sc->envir = sc->NIL;
+ sc->envir = sc->nil;
else
{
if (!is_let(e))
@@ -63615,7 +64046,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (!is_goto(opt_goto(code))) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
case HOP_GOTO:
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->code = opt_goto(code);
call_with_exit(sc);
goto START;
@@ -63698,8 +64129,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_GLOSURE_A:
- if ((symbol_id(car(code)) != 0) ||
- (opt_lambda(code) != slot_value(global_slot(car(code)))))
+ if ((symbol_id(car(code)) != 0) || (opt_lambda_unchecked(code) != slot_value(global_slot(car(code)))))
{set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
if (!indirect_c_function_is_ok(sc, cadr(code))) break;
@@ -63713,10 +64143,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_GLOSURE_P:
- if ((symbol_id(car(code)) != 0) || (opt_lambda(code) != slot_value(global_slot(car(code))))) break;
+ if ((symbol_id(car(code)) != 0) || (opt_lambda_unchecked(code) != slot_value(global_slot(car(code))))) break;
case HOP_GLOSURE_P:
- push_stack(sc, OP_CLOSURE_P_1, sc->NIL, code);
+ push_stack(sc, OP_CLOSURE_P_1, sc->nil, code);
sc->code = cadr(code);
goto EVAL;
@@ -63802,7 +64232,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
for (p = closure_args(func), args = cdr(code); is_pair(p); p = cdr(p), args = cdr(args))
add_slot(e, car(p), find_symbol_checked(sc, car(args)));
sc->envir = e;
- sc->z = sc->NIL;
+ sc->z = sc->nil;
sc->code = closure_body(func);
goto BEGIN1;
}
@@ -63825,7 +64255,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
add_slot_checked(e, car(p), val); /* can't use add_slot here -- all_x_c_* hit trigger? */
}
sc->envir = e;
- sc->z = sc->NIL;
+ sc->z = sc->nil;
sc->code = closure_body(func);
goto BEGIN1;
}
@@ -63846,7 +64276,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer args, p, func, new_args;
func = opt_lambda(code);
- sc->args = make_list(sc, closure_star_arity_to_int(sc, func), sc->NIL);
+ sc->args = make_list(sc, closure_star_arity_to_int(sc, func), sc->nil);
new_args = sc->args;
for (p = closure_args(func), args = cdr(code); is_pair(args); p = cdr(p), args = cdr(args), new_args = cdr(new_args))
@@ -63883,13 +64313,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
val2 = find_symbol_checked(sc, val2);
if (is_null(args))
{
- car(sc->T2_1) = val1;
- car(sc->T2_2) = val2;
+ car(sc->t2_1) = val1;
+ car(sc->t2_2) = val2;
code = opt_lambda(sc->code);
args = closure_args(code);
new_frame_with_two_slots(sc, closure_let(code), sc->envir,
- (is_pair(car(args))) ? caar(args) : car(args), car(sc->T2_1),
- (is_pair(cadr(args))) ? caadr(args) : cadr(args), car(sc->T2_2));
+ (is_pair(car(args))) ? caar(args) : car(args), car(sc->t2_1),
+ (is_pair(cadr(args))) ? caadr(args) : cadr(args), car(sc->t2_2));
sc->code = closure_body(code);
}
else
@@ -63907,7 +64337,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_CLOSURE_STAR:
/* (let () (define* (hi (a 1)) (list a)) (define (ho) (hi)) (ho)) */
- sc->args = sc->NIL;
+ sc->args = sc->nil;
fill_closure_star(sc, closure_args(opt_lambda(code)));
unsafe_closure_star(sc);
goto BEGIN1;
@@ -64072,7 +64502,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sym = cadr(cadr(code));
if (is_symbol(sym))
sc->value = let_ref_1(sc, s, sym);
- else return(wrong_type_argument_with_type(sc, sc->LET_REF, 2, sym, A_SYMBOL)); /* (e '(1)) */
+ else return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sym, a_symbol_string)); /* (e '(1)) */
goto START;
}
@@ -64087,7 +64517,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sym = c_call(cdr(code))(sc, cadr(code));
if (is_symbol(sym))
sc->value = let_ref_1(sc, s, sym);
- else return(wrong_type_argument_with_type(sc, sc->LET_REF, 2, sym, A_SYMBOL)); /* (e expr) where expr->#f */
+ else return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sym, a_symbol_string)); /* (e expr) where expr->#f */
goto START;
}
@@ -64134,7 +64564,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer c;
c = find_symbol_checked(sc, car(code));
if (!is_c_object(c)) break;
- sc->value = (*(c_object_ref(c)))(sc, c, sc->NIL);
+ sc->value = (*(c_object_ref(c)))(sc, c, sc->nil);
goto START;
}
@@ -64157,8 +64587,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer c;
c = find_symbol_checked(sc, car(code));
if (!is_c_object(c)) break;
- car(sc->T1_1) = c_call(cdr(code))(sc, cadr(code));
- sc->value = (*(c_object_ref(c)))(sc, c, sc->T1_1);
+ car(sc->t1_1) = c_call(cdr(code))(sc, cadr(code));
+ sc->value = (*(c_object_ref(c)))(sc, c, sc->t1_1);
goto START;
}
@@ -64168,8 +64598,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer c;
c = find_symbol_checked(sc, car(code));
if (!is_c_object(c)) break;
- car(sc->T1_1) = find_symbol_checked(sc, cadr(code));
- sc->value = (*(c_object_ref(c)))(sc, c, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(code));
+ sc->value = (*(c_object_ref(c)))(sc, c, sc->t1_1);
goto START;
}
@@ -64182,6 +64612,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* there is a problem with this -- if the caller still insists on goto OPT_EVAL, for example,
* we get here over and over. (let ((x (list (car y))))...) where list is redefined away.
*/
+#if DEBUGGING
+ if (is_h_optimized(sc->code))
+ fprintf(stderr, "%s[%d]: clearing %s in %s\n", __func__, __LINE__, opt_names[optimize_op(sc->code)], DISPLAY(sc->code));
+#endif
clear_all_optimizations(sc, code);
/* and fall into the normal evaluator */
}
@@ -64193,12 +64627,16 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (is_pair(code))
{
- sc->cur_code = code;
+
+#if WITH_PROFILE
+ profile(sc, code);
+#endif
+ set_current_code(sc, code);
carc = car(code);
if (typesflag(carc) == SYNTACTIC_TYPE)
{
- set_type(code, SYNTACTIC_PAIR);
+ set_syntactic_pair(code); /* leave other bits (T_LINE_NUMBER) intact */
car(code) = syntax_symbol(slot_value(initial_slot(carc))); /* clear possible optimization confusion */
sc->op = (opcode_t)symbol_syntax_op(car(code));
pair_set_syntax_op(code, sc->op);
@@ -64225,13 +64663,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
*/
if (sc->stack_end >= sc->stack_resize_trigger)
check_for_cyclic_code(sc, code);
- push_stack(sc, OP_EVAL_ARGS, sc->NIL, cdr(code));
+ push_stack(sc, OP_EVAL_ARGS, sc->nil, cdr(code));
if (typesflag(car(carc)) == SYNTACTIC_TYPE)
/* was checking for is_syntactic here but that can be confused by successive optimizer passes:
* (define (hi) (((lambda () list)) 1 2 3)) etc
*/
{
- if ((car(carc) == sc->QUOTE) && /* ('and #f) */
+ if ((car(carc) == sc->quote_symbol) && /* ('and #f) */
((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */
(is_syntactic(cadr(carc)))))
return(apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)));
@@ -64240,7 +64678,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto START_WITHOUT_POP_STACK;
}
- push_stack(sc, OP_EVAL_ARGS, sc->NIL, cdr(carc));
+ push_stack(sc, OP_EVAL_ARGS, sc->nil, cdr(carc));
sc->code = car(carc);
goto EVAL;
}
@@ -64306,7 +64744,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (sc->op_stack_now >= sc->op_stack_end)
resize_op_stack(sc);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
goto EVAL_ARGS;
/* moving eval_args up here (to avoid this goto) was slightly slower, probably by chance. */
@@ -64346,9 +64784,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* from HOP_SAFE_C_SP||CP|QP, handled like P_1 case above
* primarily involves generators: (outa i (nrcos gen)) etc
*/
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
@@ -64360,10 +64798,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_EVAL_ARGS_SSP_1:
/* from HOP_SAFE_C_SSP */
- car(sc->T3_3) = sc->value;
- car(sc->T3_1) = find_symbol_checked(sc, cadr(sc->code));
- car(sc->T3_2) = find_symbol_checked(sc, caddr(sc->code));
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_3) = sc->value;
+ car(sc->t3_1) = find_symbol_checked(sc, cadr(sc->code));
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(sc->code));
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
@@ -64374,12 +64812,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_EVAL_ARGS_P_3:
- car(sc->T2_2) = find_symbol_checked(sc, caddr(sc->code));
+ car(sc->t2_2) = find_symbol_checked(sc, caddr(sc->code));
/* we have to wait because we say the evaluation order is always left to right
* and the first arg's evaluation might change the value of the second arg.
*/
- car(sc->T2_1) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_EVAL_ARGS_P_3_MV:
@@ -64393,9 +64831,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_EVAL_ARGS_P_4:
- car(sc->T2_1) = sc->value;
- car(sc->T2_2) = sc->args;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->value;
+ car(sc->t2_2) = sc->args;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_EVAL_ARGS_P_4_MV: /* same as P_2_MV) */
@@ -64405,16 +64843,16 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_ZC_1:
- car(sc->T2_1) = sc->value;
- car(sc->T2_2) = sc->args;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->value;
+ car(sc->t2_2) = sc->args;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_SAFE_C_SZ_1:
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
@@ -64422,18 +64860,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* S_opSZq actually, in (nominal second, only actual) SZ, S=args, Z=value,
* SZ from the SP combiner for SZ
*/
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- car(sc->T2_2) = c_call(caddr(sc->code))(sc, sc->T2_1);
- car(sc->T2_1) = find_symbol_checked(sc, cadr(sc->code));
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ car(sc->t2_2) = c_call(caddr(sc->code))(sc, sc->t2_1);
+ car(sc->t2_1) = find_symbol_checked(sc, cadr(sc->code));
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_SAFE_C_ZA_1:
- car(sc->T2_2) = c_call(cddr(sc->code))(sc, caddr(sc->code));
- car(sc->T2_1) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_2) = c_call(cddr(sc->code))(sc, caddr(sc->code));
+ car(sc->t2_1) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
@@ -64444,41 +64882,41 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_ZZ_2:
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_SAFE_C_ZAA_1:
- car(sc->A3_1) = sc->value;
- car(sc->A3_2) = c_call(cddr(sc->code))(sc, caddr(sc->code));
- car(sc->A3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
- sc->value = c_call(sc->code)(sc, sc->A3_1);
+ car(sc->a3_1) = sc->value;
+ car(sc->a3_2) = c_call(cddr(sc->code))(sc, caddr(sc->code));
+ car(sc->a3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
+ sc->value = c_call(sc->code)(sc, sc->a3_1);
break;
case OP_SAFE_C_AZA_1:
- car(sc->T3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
- car(sc->T3_2) = sc->value;
- car(sc->T3_1) = sc->args;
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
+ car(sc->t3_2) = sc->value;
+ car(sc->t3_1) = sc->args;
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
case OP_SAFE_C_SSZ_1:
- car(sc->T3_1) = sc->args;
- car(sc->T3_3) = sc->value;
- car(sc->T3_2) = find_symbol_checked(sc, caddr(sc->code));
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_1) = sc->args;
+ car(sc->t3_3) = sc->value;
+ car(sc->t3_2) = find_symbol_checked(sc, caddr(sc->code));
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
case OP_SAFE_C_AAZ_1:
- car(sc->T3_1) = pop_op_stack(sc);
- car(sc->T3_2) = sc->args;
- car(sc->T3_3) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_1) = pop_op_stack(sc);
+ car(sc->t3_2) = sc->args;
+ car(sc->t3_3) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
@@ -64490,10 +64928,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_ZZA_2:
- car(sc->A3_1) = pop_op_stack(sc);
- car(sc->A3_2) = sc->value;
- car(sc->A3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
- sc->value = c_call(sc->code)(sc, sc->A3_1);
+ car(sc->a3_1) = pop_op_stack(sc);
+ car(sc->a3_2) = sc->value;
+ car(sc->a3_3) = c_call(cdddr(sc->code))(sc, cadddr(sc->code));
+ sc->value = c_call(sc->code)(sc, sc->a3_1);
break;
@@ -64505,10 +64943,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_ZAZ_2:
- car(sc->T3_1) = pop_op_stack(sc);
- car(sc->T3_2) = sc->args;
- car(sc->T3_3) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_1) = pop_op_stack(sc);
+ car(sc->t3_2) = sc->args;
+ car(sc->t3_3) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
@@ -64520,10 +64958,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_AZZ_2:
- car(sc->T3_1) = sc->args;
- car(sc->T3_2) = pop_op_stack(sc);
- car(sc->T3_3) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_1) = sc->args;
+ car(sc->t3_2) = pop_op_stack(sc);
+ car(sc->t3_3) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
@@ -64541,18 +64979,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_ZZZ_3:
- car(sc->T3_1) = sc->args;
- car(sc->T3_2) = pop_op_stack(sc);
- car(sc->T3_3) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T3_1);
+ car(sc->t3_1) = sc->args;
+ car(sc->t3_2) = pop_op_stack(sc);
+ car(sc->t3_3) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t3_1);
break;
case OP_SAFE_C_opSq_P_1:
/* this is the no-multiple-values case */
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_SAFE_C_opSq_P_MV:
@@ -64628,7 +65066,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
EVAL_ARGS:
/* first time, value = op, args = nil, code is args */
- if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->NIL (improper list as args) */
+ if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */
{
s7_pointer car_code;
@@ -64643,7 +65081,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* all 3 of these push_stacks can result in stack overflow, see above 64065 */
if (is_null(cdr(sc->code)))
- push_stack(sc, OP_EVAL_ARGS2, sc->args, sc->NIL);
+ push_stack(sc, OP_EVAL_ARGS2, sc->args, sc->nil);
else
{
if (!is_pair(cdr(sc->code))) /* (= 0 '(1 . 2) . 3) */
@@ -64786,14 +65224,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case T_MACRO:
if (is_expansion(sc->code))
- push_stack(sc, OP_EXPANSION, sc->NIL, sc->NIL);
- else push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EXPANSION, sc->nil, sc->nil);
+ else push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
new_frame(sc, closure_let(sc->code), sc->envir);
apply_lambda(sc);
goto BEGIN1;
case T_BACRO:
- push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
new_frame(sc, sc->envir, sc->envir); /* like let* -- we'll be adding macro args, so might as well sequester things here */
apply_lambda(sc);
goto BEGIN1;
@@ -64803,16 +65241,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
new_frame(sc, closure_let(sc->code), sc->envir);
apply_lambda(sc);
goto BEGIN1;
-
case T_MACRO_STAR:
- push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
new_frame(sc, closure_let(sc->code), sc->envir);
if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
goto BEGIN1;
case T_BACRO_STAR:
- push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->NIL);
+ push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
new_frame(sc, sc->envir, sc->envir);
if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
goto BEGIN1;
@@ -64862,7 +65299,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
{
- push_stack(sc, OP_MACROEXPAND_1, sc->NIL, sc->code);
+ push_stack(sc, OP_MACROEXPAND_1, sc->nil, sc->code);
sc->code = caar(sc->code);
goto EVAL;
}
@@ -64938,7 +65375,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->value = find_symbol_checked(sc, car(sc->code));
goto START;
}
- push_stack(sc, OP_DEFINE_CONSTANT1, sc->NIL, sc->code);
+ push_stack(sc, OP_DEFINE_CONSTANT1, sc->nil, sc->code);
case OP_DEFINE_STAR:
case OP_DEFINE:
@@ -64966,6 +65403,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
* (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23"
* (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (hi) (hi)) is an error from the first call (caught elsewhere)
* (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (catch #t hi (lambda a a)) (hi)) is an error from the second call
+ * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0))
*/
push_stack_no_args(sc, OP_SET_PAIR_P_1, sc->code);
sc->code = cadr(sc->code);
@@ -64983,11 +65421,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer obj, val;
obj = find_symbol_checked(sc, caar(sc->code));
val = c_call(cdr(sc->code))(sc, cadr(sc->code)); /* this call can step on sc->Tx_x */
- car(sc->T2_1) = cadar(sc->code); /* might be a constant: (set! (mus-sound-srate "oboe.snd") 12345) */
- if (is_symbol(car(sc->T2_1)))
- car(sc->T2_1) = find_symbol_checked(sc, cadar(sc->code));
- car(sc->T2_2) = val;
- sc->value = c_function_call(c_function_setter(obj))(sc, sc->T2_1);
+ car(sc->t2_1) = cadar(sc->code); /* might be a constant: (set! (mus-sound-srate "oboe.snd") 12345) */
+ if (is_symbol(car(sc->t2_1)))
+ car(sc->t2_1) = find_symbol_checked(sc, cadar(sc->code));
+ car(sc->t2_2) = val;
+ sc->value = c_function_call(c_function_setter(obj))(sc, sc->t2_1);
}
break;
@@ -65118,30 +65556,30 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* here we know the symbols do not have accessors, at least at optimization time */
SET_CASE(OP_SET_SYMBOL_opSq,
do { \
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym2(sc->code)); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->T1_1)); \
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym2(sc->code)); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t1_1)); \
} while (0))
SET_CASE(OP_SET_SYMBOL_opSSq,
do { \
- car(sc->T2_1) = find_symbol_checked(sc, car(opt_pair2(sc->code))); \
- car(sc->T2_2) = find_symbol_checked(sc, cadr(opt_pair2(sc->code))); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->T2_1)); \
+ car(sc->t2_1) = find_symbol_checked(sc, car(opt_pair2(sc->code))); \
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(opt_pair2(sc->code))); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
} while (0))
SET_CASE(OP_SET_SYMBOL_opSSSq,
do { \
- car(sc->T3_1) = find_symbol_checked(sc, car(opt_pair2(sc->code))); \
- car(sc->T3_2) = find_symbol_checked(sc, opt_sym1(opt_pair2(sc->code))); \
- car(sc->T3_3) = find_symbol_checked(sc, opt_sym2(opt_pair2(sc->code))); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->T3_1)); \
+ car(sc->t3_1) = find_symbol_checked(sc, car(opt_pair2(sc->code))); \
+ car(sc->t3_2) = find_symbol_checked(sc, opt_sym1(opt_pair2(sc->code))); \
+ car(sc->t3_3) = find_symbol_checked(sc, opt_sym2(opt_pair2(sc->code))); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t3_1)); \
} while (0))
SET_CASE(OP_INCREMENT_SS, /* ([set!] x (+ x i)) */
do { \
- car(sc->T2_1) = slot_value(lx); \
- car(sc->T2_2) = find_symbol_checked(sc, cadr(opt_pair2(sc->code))); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->T2_1)); \
+ car(sc->t2_1) = slot_value(lx); \
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(opt_pair2(sc->code))); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
} while (0))
SET_CASE(OP_INCREMENT_SSS, /* ([set!] x (+ x y z)) -- nearly always involves reals */
@@ -65153,8 +65591,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) \
slot_set_value(lx, make_real(sc, real(x1) + real(x2) + real(x3))); \
else { \
- car(sc->T3_1) = x1; car(sc->T3_2) = x2; car(sc->T3_3) = x3; \
- slot_set_value(lx, global_add(sc, sc->T3_1)); \
+ car(sc->t3_1) = x1; car(sc->t3_2) = x2; car(sc->t3_3) = x3; \
+ slot_set_value(lx, global_add(sc, sc->t3_1)); \
} \
} while (0))
@@ -65162,19 +65600,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
do { \
s7_pointer arg; \
arg = opt_pair2(sc->code); \
- car(sc->T2_2) = c_call(arg)(sc, car(arg)); \
- car(sc->T2_1) = slot_value(lx); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->T2_1)); \
+ car(sc->t2_2) = c_call(arg)(sc, car(arg)); \
+ car(sc->t2_1) = slot_value(lx); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
} while (0))
SET_CASE(OP_INCREMENT_SAA, /* (set! sum (+ sum (expt k i) (expt (- k) i))) -- oops */
do { \
s7_pointer arg; \
arg = opt_pair2(sc->code); /* cddr(value) */ \
- car(sc->A3_3) = c_call(cdr(arg))(sc, cadr(arg)); \
- car(sc->A3_2) = c_call(arg)(sc, car(arg)); \
- car(sc->A3_1) = slot_value(lx); \
- slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->A3_1)); \
+ car(sc->a3_3) = c_call(cdr(arg))(sc, cadr(arg)); \
+ car(sc->a3_2) = c_call(arg)(sc, car(arg)); \
+ car(sc->a3_1) = slot_value(lx); \
+ slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->a3_1)); \
} while (0))
@@ -65215,9 +65653,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
case OP_INCREMENT_SZ_1:
- car(sc->T2_1) = slot_value(sc->args);
- car(sc->T2_2) = sc->value;
- sc->value = c_call(cadr(sc->code))(sc, sc->T2_1);
+ car(sc->t2_1) = slot_value(sc->args);
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(cadr(sc->code))(sc, sc->t2_1);
slot_set_value(sc->args, sc->value);
break;
@@ -65244,12 +65682,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* in all of these cases, we might need to GC protect the temporary lists */
if (is_multiple_value(sc->value))
- sc->code = cons(sc, sc->SET, s7_append(sc, multiple_value(sc->value), s7_append(sc, sc->args, sc->code))); /* drop into OP_SET */
+ sc->code = cons(sc, sc->set_symbol, s7_append(sc, multiple_value(sc->value), s7_append(sc, sc->args, sc->code))); /* drop into OP_SET */
else
{
- if (sc->args != sc->NIL)
+ if (sc->args != sc->nil)
{
- push_op_stack(sc, sc->List_Set);
+ 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 = car(sc->args);
}
@@ -65264,9 +65702,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1) 0) 32) L)
* bad case when args is nil: (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1)) 32) L)
*/
- if (sc->args != sc->NIL)
+ if (sc->args != sc->nil)
{
- push_op_stack(sc, sc->Vector_Set);
+ 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 = car(sc->args);
}
@@ -65326,11 +65764,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
if (is_c_function(func))
{
- car(sc->T2_1) = sc->code;
- car(sc->T2_2) = sc->value;
- sc->value = c_function_call(func)(sc, sc->T2_1);
- if (sc->value == sc->ERROR) /* backwards compatibility... */
- return(s7_error(sc, sc->ERROR, set_elist_3(sc, make_string_wrapper(sc, "can't set ~S to ~S"), car(sc->T2_1), car(sc->T2_2))));
+ car(sc->t2_1) = sc->code;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_function_call(func)(sc, sc->t2_1);
+ if (sc->value == sc->error_symbol) /* backwards compatibility... (but still used I think in g_features_set) */
+ return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't set ~S to ~S"), car(sc->t2_1), car(sc->t2_2))));
}
else
{
@@ -65353,10 +65791,26 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
case OP_SET_WITH_ACCESSOR:
- if (sc->value == sc->ERROR) /* backwards compatibility... */
- return(s7_error(sc, sc->ERROR, set_elist_2(sc, make_string_wrapper(sc, "can't set ~S"), sc->args)));
+ if (sc->value == sc->error_symbol) /* backwards compatibility... */
+ return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't set ~S"), sc->args)));
slot_set_value(sc->code, sc->value);
break;
+
+ case OP_SET_WITH_LET_1:
+ /* here sc->value is the new value for the settee, args has the (as yet unevaluated) let and settee-expression.
+ */
+ /* fprintf(stderr, "with_let_1: %s %s %s\n", DISPLAY(sc->value), DISPLAY(sc->code), DISPLAY(sc->args)); */
+ sc->code = car(sc->args);
+ sc->args = list_2(sc, cadr(sc->args), sc->value);
+ push_stack(sc, OP_SET_WITH_LET_2, sc->args, sc->code);
+ goto EVAL;
+
+ case OP_SET_WITH_LET_2:
+ /* fprintf(stderr, "with_let_2: %s %s %s\n", DISPLAY(sc->value), DISPLAY(sc->code), DISPLAY(sc->args)); */
+ sc->code = cons(sc, sc->set_symbol, sc->args);
+ activate_let(sc);
+ goto EVAL;
+
/* -------------------------------- IF -------------------------------- */
@@ -65371,7 +65825,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_IF1:
if (is_true(sc, sc->value))
sc->code = car(sc->code);
- else sc->code = cadr(sc->code); /* even pre-optimization, (if #f #f) ==> #<unspecified> because car(sc->NIL) = sc->UNSPECIFIED */
+ else sc->code = cadr(sc->code); /* even pre-optimization, (if #f #f) ==> #<unspecified> because car(sc->nil) = sc->unspecified */
if (is_pair(sc->code))
goto EVAL;
if (is_symbol(sc->code))
@@ -65381,7 +65835,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
#define IF_CASE(Op, Code) \
- case Op ## _P: Code {sc->code = cadr(sc->code); goto EVAL;} else {sc->value = sc->UNSPECIFIED; goto START;} \
+ case Op ## _P: Code {sc->code = cadr(sc->code); goto EVAL;} else {sc->value = sc->unspecified; goto START;} \
case Op ## _P_P: Code {sc->code = cadr(sc->code); goto EVAL;} else {sc->code = caddr(sc->code); goto EVAL;}
IF_CASE(OP_IF_S, if (is_true(sc, find_symbol_checked(sc, car(sc->code)))))
@@ -65396,32 +65850,32 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
IF_CASE(OP_IF_IS_SYMBOL, if (is_symbol(find_symbol_checked(sc, opt_sym2(sc->code)))))
- IF_CASE(OP_IF_CS, car(sc->T1_1) = find_symbol_checked(sc, opt_sym2(sc->code)); \
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T1_1))))
+ IF_CASE(OP_IF_CS, car(sc->t1_1) = find_symbol_checked(sc, opt_sym2(sc->code)); \
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t1_1))))
- IF_CASE(OP_IF_CSQ, car(sc->T2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
- car(sc->T2_2) = opt_con2(sc->code); \
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1))))
+ IF_CASE(OP_IF_CSQ, car(sc->t2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
+ car(sc->t2_2) = opt_con2(sc->code); \
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
- IF_CASE(OP_IF_CSS, car(sc->T2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym2(sc->code));
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1))))
+ IF_CASE(OP_IF_CSS, car(sc->t2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym2(sc->code));
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
- IF_CASE(OP_IF_CSC, car(sc->T2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
- car(sc->T2_2) = opt_con2(sc->code); \
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1))))
+ IF_CASE(OP_IF_CSC, car(sc->t2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
+ car(sc->t2_2) = opt_con2(sc->code); \
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
- IF_CASE(OP_IF_S_opCq, car(sc->T2_2) = c_call(opt_pair2(sc->code))(sc, cdr(opt_pair2(sc->code))); \
- car(sc->T2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1))))
+ IF_CASE(OP_IF_S_opCq, car(sc->t2_2) = c_call(opt_pair2(sc->code))(sc, cdr(opt_pair2(sc->code))); \
+ car(sc->t2_1) = find_symbol_checked(sc, opt_sym3(sc->code)); \
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
IF_CASE(OP_IF_opSSq, {s7_pointer args; s7_pointer val1; \
args = opt_pair2(sc->code); \
val1 = find_symbol_checked(sc, cadr(args)); \
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym3(sc->code)); \
- car(sc->T2_1) = val1; \
- car(sc->T1_1) = c_call(args)(sc, sc->T2_1);} \
- if (is_true(sc, c_call(car(sc->code))(sc, sc->T1_1))))
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym3(sc->code)); \
+ car(sc->t2_1) = val1; \
+ car(sc->t1_1) = c_call(args)(sc, sc->t2_1);} \
+ if (is_true(sc, c_call(car(sc->code))(sc, sc->t1_1))))
IF_CASE(OP_IF_AND2, if ((is_true(sc, c_call(opt_pair2(sc->code))(sc, car(opt_pair2(sc->code))))) && \
(is_true(sc, c_call(opt_and_2_test(sc->code))(sc, car(opt_and_2_test(sc->code)))))))
@@ -65481,7 +65935,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_IF_PP:
if (is_true(sc, sc->value))
goto EVAL;
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
break;
@@ -65503,7 +65957,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
goto EVAL;
}
- sc->value = sc->NIL; /* since it's actually cond -- perhaps push as sc->args above */
+ sc->value = sc->nil; /* since it's actually cond -- perhaps push as sc->args above */
break;
@@ -65517,7 +65971,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_WHEN1:
if (is_true(sc, sc->value)) goto BEGIN1;
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
break;
case OP_WHEN_S:
@@ -65526,7 +65980,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdr(sc->code);
goto BEGIN1;
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
break;
@@ -65540,7 +65994,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_UNLESS1:
if (is_false(sc, sc->value)) goto BEGIN1;
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
break;
case OP_UNLESS_S:
@@ -65549,18 +66003,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdr(sc->code);
goto BEGIN1;
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
break;
case OP_SAFE_C_P_1:
- car(sc->T1_1) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T1_1);
+ car(sc->t1_1) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t1_1);
break;
case OP_SAFE_C_PP_1:
- /* unless multiple values from last call (first arg), sc->args == sc->NIL because we pushed that.
+ /* unless multiple values from last call (first arg), sc->args == sc->nil because we pushed that.
* we get here only from OP_SAFE_C_PP.
*
* currently splice_in_values changes the operator so if we get here, sc->value is the result of the first arg
@@ -65583,9 +66037,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_PP_2:
/* we get here only if neither arg returned multiple values, so sc->args is the first value, and sc->value the second */
- car(sc->T2_1) = sc->args;
- car(sc->T2_2) = sc->value;
- sc->value = c_call(sc->code)(sc, sc->T2_1);
+ car(sc->t2_1) = sc->args;
+ car(sc->t2_2) = sc->value;
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
break;
case OP_SAFE_C_PP_3:
@@ -65675,7 +66129,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_NAMED_LET_NO_VARS:
new_frame(sc, sc->envir, sc->envir);
- sc->args = make_closure(sc, sc->NIL, cddr(sc->code), T_CLOSURE); /* sc->args is a temp here */
+ sc->args = make_closure(sc, sc->nil, cddr(sc->code), T_CLOSURE); /* sc->args is a temp here */
make_slot_1(sc, sc->envir, car(sc->code), sc->args);
sc->code = cddr(sc->code);
goto BEGIN1;
@@ -65699,8 +66153,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer binding;
binding = caar(sc->code);
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym2(sc->code));
- sc->value = c_call(cadr(binding))(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym2(sc->code));
+ sc->value = c_call(cadr(binding))(sc, sc->t1_1);
new_frame_with_slot(sc, sc->envir, sc->envir, car(binding), sc->value);
push_stack_no_args(sc, OP_BEGIN1, cddr(sc->code));
sc->code = cadr(sc->code);
@@ -65712,8 +66166,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer binding;
binding = caar(sc->code);
- car(sc->T1_1) = find_symbol_checked(sc, opt_sym2(sc->code));
- sc->value = c_call(cadr(binding))(sc, sc->T1_1);
+ car(sc->t1_1) = find_symbol_checked(sc, opt_sym2(sc->code));
+ sc->value = c_call(cadr(binding))(sc, sc->t1_1);
new_frame_with_slot(sc, sc->envir, sc->envir, car(binding), sc->value);
sc->code = cadr(sc->code);
goto EVAL;
@@ -65732,9 +66186,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer largs, in_val;
largs = opt_pair2(sc->code); /* cadr(caar(sc->code)); */
in_val = find_symbol_checked(sc, cadr(largs));
- car(sc->T2_2) = find_symbol_checked(sc, opt_sym3(sc->code)); /* caddr(largs)); */
- car(sc->T2_1) = in_val;
- sc->value = c_call(largs)(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, opt_sym3(sc->code)); /* caddr(largs)); */
+ car(sc->t2_1) = in_val;
+ sc->value = c_call(largs)(sc, sc->t2_1);
new_frame_with_slot(sc, sc->envir, sc->envir, caaar(sc->code), sc->value);
sc->code = cdr(sc->code);
goto BEGIN1;
@@ -65812,8 +66266,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
s7_pointer cp;
cp = cadar(p);
- car(sc->T1_1) = find_symbol_checked(sc, cadr(cp));
- add_slot(frame, caar(p), c_call(cp)(sc, sc->T1_1));
+ car(sc->t1_1) = find_symbol_checked(sc, cadr(cp));
+ add_slot(frame, caar(p), c_call(cp)(sc, sc->t1_1));
}
sc->let_number++;
sc->envir = frame;
@@ -65846,7 +66300,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_NAMED_LET:
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->value = sc->code;
sc->code = cadr(sc->code);
goto LET1;
@@ -65858,7 +66312,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer x;
new_cell(sc, x, T_PAIR);
car(x) = sc->code;
- cdr(x) = sc->NIL;
+ cdr(x) = sc->nil;
sc->args = x;
sc->code = car(sc->code);
goto LET1A;
@@ -65871,7 +66325,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
bool named_let;
check_let(sc);
- sc->args = sc->NIL;
+ sc->args = sc->nil;
sc->value = sc->code;
named_let = is_symbol(car(sc->code));
@@ -65882,13 +66336,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
new_frame(sc, sc->envir, sc->envir);
if (named_let)
{
- sc->x = make_closure(sc, sc->NIL, cddr(sc->code), T_CLOSURE); /* args = () in new closure, see NAMED_LET_NO_VARS above */
+ sc->x = make_closure(sc, sc->nil, cddr(sc->code), T_CLOSURE); /* args = () in new closure, see NAMED_LET_NO_VARS above */
/* if this is a safe closure, we can build its env in advance and name it (a thunk in this case) */
set_function_env(closure_let(sc->x));
funclet_set_function(closure_let(sc->x), car(sc->code));
make_slot_1(sc, sc->envir, car(sc->code), sc->x);
sc->code = cddr(sc->code);
- sc->x = sc->NIL;
+ sc->x = sc->nil;
}
else sc->code = cdr(sc->code);
goto BEGIN1;
@@ -65948,23 +66402,23 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
let_name = car(sc->code);
sc->envir = new_frame_in_env(sc, sc->envir);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (x = cadr(sc->code); is_pair(x); x = cdr(x))
sc->w = cons(sc, caar(x), sc->w);
sc->x = make_closure(sc, sc->w = safe_reverse_in_place(sc, sc->w), cddr(sc->code), T_CLOSURE);
- sc->w = sc->NIL;
+ sc->w = sc->nil;
if (is_safe_closure(sc->x))
{
s7_pointer arg, new_env;
new_env = new_frame_in_env(sc, sc->envir);
closure_set_let(sc->x, new_env);
for (arg = closure_args(sc->x); is_pair(arg); arg = cdr(arg))
- make_slot_1(sc, new_env, car(arg), sc->NIL);
+ make_slot_1(sc, new_env, car(arg), sc->nil);
let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
}
make_slot_1(sc, sc->envir, let_name, sc->x);
- sc->x = sc->NIL;
+ sc->x = sc->nil;
sc->envir = new_frame_in_env(sc, sc->envir);
for (x = cadr(sc->code); is_not_null(y); x = cdr(x))
@@ -65973,7 +66427,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* reuse the value cells as the new frame slots */
sym = caar(x);
- if (sym == let_name) let_name = sc->NIL;
+ if (sym == let_name) let_name = sc->nil;
val = car(y);
args = cdr(y);
@@ -66017,7 +66471,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdr(sc->code);
}
}
- sc->y = sc->NIL;
+ sc->y = sc->nil;
goto BEGIN1;
}
@@ -66064,7 +66518,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
sc->envir = new_frame_in_env(sc, sc->envir);
sc->code = cdr(sc->value);
- make_slot_1(sc, sc->envir, cx, make_closure(sc, sc->NIL, sc->code, T_CLOSURE_STAR));
+ make_slot_1(sc, sc->envir, cx, make_closure(sc, sc->nil, sc->code, T_CLOSURE_STAR));
goto BEGIN1;
}
}
@@ -66158,8 +66612,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
for (x = car(sc->code); is_not_null(x); x = cdr(x))
{
s7_pointer slot;
- slot = make_slot_1(sc, sc->envir, caar(x), sc->UNDEFINED);
- slot_pending_value(slot) = sc->UNDEFINED;
+ slot = make_slot_1(sc, sc->envir, caar(x), sc->undefined);
+ slot_pending_value(slot) = sc->undefined;
slot_expression(slot) = cadar(x);
set_checked_slot(slot);
}
@@ -66209,12 +66663,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
for (x = car(sc->code); is_not_null(x); x = cdr(x))
{
s7_pointer slot;
- slot = make_slot_1(sc, sc->envir, caar(x), sc->UNDEFINED);
+ slot = make_slot_1(sc, sc->envir, caar(x), sc->undefined);
slot_expression(slot) = cadar(x);
}
/* these are reversed, and for letrec*, they need to be in order, so... (reverse_in_place on the slot list) */
p = let_slots(sc->envir);
- x = sc->NIL;
+ x = sc->nil;
while (is_slot(p))
{
q = next_slot(p);
@@ -66257,7 +66711,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
check_cond(sc);
case OP_COND_UNCHECKED:
- push_stack(sc, OP_COND1, sc->NIL, sc->code);
+ push_stack(sc, OP_COND1, sc->nil, sc->code);
sc->code = caar(sc->code);
goto EVAL;
@@ -66276,12 +66730,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (is_pair(sc->code))
{
- if ((car(sc->code) == sc->FEED_TO) &&
- (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
+ if ((car(sc->code) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
{
if (is_multiple_value(sc->value)) /* (cond ((values 1 2) => +)) */
sc->code = cons(sc, cadr(sc->code), multiple_value(sc->value));
- else sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->QUOTE, sc->value));
+ else sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->quote_symbol, sc->value));
goto EVAL;
}
goto BEGIN1;
@@ -66291,7 +66745,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdr(sc->code);
if (is_null(sc->code))
{
- sc->value = sc->NIL;
+ sc->value = sc->unspecified; /* changed 31-Dec-15 */
+ /* r7rs sez the value if no else clause is unspecified, and this choice makes cond consistent with if and case,
+ * and rewrite choices between the three are simpler if they are consistent.
+ */
goto START;
}
@@ -66324,7 +66781,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdr(sc->code);
if (is_null(sc->code))
{
- sc->value = sc->NIL;
+ sc->value = sc->unspecified;
goto START;
}
if (is_pair(caar(sc->code)))
@@ -66350,8 +66807,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
ap = caar(p);
if (is_pair(ap))
{
- car(sc->T1_1) = val;
- sc->value = c_call(ap)(sc, sc->T1_1);
+ car(sc->t1_1) = val;
+ sc->value = c_call(ap)(sc, sc->t1_1);
}
else sc->value = sc->T;
if (is_true(sc, sc->value))
@@ -66366,7 +66823,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto BEGIN1;
}
}
- sc->value = sc->NIL;
+ sc->value = sc->unspecified;
}
break;
@@ -66381,7 +66838,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->value = c_call(car(p))(sc, caar(p));
if (!is_true(sc, sc->value))
{
- sc->value = sc->NIL;
+ sc->value = sc->unspecified;
goto START;
}
}
@@ -66413,9 +66870,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto BEGIN1;
}
}
- sc->value = sc->NIL;
+ sc->value = sc->unspecified;
}
break;
+
/* -------------------------------- AND -------------------------------- */
case OP_AND:
@@ -66604,7 +67062,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
* (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19
* (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3
*/
- push_stack(sc, OP_EVAL_MACRO_MV, sc->NIL, cdr(sc->value));
+ push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value));
sc->code = car(sc->value);
}
else sc->code = sc->value;
@@ -66626,7 +67084,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* after the expander has finished, if a list was returned, we need to add some annotations.
* if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*).
*/
- if (sc->value == sc->NO_VALUE)
+ if (sc->value == sc->no_value)
sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT;
else
{
@@ -66637,8 +67095,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_DEFINE_MACRO_WITH_ACCESSOR:
- if (sc->value == sc->ERROR) /* backwards compatibility... */
- return(s7_error(sc, sc->ERROR, set_elist_3(sc, make_string_wrapper(sc, "can't define-macro ~S to ~S"), car(sc->args), cadr(sc->args))));
+ if (sc->value == sc->error_symbol) /* backwards compatibility... */
+ return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't define-macro ~S to ~S"), car(sc->args), cadr(sc->args))));
sc->code = sc->value;
if ((!is_pair(sc->code)) ||
(!is_pair(car(sc->code))) ||
@@ -66662,7 +67120,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
(slot_has_accessor(x)))
{
sc->value = bind_accessed_symbol(sc, OP_DEFINE_MACRO_WITH_ACCESSOR, caar(sc->code), sc->code);
- if (sc->value == sc->NO_VALUE)
+ if (sc->value == sc->no_value)
goto APPLY;
sc->code = sc->value;
}
@@ -66748,17 +67206,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = cdar(x);
/* check for => */
- if ((car(sc->code) == sc->FEED_TO) &&
- (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
+ if ((car(sc->code) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
{
- sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->QUOTE, sc->value));
+ sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->quote_symbol, sc->value));
goto EVAL;
}
goto BEGIN1;
}
/* no match found */
- sc->value = sc->UNSPECIFIED; /* this was sc->NIL but the spec says case value is unspecified if no clauses match */
+ sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */
}
break;
@@ -66784,7 +67242,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
y = cdr(y);
} while (is_pair(y));
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66805,7 +67263,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
y = cdr(y);
} while (is_pair(y));
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66826,7 +67284,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
y = cdr(y);
} while (is_pair(y));
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66836,9 +67294,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer x, y, selector, args;
args = cdar(sc->code);
x = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = x;
- selector = c_call(car(sc->code))(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = x;
+ selector = c_call(car(sc->code))(sc, sc->t2_1);
for (x = cdr(sc->code); is_pair(x); x = cdr(x))
{
y = opt_key(x);
@@ -66851,7 +67309,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
y = cdr(y);
} while (is_pair(y));
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66860,16 +67318,16 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer x, selector, args;
args = cdar(sc->code);
x = find_symbol_checked(sc, car(args));
- car(sc->T2_2) = find_symbol_checked(sc, cadr(args));
- car(sc->T2_1) = x;
- selector = c_call(car(sc->code))(sc, sc->T2_1);
+ car(sc->t2_2) = find_symbol_checked(sc, cadr(args));
+ car(sc->t2_1) = x;
+ selector = c_call(car(sc->code))(sc, sc->t2_1);
for (x = cdr(sc->code); is_pair(x); x = cdr(x))
if (opt_key(x) == selector)
{
sc->code = cdar(x);
goto BEGIN1;
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66884,7 +67342,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->code = opt_clause(x); /* cadar(x); */
goto EVAL;
}
- sc->value = sc->UNSPECIFIED;
+ sc->value = sc->unspecified;
}
break;
@@ -66918,7 +67376,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
*/
stack_reset(sc);
sc->op = OP_ERROR_QUIT;
- if (sc->longjmp_ok) longjmp(sc->goto_start, 1);
+ if (sc->longjmp_ok) longjmp(sc->goto_start, ERROR_QUIT_JUMP);
return(sc->value); /* not executed I hope */
@@ -66930,7 +67388,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_GET_OUTPUT_STRING_1: /* from call-with-output-string and with-output-to-string -- return the port string directly */
if ((!is_output_port(sc->code)) ||
(port_is_closed(sc->code)))
- simple_wrong_type_argument_with_type(sc, sc->WITH_OUTPUT_TO_STRING, sc->code, make_string_wrapper(sc, "an open string output port"));
+ simple_wrong_type_argument_with_type(sc, sc->with_output_to_string_symbol, sc->code, make_string_wrapper(sc, "an open string output port"));
if (port_position(sc->code) >= port_data_size(sc->code))
resize_port_data(sc->code, port_position(sc->code) + 1); /* need room for the trailing #\null */
@@ -66966,7 +67424,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_pointer e;
e = find_symbol_checked(sc, car(sc->code));
if (e == sc->rootlet)
- sc->envir = sc->NIL;
+ sc->envir = sc->nil;
else
{
s7_pointer p;
@@ -67018,35 +67476,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
else
{
- push_stack(sc, OP_WITH_LET1, sc->NIL, cdr(sc->code));
+ push_stack(sc, OP_WITH_LET1, sc->nil, cdr(sc->code));
sc->code = sc->value; /* eval env arg */
goto EVAL;
}
case OP_WITH_LET1:
- {
- s7_pointer e;
- e = sc->value;
- if (!is_let(e)) /* (with-let . "hi") */
- eval_type_error(sc, "with-let takes an environment argument: ~A", e);
- if (e == sc->rootlet)
- sc->envir = sc->NIL; /* (with-let (rootlet) ...) */
- else
- {
- s7_pointer p;
- set_with_let_let(e);
- let_id(e) = ++sc->let_number;
- sc->envir = e;
- for (p = let_slots(e); is_slot(p); p = next_slot(p))
- {
- s7_pointer sym;
- sym = slot_symbol(p);
- if (symbol_id(sym) != sc->let_number)
- symbol_set_local(sym, sc->let_number, p);
- }
- }
- goto BEGIN1;
- }
+ activate_let(sc);
+ goto BEGIN1;
case OP_WITH_BAFFLE:
@@ -67056,16 +67493,16 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if ((!is_null(sc->code)) &&
(is_overlaid(sc->code)) &&
(has_opt_back(sc->code)))
- pair_set_syntax_symbol(sc->code, sc->WITH_BAFFLE_UNCHECKED);
+ pair_set_syntax_symbol(sc->code, sc->with_baffle_unchecked_symbol);
case OP_WITH_BAFFLE_UNCHECKED:
if (is_null(sc->code))
{
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto START;
}
new_frame(sc, sc->envir, sc->envir);
- make_slot_1(sc, sc->envir, sc->BAFFLE, make_baffle(sc));
+ make_slot_1(sc, sc->envir, sc->baffle_symbol, make_baffle(sc));
goto BEGIN1;
@@ -67078,7 +67515,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = sc->stack_end[2];
READ_LIST:
- case OP_READ_LIST: /* sc->args is sc->NIL at first */
+ case OP_READ_LIST: /* sc->args is sc->nil at first */
{
s7_pointer x;
new_cell(sc, x, T_PAIR);
@@ -67103,7 +67540,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
switch (c)
{
case '(': sc->tok = TOKEN_LEFT_PAREN; break;
- case ')': sc->value = sc->NIL; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */
+ case ')': sc->value = sc->nil; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */
case '.': sc->tok = read_dot(sc, pt); break;
case '\'': sc->tok = TOKEN_QUOTE; break;
case ';': sc->tok = port_read_semicolon(pt)(sc, pt); break;
@@ -67122,12 +67559,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->value = port_read_name(pt)(sc, pt);
new_cell(sc, x, T_PAIR);
car(x) = sc->value;
- cdr(x) = sc->NIL;
+ cdr(x) = sc->nil;
sc->args = x;
- /*
- if (port_position(pt) >= port_data_size(pt))
- return(missing_close_paren_error(sc));
- */
c = port_read_white_space(pt)(sc, pt);
goto READ_C;
}
@@ -67141,19 +67574,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->value = port_read_name(pt)(sc, pt);
new_cell(sc, x, T_PAIR);
car(x) = sc->value;
- cdr(x) = sc->NIL;
+ cdr(x) = sc->nil;
sc->args = x;
- /*
- if (port_position(pt) >= port_data_size(pt))
- return(missing_close_paren_error(sc));
- */
c = port_read_white_space(pt)(sc, pt);
goto READ_C;
}
if (sc->tok == TOKEN_RIGHT_PAREN)
{
- sc->value = sc->NIL;
+ sc->value = sc->nil;
goto READ_LIST;
}
@@ -67167,7 +67596,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
return(missing_close_paren_error(sc));
push_stack_no_code(sc, OP_READ_LIST, sc->args);
- push_stack_no_code(sc, OP_READ_LIST, sc->NIL);
+ push_stack_no_code(sc, OP_READ_LIST, sc->nil);
check_stack_size(sc);
sc->value = read_expression(sc);
if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
@@ -67224,10 +67653,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
default:
sc->strbuf[0] = c;
sc->value = port_read_name(pt)(sc, pt);
- /*
- if (port_position(pt) >= port_data_size(pt))
- return(missing_close_paren_error(sc));
- */
goto READ_LIST;
}
}
@@ -67259,17 +67684,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case TOKEN_ATOM:
sc->value = port_read_name(sc->input_port)(sc, sc->input_port);
- /*
- if (port_position(sc->input_port) >= port_data_size(sc->input_port))
- return(missing_close_paren_error(sc));
- */
goto READ_LIST;
case TOKEN_SHARP_CONST:
sc->value = port_read_sharp(sc->input_port)(sc, sc->input_port);
if (is_null(sc->value))
return(read_error(sc, "undefined # expression"));
- if (sc->value == sc->NO_VALUE)
+ if (sc->value == sc->no_value)
{
/* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*))
* (+ 1 #;(* 2 3) 4)
@@ -67331,8 +67752,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_READ_QUOTE:
- /* can't check for sc->value = sc->NIL here because we want ''() to be different from '() */
- sc->value = list_2(sc, sc->QUOTE, sc->value);
+ /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */
+ sc->value = list_2(sc, sc->quote_symbol, sc->value);
set_opt_back(sc->value);
set_overlay(cdr(sc->value));
if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
@@ -67369,17 +67790,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
break;
-#if WITH_QUASIQUOTE_VECTOR
- case OP_READ_QUASIQUOTE_VECTOR:
- read_quasiquote_vector_ex(sc);
- goto EVAL;
-#endif
-
case OP_READ_UNQUOTE:
- /* here if sc->value is a constant, the unquote is pointless (what about ,pi?) */
+ /* here if sc->value is a constant, the unquote is pointless (should we complain?) */
if ((is_pair(sc->value)) ||
(is_symbol(sc->value)))
- sc->value = list_2(sc, sc->UNQUOTE, sc->value);
+ sc->value = list_2(sc, sc->unquote_symbol, sc->value);
if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
break;
@@ -67388,19 +67803,24 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (is_symbol(sc->value))
{
s7_pointer lst;
- lst = list_2(sc, sc->QQ_Apply_Values, sc->value);
+ lst = list_2(sc, sc->qq_apply_values_function, sc->value);
set_unsafe_optimize_op(lst, HOP_C_S);
- set_c_function(lst, sc->QQ_Apply_Values);
- sc->value = list_2(sc, sc->UNQUOTE, lst);
+ set_c_function(lst, sc->qq_apply_values_function);
+ sc->value = list_2(sc, sc->unquote_symbol, lst);
}
- else sc->value = list_2(sc, sc->UNQUOTE, list_2(sc, sc->QQ_Apply_Values, sc->value));
+ else sc->value = list_2(sc, sc->unquote_symbol, list_2(sc, sc->qq_apply_values_function, sc->value));
if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
break;
default:
- fprintf(stderr, "unknown operator: %d in %s\n", (int)(sc->op), DISPLAY(sc->cur_code));
+ fprintf(stderr, "unknown operator: " INT_FORMAT " in %s\n", sc->op, DISPLAY(current_code(sc)));
#if DEBUGGING
+ fprintf(stderr, "stack size: %u\n", sc->stack_size);
+ if (sc->stack_end < sc->stack_start)
+ fprintf(stderr, "%sstack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
+ if (sc->stack_end >= sc->stack_start + sc->stack_size)
+ fprintf(stderr, "%sstack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
abort();
#endif
return(sc->F);
@@ -67431,10 +67851,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* needed in s7_gmp_init and s7_init, initialized in s7_init before we get to gmp */
-static s7_pointer pl_bt, pl_p, pl_bc, pcl_bc, pcl_bs, pl_bn, pl_sf, pcl_bt, pcl_i, pcl_t, pcl_r, pcl_n, pcl_s, pcl_v, pcl_f, pcl_c;
-#if (!WITH_PURE_S7)
-static s7_pointer pl_tp;
-#endif
+static s7_pointer pl_bt, pl_p, pl_bc, pcl_bc, pcl_bs, pl_bn, pl_sf, pcl_bt, pcl_i, pcl_t, pcl_r, pcl_n, pcl_s, pcl_v, pcl_f, pcl_c, pl_tl;
+
@@ -68463,7 +68881,7 @@ static s7_pointer promote_number_1(s7_scheme *sc, int type, s7_pointer x, bool c
}
return(s7_number_to_big_complex(sc, x));
}
- return(sc->NIL);
+ return(sc->nil);
}
@@ -68511,7 +68929,7 @@ void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
* and the vector itself is GC protected (we can be called within make-vector).
*/
gc_loc = s7_gc_protect(sc, vec);
- vector_fill(sc, vec, sc->NIL);
+ vector_fill(sc, vec, sc->nil);
switch (type(obj))
{
@@ -68529,10 +68947,10 @@ void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
static s7_pointer big_bignum(s7_scheme *sc, s7_pointer args)
{
#define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'"
- #define Q_bignum s7_make_signature(sc, 3, sc->IS_BIGNUM, sc->IS_NUMBER, sc->IS_INTEGER)
+ #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, sc->is_number_symbol, sc->is_integer_symbol)
s7_pointer p;
- p = g_string_to_number_1(sc, args, sc->BIGNUM);
+ p = g_string_to_number_1(sc, args, sc->bignum_symbol);
if (is_false(sc, p)) /* (bignum "1/3.0") */
s7_error(sc, make_symbol(sc, "bignum-error"),
set_elist_2(sc, make_string_wrapper(sc, "bignum argument does not represent a number: ~S"), car(args)));
@@ -68582,25 +69000,25 @@ static int result_type_via_method(s7_scheme *sc, int result_type, s7_pointer p)
s7_pointer f;
if (!has_methods(p)) return(-1);
- f = find_method(sc, find_let(sc, p), sc->IS_INTEGER);
- if ((f != sc->UNDEFINED) &&
- (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL)))))
+ f = find_method(sc, find_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);
- if ((f != sc->UNDEFINED) &&
- (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL)))))
+ f = find_method(sc, find_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);
- if ((f != sc->UNDEFINED) &&
- (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL)))))
+ f = find_method(sc, find_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);
- if ((f != sc->UNDEFINED) &&
- (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL)))))
+ f = find_method(sc, find_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));
return(-1);
@@ -68630,7 +69048,7 @@ static s7_pointer big_add(s7_scheme *sc, s7_pointer args)
if (result_type < T_BIG_INTEGER)
return(g_add(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->ADD, args);
+ check_method(sc, car(args), sc->add_symbol, args);
result = copy_and_promote_number(sc, result_type, car(args));
@@ -68638,7 +69056,7 @@ static s7_pointer big_add(s7_scheme *sc, s7_pointer args)
{
s7_pointer arg;
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->ADD, cons(sc, result, x));
+ check_method(sc, car(x), sc->add_symbol, cons(sc, result, x));
arg = promote_number(sc, result_type, car(x));
@@ -68715,7 +69133,7 @@ static s7_pointer big_subtract(s7_scheme *sc, s7_pointer args)
s7_pointer x, result;
if (!s7_is_number(car(args)))
- method_or_bust_with_type(sc, car(args), sc->SUBTRACT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, car(args), sc->subtract_symbol, args, a_number_string, 1);
if (is_null(cdr(args)))
return(big_negate(sc, args));
@@ -68733,7 +69151,7 @@ static s7_pointer big_subtract(s7_scheme *sc, s7_pointer args)
return(g_subtract(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->SUBTRACT, args);
+ check_method(sc, car(args), sc->subtract_symbol, args);
result = copy_and_promote_number(sc, result_type, car(args));
@@ -68741,7 +69159,7 @@ static s7_pointer big_subtract(s7_scheme *sc, s7_pointer args)
{
s7_pointer arg;
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->SUBTRACT, cons(sc, result, x));
+ check_method(sc, car(x), sc->subtract_symbol, cons(sc, result, x));
arg = promote_number(sc, result_type, car(x));
@@ -68787,7 +69205,7 @@ static s7_pointer big_multiply(s7_scheme *sc, s7_pointer args)
return(g_multiply(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->MULTIPLY, args);
+ check_method(sc, car(args), sc->multiply_symbol, args);
result = copy_and_promote_number(sc, result_type, car(args));
@@ -68795,7 +69213,7 @@ static s7_pointer big_multiply(s7_scheme *sc, s7_pointer args)
{
s7_pointer arg;
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->MULTIPLY, cons(sc, result, x));
+ check_method(sc, car(x), sc->multiply_symbol, cons(sc, result, x));
arg = promote_number(sc, result_type, car(x));
switch (result_type)
@@ -68823,7 +69241,7 @@ static s7_pointer big_invert(s7_scheme *sc, s7_pointer args)
p = car(args);
if (s7_is_zero(p))
- return(division_by_zero_error(sc, sc->DIVIDE, p));
+ return(division_by_zero_error(sc, sc->divide_symbol, p));
switch (type(p))
{
@@ -68942,7 +69360,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
s7_pointer x, divisor, result;
if (!s7_is_number(car(args)))
- method_or_bust_with_type(sc, car(args), sc->DIVIDE, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, car(args), sc->divide_symbol, args, a_number_string, 1);
if (is_null(cdr(args)))
return(big_invert(sc, args));
@@ -68960,17 +69378,17 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
if ((x != args) &&
(s7_is_zero(p)))
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
}
if (result_type < T_BIG_INTEGER)
return(g_divide(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->DIVIDE, args);
+ check_method(sc, car(args), sc->divide_symbol, args);
if (!s7_is_number(cadr(args)))
- check_method(sc, cadr(args), sc->DIVIDE, args);
+ check_method(sc, cadr(args), sc->divide_symbol, args);
divisor = copy_and_promote_number(sc, result_type, cadr(args));
@@ -68980,7 +69398,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
if (!s7_is_number(car(x)))
{
s7_pointer func;
- if ((has_methods(car(x))) && ((func = find_method(sc, find_let(sc, car(x)), sc->MULTIPLY)) != sc->UNDEFINED))
+ if ((has_methods(car(x))) && ((func = find_method(sc, find_let(sc, car(x)), sc->multiply_symbol)) != sc->undefined))
{
divisor = s7_apply_function(sc, func, cons(sc, divisor, x));
break;
@@ -68998,7 +69416,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
}
if (s7_is_zero(divisor))
- return(division_by_zero_error(sc, sc->DIVIDE, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, args));
/* it's possible for the divisor to be the wrong type here (if complex multiply -> real for example */
divisor = promote_number_1(sc, result_type, divisor, false);
@@ -69041,7 +69459,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
static s7_pointer big_abs(s7_scheme *sc, s7_pointer args)
{
#define H_abs "(abs x) returns the absolute value of the real number x"
- #define Q_abs s7_make_signature(sc, 2, sc->IS_REAL, sc->IS_REAL)
+ #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
s7_pointer p, x;
@@ -69087,7 +69505,7 @@ static s7_pointer big_abs(s7_scheme *sc, s7_pointer args)
return(x);
default:
- method_or_bust(sc, p, sc->ABS, args, T_REAL, 0);
+ method_or_bust(sc, p, sc->abs_symbol, args, T_REAL, 0);
}
}
@@ -69095,13 +69513,13 @@ static s7_pointer big_abs(s7_scheme *sc, s7_pointer args)
static s7_pointer big_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, sc->IS_NUMBER)
+ #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer p;
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->MAGNITUDE, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->magnitude_symbol, args, a_number_string, 0);
if (is_t_big_complex(p))
{
@@ -69122,7 +69540,7 @@ static s7_pointer big_magnitude(s7_scheme *sc, s7_pointer args)
static s7_pointer big_angle(s7_scheme *sc, s7_pointer args)
{
#define H_angle "(angle z) returns the angle of z"
- #define Q_angle s7_make_signature(sc, 2, sc->IS_REAL, sc->IS_NUMBER)
+ #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer p;
@@ -69180,7 +69598,7 @@ static s7_pointer big_angle(s7_scheme *sc, s7_pointer args)
}
default:
- method_or_bust_with_type(sc, p, sc->ANGLE, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->angle_symbol, args, a_number_string, 0);
}
}
@@ -69188,7 +69606,7 @@ static s7_pointer big_angle(s7_scheme *sc, s7_pointer args)
static s7_pointer c_big_complex(s7_scheme *sc, s7_pointer args)
{
#define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
- #define Q_complex s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_REAL, sc->IS_REAL)
+ #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
s7_pointer p0, p1, p;
mpfr_t rl, im;
@@ -69196,11 +69614,11 @@ static s7_pointer c_big_complex(s7_scheme *sc, s7_pointer args)
p0 = car(args);
if (!s7_is_real(p0))
- method_or_bust(sc, p0, sc->COMPLEX, args, T_REAL, 1);
+ method_or_bust(sc, p0, sc->complex_symbol, args, T_REAL, 1);
p1 = cadr(args);
if (!s7_is_real(p1))
- method_or_bust(sc, p1, sc->COMPLEX, args, T_REAL, 2);
+ method_or_bust(sc, p1, sc->complex_symbol, args, T_REAL, 2);
if ((!is_big_number(p1)) && (real_to_double(sc, p1, "complex") == 0.0)) /* imag-part is not bignum and is 0.0 */
return(p0);
@@ -69232,7 +69650,7 @@ static s7_pointer c_big_complex(s7_scheme *sc, s7_pointer args)
static s7_pointer big_make_polar(s7_scheme *sc, s7_pointer args)
{
#define H_make_polar "(make-polar mag ang) returns a complex number with magnitude mag and angle ang"
- #define Q_make_polar s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_REAL, sc->IS_REAL)
+ #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
s7_pointer p0, p1, p;
mpfr_t ang, mag, rl, im;
@@ -69240,11 +69658,11 @@ static s7_pointer big_make_polar(s7_scheme *sc, s7_pointer args)
p0 = car(args);
if (!s7_is_real(p0))
- method_or_bust(sc, p0, sc->MAKE_POLAR, args, T_REAL, 1);
+ method_or_bust(sc, p0, sc->make_polar_symbol, args, T_REAL, 1);
p1 = cadr(args);
if (!s7_is_real(p1))
- method_or_bust(sc, p1, sc->MAKE_POLAR, args, T_REAL, 2);
+ method_or_bust(sc, p1, sc->make_polar_symbol, args, T_REAL, 2);
mpfr_init_set(ang, big_real(promote_number(sc, T_BIG_REAL, p1)), GMP_RNDN);
y = mpfr_get_d(ang, GMP_RNDN);
@@ -69313,13 +69731,13 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args)
p0 = car(args);
if (!s7_is_number(p0))
- method_or_bust_with_type(sc, p0, sc->LOG, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, p0, sc->log_symbol, args, a_number_string, 1);
if (is_not_null(cdr(args)))
{
p1 = cadr(args);
if (!s7_is_number(p1))
- method_or_bust_with_type(sc, p1, sc->LOG, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, p1, sc->log_symbol, args, a_number_string, 2);
}
if ((s7_is_real(p0)) &&
@@ -69346,7 +69764,7 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args)
if (is_NaN(y))
return(real_NaN);
if (y == 0.0)
- return(out_of_range(sc, sc->LOG, small_int(2), p1, make_string_wrapper(sc, "argument can't be 0.0")));
+ return(out_of_range(sc, sc->log_symbol, small_int(2), p1, make_string_wrapper(sc, "argument can't be 0.0")));
}
if (x == 0.0)
return(s7_make_complex(sc, -INFINITY, M_PI));
@@ -69437,7 +69855,7 @@ static s7_pointer big_sqrt(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->SQRT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->sqrt_symbol, args, a_number_string, 0);
p = to_big(sc, p);
/* if big integer, try to return int if perfect square */
@@ -69558,7 +69976,7 @@ static s7_pointer big_trig(s7_scheme *sc, s7_pointer args,
/* I think here we should always promote to bignum (otherwise, for example, (exp 800) -> inf)
*/
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sym, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sym, args, a_number_string, 0);
if (s7_is_real(p))
{
mpfr_t n;
@@ -69627,7 +70045,7 @@ static s7_pointer big_sin(s7_scheme *sc, s7_pointer args)
#define H_sin "(sin z) returns sin(z)"
#define Q_sin pcl_n
- return(big_trig(sc, args, mpfr_sin, mpc_sin, TRIG_NO_CHECK, sc->SIN));
+ return(big_trig(sc, args, mpfr_sin, mpc_sin, TRIG_NO_CHECK, sc->sin_symbol));
}
@@ -69636,13 +70054,13 @@ static s7_pointer big_cos(s7_scheme *sc, s7_pointer args)
#define H_cos "(cos z) returns cos(z)"
#define Q_cos pcl_n
- return(big_trig(sc, args, mpfr_cos, mpc_cos, TRIG_NO_CHECK, sc->COS));
+ return(big_trig(sc, args, mpfr_cos, mpc_cos, TRIG_NO_CHECK, sc->cos_symbol));
}
s7_pointer s7_cos(s7_scheme *sc, s7_pointer x)
{
- return(big_cos(sc, cons(sc, x, sc->NIL)));
+ return(big_cos(sc, cons(sc, x, sc->nil)));
}
@@ -69651,7 +70069,7 @@ static s7_pointer big_tan(s7_scheme *sc, s7_pointer args)
#define H_tan "(tan z) returns tan(z)"
#define Q_tan pcl_n
- return(big_trig(sc, args, mpfr_tan, mpc_tan, TRIG_TAN_CHECK, sc->TAN));
+ return(big_trig(sc, args, mpfr_tan, mpc_tan, TRIG_TAN_CHECK, sc->tan_symbol));
}
@@ -69661,7 +70079,7 @@ static s7_pointer big_sinh(s7_scheme *sc, s7_pointer args)
#define Q_sinh pcl_n
/* currently (sinh 0+0/0i) -> 0.0? */
- return(big_trig(sc, args, mpfr_sinh, mpc_sinh, TRIG_NO_CHECK, sc->SINH));
+ return(big_trig(sc, args, mpfr_sinh, mpc_sinh, TRIG_NO_CHECK, sc->sinh_symbol));
}
@@ -69670,7 +70088,7 @@ static s7_pointer big_cosh(s7_scheme *sc, s7_pointer args)
#define H_cosh "(cosh z) returns cosh(z)"
#define Q_cosh pcl_n
- return(big_trig(sc, args, mpfr_cosh, mpc_cosh, TRIG_NO_CHECK, sc->COSH));
+ return(big_trig(sc, args, mpfr_cosh, mpc_cosh, TRIG_NO_CHECK, sc->cosh_symbol));
}
@@ -69679,7 +70097,7 @@ static s7_pointer big_tanh(s7_scheme *sc, s7_pointer args)
#define H_tanh "(tanh z) returns tanh(z)"
#define Q_tanh pcl_n
- return(big_trig(sc, args, mpfr_tanh, mpc_tanh, TRIG_TANH_CHECK, sc->TANH));
+ return(big_trig(sc, args, mpfr_tanh, mpc_tanh, TRIG_TANH_CHECK, sc->tanh_symbol));
}
@@ -69688,7 +70106,7 @@ static s7_pointer big_exp(s7_scheme *sc, s7_pointer args)
#define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
#define Q_exp pcl_n
- return(big_trig(sc, args, mpfr_exp, mpc_exp, TRIG_NO_CHECK, sc->EXP));
+ return(big_trig(sc, args, mpfr_exp, mpc_exp, TRIG_NO_CHECK, sc->exp_symbol));
}
@@ -69706,11 +70124,11 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
x = car(args);
if (!s7_is_number(x))
- method_or_bust_with_type(sc, x, sc->EXPT, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, x, sc->expt_symbol, args, a_number_string, 1);
y = cadr(args);
if (!s7_is_number(y))
- method_or_bust_with_type(sc, y, sc->EXPT, args, A_NUMBER, 2);
+ method_or_bust_with_type(sc, y, sc->expt_symbol, args, a_number_string, 2);
if (s7_is_zero(x))
{
@@ -69722,12 +70140,12 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
if (s7_is_real(y))
{
if (s7_is_negative(y))
- return(division_by_zero_error(sc, sc->EXPT, args));
+ return(division_by_zero_error(sc, sc->expt_symbol, args));
}
else
{
if (s7_is_negative(g_real_part(sc, cdr(args))))
- return(division_by_zero_error(sc, sc->EXPT, args));
+ return(division_by_zero_error(sc, sc->expt_symbol, args));
}
if ((s7_is_rational(x)) &&
@@ -69956,7 +70374,7 @@ static s7_pointer big_asinh(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->ASINH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->asinh_symbol, args, a_number_string, 0);
if (s7_is_real(p))
{
@@ -69993,7 +70411,7 @@ static s7_pointer big_acosh(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->ACOSH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->acosh_symbol, args, a_number_string, 0);
p = promote_number(sc, T_BIG_COMPLEX, p);
mpc_init(n);
@@ -70018,7 +70436,7 @@ static s7_pointer big_atanh(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->ATANH, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->atanh_symbol, args, a_number_string, 0);
if (s7_is_real(p))
{
@@ -70055,22 +70473,22 @@ static s7_pointer big_atanh(s7_scheme *sc, s7_pointer args)
static s7_pointer big_atan(s7_scheme *sc, s7_pointer args)
{
#define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
- #define Q_atan s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_NUMBER, sc->IS_REAL)
+ #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
s7_pointer p0, p1 = NULL, p;
p0 = car(args);
if (!s7_is_number(p0))
- method_or_bust_with_type(sc, p0, sc->ATAN, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p0, sc->atan_symbol, args, a_number_string, 0);
if (is_not_null(cdr(args)))
{
p1 = cadr(args);
if (!s7_is_real(p1))
- method_or_bust(sc, p1, sc->ATAN, args, T_REAL, 2);
+ method_or_bust(sc, p1, sc->atan_symbol, args, T_REAL, 2);
if (!s7_is_real(p0))
- return(wrong_type_argument(sc, sc->ATAN, 1, p0, T_REAL));
+ return(wrong_type_argument(sc, sc->atan_symbol, 1, p0, T_REAL));
p1 = promote_number(sc, T_BIG_REAL, p1);
}
@@ -70109,7 +70527,7 @@ static s7_pointer big_acos(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->ACOS, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->acos_symbol, args, a_number_string, 0);
if (s7_is_real(p))
{
@@ -70152,7 +70570,7 @@ static s7_pointer big_asin(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p))
- method_or_bust_with_type(sc, p, sc->ASIN, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->asin_symbol, args, a_number_string, 0);
if (s7_is_real(p))
{
@@ -70264,7 +70682,7 @@ static s7_pointer big_ash(s7_scheme *sc, s7_pointer args)
if (!mpz_fits_sint_p(big_integer(p1)))
{
if (mpz_cmp_ui(big_integer(p1), 0) > 0)
- return(out_of_range(sc, sc->ASH, small_int(2), p1, ITS_TOO_LARGE));
+ return(out_of_range(sc, sc->ash_symbol, small_int(2), p1, its_too_large_string));
/* here if p0 is negative, we need to return -1 */
if (p0_compared_to_zero == 1)
@@ -70307,9 +70725,9 @@ static bool is_integer_via_method(s7_scheme *sc, s7_pointer p)
if (has_methods(p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->IS_INTEGER);
- if (f != sc->UNDEFINED)
- return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->NIL))));
+ f = find_method(sc, find_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))));
}
return(false);
}
@@ -70364,7 +70782,7 @@ static s7_pointer big_logand(s7_scheme *sc, s7_pointer args)
{
if (is_null(args))
return(minus_one);
- return(big_bits(sc, args, sc->LOGAND, -1, g_logand, mpz_and));
+ return(big_bits(sc, args, sc->logand_symbol, -1, g_logand, mpz_and));
}
@@ -70372,7 +70790,7 @@ static s7_pointer big_logior(s7_scheme *sc, s7_pointer args)
{
if (is_null(args))
return(small_int(0));
- return(big_bits(sc, args, sc->LOGIOR, 0, g_logior, mpz_ior));
+ return(big_bits(sc, args, sc->logior_symbol, 0, g_logior, mpz_ior));
}
@@ -70380,14 +70798,14 @@ static s7_pointer big_logxor(s7_scheme *sc, s7_pointer args)
{
if (is_null(args))
return(small_int(0));
- return(big_bits(sc, args, sc->LOGXOR, 0, g_logxor, mpz_xor));
+ return(big_bits(sc, args, sc->logxor_symbol, 0, g_logxor, mpz_xor));
}
static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
{
#define H_rationalize "(rationalize x err) returns the ratio with lowest denominator within err of x"
- #define Q_rationalize s7_make_signature(sc, 3, sc->IS_RATIONAL, sc->IS_REAL, sc->IS_REAL)
+ #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
/* currently (rationalize 1/0 1e18) -> 0
* remember to pad with many trailing zeros:
@@ -70414,7 +70832,7 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
p0 = car(args);
if (!s7_is_real(p0))
- method_or_bust(sc, p0, sc->RATIONALIZE, args, T_REAL, 1);
+ method_or_bust(sc, p0, sc->rationalize_symbol, args, T_REAL, 1);
/* p0 can be exact, but we still have to check it for simplification */
if (is_not_null(cdr(args)))
@@ -70422,7 +70840,7 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
double err_x;
p1 = cadr(args);
if (!s7_is_real(p1)) /* (rationalize (expt 2 60) -) */
- method_or_bust(sc, p1, sc->RATIONALIZE, args, T_REAL, 2);
+ method_or_bust(sc, p1, sc->rationalize_symbol, args, T_REAL, 2);
if (is_big_number(p1))
mpfr_init_set(error, big_real(promote_number(sc, T_BIG_REAL, p1)), GMP_RNDN);
@@ -70432,7 +70850,7 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
if (is_NaN(err_x))
{
mpfr_clear(error);
- return(out_of_range(sc, sc->RATIONALIZE, small_int(2), cadr(args), ITS_NAN));
+ return(out_of_range(sc, sc->rationalize_symbol, small_int(2), cadr(args), its_nan_string));
}
if (mpfr_inf_p(error) != 0)
{
@@ -70452,13 +70870,13 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
{
mpfr_clear(ux);
mpfr_clear(error);
- return(out_of_range(sc, sc->RATIONALIZE, small_int(1), car(args), ITS_NAN));
+ return(out_of_range(sc, sc->rationalize_symbol, small_int(1), car(args), its_nan_string));
}
if (mpfr_inf_p(ux) != 0)
{
mpfr_clear(ux);
mpfr_clear(error);
- return(out_of_range(sc, sc->RATIONALIZE, small_int(1), car(args), ITS_INFINITE));
+ return(out_of_range(sc, sc->rationalize_symbol, small_int(1), car(args), its_infinite_string));
}
mpfr_init_set(x0, ux, GMP_RNDN); /* x0 = ux - error */
@@ -70640,7 +71058,7 @@ static s7_pointer big_exact_to_inexact(s7_scheme *sc, s7_pointer args)
p = car(args);
if (!s7_is_number(p)) /* apparently (exact->inexact 1+i) is not an error */
- method_or_bust_with_type(sc, p, sc->EXACT_TO_INEXACT, args, A_NUMBER, 0);
+ method_or_bust_with_type(sc, p, sc->exact_to_inexact_symbol, args, a_number_string, 0);
if (!s7_is_rational(p))
return(p);
@@ -70652,7 +71070,7 @@ static s7_pointer big_exact_to_inexact(s7_scheme *sc, s7_pointer args)
static s7_pointer big_inexact_to_exact(s7_scheme *sc, s7_pointer args)
{
#define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2"
- #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->IS_RATIONAL, sc->IS_REAL)
+ #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_rational_symbol, sc->is_real_symbol)
s7_pointer p;
p = car(args);
@@ -70661,7 +71079,7 @@ static s7_pointer big_inexact_to_exact(s7_scheme *sc, s7_pointer args)
return(p);
if (!s7_is_real(p))
- method_or_bust(sc, p, sc->INEXACT_TO_EXACT, args, T_REAL, 0);
+ method_or_bust(sc, p, sc->inexact_to_exact_symbol, args, T_REAL, 0);
return(big_rationalize(sc, args));
}
#endif
@@ -70695,7 +71113,7 @@ static s7_pointer big_convert_to_int(s7_scheme *sc, s7_pointer args, s7_pointer
{
if ((g_is_nan(sc, args) == sc->T) ||
(g_is_infinite(sc, args)) == sc->T)
- return(simple_out_of_range(sc, sym, p, (g_is_nan(sc, args) == sc->T) ? ITS_NAN : ITS_INFINITE));
+ return(simple_out_of_range(sc, sym, p, (g_is_nan(sc, args) == sc->T) ? its_nan_string : its_infinite_string));
mpz_init(n);
mpfr_get_z(n, big_real(p), mode);
@@ -70709,41 +71127,41 @@ static s7_pointer big_convert_to_int(s7_scheme *sc, s7_pointer args, s7_pointer
static s7_pointer big_floor(s7_scheme *sc, s7_pointer args)
{
#define H_floor "(floor x) returns the integer closest to x toward -inf"
- #define Q_floor s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
- return(big_convert_to_int(sc, args, sc->FLOOR, mpz_fdiv_q, GMP_RNDD));
+ return(big_convert_to_int(sc, args, sc->floor_symbol, mpz_fdiv_q, GMP_RNDD));
}
static s7_pointer big_ceiling(s7_scheme *sc, s7_pointer args)
{
#define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
- #define Q_ceiling s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
- return(big_convert_to_int(sc, args, sc->CEILING, mpz_cdiv_q, GMP_RNDU));
+ return(big_convert_to_int(sc, args, sc->ceiling_symbol, mpz_cdiv_q, GMP_RNDU));
}
static s7_pointer big_truncate(s7_scheme *sc, s7_pointer args)
{
#define H_truncate "(truncate x) returns the integer closest to x toward 0"
- #define Q_truncate s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
- return(big_convert_to_int(sc, args, sc->TRUNCATE, mpz_tdiv_q, GMP_RNDZ));
+ return(big_convert_to_int(sc, args, sc->truncate_symbol, mpz_tdiv_q, GMP_RNDZ));
}
static s7_pointer big_round(s7_scheme *sc, s7_pointer args)
{
#define H_round "(round x) returns the integer closest to x"
- #define Q_round s7_make_signature(sc, 2, sc->IS_INTEGER, sc->IS_REAL)
+ #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
s7_pointer p;
mpz_t n;
p = car(args);
if (!s7_is_real(p))
- method_or_bust(sc, p, sc->ROUND, args, T_REAL, 0);
+ method_or_bust(sc, p, sc->round_symbol, args, T_REAL, 0);
if (s7_is_integer(p))
return(p);
@@ -70780,7 +71198,7 @@ static s7_pointer big_round(s7_scheme *sc, s7_pointer args)
if ((g_is_nan(sc, args) == sc->T) ||
(g_is_infinite(sc, args)) == sc->T)
- return(simple_out_of_range(sc, sc->ROUND, p, (g_is_nan(sc, args) == sc->T) ? ITS_NAN : ITS_INFINITE));
+ return(simple_out_of_range(sc, sc->round_symbol, p, (g_is_nan(sc, args) == sc->T) ? its_nan_string : its_infinite_string));
{
int cmp_res;
@@ -70832,10 +71250,10 @@ static s7_pointer big_quotient(s7_scheme *sc, s7_pointer args)
y = cadr(args);
if (!s7_is_real(x))
- method_or_bust(sc, x, sc->QUOTIENT, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 1);
if (!s7_is_real(y))
- method_or_bust(sc, y, sc->QUOTIENT, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
if ((s7_is_integer(x)) &&
(s7_is_integer(y)))
@@ -70845,7 +71263,7 @@ static s7_pointer big_quotient(s7_scheme *sc, s7_pointer args)
y = to_big(sc, y);
if (s7_is_zero(y))
- return(division_by_zero_error(sc, sc->QUOTIENT, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, args));
mpz_init_set(n, big_integer(x));
mpz_tdiv_q(n, n, big_integer(y));
@@ -70868,10 +71286,10 @@ static s7_pointer big_remainder(s7_scheme *sc, s7_pointer args)
y = cadr(args);
if (!s7_is_real(x))
- method_or_bust(sc, x, sc->REMAINDER, args, T_REAL, 1);
+ method_or_bust(sc, x, sc->remainder_symbol, args, T_REAL, 1);
if (!s7_is_real(y))
- method_or_bust(sc, y, sc->REMAINDER, args, T_REAL, 2);
+ method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
if ((s7_is_integer(x)) &&
(s7_is_integer(y)))
@@ -70881,7 +71299,7 @@ static s7_pointer big_remainder(s7_scheme *sc, s7_pointer args)
y = to_big(sc, y);
if (s7_is_zero(y))
- return(division_by_zero_error(sc, sc->REMAINDER, args));
+ return(division_by_zero_error(sc, sc->remainder_symbol, args));
mpz_init_set(n, big_integer(x));
mpz_tdiv_r(n, n, big_integer(y));
@@ -70907,11 +71325,11 @@ static s7_pointer big_modulo(s7_scheme *sc, s7_pointer args)
a = car(args);
if (!s7_is_real(a))
- method_or_bust(sc, a, sc->MODULO, args, T_REAL, 1);
+ method_or_bust(sc, a, sc->modulo_symbol, args, T_REAL, 1);
b = cadr(args);
if (!s7_is_real(b))
- method_or_bust(sc, b, sc->MODULO, args, T_REAL, 2);
+ method_or_bust(sc, b, sc->modulo_symbol, args, T_REAL, 2);
a = to_big(sc, a);
b = to_big(sc, b);
@@ -70977,20 +71395,20 @@ static s7_pointer big_max(s7_scheme *sc, s7_pointer args)
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->MAX, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->max_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
if (result_type < T_BIG_INTEGER)
return(g_max(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->MAX, args);
+ check_method(sc, car(args), sc->max_symbol, args);
result = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->MAX, cons(sc, result, x));
+ check_method(sc, car(x), sc->max_symbol, cons(sc, result, x));
arg = promote_number(sc, result_type, car(x));
switch (result_type)
@@ -71023,20 +71441,20 @@ static s7_pointer big_min(s7_scheme *sc, s7_pointer args)
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->MIN, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->min_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
if (result_type < T_BIG_INTEGER)
return(g_min(sc, args));
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->MIN, args);
+ check_method(sc, car(args), sc->min_symbol, args);
result = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->MIN, cons(sc, result, x));
+ check_method(sc, car(x), sc->min_symbol, cons(sc, result, x));
arg = promote_number(sc, result_type, car(x));
switch (result_type)
@@ -71065,28 +71483,28 @@ static s7_pointer big_min(s7_scheme *sc, s7_pointer args)
static s7_pointer big_less(s7_scheme *sc, s7_pointer args)
{
#define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
- #define Q_less s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
int result_type;
s7_pointer x, previous, current;
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->LT, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->lt_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
/* don't try to use g_less here */
if (result_type < T_BIG_INTEGER)
result_type += 4;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->LT, args);
+ check_method(sc, car(args), sc->lt_symbol, args);
previous = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->LT, cons(sc, previous, x));
+ check_method(sc, car(x), sc->lt_symbol, cons(sc, previous, x));
current = promote_number(sc, result_type, car(x));
switch (result_type)
@@ -71104,27 +71522,27 @@ static s7_pointer big_less(s7_scheme *sc, s7_pointer args)
static s7_pointer big_less_or_equal(s7_scheme *sc, s7_pointer args)
{
#define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in increasing order"
- #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
int result_type;
s7_pointer x, previous, current;
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->LEQ, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->leq_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
if (result_type < T_BIG_INTEGER)
result_type += 4;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->LEQ, args);
+ check_method(sc, car(args), sc->leq_symbol, args);
previous = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->LEQ, cons(sc, previous, x));
+ check_method(sc, car(x), sc->leq_symbol, cons(sc, previous, x));
current = promote_number(sc, result_type, car(x));
switch (result_type)
@@ -71142,27 +71560,27 @@ static s7_pointer big_less_or_equal(s7_scheme *sc, s7_pointer args)
static s7_pointer big_greater(s7_scheme *sc, s7_pointer args)
{
#define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
- #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
int result_type;
s7_pointer x, previous, current;
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->GT, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->gt_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
if (result_type < T_BIG_INTEGER)
result_type += 4;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->GT, args);
+ check_method(sc, car(args), sc->gt_symbol, args);
previous = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->GT, cons(sc, previous, x));
+ check_method(sc, car(x), sc->gt_symbol, cons(sc, previous, x));
current = promote_number(sc, result_type, car(x));
switch (result_type)
{
@@ -71179,26 +71597,26 @@ static s7_pointer big_greater(s7_scheme *sc, s7_pointer args)
static s7_pointer big_greater_or_equal(s7_scheme *sc, s7_pointer args)
{
#define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in decreasing order"
- #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_REAL)
+ #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
int result_type;
s7_pointer x, previous, current;
result_type = big_real_scan_args(sc, args);
if (result_type < 0)
- return(wrong_type_argument(sc, sc->GEQ, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
+ return(wrong_type_argument(sc, sc->geq_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
if (result_type < T_BIG_INTEGER)
result_type += 4;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->GEQ, args);
+ check_method(sc, car(args), sc->geq_symbol, args);
previous = promote_number(sc, result_type, car(args));
for (x = cdr(args); is_not_null(x); x = cdr(x))
{
if (!s7_is_number(car(x)))
- check_method(sc, car(x), sc->GEQ, cons(sc, previous, x));
+ check_method(sc, car(x), sc->geq_symbol, cons(sc, previous, x));
current = promote_number(sc, result_type, car(x));
switch (result_type)
{
@@ -71214,7 +71632,7 @@ static s7_pointer big_greater_or_equal(s7_scheme *sc, s7_pointer args)
static s7_pointer big_equal(s7_scheme *sc, s7_pointer args)
{
- #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_NUMBER)
+ #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)
/* this is morally-equal? for bignums, the other case goes through big_numbers_are_eqv */
int result_type = T_INTEGER;
@@ -71227,8 +71645,8 @@ static s7_pointer big_equal(s7_scheme *sc, s7_pointer args)
p = car(x);
if (!s7_is_number(p))
{
- check_method(sc, car(args), sc->EQ, x);
- return(wrong_type_argument_with_type(sc, sc->EQ, position_of(x, args), p, A_NUMBER));
+ check_method(sc, car(args), sc->eq_symbol, x);
+ return(wrong_type_argument_with_type(sc, sc->eq_symbol, position_of(x, args), p, a_number_string));
}
result_type = get_result_type(sc, result_type, p);
@@ -71290,7 +71708,7 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_pointer args)
for (x = args; is_not_null(x); x = cdr(x))
{
if (!is_rational_via_method(sc, car(x)))
- return(wrong_type_argument_with_type(sc, sc->GCD, position_of(x, args), car(x), A_RATIONAL));
+ return(wrong_type_argument_with_type(sc, sc->gcd_symbol, position_of(x, args), car(x), a_rational_string));
if (!rats)
rats = (!is_integer_via_method(sc, car(x)));
}
@@ -71308,7 +71726,7 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_pointer args)
{
lst = cons(sc, mpz_to_big_integer(sc, n), x);
mpz_clear(n);
- method_or_bust(sc, car(x), sc->GCD, lst, T_INTEGER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->gcd_symbol, lst, T_INTEGER, position_of(x, args));
}
mpz_gcd(n, n, big_integer(promote_number(sc, T_BIG_INTEGER, car(x))));
if (mpz_cmp_ui(n, 1) == 0)
@@ -71328,7 +71746,7 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_pointer args)
mpz_t n, d;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->GCD, args);
+ check_method(sc, car(args), sc->gcd_symbol, args);
rat = promote_number(sc, T_BIG_RATIO, car(args));
mpz_init_set(n, mpq_numref(big_ratio(rat)));
@@ -71344,7 +71762,7 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_pointer args)
mpz_clear(n);
mpz_clear(d);
mpq_clear(q);
- method_or_bust_with_type(sc, car(x), sc->GCD, lst, A_RATIONAL, position_of(x, args));
+ method_or_bust_with_type(sc, car(x), sc->gcd_symbol, lst, a_rational_string, position_of(x, args));
}
rat = promote_number(sc, T_BIG_RATIO, car(x));
mpz_gcd(n, n, mpq_numref(big_ratio(rat)));
@@ -71382,7 +71800,7 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_pointer args)
for (x = args; is_not_null(x); x = cdr(x))
{
if (!is_rational_via_method(sc, car(x)))
- return(wrong_type_argument_with_type(sc, sc->LCM, position_of(x, args), car(x), A_RATIONAL));
+ return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(x, args), car(x), a_rational_string));
if (!rats)
rats = (!is_integer_via_method(sc, car(x)));
}
@@ -71401,7 +71819,7 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_pointer args)
{
lst = cons(sc, mpz_to_big_integer(sc, n), x);
mpz_clear(n);
- method_or_bust(sc, car(x), sc->LCM, lst, T_INTEGER, position_of(x, args));
+ method_or_bust(sc, car(x), sc->lcm_symbol, lst, T_INTEGER, position_of(x, args));
}
mpz_lcm(n, n, big_integer(promote_number(sc, T_BIG_INTEGER, car(x))));
if (mpz_cmp_ui(n, 0) == 0)
@@ -71421,7 +71839,7 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_pointer args)
mpz_t n, d;
if (!s7_is_number(car(args)))
- check_method(sc, car(args), sc->LCM, args);
+ check_method(sc, car(args), sc->lcm_symbol, args);
rat = promote_number(sc, T_BIG_RATIO, car(args));
mpz_init_set(n, mpq_numref(big_ratio(rat)));
@@ -71443,7 +71861,7 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_pointer args)
mpz_clear(n);
mpz_clear(d);
mpq_clear(q);
- method_or_bust_with_type(sc, car(x), sc->LCM, lst, A_RATIONAL, position_of(x, args));
+ method_or_bust_with_type(sc, car(x), sc->lcm_symbol, lst, a_rational_string, position_of(x, args));
}
rat = promote_number(sc, T_BIG_RATIO, car(x));
@@ -71486,7 +71904,7 @@ static s7_pointer set_bignum_precision(s7_scheme *sc, int precision)
bits = (mp_prec_t)precision;
mpfr_set_default_prec(bits);
mpc_set_default_precision(bits);
- s7_symbol_set_value(sc, sc->PI, big_pi(sc));
+ s7_symbol_set_value(sc, sc->pi_symbol, big_pi(sc));
return(sc->F);
}
@@ -71496,12 +71914,12 @@ static s7_pointer big_random_state(s7_scheme *sc, s7_pointer args)
#define H_random_state "(random-state seed) returns a new random number state initialized with 'seed'. \
Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
(let ((seed (random-state 1234))) (random 1.0 seed))"
- #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->IS_RANDOM_STATE, sc->IS_INTEGER)
+ #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)
s7_pointer r, seed;
seed = car(args);
if (!s7_is_integer(seed))
- method_or_bust(sc, seed, sc->RANDOM_STATE, args, T_INTEGER, 0);
+ method_or_bust(sc, seed, sc->random_state_symbol, args, T_INTEGER, 0);
if (type(seed) != T_BIG_INTEGER)
seed = promote_number(sc, T_BIG_INTEGER, seed);
@@ -71516,19 +71934,19 @@ Pass this as the second argument to 'random' to get a repeatable random number s
static s7_pointer big_random(s7_scheme *sc, s7_pointer args)
{
#define H_random "(random num (state #f)) returns a random number between 0 and num (0 if num=0)."
- #define Q_random s7_make_signature(sc, 3, sc->IS_NUMBER, sc->IS_NUMBER, sc->IS_RANDOM_STATE)
+ #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
s7_pointer num, state, x;
num = car(args);
if (!s7_is_number(num))
- method_or_bust_with_type(sc, num, sc->RANDOM, args, A_NUMBER, 1);
+ method_or_bust_with_type(sc, num, sc->random_symbol, args, a_number_string, 1);
state = sc->default_rng;
if (is_not_null(cdr(args)))
{
state = cadr(args);
if (!is_random_state(state))
- return(wrong_type_argument_with_type(sc, sc->RANDOM, 2, state, A_RANDOM_STATE_OBJECT));
+ return(wrong_type_argument_with_type(sc, sc->random_symbol, 2, state, a_random_state_object_string));
}
if (s7_is_zero(num))
@@ -71625,71 +72043,71 @@ static void s7_gmp_init(s7_scheme *sc)
#define big_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_typed_function(sc, Scheme_Name, big_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
#define c_big_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_typed_function(sc, Scheme_Name, c_big_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
- sc->ADD = big_defun("+", add, 0, 0, true);
- sc->SUBTRACT = big_defun("-", subtract, 1, 0, true);
- sc->MULTIPLY = big_defun("*", multiply, 0, 0, true);
- sc->DIVIDE = big_defun("/", divide, 1, 0, true);
- sc->MAX = big_defun("max", max, 1, 0, true);
- sc->MIN = big_defun("min", min, 1, 0, true);
- sc->LT = big_defun("<", less, 2, 0, true);
- sc->LEQ = big_defun("<=", less_or_equal, 2, 0, true);
- sc->GT = big_defun(">", greater, 2, 0, true);
- sc->GEQ = big_defun(">=", greater_or_equal, 2, 0, true);
- sc->EQ = big_defun("=", equal, 2, 0, true);
- sc->RATIONALIZE = big_defun("rationalize", rationalize, 1, 1, false);
+ sc->add_symbol = big_defun("+", add, 0, 0, true);
+ sc->subtract_symbol = big_defun("-", subtract, 1, 0, true);
+ sc->multiply_symbol = big_defun("*", multiply, 0, 0, true);
+ sc->divide_symbol = big_defun("/", divide, 1, 0, true);
+ sc->max_symbol = big_defun("max", max, 1, 0, true);
+ sc->min_symbol = big_defun("min", min, 1, 0, true);
+ sc->lt_symbol = big_defun("<", less, 2, 0, true);
+ sc->leq_symbol = big_defun("<=", less_or_equal, 2, 0, true);
+ sc->gt_symbol = big_defun(">", greater, 2, 0, true);
+ sc->geq_symbol = big_defun(">=", greater_or_equal, 2, 0, true);
+ sc->eq_symbol = big_defun("=", equal, 2, 0, true);
+ sc->rationalize_symbol = big_defun("rationalize", rationalize, 1, 1, false);
#if (!WITH_PURE_S7)
- sc->EXACT_TO_INEXACT = big_defun("exact->inexact", exact_to_inexact, 1, 0, false);
- sc->INEXACT_TO_EXACT = big_defun("inexact->exact", inexact_to_exact, 1, 0, false);
- sc->INTEGER_LENGTH = big_defun("integer-length", integer_length, 1, 0, false);
- sc->MAKE_RECTANGULAR = c_big_defun("make-rectangular", complex, 2, 0, false);
- sc->MAKE_POLAR = big_defun("make-polar", make_polar, 2, 0, false);
+ sc->exact_to_inexact_symbol = big_defun("exact->inexact", exact_to_inexact, 1, 0, false);
+ sc->inexact_to_exact_symbol = big_defun("inexact->exact", inexact_to_exact, 1, 0, false);
+ sc->integer_length_symbol = big_defun("integer-length", integer_length, 1, 0, false);
+ sc->make_rectangular_symbol = c_big_defun("make-rectangular", complex, 2, 0, false);
+ sc->make_polar_symbol = big_defun("make-polar", make_polar, 2, 0, false);
#endif
- sc->FLOOR = big_defun("floor", floor, 1, 0, false);
- sc->CEILING = big_defun("ceiling", ceiling, 1, 0, false);
- sc->TRUNCATE = big_defun("truncate", truncate, 1, 0, false);
- sc->ROUND = big_defun("round", round, 1, 0, false);
- sc->QUOTIENT = big_defun("quotient", quotient, 2, 0, false);
- sc->REMAINDER = big_defun("remainder", remainder, 2, 0, false);
- sc->MODULO = big_defun("modulo", modulo, 2, 0, false);
- sc->GCD = big_defun("gcd", gcd, 0, 0, true);
- sc->LCM = big_defun("lcm", lcm, 0, 0, true);
- sc->COMPLEX = c_big_defun("complex", complex, 2, 0, false);
- sc->MAGNITUDE = big_defun("magnitude", magnitude, 1, 0, false);
- sc->ANGLE = big_defun("angle", angle, 1, 0, false);
- sc->ABS = big_defun("abs", abs, 1, 0, false);
- sc->LOGNOT = big_defun("lognot", lognot, 1, 0, false);
- sc->LOGIOR = big_defun("logior", logior, 0, 0, true);
- sc->LOGXOR = big_defun("logxor", logxor, 0, 0, true);
- sc->LOGAND = big_defun("logand", logand, 0, 0, true);
- sc->ASH = big_defun("ash", ash, 2, 0, false);
- sc->EXP = big_defun("exp", exp, 1, 0, false);
- sc->EXPT = big_defun("expt", expt, 2, 0, false);
- sc->LOG = big_defun("log", log, 1, 1, false);
- sc->SQRT = big_defun("sqrt", sqrt, 1, 0, false);
- sc->SIN = big_defun("sin", sin, 1, 0, false);
- sc->COS = big_defun("cos", cos, 1, 0, false);
- sc->TAN = big_defun("tan", tan, 1, 0, false);
- sc->ASIN = big_defun("asin", asin, 1, 0, false);
- sc->ACOS = big_defun("acos", acos, 1, 0, false);
- sc->ATAN = big_defun("atan", atan, 1, 1, false);
- sc->SINH = big_defun("sinh", sinh, 1, 0, false);
- sc->COSH = big_defun("cosh", cosh, 1, 0, false);
- sc->TANH = big_defun("tanh", tanh, 1, 0, false);
- sc->ASINH = big_defun("asinh", asinh, 1, 0, false);
- sc->ACOSH = big_defun("acosh", acosh, 1, 0, false);
- sc->ATANH = big_defun("atanh", atanh, 1, 0, false);
-
- sc->RANDOM = big_defun("random", random, 1, 1, false);
- sc->RANDOM_STATE = big_defun("random-state", random_state, 1, 1, false);
-
- sc->IS_BIGNUM = big_defun("bignum?", is_bignum, 1, 0, false); /* needed by Q_bignum below */
- sc->BIGNUM = big_defun("bignum", bignum, 1, 1, false);
+ sc->floor_symbol = big_defun("floor", floor, 1, 0, false);
+ sc->ceiling_symbol = big_defun("ceiling", ceiling, 1, 0, false);
+ sc->truncate_symbol = big_defun("truncate", truncate, 1, 0, false);
+ sc->round_symbol = big_defun("round", round, 1, 0, false);
+ sc->quotient_symbol = big_defun("quotient", quotient, 2, 0, false);
+ sc->remainder_symbol = big_defun("remainder", remainder, 2, 0, false);
+ sc->modulo_symbol = big_defun("modulo", modulo, 2, 0, false);
+ sc->gcd_symbol = big_defun("gcd", gcd, 0, 0, true);
+ sc->lcm_symbol = big_defun("lcm", lcm, 0, 0, true);
+ sc->complex_symbol = c_big_defun("complex", complex, 2, 0, false);
+ sc->magnitude_symbol = big_defun("magnitude", magnitude, 1, 0, false);
+ sc->angle_symbol = big_defun("angle", angle, 1, 0, false);
+ sc->abs_symbol = big_defun("abs", abs, 1, 0, false);
+ sc->lognot_symbol = big_defun("lognot", lognot, 1, 0, false);
+ sc->logior_symbol = big_defun("logior", logior, 0, 0, true);
+ sc->logxor_symbol = big_defun("logxor", logxor, 0, 0, true);
+ sc->logand_symbol = big_defun("logand", logand, 0, 0, true);
+ sc->ash_symbol = big_defun("ash", ash, 2, 0, false);
+ sc->exp_symbol = big_defun("exp", exp, 1, 0, false);
+ sc->expt_symbol = big_defun("expt", expt, 2, 0, false);
+ sc->log_symbol = big_defun("log", log, 1, 1, false);
+ sc->sqrt_symbol = big_defun("sqrt", sqrt, 1, 0, false);
+ sc->sin_symbol = big_defun("sin", sin, 1, 0, false);
+ sc->cos_symbol = big_defun("cos", cos, 1, 0, false);
+ sc->tan_symbol = big_defun("tan", tan, 1, 0, false);
+ sc->asin_symbol = big_defun("asin", asin, 1, 0, false);
+ sc->acos_symbol = big_defun("acos", acos, 1, 0, false);
+ sc->atan_symbol = big_defun("atan", atan, 1, 1, false);
+ sc->sinh_symbol = big_defun("sinh", sinh, 1, 0, false);
+ sc->cosh_symbol = big_defun("cosh", cosh, 1, 0, false);
+ sc->tanh_symbol = big_defun("tanh", tanh, 1, 0, false);
+ sc->asinh_symbol = big_defun("asinh", asinh, 1, 0, false);
+ sc->acosh_symbol = big_defun("acosh", acosh, 1, 0, false);
+ sc->atanh_symbol = big_defun("atanh", atanh, 1, 0, false);
+
+ sc->random_symbol = big_defun("random", random, 1, 1, false);
+ sc->random_state_symbol = big_defun("random-state", random_state, 1, 1, false);
+
+ sc->is_bignum_symbol = big_defun("bignum?", is_bignum, 1, 0, false); /* needed by Q_bignum below */
+ sc->bignum_symbol = big_defun("bignum", bignum, 1, 1, false);
sc->bignum_precision = DEFAULT_BIGNUM_PRECISION;
mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION);
mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION);
- s7_symbol_set_value(sc, sc->PI, big_pi(sc));
+ s7_symbol_set_value(sc, sc->pi_symbol, big_pi(sc));
/* if these fixnum limits were read as strings, they'd be bignums in the gmp case,
* so for consistency make the symbolic versions bignums as well.
@@ -71754,6 +72172,8 @@ static void init_s7_let(s7_scheme *sc)
sc->bignum_precision_symbol = s7_make_symbol(sc, "bignum-precision");
sc->memory_usage_symbol = s7_make_symbol(sc, "memory-usage");
sc->float_format_precision_symbol = s7_make_symbol(sc, "float-format-precision");
+ sc->history_size_symbol = s7_make_symbol(sc, "history-size");
+ sc->profile_info_symbol = s7_make_symbol(sc, "profile-info");
}
#ifdef __linux__
@@ -71833,7 +72253,7 @@ static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args)
sym = cadr(args);
if (!is_symbol(sym))
- return(simple_wrong_type_argument(sc, sc->LET_REF, sym, T_SYMBOL));
+ return(simple_wrong_type_argument(sc, sc->let_ref_symbol, sym, T_SYMBOL));
if (sym == sc->print_length_symbol) /* print-length */
return(s7_make_integer(sc, sc->print_length));
@@ -71882,6 +72302,10 @@ static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args)
if (sym == sc->default_random_state_symbol) /* default-random-state */
return(sc->default_rng);
+ if (sym == sc->history_size_symbol) /* history-size (eval history circular buffer size) */
+ return(s7_make_integer(sc, sc->history_size));
+ if (sym == sc->profile_info_symbol) /* profile-info -- profiling data hash-table */
+ return(sc->profile_info);
if (sym == sc->max_list_length_symbol) /* max-list-length (as arg to make-list) */
return(s7_make_integer(sc, sc->max_list_length));
if (sym == sc->max_vector_length_symbol) /* max-vector-length (as arg to make-vector and make-hash-table) */
@@ -71922,11 +72346,11 @@ static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args)
{
s7_pointer res;
int i;
- sc->w = sc->NIL;
+ sc->w = sc->nil;
for (i = 0; i < num_object_types; i++) /* c-object type (tag) is i */
sc->w = cons(sc, object_types[i]->scheme_name, sc->w);
res = safe_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */
- sc->w = sc->NIL;
+ sc->w = sc->nil;
return(res);
}
@@ -71938,7 +72362,7 @@ static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args)
return(describe_memory_usage(sc));
/* sc->unlet is a scheme vector of slots -- not very useful at the scheme level */
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
@@ -71947,7 +72371,7 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
sym = cadr(args);
if (!is_symbol(sym))
- return(simple_wrong_type_argument(sc, sc->LET_SET, sym, T_SYMBOL));
+ return(simple_wrong_type_argument(sc, sc->let_set_symbol, sym, T_SYMBOL));
val = caddr(args);
@@ -71955,6 +72379,7 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
(sym == sc->max_vector_length_symbol) ||
(sym == sc->max_vector_dimensions_symbol) ||
(sym == sc->max_list_length_symbol) ||
+ (sym == sc->history_size_symbol) ||
(sym == sc->max_string_length_symbol))
{
if (s7_is_integer(val))
@@ -71975,9 +72400,42 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
sc->max_vector_dimensions = iv;
else
{
- if (sym == sc->max_list_length_symbol)
- sc->max_list_length = iv;
- else sc->max_string_length = iv;
+ if (sym == sc->history_size_symbol)
+ {
+#if WITH_HISTORY
+ s7_pointer p1, p2;
+ if (iv > sc->true_history_size)
+ {
+ /* splice in the new cells, reattach the circles */
+ s7_pointer next1, next2;
+ next1 = cdr(sc->eval_history1);
+ next2 = cdr(sc->eval_history2);
+ cdr(sc->eval_history1) = permanent_list(sc, iv - sc->true_history_size);
+ cdr(sc->eval_history2) = permanent_list(sc, iv - sc->true_history_size);
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
+ cdr(p1) = next1;
+ cdr(p2) = next2;
+ sc->true_history_size = iv;
+ }
+ sc->history_size = iv;
+ /* clear out both bufffers to avoid GC confusion */
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2))
+ {
+ car(p1) = sc->nil;
+ car(p2) = sc->nil;
+ p1 = cdr(p1);
+ if (p1 == sc->eval_history1) break;
+ }
+#else
+ sc->history_size = iv;
+#endif
+ }
+ else
+ {
+ if (sym == sc->max_list_length_symbol)
+ sc->max_list_length = iv;
+ else sc->max_string_length = iv;
+ }
}
}
}
@@ -72073,7 +72531,7 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
#endif
return(val);
}
- return(wrong_type_argument_with_type(sc, sym, 1, val, A_RANDOM_STATE_OBJECT));
+ return(wrong_type_argument_with_type(sc, sym, 1, val, a_random_state_object_string));
}
if (sym == sc->stacktrace_defaults_symbol)
@@ -72113,11 +72571,11 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
(sym == sc->heap_size_symbol) || (sym == sc->free_heap_size_symbol) ||
(sym == sc->gc_freed_symbol) || (sym == sc->gc_protected_objects_symbol) ||
(sym == sc->file_names_symbol) || (sym == sc->c_types_symbol) || (sym == sc->catches_symbol) || (sym == sc->exits_symbol) ||
- (sym == sc->rootlet_size_symbol) ||
+ (sym == sc->rootlet_size_symbol) || (sym == sc->profile_info_symbol) ||
(sym == sc->stack_top_symbol) || (sym == sc->stack_size_symbol))
- return(s7_error(sc, sc->ERROR, set_elist_2(sc, make_string_wrapper(sc, "can't set (*s7* '~S)"), sym)));
+ return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't set (*s7* '~S)"), sym)));
- return(sc->UNDEFINED);
+ return(sc->undefined);
}
/* some procedure-signature support functions */
@@ -72157,9 +72615,9 @@ static bool is_decodable(s7_scheme *sc, s7_pointer p)
if ((void *)p == (void *)sc) return(false);
/* check basic constants */
- if ((p == sc->NIL) || (p == sc->T) || (p == sc->F) || (p == sc->EOF_OBJECT) || (p == sc->ELSE) || (p == sc->rootlet) ||
- (p == sc->UNDEFINED) || (p == sc->UNSPECIFIED) || (p == sc->NO_VALUE) || (p == sc->GC_NIL) ||
- (p == sc->T1_1) || (p == sc->T2_1) || (p == sc->T3_1) || (p == sc->A1_1) || (p == sc->A2_1) || (p == sc->A3_1) || (p == sc->A4_1))
+ if ((p == sc->nil) || (p == sc->T) || (p == sc->F) || (p == sc->eof_object) || (p == sc->else_object) || (p == sc->rootlet) ||
+ (p == sc->undefined) || (p == sc->unspecified) || (p == sc->no_value) || (p == sc->gc_nil) ||
+ (p == sc->t1_1) || (p == sc->t2_1) || (p == sc->t3_1) || (p == sc->a1_1) || (p == sc->a2_1) || (p == sc->a3_1) || (p == sc->a4_1))
return(true);
/* check symbol-table */
@@ -72271,7 +72729,6 @@ char *s7_decode_bt(void)
#endif
-
/* -------------------------------- initialization -------------------------------- */
static s7_pointer make_unique_object(const char* name, unsigned int typ)
@@ -72285,6 +72742,22 @@ static s7_pointer make_unique_object(const char* name, unsigned int typ)
return(p);
}
+/* ---------------- an experiment ---------------- */
+static s7_int tree_len(s7_scheme *sc, s7_pointer p, s7_int i)
+{
+ if (is_null(p))
+ return(i);
+ if (!is_pair(p))
+ return(i + 1);
+ return(tree_len(sc, car(p), tree_len(sc, cdr(p), i)));
+}
+
+static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args)
+{
+ return(s7_make_integer(sc, tree_len(sc, car(args), 0)));
+}
+/* -------------------------------- */
+
s7_scheme *s7_init(void)
{
@@ -72326,6 +72799,7 @@ s7_scheme *s7_init(void)
init_gc_caches(sc);
sc->longjmp_ok = false;
+ sc->setjmp_loc = NO_SET_JUMP;
sc->symbol_table_is_locked = false;
if (sizeof(s7_int) == 4)
@@ -72339,6 +72813,7 @@ s7_scheme *s7_init(void)
sc->strbuf = (char *)calloc(sc->strbuf_size, sizeof(char));
sc->tmpbuf = (char *)calloc(TMPBUF_SIZE, sizeof(char));
sc->print_width = sc->max_string_length;
+ sc->short_print = false;
sc->initial_string_port_length = 128;
sc->format_depth = -1;
@@ -72353,84 +72828,97 @@ s7_scheme *s7_init(void)
sc->rf_free_list = NULL;
sc->rf_stack = NULL;
- sc->NIL = make_unique_object("()", T_NIL);
- sc->GC_NIL = make_unique_object("#<nil>", T_UNIQUE);
+ sc->nil = make_unique_object("()", T_NIL);
+ sc->gc_nil = make_unique_object("#<nil>", T_UNIQUE);
sc->T = make_unique_object("#t", T_BOOLEAN);
sc->F = make_unique_object("#f", T_BOOLEAN);
- sc->EOF_OBJECT = make_unique_object("#<eof>", T_UNIQUE);
- sc->UNDEFINED = make_unique_object("#<undefined>", T_UNIQUE);
- sc->ELSE = make_unique_object("else", T_UNIQUE);
+ sc->eof_object = make_unique_object("#<eof>", T_UNIQUE);
+ sc->undefined = make_unique_object("#<undefined>", T_UNIQUE);
+ sc->else_object = make_unique_object("else", T_UNIQUE);
/* "else" is added to the rootlet below -- can't do it here because the symbol table and environment don't exist yet. */
- sc->UNSPECIFIED = make_unique_object("#<unspecified>", T_UNSPECIFIED);
- sc->NO_VALUE = make_unique_object("#<unspecified>", T_UNSPECIFIED);
+ sc->unspecified = make_unique_object("#<unspecified>", T_UNSPECIFIED);
+ sc->no_value = make_unique_object("#<unspecified>", T_UNSPECIFIED);
- car(sc->NIL) = cdr(sc->NIL) = sc->UNSPECIFIED;
+ car(sc->nil) = cdr(sc->nil) = sc->unspecified;
/* this is mixing two different s7_cell structs, cons and envr, but luckily
* envr has two initial s7_pointer fields, equivalent to car and cdr, so
* let_id which is the same as opt1 is unaffected. To get the names
* built-in, I'll append unique_name and unique_name_length fields to
* the envr struct.
*/
- let_id(sc->NIL) = -1;
- unique_cdr(sc->UNSPECIFIED) = sc->UNSPECIFIED;
- unique_cdr(sc->UNDEFINED) = sc->UNDEFINED;
+ let_id(sc->nil) = -1;
+ unique_cdr(sc->unspecified) = sc->unspecified;
+ unique_cdr(sc->undefined) = sc->undefined;
/* this way find_symbol of an undefined symbol returns #<undefined> not #<unspecified> */
- sc->temp_cell_1 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->temp_cell = permanent_cons(sc->temp_cell_1, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->temp_cell_2 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
+ sc->temp_cell_1 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->temp_cell = permanent_cons(sc->temp_cell_1, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->temp_cell_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
- sc->T1_1 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
+ sc->t1_1 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
- sc->T2_2 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->T2_1 = permanent_cons(sc->NIL, sc->T2_2, T_PAIR | T_IMMUTABLE);
- sc->Z2_2 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->Z2_1 = permanent_cons(sc->NIL, sc->Z2_2, T_PAIR | T_IMMUTABLE);
+ sc->t2_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->t2_1 = permanent_cons(sc->nil, sc->t2_2, T_PAIR | T_IMMUTABLE);
+ sc->z2_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->z2_1 = permanent_cons(sc->nil, sc->z2_2, T_PAIR | T_IMMUTABLE);
- sc->T3_3 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->T3_2 = permanent_cons(sc->NIL, sc->T3_3, T_PAIR | T_IMMUTABLE);
- sc->T3_1 = permanent_cons(sc->NIL, sc->T3_2, T_PAIR | T_IMMUTABLE);
+ sc->t3_3 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->t3_2 = permanent_cons(sc->nil, sc->t3_3, T_PAIR | T_IMMUTABLE);
+ sc->t3_1 = permanent_cons(sc->nil, sc->t3_2, T_PAIR | T_IMMUTABLE);
- sc->A4_4 = permanent_cons(sc->NIL, sc->NIL, T_PAIR | T_IMMUTABLE);
- sc->A4_3 = permanent_cons(sc->NIL, sc->A4_4, T_PAIR | T_IMMUTABLE);
- sc->A4_2 = permanent_cons(sc->NIL, sc->A4_3, T_PAIR | T_IMMUTABLE);
- sc->A4_1 = permanent_cons(sc->NIL, sc->A4_2, T_PAIR | T_IMMUTABLE);
+ sc->a4_4 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->a4_3 = permanent_cons(sc->nil, sc->a4_4, T_PAIR | T_IMMUTABLE);
+ sc->a4_2 = permanent_cons(sc->nil, sc->a4_3, T_PAIR | T_IMMUTABLE);
+ sc->a4_1 = permanent_cons(sc->nil, sc->a4_2, T_PAIR | T_IMMUTABLE);
- sc->A1_1 = sc->A4_4;
- sc->A2_1 = sc->A4_3;
- sc->A2_2 = sc->A4_4;
- sc->A3_1 = sc->A4_2;
- sc->A3_2 = sc->A4_3;
- sc->A3_3 = sc->A4_4;
+ sc->a1_1 = sc->a4_4;
+ sc->a2_1 = sc->a4_3;
+ sc->a2_2 = sc->a4_4;
+ sc->a3_1 = sc->a4_2;
+ sc->a3_2 = sc->a4_3;
+ sc->a3_3 = sc->a4_4;
sc->safe_lists = (s7_pointer *)calloc(NUM_SAFE_LISTS, sizeof(s7_pointer));
for (i = 1; i < NUM_SAFE_LISTS; i++)
sc->safe_lists[i] = permanent_list(sc, i);
- sc->input_port_stack = sc->NIL;
- sc->code = sc->NIL;
+ sc->input_port_stack = sc->nil;
+ sc->code = sc->nil;
+#if WITH_HISTORY
+ sc->eval_history1 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
+ sc->eval_history2 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
+ {
+ s7_pointer p1, p2;
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
+ cdr(p1) = sc->eval_history1;
+ cdr(p2) = sc->eval_history2;
+ sc->cur_code = sc->eval_history1;
+ sc->using_history1 = true;
+ }
+#else
sc->cur_code = sc->F;
- sc->args = sc->NIL;
- sc->value = sc->NIL;
- sc->v = sc->NIL;
- sc->w = sc->NIL;
- sc->x = sc->NIL;
- sc->y = sc->NIL;
- sc->z = sc->NIL;
-
- sc->temp1 = sc->NIL;
- sc->temp2 = sc->NIL;
- sc->temp3 = sc->NIL;
- sc->temp4 = sc->NIL;
- sc->temp5 = sc->NIL;
- sc->temp6 = sc->NIL;
- sc->temp7 = sc->NIL;
- sc->temp8 = sc->NIL;
- sc->temp9 = sc->NIL;
- sc->temp10 = sc->NIL;
+#endif
+ sc->args = sc->nil;
+ sc->value = sc->nil;
+ sc->v = sc->nil;
+ sc->w = sc->nil;
+ sc->x = sc->nil;
+ sc->y = sc->nil;
+ sc->z = sc->nil;
+
+ sc->temp1 = sc->nil;
+ sc->temp2 = sc->nil;
+ sc->temp3 = sc->nil;
+ sc->temp4 = sc->nil;
+ sc->temp5 = sc->nil;
+ sc->temp6 = sc->nil;
+ sc->temp7 = sc->nil;
+ sc->temp8 = sc->nil;
+ sc->temp9 = sc->nil;
+ sc->temp10 = sc->nil;
sc->begin_hook = NULL;
- sc->autoload_table = sc->NIL;
+ sc->autoload_table = sc->nil;
sc->autoload_names = NULL;
sc->autoload_names_sizes = NULL;
sc->autoloaded_already = NULL;
@@ -72475,8 +72963,8 @@ s7_scheme *s7_init(void)
for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++)
{
- vector_element(sc->protected_objects, i) = sc->GC_NIL;
- vector_element(sc->protected_accessors, i) = sc->GC_NIL;
+ vector_element(sc->protected_objects, i) = sc->gc_nil;
+ vector_element(sc->protected_accessors, i) = sc->gc_nil;
}
sc->stack = s7_make_vector(sc, INITIAL_STACK_SIZE);
@@ -72496,7 +72984,7 @@ s7_scheme *s7_init(void)
vector_elements(sc->symbol_table) = (s7_pointer *)malloc(SYMBOL_TABLE_SIZE * sizeof(s7_pointer));
vector_getter(sc->symbol_table) = default_vector_getter;
vector_setter(sc->symbol_table) = default_vector_setter;
- s7_vector_fill(sc, sc->symbol_table, sc->NIL);
+ s7_vector_fill(sc, sc->symbol_table, sc->nil);
unheap(sc->symbol_table);
sc->tmp_strs = (s7_pointer *)malloc(2 * sizeof(s7_pointer));
@@ -72536,9 +73024,12 @@ s7_scheme *s7_init(void)
sc->s7_call_name = NULL;
sc->safety = 0;
sc->print_length = 8;
+ sc->history_size = DEFAULT_HISTORY_SIZE;
+ sc->true_history_size = DEFAULT_HISTORY_SIZE;
+ sc->profile_info = sc->nil;
sc->baffle_ctr = 0;
sc->syms_tag = 0;
- sc->CLASS_NAME = make_symbol(sc, "class-name");
+ sc->class_name_symbol = make_symbol(sc, "class-name");
sc->circle_info = NULL;
sc->fdats = (format_data **)calloc(8, sizeof(format_data *));
sc->num_fdats = 8;
@@ -72559,9 +73050,9 @@ s7_scheme *s7_init(void)
set_type(sc->rootlet, T_LET);
sc->rootlet_entries = 0;
for (i = 0; i < ROOTLET_SIZE; i++)
- vector_element(sc->rootlet, i) = sc->NIL;
- sc->envir = sc->NIL;
- sc->shadow_rootlet = sc->NIL;
+ vector_element(sc->rootlet, i) = sc->nil;
+ sc->envir = sc->nil;
+ sc->shadow_rootlet = sc->nil;
if (!already_inited)
{
@@ -72595,8 +73086,8 @@ s7_scheme *s7_init(void)
/* keep the characters out of the heap */
chars = (s7_pointer *)malloc((NUM_CHARS + 1) * sizeof(s7_pointer));
- chars[0] = sc->EOF_OBJECT;
- chars++; /* now chars[EOF] == chars[-1] == sc->EOF_OBJECT */
+ chars[0] = sc->eof_object;
+ chars++; /* now chars[EOF] == chars[-1] == sc->eof_object */
{
s7_cell *cells;
cells = (s7_cell *)calloc(NUM_CHARS, sizeof(s7_cell));
@@ -72645,9 +73136,6 @@ s7_scheme *s7_init(void)
}
}
-#if WITH_COUNTS
- init_hashes(sc);
-#endif
make_standard_ports(sc);
sc->syn_docs = (s7_pointer *)calloc(OP_MAX_DEFINED, sizeof(s7_pointer));
@@ -72691,215 +73179,215 @@ s7_scheme *s7_init(void)
#define MACROEXPAND_HELP "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call."
#define WITH_LET_HELP "(with-let env ...) evaluates its body in the environment env."
- sc->QUOTE = assign_syntax(sc, "quote", OP_QUOTE, small_int(1), small_int(1), QUOTE_HELP);
- sc->IF = assign_syntax(sc, "if", OP_IF, small_int(2), small_int(3), IF_HELP);
- sc->WHEN = assign_syntax(sc, "when", OP_WHEN, small_int(2), max_arity, WHEN_HELP);
- sc->UNLESS = assign_syntax(sc, "unless", OP_UNLESS, small_int(2), max_arity, UNLESS_HELP);
- sc->BEGIN = assign_syntax(sc, "begin", OP_BEGIN, small_int(0), max_arity, BEGIN_HELP);
- sc->SET = assign_syntax(sc, "set!", OP_SET, small_int(2), small_int(2), SET_HELP);
- sc->LET = assign_syntax(sc, "let", OP_LET, small_int(2), max_arity, LET_HELP);
- sc->LET_STAR = assign_syntax(sc, "let*", OP_LET_STAR, small_int(2), max_arity, LET_STAR_HELP);
- sc->LETREC = assign_syntax(sc, "letrec", OP_LETREC, small_int(2), max_arity, LETREC_HELP);
- sc->LETREC_STAR = assign_syntax(sc, "letrec*", OP_LETREC_STAR, small_int(2), max_arity, LETREC_STAR_HELP);
- sc->COND = assign_syntax(sc, "cond", OP_COND, small_int(1), max_arity, COND_HELP);
- sc->AND = assign_syntax(sc, "and", OP_AND, small_int(0), max_arity, AND_HELP);
- sc->OR = assign_syntax(sc, "or", OP_OR, small_int(0), max_arity, OR_HELP);
- sc->CASE = assign_syntax(sc, "case", OP_CASE, small_int(2), max_arity, CASE_HELP);
- sc->DO = assign_syntax(sc, "do", OP_DO, small_int(2), max_arity, DO_HELP); /* 2 because body can be null */
- sc->LAMBDA = assign_syntax(sc, "lambda", OP_LAMBDA, small_int(2), max_arity, LAMBDA_HELP);
- sc->LAMBDA_STAR = assign_syntax(sc, "lambda*", OP_LAMBDA_STAR, small_int(2), max_arity, LAMBDA_STAR_HELP);
- sc->DEFINE = assign_syntax(sc, "define", OP_DEFINE, small_int(2), max_arity, DEFINE_HELP);
- sc->DEFINE_STAR = assign_syntax(sc, "define*", OP_DEFINE_STAR, small_int(2), max_arity, DEFINE_STAR_HELP);
- sc->DEFINE_CONSTANT = assign_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, small_int(2), max_arity, DEFINE_CONSTANT_HELP);
- sc->DEFINE_MACRO = assign_syntax(sc, "define-macro", OP_DEFINE_MACRO, small_int(2), max_arity, DEFINE_MACRO_HELP);
- sc->DEFINE_MACRO_STAR = assign_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, small_int(2), max_arity, DEFINE_MACRO_STAR_HELP);
- sc->DEFINE_EXPANSION = assign_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION, small_int(2), max_arity, DEFINE_EXPANSION_HELP);
- sc->DEFINE_BACRO = assign_syntax(sc, "define-bacro", OP_DEFINE_BACRO, small_int(2), max_arity, DEFINE_BACRO_HELP);
- sc->DEFINE_BACRO_STAR = assign_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, small_int(2), max_arity, DEFINE_BACRO_STAR_HELP);
- sc->WITH_BAFFLE = assign_syntax(sc, "with-baffle", OP_WITH_BAFFLE, small_int(1), max_arity, WITH_BAFFLE_HELP);
- sc->MACROEXPAND = assign_syntax(sc, "macroexpand", OP_MACROEXPAND, small_int(1), small_int(1), MACROEXPAND_HELP);
- sc->WITH_LET = assign_syntax(sc, "with-let", OP_WITH_LET, small_int(1), max_arity, WITH_LET_HELP);
- set_immutable(sc->WITH_LET);
+ sc->quote_symbol = assign_syntax(sc, "quote", OP_QUOTE, small_int(1), small_int(1), QUOTE_HELP);
+ sc->if_symbol = assign_syntax(sc, "if", OP_IF, small_int(2), small_int(3), IF_HELP);
+ sc->when_symbol = assign_syntax(sc, "when", OP_WHEN, small_int(2), max_arity, WHEN_HELP);
+ sc->unless_symbol = assign_syntax(sc, "unless", OP_UNLESS, small_int(2), max_arity, UNLESS_HELP);
+ sc->begin_symbol = assign_syntax(sc, "begin", OP_BEGIN, small_int(0), max_arity, BEGIN_HELP);
+ sc->set_symbol = assign_syntax(sc, "set!", OP_SET, small_int(2), small_int(2), SET_HELP);
+ sc->let_symbol = assign_syntax(sc, "let", OP_LET, small_int(2), max_arity, LET_HELP);
+ sc->let_star_symbol = assign_syntax(sc, "let*", OP_LET_STAR, small_int(2), max_arity, LET_STAR_HELP);
+ sc->letrec_symbol = assign_syntax(sc, "letrec", OP_LETREC, small_int(2), max_arity, LETREC_HELP);
+ sc->letrec_star_symbol = assign_syntax(sc, "letrec*", OP_LETREC_STAR, small_int(2), max_arity, LETREC_STAR_HELP);
+ sc->cond_symbol = assign_syntax(sc, "cond", OP_COND, small_int(1), max_arity, COND_HELP);
+ sc->and_symbol = assign_syntax(sc, "and", OP_AND, small_int(0), max_arity, AND_HELP);
+ sc->or_symbol = assign_syntax(sc, "or", OP_OR, small_int(0), max_arity, OR_HELP);
+ sc->case_symbol = assign_syntax(sc, "case", OP_CASE, small_int(2), max_arity, CASE_HELP);
+ sc->do_symbol = assign_syntax(sc, "do", OP_DO, small_int(2), max_arity, DO_HELP); /* 2 because body can be null */
+ sc->lambda_symbol = assign_syntax(sc, "lambda", OP_LAMBDA, small_int(2), max_arity, LAMBDA_HELP);
+ sc->lambda_star_symbol = assign_syntax(sc, "lambda*", OP_LAMBDA_STAR, small_int(2), max_arity, LAMBDA_STAR_HELP);
+ sc->define_symbol = assign_syntax(sc, "define", OP_DEFINE, small_int(2), max_arity, DEFINE_HELP);
+ sc->define_star_symbol = assign_syntax(sc, "define*", OP_DEFINE_STAR, small_int(2), max_arity, DEFINE_STAR_HELP);
+ sc->define_constant_symbol = assign_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, small_int(2), max_arity, DEFINE_CONSTANT_HELP);
+ sc->define_macro_symbol = assign_syntax(sc, "define-macro", OP_DEFINE_MACRO, small_int(2), max_arity, DEFINE_MACRO_HELP);
+ sc->define_macro_star_symbol = assign_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, small_int(2), max_arity, DEFINE_MACRO_STAR_HELP);
+ sc->define_expansion_symbol = assign_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION, small_int(2), max_arity, DEFINE_EXPANSION_HELP);
+ sc->define_bacro_symbol = assign_syntax(sc, "define-bacro", OP_DEFINE_BACRO, small_int(2), max_arity, DEFINE_BACRO_HELP);
+ sc->define_bacro_star_symbol = assign_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, small_int(2), max_arity, DEFINE_BACRO_STAR_HELP);
+ sc->with_baffle_symbol = assign_syntax(sc, "with-baffle", OP_WITH_BAFFLE, small_int(1), max_arity, WITH_BAFFLE_HELP);
+ sc->macroexpand_symbol = assign_syntax(sc, "macroexpand", OP_MACROEXPAND, small_int(1), small_int(1), MACROEXPAND_HELP);
+ sc->with_let_symbol = assign_syntax(sc, "with-let", OP_WITH_LET, small_int(1), max_arity, WITH_LET_HELP);
+ set_immutable(sc->with_let_symbol);
#if WITH_OPTIMIZATION
- syntax_rp(slot_value(global_slot(sc->SET))) = set_rf;
- syntax_ip(slot_value(global_slot(sc->SET))) = set_if;
- syntax_pp(slot_value(global_slot(sc->SET))) = set_pf;
- syntax_rp(slot_value(global_slot(sc->IF))) = if_rf;
- syntax_pp(slot_value(global_slot(sc->IF))) = if_pf;
- syntax_pp(slot_value(global_slot(sc->OR))) = or_pf;
- syntax_pp(slot_value(global_slot(sc->AND))) = and_pf;
- syntax_pp(slot_value(global_slot(sc->QUOTE))) = quote_pf;
+ syntax_rp(slot_value(global_slot(sc->set_symbol))) = set_rf;
+ syntax_ip(slot_value(global_slot(sc->set_symbol))) = set_if;
+ syntax_pp(slot_value(global_slot(sc->set_symbol))) = set_pf;
+ syntax_rp(slot_value(global_slot(sc->if_symbol))) = if_rf;
+ syntax_pp(slot_value(global_slot(sc->if_symbol))) = if_pf;
+ syntax_pp(slot_value(global_slot(sc->or_symbol))) = or_pf;
+ syntax_pp(slot_value(global_slot(sc->and_symbol))) = and_pf;
+ syntax_pp(slot_value(global_slot(sc->quote_symbol))) = quote_pf;
#endif
- sc->QUOTE_UNCHECKED = assign_internal_syntax(sc, "quote", OP_QUOTE_UNCHECKED);
- sc->BEGIN_UNCHECKED = assign_internal_syntax(sc, "begin", OP_BEGIN_UNCHECKED);
- sc->WITH_BAFFLE_UNCHECKED = assign_internal_syntax(sc, "with-baffle", OP_WITH_BAFFLE_UNCHECKED);
- sc->LET_UNCHECKED = assign_internal_syntax(sc, "let", OP_LET_UNCHECKED);
- sc->LET_STAR_UNCHECKED = assign_internal_syntax(sc, "let*", OP_LET_STAR_UNCHECKED);
- sc->LETREC_UNCHECKED = assign_internal_syntax(sc, "letrec", OP_LETREC_UNCHECKED);
- sc->LETREC_STAR_UNCHECKED = assign_internal_syntax(sc, "letrec*", OP_LETREC_STAR_UNCHECKED);
- sc->LET_NO_VARS = assign_internal_syntax(sc, "let", OP_LET_NO_VARS);
- sc->LET_C = assign_internal_syntax(sc, "let", OP_LET_C);
- sc->LET_S = assign_internal_syntax(sc, "let", OP_LET_S);
- sc->LET_ALL_C = assign_internal_syntax(sc, "let", OP_LET_ALL_C);
- sc->LET_ALL_S = assign_internal_syntax(sc, "let", OP_LET_ALL_S);
- sc->LET_ALL_X = assign_internal_syntax(sc, "let", OP_LET_ALL_X);
- sc->LET_STAR_ALL_X = assign_internal_syntax(sc, "let*", OP_LET_STAR_ALL_X);
- sc->LET_opCq = assign_internal_syntax(sc, "let", OP_LET_opCq);
- sc->LET_opSSq = assign_internal_syntax(sc, "let", OP_LET_opSSq);
- sc->LET_opSq = assign_internal_syntax(sc, "let", OP_LET_opSq);
- sc->LET_opSq_P = assign_internal_syntax(sc, "let", OP_LET_opSq_P);
- sc->LET_ONE = assign_internal_syntax(sc, "let", OP_LET_ONE);
- sc->LET_Z = assign_internal_syntax(sc, "let", OP_LET_Z);
- sc->LET_ALL_opSq = assign_internal_syntax(sc, "let", OP_LET_ALL_opSq);
- sc->NAMED_LET_NO_VARS = assign_internal_syntax(sc, "let", OP_NAMED_LET_NO_VARS);
- sc->NAMED_LET = assign_internal_syntax(sc, "let", OP_NAMED_LET);
- sc->NAMED_LET_STAR = assign_internal_syntax(sc, "let*", OP_NAMED_LET_STAR);
- sc->LET_STAR2 = assign_internal_syntax(sc, "let*", OP_LET_STAR2);
- sc->WITH_LET_UNCHECKED = assign_internal_syntax(sc, "with-let", OP_WITH_LET_UNCHECKED);
- sc->WITH_LET_S = assign_internal_syntax(sc, "with-let", OP_WITH_LET_S);
- sc->CASE_UNCHECKED = assign_internal_syntax(sc, "case", OP_CASE_UNCHECKED);
- sc->CASE_SIMPLE = assign_internal_syntax(sc, "case", OP_CASE_SIMPLE);
- sc->CASE_SIMPLER = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER);
- sc->CASE_SIMPLER_1 = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER_1);
- sc->CASE_SIMPLER_SS = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER_SS);
- sc->CASE_SIMPLEST = assign_internal_syntax(sc, "case", OP_CASE_SIMPLEST);
- sc->CASE_SIMPLEST_SS = assign_internal_syntax(sc, "case", OP_CASE_SIMPLEST_SS);
- sc->COND_UNCHECKED = assign_internal_syntax(sc, "cond", OP_COND_UNCHECKED);
- sc->COND_SIMPLE = assign_internal_syntax(sc, "cond", OP_COND_SIMPLE);
- sc->DO_UNCHECKED = assign_internal_syntax(sc, "do", OP_DO_UNCHECKED);
- sc->LAMBDA_UNCHECKED = assign_internal_syntax(sc, "lambda", OP_LAMBDA_UNCHECKED);
- sc->LAMBDA_STAR_UNCHECKED = assign_internal_syntax(sc, "lambda*", OP_LAMBDA_STAR_UNCHECKED);
- sc->DEFINE_UNCHECKED = assign_internal_syntax(sc, "define", OP_DEFINE_UNCHECKED);
- sc->DEFINE_FUNCHECKED = assign_internal_syntax(sc, "define", OP_DEFINE_FUNCHECKED);
- sc->DEFINE_STAR_UNCHECKED = assign_internal_syntax(sc, "define*", OP_DEFINE_STAR_UNCHECKED);
- sc->DEFINE_CONSTANT_UNCHECKED = assign_internal_syntax(sc, "define-constant", OP_DEFINE_CONSTANT_UNCHECKED);
- sc->SET_UNCHECKED = assign_internal_syntax(sc, "set!", OP_SET_UNCHECKED);
- sc->SET_SYMBOL_C = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_C);
- sc->SET_SYMBOL_S = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_S);
- sc->SET_SYMBOL_Q = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_Q);
- sc->SET_SYMBOL_opSq = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSq);
- sc->SET_SYMBOL_opSSq = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSSq);
- sc->SET_SYMBOL_opSSSq = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSSSq);
- sc->SET_SYMBOL_opCq = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opCq);
- sc->SET_SYMBOL_P = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_P);
- sc->SET_SYMBOL_Z = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_Z);
- sc->SET_SYMBOL_A = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_A);
- sc->SET_NORMAL = assign_internal_syntax(sc, "set!", OP_SET_NORMAL);
- sc->SET_PWS = assign_internal_syntax(sc, "set!", OP_SET_PWS);
- sc->SET_PAIR = assign_internal_syntax(sc, "set!", OP_SET_PAIR);
- sc->SET_PAIR_P = assign_internal_syntax(sc, "set!", OP_SET_PAIR_P);
- sc->SET_PAIR_Z = assign_internal_syntax(sc, "set!", OP_SET_PAIR_Z);
- sc->SET_PAIR_A = assign_internal_syntax(sc, "set!", OP_SET_PAIR_A);
- sc->SET_PAIR_ZA = assign_internal_syntax(sc, "set!", OP_SET_PAIR_ZA);
- sc->SET_LET_S = assign_internal_syntax(sc, "set!", OP_SET_LET_S);
- sc->SET_LET_ALL_X = assign_internal_syntax(sc, "set!", OP_SET_LET_ALL_X);
- sc->SET_PAIR_C = assign_internal_syntax(sc, "set!", OP_SET_PAIR_C);
- sc->SET_PAIR_C_P = assign_internal_syntax(sc, "set!", OP_SET_PAIR_C_P);
- sc->INCREMENT_1 = assign_internal_syntax(sc, "set!", OP_INCREMENT_1);
- sc->INCREMENT_SS = assign_internal_syntax(sc, "set!", OP_INCREMENT_SS);
- sc->INCREMENT_SSS = assign_internal_syntax(sc, "set!", OP_INCREMENT_SSS);
- sc->INCREMENT_SZ = assign_internal_syntax(sc, "set!", OP_INCREMENT_SZ);
- sc->INCREMENT_SA = assign_internal_syntax(sc, "set!", OP_INCREMENT_SA);
- sc->INCREMENT_SAA = assign_internal_syntax(sc, "set!", OP_INCREMENT_SAA);
- sc->DECREMENT_1 = assign_internal_syntax(sc, "set!", OP_DECREMENT_1);
- sc->SET_CONS = assign_internal_syntax(sc, "set!", OP_SET_CONS);
- sc->AND_UNCHECKED = assign_internal_syntax(sc, "and", OP_AND_UNCHECKED);
- sc->AND_P = assign_internal_syntax(sc, "and", OP_AND_P);
- sc->AND_P2 = assign_internal_syntax(sc, "and", OP_AND_P2);
- sc->OR_UNCHECKED = assign_internal_syntax(sc, "or", OP_OR_UNCHECKED);
- sc->OR_P = assign_internal_syntax(sc, "or", OP_OR_P);
- sc->OR_P2 = assign_internal_syntax(sc, "or", OP_OR_P2);
- sc->IF_UNCHECKED = assign_internal_syntax(sc, "if", OP_IF_UNCHECKED);
-
- sc->IF_P_P = assign_internal_syntax(sc, "if", OP_IF_P_P);
- sc->IF_P_P_P = assign_internal_syntax(sc, "if", OP_IF_P_P_P);
- sc->IF_ANDP_P = assign_internal_syntax(sc, "if", OP_IF_ANDP_P);
- sc->IF_ANDP_P_P = assign_internal_syntax(sc, "if", OP_IF_ANDP_P_P);
- sc->IF_ORP_P = assign_internal_syntax(sc, "if", OP_IF_ORP_P);
- sc->IF_ORP_P_P = assign_internal_syntax(sc, "if", OP_IF_ORP_P_P);
- sc->IF_S_P = assign_internal_syntax(sc, "if", OP_IF_S_P);
- sc->IF_S_P_P = assign_internal_syntax(sc, "if", OP_IF_S_P_P);
- sc->IF_P_FEED = assign_internal_syntax(sc, "cond", OP_IF_P_FEED);
- sc->COND_ALL_X = assign_internal_syntax(sc, "cond", OP_COND_ALL_X);
- sc->COND_ALL_X_2 = assign_internal_syntax(sc, "cond", OP_COND_ALL_X_2);
- sc->COND_S = assign_internal_syntax(sc, "cond", OP_COND_S);
- sc->IF_Z_P = assign_internal_syntax(sc, "if", OP_IF_Z_P);
- sc->IF_Z_P_P = assign_internal_syntax(sc, "if", OP_IF_Z_P_P);
- sc->IF_A_P = assign_internal_syntax(sc, "if", OP_IF_A_P);
- sc->IF_A_P_P = assign_internal_syntax(sc, "if", OP_IF_A_P_P);
- sc->IF_CC_P = assign_internal_syntax(sc, "if", OP_IF_CC_P);
- sc->IF_CC_P_P = assign_internal_syntax(sc, "if", OP_IF_CC_P_P);
- sc->IF_CS_P = assign_internal_syntax(sc, "if", OP_IF_CS_P);
- sc->IF_CS_P_P = assign_internal_syntax(sc, "if", OP_IF_CS_P_P);
- sc->IF_CSQ_P = assign_internal_syntax(sc, "if", OP_IF_CSQ_P);
- sc->IF_CSQ_P_P = assign_internal_syntax(sc, "if", OP_IF_CSQ_P_P);
- sc->IF_CSS_P = assign_internal_syntax(sc, "if", OP_IF_CSS_P);
- sc->IF_CSS_P_P = assign_internal_syntax(sc, "if", OP_IF_CSS_P_P);
- sc->IF_CSC_P = assign_internal_syntax(sc, "if", OP_IF_CSC_P);
- sc->IF_CSC_P_P = assign_internal_syntax(sc, "if", OP_IF_CSC_P_P);
- sc->IF_S_opCq_P = assign_internal_syntax(sc, "if", OP_IF_S_opCq_P);
- sc->IF_S_opCq_P_P = assign_internal_syntax(sc, "if", OP_IF_S_opCq_P_P);
- sc->IF_opSSq_P = assign_internal_syntax(sc, "if", OP_IF_opSSq_P);
- sc->IF_opSSq_P_P = assign_internal_syntax(sc, "if", OP_IF_opSSq_P_P);
- sc->IF_IS_PAIR_P = assign_internal_syntax(sc, "if", OP_IF_IS_PAIR_P);
- sc->IF_IS_PAIR_P_P = assign_internal_syntax(sc, "if", OP_IF_IS_PAIR_P_P);
- sc->IF_IS_SYMBOL_P = assign_internal_syntax(sc, "if", OP_IF_IS_SYMBOL_P);
- sc->IF_IS_SYMBOL_P_P = assign_internal_syntax(sc, "if", OP_IF_IS_SYMBOL_P_P);
- sc->IF_NOT_S_P = assign_internal_syntax(sc, "if", OP_IF_NOT_S_P);
- sc->IF_NOT_S_P_P = assign_internal_syntax(sc, "if", OP_IF_NOT_S_P_P);
- sc->IF_AND2_P = assign_internal_syntax(sc, "if", OP_IF_AND2_P);
- sc->IF_AND2_P_P = assign_internal_syntax(sc, "if", OP_IF_AND2_P_P);
- sc->WHEN_S = assign_internal_syntax(sc, "when", OP_WHEN_S);
- sc->UNLESS_S = assign_internal_syntax(sc, "unless", OP_UNLESS_S);
- sc->WHEN_UNCHECKED = assign_internal_syntax(sc, "when", OP_WHEN_UNCHECKED);
- sc->UNLESS_UNCHECKED = assign_internal_syntax(sc, "unless", OP_UNLESS_UNCHECKED);
- sc->DOTIMES_P = assign_internal_syntax(sc, "do", OP_DOTIMES_P);
- sc->SIMPLE_DO = assign_internal_syntax(sc, "do", OP_SIMPLE_DO);
- sc->SIMPLE_DO_P = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_P);
- sc->SIMPLE_DO_A = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_A);
- sc->SIMPLE_DO_E = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_E);
- sc->SAFE_DOTIMES = assign_internal_syntax(sc, "do", OP_SAFE_DOTIMES);
- sc->SAFE_DO = assign_internal_syntax(sc, "do", OP_SAFE_DO);
- sc->DOX = assign_internal_syntax(sc, "do", OP_DOX);
-
- sc->DOCUMENTATION = make_symbol(sc, "documentation");
- sc->SIGNATURE = make_symbol(sc, "signature");
+ sc->quote_unchecked_symbol = assign_internal_syntax(sc, "quote", OP_QUOTE_UNCHECKED);
+ sc->begin_unchecked_symbol = assign_internal_syntax(sc, "begin", OP_BEGIN_UNCHECKED);
+ sc->with_baffle_unchecked_symbol = assign_internal_syntax(sc, "with-baffle", OP_WITH_BAFFLE_UNCHECKED);
+ sc->let_unchecked_symbol = assign_internal_syntax(sc, "let", OP_LET_UNCHECKED);
+ sc->let_star_unchecked_symbol = assign_internal_syntax(sc, "let*", OP_LET_STAR_UNCHECKED);
+ sc->letrec_unchecked_symbol = assign_internal_syntax(sc, "letrec", OP_LETREC_UNCHECKED);
+ sc->letrec_star_unchecked_symbol = assign_internal_syntax(sc, "letrec*", OP_LETREC_STAR_UNCHECKED);
+ sc->let_no_vars_symbol = assign_internal_syntax(sc, "let", OP_LET_NO_VARS);
+ sc->let_c_symbol = assign_internal_syntax(sc, "let", OP_LET_C);
+ sc->let_s_symbol = assign_internal_syntax(sc, "let", OP_LET_S);
+ sc->let_all_c_symbol = assign_internal_syntax(sc, "let", OP_LET_ALL_C);
+ sc->let_all_s_symbol = assign_internal_syntax(sc, "let", OP_LET_ALL_S);
+ sc->let_all_x_symbol = assign_internal_syntax(sc, "let", OP_LET_ALL_X);
+ sc->let_star_all_x_symbol = assign_internal_syntax(sc, "let*", OP_LET_STAR_ALL_X);
+ sc->let_opcq_symbol = assign_internal_syntax(sc, "let", OP_LET_opCq);
+ sc->let_opssq_symbol = assign_internal_syntax(sc, "let", OP_LET_opSSq);
+ sc->let_opsq_symbol = assign_internal_syntax(sc, "let", OP_LET_opSq);
+ sc->let_opsq_p_symbol = assign_internal_syntax(sc, "let", OP_LET_opSq_P);
+ sc->let_one_symbol = assign_internal_syntax(sc, "let", OP_LET_ONE);
+ sc->let_z_symbol = assign_internal_syntax(sc, "let", OP_LET_Z);
+ sc->let_all_opsq_symbol = assign_internal_syntax(sc, "let", OP_LET_ALL_opSq);
+ sc->named_let_no_vars_symbol = assign_internal_syntax(sc, "let", OP_NAMED_LET_NO_VARS);
+ sc->named_let_symbol = assign_internal_syntax(sc, "let", OP_NAMED_LET);
+ sc->named_let_star_symbol = assign_internal_syntax(sc, "let*", OP_NAMED_LET_STAR);
+ sc->let_star2_symbol = assign_internal_syntax(sc, "let*", OP_LET_STAR2);
+ sc->with_let_unchecked_symbol = assign_internal_syntax(sc, "with-let", OP_WITH_LET_UNCHECKED);
+ sc->with_let_s_symbol = assign_internal_syntax(sc, "with-let", OP_WITH_LET_S);
+ sc->case_unchecked_symbol = assign_internal_syntax(sc, "case", OP_CASE_UNCHECKED);
+ sc->case_simple_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLE);
+ sc->case_simpler_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER);
+ sc->case_simpler_1_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER_1);
+ sc->case_simpler_ss_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLER_SS);
+ sc->case_simplest_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLEST);
+ sc->case_simplest_ss_symbol = assign_internal_syntax(sc, "case", OP_CASE_SIMPLEST_SS);
+ sc->cond_unchecked_symbol = assign_internal_syntax(sc, "cond", OP_COND_UNCHECKED);
+ sc->cond_simple_symbol = assign_internal_syntax(sc, "cond", OP_COND_SIMPLE);
+ sc->do_unchecked_symbol = assign_internal_syntax(sc, "do", OP_DO_UNCHECKED);
+ sc->lambda_unchecked_symbol = assign_internal_syntax(sc, "lambda", OP_LAMBDA_UNCHECKED);
+ sc->lambda_star_unchecked_symbol = assign_internal_syntax(sc, "lambda*", OP_LAMBDA_STAR_UNCHECKED);
+ sc->define_unchecked_symbol = assign_internal_syntax(sc, "define", OP_DEFINE_UNCHECKED);
+ sc->define_funchecked_symbol = assign_internal_syntax(sc, "define", OP_DEFINE_FUNCHECKED);
+ sc->define_star_unchecked_symbol = assign_internal_syntax(sc, "define*", OP_DEFINE_STAR_UNCHECKED);
+ sc->define_constant_unchecked_symbol = assign_internal_syntax(sc, "define-constant", OP_DEFINE_CONSTANT_UNCHECKED);
+ sc->set_unchecked_symbol = assign_internal_syntax(sc, "set!", OP_SET_UNCHECKED);
+ sc->set_symbol_c_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_C);
+ sc->set_symbol_s_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_S);
+ sc->set_symbol_q_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_Q);
+ sc->set_symbol_opsq_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSq);
+ sc->set_symbol_opssq_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSSq);
+ sc->set_symbol_opsssq_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opSSSq);
+ sc->set_symbol_opcq_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_opCq);
+ sc->set_symbol_p_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_P);
+ sc->set_symbol_z_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_Z);
+ sc->set_symbol_a_symbol = assign_internal_syntax(sc, "set!", OP_SET_SYMBOL_A);
+ sc->set_normal_symbol = assign_internal_syntax(sc, "set!", OP_SET_NORMAL);
+ sc->set_pws_symbol = assign_internal_syntax(sc, "set!", OP_SET_PWS);
+ sc->set_pair_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR);
+ sc->set_pair_p_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_P);
+ sc->set_pair_z_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_Z);
+ sc->set_pair_a_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_A);
+ sc->set_pair_za_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_ZA);
+ sc->set_let_s_symbol = assign_internal_syntax(sc, "set!", OP_SET_LET_S);
+ sc->set_let_all_x_symbol = assign_internal_syntax(sc, "set!", OP_SET_LET_ALL_X);
+ sc->set_pair_c_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_C);
+ sc->set_pair_c_p_symbol = assign_internal_syntax(sc, "set!", OP_SET_PAIR_C_P);
+ sc->increment_1_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_1);
+ sc->increment_ss_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_SS);
+ sc->increment_sss_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_SSS);
+ sc->increment_sz_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_SZ);
+ sc->increment_sa_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_SA);
+ sc->increment_saa_symbol = assign_internal_syntax(sc, "set!", OP_INCREMENT_SAA);
+ sc->decrement_1_symbol = assign_internal_syntax(sc, "set!", OP_DECREMENT_1);
+ sc->set_cons_symbol = assign_internal_syntax(sc, "set!", OP_SET_CONS);
+ sc->and_unchecked_symbol = assign_internal_syntax(sc, "and", OP_AND_UNCHECKED);
+ sc->and_p_symbol = assign_internal_syntax(sc, "and", OP_AND_P);
+ sc->and_p2_symbol = assign_internal_syntax(sc, "and", OP_AND_P2);
+ sc->or_unchecked_symbol = assign_internal_syntax(sc, "or", OP_OR_UNCHECKED);
+ sc->or_p_symbol = assign_internal_syntax(sc, "or", OP_OR_P);
+ sc->or_p2_symbol = assign_internal_syntax(sc, "or", OP_OR_P2);
+ sc->if_unchecked_symbol = assign_internal_syntax(sc, "if", OP_IF_UNCHECKED);
+
+ sc->if_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_P_P);
+ sc->if_p_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_P_P_P);
+ sc->if_andp_p_symbol = assign_internal_syntax(sc, "if", OP_IF_ANDP_P);
+ sc->if_andp_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_ANDP_P_P);
+ sc->if_orp_p_symbol = assign_internal_syntax(sc, "if", OP_IF_ORP_P);
+ sc->if_orp_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_ORP_P_P);
+ sc->if_s_p_symbol = assign_internal_syntax(sc, "if", OP_IF_S_P);
+ sc->if_s_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_S_P_P);
+ sc->if_p_feed_symbol = assign_internal_syntax(sc, "cond", OP_IF_P_FEED);
+ sc->cond_all_x_symbol = assign_internal_syntax(sc, "cond", OP_COND_ALL_X);
+ sc->cond_all_x_2_symbol = assign_internal_syntax(sc, "cond", OP_COND_ALL_X_2);
+ sc->cond_s_symbol = assign_internal_syntax(sc, "cond", OP_COND_S);
+ sc->if_z_p_symbol = assign_internal_syntax(sc, "if", OP_IF_Z_P);
+ sc->if_z_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_Z_P_P);
+ sc->if_a_p_symbol = assign_internal_syntax(sc, "if", OP_IF_A_P);
+ sc->if_a_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_A_P_P);
+ sc->if_cc_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CC_P);
+ sc->if_cc_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CC_P_P);
+ sc->if_cs_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CS_P);
+ sc->if_cs_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CS_P_P);
+ sc->if_csq_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSQ_P);
+ sc->if_csq_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSQ_P_P);
+ sc->if_css_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSS_P);
+ sc->if_css_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSS_P_P);
+ sc->if_csc_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSC_P);
+ sc->if_csc_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_CSC_P_P);
+ sc->if_s_opcq_p_symbol = assign_internal_syntax(sc, "if", OP_IF_S_opCq_P);
+ sc->if_s_opcq_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_S_opCq_P_P);
+ sc->if_opssq_p_symbol = assign_internal_syntax(sc, "if", OP_IF_opSSq_P);
+ sc->if_opssq_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_opSSq_P_P);
+ sc->if_is_pair_p_symbol = assign_internal_syntax(sc, "if", OP_IF_IS_PAIR_P);
+ sc->if_is_pair_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_IS_PAIR_P_P);
+ sc->if_is_symbol_p_symbol = assign_internal_syntax(sc, "if", OP_IF_IS_SYMBOL_P);
+ sc->if_is_symbol_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_IS_SYMBOL_P_P);
+ sc->if_not_s_p_symbol = assign_internal_syntax(sc, "if", OP_IF_NOT_S_P);
+ sc->if_not_s_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_NOT_S_P_P);
+ sc->if_and2_p_symbol = assign_internal_syntax(sc, "if", OP_IF_AND2_P);
+ sc->if_and2_p_p_symbol = assign_internal_syntax(sc, "if", OP_IF_AND2_P_P);
+ sc->when_s_symbol = assign_internal_syntax(sc, "when", OP_WHEN_S);
+ sc->unless_s_symbol = assign_internal_syntax(sc, "unless", OP_UNLESS_S);
+ sc->when_unchecked_symbol = assign_internal_syntax(sc, "when", OP_WHEN_UNCHECKED);
+ sc->unless_unchecked_symbol = assign_internal_syntax(sc, "unless", OP_UNLESS_UNCHECKED);
+ sc->dotimes_p_symbol = assign_internal_syntax(sc, "do", OP_DOTIMES_P);
+ sc->simple_do_symbol = assign_internal_syntax(sc, "do", OP_SIMPLE_DO);
+ sc->simple_do_p_symbol = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_P);
+ sc->simple_do_a_symbol = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_A);
+ sc->simple_do_e_symbol = assign_internal_syntax(sc, "do", OP_SIMPLE_DO_E);
+ sc->safe_dotimes_symbol = assign_internal_syntax(sc, "do", OP_SAFE_DOTIMES);
+ sc->safe_do_symbol = assign_internal_syntax(sc, "do", OP_SAFE_DO);
+ sc->dox_symbol = assign_internal_syntax(sc, "do", OP_DOX);
+
+ sc->documentation_symbol = make_symbol(sc, "documentation");
+ sc->signature_symbol = make_symbol(sc, "signature");
#if WITH_IMMUTABLE_UNQUOTE
/* this code solves the various unquote redefinition troubles
* if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,1) -> 5
* in s7, this requires a quote: (let (, (lambda (x) (+ x 1))) ,,,,'1)
*/
- sc->UNQUOTE = make_symbol(sc, ",");
- set_immutable(sc->UNQUOTE);
+ sc->unquote_symbol = make_symbol(sc, ",");
+ set_immutable(sc->unquote_symbol);
#else
- sc->UNQUOTE = make_symbol(sc, "unquote");
+ sc->unquote_symbol = make_symbol(sc, "unquote");
#endif
- sc->FEED_TO = make_symbol(sc, "=>");
- sc->BAFFLE = make_symbol(sc, "(baffle)");
- sc->BODY = make_symbol(sc, "body");
- sc->ERROR = make_symbol(sc, "error");
- sc->READ_ERROR = make_symbol(sc, "read-error");
- sc->STRING_READ_ERROR = make_symbol(sc, "string-read-error");
- sc->SYNTAX_ERROR = make_symbol(sc, "syntax-error");
- sc->WRONG_TYPE_ARG = make_symbol(sc, "wrong-type-arg");
- sc->WRONG_NUMBER_OF_ARGS = make_symbol(sc, "wrong-number-of-args");
- sc->FORMAT_ERROR = make_symbol(sc, "format-error");
- sc->OUT_OF_RANGE = make_symbol(sc, "out-of-range");
- sc->NO_CATCH = make_symbol(sc, "no-catch");
- sc->IO_ERROR = make_symbol(sc, "io-error");
- sc->INVALID_ESCAPE_FUNCTION = make_symbol(sc, "invalid-escape-function");
- sc->BAFFLED = make_symbol(sc, "baffled!");
-
- sc->KEY_ALLOW_OTHER_KEYS = s7_make_keyword(sc, "allow-other-keys");
- sc->KEY_REST = s7_make_keyword(sc, "rest");
- sc->KEY_READABLE = s7_make_keyword(sc, "readable");
-
- sc->__FUNC__ = make_symbol(sc, "__func__");
- s7_make_slot(sc, sc->NIL, sc->else_symbol = make_symbol(sc, "else"), sc->ELSE);
+ sc->feed_to_symbol = make_symbol(sc, "=>");
+ sc->baffle_symbol = make_symbol(sc, "(baffle)");
+ sc->body_symbol = make_symbol(sc, "body");
+ sc->error_symbol = make_symbol(sc, "error");
+ sc->read_error_symbol = make_symbol(sc, "read-error");
+ sc->string_read_error_symbol = make_symbol(sc, "string-read-error");
+ sc->syntax_error_symbol = make_symbol(sc, "syntax-error");
+ sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg");
+ sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args");
+ sc->format_error_symbol = make_symbol(sc, "format-error");
+ sc->out_of_range_symbol = make_symbol(sc, "out-of-range");
+ sc->no_catch_symbol = make_symbol(sc, "no-catch");
+ sc->io_error_symbol = make_symbol(sc, "io-error");
+ sc->invalid_escape_function_symbol = make_symbol(sc, "invalid-escape-function");
+ sc->baffled_symbol = make_symbol(sc, "baffled!");
+
+ sc->key_allow_other_keys_symbol = s7_make_keyword(sc, "allow-other-keys");
+ sc->key_rest_symbol = s7_make_keyword(sc, "rest");
+ sc->key_readable_symbol = s7_make_keyword(sc, "readable");
+
+ sc->__func___symbol = make_symbol(sc, "__func__");
+ s7_make_slot(sc, sc->nil, sc->else_symbol = make_symbol(sc, "else"), sc->else_object);
sc->owlet = init_owlet(sc);
sc->wrong_type_arg_info = permanent_list(sc, 6);
@@ -72914,10 +73402,10 @@ s7_scheme *s7_init(void)
sc->simple_out_of_range_info = permanent_list(sc, 4);
car(sc->simple_out_of_range_info) = s7_make_permanent_string("~A argument, ~S, is out of range (~A)");
- sc->TOO_MANY_ARGUMENTS = s7_make_permanent_string("~A: too many arguments: ~A");
- sc->NOT_ENOUGH_ARGUMENTS = s7_make_permanent_string("~A: not enough arguments: ~A");
- sc->DIVISION_BY_ZERO_ERROR = s7_make_permanent_string("~A: division by zero, ~S");
- sc->DIVISION_BY_ZERO = make_symbol(sc, "division-by-zero");
+ sc->too_many_arguments_string = s7_make_permanent_string("~A: too many arguments: ~A");
+ sc->not_enough_arguments_string = s7_make_permanent_string("~A: not enough arguments: ~A");
+ sc->division_by_zero_error_string = s7_make_permanent_string("~A: division by zero, ~S");
+ sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero");
if (!already_inited)
init_car_a_list();
@@ -72938,495 +73426,504 @@ s7_scheme *s7_init(void)
#define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
/* we need the sc->IS_* symbols first for the procedure signature lists */
- sc->IS_BOOLEAN = make_symbol(sc, "boolean?");
- pl_bt = s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->T);
-
- sc->IS_SYMBOL = defun("symbol?", is_symbol, 1, 0, false);
- sc->IS_GENSYM = defun("gensym?", is_gensym, 1, 0, false);
- sc->IS_KEYWORD = defun("keyword?", is_keyword, 1, 0, false);
- sc->IS_LET = defun("let?", is_let, 1, 0, false);
- sc->IS_OPENLET = defun("openlet?", is_openlet, 1, 0, false);
- sc->IS_ITERATOR = defun("iterator?", is_iterator, 1, 0, false);
- sc->IS_CONSTANT = defun("constant?", is_constant, 1, 0, false);
- sc->IS_MACRO = defun("macro?", is_macro, 1, 0, false);
- sc->IS_C_POINTER = defun("c-pointer?", is_c_pointer, 1, 0, false);
- sc->IS_C_OBJECT = defun("c-object?", is_c_object, 1, 0, false);
- sc->IS_INPUT_PORT = defun("input-port?", is_input_port, 1, 0, false);
- sc->IS_OUTPUT_PORT = defun("output-port?", is_output_port, 1, 0, false);
- sc->IS_EOF_OBJECT = defun("eof-object?", is_eof_object, 1, 0, false);
- sc->IS_INTEGER = defun("integer?", is_integer, 1, 0, false);
- sc->IS_NUMBER = defun("number?", is_number, 1, 0, false);
- sc->IS_REAL = defun("real?", is_real, 1, 0, false);
- sc->IS_COMPLEX = defun("complex?", is_complex, 1, 0, false);
- sc->IS_RATIONAL = defun("rational?", is_rational, 1, 0, false);
- sc->IS_RANDOM_STATE = defun("random-state?", is_random_state, 1, 0, false);
- sc->IS_CHAR = defun("char?", is_char, 1, 0, false);
- sc->IS_STRING = defun("string?", is_string, 1, 0, false);
- sc->IS_LIST = defun("list?", is_list, 1, 0, false);
- sc->IS_PAIR = defun("pair?", is_pair, 1, 0, false);
- sc->IS_VECTOR = defun("vector?", is_vector, 1, 0, false);
- sc->IS_FLOAT_VECTOR = defun("float-vector?", is_float_vector, 1, 0, false);
- sc->IS_INT_VECTOR = defun("int-vector?", is_int_vector, 1, 0, false);
- sc->IS_BYTE_VECTOR = defun("byte-vector?", is_byte_vector, 1, 0, false);
- sc->IS_HASH_TABLE = defun("hash-table?", is_hash_table, 1, 0, false);
- sc->IS_CONTINUATION = defun("continuation?", is_continuation, 1, 0, false);
- sc->IS_PROCEDURE = defun("procedure?", is_procedure, 1, 0, false);
- sc->IS_DILAMBDA = defun("dilambda?", is_dilambda, 1, 0, false);
- /* set above */ defun("boolean?", is_boolean, 1, 0, false);
- sc->IS_FLOAT = defun("float?", is_float, 1, 0, false);
- sc->IS_PROPER_LIST = defun("proper-list?", is_proper_list, 1, 0, false);
- sc->IS_SEQUENCE = defun("sequence?", is_sequence, 1, 0, false);
- sc->IS_NULL = defun("null?", is_null, 1, 0, false);
-
- sc->IS_INTEGER_OR_REAL_AT_END = s7_define_function(sc, "integer:real?", g_is_integer_or_real_at_end, 1, 0, false, "internal signature helper");
- sc->IS_INTEGER_OR_ANY_AT_END = s7_define_function(sc, "integer:any?", g_is_integer_or_any_at_end, 1, 0, false, "internal signature helper");
-
- pl_p = s7_make_signature(sc, 2, sc->T, sc->IS_PAIR);
-#if (!WITH_PURE_S7)
- pl_tp = s7_make_signature(sc, 3, sc->T, sc->T, sc->IS_PAIR);
-#endif
- pl_bc = s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_CHAR);
- pl_bn = s7_make_signature(sc, 2, sc->IS_BOOLEAN, sc->IS_NUMBER);
- pl_sf = s7_make_signature(sc, 3, sc->T, sc->IS_STRING, sc->IS_PROCEDURE);
- pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->T);
- pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_CHAR);
- pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->IS_BOOLEAN, sc->IS_STRING);
-
- pcl_i = s7_make_circular_signature(sc, 0, 1, sc->IS_INTEGER);
+ sc->is_boolean_symbol = make_symbol(sc, "boolean?");
+ pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T);
+
+ sc->is_symbol_symbol = defun("symbol?", is_symbol, 1, 0, false);
+ sc->is_gensym_symbol = defun("gensym?", is_gensym, 1, 0, false);
+ sc->is_keyword_symbol = defun("keyword?", is_keyword, 1, 0, false);
+ sc->is_let_symbol = defun("let?", is_let, 1, 0, false);
+ sc->is_openlet_symbol = defun("openlet?", is_openlet, 1, 0, false);
+ sc->is_iterator_symbol = defun("iterator?", is_iterator, 1, 0, false);
+ sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false);
+ sc->is_macro_symbol = defun("macro?", is_macro, 1, 0, false);
+ sc->is_c_pointer_symbol = defun("c-pointer?", is_c_pointer, 1, 0, false);
+ sc->is_c_object_symbol = defun("c-object?", is_c_object, 1, 0, false);
+ sc->is_input_port_symbol = defun("input-port?", is_input_port, 1, 0, false);
+ sc->is_output_port_symbol = defun("output-port?", is_output_port, 1, 0, false);
+ sc->is_eof_object_symbol = defun("eof-object?", is_eof_object, 1, 0, false);
+ sc->is_integer_symbol = defun("integer?", is_integer, 1, 0, false);
+ sc->is_number_symbol = defun("number?", is_number, 1, 0, false);
+ sc->is_real_symbol = defun("real?", is_real, 1, 0, false);
+ sc->is_complex_symbol = defun("complex?", is_complex, 1, 0, false);
+ sc->is_rational_symbol = defun("rational?", is_rational, 1, 0, false);
+ sc->is_random_state_symbol = defun("random-state?", is_random_state, 1, 0, false);
+ sc->is_char_symbol = defun("char?", is_char, 1, 0, false);
+ sc->is_string_symbol = defun("string?", is_string, 1, 0, false);
+ sc->is_list_symbol = defun("list?", is_list, 1, 0, false);
+ sc->is_pair_symbol = defun("pair?", is_pair, 1, 0, false);
+ sc->is_vector_symbol = defun("vector?", is_vector, 1, 0, false);
+ sc->is_float_vector_symbol = defun("float-vector?", is_float_vector, 1, 0, false);
+ sc->is_int_vector_symbol = defun("int-vector?", is_int_vector, 1, 0, false);
+ sc->is_byte_vector_symbol = defun("byte-vector?", is_byte_vector, 1, 0, false);
+ sc->is_hash_table_symbol = defun("hash-table?", is_hash_table, 1, 0, false);
+ sc->is_continuation_symbol = defun("continuation?", is_continuation, 1, 0, false);
+ sc->is_procedure_symbol = defun("procedure?", is_procedure, 1, 0, false);
+ sc->is_dilambda_symbol = defun("dilambda?", is_dilambda, 1, 0, false);
+ /* set above */ defun("boolean?", is_boolean, 1, 0, false);
+ sc->is_float_symbol = defun("float?", is_float, 1, 0, false);
+ sc->is_proper_list_symbol = defun("proper-list?", is_proper_list, 1, 0, false);
+ sc->is_sequence_symbol = defun("sequence?", is_sequence, 1, 0, false);
+ sc->is_null_symbol = defun("null?", is_null, 1, 0, false);
+ /* do we need 'syntax? */
+
+ sc->is_integer_or_real_at_end_symbol = s7_define_function(sc, "integer:real?", g_is_integer_or_real_at_end, 1, 0, false, "internal signature helper");
+ sc->is_integer_or_any_at_end_symbol = s7_define_function(sc, "integer:any?", g_is_integer_or_any_at_end, 1, 0, false, "internal signature helper");
+
+ pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol);
+ pl_tl = s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */
+ pl_bc = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol);
+ pl_bn = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol);
+ pl_sf = s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, sc->is_procedure_symbol);
+ pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T);
+ pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
+ pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol);
+
+ pcl_i = s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol);
pcl_t = s7_make_circular_signature(sc, 0, 1, sc->T);
- pcl_r = s7_make_circular_signature(sc, 0, 1, sc->IS_REAL);
- pcl_f = s7_make_circular_signature(sc, 0, 1, sc->IS_RATIONAL);
- pcl_n = s7_make_circular_signature(sc, 0, 1, sc->IS_NUMBER);
- pcl_s = s7_make_circular_signature(sc, 0, 1, sc->IS_STRING);
- pcl_v = s7_make_circular_signature(sc, 0, 1, sc->IS_VECTOR);
- pcl_c = s7_make_circular_signature(sc, 0, 1, sc->IS_CHAR);
-
- sc->VALUES = make_symbol(sc, "values");
-
- sc->GENSYM = defun("gensym", gensym, 0, 1, false);
- defun("symbol-table", symbol_table, 0, 0, false);
- sc->SYMBOL_TO_STRING = defun("symbol->string", symbol_to_string, 1, 0, false);
- sc->STRING_TO_SYMBOL = defun("string->symbol", string_to_symbol, 1, 0, false);
- sc->SYMBOL = defun("symbol", symbol, 1, 0, false);
- sc->SYMBOL_TO_VALUE = defun("symbol->value", symbol_to_value, 1, 1, false);
- sc->SYMBOL_TO_DYNAMIC_VALUE = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false);
+ pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol);
+ pcl_f = s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol);
+ pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol);
+ pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol);
+ pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol);
+ pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol);
+
+ sc->values_symbol = make_symbol(sc, "values");
+
+ sc->gensym_symbol = defun("gensym", gensym, 0, 1, false);
+ defun("symbol-table", symbol_table, 0, 0, false);
+ sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false);
+ sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false);
+ sc->symbol_symbol = defun("symbol", symbol, 1, 0, false);
+ sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false);
+ sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false);
s7_typed_dilambda(sc, "symbol-access", g_symbol_access, 1, 1, g_symbol_set_access, 2, 1, H_symbol_access, Q_symbol_access, NULL);
- sc->SYMBOL_ACCESS = make_symbol(sc, "symbol-access");
-
- sc->MAKE_KEYWORD = defun("make-keyword", make_keyword, 1, 0, false);
- sc->SYMBOL_TO_KEYWORD = defun("symbol->keyword", symbol_to_keyword, 1, 0, false);
- sc->KEYWORD_TO_SYMBOL = defun("keyword->symbol", keyword_to_symbol, 1, 0, false);
-
- sc->OUTLET = defun("outlet", outlet, 1, 0, false);
- sc->ROOTLET = defun("rootlet", rootlet, 0, 0, false);
- sc->CURLET = defun("curlet", curlet, 0, 0, false);
- sc->UNLET = defun("unlet", unlet, 0, 0, false);
- set_immutable(sc->UNLET);
- sc->SUBLET = defun("sublet", sublet, 1, 0, true);
- sc->VARLET = unsafe_defun("varlet", varlet, 1, 0, true);
- sc->CUTLET = unsafe_defun("cutlet", cutlet, 1, 0, true);
- sc->INLET = defun("inlet", inlet, 0, 0, true);
- sc->OWLET = defun("owlet", owlet, 0, 0, false);
- sc->COVERLET = defun("coverlet", coverlet, 1, 0, false);
- sc->OPENLET = defun("openlet", openlet, 1, 0, false);
- sc->LET_REF = defun("let-ref", let_ref, 2, 0, false);
- sc->LET_SET = defun("let-set!", let_set, 3, 0, false);
- sc->LET_REF_FALLBACK = make_symbol(sc, "let-ref-fallback");
- sc->LET_SET_FALLBACK = make_symbol(sc, "let-set!-fallback");
-
- sc->MAKE_ITERATOR = defun("make-iterator", make_iterator, 1, 1, false);
- sc->ITERATE = defun("iterate", iterate, 1, 0, false);
- sc->ITERATOR_SEQUENCE = defun("iterator-sequence", iterator_sequence, 1, 0, false);
- sc->ITERATOR_IS_AT_END = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false);
-
- sc->IS_PROVIDED = defun("provided?", is_provided, 1, 0, false);
- sc->PROVIDE = defun("provide", provide, 1, 0, false);
- sc->IS_DEFINED = defun("defined?", is_defined, 1, 2, false);
-
- sc->C_POINTER = defun("c-pointer", c_pointer, 1, 0, false);
-
- sc->PORT_LINE_NUMBER = defun("port-line-number", port_line_number, 0, 1, false);
- sc->PORT_FILENAME = defun("port-filename", port_filename, 0, 1, false);
- sc->PAIR_LINE_NUMBER = defun("pair-line-number", pair_line_number, 1, 0, false);
-
- sc->IS_PORT_CLOSED = defun("port-closed?", is_port_closed, 1, 0, false);
-
- sc->CURRENT_INPUT_PORT = defun("current-input-port", current_input_port, 0, 0, false);
- sc->CURRENT_OUTPUT_PORT = defun("current-output-port", current_output_port, 0, 0, false);
- sc->CURRENT_ERROR_PORT = defun("current-error-port", current_error_port, 0, 0, false);
- defun("set-current-error-port", set_current_error_port, 1, 0, false);
+ sc->symbol_access_symbol = make_symbol(sc, "symbol-access");
+
+ sc->make_keyword_symbol = defun("make-keyword", make_keyword, 1, 0, false);
+ sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false);
+ sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false);
+
+ sc->outlet_symbol = defun("outlet", outlet, 1, 0, false);
+ sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false);
+ sc->curlet_symbol = defun("curlet", curlet, 0, 0, false);
+ sc->unlet_symbol = defun("unlet", unlet, 0, 0, false);
+ set_immutable(sc->unlet_symbol);
+ sc->sublet_symbol = defun("sublet", sublet, 1, 0, true);
+ sc->varlet_symbol = unsafe_defun("varlet", varlet, 1, 0, true);
+ sc->cutlet_symbol = unsafe_defun("cutlet", cutlet, 1, 0, true);
+ sc->inlet_symbol = defun("inlet", inlet, 0, 0, true);
+ sc->owlet_symbol = defun("owlet", owlet, 0, 0, false);
+ sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false);
+ sc->openlet_symbol = defun("openlet", openlet, 1, 0, false);
+ sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false);
+ sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false);
+ sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback");
+ sc->let_set_fallback_symbol = make_symbol(sc, "let-set!-fallback");
+
+ sc->make_iterator_symbol = defun("make-iterator", make_iterator, 1, 1, false);
+ sc->iterate_symbol = defun("iterate", iterate, 1, 0, false);
+ sc->iterator_sequence_symbol = defun("iterator-sequence", iterator_sequence, 1, 0, false);
+ sc->iterator_is_at_end_symbol = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false);
+
+ sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false);
+ sc->provide_symbol = defun("provide", provide, 1, 0, false);
+ sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false);
+
+ sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 0, false);
+
+ sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false);
+ sc->port_filename_symbol = defun("port-filename", port_filename, 0, 1, false);
+ sc->pair_line_number_symbol = defun("pair-line-number", pair_line_number, 1, 0, false);
+ sc->pair_filename_symbol = defun("pair-filename", pair_filename, 1, 0, false);
+
+ sc->is_port_closed_symbol = defun("port-closed?", is_port_closed, 1, 0, false);
+
+ sc->current_input_port_symbol = defun("current-input-port", current_input_port, 0, 0, false);
+ sc->current_output_port_symbol = defun("current-output-port", current_output_port, 0, 0, false);
+ sc->current_error_port_symbol = defun("current-error-port", current_error_port, 0, 0, false);
+ defun("set-current-error-port", set_current_error_port, 1, 0, false);
#if (!WITH_PURE_S7)
- sc->LET_TO_LIST = defun("let->list", let_to_list, 1, 0, false);
- defun("set-current-input-port", set_current_input_port, 1, 0, false);
- defun("set-current-output-port", set_current_output_port, 1, 0, false);
- sc->IS_CHAR_READY = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */
+ sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false);
+ defun("set-current-input-port", set_current_input_port, 1, 0, false);
+ defun("set-current-output-port", set_current_output_port, 1, 0, false);
+ sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */
#endif
- sc->CLOSE_INPUT_PORT = defun("close-input-port", close_input_port, 1, 0, false);
- sc->CLOSE_OUTPUT_PORT = defun("close-output-port", close_output_port, 1, 0, false);
- sc->FLUSH_OUTPUT_PORT = defun("flush-output-port", flush_output_port, 0, 1, false);
- sc->OPEN_INPUT_FILE = defun("open-input-file", open_input_file, 1, 1, false);
- sc->OPEN_OUTPUT_FILE = defun("open-output-file", open_output_file, 1, 1, false);
- sc->OPEN_INPUT_STRING = defun("open-input-string", open_input_string, 1, 0, false);
- defun("open-output-string", open_output_string, 0, 0, false);
- sc->GET_OUTPUT_STRING = defun("get-output-string", get_output_string, 1, 1, false);
-
- sc->NEWLINE = defun("newline", newline, 0, 1, false);
- sc->WRITE = defun("write", write, 1, 1, false);
- sc->DISPLAY = defun("display", display, 1, 1, false);
- sc->READ_CHAR = defun("read-char", read_char, 0, 1, false);
- sc->PEEK_CHAR = defun("peek-char", peek_char, 0, 1, false);
- sc->WRITE_CHAR = defun("write-char", write_char, 1, 1, false);
- sc->WRITE_STRING = defun("write-string", write_string, 1, 3, false);
- sc->READ_BYTE = defun("read-byte", read_byte, 0, 1, false);
- sc->WRITE_BYTE = defun("write-byte", write_byte, 1, 1, false);
- sc->READ_LINE = defun("read-line", read_line, 0, 2, false);
- sc->READ_STRING = defun("read-string", read_string, 1, 1, false);
- sc->READ = unsafe_defun("read", read, 0, 1, false);
+ sc->close_input_port_symbol = defun("close-input-port", close_input_port, 1, 0, false);
+ sc->close_output_port_symbol = defun("close-output-port", close_output_port, 1, 0, false);
+ sc->flush_output_port_symbol = defun("flush-output-port", flush_output_port, 0, 1, false);
+ sc->open_input_file_symbol = defun("open-input-file", open_input_file, 1, 1, false);
+ sc->open_output_file_symbol = defun("open-output-file", open_output_file, 1, 1, false);
+ sc->open_input_string_symbol = defun("open-input-string", open_input_string, 1, 0, false);
+ defun("open-output-string", open_output_string, 0, 0, false);
+ sc->get_output_string_symbol = defun("get-output-string", get_output_string, 1, 1, false);
+
+ sc->newline_symbol = defun("newline", newline, 0, 1, false);
+ sc->write_symbol = defun("write", write, 1, 1, false);
+ sc->display_symbol = defun("display", display, 1, 1, false);
+ sc->read_char_symbol = defun("read-char", read_char, 0, 1, false);
+ sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false);
+ sc->write_char_symbol = defun("write-char", write_char, 1, 1, false);
+ sc->write_string_symbol = defun("write-string", write_string, 1, 3, false);
+ sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false);
+ sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false);
+ sc->read_line_symbol = defun("read-line", read_line, 0, 2, false);
+ sc->read_string_symbol = defun("read-string", read_string, 1, 1, false);
+ sc->read_symbol = unsafe_defun("read", read, 0, 1, false);
/* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence (not embedded in OP_SAFE_C_opSq for example) */
- sc->CALL_WITH_INPUT_STRING = unsafe_defun("call-with-input-string", call_with_input_string, 2, 0, false);
- sc->CALL_WITH_INPUT_FILE = unsafe_defun("call-with-input-file", call_with_input_file, 2, 0, false);
- sc->WITH_INPUT_FROM_STRING = unsafe_defun("with-input-from-string", with_input_from_string, 2, 0, false);
- sc->WITH_INPUT_FROM_FILE = unsafe_defun("with-input-from-file", with_input_from_file, 2, 0, false);
+ sc->call_with_input_string_symbol = unsafe_defun("call-with-input-string", call_with_input_string, 2, 0, false);
+ sc->call_with_input_file_symbol = unsafe_defun("call-with-input-file", call_with_input_file, 2, 0, false);
+ sc->with_input_from_string_symbol = unsafe_defun("with-input-from-string", with_input_from_string, 2, 0, false);
+ sc->with_input_from_file_symbol = unsafe_defun("with-input-from-file", with_input_from_file, 2, 0, false);
- sc->CALL_WITH_OUTPUT_STRING = unsafe_defun("call-with-output-string", call_with_output_string, 1, 0, false);
- sc->CALL_WITH_OUTPUT_FILE = unsafe_defun("call-with-output-file", call_with_output_file, 2, 0, false);
- sc->WITH_OUTPUT_TO_STRING = unsafe_defun("with-output-to-string", with_output_to_string, 1, 0, false);
- sc->WITH_OUTPUT_TO_FILE = unsafe_defun("with-output-to-file", with_output_to_file, 2, 0, false);
+ sc->call_with_output_string_symbol = unsafe_defun("call-with-output-string", call_with_output_string, 1, 0, false);
+ sc->call_with_output_file_symbol = unsafe_defun("call-with-output-file", call_with_output_file, 2, 0, false);
+ sc->with_output_to_string_symbol = unsafe_defun("with-output-to-string", with_output_to_string, 1, 0, false);
+ sc->with_output_to_file_symbol = unsafe_defun("with-output-to-file", with_output_to_file, 2, 0, false);
#if WITH_SYSTEM_EXTRAS
- sc->IS_DIRECTORY = defun("directory?", is_directory, 1, 0, false);
- sc->FILE_EXISTS = defun("file-exists?", file_exists, 1, 0, false);
- sc->DELETE_FILE = defun("delete-file", delete_file, 1, 0, false);
- sc->GETENV = defun("getenv", getenv, 1, 0, false);
- sc->SYSTEM = defun("system", system, 1, 1, false);
+ sc->is_directory_symbol = defun("directory?", is_directory, 1, 0, false);
+ sc->file_exists_symbol = defun("file-exists?", file_exists, 1, 0, false);
+ sc->delete_file_symbol = defun("delete-file", delete_file, 1, 0, false);
+ sc->getenv_symbol = defun("getenv", getenv, 1, 0, false);
+ sc->system_symbol = defun("system", system, 1, 1, false);
#ifndef _MSC_VER
- sc->DIRECTORY_TO_LIST = defun("directory->list", directory_to_list, 1, 0, false);
- sc->FILE_MTIME = defun("file-mtime", file_mtime, 1, 0, false);
+ sc->directory_to_list_symbol = defun("directory->list", directory_to_list, 1, 0, false);
+ sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false);
#endif
#endif
- sc->REAL_PART = defun("real-part", real_part, 1, 0, false);
- sc->IMAG_PART = defun("imag-part", imag_part, 1, 0, false);
- sc->NUMERATOR = defun("numerator", numerator, 1, 0, false);
- sc->DENOMINATOR = defun("denominator", denominator, 1, 0, false);
- sc->IS_EVEN = defun("even?", is_even, 1, 0, false);
- sc->IS_ODD = defun("odd?", is_odd, 1, 0, false);
- sc->IS_ZERO = defun("zero?", is_zero, 1, 0, false);
- sc->IS_POSITIVE = defun("positive?", is_positive, 1, 0, false);
- sc->IS_NEGATIVE = defun("negative?", is_negative, 1, 0, false);
- sc->IS_INFINITE = defun("infinite?", is_infinite, 1, 0, false);
- sc->IS_NAN = defun("nan?", is_nan, 1, 0, false);
+ sc->real_part_symbol = defun("real-part", real_part, 1, 0, false);
+ sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false);
+ sc->numerator_symbol = defun("numerator", numerator, 1, 0, false);
+ sc->denominator_symbol = defun("denominator", denominator, 1, 0, false);
+ sc->is_even_symbol = defun("even?", is_even, 1, 0, false);
+ sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false);
+ sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false);
+ sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false);
+ sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false);
+ sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false);
+ sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false);
#if (!WITH_GMP)
- sc->COMPLEX = defun("complex", complex, 2, 0, false);
- sc->MAGNITUDE = defun("magnitude", magnitude, 1, 0, false);
- sc->ANGLE = defun("angle", angle, 1, 0, false);
- sc->RATIONALIZE = defun("rationalize", rationalize, 1, 1, false);
- sc->ABS = defun("abs", abs, 1, 0, false);
- sc->EXP = defun("exp", exp, 1, 0, false);
- sc->LOG = defun("log", log, 1, 1, false);
- sc->SIN = defun("sin", sin, 1, 0, false);
- sc->COS = defun("cos", cos, 1, 0, false);
- sc->TAN = defun("tan", tan, 1, 0, false);
- sc->ASIN = defun("asin", asin, 1, 0, false);
- sc->ACOS = defun("acos", acos, 1, 0, false);
- sc->ATAN = defun("atan", atan, 1, 1, false);
- sc->SINH = defun("sinh", sinh, 1, 0, false);
- sc->COSH = defun("cosh", cosh, 1, 0, false);
- sc->TANH = defun("tanh", tanh, 1, 0, false);
- sc->ASINH = defun("asinh", asinh, 1, 0, false);
- sc->ACOSH = defun("acosh", acosh, 1, 0, false);
- sc->ATANH = defun("atanh", atanh, 1, 0, false);
- sc->SQRT = defun("sqrt", sqrt, 1, 0, false);
- sc->EXPT = defun("expt", expt, 2, 0, false);
- sc->FLOOR = defun("floor", floor, 1, 0, false);
- sc->CEILING = defun("ceiling", ceiling, 1, 0, false);
- sc->TRUNCATE = defun("truncate", truncate, 1, 0, false);
- sc->ROUND = defun("round", round, 1, 0, false);
- sc->LCM = defun("lcm", lcm, 0, 0, true);
- sc->GCD = defun("gcd", gcd, 0, 0, true);
- sc->ADD = defun("+", add, 0, 0, true);
- sc->SUBTRACT = defun("-", subtract, 1, 0, true);
- sc->MULTIPLY = defun("*", multiply, 0, 0, true);
- sc->DIVIDE = defun("/", divide, 1, 0, true);
- sc->MAX = defun("max", max, 1, 0, true);
- sc->MIN = defun("min", min, 1, 0, true);
- sc->QUOTIENT = defun("quotient", quotient, 2, 0, false);
- sc->REMAINDER = defun("remainder", remainder, 2, 0, false);
- sc->MODULO = defun("modulo", modulo, 2, 0, false);
- sc->EQ = defun("=", equal, 2, 0, true);
- sc->LT = defun("<", less, 2, 0, true);
- sc->GT = defun(">", greater, 2, 0, true);
- sc->LEQ = defun("<=", less_or_equal, 2, 0, true);
- sc->GEQ = defun(">=", greater_or_equal, 2, 0, true);
- sc->LOGIOR = defun("logior", logior, 0, 0, true);
- sc->LOGXOR = defun("logxor", logxor, 0, 0, true);
- sc->LOGAND = defun("logand", logand, 0, 0, true);
- sc->LOGNOT = defun("lognot", lognot, 1, 0, false);
- sc->ASH = defun("ash", ash, 2, 0, false);
- sc->RANDOM_STATE = defun("random-state", random_state, 1, 1, false);
- sc->RANDOM = defun("random", random, 1, 1, false);
+ sc->complex_symbol = defun("complex", complex, 2, 0, false);
+ sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false);
+ sc->angle_symbol = defun("angle", angle, 1, 0, false);
+ sc->rationalize_symbol = defun("rationalize", rationalize, 1, 1, false);
+ sc->abs_symbol = defun("abs", abs, 1, 0, false);
+ sc->exp_symbol = defun("exp", exp, 1, 0, false);
+ sc->log_symbol = defun("log", log, 1, 1, false);
+ sc->sin_symbol = defun("sin", sin, 1, 0, false);
+ sc->cos_symbol = defun("cos", cos, 1, 0, false);
+ sc->tan_symbol = defun("tan", tan, 1, 0, false);
+ sc->asin_symbol = defun("asin", asin, 1, 0, false);
+ sc->acos_symbol = defun("acos", acos, 1, 0, false);
+ sc->atan_symbol = defun("atan", atan, 1, 1, false);
+ sc->sinh_symbol = defun("sinh", sinh, 1, 0, false);
+ sc->cosh_symbol = defun("cosh", cosh, 1, 0, false);
+ sc->tanh_symbol = defun("tanh", tanh, 1, 0, false);
+ sc->asinh_symbol = defun("asinh", asinh, 1, 0, false);
+ sc->acosh_symbol = defun("acosh", acosh, 1, 0, false);
+ sc->atanh_symbol = defun("atanh", atanh, 1, 0, false);
+ sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false);
+ sc->expt_symbol = defun("expt", expt, 2, 0, false);
+ sc->floor_symbol = defun("floor", floor, 1, 0, false);
+ sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false);
+ sc->truncate_symbol = defun("truncate", truncate, 1, 0, false);
+ sc->round_symbol = defun("round", round, 1, 0, false);
+ sc->lcm_symbol = defun("lcm", lcm, 0, 0, true);
+ sc->gcd_symbol = defun("gcd", gcd, 0, 0, true);
+ sc->add_symbol = defun("+", add, 0, 0, true);
+ sc->subtract_symbol = defun("-", subtract, 1, 0, true);
+ sc->multiply_symbol = defun("*", multiply, 0, 0, true);
+ sc->divide_symbol = defun("/", divide, 1, 0, true);
+ sc->max_symbol = defun("max", max, 1, 0, true);
+ sc->min_symbol = defun("min", min, 1, 0, true);
+ sc->quotient_symbol = defun("quotient", quotient, 2, 0, false);
+ sc->remainder_symbol = defun("remainder", remainder, 2, 0, false);
+ sc->modulo_symbol = defun("modulo", modulo, 2, 0, false);
+ sc->eq_symbol = defun("=", equal, 2, 0, true);
+ sc->lt_symbol = defun("<", less, 2, 0, true);
+ sc->gt_symbol = defun(">", greater, 2, 0, true);
+ sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true);
+ sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true);
+ sc->logior_symbol = defun("logior", logior, 0, 0, true);
+ sc->logxor_symbol = defun("logxor", logxor, 0, 0, true);
+ sc->logand_symbol = defun("logand", logand, 0, 0, true);
+ sc->lognot_symbol = defun("lognot", lognot, 1, 0, false);
+ sc->ash_symbol = defun("ash", ash, 2, 0, false);
+ sc->random_state_symbol = defun("random-state", random_state, 1, 1, false);
+ sc->random_symbol = defun("random", random, 1, 1, false);
#if (!WITH_PURE_S7)
- sc->INEXACT_TO_EXACT = defun("inexact->exact", inexact_to_exact, 1, 0, false);
- sc->EXACT_TO_INEXACT = defun("exact->inexact", exact_to_inexact, 1, 0, false);
- sc->INTEGER_LENGTH = defun("integer-length", integer_length, 1, 0, false);
- sc->MAKE_POLAR = defun("make-polar", make_polar, 2, 0, false);
- sc->MAKE_RECTANGULAR = defun("make-rectangular", complex, 2, 0, false);
+ sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false);
+ sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false);
+ sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false);
+ sc->make_polar_symbol = defun("make-polar", make_polar, 2, 0, false);
+ sc->make_rectangular_symbol = defun("make-rectangular", complex, 2, 0, false);
#endif
#endif /* !gmp */
- sc->LOGBIT = defun("logbit?", logbit, 2, 0, false);
- sc->INTEGER_DECODE_FLOAT = defun("integer-decode-float", integer_decode_float, 1, 0, false);
+ sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false);
+ sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false);
#if (!WITH_PURE_S7)
- sc->IS_EXACT = defun("exact?", is_exact, 1, 0, false);
- sc->IS_INEXACT = defun("inexact?", is_inexact, 1, 0, false);
+ sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false);
+ sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false);
#endif
- sc->RANDOM_STATE_TO_LIST = defun("random-state->list", random_state_to_list, 0, 1, false);
-
- sc->NUMBER_TO_STRING = defun("number->string", number_to_string, 1, 1, false);
- sc->STRING_TO_NUMBER = defun("string->number", string_to_number, 1, 1, false);
-
- sc->CHAR_UPCASE = defun("char-upcase", char_upcase, 1, 0, false);
- sc->CHAR_DOWNCASE = defun("char-downcase", char_downcase, 1, 0, false);
- sc->CHAR_TO_INTEGER = defun("char->integer", char_to_integer, 1, 0, false);
- sc->INTEGER_TO_CHAR = defun("integer->char", integer_to_char, 1, 0, false);
-
- sc->IS_CHAR_UPPER_CASE = defun("char-upper-case?", is_char_upper_case, 1, 0, false);
- sc->IS_CHAR_LOWER_CASE = defun("char-lower-case?", is_char_lower_case, 1, 0, false);
- sc->IS_CHAR_ALPHABETIC = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false);
- sc->IS_CHAR_NUMERIC = defun("char-numeric?", is_char_numeric, 1, 0, false);
- sc->IS_CHAR_WHITESPACE = defun("char-whitespace?", is_char_whitespace, 1, 0, false);
-
- sc->CHAR_EQ = defun("char=?", chars_are_equal, 2, 0, true);
- sc->CHAR_LT = defun("char<?", chars_are_less, 2, 0, true);
- sc->CHAR_GT = defun("char>?", chars_are_greater, 2, 0, true);
- sc->CHAR_LEQ = defun("char<=?", chars_are_leq, 2, 0, true);
- sc->CHAR_GEQ = defun("char>=?", chars_are_geq, 2, 0, true);
- sc->CHAR_POSITION = defun("char-position", char_position, 2, 1, false);
- sc->STRING_POSITION = defun("string-position", string_position, 2, 1, false);
-
- sc->MAKE_STRING = defun("make-string", make_string, 1, 1, false);
- sc->STRING_REF = defun("string-ref", string_ref, 2, 0, false);
- sc->STRING_SET = defun("string-set!", string_set, 3, 0, false);
- sc->STRING_EQ = defun("string=?", strings_are_equal, 2, 0, true);
- sc->STRING_LT = defun("string<?", strings_are_less, 2, 0, true);
- sc->STRING_GT = defun("string>?", strings_are_greater, 2, 0, true);
- sc->STRING_LEQ = defun("string<=?", strings_are_leq, 2, 0, true);
- sc->STRING_GEQ = defun("string>=?", strings_are_geq, 2, 0, true);
+ sc->random_state_to_list_symbol = defun("random-state->list", random_state_to_list, 0, 1, false);
+
+ sc->number_to_string_symbol = defun("number->string", number_to_string, 1, 1, false);
+ sc->string_to_number_symbol = defun("string->number", string_to_number, 1, 1, false);
+
+ sc->char_upcase_symbol = defun("char-upcase", char_upcase, 1, 0, false);
+ sc->char_downcase_symbol = defun("char-downcase", char_downcase, 1, 0, false);
+ sc->char_to_integer_symbol = defun("char->integer", char_to_integer, 1, 0, false);
+ sc->integer_to_char_symbol = defun("integer->char", integer_to_char, 1, 0, false);
+
+ sc->is_char_upper_case_symbol = defun("char-upper-case?", is_char_upper_case, 1, 0, false);
+ sc->is_char_lower_case_symbol = defun("char-lower-case?", is_char_lower_case, 1, 0, false);
+ sc->is_char_alphabetic_symbol = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false);
+ sc->is_char_numeric_symbol = defun("char-numeric?", is_char_numeric, 1, 0, false);
+ sc->is_char_whitespace_symbol = defun("char-whitespace?", is_char_whitespace, 1, 0, false);
+
+ sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true);
+ sc->char_lt_symbol = defun("char<?", chars_are_less, 2, 0, true);
+ sc->char_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true);
+ sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true);
+ sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true);
+ sc->char_position_symbol = defun("char-position", char_position, 2, 1, false);
+ sc->string_position_symbol = defun("string-position", string_position, 2, 1, false);
+
+ sc->make_string_symbol = defun("make-string", make_string, 1, 1, false);
+ sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false);
+ sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false);
+ sc->string_eq_symbol = defun("string=?", strings_are_equal, 2, 0, true);
+ sc->string_lt_symbol = defun("string<?", strings_are_less, 2, 0, true);
+ sc->string_gt_symbol = defun("string>?", strings_are_greater, 2, 0, true);
+ sc->string_leq_symbol = defun("string<=?", strings_are_leq, 2, 0, true);
+ sc->string_geq_symbol = defun("string>=?", strings_are_geq, 2, 0, true);
#if (!WITH_PURE_S7)
- sc->CHAR_CI_EQ = defun("char-ci=?", chars_are_ci_equal, 2, 0, true);
- sc->CHAR_CI_LT = defun("char-ci<?", chars_are_ci_less, 2, 0, true);
- sc->CHAR_CI_GT = defun("char-ci>?", chars_are_ci_greater, 2, 0, true);
- sc->CHAR_CI_LEQ = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true);
- sc->CHAR_CI_GEQ = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true);
- sc->STRING_CI_EQ = defun("string-ci=?", strings_are_ci_equal, 2, 0, true);
- sc->STRING_CI_LT = defun("string-ci<?", strings_are_ci_less, 2, 0, true);
- sc->STRING_CI_GT = defun("string-ci>?", strings_are_ci_greater, 2, 0, true);
- sc->STRING_CI_LEQ = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true);
- sc->STRING_CI_GEQ = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true);
- sc->STRING_COPY = defun("string-copy", string_copy, 1, 0, false);
- sc->STRING_FILL = defun("string-fill!", string_fill, 2, 2, false);
- sc->LIST_TO_STRING = defun("list->string", list_to_string, 1, 0, false);
- sc->STRING_LENGTH = defun("string-length", string_length, 1, 0, false);
- sc->STRING_TO_LIST = defun("string->list", string_to_list, 1, 2, false);
+ sc->char_ci_eq_symbol = defun("char-ci=?", chars_are_ci_equal, 2, 0, true);
+ sc->char_ci_lt_symbol = defun("char-ci<?", chars_are_ci_less, 2, 0, true);
+ sc->char_ci_gt_symbol = defun("char-ci>?", chars_are_ci_greater, 2, 0, true);
+ sc->char_ci_leq_symbol = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true);
+ sc->char_ci_geq_symbol = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true);
+ sc->string_ci_eq_symbol = defun("string-ci=?", strings_are_ci_equal, 2, 0, true);
+ sc->string_ci_lt_symbol = defun("string-ci<?", strings_are_ci_less, 2, 0, true);
+ sc->string_ci_gt_symbol = defun("string-ci>?", strings_are_ci_greater, 2, 0, true);
+ sc->string_ci_leq_symbol = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true);
+ sc->string_ci_geq_symbol = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true);
+ sc->string_copy_symbol = defun("string-copy", string_copy, 1, 0, false);
+ sc->string_fill_symbol = defun("string-fill!", string_fill, 2, 2, false);
+ sc->list_to_string_symbol = defun("list->string", list_to_string, 1, 0, false);
+ sc->string_length_symbol = defun("string-length", string_length, 1, 0, false);
+ sc->string_to_list_symbol = defun("string->list", string_to_list, 1, 2, false);
#endif
- sc->STRING_DOWNCASE = defun("string-downcase", string_downcase, 1, 0, false);
- sc->STRING_UPCASE = defun("string-upcase", string_upcase, 1, 0, false);
- sc->STRING_APPEND = defun("string-append", string_append, 0, 0, true);
- sc->SUBSTRING = defun("substring", substring, 2, 1, false);
- sc->STRING = defun("string", string, 0, 0, true);
- sc->OBJECT_TO_STRING = defun("object->string", object_to_string, 1, 1, false);
- sc->FORMAT = defun("format", format, 1, 0, true);
+ sc->string_downcase_symbol = defun("string-downcase", string_downcase, 1, 0, false);
+ sc->string_upcase_symbol = defun("string-upcase", string_upcase, 1, 0, false);
+ sc->string_append_symbol = defun("string-append", string_append, 0, 0, true);
+ sc->substring_symbol = defun("substring", substring, 2, 1, false);
+ sc->string_symbol = defun("string", string, 0, 0, true);
+ sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 1, false);
+ sc->format_symbol = defun("format", format, 1, 0, true);
/* this was unsafe, but was that due to the (ill-advised) use of temp_call_2 in the arg lists? */
- sc->CONS = defun("cons", cons, 2, 0, false);
- sc->CAR = defun("car", car, 1, 0, false);
- sc->CDR = defun("cdr", cdr, 1, 0, false);
- sc->SET_CAR = defun("set-car!", set_car, 2, 0, false);
- sc->SET_CDR = unsafe_defun("set-cdr!", set_cdr, 2, 0, false);
- sc->CAAR = defun("caar", caar, 1, 0, false);
- sc->CADR = defun("cadr", cadr, 1, 0, false);
- sc->CDAR = defun("cdar", cdar, 1, 0, false);
- sc->CDDR = defun("cddr", cddr, 1, 0, false);
- sc->CAAAR = defun("caaar", caaar, 1, 0, false);
- sc->CAADR = defun("caadr", caadr, 1, 0, false);
- sc->CADAR = defun("cadar", cadar, 1, 0, false);
- sc->CDAAR = defun("cdaar", cdaar, 1, 0, false);
- sc->CADDR = defun("caddr", caddr, 1, 0, false);
- sc->CDDDR = defun("cdddr", cdddr, 1, 0, false);
- sc->CDADR = defun("cdadr", cdadr, 1, 0, false);
- sc->CDDAR = defun("cddar", cddar, 1, 0, false);
- sc->CAAAAR = defun("caaaar", caaaar, 1, 0, false);
- sc->CAAADR = defun("caaadr", caaadr, 1, 0, false);
- sc->CAADAR = defun("caadar", caadar, 1, 0, false);
- sc->CADAAR = defun("cadaar", cadaar, 1, 0, false);
- sc->CAADDR = defun("caaddr", caaddr, 1, 0, false);
- sc->CADDDR = defun("cadddr", cadddr, 1, 0, false);
- sc->CADADR = defun("cadadr", cadadr, 1, 0, false);
- sc->CADDAR = defun("caddar", caddar, 1, 0, false);
- sc->CDAAAR = defun("cdaaar", cdaaar, 1, 0, false);
- sc->CDAADR = defun("cdaadr", cdaadr, 1, 0, false);
- sc->CDADAR = defun("cdadar", cdadar, 1, 0, false);
- sc->CDDAAR = defun("cddaar", cddaar, 1, 0, false);
- sc->CDADDR = defun("cdaddr", cdaddr, 1, 0, false);
- sc->CDDDDR = defun("cddddr", cddddr, 1, 0, false);
- sc->CDDADR = defun("cddadr", cddadr, 1, 0, false);
- sc->CDDDAR = defun("cdddar", cdddar, 1, 0, false);
-
- sc->ASSOC = unsafe_defun("assoc", assoc, 2, 1, false);
- set_is_possibly_safe(slot_value(global_slot(sc->ASSOC)));
- sc->MEMBER = unsafe_defun("member", member, 2, 1, false);
- set_is_possibly_safe(slot_value(global_slot(sc->MEMBER)));
-
- sc->LIST = defun("list", list, 0, 0, true);
- sc->LIST_REF = defun("list-ref", list_ref, 2, 0, true);
- sc->LIST_SET = defun("list-set!", list_set, 3, 0, true);
- sc->LIST_TAIL = defun("list-tail", list_tail, 2, 0, false);
- sc->MAKE_LIST = defun("make-list", make_list, 1, 1, false);
-
- sc->LENGTH = defun("length", length, 1, 0, false);
- sc->COPY = defun("copy", copy, 1, 3, false);
- sc->FILL = defun("fill!", fill, 2, 2, false);
- sc->REVERSE = defun("reverse", reverse, 1, 0, false);
- sc->REVERSEB = defun("reverse!", reverse_in_place, 1, 0, false);
- sc->SORT = unsafe_defun("sort!", sort, 2, 0, false);
- sc->APPEND = defun("append", append, 0, 0, true);
+ sc->cons_symbol = defun("cons", cons, 2, 0, false);
+ sc->car_symbol = defun("car", car, 1, 0, false);
+ sc->cdr_symbol = defun("cdr", cdr, 1, 0, false);
+ sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false);
+ sc->set_cdr_symbol = unsafe_defun("set-cdr!", set_cdr, 2, 0, false);
+ sc->caar_symbol = defun("caar", caar, 1, 0, false);
+ sc->cadr_symbol = defun("cadr", cadr, 1, 0, false);
+ sc->cdar_symbol = defun("cdar", cdar, 1, 0, false);
+ sc->cddr_symbol = defun("cddr", cddr, 1, 0, false);
+ sc->caaar_symbol = defun("caaar", caaar, 1, 0, false);
+ sc->caadr_symbol = defun("caadr", caadr, 1, 0, false);
+ sc->cadar_symbol = defun("cadar", cadar, 1, 0, false);
+ sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false);
+ sc->caddr_symbol = defun("caddr", caddr, 1, 0, false);
+ sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false);
+ sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false);
+ sc->cddar_symbol = defun("cddar", cddar, 1, 0, false);
+ sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false);
+ sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false);
+ sc->caadar_symbol = defun("caadar", caadar, 1, 0, false);
+ sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false);
+ sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false);
+ sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false);
+ sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false);
+ sc->caddar_symbol = defun("caddar", caddar, 1, 0, false);
+ sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false);
+ sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false);
+ sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false);
+ sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false);
+ sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false);
+ sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false);
+ sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false);
+ sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false);
+
+ sc->assq_symbol = defun("assq", assq, 2, 0, false);
+ sc->assv_symbol = defun("assv", assv, 2, 0, false);
+ sc->assoc_symbol = unsafe_defun("assoc", assoc, 2, 1, false);
+ set_is_possibly_safe(slot_value(global_slot(sc->assoc_symbol)));
+ sc->memq_symbol = defun("memq", memq, 2, 0, false);
+ sc->memv_symbol = defun("memv", memv, 2, 0, false);
+ sc->member_symbol = unsafe_defun("member", member, 2, 1, false);
+ set_is_possibly_safe(slot_value(global_slot(sc->member_symbol)));
+
+ sc->list_symbol = defun("list", list, 0, 0, true);
+ sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true);
+ sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true);
+ sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false);
+ sc->make_list_symbol = defun("make-list", make_list, 1, 1, false);
+
+ sc->length_symbol = defun("length", length, 1, 0, false);
+ sc->copy_symbol = defun("copy", copy, 1, 3, false);
+ sc->fill_symbol = defun("fill!", fill, 2, 2, false);
+ sc->reverse_symbol = defun("reverse", reverse, 1, 0, false);
+ sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false);
+ sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false);
+ sc->append_symbol = defun("append", append, 0, 0, true);
#if (!WITH_PURE_S7)
- sc->ASSQ = defun("assq", assq, 2, 0, false);
- sc->ASSV = defun("assv", assv, 2, 0, false);
- sc->MEMQ = defun("memq", memq, 2, 0, false);
- sc->MEMV = defun("memv", memv, 2, 0, false);
- sc->VECTOR_APPEND = defun("vector-append", vector_append, 0, 0, true);
- sc->LIST_TO_VECTOR = defun("list->vector", list_to_vector, 1, 0, false);
- sc->VECTOR_FILL = defun("vector-fill!", vector_fill, 2, 2, false);
- sc->VECTOR_LENGTH = defun("vector-length", vector_length, 1, 0, false);
- sc->VECTOR_TO_LIST = defun("vector->list", vector_to_list, 1, 2, false);
+ sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true);
+ sc->list_to_vector_symbol = defun("list->vector", list_to_vector, 1, 0, false);
+ sc->vector_fill_symbol = defun("vector-fill!", vector_fill, 2, 2, false);
+ sc->vector_length_symbol = defun("vector-length", vector_length, 1, 0, false);
+ sc->vector_to_list_symbol = defun("vector->list", vector_to_list, 1, 2, false);
#else
- sc->VECTOR_APPEND = sc->APPEND;
- sc->VECTOR_FILL = sc->FILL;
- sc->STRING_FILL = sc->FILL;
+ sc->vector_append_symbol = sc->append_symbol;
+ sc->vector_fill_symbol = sc->fill_symbol;
+ sc->string_fill_symbol = sc->fill_symbol;
#endif
- sc->VECTOR_REF = defun("vector-ref", vector_ref, 2, 0, true);
- sc->VECTOR_SET = defun("vector-set!", vector_set, 3, 0, true);
- sc->VECTOR_DIMENSIONS = defun("vector-dimensions", vector_dimensions, 1, 0, false);
- sc->MAKE_VECTOR = defun("make-vector", make_vector, 1, 2, false);
- sc->MAKE_SHARED_VECTOR = defun("make-shared-vector", make_shared_vector, 2, 1, false);
- sc->VECTOR = defun("vector", vector, 0, 0, true);
- set_setter(sc->VECTOR); /* like cons, I guess */
- sc->Vector = slot_value(global_slot(sc->VECTOR));
-
- sc->FLOAT_VECTOR = defun("float-vector", float_vector, 0, 0, true);
- sc->MAKE_FLOAT_VECTOR = defun("make-float-vector", make_float_vector, 1, 1, false);
- sc->FLOAT_VECTOR_SET = defun("float-vector-set!", float_vector_set, 3, 0, true);
- sc->FLOAT_VECTOR_REF = defun("float-vector-ref", float_vector_ref, 2, 0, true);
-
- sc->INT_VECTOR = defun("int-vector", int_vector, 0, 0, true);
- sc->MAKE_INT_VECTOR = defun("make-int-vector", make_int_vector, 1, 1, false);
- sc->INT_VECTOR_SET = defun("int-vector-set!", int_vector_set, 3, 0, true);
- sc->INT_VECTOR_REF = defun("int-vector-ref", int_vector_ref, 2, 0, true);
-
- sc->TO_BYTE_VECTOR = defun("->byte-vector", to_byte_vector, 1, 0, false);
- sc->BYTE_VECTOR = defun("byte-vector", byte_vector, 0, 0, true);
- sc->MAKE_BYTE_VECTOR = defun("make-byte-vector", make_byte_vector, 1, 1, false);
-
- sc->HASH_TABLE = defun("hash-table", hash_table, 0, 0, true);
- sc->HASH_TABLE_STAR = defun("hash-table*", hash_table_star, 0, 0, true);
- sc->MAKE_HASH_TABLE = defun("make-hash-table", make_hash_table, 0, 2, false);
- sc->HASH_TABLE_REF = defun("hash-table-ref", hash_table_ref, 2, 0, true);
- sc->HASH_TABLE_SET = defun("hash-table-set!", hash_table_set, 3, 0, false);
- sc->HASH_TABLE_ENTRIES = defun("hash-table-entries", hash_table_entries, 1, 0, false);
-
- defun("cyclic-sequences", cyclic_sequences, 1, 0, false);
- sc->CALL_CC = unsafe_defun("call/cc", call_cc, 1, 0, false);
- sc->CALL_WITH_CURRENT_CONTINUATION = unsafe_defun("call-with-current-continuation", call_cc, 1, 0, false);
- sc->CALL_WITH_EXIT = unsafe_defun("call-with-exit", call_with_exit, 1, 0, false);
-
- sc->LOAD = unsafe_defun("load", load, 1, 1, false);
- sc->AUTOLOAD = unsafe_defun("autoload", autoload, 2, 0, false);
- sc->EVAL = unsafe_defun("eval", eval, 1, 1, false);
- sc->EVAL_STRING = unsafe_defun("eval-string", eval_string, 1, 1, false);
- sc->APPLY = unsafe_defun("apply", apply, 1, 0, true);
- sc->Apply = slot_value(global_slot(sc->APPLY));
- set_type(sc->Apply, type(sc->Apply) | T_COPY_ARGS | T_PROCEDURE);
+ sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true);
+ sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true);
+ sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false);
+ sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false);
+ sc->make_shared_vector_symbol = defun("make-shared-vector", make_shared_vector, 2, 1, false);
+ sc->vector_symbol = defun("vector", vector, 0, 0, true);
+ set_setter(sc->vector_symbol); /* like cons, I guess */
+ sc->vector_function = slot_value(global_slot(sc->vector_symbol));
+
+ sc->float_vector_symbol = defun("float-vector", float_vector, 0, 0, true);
+ sc->make_float_vector_symbol = defun("make-float-vector", make_float_vector, 1, 1, false);
+ sc->float_vector_set_symbol = defun("float-vector-set!", float_vector_set, 3, 0, true);
+ sc->float_vector_ref_symbol = defun("float-vector-ref", float_vector_ref, 2, 0, true);
+
+ sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true);
+ sc->make_int_vector_symbol = defun("make-int-vector", make_int_vector, 1, 1, false);
+ sc->int_vector_set_symbol = defun("int-vector-set!", int_vector_set, 3, 0, true);
+ sc->int_vector_ref_symbol = defun("int-vector-ref", int_vector_ref, 2, 0, true);
+
+ sc->to_byte_vector_symbol = defun("->byte-vector", to_byte_vector, 1, 0, false);
+ sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true);
+ sc->make_byte_vector_symbol = defun("make-byte-vector", make_byte_vector, 1, 1, false);
+
+ sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true);
+ sc->hash_table_star_symbol = defun("hash-table*", hash_table_star, 0, 0, true);
+ sc->make_hash_table_symbol = defun("make-hash-table", make_hash_table, 0, 2, false);
+ sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true);
+ sc->hash_table_set_symbol = defun("hash-table-set!", hash_table_set, 3, 0, false);
+ sc->hash_table_entries_symbol = defun("hash-table-entries", hash_table_entries, 1, 0, false);
+
+ defun("cyclic-sequences", cyclic_sequences, 1, 0, false);
+ sc->call_cc_symbol = unsafe_defun("call/cc", call_cc, 1, 0, false);
+ sc->call_with_current_continuation_symbol = unsafe_defun("call-with-current-continuation", call_cc, 1, 0, false);
+ sc->call_with_exit_symbol = unsafe_defun("call-with-exit", call_with_exit, 1, 0, false);
+
+ sc->load_symbol = unsafe_defun("load", load, 1, 1, false);
+ sc->autoload_symbol = unsafe_defun("autoload", autoload, 2, 0, false);
+ sc->eval_symbol = unsafe_defun("eval", eval, 1, 1, false);
+ sc->eval_string_symbol = unsafe_defun("eval-string", eval_string, 1, 1, false);
+ sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true);
+ sc->apply_function = slot_value(global_slot(sc->apply_symbol));
+ set_type(sc->apply_function, type(sc->apply_function) | T_COPY_ARGS | T_PROCEDURE);
/* (let ((x '((1 2) 3 4))) (catch #t (lambda () (apply apply apply x)) (lambda args 'error)) x) should not mess up x! */
- sc->FOR_EACH = unsafe_defun("for-each", for_each, 2, 0, true);
- sc->MAP = unsafe_defun("map", map, 2, 0, true);
- sc->DYNAMIC_WIND = unsafe_defun("dynamic-wind", dynamic_wind, 3, 0, false);
- /* sc->VALUES = */ unsafe_defun("values", values, 0, 0, true);
- sc->CATCH = unsafe_defun("catch", catch, 3, 0, false);
- sc->THROW = unsafe_defun("throw", throw, 1, 0, true);
- sc->ERROR = unsafe_defun("error", error, 0, 0, true);
+ sc->for_each_symbol = unsafe_defun("for-each", for_each, 2, 0, true);
+ sc->map_symbol = unsafe_defun("map", map, 2, 0, true);
+ sc->dynamic_wind_symbol = unsafe_defun("dynamic-wind", dynamic_wind, 3, 0, false);
+ /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true);
+ sc->catch_symbol = unsafe_defun("catch", catch, 3, 0, false);
+ sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true);
+ sc->error_symbol = unsafe_defun("error", error, 0, 0, true);
/* it's faster to leave error/throw unsafe than to set needs_copied_args and use s7_define_safe_function because copy_list overwhelms any other savings */
- sc->STACKTRACE = defun("stacktrace", stacktrace, 0, 5, false);
+ sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false);
{ /* these are internal for quasiquote's use */
s7_pointer sym;
sym = unsafe_defun("{apply_values}", apply_values, 0, 0, true);
set_immutable(sym);
- sc->QQ_Apply_Values = slot_value(global_slot(sym));
+ sc->qq_apply_values_function = slot_value(global_slot(sym));
sym = unsafe_defun("{append}", append, 0, 0, true);
set_immutable(sym);
- sc->QQ_Append = slot_value(global_slot(sym));
-
- sym = unsafe_defun("{multivector}", qq_multivector, 1, 0, true);
- set_immutable(sym);
- sc->Multivector = slot_value(global_slot(sym));
+ sc->qq_append_function = slot_value(global_slot(sym));
sym = unsafe_defun("{list}", qq_list, 0, 0, true);
set_immutable(sym);
- sc->QQ_List = slot_value(global_slot(sym));
- set_type(sc->QQ_List, T_C_RST_ARGS_FUNCTION | T_PROCEDURE | T_COPY_ARGS);
+ sc->qq_list_function = slot_value(global_slot(sym));
+ set_type(sc->qq_list_function, T_C_RST_ARGS_FUNCTION | T_PROCEDURE | T_COPY_ARGS);
}
- sc->PROCEDURE_DOCUMENTATION = defun("procedure-documentation", procedure_documentation, 1, 0, false);
- sc->PROCEDURE_SIGNATURE = defun("procedure-signature", procedure_signature, 1, 0, false);
- sc->HELP = defun("help", help, 1, 0, false);
- sc->PROCEDURE_SOURCE = defun("procedure-source", procedure_source, 1, 0, false);
- sc->FUNCLET = defun("funclet", funclet, 1, 0, false);
+ sc->procedure_documentation_symbol = defun("procedure-documentation", procedure_documentation, 1, 0, false);
+ sc->procedure_signature_symbol = defun("procedure-signature", procedure_signature, 1, 0, false);
+ sc->help_symbol = defun("help", help, 1, 0, false);
+ sc->procedure_source_symbol = defun("procedure-source", procedure_source, 1, 0, false);
+ sc->funclet_symbol = defun("funclet", funclet, 1, 0, false);
+ sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false);
s7_typed_dilambda(sc, "procedure-setter", g_procedure_setter, 1, 0, g_procedure_set_setter, 2, 0, H_procedure_setter, Q_procedure_setter, NULL);
- sc->ARITY = defun("arity", arity, 1, 0, false);
- sc->IS_ARITABLE = defun("aritable?", is_aritable, 2, 0, false);
+ sc->arity_symbol = defun("arity", arity, 1, 0, false);
+ sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false);
- sc->NOT = defun("not", not, 1, 0, false);
- sc->IS_EQ = defun("eq?", is_eq, 2, 0, false);
- sc->IS_EQV = defun("eqv?", is_eqv, 2, 0, false);
- sc->IS_EQUAL = defun("equal?", is_equal, 2, 0, false);
- sc->IS_MORALLY_EQUAL = defun("morally-equal?", is_morally_equal, 2, 0, false);
+ sc->not_symbol = defun("not", not, 1, 0, false);
+ sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false);
+ sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false);
+ sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false);
+ sc->is_morally_equal_symbol = defun("morally-equal?", is_morally_equal, 2, 0, false);
- sc->GC = defun("gc", gc, 0, 1, false);
- defun("s7-version", s7_version, 0, 0, false);
- defun("emergency-exit", emergency_exit, 0, 1, false);
- defun("exit", exit, 0, 1, false);
+ sc->gc_symbol = defun("gc", gc, 0, 1, false);
+ defun("s7-version", s7_version, 0, 0, false);
+ defun("emergency-exit", emergency_exit, 0, 1, false);
+ defun("exit", exit, 0, 1, false);
#if DEBUGGING
- s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope");
+ s7_define_function(sc, "abort", g_abort, 0, 0, true, "drop into gdb I hope");
#endif
sym = s7_define_function(sc, "(c-object set)", g_internal_object_set, 1, 0, true, "internal object setter redirection");
- sc->Object_Set = slot_value(global_slot(sym));
+ sc->object_set_function = slot_value(global_slot(sym));
+
+ s7_define_safe_function(sc, "tree-leaves", g_tree_leaves, 1, 0, false, "an experiment");
/* -------- *features* -------- */
- sc->S7_FEATURES = s7_define_variable(sc, "*features*", sc->NIL);
- s7_symbol_set_access(sc, sc->S7_FEATURES, s7_make_function(sc, "(set *features*)", g_features_set, 2, 0, false, "*features* accessor"));
+ sc->features_symbol = s7_define_variable(sc, "*features*", sc->nil);
+ s7_symbol_set_access(sc, sc->features_symbol, s7_make_function(sc, "(set *features*)", g_features_set, 2, 0, false, "*features* accessor"));
/* -------- *load-path* -------- */
- sc->LOAD_PATH = s7_define_variable_with_documentation(sc, "*load-path*", sc->NIL, "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name");
- s7_symbol_set_access(sc, sc->LOAD_PATH, s7_make_function(sc, "(set *load-path*)", g_load_path_set, 2, 0, false, "*load-path* accessor"));
+ sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil,
+ "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name");
+ s7_symbol_set_access(sc, sc->load_path_symbol, s7_make_function(sc, "(set *load-path*)", g_load_path_set, 2, 0, false, "*load-path* accessor"));
+
+#ifdef CLOAD_DIR
+ sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR));
+ s7_add_to_load_path(sc, (const char *)CLOAD_DIR);
+#else
+ sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", make_empty_string(sc, 0, 0));
+#endif
+ s7_symbol_set_access(sc, sc->cload_directory_symbol, s7_make_function(sc, "(set *cload-directory*)", g_cload_directory_set, 2, 0, false,
+ "*cload-directory* accessor"));
/* -------- *autoload* --------
* this pretends to be a hash-table or environment, but it's actually a function
*/
- sc->AUTOLOADER = s7_define_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader);
- sym = s7_define_variable(sc, "*libraries*", sc->NIL);
+ sc->autoloader_symbol = s7_define_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader);
+ sym = s7_define_variable(sc, "*libraries*", sc->nil);
sc->libraries = global_slot(sym);
s7_autoload(sc, make_symbol(sc, "cload.scm"), s7_make_permanent_string("cload.scm"));
@@ -73444,12 +73941,12 @@ s7_scheme *s7_init(void)
s7_autoload(sc, make_symbol(sc, "libgdbm.scm"), s7_make_permanent_string("libgdbm.scm"));
s7_autoload(sc, make_symbol(sc, "libutf8proc.scm"), s7_make_permanent_string("libutf8proc.scm"));
- sc->REQUIRE = s7_define_macro(sc, "require", g_require, 0, 0, true, H_require);
+ sc->require_symbol = s7_define_macro(sc, "require", g_require, 0, 0, true, H_require);
sc->stacktrace_defaults = s7_list(sc, 5, small_int(3), small_int(45), small_int(80), small_int(45), sc->T);
/* -------- *#readers* -------- */
- sym = s7_define_variable(sc, "*#readers*", sc->NIL);
+ sym = s7_define_variable(sc, "*#readers*", sc->nil);
sc->sharp_readers = global_slot(sym);
s7_symbol_set_access(sc, sym, s7_make_function(sc, "(set *#readers*)", g_sharp_readers_set, 2, 0, false, "*#readers* accessor"));
@@ -73479,12 +73976,18 @@ s7_scheme *s7_init(void)
#if DEBUGGING
s7_provide(sc, "debugging");
#endif
+#if WITH_PROFILE
+ s7_provide(sc, "profiling");
+#endif
#if HAVE_COMPLEX_NUMBERS
s7_provide(sc, "complex-numbers");
#endif
#if WITH_C_LOADER
s7_provide(sc, "dlopen");
#endif
+#if (!DISABLE_AUTOLOAD)
+ s7_provide(sc, "autoload");
+#endif
#ifdef __APPLE__
s7_provide(sc, "osx");
@@ -73521,26 +74024,26 @@ s7_scheme *s7_init(void)
#endif
- sc->Vector_Set = slot_value(global_slot(sc->VECTOR_SET));
- set_setter(sc->VECTOR_SET);
+ sc->vector_set_function = slot_value(global_slot(sc->vector_set_symbol));
+ set_setter(sc->vector_set_symbol);
/* not float-vector-set! here */
- sc->List_Set = slot_value(global_slot(sc->LIST_SET));
- set_setter(sc->LIST_SET);
+ sc->list_set_function = slot_value(global_slot(sc->list_set_symbol));
+ set_setter(sc->list_set_symbol);
- sc->Hash_Table_Set = slot_value(global_slot(sc->HASH_TABLE_SET));
- set_setter(sc->HASH_TABLE_SET);
+ sc->hash_table_set_function = slot_value(global_slot(sc->hash_table_set_symbol));
+ set_setter(sc->hash_table_set_symbol);
- sc->Let_Set = slot_value(global_slot(sc->LET_SET));
- set_setter(sc->LET_SET);
+ sc->let_set_function = slot_value(global_slot(sc->let_set_symbol));
+ set_setter(sc->let_set_symbol);
- set_setter(sc->CONS); /* (this blocks an over-eager do loop optimization -- see do-test-15 in s7test) */
+ set_setter(sc->cons_symbol); /* (this blocks an over-eager do loop optimization -- see do-test-15 in s7test) */
- sc->String_Set = slot_value(global_slot(sc->STRING_SET));
- set_setter(sc->STRING_SET);
+ sc->string_set_function = slot_value(global_slot(sc->string_set_symbol));
+ set_setter(sc->string_set_symbol);
- set_setter(sc->SET_CAR);
- set_setter(sc->SET_CDR);
+ set_setter(sc->set_car_symbol);
+ set_setter(sc->set_cdr_symbol);
#if (!WITH_PURE_S7)
set_setter(s7_make_symbol(sc, "set-current-input-port"));
@@ -73557,6 +74060,7 @@ s7_scheme *s7_init(void)
* current-error-port should simply be an s7 variable with a name like *error-port* and an accessor to
* ensure its new value, if any, is an output port.
*/
+
s7_function_set_setter(sc, "car", "set-car!");
s7_function_set_setter(sc, "cdr", "set-cdr!");
@@ -73567,8 +74071,8 @@ s7_scheme *s7_init(void)
s7_function_set_setter(sc, "list-ref", "list-set!");
s7_function_set_setter(sc, "let-ref", "let-set!");
s7_function_set_setter(sc, "string-ref", "string-set!");
- c_function_setter(slot_value(global_slot(sc->OUTLET))) = s7_make_function(sc, "(set! outlet)", g_set_outlet, 2, 0, false, "outlet setter");
-
+ c_function_setter(slot_value(global_slot(sc->outlet_symbol))) = s7_make_function(sc, "(set! outlet)", g_set_outlet, 2, 0, false, "outlet setter");
+ c_function_setter(slot_value(global_slot(sc->port_line_number_symbol))) = s7_make_function(sc, "(set! port-line-number)", g_set_port_line_number, 1, 1, false, "port line setter");
{
int i, top;
#if WITH_GMP
@@ -73602,7 +74106,7 @@ s7_scheme *s7_init(void)
if (top == 4) sc->default_rationalize_error = 1.0e-6;
s7_define_constant(sc, "pi", real_pi);
- sc->PI = s7_make_symbol(sc, "pi");
+ sc->pi_symbol = s7_make_symbol(sc, "pi");
{
s7_pointer p;
@@ -73623,13 +74127,13 @@ s7_scheme *s7_init(void)
}
for (i = 0; i < 10; i++) sc->singletons[(unsigned char)'0' + i] = small_int(i);
- sc->singletons[(unsigned char)'+'] = sc->ADD;
- sc->singletons[(unsigned char)'-'] = sc->SUBTRACT;
- sc->singletons[(unsigned char)'*'] = sc->MULTIPLY;
- sc->singletons[(unsigned char)'/'] = sc->DIVIDE;
- sc->singletons[(unsigned char)'<'] = sc->LT;
- sc->singletons[(unsigned char)'>'] = sc->GT;
- sc->singletons[(unsigned char)'='] = sc->EQ;
+ sc->singletons[(unsigned char)'+'] = sc->add_symbol;
+ sc->singletons[(unsigned char)'-'] = sc->subtract_symbol;
+ sc->singletons[(unsigned char)'*'] = sc->multiply_symbol;
+ sc->singletons[(unsigned char)'/'] = sc->divide_symbol;
+ sc->singletons[(unsigned char)'<'] = sc->lt_symbol;
+ sc->singletons[(unsigned char)'>'] = sc->gt_symbol;
+ sc->singletons[(unsigned char)'='] = sc->eq_symbol;
}
#if WITH_GMP
@@ -73640,15 +74144,7 @@ s7_scheme *s7_init(void)
s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote);
- s7_eval_c_string(sc, "(define (dilambda g s) \n\
- (if (or (not (arity g)) (not (arity s))) \n\
- (error 'wrong-type-arg \"dilambda takes 2 procedures: ~A ~A\" g s) \n\
- (set! (procedure-setter g) s)) \n\
- g)");
-
#if (!WITH_PURE_S7)
- s7_eval_c_string(sc, "(define hash-table-size length)"); /* backwards compatibility */
-
s7_eval_c_string(sc, "(define-macro (defmacro name args . body) `(define-macro ,(cons name args) , at body))");
s7_eval_c_string(sc, "(define-macro (defmacro* name args . body) `(define-macro* ,(cons name args) , at body))");
@@ -73656,28 +74152,14 @@ s7_scheme *s7_init(void)
/* (call-with-values (lambda () (values 1 2 3)) +) */
s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) \n\
- (if (or (symbol? vars) (negative? (length vars))) \n\
- `((lambda ,vars , at body) ,expression) \n\
- `((lambda* (, at vars . ,(gensym)) , at body) ,expression)))");
- /* (multiple-value-bind (a b) (values 1 2) (+ a b)), named "receive" in srfi-8 which strikes me as perverse */
-
- s7_eval_c_string(sc, "(define-macro (multiple-value-set! vars expr . body) \n\
- (if (pair? vars) \n\
- (let ((local-vars (map (lambda (n) (gensym)) vars))) \n\
- `((lambda* (, at local-vars . ,(gensym)) \n\
- ,@(map (lambda (n ln) `(set! ,n ,ln)) vars local-vars) \n\
- , at body) \n\
- ,expr)) \n\
- (if (and (null? vars) (null? expr)) \n\
- `(begin , at body) \n\
- (error \"multiple-value-set! vars/exprs messed up\"))))");
+ `((lambda ,vars , at body) ,expression))");
s7_eval_c_string(sc, "(define-macro (cond-expand . clauses) \n\
(letrec ((traverse (lambda (tree) \n\
(if (pair? tree) \n\
(cons (traverse (car tree)) \n\
(if (null? (cdr tree)) () (traverse (cdr tree)))) \n\
- (if (member tree '(and or not else) eq?) tree \n\
+ (if (memq tree '(and or not else)) tree \n\
(and (symbol? tree) (provided? tree))))))) \n\
`(cond ,@(map (lambda (clause) \n\
(cons (traverse (car clause)) \n\
@@ -73693,33 +74175,39 @@ s7_scheme *s7_init(void)
(let ((val (eval (car clause)))) \n\
(if val \n\
(if (null? (cdr clause)) (return val) \n\
- (if (null? (cddr clause)) (return (cadr clause)) \n\
+ (if (null? (cddr clause)) \n\
+ (return (cadr clause)) \n\
(return (apply values (map quote (cdr clause))))))))) \n\
clauses) \n\
(values))))");
- s7_eval_c_string(sc, "(define (make-hook . args) \n\
- (let ((body ())) \n\
- (apply lambda* args \n\
- '(let ((result #<unspecified>)) \n\
- (let ((e (curlet))) \n\
- (for-each (lambda (f) (f e)) body) \n\
- result)) \n\
- ())))");
+ s7_eval_c_string(sc, "(define make-hook \n\
+ (let ((signature '(procedure? #t)) \n\
+ (documentation \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\
+ (lambda args \n\
+ (let ((body ())) \n\
+ (apply lambda* args \n\
+ '(let ((result #<unspecified>)) \n\
+ (let ((e (curlet))) \n\
+ (for-each (lambda (f) (f e)) body) \n\
+ result)) \n\
+ ())))))");
s7_eval_c_string(sc, "(define hook-functions \n\
- (dilambda \n\
- (lambda (hook) \n\
- ((funclet hook) 'body)) \n\
- (lambda (hook lst) \n\
- (if (or (null? lst) \n\
- (and (pair? lst) \n\
- (apply and (map (lambda (f) \n\
- (and (procedure? f) \n\
- (aritable? f 1))) \n\
- lst)))) \n\
- (set! ((funclet hook) 'body) lst) \n\
- (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst)))))");
+ (let ((signature '(list? procedure?)) \n\
+ (documentation \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\
+ (dilambda \n\
+ (lambda (hook) \n\
+ ((funclet hook) 'body)) \n\
+ (lambda (hook lst) \n\
+ (if (or (null? lst) \n\
+ (and (pair? lst) \n\
+ (apply and (map (lambda (f) \n\
+ (and (procedure? f) \n\
+ (aritable? f 1))) \n\
+ lst)))) \n\
+ (set! ((funclet hook) 'body) lst) \n\
+ (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))");
/* -------- *unbound-variable-hook* -------- */
sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)");
@@ -73741,21 +74229,27 @@ s7_scheme *s7_init(void)
s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook,
"*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data).");
+ /* -------- *read-error-hook* -------- */
+ sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
+ s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook,
+ "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data).");
+
s7_define_constant(sc, "*s7*",
s7_openlet(sc, s7_inlet(sc,
s7_list(sc, 2,
- s7_cons(sc, sc->LET_REF_FALLBACK, s7_make_function(sc, "s7-let-ref", g_s7_let_ref_fallback, 2, 0, false, "*s7* reader")),
- s7_cons(sc, sc->LET_SET_FALLBACK, s7_make_function(sc, "s7-let-set", g_s7_let_set_fallback, 3, 0, false, "*s7* writer"))))));
+ s7_cons(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "s7-let-ref", g_s7_let_ref_fallback, 2, 0, false, "*s7* reader")),
+ s7_cons(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "s7-let-set", g_s7_let_set_fallback, 3, 0, false, "*s7* writer"))))));
#if (!DISABLE_DEPRECATED)
- s7_eval_c_string(sc, "(define global-environment rootlet) \n\
- (define current-environment curlet) \n\
- (define make-procedure-with-setter dilambda) \n\
- (define procedure-with-setter? dilambda?)\n\
- (define make-random-state random-state) \n\
- (define make-complex complex) \n\
- (define (procedure-arity obj) (let ((c (arity obj))) (list (car c) (- (cdr c) (car c)) (> (cdr c) 100000))))");
+ s7_eval_c_string(sc, "(begin \n\
+ (define global-environment rootlet) \n\
+ (define current-environment curlet) \n\
+ (define make-procedure-with-setter dilambda) \n\
+ (define procedure-with-setter? dilambda?)\n\
+ (define make-random-state random-state) \n\
+ (define make-complex complex) \n\
+ (define (procedure-arity obj) (let ((c (arity obj))) (list (car c) (- (cdr c) (car c)) (> (cdr c) 100000)))))");
#endif
/* fprintf(stderr, "size: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), OP_MAX_DEFINED, OPT_MAX_DEFINED); */
@@ -73765,9 +74259,6 @@ s7_scheme *s7_init(void)
fprintf(stderr, "s7_int is too small: it has %d bytes, but void* has %d\n", (int)sizeof(s7_int), (int)sizeof(void *));
save_unlet(sc);
-#if WITH_COUNTS
- clear_counts();
-#endif
init_s7_let(sc); /* set up *s7* */
already_inited = true;
@@ -73827,27 +74318,29 @@ int main(int argc, char **argv)
#endif
-/* ----------------------------------------------------
+/* --------------------------------------------------------------------
*
- * 12 | 13 | 14 | 15 | 16.0 16.1
+ * 12 | 13 | 14 | 15 | 16.0 16.1 16.2 16.6
*
- * s7test 1721 | 1358 | 995 | 1194 | 1122 1117
- * index 44.3 | 3291 | 1725 | 1276 | 1156 1158
- * teq | | | 6612 | 2380 2376
- * tauto 265 | 89 | 9 | 8.4 | 2638 2643
- * tcopy | | | 13.6 | 3204 3203
- * bench 42.7 | 8752 | 4220 | 3506 | 3230 3229
- * tform | | | 6816 | 3627 3589
- * tmap | | | 9.3 | 4176 4177
- * titer | | | 7503 | 5218 5219
- * thash | | | 50.7 | 8491 8484
- * lg | | | | 20.7
+ * s7test 1721 | 1358 | 995 | 1194 | 1122 1117 1295
+ * index 44.3 | 3291 | 1725 | 1276 | 1156 1158 1159
+ * teq | | | 6612 | 2380 2376 2382
+ * tauto 265 | 89 | 9 | 8.4 | 2638 2643 2644
+ * tcopy | | | 13.6 | 3204 3203 3204
+ * bench 42.7 | 8752 | 4220 | 3506 | 3230 3229 3218
+ * tform | | | 6816 | 3627 3589 3621
+ * tmap | | | 9.3 | 4176 4177 4173
+ * titer | | | 7503 | 5218 5219 5211
+ * thash | | | 50.7 | 8491 8484 8477
+ * lg | | | |
* | | | |
- * tgen | 71 | 70.6 | 38.0 | 12.0 11.7
- * tall 90 | 43 | 14.5 | 12.7 | 15.0 15.0
- * calls 359 | 275 | 54 | 34.7 | 37.1 37.0
+ * tgen | 71 | 70.6 | 38.0 | 12.0 11.7 11.8
+ * tall 90 | 43 | 14.5 | 12.7 | 15.0 15.0 15.0
+ * calls 359 | 275 | 54 | 34.7 | 37.1 37.0 37.2
*
- * ----------------------------------------------------
+ * --------------------------------------------------------------------
+ *
+ * new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive
*
* mockery.scm needs documentation (and stuff.scm: doc cyclic-seq+stuff under circular lists)
* cyclic-seq in stuff.scm, but current code is really clumsy
@@ -73856,11 +74349,25 @@ int main(int argc, char **argv)
* snd namespaces from <mark> etc mark: (inlet :type 'mark :name "" :home <channel> :sample 0 :sync #f) with name/sync/sample settable
* doc c_object_rf stuff? or how cload ties things into rf/sig
* libutf8proc.scm doc/examples? cload gtk/sndlib
- * remove the #t=all sounds business! = (map f (sounds))
- * gf cases (rf/if also): substring [inlet list vector float-vector int-vector] hash-table(*) sublet string format vector-append string-append append
+ * display of let can still get into infinite recursion!
+ * when trying to display a big 128-channel file, Snd cores up until it crashes?
+ * check stdin-prompt and s7webserver
+ * (> (length x) 1) and friends could be optimized by quitting as soon as possible
+ * doc (set! (with-let...) ...) and let-temporarily? this could also be greatly optimized
+ * with-let and unlet don't need to be constants
+ * (define-macro (import e) `(#_varlet (#_curlet) ,e)) or something like that?
+ *
* clm make-* sig should include the actual gen: oscil->(float? oscil? real?), also make->actual not #t in a circle
* make-oscil -> '(oscil? real? real)
* make-env -> '(env? sequence? real? real? real? real? integer? integer?) [seq here is actually pair? or float-vector?]
+ * need some semi-automated approach here
+ * also need rest of Snd signatures
+ *
+ * dac loop [need start/end of loop in dac_info, reader goes to start when end reached (requires rebuffering)
+ * looper does not stop/restart -- just keep going]
+ * play_selection_1 could puts ends somewhere, set ends to NO_END_SPECIFIED, dac_loop_sample can
+ * use begs/other-ends to get loop points, so free_dac_info does not need to restart the loop(?)
+ * If start/end selection changed while playing, are these loop points updated?
*
* how to get at read-error cause in catch? port-data=string, port-position=int, port_data_size=int last-open-paren (sc->current_line)
* port-data port-position, length=remaining (unread) chars, copy->string gets that data, so no need for new funcs
@@ -73873,30 +74380,4 @@ int main(int argc, char **argv)
* (append "asd" ((*mock-char* 'mock-char) #\g)): error: append argument 1, #\g, is mock-char but should be a sequence
* also arg num is incorrect -- always off by 1?
* append in string case uses string_append, not g_string_append!
- *
- * lint: simple type->bool outside if et al?? [if car sig boolean? simplify]
- * closure sig from body (and side-effects), expand args in code for internal lint?
- * if closure depends only on arg (no free var, no funcs other than built-ins) and has no side-effects, and gets constant arg, eval?
- * define* lambda* key-opt-key ordering and recognition -- split out arity/type/side-effect/self-contained (are globals in the var list?)
- * first step done, now make-var -> sublet/inlet, handle the todo's in lint.scm, t330 lambda case
- * also are defines in begin exported? also when etc.
- * for class let: arity, procedure?, macro?, object->string, for var: sig and side decisions, macro tests
- * can we match cc/exit args to the caller? error-args to the catcher?
- * :rest with default
- * macros that cause definitions are ignored (this also affects variable usage stats) and cload'ed identifiers are missed
- * variable not used can be confused (prepend-spaces and display-let in stuff.scm)
- * catch func arg checks (thunk, any args)
- * code that can be make-list|string or vector|string etc
- * morally-equal? for vector equality
- * do we catch (not (when...))? it's not necessarily a mistake.
- * letrec -> let (as in index.scm) [if none of letrec vars (including current) occurs in any of the bindings, use let]
- * can letrec* -> let* if there are no forward refs? ->letrec if no cross dependencies?
- * can the reverse be recognized (i.e. no occurrence of name in outer env, use in let before decl)?
- * kw passed to define? non-hygienic macro problem (these should be obvious from the calling args and current env)
- *
- * static s7_int abs_if_i(s7_scheme *sc, s7_pointer **p){s7_if_t f; s7_int x; f = (s7_if_t)(**p); (*p)++; x = f(sc, p); return(abs(x));}
- * in libc_s7.c -- this should use llabs or cast the argument, or do abs by hand.
- * (define (f f) (define* (f (f f)) f) (f)) (f 0): error: lambda* defaults: f is unbound??
- * (define* (f2 a :rest b) (list a b)), (f2 1 :a 1) is not an error? at least in lint point out that here :a does not set a
- * (define (f1 f1) f1) is also ok?
*/
diff --git a/s7.h b/s7.h
index 3f50df7..e4b09c8 100644
--- a/s7.h
+++ b/s7.h
@@ -1,8 +1,8 @@
#ifndef S7_H
#define S7_H
-#define S7_VERSION "4.2"
-#define S7_DATE "6-Nov-15"
+#define S7_VERSION "4.6"
+#define S7_DATE "20-Feb-16"
typedef long long int s7_int; /* This sets the size of integers in Scheme; it needs to be big enough to accomodate a C pointer. */
typedef double s7_double; /* similarly for Scheme reals; only "double" works in C++ */
@@ -67,6 +67,7 @@ char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj); /* same as
/* the returned value should be freed by the caller */
s7_pointer s7_load(s7_scheme *sc, const char *file); /* (load file) */
+s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e);
s7_pointer s7_load_path(s7_scheme *sc); /* *load-path* */
s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir); /* (set! *load-path* (cons dir *load-path*)) */
s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function); /* (autoload symbol file-or-function) */
@@ -83,8 +84,6 @@ 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 */
-s7_pointer s7_eval_form(s7_scheme *sc, s7_pointer form, s7_pointer e);
-
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) */
@@ -218,6 +217,7 @@ s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /*
s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (member obj lst) */
s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (memq obj lst) */
+
bool s7_is_string(s7_pointer p); /* (string? p) */
const char *s7_string(s7_pointer p); /* Scheme string -> C string (do not free the string) */
s7_pointer s7_make_string(s7_scheme *sc, const char *str); /* C string -> Scheme string (str is copied) */
@@ -225,6 +225,7 @@ s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, int len);
s7_pointer s7_make_permanent_string(const char *str); /* make a string that will never be GC'd */
unsigned int s7_string_length(s7_pointer str); /* (string-length str) */
+
bool s7_is_character(s7_pointer p); /* (character? p) */
char s7_character(s7_pointer p); /* Scheme character -> C char */
s7_pointer s7_make_character(s7_scheme *sc, unsigned int c); /* C char (as unsigned int) -> Scheme character */
@@ -296,8 +297,9 @@ void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj);
s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect);
s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect); /* (vector->list vec) */
+
s7_int s7_print_length(s7_scheme *sc); /* value of (*s7* 'print-length) */
-s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len);
+s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len); /* sets (*s7* 'print-length), returns old value */
/*
* (vect i) is the same as (vector-ref vect i)
@@ -370,10 +372,10 @@ s7_pointer s7_make_signature(s7_scheme *sc, int len, ...); /* p
s7_pointer s7_make_circular_signature(s7_scheme *sc, int cycle_point, int len, ...);
bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args); /* (aritable? x args) */
s7_pointer s7_arity(s7_scheme *sc, s7_pointer x); /* (arity x) */
-
const char *s7_help(s7_scheme *sc, s7_pointer obj); /* (help obj) */
-
s7_pointer s7_make_continuation(s7_scheme *sc); /* call/cc... (see example below) */
+
+
bool s7_is_syntax(s7_pointer p);
bool s7_is_symbol(s7_pointer p); /* (symbol? p) */
const char *s7_symbol_name(s7_pointer p); /* (symbol->string p) -- don't free the string */
@@ -386,24 +388,26 @@ s7_pointer s7_make_keyword(s7_scheme *sc, const char *key); /* (
s7_pointer s7_symbol_access(s7_scheme *sc, s7_pointer sym);
s7_pointer s7_symbol_set_access(s7_scheme *sc, s7_pointer symbol, s7_pointer func);
+
s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol);
s7_pointer s7_slot_value(s7_pointer slot);
s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value);
s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
+
s7_pointer s7_rootlet(s7_scheme *sc); /* (rootlet) */
s7_pointer s7_shadow_rootlet(s7_scheme *sc);
s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let);
s7_pointer s7_curlet(s7_scheme *sc); /* (curlet) */
s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e); /* returns previous curlet */
- s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); /* (outlet e) */
+s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); /* (outlet e) */
s7_pointer s7_sublet(s7_scheme *sc, s7_pointer env, s7_pointer bindings); /* (sublet e ...) */
s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings); /* (inlet ...) */
s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env); /* (let->list env) */
bool s7_is_let(s7_pointer e); /* )let? e) */
s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer sym); /* (let-ref e sym) */
s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */
- s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); /* (openlet e) */
+s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); /* (openlet e) */
bool s7_is_openlet(s7_pointer e); /* (openlet? e) */
s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method);
@@ -762,6 +766,7 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
#define s7_define_integer_function s7_define_safe_function
#define s7_make_random_state s7_random_state
+#define s7_eval_form s7_eval
#endif
@@ -770,6 +775,14 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
*
* s7 changes
*
+ * 20-Feb: removed last vestiges of quasiquoted vector support.
+ * 3-Feb: *cload-directory*.
+ * 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number.
+ * 7-Jan: s7_load_with_environment.
+ * s7_eval_c_string takes only one statement now (use begin to handle multiple statements)
+ * 4-Jan-16: remove s7_eval_form, change s7_eval to take its place.
+ * --------
+ * 11-Dec: owlet error-history field if WITH_HISTORY=1
* 6-Nov: removed :key and :optional.
* 16-Oct: s7_make_random_state -> s7_random_state.
* 16-Aug: remove s7_define_integer_function, s7_function_set_removes_temp,
@@ -801,7 +814,7 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
* --------
* 8-Nov: s7_symbol_documentation, s7_define_constant_with_documentation.
* 17-Oct: bignum-precision (procedure-with-setter) is now an integer variable named *bignum-precision*.
- * 28-Aug: s7_int|float_vector_elements (homogenous vectors), libc.scm.
+ * 28-Aug: s7_int|float_vector_elements (homogeneous vectors), libc.scm.
* 16-Aug: ~W directive in format, make-shared-vector.
* 23-Jul: s7_autoload_set_names, libm.scm, libdl.scm, libgdbm.scm, r7rs.scm, s7libtest.scm.
* 21-Jul: s7_is_valid (replaces deprecated s7_is_valid_pointer).
diff --git a/s7.html b/s7.html
index fa23b97..2c30a06 100644
--- a/s7.html
+++ b/s7.html
@@ -146,7 +146,7 @@
<p>s7 is a Scheme implementation intended as an extension language
-for other applications, primarily Snd and Common Music. It exists as just two files, s7.c and
+for other applications, primarily Snd, Radium, and Common Music. It exists as just two files, s7.c and
s7.h, that want only to disappear into someone else's source tree. There are no libraries,
no run-time init files, and no configuration scripts.
It can be built as a stand-alone
@@ -156,7 +156,8 @@ A tarball is available: ftp://ccrma-ftp.stanford.edu/pub/Lisp/s7.tar.gz.
<p>
s7 is the default extension language of Snd and sndlib (http://ccrma.stanford.edu/software/snd/),
-and Rick Taube's Common Music (commonmusic at sourceforge). There are X, Motif, Gtk, and openGL bindings
+Rick Taube's Common Music (commonmusic at sourceforge), and Kjetil Matheussen's Radium music editor.
+There are X, Motif, Gtk, and openGL bindings
in libxm in the Snd tarball, or at ftp://ccrma-ftp.stanford.edu/pub/Lisp/libxm.tar.gz.
If you're running s7 in a context
that has getenv, file-exists?, and system, you can use s7-slib-init.scm
@@ -227,7 +228,7 @@ indented and on a sort of brownish background.
<li><a href="#makelist">make-list</a>, <a href="#charposition">char-position</a>, <a href="#keywords">keywords</a>
<li><a href="#symboltable">symbol-table</a>, <a href="#s7help">help</a>, <a href="#s7gc">gc</a>, <a href="#morallyequalp">morally-equal?</a>
<li><a href="#expansion">define-expansion</a>, <a href="#s7env">*s7*</a>, <a href="#s7vsr5rs">r5rs</a>, <a href="#r7rs">r7rs</a>,
- <li><a href="#circle">circular lists</a>, <a href="#legolambda">legolambda</a>, etc...
+ <li><a href="#profiling">profiling</a>, <a href="#circle">circular lists</a>, <a href="#legolambda">legolambda</a>, etc...
</ul>
<li class="li_header"><a href="#FFIexamples">FFI examples</a>
@@ -257,7 +258,6 @@ indented and on a sort of brownish background.
<li class="li_header"><a href="#s7examples">s7 examples</a>
<ul>
- <li><a href="#lint">lint.scm</a>
<li><a href="#cload">cload.scm</a>
<ul>
<li><a href="#libc">libc</a>
@@ -265,6 +265,7 @@ indented and on a sort of brownish background.
<li><a href="#libgdbm">libgdbm</a>
</ul>
<li><a href="#schemerepl">repl.scm</a>
+ <li><a href="#lint">lint.scm</a>
</ul>
</ul>
@@ -634,9 +635,8 @@ have any number after, for example, #b:
(let ((cur (ints i)))
(if (= i 0)
(set! 1s (logior 1s (logand cur (apply log-n-of (- n 1) (cdr ints)))))
- (let* ((mid (cdr prev))
- (nxt (if (= i (- len 1)) () (cdr mid))))
- (set! (cdr prev) nxt)
+ (let ((mid (cdr prev)))
+ (set! (cdr prev) (if (= i (- len 1)) () (cdr mid)))
(set! 1s (logior 1s (logand cur (apply log-n-of (- n 1) ints))))
(set! (cdr prev) mid)
(set! prev mid)))))))))
@@ -690,7 +690,7 @@ above as an example:
<em class="gray">(3 2 1)</em>
</pre>
-<p>See s7test.scm for many examples.
+<p>See s7test.scm for many examples. (s7's define* is very close to srfi-89's define*).
</p>
@@ -847,12 +847,15 @@ implement the standard old-time macros.
</p>
<pre class="indented">
+> (define-macro (and-let* vars . body)
+ `(let () (and ,@(map (lambda (v) `(define , at v)) vars) (begin , at body))))
+
> (define-macro (<em class=def id="trace">trace</em> f)
`(define ,f
(apply lambda 'args
- `((format #t "(~A ~{~A~^ ~}) -> " ',',f args)
+ `((format () "(~A ~{~A~^ ~}) -> " ',',f args)
(let ((val (apply ,,f args)))
- (format #t "~A~%" val)
+ (format () "~A~%" val)
val)))))
<em class="gray">trace</em>
> (trace abs)
@@ -1049,21 +1052,21 @@ and assign it to a variable. You can even set its procedure-setter!
</p>
<pre class="indented">
(define-macro (fully-macroexpand form)
- (define (expand form)
- (if (pair? form)
- (if (and (symbol? (car form))
- (macro? (symbol->value (car form))))
- (expand (apply macroexpand (list form)))
- (if (and (eq? (car form) 'set!) ; look for (set! (mac ...) ...) and use mac's procedure-setter
- (pair? (cdr form))
- (pair? (cadr form))
- (macro? (symbol->value (caadr form))))
- (expand (apply (eval (procedure-source (procedure-setter (symbol->value (caadr form)))))
- (append (cdadr form) (cddr form))))
- (cons (expand (car form))
- (expand (cdr form)))))
- form))
- (list 'quote (expand form)))
+ (list 'quote
+ (let expand ((form form))
+ (cond ((not (pair? form)) form)
+ ((and (symbol? (car form))
+ (macro? (symbol->value (car form))))
+ (expand (apply macroexpand (list form))))
+ ((and (eq? (car form) 'set!) ; look for (set! (mac ...) ...) and use mac's procedure-setter
+ (pair? (cdr form))
+ (pair? (cadr form))
+ (macro? (symbol->value (caadr form))))
+ (expand
+ (apply (eval
+ (procedure-source (procedure-setter (symbol->value (caadr form)))))
+ (append (cdadr form) (cddr form)))))
+ (else (cons (expand (car form)) (expand (cdr form))))))))
</pre>
<p>This does not always handle bacros correctly because their expansion can depend on the run-time
state.
@@ -1260,9 +1263,33 @@ control over the environment at any point:
> (let ((a 1) (+ *)) (mac a))
<em class="gray">13</em>
+
+(define-macro (mac1 . b) ; originally `(let ((a 12)) (+ a , at b , at b))
+ `(with-let (inlet 'e (curlet)) ; this 'e will not collide with the calling env
+ (let ((a 12)) ; nor will 'a (so no gensyms are needed etc)
+ (+ a (with-let e , at b) (with-let e , at b)))))
+
+> (let ((a 1) (e 2)) (mac1 (display a) (+ a e)))
+<em class="gray">18</em> ; (and it displays "11")
+
+(define-macro (mac2 x) ; this will use mac2's definition environment for its body
+ `(with-let (sublet (funclet mac2) :x ,x)
+ (let ((a 12))
+ (+ a b x)))) ; a is always 12, b is whatever b happens to be in mac2's env
+
+> (define b 10) ; this is mac2's b
+<em class="gray">10</em>
+> (let ((+ *) (a 1) (b 15)) (mac2 (+ a b)))
+<em class="gray">37</em> ; mac2 uses its own a (12), b (10), and + (+)
+ ; but (+ a b) is 15 because at that point + is *: (* 1 15)
</pre>
-<p>So s7 does not have syntax-rules because it is not needed.
+<p>Hygenic macros are trivial! So s7 does not have syntax-rules because it is not needed.
+s7's lint.scm will warn you about any such problematic macro expansion, so I'd
+say just write macros as simply as possible, then let lint tell you
+that it's time to do the with-let shuffle. When that happens, wrap the macro body in
+a with-let that captures the current environment, and at each use of a macro argument
+wrap it in a with-let that re-establishes that environment.
</p>
<div class="indented">
@@ -1556,7 +1583,7 @@ value passed to set!:
(gotos ())
(come-froms ()))
- (define (collect-jumps tree)
+ (let collect-jumps ((tree body))
(when (pair? tree)
(when (pair? (car tree))
(case (caar tree)
@@ -1566,8 +1593,6 @@ value passed to set!:
(else (collect-jumps (car tree)))))
(collect-jumps (cdr tree))))
- (collect-jumps body)
-
(for-each
(lambda (goto)
(let* ((name (cadr (cadar goto)))
@@ -1659,32 +1684,32 @@ Here's a generic FFT:
(let ((temp (data j)))
(set! (data j) (data i))
(set! (data i) temp)))
- (let ((m (/ n 2)))
- (do ()
- ((or (< m 2) (< j m)))
- (set! j (- j m))
- (set! m (/ m 2)))
- (set! j (+ j m))))
- (let ((ipow (floor (log n 2)))
- (prev 1))
- (do ((lg 0 (+ lg 1))
- (mmax 2 (* mmax 2))
- (pow (/ n 2) (/ pow 2))
- (theta (complex 0.0 (* pi dir)) (* theta 0.5)))
- ((= lg ipow))
- (let ((wpc (exp theta))
- (wc 1.0))
- (do ((ii 0 (+ ii 1)))
- ((= ii prev))
- (do ((jj 0 (+ jj 1))
- (i ii (+ i mmax))
- (j (+ ii prev) (+ j mmax)))
- ((>= jj pow))
- (let ((tc (* wc (data j))))
- (set! (data j) (- (data i) tc))
- (set! (data i) (+ (data i) tc))))
- (set! wc (* wc wpc)))
- (set! prev mmax))))
+ (do ((m (/ n 2)))
+ ((or (< m 2)
+ (< j m))
+ (set! j (+ j m)))
+ (set! j (- j m))
+ (set! m (/ m 2))))
+ (do ((ipow (floor (log n 2)))
+ (prev 1)
+ (lg 0 (+ lg 1))
+ (mmax 2 (* mmax 2))
+ (pow (/ n 2) (/ pow 2))
+ (theta (complex 0.0 (* pi dir)) (* theta 0.5)))
+ ((= lg ipow))
+ (let ((wpc (exp theta))
+ (wc 1.0))
+ (do ((ii 0 (+ ii 1)))
+ ((= ii prev))
+ (do ((jj 0 (+ jj 1))
+ (i ii (+ i mmax))
+ (j (+ ii prev) (+ j mmax)))
+ ((>= jj pow))
+ (let ((tc (* wc (data j))))
+ (set! (data j) (- (data i) tc))
+ (set! (data i) (+ (data i) tc))))
+ (set! wc (* wc wpc)))
+ (set! prev mmax)))
data)
> (cfft! (list 0.0 1+i 0.0 0.0))
@@ -1910,10 +1935,10 @@ vector-dimensions returns a list of the dimensions.
</pre>
<p>make-vector also takes an optional fourth argument. If it is #t, and the initial-value
-is either an integer or a real, make-vector produces a homogenous vector, a vector that
+is either an integer or a real, make-vector produces a homogeneous vector, a vector that
can only hold elements of the same type as the initial value (either s7_int or s7_double
-internally). Homogenous vectors are mostly useful in conjunction with C code. These
-homogenous vector functions are currently built-in:
+internally). Homogeneous vectors are mostly useful in conjunction with C code. These
+homogeneous vector functions are currently built-in:
</p>
<pre class="indented">
@@ -2004,9 +2029,10 @@ homogenous vector functions are currently built-in:
((= y height))
(do ((x 0 (+ x 1)))
((= x width))
- (if (zero? (state0 x y))
- (format *stderr* " ") ; ESC 07m below = inverse
- (format *stderr* "~C[07m ~C[m" #\escape #\escape)))
+ (format *stderr*
+ (if (zero? (state0 x y))
+ " " ; ESC 07m below = inverse
+ (values "~C[07m ~C[m" #\escape #\escape))))
(format *stderr* "~C[E" #\escape)) ; ESC E = next line
;; get the next state
@@ -2122,7 +2148,7 @@ Perhaps we could use different colors? Or different size parentheses?
#2D<em class="bigger">(</em><em class="big">(</em>(0) (0) ((0))<em class="big">)</em> <em class="big">(</em>(0) 0 ((0))<em class="big">)</em><em class="bigger">)</em>
</pre>
-<p>A similar problem afflicts homogenous vectors. We need some reasonable way to express
+<p>A similar problem afflicts homogeneous vectors. We need some reasonable way to express
such a vector even when it has more than one dimension. My first thought was <code>#(...)#</code>,
but that makes <code>(let ((b1 0)) (#(1 2)#b1))</code> ambiguous.
</p>
@@ -2168,15 +2194,9 @@ This also affects format and sort!:
<div class="indented">
-<p>Another question: should we accept the multi-index syntax in a case such as:
-</p>
-
-<pre class="indented">
-(let ((v #("abc" "def")))
- (v 0 2))
-</pre>
-
-<p>My first thought was that the indices should all refer to the same
+<p>Another question: should we accept the multi-index syntax in a case such as <code>
+(#("abc" "def") 0 2)</code>?
+My first thought was that the indices should all refer to the same
type of object, so s7 would complain in a mixed case like that.
If we can nest any applicable objects and apply the whole thing to
an arbitrary list of indices, ambiguities arise:
@@ -2286,9 +2306,7 @@ an entry, <code>'(key . value)</code>, in whatever order the entries are encount
(map values table))
(define (merge-hash-tables . tables) ; probably faster: (define merge-hash-tables append)
- (apply hash-table
- (apply append
- (map hash-table->alist tables))))
+ (apply hash-table (apply map values hash-tables)))
</pre>
<p>reverse of a hash-table returns a new table with the keys and values reversed.
@@ -2634,8 +2652,8 @@ such as abs, we need to put it back to its original form:
(for-each ; see if any built-in functions were stepped on
(lambda (sym)
(unless (assoc (car sym) e)
- (format #t "~S clobbered ~A~%" file (car sym))
- (apply set! (car sym) (list (cdr (assoc (car sym) new-e))))))
+ (format () "~S clobbered ~A~%" file (car sym))
+ (apply set! (car sym) (list (cdr sym)))))
new-e))))
;; say libtest.scm has the line (set! abs odd?)
@@ -2673,20 +2691,21 @@ function if it exists. A bare-bones example:
<p>In CLOS, we'd declare a class and a method, and call make-instance,
and then discover that it wouldn't work anyway.
Here we have, in effect, an anonymous instance of an anonymous class.
+I think this is called a "prototype system"; javascript is apparently similar.
A slightly more complex example:
</p>
<pre class="indented">
-(let ((e1 (openlet
+(let* ((e1 (openlet
(inlet
'x 3
'* (lambda args
- (if (number? (car args))
- (apply * (car args) ((cadr args) 'x) (cddr args))
- (apply * ((car args) 'x) (cdr args))))))))
- (let ((e2 (copy e1)))
- (set! (e2 'x) 4)
- (* 2 e1 e2))) ; (* 2 3 4) => 24
+ (apply * (if (number? (car args))
+ (values (car args) ((cadr args) 'x) (cddr args))
+ (values ((car args) 'x) (cdr args))))))))
+ (e2 (copy e1)))
+ (set! (e2 'x) 4)
+ (* 2 e1 e2)) ; (* 2 3 4) => 24
</pre>
<p>Perhaps these names would be better: openlet -> with-methods, coverlet -> without-methods,
@@ -2939,7 +2958,7 @@ indexing syntax with the field or method name. To evaluate a form in the contex
<em class="gray">v3</em>
> (all-methods v3 'multiply)
<em class="gray">(#<lambda (obj num)> #<lambda (obj)>)</em>
-> (for-each (lambda (p) (format #t "~A~%" (procedure-source p))) (all-methods v3 'multiply))
+> (for-each (lambda (p) (format () "~A~%" (procedure-source p))) (all-methods v3 'multiply))
<em class="gray">(lambda (obj num) (* num ((class-2 'multiply) obj) (add obj)))</em>
<em class="gray">(lambda (obj) (with-let obj (* a b c)))</em>
</pre>
@@ -3072,15 +3091,15 @@ as "complex?"!):
(add (cons (n 'r) r) (cons (n 'i) i)
(cons (n 'j) j) (cons (n 'k) k)
(cdr args)))
- ((<em class=red>openlet?</em> n) ; maybe we'll add octonions later!
- (if (eq? n (car orig-args))
- (error 'missing-method "+ can't handle these arguments: ~A" args)
- (apply (n '+)
- (make-quaternion
- (apply + r) (apply + i) (apply + j) (apply + k))
- (cdr args))))
- (else (error 'wrong-type-arg "+ argument ~A is not a number" n))))))))
- ))
+ ((not (<em class=red>openlet?</em> n)) ; maybe we'll add octonions later!
+ (error 'wrong-type-arg "+ argument ~A is not a number" n))
+ ((eq? n (car orig-args))
+ (error 'missing-method "+ can't handle these arguments: ~A" args))
+ (else
+ (apply (n '+)
+ (make-quaternion
+ (apply + r) (apply + i) (apply + j) (apply + k))
+ (cdr args)))))))))))
> (let ((q1 (make-quaternion 1.0 1.0 0.0 0.0)))
(+ 1 q1 2.5+i))
@@ -3153,6 +3172,10 @@ In s7, multiple values are spliced directly into the caller's argument list.
(define-macro (multiple-value-bind vars expr . body)
`((lambda ,vars , at body) ,expr))
+(define-macro (define-values vars expression)
+ `(if (not (null? ',vars))
+ (varlet (curlet) ((lambda ,vars (curlet)) ,expression))))
+
(define (curry function . args)
(if (null? args)
function
@@ -3168,9 +3191,11 @@ In s7, multiple values are spliced directly into the caller's argument list.
<div class="indented">
-<p>There aren't that many real uses for multiple-values in Scheme. Nearly all can be replaced by
-a normal list. There are a few cases where multiple-values are handy.
-First, you can use "values" to return any number of values, including 0,
+<p>multiple-values are useful in a several situations. For example,
+<code>(if test (+ a b c) (+ a b d e))</code> can be written
+<code>(+ a b (if test c (values d e)))</code>.
+There are a few special uses of multiple-values.
+First, you can use the values function to return any number of values, including 0,
from map's function application:
</p>
@@ -3196,49 +3221,12 @@ from map's function application:
(apply append (map (lambda (arg) (map values arg)) args)))
</pre>
-<p>
-Second, you can use multiple-values to turn off the short-circuit evaluation
-of 'or' and 'and'.
-</p>
-
-<pre class="indented">
-> (let ((x 1)) (and (<em class=red>values</em> #f (let () (set! x 3) #f))) x)
-<em class="gray">3</em>
-</pre>
-
-<p>But 'apply' has the same effect and is easier to read:
-</p>
-
-<pre class="indented">
-(define (and? . args) (apply and args))
-(define (every? f . seqs) (apply and (apply map f seqs)))
-</pre>
-
-<p>More often you want to keep the short-circuiting, but add some action as
-'and' or 'or' marches through its arguments:
-</p>
-
-<pre class="indented">
-(define-macro (every? function . args)
- `(and ,@(map (lambda (arg) `(,function ,arg)) args)))
-
-(define (map-and proc lst)
- (or (null? lst)
- (and (proc (car lst))
- (map-and proc (cdr lst)))))
-
-(define-macro (and-let* vars . body)
- `(let () ;; bind vars, if any is #f stop, else evaluate body with those bindings
- (and ,@(map (lambda (var) `(begin (apply define ',var) ,(car var))) vars)
- (begin , at body))))
-</pre>
-
-<p>Third, a macro can return multiple values; these are evaluated and spliced,
+<p>Second, a macro can return multiple values; these are evaluated and spliced,
exactly like a normal macro,
so you can use <code>(values '(define a 1) '(define b 2))</code> to
splice multiple definitions at the macro invocation point.
If an expansion returns (values), nothing is spliced in. This is
-mostly useful in <a href="#readercond">reader-cond</a>.
+mostly useful in <a href="#readercond">reader-cond</a> and the #; reader.
</p>
<pre class="indented">
@@ -3287,13 +3275,12 @@ is 15, as anyone would expect.
<summary class="indented">more examples</summary>
<pre>
-(define (flatten lst)
- (define (flatten-1 lst)
- (cond ((null? lst) (values))
- ((not (pair? lst)) lst)
- (#t (values (flatten-1 (car lst))
- (flatten-1 (cdr lst))))))
- (map values (list (flatten-1 lst))))
+(define (flatten lst)
+ (map values (list (let flatten-1 ((lst lst))
+ (cond ((null? lst) (values))
+ ((not (pair? lst)) lst)
+ (else (values (flatten-1 (car lst))
+ (flatten-1 (cdr lst)))))))))
</pre>
<div class="indented">
@@ -3428,16 +3415,15 @@ is cleaner than call/cc, and much faster.
;; borrowed loosely from CL — predefine "return" as an escape
`(<em class=red>call-with-exit</em> (lambda (return) , at body)))
-(define-macro (while test . body) ; while loop with predefined break and continue
+(define-macro (while test . body) ; while loop with predefined break and continue
`(<em class=red>call-with-exit</em>
(lambda (break)
- (letrec ((continue (lambda ()
- (if (let () ,test)
- (begin
- (let () , at body)
- (continue))
- (break)))))
- (continue)))))
+ (let continue ()
+ (if (let () ,test)
+ (begin
+ (let () , at body)
+ (continue))
+ (break))))))
(define-macro (switch selector . clauses) ; C-style case (branches fall through unless break called)
`(<em class=red>call-with-exit</em>
@@ -3502,7 +3488,7 @@ with-baffle blocks all that — no continuation can jump into its body:
(call/cc
(lambda (biscuit?)
(set! bad-dog biscuit?) ; bad-dog smells a biscuit!
- (biscuit? 'biscuit!)))))
+ 'biscuit!))))
(if (eq? what's-for-breakfast 'biscuit!)
(bad-dog 'biscuit!)) ; now, outside the baffled block, bad-dog wants that biscuit!
what's-for-breakfast) ; but s7 says "No!": baffled! ("continuation can't jump into with-baffle")
@@ -3613,7 +3599,7 @@ original.
~F float to string, (format #f "~F" 100.1) -> "100.100000", (%f in C)
~G float to string, (format #f "~G" 100.1) -> "100.1", (%g in C)
~T insert spaces (padding)
-~N get numeric argument from argument list (similar to V in CL)
+~N get numeric argument from argument list (similar to ~V in CL)
~W object->string with :readable (write readably; s7 is the intended reader)
</pre>
@@ -3779,7 +3765,7 @@ a modern GUI leaves formatting decisions to a text or table widget.
<p>A hook is a function created by make-hook, and called (normally from C) when something interesting happens.
In GUI toolkits hooks are called callback-lists, in CL conditions,
in other contexts watchpoints or signals. s7 itself has several
-hooks: <a href="#errorhook">*error-hook*</a>,
+hooks: <a href="#errorhook">*error-hook*</a>, <a href="#readerrorhook">*read-error-hook*</a>,
<a href="#unboundvariablehook">*unbound-variable-hook*</a>, *missing-close-paren-hook*,
and <a href="#loadhook">*load-hook*</a>.
make-hook is:
@@ -3975,25 +3961,27 @@ the procedure-source first (using, for example, copy-tree in stuff.scm).
(let ((orig (<em class=red>procedure-source</em> proc))) ; this assumes we haven't called "proc" yet
(define (proc-walk source)
- (if (pair? source)
- (if (memq (car source) '(let let*)) ; if let or let*, show local variables
- (if (symbol? (cadr source)) ; named let?
- ;; (let name vars . body) -> (let name vars print-vars . body)
- (append
- (list (car source)
- (cadr source)
- (caddr source)
- `(format #t " (let ~A (~{~A~^ ~}) ...)~%" ,(cadr source) (curlet)))
- (cdddr source))
- ;; (let(*) vars . body) -> (let vars print-vars . body)
- (append
- (list (car source)
- (cadr source)
- `(format #t " (~A (~{~A~^ ~}) ...)~%" ,(car source) (curlet)))
- (cddr source)))
- (cons (proc-walk (car source))
- (proc-walk (cdr source))))
- source))
+ (cond ((not (pair? source))
+ source)
+
+ ((not (memq (car source) '(let let*))) ; if let or let*, show local variables
+ (cons (proc-walk (car source))
+ (proc-walk (cdr source))))
+
+ ((symbol? (cadr source)) ; named let?
+ (append ; (let name vars . body) -> (let name vars print-vars . body)
+ (list (car source)
+ (cadr source)
+ (caddr source)
+ `(format () " (let ~A (~{~A~^ ~}) ...)~%" ,(cadr source) (curlet)))
+ (cdddr source)))
+
+ (else ; (let(*) vars . body) -> (let vars print-vars . body)
+ (append
+ (list (car source)
+ (cadr source)
+ `(format () " (~A (~{~A~^ ~}) ...)~%" ,(car source) (curlet)))
+ (cddr source)))))
(let* ((new-body (proc-walk orig))
(result (gensym))
@@ -4002,15 +3990,15 @@ the procedure-source first (using, for example, copy-tree in stuff.scm).
(let ((,result #<undefined>))
(dynamic-wind
(lambda () ; upon entry, show procedure name and args
- (format #t "(~A~{ ~A~})~%"
+ (format () "(~A~{ ~A~})~%"
',proc
(outlet (outlet (curlet)))))
(lambda ()
(set! ,result (,new-body ,@(cadr orig))))
(lambda () ; at exit, show result
(if (eq? ,result #<undefined>)
- (format #t " ~A returns early~%" ',proc)
- (format #t " ~A returns ~A~%" ',proc ,result))))))))
+ (format () " ~A returns early~%" ',proc)
+ (format () " ~A returns ~A~%" ',proc ,result))))))))
`(define ,proc ,new-source))))
@@ -4037,7 +4025,7 @@ its bindings (this is borrowed from "nuntius" at reddit lisp):
`(let ,(map (lambda (var/val)
`(,(car var/val)
(let ((,temp-symbol ,(cadr var/val)))
- (format #t ";~S: ~S -> ~S~%"
+ (format () ";~S: ~S -> ~S~%"
',(car var/val)
',(cadr var/val)
,temp-symbol)
@@ -4049,7 +4037,7 @@ its bindings (this is borrowed from "nuntius" at reddit lisp):
(define-macro (print-let bindings . body)
`(let ,bindings
- (format #t "~{;~A~%~}" (curlet))
+ (format () "~{;~A~%~}" (curlet))
, at body))
</pre>
@@ -4074,17 +4062,17 @@ what actual arguments you pass. In these cases, aritable? returns <code>#f</cod
<pre>
(define (for-each-subset func args)
;; form each subset of args, apply func to the subsets that fit its arity
- (define (subset source dest len)
+ (let subset ((source args)
+ (dest ())
+ (len 0))
(if (null? source)
- (if (<em class=red>aritable?</em> func len) ; does this subset fit?
- (apply func dest))
- (begin
- (subset (cdr source) (cons (car source) dest) (+ len 1))
- (subset (cdr source) dest len))))
- (subset args () 0))
+ (if (<em class=red>aritable?</em> func len) ; does this subset fit?
+ (apply func dest))
+ (begin
+ (subset (cdr source) (cons (car source) dest) (+ len 1))
+ (subset (cdr source) dest len)))))
</pre>
</div>
-
</blockquote>
@@ -4278,9 +4266,7 @@ the dumb "lambda". Here are more useful examples:
<pre class="indented">
(openlet ; a soft port for format that sends its output to *stderr* and returns the string
(inlet 'format (lambda (port str . args)
- (let ((result (apply format #f str args)))
- (display result *stderr*)
- result))))
+ (display (apply format #f str args) *stderr*))))
(define (open-output-log name)
;; return a soft output port that does not hold its output file open
@@ -4460,7 +4446,7 @@ map-with-exit would be
(catch 'wrong-type-arg
(lambda ()
(abs -1))
- (lambda args (format #t "got a bad arg~%") -1)))
+ (lambda args (format () "got a bad arg~%") -1)))
(lambda args 0)))
(lambda args 123))
</pre>
@@ -4481,7 +4467,7 @@ map-with-exit would be
(caddr base)))
;;; the code above becomes:
-(catch-case ((wrong-type-arg (lambda args (format #t "got a bad arg~%") -1))
+(catch-case ((wrong-type-arg (lambda args (format () "got a bad arg~%") -1))
(division-by-zero (lambda args 0))
(else (lambda args 123)))
(abs -1))
@@ -4495,9 +4481,7 @@ Along the same lines:
(catch #t
func
(lambda args
- (if (test (car args))
- (apply err args)
- (apply throw args))))) ; if not caught, re-raise the error
+ (apply (if (test (car args)) err throw) args)))) ; if not caught, re-raise the error via throw
(define (catch-member lst func err)
(catch-if (lambda (tag) (member tag lst)) func err))
@@ -4544,8 +4528,13 @@ additional info about that error:
<li>error-code: the code that s7 thinks triggered the error
<li>error-line: the line number of that code
<li>error-file: the file name of that code
+<li>error-history: previous evaluations leading to the error (a circular list)
</ul>
+<p>The error-history field depends on the compiler flag WITH_HISTORY. See ow! in
+stuff.scm for one way to display this data. The *s7* field 'history-size sets the size of the buffer.
+</p>
+
<blockquote>
@@ -4558,7 +4547,7 @@ To list all the local bindings from the error outward:
<pre class="indented">
(do ((e (outlet (owlet)) (outlet e)))
((eq? e (rootlet)))
- (format #t "~{~A ~}~%" e))
+ (format () "~{~A ~}~%" e))
</pre>
<p>To see the current s7 stack, <code>(stacktrace)</code>. You'll probably
@@ -4596,6 +4585,18 @@ Its arguments are named 'type and 'data.
(newline *stderr*))))
</pre>
+<p><em class=def id="readerrorhook">*read-error-hook*</em> provides two hooks into the reader.
+A major problem when reading code written for other Schemes is that each Scheme provides
+a plethora of idiosyncratic #-names (even special character names), and \ escapes in string
+constants. *read-error-hook* provides a way to handle these weird cases. If a #-name
+is encountered that s7 can't deal with, *read-error-hook* is called with two arguments,
+ #t and the string representing the constant. If you set (hook 'result), that result is
+returned to the reader. Otherwise a 'read-error is raised and you drop into the error handler.
+Similarly, if some bizaare \ use occurs, *read-error-hook* is called with two arguments,
+#f and the offending character. If you return a character, it is passed to the reader;
+otherwise you get an error. lint.scm has an example.
+</p>
+
<p>
There is a break macro defined in Snd (snd-xen.c)
which allows you to stop at some point, then evaluate arbitrary expressions in that context.
@@ -4879,14 +4880,16 @@ that call the lambda body if one of the variables is set.
<b><em class=def id="loadpath">*load-path*</em></b> is a list of directories to search when loading a file.
<b><em class=def id="loadhook">*load-hook*</em></b> is a hook whose functions are called just before a file is loaded.
The hook function argument, named 'name, is the filename.
-While loading, the port-filename and port-line-number of the current-input-port can tell you
-where you are in the file.
+While loading, the <em class=def id="portfilename">port-filename</em> and
+<em class=def id="portlinenumber">port-line-number</em> of the current-input-port can tell you
+where you are in the file. This data is available after loading via <em class=def id="pairlinenumber">pair-line-number</em>
+and <em class=def id="pairfilename">pair-filename</em>. port-line-number is settable (for fancy *#readers*).
</p>
<pre class="indented">
(set! (hook-functions *load-hook*)
(list (lambda (hook)
- (format #t "loading ~S...~%" (hook 'name)))))
+ (format () "loading ~S...~%" (hook 'name)))))
(set! (hook-functions *load-hook*)
(cons (lambda (hook)
@@ -4998,6 +5001,7 @@ CLOS. We can mimic this behavior:
<code>(+ #| add |# 1 2)</code>.
</p>
+<div class="indented">
<p>Leaving aside this case and the booleans, #f and #t, you can specify your own handlers for
tokens that start with "#". <b><em class=def id="sharpreaders">*#readers*</em></b> is a list of pairs: <code>(char . func)</code>.
"char" refers to the first character after the sharp sign (#). "func" is a function of
@@ -5028,24 +5032,6 @@ rest. Say we'd like #t<number> to interpret the number in base 12:
<em class="gray">1+2i</em>
</pre>
-<div class="indented">
-<p>I use *#readers* primarily to implement a way to get the current line number and file name, along
-the lines of C's __LINE__ and __FILE__. port-line-number works if we're reading a file (during load
-for example), and (owlet) has the same information if an error happens. But during Snd's auto-test
-sequence, there are many cases that aren't errors, and the file is no longer being loaded, but
-I need to know where something unexpected happened. So:
-</p>
-
-<pre class="indented">
-(set! *#readers*
- (cons (cons #\_ (lambda (str)
- (if (string=? str "__line__")
- (port-line-number)
- (and (string=? str "__file__")
- (port-filename)))))
- *#readers*))
-</pre>
-
<p>Here's a reader macro for read-time evaluation:
</p>
@@ -5059,6 +5045,23 @@ I need to know where something unexpected happened. So:
<em class="gray">(1 2 12 5)</em>
</pre>
+
+<p>And a reader that implements #[...]# for literal hash-tables:
+</p>
+
+<pre class="indented">
+> (set! *#readers*
+ (list (cons #\[ (lambda (str)
+ (let ((h (make-hash-table)))
+ (do ((c (read) (read)))
+ ((eq? c ']#) h) ; ]# is a symbol from the reader's point of view
+ (set! (h (car c)) (cdr c))))))))
+<em class="gray">((#\[ . #<lambda (str)>))</em>
+> #[(a . 1) (b . #[(c . 3)]#)]#
+<em class="gray">(hash-table '(b . (hash-table '(c . 3))) '(a . 1))</em>
+</pre>
+
+
<p>To return no value from a reader, use <code>(values)</code>.
</p>
<pre class="indented">
@@ -5080,7 +5083,8 @@ I need to know where something unexpected happened. So:
(if (provided? e)
expr
(values))
- (if (pair? e)
+ (if (not (pair? e))
+ (error "strange #+ chooser: ~S~%" e)
(begin ; evaluate the #+(...) expression as in cond-expand
(define (traverse tree)
(if (pair? tree)
@@ -5090,13 +5094,11 @@ I need to know where something unexpected happened. So:
(and (symbol? tree) (provided? tree)))))
(if (eval (traverse e))
expr
- (values)))
- (error "strange #+ chooser: ~S~%" e)))))
+ (values)))))))
</pre>
<p>See also the <a href="#circularlistreader">#n=</a> reader below.</p>
</div>
-
<div class="separator"></div>
<p id="makelist">(<b>make-list</b> length (initial-element #f)) returns a list of 'length' elements defaulting to 'initial-element'.
@@ -5205,75 +5207,26 @@ Here we scan the symbol table looking for any function that doesn't have documen
</p>
<pre class="indented">
-(let ((constants (list #f #t pi () 1 1.5 3/2 1.5+i)))
-
- (define (autotest func args args-left)
- (catch #t (lambda () (apply func args)) (lambda any #f))
- (if (> args-left 0)
- (for-each
- (lambda (c)
- (autotest func (cons c args) (- args-left 1)))
- constants)))
-
- (for-each
- (lambda (sym)
- (if (<em class=red>defined?</em> sym)
- (let ((val (<em class=red>symbol->value</em> sym)))
- (if (procedure? val)
- (let ((max-args (cdr (arity val))))
- (if (or (> max-args 4)
- (memq sym '(exit abort)))
- (format #t ";skip ~S for now~%" sym)
- (begin
- (format #t ";whack on ~S...~%" sym)
- (autotest val () max-args))))))))
- (<em class=red>symbol-table</em>)))
-</pre>
-
-<p>Equally useful, a profiler:
-</p>
-
-<pre class="indented">
-(define <em class=def id="profile">profile</em>
- (let ((documentation "(profile func) evaluates the function, then reports profiling information. \
-The function takes one argument, the environment in which loads and evals should operate."))
- (lambda (expression)
- (define calls (make-vector 1024 (cons 'unused -1)))
- (define call 0)
-
- (define (profile-1 n)
- (set! (cdr (calls n)) (+ (cdr (calls n)) 1)))
-
- (define (wrap-all)
- (let ((e (inlet)))
- (for-each
- (lambda (sym)
- (if (and (<em class=red>defined?</em> sym)
- (not (constant? sym)))
- (let ((val (<em class=red>symbol->value</em> sym)))
- (if (procedure? val)
- (let ((new-val (apply lambda 'args `((profile-1 ,call) (apply ,val args)))))
- (set! (calls call) (cons sym 0))
- (set! call (+ call 1))
- (if (>= call (length calls))
- (set! calls (copy calls (make-vector (* 2 (length calls)) (cons 'unused -1)))))
- (if (procedure-setter val)
- (set! (procedure-setter new-val) (procedure-setter val)))
- (varlet e sym new-val))))))
- (<em class=red>symbol-table</em>))
- e))
-
- (expression (wrap-all))
- (sort! calls (lambda (a b) (> (cdr a) (cdr b))))
- (do ((i 0 (+ i 1)))
- ((= i call))
- (if (> (cdr (calls i)) 0)
- (format #t "~S: ~S~%" (car (calls i)) (cdr (calls i))))))))
-
-> (profile (lambda (e)
- (load "lint.scm" e)
- (with-let e (lint "dsp.scm"))))
-;;; many lines of data print out
+(for-each
+ (lambda (sym)
+ (if (<em class=red>defined?</em> sym)
+ (let ((val (<em class=red>symbol->value</em> sym)))
+ (if (procedure? val)
+ (let ((max-args (cdr (arity val))))
+ (if (or (> max-args 4)
+ (memq sym '(exit abort)))
+ (format () ";skip ~S for now~%" sym)
+ (begin
+ (format () ";whack on ~S...~%" sym)
+ (let ((constants (list #f #t pi () 1 1.5 3/2 1.5+i)))
+ (let autotest ((args ()) (args-left max-args))
+ (catch #t (lambda () (apply func args)) (lambda any #f))
+ (if (> args-left 0)
+ (for-each
+ (lambda (c)
+ (autotest (cons c args) (- args-left 1)))
+ constants)))))))))))
+ (<em class=red>symbol-table</em>))
</pre>
</div>
@@ -5465,7 +5418,7 @@ define-macro, and (in normal use) the same result, but it is much faster because
(See define-with-macros in s7test.scm for a way to expand macros in a function body at definition time).
Since the reader knows almost nothing
about the code it is reading,
-you need to make sure the expansion name is unique!
+you need to make sure the expansion is defined at the top level and that its name is unique!
The reader does know about global variables, so:
</p>
@@ -5480,7 +5433,10 @@ The reader does know about global variables, so:
</pre>
<p>Now the assertion code is only present in the function body (or wherever)
-if *debugging* is #t; otherwise assert expands into nothing. Leaving aside
+if *debugging* is #t; otherwise assert expands into nothing. Another very handy
+use is to embed a source file line number into a message; see for example lint-format
+in lint.scm.
+Leaving aside
read-time expansion and splicing, the real difference between define-macro and define-expansion
is that the expansion's result is not evaluated.
I'm no historian, but I believe that means that define-expansion creates
@@ -5531,8 +5487,9 @@ is simply returned, unevaluated.
()
(if (null? (cdr args))
`(display ',(car args))
- (append (list 'begin `(display ',(car args)))
- (list (apply macroexpand (list (append '(rmac) (cdr args)))))))))
+ (list 'begin
+ `(display ',(car args))
+ (apply macroexpand (list (append '(rmac) (cdr args))))))))
> (macroexpand (rmac a b c))
<em class="gray">(begin (display 'a) (begin (display 'b) (display 'c)))</em>
@@ -5574,6 +5531,14 @@ is the same (in that context) as:
<div class="separator"></div>
+<p id="profiling">If you build s7 with the flag -DWITH_PROFILE=1, s7 accumulates profiling data
+in the (*s7* 'profile-info) hash-table. The line number reported sometimes points to the end of the form.
+Also, do loops and other iterations are sometimes highly optimized, so only the outer form is counted.
+profile.scm shows one way to sort and display this data. To clear the counts, <code>(fill! (*s7* 'profile-info) #f)</code>.
+</p>
+
+
+<div class="separator"></div>
<p id="s7env"><b>*s7*</b> is an environment that gives access to some of s7's internal
state:
</p>
@@ -5585,6 +5550,8 @@ max-vector-length max size arg to make-vector and make-hash-table
max-vector-dimensions make-vector dimensions limit
default-hash-table-length default size for make-hash-table (8, tables resize as needed)
initial-string-port-length 128, initial size of a string port's buffer
+history-size eval history buffer size if s7 built WITH_HISTORY=1
+profile-info profiling data if s7 built WITH_PROFILE=1
default-rationalize-error 1e-12 (settable)
morally-equal-float-epsilon 1e-15 (settable)
@@ -5678,6 +5645,7 @@ of the object's type in the (*s7* 'c-types) list.
<li>for-each and map accept any applicable object as the first argument, and any sequence or iterator as a trailing argument.
<li>letrec*, but without conviction.
<li>set! and *-set! return the new value (modulo symbol-access), not #<unspecified>.
+<li>define and its friends return the new value.
<li>port-closed?
<li>list? means "pair or null", proper-list? is r5rs list?, float? means "real and not rational", sequence? = length.
<!-- a vector can be a member of itself, and yet vector? returns #t, why is list? different; we even call it a circular list! -->
@@ -5690,7 +5658,7 @@ of the object's type in the (*s7* 'c-types) list.
<li>s7 is case sensitive.
<li>when and unless (for r7rs), returning the value of the last form.
<li>the "d", "f", "s", and "l" exponent markers are not supported by default (use "e", "E", or "@").
-<li>quasiquoted vector constants are not supported by default — use reader-cond instead.
+<li>quasiquoted vector constants are not supported (use the normal list expansions wrapped in list->vector).
</ul>
<p>In s7 if a built-in function like gcd is referred to in a function
@@ -5727,7 +5695,8 @@ definition, and a later redefinition does not affect earlier uses.
<li>change make-rectangular to complex, and remove make-polar.
<li>remove unquote (the name, not the functionality).
<li>remove cond-expand.
-<li>remove *-ci functions (they are completely useless)
+<li>remove *-ci functions
+<li>remove #d
</ul>
<p>(most of these are removed if you set the compiler flag WITH_PURE_S7), and perhaps:
@@ -5765,6 +5734,20 @@ In place of cond-expand, s7 uses <a href="#readercond">reader-cond</a>,
so the read-time decision involves normal evaluation.
</p>
+<p>Then there's the case case: a case clause without a result appears to be an error in r7rs.
+But the notation used to indicate that is the same as that used for begin.
+So if we allow <code>(begin)</code>, we should allow case clauses to have no explicit result.
+Currently in s7, the case case is an error and <code>(begin)</code> returns nil, which strikes me
+as, *horrors*, inconsistent. But in cond,
+the "implicit progn" (in CL terminology) includes the test expression, so a clause without a result returns
+the test result (if true of course). In the case case, a similar approach might return
+the selector value. So should <code>(case x ((0 1)))</code> be an error, or equivalent
+to <code>(case x ((0 1) (begin)))</code> as in CL, or (my favorite) <code>(case x ((0 1) => values))</code>.
+If the latter, an empty else statement would also return the selector since it would be the
+same as <code>(else => values)</code>.
+</p>
+
+
<p>
Better ideas are always welcome!
</p>
@@ -5772,11 +5755,12 @@ Better ideas are always welcome!
<p>Here are the built-in s7 variables:
</p>
<ul>
-<li>*features* ; a list of symbols
-<li>*libraries* ; a list of (filename . let) pairs
-<li>*load-path* ; a list of directories
-<li>*autoload* ; autoload info (a function internally)
-<li>*#readers* ; a list of (char . handler) pairs
+<li>*features* ; a list of symbols
+<li>*libraries* ; a list of (filename . let) pairs
+<li>*load-path* ; a list of directories
+<li>*cload-directory* ; directory for cload output
+<li>*autoload* ; autoload info
+<li>*#readers* ; a list of (char . handler) pairs
</ul>
<p>And the built-in constants:
@@ -5787,7 +5771,7 @@ Better ideas are always welcome!
<li>*s7*
<li>nan.0 -nan.0 inf.0 -inf.0 (what crappy names! nan.0 is an inexact integer that is not a number?)
<li>most-positive-fixnum most-negative-fixnum
-<li>*unbound-variable-hook* *missing-close-paren-hook* *load-hook* *error-hook*
+<li>*unbound-variable-hook* *missing-close-paren-hook* *load-hook* *error-hook* *read-error-hook*
</ul>
<p>__func__ is the name (or name and location) of the function currently being called, as in C.
@@ -5802,12 +5786,11 @@ Better ideas are always welcome!
<li>omits list->string, list->vector, string->list, vector->list, let->list
<li>omits string-length and vector-length
<li>omits cond-expand, multiple-values-bind|set!, call-with-values, defmacro(*)
-<li>omits unquote (the name), and quasiquoted vector constants
+<li>omits unquote (the name)
<li>omits d/f/s/l exponents
<li>omits make-polar and make-rectangular (use complex)
<li>omits integer-length, exact?, inexact?, exact->inexact, inexact->exact, #i and #e
<li>omits set-current-output-port and set-current-input-port
-<li>omits memq, memv, assq, assv
</ul>
</div>
@@ -5956,11 +5939,11 @@ it is GC'd. Here is an example:
<pre class="indented">
(define (bad-idea)
- (let ((lst '(1 2 3)))
- (let ((result (list-ref lst 1)))
- (list-set! lst 1 (* 2.0 16.6))
- (gc)
- result)))
+ (let* ((lst '(1 2 3))
+ (result (list-ref lst 1)))
+ (list-set! lst 1 (* 2.0 16.6))
+ (gc)
+ result))
</pre>
<p>Put this is a file, load it into the interpreter, then call <code>(bad-idea)</code> a
@@ -5968,17 +5951,20 @@ few times. You can turn off the optimization in question by setting the variabl
to 1. <code>(*s7* 'safety)</code> defaults to 0.
</p>
-<!-- there is another problem here: if the list constant in question is a program fragment
- that can be optimized, then reapplied elsewhere, the optimization info remains in the
- new, possibly inappropriate context. This can cause segfaults. The fix is to copy
- the list with 2nd arg :readable. see tgen.scm
--->
+<p>A similar problem arises when you want to walk a function's source or reuse a piece of
+code directly. When the function is evaluated, the optimizer changes the program source
+to speed up subsequent evaluation. This annotation process means that nothing in that
+source is what it appears to be, so a tree walker will be confused, and if you copy that
+source and try to insert it into some other program source, the existing annotations
+will not fit the new context. In both cases, you can get a clean version of the code
+by copying it with :readable as the second argument to copy. There is an example
+in lint.scm, and in the snd file tools/tgen.scm.
+</p>
</div>
</details>
-
<details id="circle">
<summary class="indented">circular lists</summary>
<div class="indented">
@@ -6046,7 +6032,7 @@ then it is part of the language, and it doesn't look like the rest of the langua
(set! top-n n)))
(if (char=? last-char #\=) ; #n=
- (and (char=? (peek-char) #\()
+ (and (eqv? (peek-char) #\() ; eqv? since peek-char can return #<eof>
(let ((cur-val (assoc n known-vals)))
;; associate the number and the list it points to
;; if cur-val, perhaps complain? (#n# redefined)
@@ -6055,11 +6041,11 @@ then it is part of the language, and it doesn't look like the rest of the langua
(lambda args ; a read error
(set! known-vals #f) ; so clear our state
(apply throw args))))) ; and pass the error on up
- (if (not cur-val)
+ (if cur-val
+ (set! (cdr cur-val) lst)
(set! known-vals
- (cons (set! cur-val (cons n lst)) known-vals))
- (set! (cdr cur-val) lst)))
-
+ (cons (set! cur-val (cons n lst)) known-vals))))
+
(if (= n top-n) ; replace our special keywords
(let ((result (replace-syms cur-val)))
(set! known-vals #f) ; '#1=(#+gsl #1#) -> '(:1)!
@@ -6091,7 +6077,7 @@ then it is part of the language, and it doesn't look like the rest of the langua
</p>
<pre class="indented">
-(let ((ctr 0)) #1=(begin (format #t "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline))))
+(let ((ctr 0)) #1=(begin (format () "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline))))
</pre>
<p>which prints "0 1 2 3" and a newline.
@@ -6117,10 +6103,10 @@ sequences in its argument, or nil.
<pre class="indented">
(define (for-each-permutation func vals)
;; apply func to every permutation of vals:
- ;; (for-each-permutation (lambda args (format #t "~{~A~^ ~}~%" args)) '(1 2 3))
+ ;; (for-each-permutation (lambda args (format () "~{~A~^ ~}~%" args)) '(1 2 3))
(define (pinner cur nvals len)
(if (= len 1)
- (apply func (cons (car nvals) cur))
+ (apply func (car nvals) cur)
(do ((i 0 (+ i 1))) ; I suppose a named let would be more Schemish
((= i len))
(let ((start nvals))
@@ -6531,10 +6517,10 @@ HAVE_COMPLEX_NUMBERS 1 if your compiler supports complex numbers
HAVE_COMPLEX_TRIG 1 if your math library has complex versions of the trig functions
DISABLE_DEPRECATED 1 if you want to make sure you're not using any deprecated s7 stuff (default is 0)
-WITH_QUASIQUOTE_VECTOR 1 if you want to use the `#(...) junk (defualt is 0)
WITH_IMMUTATBLE_UNQUOTE 1 if you want "unquote" omitted (default is 0)
WITH_EXTRA_EXPONENT_MARKERS 1 if you want "d", "f", "l", and "s" in addition to "e" as exponent markers (default is 0)
if someone defends these exponent markers, ask him to read 1l11+11l1i
+ (in 2 million lines of open-source Scheme, there is not one use of these silly things)
WITH_SYSTEM_EXTRAS 1 if you want some additional OS-related functions built-in (default is 0)
WITH_MAIN 1 if you want s7.c to include a main program section that runs a REPL.
WITH_C_LOADER 1 if you want to be able to load shared object files with load.
@@ -7813,7 +7799,7 @@ int main(int argc, char **argv)
}
/*
- * > (do ((i 0 (+ i 1))) ((= i -1)) (format #t "~D " i) (sleep))
+ * > (do ((i 0 (+ i 1))) ((= i -1)) (format () "~D " i) (sleep))
* ;;; now type C-C to break out of this loop
* 0 1 2 ^Cinterrupted!
* ;;; call the continuation to continue from where we were interrupted
@@ -8819,47 +8805,10 @@ cload.scm is a wrapper for the FFI stuff described above, and
stuff.scm is just some arbitrary stuff.
gdbinit has some gdb commands for s7.
repl.scm is a repl.
+profile.scm provides access to profiling data, if it's enabled.
</p>
-<div class="header" id="lint"><h4>lint.scm</h4></div>
-
-<p>lint tries to find errors or infelicities in your scheme code.
-To try it:
-</p>
-
-<pre class="indented">
-(load "lint.scm")
-(lint "some-code.scm")
-</pre>
-
-
-<p>lint tries to reduce false positives, so its default behavior is somewhat laconic. There are several
-variables at the start of lint.scm to control additional output:
-</p>
-
-
-<pre class="indented">
-*report-unused-parameters* ; if #t, report unused function/macro parameters
-*report-unused-top-level-functions* ; if #t, report unused functions
-*report-undefined-variables* ; if #t, report undefined identifiers
-*report-shadowed-variables* ; if #t, report function parameters that are shadowed
-*report-minor-stuff* ; if #t, report all sorts of other stuff
-</pre>
-
-
-<p>lint is not smart about functions defined outside the current file, so *report-undefined-variables*
-sometimes gets confused. *report-minor-stuff* adds output about overly complicated boolean and numerical
-expressions, dangerous floating point operations, and
-whatever else it thinks is odd.
-</p>
-
-<p>Also in lint.scm is html-lint. It reads an HTML file looking for
-Scheme code. If any is found, it runs s7 and then lint over it, reporting troubles.
-</p>
-
-
-
<div class="header" id="cload"><h4>cload.scm</h4></div>
<p>cload.scm defines the macro c-define that reduces the overhead
@@ -9179,8 +9128,8 @@ The special symbol '** holds the last value.
<p>Meta keys are a problem on the Mac. You can use ESC instead, but that requires
super-human capacities. I stared at replacement control keys, and nothing seemed
-right. I don't know how to remap these commands, but it's easy to do: see repl.scm
-which has a small table of mappings, and try out your own.
+right. If you can think of something, it's easy to define replacements: see repl.scm
+which has a small table of mappings.
</p>
<p>To run the repl, either build s7 with the compiler flag -DWITH_MAIN,
@@ -9326,6 +9275,51 @@ not tested:
-->
+<div class="header" id="lint"><h4>lint.scm</h4></div>
+
+<p>lint tries to find errors or infelicities in your scheme code.
+To try it:
+</p>
+
+<pre class="indented">
+(load "lint.scm")
+(lint "some-code.scm")
+</pre>
+
+
+<p>lint tries to reduce false positives, so its default behavior is somewhat laconic. There are several
+variables at the start of lint.scm to control additional output:
+</p>
+
+
+<pre class="indented">
+*report-unused-top-level-functions* ; if #t, report unused functions
+*report-undefined-variables* ; if #t, report undefined identifiers
+*report-shadowed-variables* ; if #t, report function parameters that are shadowed
+</pre>
+
+<p>lint is not smart about functions defined outside the current file, so *report-undefined-variables*
+sometimes gets confused. You'll sometimes get a recommendation from lint that is less than helpful; nobody's perfect.
+If it's actually wrong, and not just wrong-headed, please let me know.
+Also in lint.scm are html-lint and C-lint. html-lint reads an HTML file looking for
+Scheme code. If any is found, it runs s7 and then lint over it, reporting troubles.
+Similarly C-lint reads a C file looking for s7_eval_c_string and running lint over its string.
+</p>
+
+
+<blockquote>
+<div class="indented">
+<p>After months of intense typing,
+Insanely declares his labors complete. "Ship it!" says Mr Big, and hands
+him a million stock options. Meanwhile, in the basement behind an old door
+with the eldritch sign "eep Ou", in a labyrinth of pounding pipes and fluorescent lights,
+a forgotten shadow types <code>(lint "insanely-great.scm")</code>...
+</p>
+</div>
+</blockquote>
+
+
+
<!-- ================================================================================ -->
<script language=JavaScript>
diff --git a/s7test.scm b/s7test.scm
index e5d95c9..60ea2e4 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -27,7 +27,6 @@
(define with-complex (provided? 'complex-numbers))
(define with-windows (provided? 'windows))
-(define with-qq-vectors (catch #t (lambda () (integer? (`#(,(*s7* 'safety)) 0))) (lambda any #f)))
(if (not (defined? 's7test-exits)) (define s7test-exits #t))
@@ -40,11 +39,6 @@
(error 'wrong-type-arg "make-polar args should be real")))
(define make-rectangular complex)
- (define (memq a b) (member a b eq?))
- (define (memv a b) (member a b eqv?))
- (define (assq a b) (assoc a b eq?))
- (define (assv a b) (assoc a b eqv?))
-
(define (char-ci=? . chars) (apply char=? (map char-upcase chars)))
(define (char-ci<=? . chars) (apply char<=? (map char-upcase chars)))
(define (char-ci>=? . chars) (apply char>=? (map char-upcase chars)))
@@ -122,11 +116,6 @@
(apply append args)
(error 'wrong-type-arg "vector-append arguments should be vectors: ~A" args))))
- (define (hash-table-size hash)
- (if (hash-table? hash)
- (length hash)
- (error 'wrong-type-arg "hash-table-size argument should be a hash-table: ~A" hash)))
-
(define* (char-ready? p)
(and p (not (input-port? p))
(error 'wrong-type-arg "char-ready? arg should be an input port")))
@@ -225,6 +214,8 @@
(lambda (val)
(set! (*s7* 'symbol-table-locked?) val))))
+(if (provided? 'profiling)
+ (load "profile.scm"))
;;; --------------------------------------------------------------------------------
@@ -243,24 +234,9 @@
(close-output-port p)))
str))
-;(define error-port (open-output-file "err"))
-
-(define (show-error args tst)
- (if (or (not (pair? args))
- (not (pair? (cdr args)))
- (not (pair? (cadr args)))
- (not (string? (caadr args))))
- (format *stderr* "~S -> ~S?~%" tst args)
- (let ((type (car args))
- (info (cadr args)))
- (let ((str (apply format #f info)))
- (format error-port "~S -> ~S ~S~%" tst type str)))))
-
-
(define (ok? otst ola oexp)
(let ((result (catch #t ola
(lambda args
- ;(show-error args otst)
(if (not (eq? oexp 'error))
(begin (display args) (newline)))
'error))))
@@ -283,14 +259,21 @@
;; `(ok? ',tst (lambda () (define (_s7_ _a_) _a_) (_s7_ ,tst)) ,expected))
;; `(ok? ',tst (lambda () (define* (_s7_ (_a_ #f)) (or _a_)) (_s7_ ,tst)) ,expected))
({list} 'ok? ({list} quote tst) ({list} lambda () tst) expected))
+#|
+ `(let ((_result_ #f))
+ (define (stest) (set! _result_ ,tst))
+ (catch #t stest
+ (lambda args
+ (set! _result_ 'error)))
+ (if (not (equal? _result_ ,expected))
+ (format-logged #t "~A: ~A got ~S but expected ~S~%~%" (port-line-number) ',tst _result_ ,expected))))
+|#
)
-
(define (tok? otst ola)
(let* ((data #f)
(result (catch #t ola
(lambda args
- ;(show-error args otst)
(set! data args)
'error))))
(if (or (not result)
@@ -303,7 +286,6 @@
(define-macro (test-e tst op arg) ;(display tst *stderr*) (newline *stderr*)
`(let ((result (catch #t (lambda () ,tst)
(lambda args
- ;(show-error args ',tst)
'error))))
(if (not (eq? result 'error))
(format-logged #t "~A: (~A ~S) got ~S but expected 'error~%~%" (port-line-number) ,op ,arg result))))
@@ -353,41 +335,40 @@
(define error-6 1e-6)
(define (number-ok? tst result expected)
- (if (not (eq? result expected))
- (if (or (and (not (number? expected))
- (not (eq? result expected)))
- (and (number? expected)
- (nan? expected)
- (not (nan? result)))
- (and (number? result)
- (nan? result)
- (number? expected)
- (not (nan? expected)))
- (and (number? expected)
- (or (not (number? result))
- (nan? result)))
- (and (rational? expected)
- (rational? result)
- (not (= result expected)))
- (and (or (rational? expected)
- (rational? result))
- (real? expected)
- (real? result)
- (> (/ (abs (- result expected)) (max 1.0 (abs expected))) error-12))
- (and (pair? tst)
- (> (op-error (car tst) result expected) error-6)))
-
- (format-logged #t "~A: ~A got ~A~Abut expected ~A~%~%"
- (port-line-number) tst result
- (if (and (rational? result) (not (rational? expected)))
- (format #f " (~A) " (* 1.0 result))
- " ")
- expected))))
+ (if (and (not (eq? result expected))
+ (or (and (not (number? expected))
+ (not (eq? result expected)))
+ (and (number? expected)
+ (nan? expected)
+ (not (nan? result)))
+ (and (number? result)
+ (nan? result)
+ (number? expected)
+ (not (nan? expected)))
+ (and (number? expected)
+ (or (not (number? result))
+ (nan? result)))
+ (and (rational? expected)
+ (rational? result)
+ (not (= result expected)))
+ (and (or (rational? expected)
+ (rational? result))
+ (real? expected)
+ (real? result)
+ (> (/ (abs (- result expected)) (max 1.0 (abs expected))) error-12))
+ (and (pair? tst)
+ (> (op-error (car tst) result expected) error-6))))
+
+ (format-logged #t "~A: ~A got ~A~Abut expected ~A~%~%"
+ (port-line-number) tst result
+ (if (and (rational? result) (not (rational? expected)))
+ (format #f " (~A) " (* 1.0 result))
+ " ")
+ expected)))
(define (nok? otst ola oexp)
(let ((result (catch #t ola
(lambda args
- ;(show-error args otst)
'error))))
(number-ok? otst result oexp)))
@@ -400,14 +381,12 @@
(define-macro (num-test-1 proc val tst expected)
`(let ((result (catch #t (lambda () ,tst)
(lambda args
- ;(show-error args ',tst)
'error))))
(number-ok? (list ,proc ,val) result ,expected)))
(define-macro (num-test-2 proc val1 val2 tst expected)
`(let ((result (catch #t (lambda () ,tst)
(lambda args
- ;(show-error args ',tst)
'error))))
(number-ok? (list ,proc ,val1 ,val2) result ,expected)))
@@ -491,13 +470,14 @@ static s7_pointer g_to_block(s7_scheme *sc, s7_pointer args)
return(b);
}
-static char *block_write_readably(s7_scheme *sc, void *value)
+static char *g_block_display(s7_scheme *sc, void *value)
{
g_block *b = (g_block *)value;
int i, len;
char *buf;
char flt[64];
len = b->size;
+ if (len > s7_print_length(sc)) len = s7_print_length(sc);
buf = (char *)calloc((len + 1) * 64, sizeof(char));
snprintf(buf, (len + 1) * 64, \"(block\");
for (i = 0; i < len; i++)
@@ -505,16 +485,21 @@ static char *block_write_readably(s7_scheme *sc, void *value)
snprintf(flt, 64, \" %.3f\", b->data[i]);
strcat(buf, flt);
}
- strcat(buf, \")\");
+ if (b->size > s7_print_length(sc))
+ strcat(buf, \" ...)\");
+ else strcat(buf, \")\");
return(buf);
}
-static char *g_block_display(s7_scheme *sc, void *value)
+static char *g_block_display_readably(s7_scheme *sc, void *value)
{
+ char *buf;
+ s7_int plen;
g_block *b = (g_block *)value;
- if (b->size < 6)
- return(block_write_readably(sc, value));
- return(strdup(\"(block ...)\"));
+ plen = s7_set_print_length(sc, b->size + 1);
+ buf = g_block_display(sc, value);
+ s7_set_print_length(sc, plen);
+ return(buf);
}
static void g_block_free(void *value)
@@ -937,6 +922,49 @@ static s7_pointer g_rs11(s7_scheme *sc, s7_pointer args) {return(s7_make_integer
static s7_pointer g_cf51(s7_scheme *sc, s7_pointer args) {return(s7_car(args));}
+static s7_pointer sload(s7_scheme *sc, s7_pointer args)
+{
+ if (s7_is_string(s7_car(args)))
+ {
+ if (s7_is_pair(s7_cdr(args)))
+ {
+ if (s7_is_let(s7_cadr(args)))
+ return(s7_load_with_environment(sc, s7_string(s7_car(args)), s7_cadr(args)));
+ return(s7_wrong_type_arg_error(sc, \"load\", 2, s7_cadr(args), \"an environment\"));
+ }
+ return(s7_load(sc, s7_string(s7_car(args))));
+ }
+ return(s7_wrong_type_arg_error(sc, \"load\", 1, s7_car(args), \"file name\"));
+}
+static s7_pointer scall(s7_scheme *sc, s7_pointer args) {return(s7_call(sc, s7_car(args), s7_cadr(args)));}
+static s7_pointer sread(s7_scheme *sc, s7_pointer args)
+{
+ if (s7_is_pair(args))
+ return(s7_read(sc, s7_car(args)));
+ return(s7_read(sc, s7_current_input_port(sc)));
+}
+static s7_pointer swind(s7_scheme *sc, s7_pointer args) {return(s7_dynamic_wind(sc, s7_car(args), s7_cadr(args), s7_caddr(args)));}
+static s7_pointer seval(s7_scheme *sc, s7_pointer args)
+{
+ if (s7_is_pair(s7_cdr(args)))
+ return(s7_eval(sc, s7_car(args), s7_cadr(args)));
+ return(s7_eval(sc, s7_car(args), s7_curlet(sc)));
+}
+static s7_pointer sevalstr(s7_scheme *sc, s7_pointer args)
+{
+ if (s7_is_string(s7_car(args)))
+ {
+ if (s7_is_pair(s7_cdr(args)))
+ {
+ if (s7_is_let(s7_cadr(args)))
+ return(s7_eval_c_string_with_environment(sc, s7_string(s7_car(args)), s7_cadr(args)));
+ return(s7_wrong_type_arg_error(sc, \"eval-string\", 2, s7_cadr(args), \"an environment\"));
+ }
+ return(s7_eval_c_string_with_environment(sc, s7_string(s7_car(args)), s7_curlet(sc)));
+ }
+ return(s7_wrong_type_arg_error(sc, \"eval-string\", 1, s7_car(args), \"string of code\"));
+}
+
void block_init(s7_scheme *sc);
void block_init(s7_scheme *sc)
{
@@ -947,7 +975,7 @@ void block_init(s7_scheme *sc)
g_block_is_equal, g_block_mark,
g_block_ref, g_block_set, g_block_length,
g_block_copy, g_block_reverse, g_block_fill);
- s7_set_object_print_readably(g_block_type, block_write_readably);
+ s7_set_object_print_readably(g_block_type, g_block_display_readably);
s7_define_function(sc, \"make-block\", g_make_block, 1, 0, false, g_make_block_help);
s7_define_function(sc, \"block\", g_to_block, 0, 0, true, g_block_help);
s7_define_function(sc, \"subblock\", g_subblock, 1, 0, true, g_subblock_help);
@@ -993,6 +1021,13 @@ void block_init(s7_scheme *sc)
s7_define_safe_function(sc, \"cf44\", g_cf44, 4, 0, false, \"\");
s7_define_safe_function(sc, \"cf51\", g_cf51, 5, 0, false, \"\");
+
+ s7_define_function(sc, \"sload\", sload, 1, 1, false, \"test s7_load\");
+ s7_define_function(sc, \"scall\", scall, 2, 0, false, \"test s7_call\");
+ s7_define_function(sc, \"sread\", sread, 0, 1, false, \"test s7_read\");
+ s7_define_function(sc, \"swind\", swind, 3, 0, false, \"test s7_dynamic_wind\");
+ s7_define_function(sc, \"seval\", seval, 1, 1, false, \"test s7_eval\");
+ s7_define_function(sc, \"sevalstr\", sevalstr, 1, 1, false, \"test s7_eval_c_string\");
}
")))
@@ -1017,11 +1052,12 @@ void block_init(s7_scheme *sc)
(system "gcc -fPIC -c s7test-block.c -O2")
(system "gcc s7test-block.o -shared -o s7test-block.so -ldl -lm -Wl,-export-dynamic")))
-(let ((new-env (sublet (curlet) (cons 'init_func 'block_init)))) ; load calls init_func if possible
+(let ((new-env (sublet (curlet) (cons 'init_func 'block_init)))) ; load calls init_func
(load "s7test-block.so" new-env))
(define _c_obj_ (make-block 16))
-)
+) ; with-block
+
(define _c_obj_ (c-pointer 0))) ; not with-block
(define _null_ (c-pointer 0))
@@ -1032,6 +1068,56 @@ void block_init(s7_scheme *sc)
(system "ffitest"))
+(when with-block
+;(define eval seval) ; finished ok
+;(define dynamic-wind swind) ; finished ok
+;(define read sread) ; ok until (unsupported) let-as-port 80480, also read-error in sevalstr does not unwind C stack
+;(define load sload) ; ok until (unsupported) cload
+;(define-macro (test tst expected) `(ok? ',tst (lambda () (define (_s7_ _a_) ,tst) (scall _s7_ (list 0))) ,expected)) ; finished ok!
+;(define eval-string sevalstr) ; ok except various local exiters, eval-string as method, multiple statements etc, gloms up C stack
+(test (sevalstr "(+ 1 2)") 3)
+(test (sevalstr "(+ 1 #())") 'error)
+(test (let ((x 1) (y 2)) (sevalstr "(begin (set! x 3) (set! y 4))") (list x y)) '(3 4))
+(test (+ 1 (values (sevalstr "(catch #t (lambda () asdf) (lambda args 2))") (sevalstr "(catch #t (lambda () asdf) (lambda args 3))"))) 6)
+(test (seval '(+ 1 #())) 'error)
+)
+
+#|
+(let ()
+ (if (null? (hook-functions *error-hook*))
+ (set! (hook-functions *error-hook*)
+ (list (lambda (hook)
+ (apply format *stderr* (hook 'data))
+ (newline *stderr*)
+ (throw 'all-done)))))
+ (catch 'all-done
+ (lambda ()
+ (+ 1 #()))
+ (lambda args
+ (format *stderr* "in catch~%"))))
+
+(define (ok1? otst ola oexp)
+ (let ((result (catch 'all-done ola
+ (lambda args
+ (if (not (eq? oexp 'error))
+ (begin (display args) (newline)))
+ 'error))))
+ (if (not (equal? result oexp))
+ (format-logged #t "~A: ~A got ~S but expected ~S~%~%" (port-line-number) otst result oexp))))
+
+(define-macro (test tst expected)
+ `(ok1? ',tst (lambda ()
+ (if (null? (hook-functions *error-hook*))
+ (set! (hook-functions *error-hook*)
+ (list (lambda (hook)
+ (apply format *stderr* (hook 'data))
+ (newline *stderr*)
+ (set! (hook 'result) 'error)
+ (throw 'all-done)))))
+ ,tst)
+ ,expected))
+|#
+
;;; --------------------------------------------------------------------------------
;;; eq?
@@ -1119,6 +1205,8 @@ void block_init(s7_scheme *sc)
(test (eq? 'car car) #f)
(test (eq? '()()) #t)
(test (eq? ''() '()) #f)
+(test (eq? ' () '
+()) #t)
(test (eq? '#f #f) #t)
(test (eq? '#f '#f) #t)
(test (eq? #f ' #f) #t)
@@ -1602,6 +1690,7 @@ void block_init(s7_scheme *sc)
(test (equal? '`#(1) #(1)) #t)
(test (equal? ''#(1) #(1)) #f)
(test (equal? ''#(1) '#(1)) #f)
+(test (equal? '(1) ' ( 1 )) #t)
(test (equal? (list 1 "hi" #\a) '(1 "hi" #\a)) #t)
(test (equal? (list 1.0 2/3) '(1.0 2/3)) #t)
(test (equal? (list 1 2) '(1 2.0)) #f)
@@ -1670,7 +1759,7 @@ void block_init(s7_scheme *sc)
(test (equal? '1/0 '1/0) #f)
(test (let ((+nan.0 1/0)) (equal? '(+nan.0) '(+nan.0))) #t)
(test (let ((+nan.0 1/0)) (equal? (list +nan.0) (list +nan.0))) #f)
-;;; in the 1st case we're looking at the symbol, not its value
+;;; in the first case we're looking at the symbol, not its value
(test (let ((+nan.0 1/0)) (equal? (vector +nan.0) (vector +nan.0))) #f)
(test (let ((+nan.0 1/0)) (equal? #(1/0) #(1/0))) #f)
@@ -2616,32 +2705,27 @@ void block_init(s7_scheme *sc)
;;; ----------------
;;; try a bunch of combinations
-(define old-readers *#readers*)
-(set! *#readers*
- (cons (cons #\_ (lambda (str)
- (if (string=? str "__line__")
- (port-line-number)
- #f)))
- *#readers*))
+(define-expansion (format-logged-with-line port str . args)
+ `(format-logged ,port ,str ,(port-line-number) , at args))
(let ((lst1 ())
(lst2 ()))
- (if (not (eq? lst1 lst2)) (format-logged #t ";~A: nils are not eq?~%" #__line__))
- (if (not (eqv? lst1 lst2)) (format-logged #t ";~A: nils are not eqv?~%" #__line__))
- (if (not (equal? lst1 lst2)) (format-logged #t ";~A: nils are not equal?~%" #__line__))
+ (if (not (eq? lst1 lst2)) (format-logged-with-line #t ";~A: nils are not eq?~%"))
+ (if (not (eqv? lst1 lst2)) (format-logged-with-line #t ";~A: nils are not eqv?~%"))
+ (if (not (equal? lst1 lst2)) (format-logged-with-line #t ";~A: nils are not equal?~%"))
(let ((v1 (make-vector 100 #f))
(v2 (make-vector 100 #f)))
- (if (not (equal? v1 v2)) (format-logged #t ";~A: base vectors are not equal?~%" #__line__))
+ (if (not (equal? v1 v2)) (format-logged-with-line #t ";~A: base vectors are not equal?~%"))
(let ((h1 (make-hash-table))
(h2 (make-hash-table)))
- (if (not (equal? h1 h2)) (format-logged #t ";~A: base hash-tables are not equal?~%" #__line__))
+ (if (not (equal? h1 h2)) (format-logged-with-line #t ";~A: base hash-tables are not equal?~%"))
(let ((e1 (sublet (curlet)))
(e2 (sublet (curlet))))
- (if (not (equal? e1 e2)) (format-logged #t ";~A: base environments are not equal?~%" #__line__))
+ (if (not (equal? e1 e2)) (format-logged-with-line #t ";~A: base environments are not equal?~%"))
(let ((ctr 0))
(for-each
@@ -2652,16 +2736,16 @@ void block_init(s7_scheme *sc)
(let ((a1 arg1)
(a2 arg2))
(if (not (eq? a1 arg1))
- (format-logged #t ";~A: ~A is not eq? to itself? ~A~%" #__line__ arg1 a1))
+ (format-logged-with-line #t ";~A: ~A is not eq? to itself? ~A~%" arg1 a1))
(if (and (eq? a1 a2) (not (eqv? a1 a2)))
- (format-logged #t ";~A: ~A is eq? but not eqv? ~A~%" #__line__ a1 a2))
+ (format-logged-with-line #t ";~A: ~A is eq? but not eqv? ~A~%" a1 a2))
(if (equal? a1 a2)
(begin
(if (and (eq? a1 a2) (not (eqv? a1 a2)))
- (format-logged #t ";~A: ~A is eq? and equal? but not eqv?? ~A~%" #__line__ a1 a2))
+ (format-logged-with-line #t ";~A: ~A is eq? and equal? but not eqv?? ~A~%" a1 a2))
(if (not (morally-equal? a1 a2))
- (format-logged #t ";~A: ~A is equal? but not morally-equal? ~A~%" #__line__ a1 a2))
+ (format-logged-with-line #t ";~A: ~A is equal? but not morally-equal? ~A~%" a1 a2))
(set! lst1 (cons a1 lst1))
(set! lst2 (cons a2 lst2))
(set! (v1 ctr) a1)
@@ -2675,29 +2759,29 @@ void block_init(s7_scheme *sc)
(if (not (equal? lst1 lst2))
(begin
- (format-logged #t ";~A: add ~A to lists, now not equal?~%" #__line__ a1)
+ (format-logged-with-line #t ";~A: add ~A to lists, now not equal?~%" a1)
(set! lst1 (cdr lst1))
(set! lst2 (cdr lst2))))
(if (not (equal? v1 v2))
(begin
- (format-logged #t ";~A: add ~A to vectors, now not equal?~%" #__line__ a1)
+ (format-logged-with-line #t ";~A: add ~A to vectors, now not equal?~%" a1)
(set! (v1 ctr) #f)
(set! (v2 ctr) #f)))
(if (not (equal? h1 h2))
(begin
- (format-logged #t ";~A: add ~A to hash-tables, now not equal?~%" #__line__ a1)
+ (format-logged-with-line #t ";~A: add ~A to hash-tables, now not equal?~%" a1)
(set! (h1 sym1) #f)
(set! (h2 sym2) #f)))
(if (not (equal? e1 e2))
(begin
- (format-logged #t ";~A: add ~A to environments, now not equal?~% ~A~% ~A~%" #__line__ a1 e1 e2)
+ (format-logged-with-line #t ";~A: add ~A to environments, now not equal?~% ~A~% ~A~%" a1 e1 e2)
(eval `(set! ,sym1 #f) e1)
(eval `(set! ,sym2 #f) e2)))
))
(begin
- (if (eq? a1 arg1) (format-logged #t ";~A: ~A is eq? but not equal? ~A~%" #__line__ a1 a2))
- (if (eqv? a1 arg1) (format-logged #t ";~A: ~A is eqv? but not equal? ~A~%" #__line__ a1 a2))
- (format-logged #t ";~A: ~A is not equal to ~A~%" #__line__ a1 a2)))
+ (if (eq? a1 arg1) (format-logged-with-line #t ";~A: ~A is eq? but not equal? ~A~%" a1 a2))
+ (if (eqv? a1 arg1) (format-logged-with-line #t ";~A: ~A is eqv? but not equal? ~A~%" a1 a2))
+ (format-logged-with-line #t ";~A: ~A is not equal to ~A~%" a1 a2)))
(set! ctr (+ ctr 1))))
@@ -2736,32 +2820,32 @@ void block_init(s7_scheme *sc)
(set! (v2 ctr) lst2)
(set! ctr (+ ctr 1))
(if (not (equal? v1 v2))
- (format-logged #t ";~A: add lists to vectors, now vectors not equal?~%" #__line__)
+ (format-logged-with-line #t ";~A: add lists to vectors, now vectors not equal?~%")
(begin
(set! lst1 (cons v1 lst1))
(set! lst2 (cons v2 lst2))
(if (not (equal? lst1 lst2))
(begin
- (format-logged #t ";~A: add vectors to lists, now lists not equal?~%" #__line__)
+ (format-logged-with-line #t ";~A: add vectors to lists, now lists not equal?~%")
(set! (h1 'lst1) lst1)
(set! (h2 'lst2) lst2)
(if (not (equal? h1 h2))
- (format-logged #t ";~A: add lists to hash-tables, not hash-tables not equal?~%" #__line__)
+ (format-logged-with-line #t ";~A: add lists to hash-tables, not hash-tables not equal?~%")
(begin
(set! (v1 ctr) v1)
(set! (v2 ctr) v2)
(set! ctr (+ ctr 1))
(if (not (equal? v1 v2))
- (format-logged #t ";~A: add vectors to themselves, now vectors not equal?~%" #__line__))
+ (format-logged-with-line #t ";~A: add vectors to themselves, now vectors not equal?~%"))
(if (not (equal? lst1 lst2))
- (format-logged #t ";~A: add vectors to themselves, now lists not equal?~%" #__line__))
+ (format-logged-with-line #t ";~A: add vectors to themselves, now lists not equal?~%"))
(set! (h1 'h1) h1)
(set! (h2 'h2) h2)
(if (not (equal? h1 h2))
- (format-logged #t ";~A: add hash-tables to themselves, not hash-tables not equal?~%" #__line__))
+ (format-logged-with-line #t ";~A: add hash-tables to themselves, not hash-tables not equal?~%"))
)))))))))))
-
+(define old-readers *#readers*)
(set! *#readers* (cons (cons #\u (lambda (str) (string->number (substring str 1)))) ()))
(test (eval (with-input-from-string "(+ 10 #u12)" read)) 22)
(test (eval (with-input-from-string "(+ 10 #u87)" read)) 97)
@@ -2773,6 +2857,20 @@ void block_init(s7_scheme *sc)
(let ((val (eval (with-input-from-string (string-append "(+ 10 #" (string (integer->char i)) "12)") read))))
(if (not (equal? val 22)) (format *stderr* "~D (~C): ~A~%" i (integer->char i) val)))))
+(set! *#readers*
+ (list (cons #\[
+ (lambda (str)
+ (let ((h (make-hash-table)))
+ (do ((c (read) (read)))
+ ((eq? c ']#) h)
+ (set! (h (car c)) (cdr c))))))))
+
+(eval-string "(let ((table #[(a . 1) (b . #[(c . 3)]#)]#))
+ (test (hash-table? table) #t)
+ (test (table 'a) 1)
+ (test (hash-table? (table 'b)) #t)
+ (test ((table 'b) 'c) 3))")
+
(set! *#readers* old-readers)
(when with-block
@@ -3152,7 +3250,6 @@ void block_init(s7_scheme *sc)
;; any larger number is a reader error
(test (eval-string "(char? #\xbdca2cbec)") 'error) ; this can overflow internally!
-(test (eval-string "(char? #\\x#b0)") 'error)
(test (eval-string "(char? #\\100)") 'error)
(test (eval-string "(char? #\\x-65)") 'error)
(test (eval-string "(char? #\\x6.5)") 'error)
@@ -3161,11 +3258,17 @@ void block_init(s7_scheme *sc)
(test (eval-string "(char? #\\x6+i)") 'error)
(test (eval-string "(char? #\\x6asd)") 'error)
(test (eval-string "(char? #\\x6#)") 'error)
+(test (eval-string "(char? #\\x#b0)") 'error)
(test (eval-string "(char? #\\x#b0") 'error)
(test (eval-string "(char? #\\x#e0.0") 'error)
(test (eval-string "(char? #\\x-0") 'error)
(test (eval-string "(char? #\\x#e0e100") 'error)
-(test (eval-string "(char? #\\x1.4") 'error)
+(test (eval-string "(char? #\\x1.4)") 'error)
+(test (eval-string "(char? #\\x#b0)") 'error)
+(test (eval-string "(char? #\\x#e0.0)") 'error)
+(test (eval-string "(char? #\\x-0)") 'error)
+(test (eval-string "(char? #\\x#e0e100)") 'error)
+(test (eval-string "(char? #\\x1.4)") 'error)
(test (char=? #\x6a #\j) #t)
@@ -4999,17 +5102,16 @@ zzy" (lambda (p) (eval (read p))))) 32)
(max-tar-index (- tar-len 1))
(max-pat-index (- pat-len 1)))
(let outer ((start-index 0))
- (if (> (+ pat-len start-index) tar-len)
- #f
- (let inner ((p-ind 0) (t-ind start-index))
- (cond
- ((> p-ind max-pat-index) #f) ; nothing left to check
- ((char=? (pattern p-ind) (target t-ind))
- (if (= p-ind max-pat-index)
- start-index ; success -- return start index of match
- (inner (+ p-ind 1) (+ t-ind 1)))) ; keep checking
- ((> (+ pat-len start-index) max-tar-index) #f) ; fail
- (else (outer (+ start-index (shift-vec (char->integer (target (+ start-index pat-len)))))))))))))))))
+ (and (<= (+ pat-len start-index) tar-len)
+ (let inner ((p-ind 0) (t-ind start-index))
+ (cond
+ ((> p-ind max-pat-index) #f) ; nothing left to check
+ ((char=? (pattern p-ind) (target t-ind))
+ (if (= p-ind max-pat-index)
+ start-index ; success -- return start index of match
+ (inner (+ p-ind 1) (+ t-ind 1)))) ; keep checking
+ ((> (+ pat-len start-index) max-tar-index) #f) ; fail
+ (else (outer (+ start-index (shift-vec (char->integer (target (+ start-index pat-len)))))))))))))))))
(test (substring? "hiho" "test hiho test") 5)
(test (substring? "hiho" "test hihptest") #f)
@@ -5413,7 +5515,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (char-position "" (string #\a #\n)) #f)
(test (char-position #(1) "asdasd" 63) 'error)
-;; if "" as string-pos 1st, -> #f so same for char-pos, even if string contains a null
+;; if "" as string-pos first, -> #f so same for char-pos, even if string contains a null
(let ()
;; actually more of a string-append/temp substring test
@@ -5424,10 +5526,10 @@ zzy" (lambda (p) (eval (read p))))) 32)
(string-append (substring str 0 pos)
(let ((epos (char-position #\; str pos)))
(let ((substr (substring str (+ pos 1) epos)))
- (let ((replacement (if (string=? substr "gt") ">"
- (if (string=? substr "lt") "<"
- (if (string=? substr "mdash") "-"
- (format-logged #t "unknown: ~A~%" substr))))))
+ (let ((replacement (cond ((string=? substr "gt") ">")
+ ((string=? substr "lt") "<")
+ ((string=? substr "mdash") "-")
+ (else (format-logged #t "unknown: ~A~%" substr)))))
(string-append replacement
(fixit (substring str (+ epos 1)))))))))))
(test (fixit "(let ((f (hz->radians 100)) (g (hz->radians 200))) (< f g))")
@@ -6457,6 +6559,12 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (cddadr '(1 (2 3 . 4))) 4)
(test (cdddar '((1 2 3 . 4))) 4)
+(let () (define (f1 x) (eq? (car x) 'y)) (let ((z 1)) (test (f1 z) 'error)))
+(let () (define (f1 x) (eq? (cdr x) 'y)) (let ((z 1)) (test (f1 z) 'error)))
+(let () (define (f1 x) (eq? (caar x) 'y)) (let ((z (list 1 2))) (test (f1 z) 'error)))
+(let () (define (f1 x) (eq? (cadr x) 'y)) (let ((z (cons 1 2))) (test (f1 z) 'error)))
+(let () (define (f1 x) (eq? (cdar x) 'y)) (let ((z (list 1 2))) (test (f1 z) 'error)))
+(let () (define (f1 x) (eq? (cddr x) 'y)) (let ((z (cons 1 2))) (test (f1 z) 'error)))
@@ -7000,6 +7108,16 @@ zzy" (lambda (p) (eval (read p))))) 32)
(list "hi" (integer->char 65) #f 'a-symbol (make-vector 3) abs _ht_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0)
3.14 3/4 1.0+1.0i #\f #t :hi (if #f #f) (lambda (a) (+ a 1))))
+;;; pair-filename
+
+(test (pair-filename) 'error)
+(test (pair-filename () ()) 'error)
+(for-each
+ (lambda (arg)
+ (test (pair-filename arg) 'error))
+ (list "hi" (integer->char 65) #f 'a-symbol (make-vector 3) abs _ht_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0)
+ 3.14 3/4 1.0+1.0i #\f #t :hi (if #f #f) (lambda (a) (+ a 1))))
+
@@ -7680,7 +7798,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (assq 'x (cdr (assq 'a '((b . 32) (a . ((a . 12) (b . 32) (x . 1))) (c . 1))))) '(x . 1))
-(when (not pure-s7) (test (assq #f '(#f 2 . 3)) #f))
+(test (assq #f '(#f 2 . 3)) #f)
(test (assq #f '((#f 2) . 3)) '(#f 2))
(test (assq () '((() 1) (#f 2))) '(() 1))
(test (assq () '((1) (#f 2))) #f)
@@ -7689,7 +7807,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (assq 'b '((a . 1) (b . 2) () (c . 3) #f)) '(b . 2))
(test (assq 'c '((a . 1) (b . 2) () (c . 3) #f)) '(c . 3))
(test (assq 'b '((a . 1) (b . 2) () (c . 3) . 4)) '(b . 2))
-(when (not pure-s7) (test (assq 'c '((a . 1) (b . 2) () (c . 3) . 4)) '(c . 3)))
+(test (assq 'c '((a . 1) (b . 2) () (c . 3) . 4)) '(c . 3))
(test (assq 'b (list '(a . 1) '(b . 2) () '(c . 3) #f)) '(b . 2))
(test (assq 'asdf (list '(a . 1) '(b . 2) () '(c . 3) #f)) #f)
(test (assq "" (list '("a" . 1) '("" . 2) '(#() . 3))) #f) ; since (eq? "" "") is #f
@@ -7713,7 +7831,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
;;; --------------------------------------------------------------------------------
;;; assv
-(when (not pure-s7) (test (assv 1 '(1 2 . 3)) #f))
+(test (assv 1 '(1 2 . 3)) #f)
(test (assv 1 '((1 2) . 3)) '(1 2))
(let ((e '((a 1) (b 2) (c 3))))
@@ -7759,8 +7877,8 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (assv 'b '((a . 1) (b . 2) () (c . 3) #f)) '(b . 2))
(test (assv 'c '((a . 1) (b . 2) () (c . 3) #f)) '(c . 3))
(test (assv 'b '((a . 1) (b . 2) () (c . 3) . 4)) '(b . 2))
-(when (not pure-s7) (test (assv 'c '((a . 1) (b . 2) () (c . 3) . 4)) '(c . 3)))
-(when (not pure-s7) (test (assv 'asdf '((a . 1) (b . 2) () (c . 3) . 4)) #f))
+(test (assv 'c '((a . 1) (b . 2) () (c . 3) . 4)) '(c . 3))
+(test (assv 'asdf '((a . 1) (b . 2) () (c . 3) . 4)) #f)
(test (assv 'd '((a . 1) (b . 2) () (c . 3) (d . 5))) '(d . 5))
(test (assv 'a '((a . 1) (a . 2) (a . 3))) '(a . 1)) ; is this specified?
(test (assv 'a '((b . 1) (a . 2) (a . 3))) '(a . 2))
@@ -8182,7 +8300,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (member 3.0 '(1 #\a (3 . 3) abs #() 3+i)) #f)
(test (member 3.0 '(1 #\a (3 . 3) abs #() 3+i) (lambda (a b) (= (real-part a) b))) 'error)
(test (member 3.0 '(1 #\a (3 . 3) abs #() 3+i) (lambda (a b) (and (number? b) (= (real-part b) a)))) '(3+i))
-;; is it guaranteed that in the comparison function the value is 1st and the list member 2nd?
+;; is it guaranteed that in the comparison function the value is first and the list member 2nd?
(test (member 4 '((1 2 3) (4 5 6) (7 8 9)) member) '((4 5 6) (7 8 9)))
(test (member 4 '(1 2 3) member) 'error)
(test (member 4 '((1 2) (3 5) 7) (lambda (a b) (member a (map (lambda (c) (+ c 1)) b)))) '((3 5) 7))
@@ -9394,6 +9512,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (let ((v #(1 2))) (vector-set! v 0 32)) 32)
(test (let ((v #(1 2))) (set! (v 0) 32)) 32)
(test (let ((v #(1 2))) (set! (vector-ref v 0) 32)) 32)
+(test (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) #2D((0 23 0) (0 0 0)))
(for-each
(lambda (arg)
@@ -11688,6 +11807,125 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (+ 1 _an_undefined_variable_i_hope_) 33)
(set! (hook-functions *unbound-variable-hook*) old-hook))
+
+;;; optimizer bug involving unbound variable
+(let ()
+ (define (opt1)
+ (let ((val (let ()
+ (define (hi x y) (let ((m (memq x y)) (loc (and m (- x (length m))))) loc))
+ (hi 'a '(a b c)))))
+ (format-logged #t "~A: opt1 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt1
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" m))))
+ (format *stderr* "opt 1type: ~A, info: ~A~%" type info))
+ 'error)))
+(let ()
+ (define (opt2)
+ (let ((val (let ()
+ (define (hi x y) (let* ((n (memq x y)) (loc (and m (- x (length m)))) (m (+ n 1))) loc))
+ (hi 'a '(a b c)))))
+ (format-logged #t "~A: opt2 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt2
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" m))))
+ (format *stderr* "opt2 type: ~A, info: ~A~%" type info))
+ 'error)))
+
+(let ()
+ (define (opt3)
+ (let ((val (let ()
+ (define (hi x y) (do ((m (memq x y) 0) (loc (and m (- x (length m))) 0)) (loc #t)))
+ (hi 'a '(a b c)))))
+ (format-logged #t "~A: opt3 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt3
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" m))))
+ (format *stderr* "opt3 type: ~A, info: ~A~%" type info))
+ 'error)))
+
+(let ()
+ (define (opt4)
+ (let ()
+ (define (hi x y) (letrec ((m (memq x y)) (loc (and m (length m)))) loc))
+ (hi 'a '(a b c))))
+ (catch #t opt4
+ (lambda (type info)
+ 'error)))
+
+(let ()
+ (define (opt5)
+ (let ((val (let ()
+ (define (hi x y) (letrec* ((n (memq x y)) (loc (and m (- x (length m)))) (m (+ n 1))) loc))
+ (hi 'a '(a b c)))))
+ (format-logged #t "~A: opt5 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt5
+ (lambda (type info)
+ 'error)))
+
+(let ()
+ (define (opt6)
+ (let ((val (let ()
+ (define (hi x) (let ((m (memq n x)) (loc (and m (- x (length m))))) (define n 1) loc))
+ (hi '(a b c)))))
+ (format-logged #t "~A: opt6 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt6
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" n))))
+ (format *stderr* "opt6 type: ~A, info: ~A~%" type info))
+ 'error)))
+
+(let ()
+ (define (opt7)
+ (let ((val (let ()
+ (define* (f1 (a (+ m 1)) (m (+ a 1))) (+ a m))
+ (f1))))
+ (format-logged #t "~A: opt7 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt7
+ (lambda (type info)
+ 'error)))
+
+(let ()
+ (define (opt8)
+ (let ((val (let ()
+ (let ((x 1))
+ (set! x (+ m 1))
+ (define m 2)
+ x))))
+ (format-logged #t "~A: opt8 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt8
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" m))))
+ (format *stderr* "opt8 type: ~A, info: ~A~%" type info))
+ 'error)))
+
+(let ()
+ (define (opt9)
+ (let ((val (let ()
+ (let ((x 1)) (set! x (and m (length m))) (define m 2) x))))
+ (format-logged #t "~A: opt9 got ~S but expected 'error~%~%" (port-line-number) val)))
+ (catch #t opt9
+ (lambda (type info)
+ (if (or (not (eq? type 'syntax-error))
+ (not (equal? info '("~A: unbound variable" m))))
+ (format *stderr* "opt9 type: ~A, info: ~A~%" type info))
+ 'error)))
+
+(let ()
+ (define (opt10)
+ (let ()
+ (define* (f1 (a (and m (length m))) (m 1)) (+ a m))
+ (f1))) ; but not unbound var error! isn't this a bug?
+ (catch #t opt10
+ (lambda (type info)
+ 'error)))
+
+
(let ((old-load-hook (hook-functions *load-hook*))
(val #f))
(with-output-to-file "load-hook-test.scm"
@@ -11990,7 +12228,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(if (not (equal? ht1 ht2))
(format-logged #t ";ht1 and ht2 are empty, but not equal??~%"))
- ;; these 1st tests take advantage of s7's hashing function
+ ;; these first tests take advantage of s7's hashing function
(hash-table-set! ht1 'abc 1)
(hash-table-set! ht1 'abcabc 2)
(hash-table-set! ht1 'abcabcabc 3)
@@ -15200,6 +15438,9 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (format #f "1 2~C 3 4" #\null) "1 2\x00 3 4") ; this is also what Guile returns
(test (format #f "~nc" 3 #\a) "aaa")
(test (format #f "~nc" 0 #\a) "")
+(test (format #f "~0c" #\a) "")
+(test (format #f "~01c" #\a) "a")
+(test (format #f "~002c" #\a) "aa")
(test (format #f "~nc" -1 #\a) 'error)
(test (format #f "~nc" most-positive-fixnum #\a) 'error)
(test (format #f "~nc" 1.0 #\a) 'error)
@@ -15240,6 +15481,8 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (format #f "~{~A ~}" #2d((1 2) (3 4))) "1 2 3 4 ")
(test (format #f "1~\
a2" 3) "132")
+(test (format #f "1~
+ ~a2" 3) "132")
(test (format #f "~{~{~C~^ ~}~^...~}" (list "hiho" "test")) "h i h o...t e s t")
@@ -16300,6 +16543,8 @@ a2" 3) "132")
(let ((eof (read-line)))
(test (eof-object? eof) #t)))))
+(test (display 3 #f) 3)
+(test (write 3 #f) 3)
(let ((val (format #f "line 1~%line 2~%line 3")))
(call-with-input-string val
@@ -17519,7 +17764,7 @@ a2" 3) "132")
#|
(equal? (quote `1) (quote (quasiquote 1))) -> #f
-the reader sees `1 and turns it into 1 in the 1st case, but does not collapse the 2nd case to 1
+the reader sees `1 and turns it into 1 in the first case, but does not collapse the 2nd case to 1
(who knows, quasiquote might have been redefined in context... but ` can't be redefined):
:(define (` a) a)
;define: define a non-symbol? 'a
@@ -18325,9 +18570,12 @@ c"
(let ((a 1) (b 2)) (curlet))))
(when with-block
- (let ((b (block 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0)))
+ (let ((b (block 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0))
+ (old-plen (*s7* 'print-length)))
+ (set! (*s7* 'print-length) 2)
(test (format #f "~W" b) "(block 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000)")
- (test (format #f "~A" b) "(block ...)")))
+ (test (format #f "~A" b) "(block 1.000 2.000 ...)")
+ (set! (*s7* 'print-length) old-plen)))
(test (object->string (define (ex1 a b) (+ a b)) :readable) "(lambda (a b) (+ a b))")
(test (object->string (let ((c 3)) (define (ex1 a b) (+ a c b))) :readable) "(let ((c 3)) (lambda (a b) (+ a c b)))")
@@ -18351,7 +18599,7 @@ c"
(test (object->string (inlet 'a 3.0) :readable) "(inlet 'a 3.0)")
(test (object->string (inlet 'a 1/2) :readable) "(inlet 'a 1/2)")
(test (object->string (inlet 'a 1+i) :readable) "(inlet 'a 1+1i)")
-(test (object->string (inlet 'a (log 0)) :readable) (format #f "(inlet 'a (~S -inf.0 3.141592653589793))" (if pure-s7 'complex 'complex)))
+(test (object->string (inlet 'a (log 0)) :readable) (format #f "(inlet 'a (~S -inf.0 3.141592653589793))" 'complex))
(test (object->string (inlet 'a 1/0) :readable) "(inlet 'a nan.0)")
(test (object->string (inlet 'a "1") :readable) "(inlet 'a \"1\")")
(test (object->string (inlet 'a "") :readable) "(inlet 'a \"\")")
@@ -19470,6 +19718,24 @@ c"
|#
)
+;;; originally for-each/map used old_frame_with_slot, but if the closure had
+;;; a local define, the arg symbol was not updated (let_id), leading to segfaults
+;;; if the optimizer thought checks were unneeded. So...
+
+(let ()
+ (define (f1) (for-each (lambda (f3) (let ((x 0)) (if (> f3 x) (abs f3)))) (list 1 2))) (f1)
+ (define (f2) (for-each (lambda (f3) (define x 0) (if (> f3 x) (abs f3))) (list 1 2))) (f2)
+ (let ((f (let flet ((x 1)) (if (> x 0) (flet (- x 1))) flet))) (map f (list 1 2)))
+ (define (f4) (map (let flet ((x 1)) (if (> x 0) (flet (- x 1))) flet) (list 1 2))) (f4)
+ (define (f4a) (for-each (let flet ((x 1)) (if (> x 0) (flet (- x 1))) flet) (list 1 2))) (f4a)
+ (define (f4b) (for-each (let flet ((x 1)) (define y 0) (if (> x y) (flet (- x 1))) flet) (list 1 2))) (f4b)
+ (define (f5) (for-each (let () (define (f x) (if (> x 0) (f (- x 1)))) f) (list 1 2))) (f5)
+ (define (f5a) (for-each (let () (define (f x) (define y 0) (if (> x y) (f (- x 1)))) f) (list 1 2))) (f5a)
+ (define (f5b) (for-each (lambda (x) (define z 2) (define y 0) (if (> z x y) (display (- x 1)))) (list 1 2))) (f5b)
+ (define (f6) (map (let () (define (f x) (if (> x 0) (f (- x 1)) x)) f) (list 1 2))) (test (f6) '(0 0))
+ (define (f7) (map (let () (define (f x) (define y (+ x 1)) (if (> y 0) (f (- x 1)) x)) f) (list 1 2))) (test (f7) '(-1 -1))
+ )
+
;;; --------------------------------------------------------------------------------
@@ -19850,7 +20116,7 @@ c"
(or (equal? L '(3 32))
(equal? L '(4 3)))))
#t)
-;; in that 1st example, the set-cdr! is not the problem (map supposedly can treat its args in any order),
+;; in that first example, the set-cdr! is not the problem (map supposedly can treat its args in any order),
;; any set! will do:
(test (let ((x 0)) (map (lambda (y) (set! x (+ x y)) x) '(1 2 3 4))) '(1 3 6 10))
@@ -21241,6 +21507,7 @@ in s7:
(checker '(#\a) #\a)))))
(test (hi) ()))
+
(define (__a-func__ a)
(format-logged #t ";oops called first a-func by mistake: ~A~%" a)
(if (> a 0)
@@ -21528,6 +21795,10 @@ in s7:
(test (set! (#(a 0 (3)) 1) 0) 0)
(test (set! ('(a 0) 1) 0) 0)
(test (apply set! (apply list (list ''(1 2 3) 1)) '(32)) 32)
+(test (set! (let ((x 1)) x) 3) 'error)
+(test (set! (lambda () 1) 4) 'error)
+(test (set! (with-baffle (display x)) 5) 'error)
+(test (set! (define x 3) 6) 'error)
(let ()
(define-macro (symbol-set! var val) `(apply set! ,var (list ,val))) ; but this evals twice
@@ -21625,7 +21896,6 @@ in s7:
-
;;; --------------------------------------------------------------------------------
;;; and
;;; --------------------------------------------------------------------------------
@@ -21770,9 +22040,10 @@ in s7:
(test (let ((a #t)) (let ((b (lambda () (set! a (not a)) a))) (cond ((b) 1) ((b) 2) (t 3)))) 2)
(test (let ((otherwise else)) (cond ((= 1 2) 1) (otherwise 3))) 3)
(test (let ((otherwise #t)) (cond ((= 1 2) 1) (otherwise 3))) 3) ; or actually anything... 12 for example
-(test (let ((else #f)) (cond ((= 1 2) 1) (else 3))) ())
+(test (let ((else #f)) (cond ((= 1 2) 1) (else 3))) #<unspecified>) ; was () -- 31-Dec-15
(test (let ((else #f)) (cond ((= 1 2) 1) (#_else 3))) 3)
(test (let ((else 1)) (let ((otherwise else)) (case 0 (otherwise 1)))) 'error)
+(test (let ((x 1)) (cond ((< x 0) 1))) #<unspecified>)
(for-each
(lambda (arg)
@@ -22073,6 +22344,10 @@ in s7:
(test (case 1.0 ((1e0) 3) ((1.0) 4) (else 5)) 3)
(test (case 1.0 ((#i1) 2) ((1e0) 3) ((1.0) 4) (else 5)) 2)
(test (case 1 ((#i1) 2) ((1e0) 3) ((1.0) 4) (else 5)) 5)
+(test (let ((x :a)) (case x ((:b) 1) ((:a) 0) (else 3))) 0)
+
+(test (eval `(case ,+ ((,-) 0) ((,+) 1) (else 2))) 1)
+(test (case + ((#_-) 0) ((#_+) 2) (else 3)) 2)
(let ()
(define (c1 x)
@@ -23121,6 +23396,68 @@ in s7:
(test (let () (define (hi) 1 . 2)) 'error)
(test (let () (define (hi) (1) . "hi")) 'error)
+(test (let () (define (f f) f) (f 0)) 0)
+(test (let () (define (f f) (define* (f1 (f f)) f) (f1)) (f 0)) 0)
+(test (let () (define (f1 f) (define* (f (f f)) f) (f)) (procedure? (f1 0))) #t) ; ?? see comment in s7.c -- this might also return 0
+(test (let () (define (f f) (define* (f (f f)) f) (f)) (procedure? (f 0))) #t)
+(test (let ((f1 (define f2 32))) (+ f1 f2)) 64)
+(test (let () (define x (+ (define y 3) 2)) (list x y)) '(5 3))
+(test (let ((a 1) (b 2)) (define (f a b) (let ((a a) (b b)) (+ a b))) (f 4 3)) 7)
+
+;;; --------
+;;; check envs
+(test (let () (do ((i 0 (+ i 1))) ((= i 3) (define xyz 37) i)) xyz) 'error)
+(test (let () (do ((i 0 (+ i 1))) ((= i 3)) (define xyz 37)) xyz) 'error)
+(test (let () (do ((i (begin (define xyz 37) 0) (+ i 1))) ((= i 3))) xyz) 37)
+(test (let () (do ((i 0 (begin (define xyz 37) (+ i 1)))) ((= i 3))) xyz) 'error)
+
+(test (let () (let ((i (begin (define xyz 37) 0))) i) xyz) 37)
+(test (let () (let ((i 0)) (define xyz 37) i) xyz) 'error)
+
+(test (let () (let* ((i (begin (define xyz 37) 0))) i) xyz) 37)
+(test (let () (let* ((i 0)) (define xyz 37) i) xyz) 'error)
+(test (let () (let* ((k 0) (i (begin (define xyz 37) 0))) i) xyz) 'error)
+
+(test (let () (letrec ((i (begin (define xyz 37) 0))) i) xyz) 'error) ; ??? it's defined in the letrec
+(test (let () (letrec ((i (begin (define xyz 37) 0))) xyz)) 37) ; !
+(test (let () (letrec ((i 0)) (define xyz 37) i) xyz) 'error)
+
+(test (let () (letrec* ((i (begin (define xyz 37) 0))) i) xyz) 'error) ; ??? same as above
+(test (let () (letrec* ((i (begin (define xyz 37) 0))) xyz)) 37) ; !
+(test (let () (letrec* ((i 0)) (define xyz 37) i) xyz) 'error)
+(test (let () (letrec* ((k 0) (i (begin (define xyz 37) 0))) i) xyz) 'error)
+
+(test (let () (cond ((define xyz 37) #f)) xyz) 37)
+(test (let () (cond ((> 2 1) (define xyz 37) #f)) xyz) 37)
+(test (let () (cond ((< 2 1) 0) (else (define xyz 37) #f)) xyz) 37)
+
+(test (let () (if (define xyz 37) 0 1) xyz) 37)
+(test (let () (if (> 2 1) (define xyz 37) 1) xyz) 37)
+(test (let () (if (< 2 1) 0 (define xyz 37)) xyz) 37)
+
+(test (let () (when (define xyz 37) #f) xyz) 37)
+(test (let () (when (> 2 1) (define xyz 37) #f) xyz) 37)
+(test (let () (unless (define xyz 37) #f) xyz) 37)
+(test (let () (unless (< 2 1) (define xyz 37) #f) xyz) 37)
+
+(test (let () (quote (define xyz 37)) xyz) 'error)
+(test (let () (begin (define xyz 37) 0) xyz) 37)
+(test (let () (and (define xyz 37) 0) xyz) 37)
+(test (let () (or (define xyz 37) 0) xyz) 37)
+(test (let ((x 0)) (set! x (define xyz 37)) xyz) 37)
+(test (let () (with-let (curlet) (define xyz 37)) xyz) 37)
+(test (let () (with-let (inlet 'a 1) (define xyz 37)) xyz) 'error)
+(test (let () (with-baffle (define xyz 37) 2) xyz) 'error) ; with-baffle introduces a new frame
+
+(test (let () (case (define xyz 37) ((0) 1) ((37) #t)) xyz) 37)
+(test (let () (case 1 ((1) (define xyz 37)) ((0) 1)) xyz) 37)
+(test (let () (case 1 ((0) 1) (else (define xyz 37) 2)) xyz) 37)
+
+(test (let () (lambda () (define xyz 37)) xyz) 'error)
+(test (let () (define* (fxyz (a (define xyz 37))) a) (fxyz) xyz) 'error) ; ??? it's defined in fxyz!
+(test (let () (define* (fxyz (a (define xyz 37))) xyz) (fxyz)) 37) ; !
+;;; --------
+
(let ()
(define a#b 3)
(define a'b 4)
@@ -24048,20 +24385,9 @@ in s7:
(test (multiple-value-bind a (values 1 2 3) a) '(1 2 3))
(test (multiple-value-bind (x y z) (values 1 2 3) (list z y x)) '(3 2 1))
(test (multiple-value-bind (x y z) (values 1 2 3) (let ((x 4)) (list x y z))) '(4 2 3))
-(test (multiple-value-bind (x y z) (values 1 2 3 4 5 6) (list x y z)) '(1 2 3))
-(test (multiple-value-bind (x y z) (values 1 2) (list x y z)) '(1 2 #f))
-(test (multiple-value-bind (x y z) (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) (list x y z)) '(a b c))
-
-(test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64)) (+ a b)) 96)
-(test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64) (set! a (+ b 1))) (+ a b)) 129)
-(test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64 12)) (+ a b)) 96)
-(test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32)) (cons a b)) '(32 . #f))
-
-(test (multiple-value-set! #() "1234" #(0 1 2 3 4)) 'error)
-(test (multiple-value-set! "" #(0 1 2 3 4) :readable) 'error)
-(test (multiple-value-set! () #(0 1 2 3 4) :readable) 'error)
-(test (multiple-value-set! () ()) ())
-(test (multiple-value-set! () () 1 2) 2)
+(test (multiple-value-bind (x y z) (values 1 2 3 4 5 6) (list x y z)) 'error) ; was '(1 2 3)) -- 25-Jan-16
+(test (multiple-value-bind (x y z) (values 1 2) (list x y z)) 'error) ; was '(1 2 #f))
+(test (multiple-value-bind (x y z) (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) (list x y z)) 'error) ;was '(a b c))
(test (let ((add (lambda (a b) (values (+ a 1) (+ b 1))))) (+ 1 (add 2 3))) 8)
(test (min (values 1 2) (values 3 0)) 0)
@@ -24192,6 +24518,14 @@ in s7:
(num-test (let ((f- -) (f+ +)) (define (fb n) (if (< n 2.0) n (f+ (fb (f- n 1.0)) (fb (f- n 2.0))))) (fb 12.0)) 144.0)
(let ()
+ (define (flatten lst)
+ (map values (list (let flatten-1 ((lst lst))
+ (cond ((null? lst) (values))
+ ((not (pair? lst)) lst)
+ (else (values (flatten-1 (car lst))
+ (flatten-1 (cdr lst)))))))))
+#|
+ ;; old form
(define (flatten lst) ; flatten via values and map
(define (flatten-1 lst)
(cond ((null? lst) (values))
@@ -24199,6 +24533,7 @@ in s7:
(#t (values (flatten-1 (car lst))
(flatten-1 (cdr lst))))))
(map values (list (flatten-1 lst))))
+|#
(test (flatten '(1 2 3)) '(1 2 3))
(test (flatten ()) ())
@@ -24278,22 +24613,22 @@ in s7:
(test (hi 0) 3))
(let ()
- (define-macro (define-values vars . body)
+ (define-macro (define-values1 vars . body)
`(apply begin (map (lambda (var val) `(define ,var ,val)) ',vars (list (begin , at body)))))
- (define-macro (let*-values vars . body)
+ (define-macro (let*-values1 vars . body)
`(let ()
,@(map (lambda (nvars . nbody)
- `(apply define-values ',nvars ', at nbody))
+ `(apply define-values1 ',nvars ', at nbody))
(map car vars) (map cdr vars))
, at body))
(let ()
- (define-values (a b) (values 3 2))
+ (define-values1 (a b) (values 3 2))
(test (* a b) 6))
(let ()
- (test (let*-values (((a b) (values 3 2))) (* a b)) 6)))
+ (test (let*-values1 (((a b) (values 3 2))) (* a b)) 6)))
(define __p__ 123)
(define current-rootlet (curlet))
@@ -24471,6 +24806,7 @@ in s7:
(test (let ((x 1)) (let ((y 0)) (begin (let ((x (* 2 x))) (set! y x))) y)) 2)
(test (let* ((x 1) (x (+ x 1)) (x (+ x 2))) x) 4)
(test (let ((.. 2) (.... 4) (..... +)) (..... .. ....)) 6)
+(test (let ((\"a\"")) \) "a\"")
(test (let () (begin (define x 1)) x) 1)
(test (let ((define 1)) define) 1)
@@ -24500,6 +24836,9 @@ in s7:
(test (let* _name_ ((x 1) (y (_name_ 2))) (+ x y)) 'error)
(let () (define (hi) (let* named-let ((i 0) (j (+ i 1))) j)) (hi) (test (hi) 1))
+;; from lisp bboard
+(test (let ((x 1) (y 2)) (let ((x y) (y x)) (let ((x y) (y x)) (let ((x y) (y x)) (+ (* x x) y))))) 5)
+
(test ((let ((x 2))
(let ((x 3))
(lambda (arg) (+ arg x))))
@@ -24896,27 +25235,27 @@ in s7:
(+ 1 (p (- y 1))))))
(x (p 5))
(y x))
- y)
+ y)
5)
(test (letrec ((p (lambda (x)
(+ 1 (q (- x 1)))))
- (q (lambda (y)
- (if (zero? y)
- 0
- (+ 1 (p (- y 1))))))
- (x (p 5))
- (y x))
- y)
+ (q (lambda (y)
+ (if (zero? y)
+ 0
+ (+ 1 (p (- y 1))))))
+ (x (p 5))
+ (y x))
+ y)
'error)
(test (let* ((p (lambda (x)
(+ 1 (q (- x 1)))))
- (q (lambda (y)
- (if (zero? y)
- 0
- (+ 1 (p (- y 1))))))
- (x (p 5))
- (y x))
- y)
+ (q (lambda (y)
+ (if (zero? y)
+ 0
+ (+ 1 (p (- y 1))))))
+ (x (p 5))
+ (y x))
+ y)
'error)
(test (let ((x 1) ((y 2))) x) 'error)
@@ -25272,15 +25611,19 @@ in s7:
(test (let ((x 1)) (+ (begin (set! x 2) x) x)) 4)
(test (let ((x 1)) ((if (= x 1) + -) x (begin (set! x 2) x))) 3)
-(let ()
- (define-constant _letrec_x_ 32)
- (test (letrec ((_letrec_x_ 1)) _letrec_x_) 'error))
-(let ()
- (define-constant _let_x_ 32)
- (test (let ((_let_x_ 1)) _let_x_) 'error))
-(let ()
- (define-constant _let*_x_ 32)
- (test (let* ((_let*_x_ 1)) _let*_x_) 'error))
+(catch #t
+ (lambda ()
+ (let ()
+ (define-constant _letrec_x_ 32)
+ (test (letrec ((_letrec_x_ 1)) _letrec_x_) 'error))
+ (let ()
+ (define-constant _let_x_ 32)
+ (test (let ((_let_x_ 1)) _let_x_) 'error))
+ (let ()
+ (define-constant _let*_x_ 32)
+ (test (let* ((_let*_x_ 1)) _let*_x_) 'error)))
+ (lambda args 'error))
+
#|
;;; here is the old letrec* macro:
@@ -25733,7 +26076,7 @@ in s7:
(if (<= w 1024) (c w) r))))
'(2047 1023 511 255 127 63 31 15 7 3))
-;;; the 1st v is 1, the 3rd reflects the previous call/cc which reflects the
+;;; the first v is 1, the 3rd reflects the previous call/cc which reflects the
;;; env+slot that had the subsequent set! -- weird.
(test (let ((cc #f)
@@ -26069,12 +26412,13 @@ in s7:
(test ((a-func)) 'error) ;invalid-escape-function
(test ((b-func)) 33))
+#|
(test ((call-with-exit
(lambda (go)
(lambda ()
(eval-string "(go + 32 1)")))))
'error)
-
+|#
;;; (test ((call/cc (lambda (go) (lambda () (eval-string "(go + 32 1)"))))) 33)
;;; this is ok in the listener, but exits the load in this context
@@ -26453,7 +26797,6 @@ in s7:
(test (+ 1 (call/cc (lambda (r1) (call/cc (lambda (r2) (r1 2 3))))) 4) 10)
(test (+ 1 (call/cc (lambda (r1) (+ 5 (call/cc (lambda (r2) (r2 2 3)))))) 4) 15)
-
;;; from Andy Wingo's Guile blog
(let ()
(define (test1 get)
@@ -26507,7 +26850,21 @@ in s7:
(test (discriminate2 test1) #(42 1))
(test (discriminate2 test2) #(0 1)))
+(let ()
+ (define (gotof x)
+ (x (cond ((continuation? x) 1)
+ ((procedure? x) 2)
+ ((macro? x) 3)
+ ((sequence? x) 0)
+ (else (throw 'oops 4)))))
+ (test (call/cc gotof) 1)
+ (test (call-with-exit gotof) 2)
+ (test (gotof abs) 2)
+ (test (gotof (define-macro (m1 a) `(+ ,a ))) 3)
+ (test (catch 'oops (lambda () (gotof 21)) (lambda (type info) (car info))) 4)
+ (test (gotof #(5 9 10 11 12)) 5))
+
#|
;;; from bug-guile
(define k #f)
@@ -26673,7 +27030,6 @@ who says the continuation has to restart the map from the top?
(test (call-with-exit (lambda (go) (eval '(go 1)) 2)) 1)
(test (call-with-exit (lambda (go) (eval-string "(go 1)") 2)) 1)
(test (call-with-exit (lambda (go) `(,(go 1) 2))) 1)
-;;; (test (call-with-exit (lambda (go) `#(,(go 1) 2))) 'error) ; this is s7's choice -- read time #(...)
(test (call-with-exit (lambda (go) (case 0 ((0) (go 1) (go 2))))) 1)
(test (call-with-exit (lambda (go) (cond (1 => go)) 2)) 1)
(test (call-with-exit (lambda (go) (((cond ((go 1) => go)) 2)))) 1)
@@ -26681,8 +27037,8 @@ who says the continuation has to restart the map from the top?
(test (call-with-exit (lambda (go) (go (eval '(go 1))) 2)) 1)
(test (+ 10 (call-with-exit (lambda (go) (go (eval '(go 1))) 2))) 11)
-(test (call-with-exit (lambda (go) (go (eval-string "(go 1)")) 2)) 1)
-(test (call-with-exit (lambda (go) (eval-string "(go 1)") 2)) 1)
+;(test (call-with-exit (lambda (go) (go (eval-string "(go 1)")) 2)) 1)
+;(test (call-with-exit (lambda (go) (eval-string "(go 1)") 2)) 1)
(test (call-with-exit (lambda (go) ((eval 'go) 1) 2)) 1)
(test (eval-string "(call/cc (lambda (go) (if (go 1) (go 2) (go 3))))") 1)
(test (call-with-exit (lambda (quit) ((lambda* ((a (quit 32))) a)))) 32)
@@ -26705,6 +27061,7 @@ who says the continuation has to restart the map from the top?
5)
(let ()
+#|
(define-macro (while test . body)
`(call-with-exit
(lambda (break)
@@ -26715,6 +27072,17 @@ who says the continuation has to restart the map from the top?
(continue))
(break)))))
(continue)))))
+|#
+ (define-macro (while test . body) ; while loop with predefined break and continue
+ `(call-with-exit
+ (lambda (break)
+ (let continue ()
+ (if (let () ,test)
+ (begin
+ (let () , at body)
+ (continue))
+ (break))))))
+
(test (let ((i 0)
(sum 0)
(break 32)
@@ -27394,18 +27762,30 @@ who says the continuation has to restart the map from the top?
(lambda args
'oops)))
'oops)
-
+#|
(test (let ()
(call-with-exit
(lambda (return)
(eval-string "(return 3)"))))
3)
+
(test (let ()
(call-with-exit
(lambda (return)
(eval-string "(abs (+ 1 (if #t (return 3))))"))))
3)
+|#
+(test (let ()
+ (call-with-exit
+ (lambda (return)
+ (eval '(return 3)))))
+ 3)
+(test (let ()
+ (call-with-exit
+ (lambda (return)
+ (eval '(abs (+ 1 (if #t (return 3))))))))
+ 3)
(test (let ((val (catch #t
(lambda ()
(eval-string "(catch 'a (lambda () (+ 1 __asdf__)) (lambda args 'oops))"))
@@ -27462,7 +27842,7 @@ who says the continuation has to restart the map from the top?
(dw1 (+ a 1) c)))
(lambda ()
(set! z (+ z 1))
- (set! y (= y 1))))) ; an error after the 1st call because we have (= #f 1)
+ (set! y (= y 1))))) ; an error after the first call because we have (= #f 1)
(lambda args 'error)))
(let ((val (dw1 0 4)))
(test val 'error)))
@@ -27477,7 +27857,7 @@ who says the continuation has to restart the map from the top?
(lambda ()
(set! x (+ x 1)))
(lambda ()
- (set! y (= y 1)) ; an error after the 1st call because we have (= #f 1)
+ (set! y (= y 1)) ; an error after the first call because we have (= #f 1)
(or (and (>= a c) a)
(dw1 (+ a 1) c)))
(lambda ()
@@ -27495,7 +27875,7 @@ who says the continuation has to restart the map from the top?
(lambda ()
(dynamic-wind
(lambda ()
- (set! x (= x 1))) ; an error after the 1st call because we have (= #f 1)
+ (set! x (= x 1))) ; an error after the first call because we have (= #f 1)
(lambda ()
(set! y (= y 1))
(or (and (>= a c) a)
@@ -27640,38 +28020,6 @@ who says the continuation has to restart the map from the top?
))
;; mostly from gauche
-;;; the vector quasiquote comma-eval takes place in the global environment so
-;;; (let ((x 0)) (let ((y `#(,(begin (define x 32) x)))) (list x y))) -> '(0 #(32)) and defines x=32 in the top level
-
-(if with-qq-vectors (begin
- (test `#(1 ,@(list 1 2) 4) #(1 1 2 4))
- (if (eqv? 2 (sqrt 4))
- (test `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) #(10 5 2 4 3 8))) ; inexactness foolishness
- (test `#(,(cons 1 2) 3) #((1 . 2) 3))
- ; (test `#(,quasi0 3) #(99 3)) ; and (let ((quasi0 99)) (quasiquote #(,quasi0 3))) -> #((unquote quasi0) 3)
- ; (test `#(,(+ quasi0 1) 3) #(100 3))
- ; (test `#(3 ,quasi1) #(3 101))
- ; (test `#(3 ,(+ quasi1 1)) #(3 102))
- (test `#(1 ,@(list 2 3) 4) #(1 2 3 4))
- (test `#(1 2 ,@(list 3 4)) #(1 2 3 4))
- ; (test `#(, at quasi2 , at quasi3) #(a b c d))
- ; (test `#(, at quasi2 ,quasi3) #(a b (c d)))
- ; (test `#(,quasi2 , at quasi3) #((a b) c d))
- (test `#(,@(list)) #())
- (test `#(,@(list 1 2) ,@(list 1 2)) #(1 2 1 2))
- (test `#(,@(list 1 2) a ,@(list 1 2)) #(1 2 a 1 2))
- (test `#(a ,@(list 1 2) ,@(list 1 2)) #(a 1 2 1 2))
- (test `#(,@(list 1 2) ,@(list 1 2) a) #(1 2 1 2 a))
- (test `#(,@(list 1 2) ,@(list 1 2) a b) #(1 2 1 2 a b))
- ; (test `#(1 `(1 ,2 ,,(+ 1 2)) 1) #(1 `(1 ,2 ,3) 1))
- ; (test `#(1 `(1 ,,quasi0 ,,quasi1) 1) #(1 `(1 ,99 ,101) 1))
- (test `#(1 `(1 , at 2 ,@,(list 1 2))) #(1 `(1 , at 2 ,@(1 2))))
- ; (test `#(1 `(1 ,@,quasi2 ,@,quasi3)) #(1 `(1 ,@(a b) ,@(c d))))
- ; (test `#(1 `(1 ,(, at quasi2 x) ,(y , at quasi3))) #(1 `(1 ,(a b x) ,(y c d))))
- (test (eval-string "`#(1 2 3 unquote abs)") 'error) ; guile mailing list says it should work, but unquote is translated at the reader level
- ;; which does not know it's in a vector here, so s7 sees `#(1 2 3 . abs) which is indeed an error
- ))
-
(let ((quasi0 99)
(quasi1 101)
(quasi2 '(a b))
@@ -27710,19 +28058,8 @@ who says the continuation has to restart the map from the top?
(test `(1 `(1 , at 2 ,@,(list 1 2))) '(1 `(1 , at 2 ,@(1 2))))
(test `(1 `(1 ,@,quasi2 ,@,quasi3)) '(1 `(1 ,@(a b) ,@(c d))))
(test `(1 `(1 ,(, at quasi2 x) ,(y , at quasi3))) '(1 `(1 ,(a b x) ,(y c d))))
-; (test `(1 `#(1 ,(, at quasi2 x) ,(y , at quasi3))) '(1 `#(1 ,(a b x) ,(y c d))))
)
-(if with-qq-vectors (begin
- (test `#2d((1 ,(* 3 2)) (,@(list 2) 3)) #2D((1 6) (2 3)))
- (test `#3d() #3D())
- (test `#3D((,(list 1 2) (,(+ 1 2) 4)) (,@(list (list 5 6)) (7 8))) #3D(((1 2) (3 4)) ((5 6) (7 8))))))
-
-(test (eval-string "`#2d(1 2)") 'error)
-(test (eval-string "`#2d((1) 2)") 'error)
-(test (eval-string "`#2d((1 2) (3 4) (5 6 7))") 'error)
-(test `#2d((1 2)) #2D((1 2)))
-
(let ((x 3)
(y '(a b c)))
(test `(1 . ,2) '(1 . 2))
@@ -27795,11 +28132,6 @@ who says the continuation has to restart the map from the top?
`(1 , at x 4))
'(1 2 3 4))
-(if with-qq-vectors (begin
- (test `#(1 ,(/ 12 2)) #(1 6))
- (test `#(,most-positive-fixnum 2) #(9223372036854775807 2))
- (test ((lambda () `#(1 ,(/ 12 2)))) #(1 6))))
-
(test (let ((x '(2 3)))
`(1 ,@(map (lambda (a) (+ a 1)) x)))
'(1 3 4))
@@ -27807,8 +28139,6 @@ who says the continuation has to restart the map from the top?
;;; these are from the scheme bboard
(test (let ((x '(1 2 3))) `(0 . ,x)) '(0 1 2 3))
(test (let ((x '(1 2 3))) `(0 ,x)) '(0 (1 2 3)))
-;(test (let ((x '(1 2 3))) `#(0 ,x)) #(0 (1 2 3))) ; local var
-;(test (let ((x '(1 2 3))) `#(0 . ,x)) #(0 1 2 3)) ; same
;; unbound variable x, but (let ((x '(1 2 3))) (quasiquote #(0 . ,x))) -> #(0 unquote x)
;; so ` and (quasiquote...) are not the same in the vector case
@@ -27916,18 +28246,6 @@ who says the continuation has to restart the map from the top?
; (({apply_values} ''values 1)) got error but expected 1
;(test (`,@''.'.) '.'.)
; (({apply_values} ''values .'.)) got error but expected .'.
-(if with-qq-vectors (begin
- (test #(`,1) #(1))
- (test `#(,@'(1)) #(1))
- (test `#(,`,@''1) #(quote 1))
- (test `#(,@'(1 2 3)) #(1 2 3))
- (test `#(,`,@'(1 2 3)) #(1 2 3)) ; but #(`,@'(1 2 3)) -> #(({apply_values} '(1 2 3)))
- (test `#(,`#(1 2 3)) #(#(1 2 3)))
- (test `#(,`#(1 ,(+ 2 3))) #(#(1 5)))
- (test (quasiquote #(,`#(1 ,(+ 2 3)))) #(#(1 5)))
- (test `#(,`#(1 ,(+ `,@'(2 3)))) #(#(1 5)))
- (test `#(1 `,,(+ 2 3)) #(1 5))))
-
(test (apply . `''1) 'error) ; '(quote quote 1)) ; (apply {list} 'quote ({list} 'quote 1)) -> ;quote: too many arguments '1
(test (apply - 1( )) -1) ; (apply - 1 ())
(num-test (apply - 1.()) -1.0)
@@ -27962,14 +28280,6 @@ who says the continuation has to restart the map from the top?
(test (defined? '{append}) #t)
(test (let () (set! {append} 2)) 'error)
(test (let (({append} 2)) {append}) 'error)
-(test (defined? '{multivector}) #t)
-(test (let () (set! {multivector} 2)) 'error)
-(test (let (({multivector} 2)) {multivector}) 'error)
-
-(if with-qq-vectors (begin
- (test (+ 1 ((`#(,(lambda () 0) ,(lambda () 2) ,(lambda () 4)) 1))) 3) ; this calls vector each time, just like using vector directly
- (test `#(,@(list 1 2 3)) #(1 2 3)) ; but #(,@(list 1 2 3)) -> #((unquote ({apply_values} (list 1 2 3))))
- (test (+ 1 ((`(,(lambda () 0) ,(lambda () 2) ,(lambda () 4)) 1))) 3)))
(test (object->string (list 'quote 1 2)) "(quote 1 2)")
(test (object->string (list 'quote 'quote 1)) "(quote quote 1)")
@@ -29892,7 +30202,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
;;; here be bugs...
(test ((lambda* a a) :a) '(:a))
-(test ((lambda* (a . b) (list a b)) :b 1) '(#f 1)) ; ??? why doesn't the 1st arg work this way?
+(test ((lambda* (a . b) (list a b)) :b 1) '(#f 1)) ; ??? why doesn't the first arg work this way?
(test ((lambda* (a :rest b) (list a b)) :b 1) '(#f 1))
(test ((lambda* (:rest a) (list a)) :a 1) '((:a 1))) ; surely these are inconsistent
(test ((lambda* (a . b ) (list a b)) :b 1 1) '(#f (1))) ; so if trailer, overwrite is not error?
@@ -30391,12 +30701,16 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (old-and-let* ((hi 3) (ho #f)) (+ hi 1)) #f))
(let ()
+#|
(define-macro (and-let* vars . body)
`(let ()
(and ,@(map (lambda (var)
`(apply define ',var))
vars)
(begin , at body))))
+|#
+ (define-macro (and-let* vars . body) ; bind vars, if any is #f stop, else evaluate body with those bindings
+ `(let () (and ,@(map (lambda (v) `(define , at v)) vars) (begin , at body))))
(test (and-let* ((hi 3) (ho #f)) (+ hi 1)) #f)
(test (and-let* ((hi 3) (ho #t)) (+ hi 1)) 4))
@@ -30550,6 +30864,34 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(if (> (abs (- y (* 4 9.5))) 1e-9)
(format-logged #t "(2) ~A: ~A got ~S but expected ~S~%~%" (port-line-number) 'mac-y0 y (* 4 9.5)))))
+(let ((val 0))
+ (let ()
+ (define (f x)
+ (+ x 1))
+ (let ()
+ (define-macro (m x)
+ `(f ,x))
+ (let ()
+ (define (f x)
+ (* x x))
+ (let ()
+ (set! val (m 2))))))
+ (test val 4))
+
+(let ((val 0))
+ (let ()
+ (define (f x)
+ (+ x 1))
+ (let ()
+ (define-macro (m x)
+ (with-let (inlet 'f f 'x x)
+ `(,f ,x)))
+ (let ()
+ (define (f x)
+ (* x x))
+ (let ()
+ (set! val (m 2))))))
+ (test val 3))
@@ -30858,7 +31200,6 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (arity port-line-number) '(0 . 1))
(test (arity dilambda) '(2 . 2))
(test (arity letrec*) (cons 2 *max-arity*))
-(test (arity multiple-value-set!) (cons 2 *max-arity*))
(test (arity make-iterator) '(1 . 2))
(test (arity random-state) '(1 . 2))
(test (arity format) (cons 1 *max-arity*))
@@ -31336,7 +31677,17 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(define f1 (let ((signature '(real? boolean?)))
(lambda (x)
(if x 1.0 2.0))))
- (test (procedure-signature f1) '(real? boolean?)))
+ (test (procedure-signature f1) '(real? boolean?))
+ (define f2 f1)
+ (test (procedure-signature f1) '(real? boolean?))
+ (test (procedure-signature f2) '(real? boolean?))
+ (test (f1 #t) (f2 #t))
+ (define f3 f1)
+ (test (procedure-signature f1) '(real? boolean?))
+ (test (procedure-signature f2) '(real? boolean?))
+ (define f4 f2)
+ (test (procedure-signature f1) '(real? boolean?))
+ (test (procedure-signature f2) '(real? boolean?)))
(test (procedure-signature cddddr) '(#t pair?))
(test (procedure-signature *) (let ((L (list 'number?))) (set-cdr! L L) L))
@@ -31353,7 +31704,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature make-polar) '(number? real? real?))
(test (procedure-signature provided?) '(boolean? symbol?))
(test (procedure-signature make-byte-vector) (let ((L (list 'byte-vector? 'integer?))) (set-cdr! (cdr L) (cdr L)) L))
-(test (procedure-signature string-copy) (let ((L (list 'string?))) (set-cdr! L L) L))
+(test (procedure-signature string-copy) '(string? string?))
(test (procedure-signature append) (let ((L (list #t))) (set-cdr! L L) L))
(test (procedure-signature cosh) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature positive?) '(boolean? real?))
@@ -31378,7 +31729,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature rootlet) '(let?))
(test (procedure-signature object->string) '(string? #t (boolean? keyword?)))
(test (procedure-signature stacktrace) '(string? integer? integer? integer? integer? boolean?))
-(test (procedure-signature make-hook) #f)
+(test (procedure-signature make-hook) '(procedure? #t))
(test (procedure-signature string-length) '(integer? string?))
(test (procedure-signature char-whitespace?) '(boolean? char?))
(test (procedure-signature random) '(number? number? random-state?))
@@ -31451,7 +31802,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature make-keyword) '(keyword? string?))
(test (procedure-signature write-char) '(char? char? output-port?))
(test (procedure-signature float-vector-ref) (let ((L (list 'float? 'float-vector? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
-(test (procedure-signature cyclic-sequences) '(list? #t))
+(test (procedure-signature cyclic-sequences) '(proper-list? #t))
(test (procedure-signature reverse) '(sequence? sequence?))
(test (procedure-signature with-output-to-file) '(#t string? procedure?))
(test (procedure-signature procedure-documentation) '(string? procedure?))
@@ -31463,7 +31814,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature min) (let ((L (list 'real?))) (set-cdr! L L) L))
(test (procedure-signature sin) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature cadaar) '(#t pair?))
-(test (procedure-signature list) (let ((L (list 'pair? #t))) (set-cdr! (cdr L) (cdr L)) L))
+(test (procedure-signature list) (let ((L (list 'proper-list? #t))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature make-rectangular) '(number? real? real?))
(test (procedure-signature macro?) '(boolean? #t))
(test (procedure-signature inlet) (let ((L (list 'let? #t))) (set-cdr! (cdr L) (cdr L)) L))
@@ -31476,9 +31827,8 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature open-input-file) '(input-port? string? string?))
(test (procedure-signature keyword?) '(boolean? #t))
(test (procedure-signature acosh) (let ((L (list 'number?))) (set-cdr! L L) L))
-(test (procedure-signature make-hash-table) '(hash-table? integer? pair?))
-(test (procedure-signature string->list) (let ((L (list 'list? 'string? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
-(test (procedure-signature hash-table-size) (let ((L (list #t))) (set-cdr! L L) L))
+(test (procedure-signature make-hash-table) '(hash-table? integer? (procedure? pair?)))
+(test (procedure-signature string->list) (let ((L (list 'proper-list? 'string? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature cdaar) '(#t pair?))
(test (procedure-signature set-car!) '(#t pair? #t))
(test (procedure-signature lcm) (let ((L (list 'rational?))) (set-cdr! L L) L))
@@ -31489,12 +31839,12 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature vector-length) '(integer? vector?))
(test (procedure-signature read) '(#t input-port?))
(test (procedure-signature vector-fill!) (let ((L (list #t 'vector? #t 'integer?))) (set-cdr! (cdddr L) (cdddr L)) L))
-(test (procedure-signature for-each) (let ((L (list #t 'procedure? 'length))) (set-cdr! (cddr L) (cddr L)) L))
-(test (procedure-signature memq) '(#t #t pair?))
+(test (procedure-signature for-each) (let ((L (list #t 'procedure? 'sequence?))) (set-cdr! (cddr L) (cddr L)) L))
+(test (procedure-signature memq) '((pair? boolean?) #t list?))
(test (procedure-signature int-vector-set!) (let ((L (list 'integer? 'int-vector? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature call-with-input-file) '(#t string? procedure?))
(test (procedure-signature call-with-input-string) '(#t string? procedure?))
-(test (procedure-signature dilambda) #f)
+(test (procedure-signature dilambda) '(procedure? procedure? procedure?))
(test (procedure-signature hash-table?) '(boolean? #t))
(test (procedure-signature dilambda?) '(boolean? #t))
(test (procedure-signature not) '(boolean? #t))
@@ -31502,7 +31852,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature char-ci=?) (let ((L (list 'boolean? 'char?))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature c-object?) '(boolean? #t))
(test (procedure-signature vector?) '(boolean? #t))
-(test (procedure-signature length) (let ((L (list #t))) (set-cdr! L L) L))
+(test (procedure-signature length) '((real? boolean?) #t))
(test (procedure-signature caaddr) '(#t pair?))
(test (procedure-signature vector) (let ((L (list 'vector? #t))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature error) (let ((L (list #t))) (set-cdr! L L) L))
@@ -31533,7 +31883,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature c-pointer) '(c-pointer? integer?))
(test (procedure-signature string-ci>?) (let ((L (list 'boolean? 'string?))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature with-output-to-string) '(string? procedure?))
-(test (procedure-signature memv) '(#t #t pair?))
+(test (procedure-signature memv) '((pair? boolean?) #t list?))
(test (procedure-signature char?) '(boolean? #t))
(test (procedure-signature ash) (let ((L (list 'integer?))) (set-cdr! L L) L))
(test (procedure-signature denominator) '(integer? rational?))
@@ -31558,6 +31908,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature symbol) '(symbol? string?))
(test (procedure-signature asinh) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature pair-line-number) '(integer? pair?))
+(test (procedure-signature pair-filename) '(string? pair?))
(test (procedure-signature load) '(values string? let?))
(test (procedure-signature cos) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature iterate) '(#t iterator?))
@@ -31576,7 +31927,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature fill!) (let ((L (list #t 'sequence? #t 'integer?))) (set-cdr! (cdddr L) (cdddr L)) L))
(test (procedure-signature cdaadr) '(#t pair?))
(test (procedure-signature even?) '(boolean? integer?))
-(test (procedure-signature make-list) '(list? integer? #t))
+(test (procedure-signature make-list) '(proper-list? integer? #t))
(test (procedure-signature modulo) (let ((L (list 'real?))) (set-cdr! L L) L))
(test (procedure-signature defined?) '(boolean? symbol? let? boolean?))
(test (procedure-signature with-input-from-file) '(#t string? procedure?))
@@ -31589,7 +31940,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature set-current-input-port) '(input-port? input-port?))
(test (procedure-signature assq) '((pair? boolean?) #t list?))
(test (procedure-signature make-vector) '(vector? (integer? pair?) #t boolean?))
-(test (procedure-signature eval) '(values list? let?))
+(test (procedure-signature eval) '(values #t let?))
(test (procedure-signature caddr) '(#t pair?))
(test (procedure-signature cons) '(pair? #t #t))
(test (procedure-signature port-closed?) '(boolean? #t))
@@ -31627,7 +31978,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature set-current-error-port) '(output-port? output-port?))
(test (procedure-signature char-numeric?) '(boolean? char?))
(test (procedure-signature string-upcase) (let ((L (list 'string?))) (set-cdr! L L) L))
-(test (procedure-signature member) '(#t #t list? procedure?))
+(test (procedure-signature member) '((pair? boolean?) #t list? procedure?))
(test (procedure-signature close-output-port) '(#t output-port?))
(test (procedure-signature byte-vector) (let ((L (list 'byte-vector? 'integer?))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature cadar) '(#t pair?))
@@ -31637,9 +31988,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature floor) '(integer? real?))
(test (procedure-signature let-set!) '(#t let? symbol? #t))
(test (procedure-signature system) '(#t string? boolean?))
-(test (procedure-signature map) (let ((L (list 'list? 'procedure? 'length))) (set-cdr! (cddr L) (cddr L)) L))
+(test (procedure-signature map) (let ((L (list 'list? 'procedure? 'sequence?))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature caaaar) '(#t pair?))
-(test (procedure-signature port-line-number) '(integer? input-port?))
+(test (procedure-signature port-line-number) '(integer? (input-port? null?)))
(test (procedure-signature c-pointer?) '(boolean? #t))
(test (procedure-signature int-vector-ref) (let ((L (list 'integer? 'int-vector? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature gc) '(#t boolean?))
@@ -31676,7 +32027,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature string->symbol) '(symbol? string?))
(test (procedure-signature symbol->string) '(string? symbol?))
(test (procedure-signature read-string) '((string? eof-object?) integer? input-port?))
-(test (procedure-signature vector->list) (let ((L (list 'list? 'vector? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
+(test (procedure-signature vector->list) (let ((L (list 'proper-list? 'vector? 'integer?))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature odd?) '(boolean? integer?))
(test (procedure-signature atanh) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature read-byte) '((integer? eof-object?) input-port?))
@@ -31724,6 +32075,23 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(for-each test-sym st))
|#
+(let ((st (symbol-table)))
+ (for-each (lambda (s)
+ (if (and (procedure? (symbol->value s))
+ (let ((p (procedure-signature (symbol->value s))))
+ (and (pair? p)
+ (pair? (car p))
+ (or (null? (cdar p))
+ (memq #t (car p))
+ (let search ((lst (car p)))
+ (and (pair? lst)
+ (or (memq (car lst) (cdr lst))
+ (search (cdr lst)))))))))
+ (format *stderr* "~A: ~A?~%" s (procedure-signature (symbol->value s)))))
+ st))
+
+
+
;;; --------------------------------------------------------------------------------
;;; funclet
@@ -32179,6 +32547,7 @@ func
(test (let () __eval_var1__) 12)
(test (let () (eval '(begin (define __eval_var2__ 123) __eval_var__) (curlet)) __eval_var2__) 123)
(test (let () __eval_var2__) 'error)
+(test (let ((x 1) (y 2)) (eval-string "(set! x 3) (set! y 4)") (list x y)) '(3 4))
;; from scheme wg
(let ((x (list 'cons 1 2))
@@ -33218,7 +33587,7 @@ func
(+ 10 (- (char->integer c) (char->integer #\A))))))
(let* ((negative (char=? (str 0) #\-))
(len (length str))
- (j (if (or negative (char=? (str 0) #\+)) 2 1))) ; 1st char is "z"
+ (j (if (or negative (char=? (str 0) #\+)) 2 1))) ; first char is "z"
(do ((sum (char->digit (str j))
(+ (* sum radix) (char->digit (str j)))))
((= j (- len 1)) sum)
@@ -34355,6 +34724,15 @@ func
(test (f2) #(0 1 2)))
+(let ()
+ (varlet (curlet)
+ ((lambda (a b)
+ (define (f1 x) (+ x a))
+ (define (f2 x) (+ x a b))
+ (curlet))
+ 1 2))
+ (test (f1 3) 4)
+ (test (f2 3) 6))
(test (null? (let->list (rootlet))) #f)
@@ -34394,6 +34772,21 @@ func
(test ((inlet (inlet 'a 1)) 'a) 1)
(test ((inlet (inlet 'a 1) '(b . 2)) 'b) 2)
+(test (let ((c 1)) (set! (with-let (curlet) c) 32) c) 32)
+(test (let ((c (list 1 2))) (set! (with-let (curlet) (c 1)) 32) c) '(1 32))
+(test (let ((c (list 1 2))) (set! (with-let (curlet) (c 3)) 32) c) 'error)
+(test (let ((a (inlet 'b #(0 1)))) (set! (with-let a (b 0)) 1) ((a 'b) 0)) 1)
+(test (set! (with-let (curlet) 3) 2) 'error)
+(test (let ((c (list 1 2))) (set! (with-let (curlet) (c 3)) 32 0)) 'error)
+
+(let ((a (inlet 'abc (let ((inx 0)) (dilambda (lambda () inx) (lambda (y) (set! inx y)))))))
+ (set! ((a 'abc)) 32)
+ (test ((a 'abc)) 32)
+ (with-let a (set! (abc) 1))
+ (test (with-let a (abc)) 1)
+ (set! (with-let a (abc)) 3)
+ (test ((a 'abc)) 3))
+
(for-each
(lambda (arg)
(test (inlet arg) 'error)
@@ -34462,10 +34855,13 @@ func
(test (inlet :a 1 :b 2) (inlet 'a 1 'b 2))
(test (inlet 'pi 3.0) 'error)
+#|
+;; not sure about this...
(let ((e (inlet 'a 1)))
(test (let-set! e :a 2) #<undefined>)
(test (let-ref e :a) #<undefined>)
(test (let-ref e 'a) 1))
+|#
(for-each
(lambda (arg)
@@ -34929,17 +35325,19 @@ func
(hiho 2))
125)
|#
+
(test (let () ; here's one way for multiple functions to share a normal scheme closure
(define f1 (let ((x 23))
(lambda (a)
(+ x a))))
(define f2
- (with-let (funclet f1)
+ (with-let (outlet (funclet f1)) ; outlet is needed as of 28-Feb-16
(lambda (b)
(+ b (* 2 x)))))
(+ (f1 1) (f2 1)))
71)
+
(test (varlet) 'error)
(test (sublet 3) 'error)
(test (varlet 3) 'error)
@@ -35069,7 +35467,7 @@ func
(transparent-memq 'c 'x ce))
'((a) (b) #f)))))
-(test (let-set! (rootlet) :rest #f) 'error)
+;(test (let-set! (rootlet) :rest #f) 'error) ;??
(test (make-iterator) 'error)
@@ -35103,7 +35501,41 @@ func
(test (defined? (car (lti))) #t)
(test (let ((b (lti))) (equal? (symbol->value (car b)) (cdr b))) #t))
+;;; test keyword-as-let-ref-arg -- this is an experiment, see let_ref_1 and let_set_1
+(let ((e (inlet :name 'hi)))
+ (test (e :name) 'hi)
+ (set! (e :name) 'ho)
+ (test (e :name) 'ho)
+ (test (let-ref e :name) 'ho)
+ (let-set! e :name 'ha)
+ (test (e 'name) 'ha))
+(test ((rootlet) :abs) abs)
+(test ((rootlet) :allow-other-keys) #<undefined>)
+;;; but this only works directly, not in with-let:
+(test (with-let (inlet :x 1 :y 2) (+ :x :y)) 'error) ; + argument 1, :x, is a symbol but should be a number
+;;; but that's actually parallel to (+ 'x 'y) so I think it's not a show-stopper
+(let ((y 12))
+ (test ((curlet) :y) 12)
+ (define f1 (let ((x 32)) (lambda (a) (+ a x))))
+ (test ((funclet f1) :x) 32))
+(let ((e (inlet :a 1)))
+ (varlet e :b 2)
+ (test (e 'b) 2)
+ (cutlet e :a)
+ (test (e 'a) #<undefined>))
+
+(let ((e (inlet 'a 1 'b 2 'c 3 'd 4)))
+ (test (object->string e) "(inlet 'a 1 'b 2 'c 3 'd 4)")
+ (let ((old-plen (*s7* 'print-length)))
+ (set! (*s7* 'print-length) 2)
+ (test (object->string e) "(inlet 'a 1 'b 2 ...)")
+ (set! (*s7* 'print-length) 4)
+ (test (object->string e) "(inlet 'a 1 'b 2 'c 3 'd 4)")
+ (set! (*s7* 'print-length) 3)
+ (test (object->string e) "(inlet 'a 1 'b 2 'c 3 ...)")
+ (set! (*s7* 'print-length) old-plen)))
+
;;; make-type ----------------
(let ()
@@ -36049,8 +36481,8 @@ hi6: (string-app...
(test (dilambda (lambda () 1) (lambda (a) a) (lambda () 2)) 'error)
(test (dilambda (lambda () 1) 2) 'error)
(test (call-with-exit (lambda (return) (let ((g (dilambda return (lambda (s v) s)))) (g 0)))) 'error)
-(test (call-with-exit (lambda (return) (let ((g (dilambda (lambda (s) s) return))) (g 0)))) 0) ; ??
-(test (+ (call-with-exit (lambda (return) (let ((g (dilambda (lambda (s) s) return))) (set! (g 1) 2))))) 3) ; ??
+(test (call-with-exit (lambda (return) (let ((g (dilambda (lambda (s) s) return))) (g 0)))) 'error)
+(test (+ (call-with-exit (lambda (return) (let ((g (dilambda (lambda (s) s) return))) (set! (g 1) 2))))) 'error)
(for-each
(lambda (arg)
@@ -36358,8 +36790,8 @@ hi6: (string-app...
(f2 (float-vector 11 12))
(p1 (list 13 14))
(p2 (list 15 16))
- (b1 (if with-block (block 17 18) (vector 17 18)))
- (b2 (if with-block (block 19 20) (vector 19 20)))
+ (b1 (if with-block (block 17 18) (float-vector 17 18)))
+ (b2 (if with-block (block 19 20) (float-vector 19 20)))
(s1 (make-string 2 #\a))
(s2 (make-string 2 #\b)))
(test (copy e1 e2) (inlet 'a 3 'c 3 'b 2 'a 1))
@@ -36368,7 +36800,7 @@ hi6: (string-app...
(test (copy e1 f2) 'error)
(test (copy e1 h2) (hash-table '(a . 1) '(b . 2) '(e . 7) '(f . 6)))
(test (copy e1 p2) '((b . 2) (a . 1)))
- (test (copy e1 b2) 'error)
+ (if with-block (test (copy e1 b2) 'error))
(test (copy e1 s2) 'error)
(test (copy v1 e2) 'error)
(test (copy v1 v2) #(1 2))
@@ -36376,7 +36808,7 @@ hi6: (string-app...
(test (copy v1 f2) (float-vector 1.0 2.0))
(test (copy v1 h2) 'error)
(test (copy v1 p2) '(1 2))
- (test (copy v1 b2) (block 1.000 2.000))
+ (if with-block (test (copy v1 b2) (block 1.000 2.000)))
(test (copy v1 s2) 'error)
(test (copy i1 e2) 'error)
(test (copy i1 v2) #(5 6))
@@ -36384,7 +36816,7 @@ hi6: (string-app...
(test (copy i1 f2) (float-vector 5.0 6.0))
(test (copy i1 h2) 'error)
(test (copy i1 p2) '(5 6))
- (test (copy i1 b2) (block 5.000 6.000))
+ (if with-block (test (copy i1 b2) (block 5.000 6.000)))
(test (copy i1 s2) "\x05\x06")
(test (copy f1 e2) 'error)
(test (copy f1 v2) #(9.0 10.0))
@@ -36392,7 +36824,7 @@ hi6: (string-app...
(test (copy f1 f2) (float-vector 9.0 10.0))
(test (copy f1 h2) 'error)
(test (copy f1 p2) '(9.0 10.0))
- (test (copy f1 b2) (block 9.000 10.000))
+ (if with-block (test (copy f1 b2) (block 9.000 10.000)))
(test (copy f1 s2) 'error)
(test (copy h1 e2) (inlet 'a 3 'c 3 'b 2 'a 1 'd 4 'e 5))
(test (let ((h (copy h1 v2)))
@@ -36414,7 +36846,7 @@ hi6: (string-app...
(test (copy p1 f2) (float-vector 13.0 14.0))
(test (copy p1 h2) 'error)
(test (copy p1 p2) '(13 14))
- (test (copy p1 b2) (block 13.000 14.000))
+ (test (copy p1 b2) (if with-block (block 13.000 14.000) (float-vector 13.0 14.0)))
(test (copy p1 s2) 'error)
(test (copy b1 e2) 'error)
(test (copy b1 v2) #(17.0 18.0))
@@ -36422,7 +36854,7 @@ hi6: (string-app...
(test (copy b1 f2) (float-vector 17.0 18.0))
(test (copy b1 h2) 'error)
(test (copy b1 p2) '(17.0 18.0))
- (test (copy b1 b2) (block 17.000 18.000))
+ (test (copy b1 b2) (if with-block (block 17.000 18.000) (float-vector 17.0 18.0)))
(test (copy b1 s2) 'error)
(test (copy s1 e2) 'error)
(test (copy s1 v2) #(#\a #\a))
@@ -36430,7 +36862,7 @@ hi6: (string-app...
(test (copy s1 f2) (float-vector 97.0 97.0))
(test (copy s1 h2) 'error)
(test (copy s1 p2) '(#\a #\a))
- (test (copy s1 b2) 'error)
+ (if with-block (test (copy s1 b2) 'error))
(test (copy s1 s2) "aa"))
(let ((e1 (inlet 'a 1 'b 2))
@@ -36445,8 +36877,8 @@ hi6: (string-app...
(f2 (float-vector 11 12))
(p1 (list 13 14))
(p2 (list 15 16))
- (b1 (if with-block (block 17 18) (vector 17 18)))
- (b2 (if with-block (block 19 20) (vector 19 20)))
+ (b1 (if with-block (block 17 18) (float-vector 17 18)))
+ (b2 (if with-block (block 19 20) (float-vector 19 20)))
(s1 (make-string 2 #\a))
(s2 (make-string 2 #\b)))
(test (copy e1 e2 1) (inlet 'a 3 'c 3 'a 1))
@@ -36455,7 +36887,7 @@ hi6: (string-app...
(test (copy e1 f2 1) 'error)
(test (copy e1 h2 1) (hash-table '(a . 1) '(e . 7) '(f . 6)))
(test (copy e1 p2 1) '((a . 1) 16))
- (test (copy e1 b2 1) 'error)
+ (if with-block (test (copy e1 b2 1) 'error))
(test (copy e1 s2 1) 'error)
(test (copy v1 e2 1) 'error)
(test (copy v1 v2 1) #(2 4))
@@ -36463,7 +36895,7 @@ hi6: (string-app...
(test (copy v1 f2 1) (float-vector 2.0 12.0))
(test (copy v1 h2 1) 'error)
(test (copy v1 p2 1) '(2 16))
- (test (copy v1 b2 1) (block 2.000 20.000))
+ (if with-block (test (copy v1 b2 1) (block 2.000 20.000)))
(test (copy v1 s2 1) 'error)
(test (copy i1 e2 1) 'error)
(test (copy i1 v2 1) #(6 4))
@@ -36471,7 +36903,7 @@ hi6: (string-app...
(test (copy i1 f2 1) (float-vector 6.0 12.0))
(test (copy i1 h2 1) 'error)
(test (copy i1 p2 1) '(6 16))
- (test (copy i1 b2 1) (block 6.000 20.000))
+ (if with-block (test (copy i1 b2 1) (block 6.000 20.000)))
(test (copy i1 s2 1) "\x06b")
(test (copy f1 e2 1) 'error)
(test (copy f1 v2 1) #(10.0 4))
@@ -36479,7 +36911,7 @@ hi6: (string-app...
(test (copy f1 f2 1) (float-vector 10.0 12.0))
(test (copy f1 h2 1) 'error)
(test (copy f1 p2 1) '(10.0 16))
- (test (copy f1 b2 1) (block 10.000 20.000))
+ (if with-block (test (copy f1 b2 1) (block 10.000 20.000)))
(test (copy f1 s2 1) 'error)
(test (let ((e (copy h1 e2 1)))
(or (equal? e (inlet 'a 3 'c 3 'a 1 'e 5))
@@ -36507,7 +36939,7 @@ hi6: (string-app...
(test (copy p1 f2 1) (float-vector 14.0 12.0))
(test (copy p1 h2 1) 'error)
(test (copy p1 p2 1) '(14 16))
- (test (copy p1 b2 1) (block 14.000 20.000))
+ (test (copy p1 b2 1) (if with-block (block 14.000 20.000) (float-vector 14.0 20.0)))
(test (copy p1 s2 1) 'error)
(test (copy b1 e2 1) 'error)
(test (copy b1 v2 1) #(18.0 4))
@@ -36515,7 +36947,7 @@ hi6: (string-app...
(test (copy b1 f2 1) (float-vector 18.0 12.0))
(test (copy b1 h2 1) 'error)
(test (copy b1 p2 1) '(18.0 16))
- (test (copy b1 b2 1) (block 18.000 20.000))
+ (test (copy b1 b2 1) (if with-block (block 18.000 20.000) (float-vector 18.0 20.0)))
(test (copy b1 s2 1) 'error)
(test (copy s1 e2 1) 'error)
(test (copy s1 v2 1) #(#\a 4))
@@ -36523,7 +36955,7 @@ hi6: (string-app...
(test (copy s1 f2 1) (float-vector 97.0 12.0))
(test (copy s1 h2 1) 'error)
(test (copy s1 p2 1) '(#\a 16))
- (test (copy s1 b2 1) 'error)
+ (if with-block (test (copy s1 b2 1) 'error))
(test (copy s1 s2 1) "ab"))
#|
@@ -38617,6 +39049,25 @@ hi6: (string-app...
'(32 32))
;; oops! fluid-let doesn't actually work
+ ;; to make this work, use symbol->dynamic-value. See also let-temporarily in stuff.scm.
+ (test (let ((x 32)
+ (y 0))
+ (define (gx) (symbol->dynamic-value 'x))
+ (let ((x 100))
+ (let ((x 12)) ; no need for fluid-let anymore
+ (set! y (gx))))
+ (list x y))
+ '(32 12))
+
+ (test (let ((y 0))
+ (define (gx) (symbol->dynamic-value 'x))
+ (let ((x 100))
+ (let ((x 12))
+ (set! y (gx))
+ (set! x 123))
+ (list x y)))
+ '(100 12))
+
;; in CL: (defvar x 32) (let ((y 0)) (defun gx () x) (let ((x 12)) (setf y (gx))) (list x y)) -> '(32 12)
;; (let ((y 0)) (defun gx () x) (let ((x 100)) (let ((x 12)) (setf y (gx)))) (list x y)) -> '(32 12)
;; (let ((y 0)) (defun gx () x) (let ((x 100)) (let ((x 12)) (setf y (gx)) (setf x 123)) (list x y))) -> '(100 12) !
@@ -40843,33 +41294,34 @@ hi6: (string-app...
(test-t (equal (substitute '(a) 'x '((x) (y) (z)) :key car) '((a) (y) (z))))
(test-t (equal (substitute 'c 'b '(a b a b a b a b)) '(a c a c a c a c)))
(test-t (equal (substitute 'a 'b '(b b b)) '(a a a)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f)) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1 :from-end t) '(a x b x c x d x e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2 :from-end t) '(a x b x c x d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3 :from-end t) '(a x b x c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4 :from-end t) '(a x b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
- (test-t (equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
+ (define axbx-etc '(a x b x c x d x e x f))
+ (test-t (equal (substitute 'z 'x axbx-etc) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 0) axbx-etc))
+ (test-t (equal (substitute 'z 'x axbx-etc :count -100) axbx-etc))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count nil :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 0 :from-end t) axbx-etc))
+ (test-t (equal (substitute 'z 'x axbx-etc :count -100 :from-end t) axbx-etc))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 1 :from-end t) '(a x b x c x d x e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 2 :from-end t) '(a x b x c x d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 3 :from-end t) '(a x b x c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 4 :from-end t) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 5 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 6 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :count 7 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
+ (test-t (equal (substitute 'z 'x axbx-etc :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
(test-t (equal (substitute #\z #\c '(#\a #\b #\c #\d #\e #\f) :test char<) '(#\a #\b #\c #\z #\z #\z)))
(test-t (equal (substitute "peace" "war" '("war" "War" "WAr" "WAR") :test string-equal) '("peace" "peace" "peace" "peace")))
(test-t (equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") :test string=) '("war" "War" "WAr" "peace")))
@@ -40950,33 +41402,33 @@ hi6: (string-app...
(test-t (equal (substitute-if '(a) (lambda (arg) (eq arg 'x)) '((x) (y) (z)) :key car) '((a) (y) (z))))
(test-t (equal (substitute-if 'c (lambda (arg) (eq arg 'b)) '(a b a b a b a b)) '(a c a c a c a c)))
(test-t (equal (substitute-if 'a (lambda (arg) (eq arg 'b)) '(b b b)) '(a a a)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f)) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 7) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count nil :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 0 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count -100 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 1 :from-end t) '(a x b x c x d x e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 2 :from-end t) '(a x b x c x d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 3 :from-end t) '(a x b x c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 4 :from-end t) '(a x b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 5 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 6 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :count 7 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
- (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) '(a x b x c x d x e x f) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 0) axbx-etc))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count -100) axbx-etc))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count nil :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 0 :from-end t) axbx-etc))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count -100 :from-end t) axbx-etc))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 1 :from-end t) '(a x b x c x d x e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 2 :from-end t) '(a x b x c x d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 3 :from-end t) '(a x b x c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 4 :from-end t) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 5 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 6 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :count 7 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
+ (test-t (equal (substitute-if 'z (lambda (arg) (eq arg 'x)) axbx-etc :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
(test-t (equal (substitute-if #\z (lambda (arg) (char< #\c arg)) '(#\a #\b #\c #\d #\e #\f)) '(#\a #\b #\c #\z #\z #\z)))
(test-t (equal (substitute-if "peace" (lambda (arg) (equal "war" arg)) '("love" "hate" "war" "peace")) '("love" "hate" "peace" "peace")))
(test-t (equal (substitute-if "peace" (lambda (arg) (string-equal "war" arg)) '("war" "War" "WAr" "WAR")) '("peace" "peace" "peace" "peace")))
@@ -41075,33 +41527,33 @@ hi6: (string-app...
(test-t (equal (substitute-if-not '(a) (lambda (arg) (not (eq arg 'x))) '((x) (y) (z)) :key car) '((a) (y) (z))))
(test-t (equal (substitute-if-not 'c (lambda (arg) (not (eq arg 'b))) '(a b a b a b a b)) '(a c a c a c a c)))
(test-t (equal (substitute-if-not 'a (lambda (arg) (not (eq arg 'b))) '(b b b)) '(a a a)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f)) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 7) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count nil :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 0 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count -100 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 1 :from-end t) '(a x b x c x d x e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 2 :from-end t) '(a x b x c x d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 3 :from-end t) '(a x b x c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 4 :from-end t) '(a x b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 5 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 6 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :count 7 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
- (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) '(a x b x c x d x e x f) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 0) axbx-etc))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count -100) axbx-etc))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count nil :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 0 :from-end t) axbx-etc))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count -100 :from-end t) axbx-etc))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 1 :from-end t) '(a x b x c x d x e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 2 :from-end t) '(a x b x c x d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 3 :from-end t) '(a x b x c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 4 :from-end t) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 5 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 6 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :count 7 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
+ (test-t (equal (substitute-if-not 'z (lambda (arg) (not (eq arg 'x))) axbx-etc :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
(test-t (equal (substitute-if-not #\z (lambda (arg) (not (char< #\c arg))) '(#\a #\b #\c #\d #\e #\f)) '(#\a #\b #\c #\z #\z #\z)))
(test-t (equal (substitute-if-not "peace" (lambda (arg) (not (equal "war" arg))) '("love" "hate" "war" "peace")) '("love" "hate" "peace" "peace")))
(test-t (equal (substitute-if-not "peace" (lambda (arg) (not (string-equal "war" arg))) '("war" "War" "WAr" "WAR")) '("peace" "peace" "peace" "peace")))
@@ -41199,33 +41651,33 @@ hi6: (string-app...
(test-t (equal (nsubstitute '(a) 'x (copy-seq '((x) (y) (z))) :key car) '((a) (y) (z))))
(test-t (equal (nsubstitute 'c 'b (copy-seq '(a b a b a b a b))) '(a c a c a c a c)))
(test-t (equal (nsubstitute 'a 'b (copy-seq '(b b b))) '(a a a)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 7) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count nil :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 0 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count -100 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 1 :from-end t) '(a x b x c x d x e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 2 :from-end t) '(a x b x c x d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 3 :from-end t) '(a x b x c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 4 :from-end t) '(a x b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 5 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 6 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 7 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
- (test-t (equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc)) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 0) axbx-etc))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count -100) axbx-etc))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count nil :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 0 :from-end t) axbx-etc))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count -100 :from-end t) axbx-etc))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 1 :from-end t) '(a x b x c x d x e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 2 :from-end t) '(a x b x c x d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 3 :from-end t) '(a x b x c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 4 :from-end t) '(a x b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 5 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 6 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :count 7 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
+ (test-t (equal (nsubstitute 'z 'x (copy-seq axbx-etc) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
(test-t (equal (nsubstitute #\z #\c (copy-seq '(#\a #\b #\c #\d #\e #\f)) :test char<) '(#\a #\b #\c #\z #\z #\z)))
(test-t (equal (nsubstitute "peace" "war" (copy-seq '("love" "hate" "war" "peace")) :test equal) '("love" "hate" "peace" "peace")))
(test-t (equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR")) :test string-equal) '("peace" "peace" "peace" "peace")))
@@ -41304,33 +41756,33 @@ hi6: (string-app...
(test-t (equal (nsubstitute-if '(a) (lambda (arg) (eq arg 'x)) (copy-seq '((x) (y) (z))) :key car) '((a) (y) (z))))
(test-t (equal (nsubstitute-if 'c (lambda (arg) (eq arg 'b)) (copy-seq '(a b a b a b a b))) '(a c a c a c a c)))
(test-t (equal (nsubstitute-if 'a (lambda (arg) (eq arg 'b)) (copy-seq '(b b b))) '(a a a)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f))) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 7) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count nil :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 0 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count -100 :from-end t) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 1 :from-end t) '(a x b x c x d x e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 2 :from-end t) '(a x b x c x d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 3 :from-end t) '(a x b x c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 4 :from-end t) '(a x b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 5 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 6 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :count 7 :from-end t) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
- (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq '(a x b x c x d x e x f)) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc)) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 0) axbx-etc))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count -100) axbx-etc))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count nil :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 0 :from-end t) axbx-etc))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count -100 :from-end t) axbx-etc))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 1 :from-end t) '(a x b x c x d x e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 2 :from-end t) '(a x b x c x d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 3 :from-end t) '(a x b x c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 4 :from-end t) '(a x b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 5 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 6 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :count 7 :from-end t) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :end nil :count 1) '(a x b z c x d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :end 6 :count 100) '(a x b z c z d x e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :end 11 :count 100) '(a x b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :end 8 :count 10) '(a x b z c z d z e x f)))
+ (test-t (equal (nsubstitute-if 'z (lambda (arg) (eq arg 'x)) (copy-seq axbx-etc) :start 2 :end 8 :count 2 :from-end t) '(a x b x c z d z e x f)))
(test-t (equal (nsubstitute-if #\z (lambda (arg) (char< #\c arg)) (copy-seq '(#\a #\b #\c #\d #\e #\f))) '(#\a #\b #\c #\z #\z #\z)))
(test-t (equal (nsubstitute-if "peace" (lambda (arg) (equal "war" arg)) (copy-seq '("love" "hate" "war" "peace"))) '("love" "hate" "peace" "peace")))
(test-t (equal (nsubstitute-if "peace" (lambda (arg) (string-equal "war" arg)) (copy-seq '("war" "War" "WAr" "WAR"))) '("peace" "peace" "peace" "peace")))
@@ -41417,17 +41869,17 @@ hi6: (string-app...
(test-t (equal (nsubstitute-if-not '(a) (lambda (arg) (not (eq arg 'x))) (copy-seq '((x) (y) (z))) :key car) '((a) (y) (z))))
(test-t (equal (nsubstitute-if-not 'c (lambda (arg) (not (eq arg 'b))) (copy-seq '(a b a b a b a b))) '(a c a c a c a c)))
(test-t (equal (nsubstitute-if-not 'a (lambda (arg) (not (eq arg 'b))) (copy-seq '(b b b))) '(a a a)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f))) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count nil) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 0) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count -100) '(a x b x c x d x e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 1) '(a z b x c x d x e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 2) '(a z b z c x d x e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 3) '(a z b z c z d x e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 4) '(a z b z c z d z e x f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 5) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 6) '(a z b z c z d z e z f)))
- (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq '(a x b x c x d x e x f)) :count 7) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc)) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count nil) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 0) axbx-etc))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count -100) axbx-etc))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 1) '(a z b x c x d x e x f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 2) '(a z b z c x d x e x f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 3) '(a z b z c z d x e x f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 4) '(a z b z c z d z e x f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 5) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 6) '(a z b z c z d z e z f)))
+ (test-t (equal (nsubstitute-if-not 'z (lambda (arg) (not (eq arg 'x))) (copy-seq axbx-etc) :count 7) '(a z b z c z d z e z f)))
)
(let ()
@@ -45724,11 +46176,6 @@ hi6: (string-app...
(test (let ((val (list 1 2 3 4 5 6 7 8 9 10))) (nth 7 val)) 8)
(test (let ((val (list 1 2 3 4 5 6 7 8 9 10))) (nth 17 val)) ())
- (test (let*-values (((x) (values 1))) x) 1)
- (test (let*-values ((x (values 1))) x) '(1))
- (test (let*-values (((x) (values 1)) ((y) (values 2))) (list x y)) '(1 2))
- (test (let*-values (((x) (values 1)) ((y) (values (+ x 1)))) (list x y)) '(1 2))
-
(test (let () (enum one two three) (list one two three)) '(0 1 2))
(test (let () (defstruct x1 a b c) (let ((xx1 (make-x1 1 2 3))) (list (x1-a xx1) (x1-b xx1) (x1-c xx1) (x1? xx1)))) '(1 2 3 #t))
@@ -50549,9 +50996,8 @@ hi6: (string-app...
(let ((cur (ints i)))
(if (= i 0)
(set! 1s (cons (logand cur (apply log-n-of (- n 1) (cdr ints))) 1s))
- (let* ((mid (cdr prev))
- (nxt (if (= i (- len 1)) () (cdr mid))))
- (set! (cdr prev) nxt)
+ (let ((mid (cdr prev)))
+ (set! (cdr prev) (if (= i (- len 1)) () (cdr mid)))
(set! 1s (cons (logand cur (apply log-n-of (- n 1) ints)) 1s))
(set! (cdr prev) mid)
(set! prev mid)))))))))
@@ -56088,6 +56534,9 @@ hi6: (string-app...
(num-test (min -0.0) 0.0)
(num-test (min -1 -1/2) -1)
+(num-test (min -1/2 0) -1/2)
+(num-test (min 0 -1/2) -1/2)
+(num-test (min -1 1/2) -1)
(num-test (min -1 1/2) -1)
(num-test (min -1.0) -1.0)
(num-test (min -1.797693134862315699999999999999999999998E308 -9223372036854775808) -1.797693134862315699999999999999999999998E308)
@@ -56461,6 +56910,10 @@ hi6: (string-app...
(num-test (max -0.0) 0.0)
(num-test (max -1 -1/2) -1/2)
+(num-test (max -1/2 0) 0)
+(num-test (max -1/2 -1) -1/2)
+(num-test (max 0 -1/2) 0)
+(num-test (max -1 -1/2) -1/2)
(num-test (max -1 1/2) 1/2)
(num-test (max -1.0) -1.0)
(num-test (max -1.797693134862315699999999999999999999998E308 -9223372036854775808) -9.223372036854775808E18)
@@ -56797,7 +57250,7 @@ hi6: (string-app...
(num-test (max 9223372036854776/9223372036854775807 9223372036854775/9223372036854774806) 9223372036854775/9223372036854774806)
(num-test (max 9223372036854775/9223372036854774806 9223372036854776/9223372036854775807) 9223372036854775/9223372036854774806)
(num-test (max 9223372036854776/9223372036854775807 9223372036854775/9223372036854775000) 9223372036854776/9223372036854775807)
-;; mpfr says the 1st fraction is 1.000000000000000020925101928970235578612E-3
+;; mpfr says the first fraction is 1.000000000000000020925101928970235578612E-3
(num-test (max 1e18 most-positive-fixnum) most-positive-fixnum) ; in bignum case there's type confusion here I think (hence num-test)
(if with-bignums
@@ -56878,6 +57331,75 @@ hi6: (string-app...
(begin (set! happy #f) (display "(min ") (display val1) (display " ") (display val2) (display ") -> ") (display (min val2 val1)) (display "?") (newline)))
))))
+(let ()
+ (define (tmin . args)
+ (let ((val (apply min args)))
+ (if (number? val)
+ (for-each
+ (lambda (arg)
+ (if (< arg val)
+ (format *stderr* "(min ~{~^~A ~}) -> ~A~%" args val)))
+ args))
+ val))
+
+ (define (tmax . args)
+ (let ((val (apply max args)))
+ (if (number? val)
+ (for-each
+ (lambda (arg)
+ (if (> arg val)
+ (format *stderr* "(max ~{~^~A ~}) -> ~A~%" args val)))
+ args))
+ val))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (tmin (- (random 10) 5) (- (random 99/100) 49/100))
+ (tmax (- (random 10) 5) (- (random 99/100) 49/100))
+ (tmin (- (random 99/100) 49/100) (- (random 10) 5))
+ (tmax (- (random 99/100) 49/100) (- (random 10) 5))
+ (tmin (- (random 10) 5) 0)
+ (tmax (- (random 10) 5) 0)
+ (tmin (- (random 99/100) 49/100) 0)
+ (tmax (- (random 99/100) 49/100) 0)
+ (tmin 0 (- (random 10) 5))
+ (tmax 0 (- (random 10) 5))
+ (tmin 0 (- (random 99/100) 49/100))
+ (tmax 0 (- (random 99/100) 49/100))
+
+ (tmin (- (random 10) 5) 1)
+ (tmax (- (random 10) 5) 1)
+ (tmin (- (random 99/100) 49/100) 1)
+ (tmax (- (random 99/100) 49/100) 1)
+ (tmin 1 (- (random 10) 5))
+ (tmax 1 (- (random 10) 5))
+ (tmin 1 (- (random 99/100) 49/100))
+ (tmax 1 (- (random 99/100) 49/100))
+
+ (tmin (- (random 10) 5) -1/4)
+ (tmax (- (random 10) 5) -1/4)
+ (tmin (- (random 99/100) 49/100) -1/4)
+ (tmax (- (random 99/100) 49/100) -1/4)
+ (tmin -3/4 (- (random 10) 5))
+ (tmax -3/4 (- (random 10) 5))
+ (tmin -3/4 (- (random 99/100) 49/100))
+ (tmax -3/4 (- (random 99/100) 49/100))
+
+ (tmin (- (random 299/100) 149/100) (- (random 199/100) 1))
+ (tmax (- (random 299/100) 149/100) (- (random 199/100) 1))
+ (tmin 0 (- (random 10) 5) (- (random 99/100) 49/100))
+ (tmax 0 (- (random 10) 5) (- (random 99/100) 49/100))
+ (tmin 0 (- (random 99/100) 49/100) (- (random 10) 5))
+ (tmax 0 (- (random 99/100) 49/100) (- (random 10) 5))
+ (tmin (- (random 10) 5) -1/2)
+ (tmax (- (random 10) 5) -1/2)
+ (tmin (- (random 99/100) 49/100) -1/2)
+ (tmax (- (random 99/100) 49/100) -1/2)
+ (tmin -1/2 (- (random 10) 5))
+ (tmax -1/2 (- (random 10) 5))
+ (tmin -1/2 (- (random 99/100) 49/100))
+ (tmax -1/2 (- (random 99/100) 49/100))))
+
;;; --------------------------------------------------------------------------------
@@ -60867,6 +61389,8 @@ hi6: (string-app...
(num-test (tan (/ pi 8)) (- (sqrt 2) 1))
(num-test (* (tan (/ pi 11)) (tan (/ (* 2 pi) 11)) (tan (/ (* 3 pi) 11)) (tan (/ (* 4 pi) 11)) (tan (/ (* 5 pi) 11))) (sqrt 11))
(num-test (* (tan (/ pi 9)) (tan (/ (* 2 pi) 9)) (tan (/ (* 4 pi) 9))) (sqrt 3))
+(num-test (tan 0-1000i) 0-i)
+(num-test (tan 0+1000i) 0+i)
(if with-bignums
(begin
@@ -78547,7 +79071,7 @@ etc....
"#o8" "#o9" "1/#e1" "#o#" "#e#i1" "#d--2" "#b#x1" "#i#x#b1" "#e#e#b1" "#e#b#b1"
"-#b1" "+#b1" "#b1/#b2" "#b1+#b1i" "1+#bi" "1+#b1i" "1#be1" "#b" "#o" "#" "#ea" "#e1a" "1+ie1" "1+i1" "1e+1i"
"#e#b" "#b#b" "#b#b1" "1e3e4" "1.0e-3e+4" "1e3s" "1e3s3" "#o#x1" "#i#i1" "1e-i" "#be1" "1/i" "1/e1" "1+e1"
- "1e+" "1e1+" "1e1e1" "1e-+1" "1e0x1" "1e-" "1/#o2"
+ "1e+" "1e1+" "1e1e1" "1e-+1" "1e0x1" "1e-" "1/#o2" "-#xae" "-#o-7"
"#i#i1" "12 at 12i"))
(for-each
@@ -79337,6 +79861,106 @@ etc
(test (apply union list (power-set list '(1 2 3))) '(3 2 1))
+ ;; this used to be built into s7.c
+ (test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64)) (+ a b)) 96)
+ (test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64) (set! a (+ b 1))) (+ a b)) 129)
+ (test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32 64 12) (+ a b))) 'error) ; was 96)
+ (test (let ((a 1) (b 2)) (multiple-value-set! (a b) (values 32)) (cons a b)) 'error) ; was '(32 . #f))
+
+ (test (multiple-value-set! #() "1234" #(0 1 2 3 4)) 'error)
+ (test (multiple-value-set! "" #(0 1 2 3 4) :readable) 'error)
+ (test (multiple-value-set! () #(0 1 2 3 4) :readable) 'error)
+ (test (multiple-value-set! () ()) ())
+ (test (multiple-value-set! () () 1 2) 2)
+
+ (let ((aaa 1)
+ (bbb 0)
+ (ccc 0))
+ (let-temporarily ((aaa 2))
+ (set! bbb aaa)
+ (set! aaa 32)
+ (set! ccc aaa))
+ (test (list aaa bbb ccc) '(1 2 32)))
+
+ (test (let ((aaa 0)
+ (bbb 0))
+ (let-temporarily ((aaa 32))
+ (set! bbb aaa)
+ (let-temporarily ((bbb 10))
+ (set! aaa bbb)))
+ (list aaa bbb))
+ '(0 32))
+
+ (let ((saved 0)
+ (orig 1)
+ (vars 2)
+ (body 3))
+ (let ((vals (list (let-temporarily ((saved 30)
+ (orig 31)
+ (vars 32)
+ (body 33))
+ (let ((inner (list saved orig vars body)))
+ (set! saved 41)
+ (set! orig 42)
+ (set! vars 43)
+ (set! body 44)
+ inner))
+ (list saved orig vars body))))
+ (test vals '((30 31 32 33) (0 1 2 3)))))
+
+(let ((cons +)
+ (curlet abs)
+ (inlet call/cc)
+ (saved 32)
+ (inner-let -1))
+ (let-temporarily ((saved *))
+ (set! inner-let (cons (saved (abs inner-let) 2) 3)))
+ (test inner-let 5)
+ (test (eq? curlet abs) #t))
+
+(let ((a (vector 1 2 3))
+ (x 1)
+ (y 32))
+ (let-temporarily (((a x) y))
+ (test (a x) y))
+ (test (a x) 2))
+
+(let ((a (inlet 'b (vector 1 2 3)))
+ (x 32)
+ (y 1))
+ (let-temporarily ((((a 'b) 1) 32))
+ (test (a 'b) #(1 32 3)))
+ (test (a 'b) #(1 2 3)))
+
+(let ((x 1)
+ (y 2))
+ (let-temporarily ((x 32) (y x))
+ (test (list x y) '(32 1)))
+ (test (list x y) '(1 2)))
+
+(let ((x 1)
+ (y 2))
+ (let*-temporarily ((x 32) (y x))
+ (test (list x y) '(32 32)))
+ (test (list x y) '(1 2)))
+
+(let ((a (vector 1 2 3))
+ (x 1)
+ (y 32)
+ (z 0))
+ (let-temporarily (((a x) y) (z (a x)))
+ (test (list (a x) y z) '(32 32 2)))
+ (test (list (a x) y z) '(2 32 0)))
+
+(let ((a (vector 1 2 3))
+ (x 1)
+ (y 32)
+ (z 0))
+ (let*-temporarily (((a x) y) (z (a x)))
+ (test (list (a x) y z) '(32 32 32)))
+ (test (list (a x) y z) '(2 32 0)))
+
+
(test (hash-table->alist (hash-table)) ())
(test (hash-table->alist (hash-table '(a . 1))) '((a . 1)))
(test (let ((lst (hash-table->alist (hash-table '(a . 1) '(b . 2)))))
@@ -80184,6 +80808,8 @@ etc
(format *stderr* "pp 4: ~A~%" (pp '(case a ((a b c) 1) ((d) 2) (else 3)))))
(if (not (string=? (pp '(cond ((> a 1) 2) ((< a 3) 3) (#t 4))) "(cond ((> a 1) 2)\n ((< a 3) 3)\n (#t 4))"))
(format *stderr* "pp 5~%"))
+ (if (not (string=? (pp '(catch 'x (lambda () 32) (lambda args 'error))) "(catch 'x\n (lambda ()\n 32)\n (lambda args\n 'error))"))
+ (format *stderr* "pp 6~%"))
(if (not (string=? (pp '(if a '(1 2 3))) "(if a '(1 2 3))"))
(format *stderr* "pp7~%"))
(if (not (= ((funclet pretty-print) '*pretty-print-length*) 100))
@@ -80312,9 +80938,46 @@ etc
(test (mult 1 2 3 4) 24))
(test (let () (define-values (x y) (values 1 2)) (+ x y)) 3)
+ ;; from Guile:
+ (test (let () (define-values () (values)) #f) #f) ; just avoid dumb error
+ (test (let () (define-values (x) 1) x) 1)
+ (test (let () (define-values (x y) (values 2 3)) (+ x y)) 5)
+ (test (let () (define-values (x y z) (values 4 5 6)) (+ x y z)) 15)
+ (test (let () (define-values (x . y) (values 'a 'b 'c 'd)) (list x y)) '(a (b c d)))
+ (test (let () (define-values (x y . z) (values 'x 'y 'z 'w)) (list x y z)) '(x y (z w)))
+ (test (let () (define-values x (values 1 2 3)) x) '(1 2 3))
+
(test (call-with-values (lambda () (exact-integer-sqrt 4)) list) '(2 0))
(test (call-with-values (lambda () (exact-integer-sqrt 5)) list) '(2 1))
+ (test (let-values (((x) (values 1))) x) 1)
+ (test (let-values ((x (values 1))) x) '(1))
+ (test (let-values (((x) (values 1)) ((y) (values 2))) (list x y)) '(1 2))
+ (test (let ((x 32)) (let-values (((x) (values 1)) ((y) (values (+ x 1)))) (list x y))) '(1 33))
+ (test (let-values (((x y) (values 1 2))) (list x y)) '(1 2))
+ (test (let ((d 32)) (let-values (((a) 1) ((c d e) (values 3 4 5)) ((b) d)) (+ a b (* c d e))))
+ (let ((d 32))
+ (with-let (apply sublet (curlet)
+ (list ((lambda (a) (values :a a)) 1)
+ ((lambda (c d e) (values :c c :d d :e e)) (values 3 4 5))
+ ((lambda (b) (values :b b)) d))) (+ a b (* c d e)))))
+ (test (let ((a 32) (b -1)) (let-values (((a b) (values 1 2)) ((x y) (values a b))) (list a b x y)))
+ (let ((a 32) (b -1))
+ (with-let (apply sublet (curlet)
+ (list ((lambda (a b) (values :a a :b b)) (values 1 2))
+ ((lambda (x y) (values :x x :y y)) (values a b))))
+ (list a b x y))))
+
+ (test (let*-values (((x) (values 1))) x) 1)
+ (test (let*-values ((x (values 1))) x) '(1))
+ (test (let*-values (((x) (values 1)) ((y) (values 2))) (list x y)) '(1 2))
+ (test (let*-values (((x) (values 1)) ((y) (values (+ x 1)))) (list x y)) '(1 2))
+ (test (let*-values (((x y) (values 1 2))) (list x y)) '(1 2))
+ (test (let*-values (((a) 1) ((c d e) (values 3 4 5)) ((b) d)) (+ a b (* c d e)))
+ (let ((a 1)) ((lambda (c d e) (let ((b d)) (+ a b (* c d e)))) (values 3 4 5))))
+ (test (let*-values (((a b) (values 1 2)) ((x y) (values a b))) (list a b x y))
+ ((lambda (a b) ((lambda (x y) (list a b x y)) (values a b))) (values 1 2)))
+
(test (vector-copy #()) #())
(test (vector-copy #(a b c)) #(a b c))
(test (vector-copy #(a b c) 1) #(b c))
@@ -80407,6 +81070,240 @@ etc
))
+;;; --------------------------------------------------------------------------------
+(when with-block
+(let ()
+ (define (catch1)
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ 12)))
+
+ (with-output-to-file "tmp343.scm"
+ (lambda ()
+ (display "
+ (catch #t
+ (lambda ()
+ (asdf-tmp343 21))
+ (lambda args
+ 12))
+ ")))
+
+ (let ((val1 (catch1))
+ (val2 (eval-string "(catch1)"))
+ (val3 (eval-string "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ 12))
+ "))
+ (val4 (eval '(catch1)))
+ (val5 (eval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ 12))))
+ (val6 (load "tmp343.scm"))
+ (val7 (sload "tmp343.scm"))
+ (val8 (scall catch1 ()))
+ (val9 (eval (call-with-input-file "tmp343.scm" read)))
+ (val10 (eval (call-with-input-file "tmp343.scm" sread)))
+ (val11 (swind (lambda () #f) catch1 (lambda () #f)))
+ (val12 (seval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ 12))))
+ (val13 (sevalstr "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ 12))
+ ")))
+ (test (list val1 val2 val3 val4 val5 val6 val7 val8 val9 val10 val11 val12 val13) '(12 12 12 12 12 12 12 12 12 12 12 12 12)))
+
+ (delete-file "tmp343.scm")
+
+ (define (catch2)
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32)))))
+
+ (with-output-to-file "tmp343.scm"
+ (lambda ()
+ (display "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32))))
+ ")))
+
+ (let ((val1 (catch2))
+ (val2 (eval-string "(catch2)"))
+ (val3 (eval-string "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32))))
+ "))
+ (val4 (eval '(catch2)))
+ (val5 (eval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32))))))
+ (val6 (load "tmp343.scm"))
+ (val7 (sload "tmp343.scm"))
+ (val8 (scall catch2 ()))
+ (val9 (eval (call-with-input-file "tmp343.scm" read)))
+ (val10 (eval (call-with-input-file "tmp343.scm" sread)))
+ (val11 (swind (lambda () #f) catch2 (lambda () #f)))
+ (val12 (seval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32))))))
+ (val13 (sevalstr "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ 32))))
+ ")))
+
+ (test (list val1 val2 val3 val4 val5 val6 val7 val8 val9 val10 val11 val12 val13) '(32 32 32 32 32 32 32 32 32 32 32 32 32)))
+
+ (delete-file "tmp343.scm")
+
+ (define (catch3)
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64)))))))
+
+ (with-output-to-file "tmp343.scm"
+ (lambda ()
+ (display "(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64))))))
+ ")))
+
+ (let ((val1 (catch3))
+ (val2 (eval-string "(catch3)"))
+ (val3 (eval-string "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64))))))
+ "))
+ (val4 (eval '(catch3)))
+ (val5 (eval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64))))))))
+ (val6 (load "tmp343.scm"))
+ (val7 (sload "tmp343.scm"))
+ (val8 (scall catch3 ()))
+ (val9 (eval (call-with-input-file "tmp343.scm" read)))
+ (val10 (eval (call-with-input-file "tmp343.scm" sread)))
+ (val11 (swind (lambda () #f) catch3 (lambda () #f)))
+ (val12 (seval '(catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64))))))))
+ (val13 (sevalstr "
+ (catch #t
+ (lambda ()
+ (asdf 21))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (fdsa 12))
+ (lambda args
+ (catch #t
+ (lambda ()
+ (sfsa 32))
+ (lambda args
+ 64))))))
+ ")))
+ (test (list val1 val2 val3 val4 val5 val6 val7 val8 val9 val10 val11 val12 val13) '(64 64 64 64 64 64 64 64 64 64 64 64 64)))))
;;; --------------------------------------------------------------------------------
@@ -81055,21 +81952,21 @@ etc
q))))))
-(define-class float ()
+(define-class pfloat () ; don't clobber built-in float?!
'((x 0.0))
(list (list '+ (lambda orig-args
(let add ((x ()) (args orig-args))
(if (null? args)
- (make-float (apply + x))
+ (make-pfloat (apply + x))
(let ((n (car args)))
(cond
- ((float? n) (add (cons (n 'x) x) (cdr args)))
+ ((pfloat? n) (add (cons (n 'x) x) (cdr args)))
((real? n) (add (cons n x) (cdr args)))
((complex? n) (add (cons (real-part n) x) (cdr args)))
((openlet? n)
(if (eq? n (car orig-args))
(error 'missing-method "+ can't handle these arguments: ~A" args)
- (apply (n '+) (make-float (apply + x)) (cdr args))))
+ (apply (n '+) (make-pfloat (apply + x)) (cdr args))))
(else (error 'wrong-type-arg "+ argument ~A is not a number" n))))))))
(list 'number? (lambda (obj) #t))))
@@ -81113,10 +82010,10 @@ etc
(test (- q1 1 0.0+i) (make-quaternion 0.0 0.0 0.0 0.0))
(test (- 1 q1) (make-quaternion 0.0 -1.0 0.0 0.0))
- (test (+ (make-float 1.0) 1.0) (make-float 2.0))
- (test (+ (make-quaternion 1 0 0 0) (make-float 1.0)) 'error)
- (test (+ (make-float 1.0) 2 (make-quaternion 1 1 1 1)) 'error)
- (test (+ 1 (make-float 1.0) 2 (make-quaternion 1 1 1 1)) 'error)
+ (test (+ (make-pfloat 1.0) 1.0) (make-pfloat 2.0))
+ (test (+ (make-quaternion 1 0 0 0) (make-pfloat 1.0)) 'error)
+ (test (+ (make-pfloat 1.0) 2 (make-quaternion 1 1 1 1)) 'error)
+ (test (+ 1 (make-pfloat 1.0) 2 (make-quaternion 1 1 1 1)) 'error)
(test (make-quaternion 1 2+i 0 0) 'error)
(test (make-quaternion 1 2 3 "hi") 'error)
@@ -82639,6 +83536,10 @@ etc
3/4 3.14 1.0+1.0i #\f (lambda (a) (+ a 1)) #<eof> #<undefined>)))
'(undefined-identifier-warnings gc-stats symbol-table-locked?))
+(test (set! #_abs 32) 'error)
+(test (define (#_abs a) (= a 1)) 'error)
+(test #|a|#|b|#|c|# 'error) ; unbound variable |b|#|c|#
+
;; it's documented that this kind of stuff may be optimized out, so these can do anything
;(test (let ((x (abs -1)) (sba abs)) (set! abs odd?) (let ((y (abs 1))) (set! abs sba) (list x y abs))) (list 1 #t abs))
@@ -84175,27 +85076,75 @@ etc
(lint-test "(+ 1 (+ 2 3))" " +: perhaps (+ 1 (+ 2 3)) -> 6")
(lint-test "(+ 1 (+ x 3))" " +: perhaps (+ 1 (+ x 3)) -> (+ 4 x)")
(lint-test "(+ x)" " +: perhaps (+ x) -> x")
- (lint-test "(* 2 (+))" " *: perhaps (* 2 (+)) -> 0")
(lint-test "(+ (+ (+ x 2) 3) 4)" " +: perhaps (+ (+ (+ x 2) 3) 4) -> (+ 9 x)")
(lint-test "(+ 1 2 x -3)" " +: perhaps (+ 1 2 x -3) -> x")
(lint-test "(+ 1/2 -1/2)" " +: perhaps (+ 1/2 -1/2) -> 0")
(lint-test "(+ 1/3 2/3)" " +: perhaps (+ 1/3 2/3) -> 1")
(lint-test "(+ (log x) (log 3))" "") ; oops...
(lint-test "(+ x 0 (+ 0 0))" " +: perhaps (+ x 0 (+ 0 0)) -> x")
- (lint-test "(+ x #(0))" " +: +'s argument 2 should be a number?: #(0): (+ x #(0))")
+ (lint-test "(+ x #(0))" " +: in (+ x #(0)), +'s argument 2 should be a number, but #(0) is a vector?")
(lint-test "(+ x 2.0 -2)" "")
-
+ (lint-test "(+ x (+ y z) (+ a b))" " +: perhaps (+ x (+ y z) (+ a b)) -> (+ x y z a b)")
+ (lint-test "(+ (- x) y)" " +: perhaps (+ (- x) y) -> (- y x)")
+ (lint-test "(+ x (- y))" " +: perhaps (+ x (- y)) -> (- x y)")
+ (lint-test "(+ x (+ y 2) (+ z 3))" " +: perhaps (+ x (+ y 2) (+ z 3)) -> (+ 5 x y z)")
+ (lint-test "(+ 1 (* 2 (+ x)) (+ y z))" " +: perhaps (+ 1 (* 2 (+ x)) (+ y z)) -> (+ 1 (* 2 x) y z)")
+ (lint-test "(+ x (- y) (- a b) w)" " +: perhaps (+ x (- y) (- a b) w) -> (- (+ x a w) y b)")
+ (lint-test "(+ x (- 1))" " +: perhaps (+ x (- 1)) -> (- x 1)")
+ (lint-test "(+ -1 x)" " +: perhaps (+ -1 x) -> (- x 1)")
+ (lint-test "(+ x -1)" " +: perhaps (+ x -1) -> (- x 1)")
+ (lint-test "(+ (/ a b) (/ c b))" " +: perhaps (+ (/ a b) (/ c b)) -> (/ (+ a c) b)")
+ (lint-test "(+ (/ a b d) (/ c b d))" " +: perhaps (+ (/ a b d) (/ c b d)) -> (/ (+ a c) b d)")
+ (lint-test "(+ (* a b) (* c a))" " +: perhaps (+ (* a b) (* c a)) -> (* a (+ b c))")
+ (lint-test "(+ x (- (+ y z) w))" " +: perhaps (+ x (- (+ y z) w)) -> (- (+ x y z) w)")
+ (lint-test "(+ (- (+ y z) w v) x)" " +: perhaps (+ (- (+ y z) w v) x) -> (- (+ y z x) w v)")
+ (lint-test "(+ (- (+ a b) c d e) (- (+ y z) w v))" " +: perhaps (+ (- (+ a b) c d e) (- (+ y z) w v)) -> (- (+ a b y z) c d e w v)")
+ (lint-test "(+ x (- (+ y z) w) v)" " +: perhaps (+ x (- (+ y z) w) v) -> (- (+ x y z v) w)")
+ (lint-test "(+ (- x) (- y))" " +: perhaps (+ (- x) (- y)) -> (- (+ x y))")
+ (lint-test "(+ (- x) (- y) (- z))" " +: perhaps (+ (- x) (- y) (- z)) -> (- (+ x y z))")
+ (lint-test "(+ (- x) (- y z))" " +: perhaps (+ (- x) (- y z)) -> (- y x z)")
+ (lint-test "(+ (- x) (- x z))" " +: perhaps (+ (- x) (- x z)) -> (- z)")
+ (lint-test "(+ (- x z) (- y))" " +: perhaps (+ (- x z) (- y)) -> (- x z y)")
+ (lint-test "(+ (- y z) (- y))" " +: perhaps (+ (- y z) (- y)) -> (- z)")
+ (lint-test "(+ -1 (- x y))" " +: perhaps (+ -1 (- x y)) -> (- x y 1)")
+ (lint-test "(+ (- x) -1)" " +: perhaps (+ (- x) -1) -> (- (+ x 1))")
+ (lint-test "(+ (- -1 x) (- y -1))" " +: perhaps (+ (- -1 x) (- y -1)) -> (- y x)")
+ (lint-test "(+ (- -1 x) (- -1 y))" " +: perhaps (+ (- -1 x) (- -1 y)) -> (- (+ x y 2))")
+ (lint-test "(+ (- x 2) (- 1 y 3 4))" " +: perhaps (+ (- x 2) (- 1 y 3 4)) -> (- x y 8)")
+ (lint-test "(+ (* a b) (* b c))" " +: perhaps (+ (* a b) (* b c)) -> (* b (+ a c))")
+ (lint-test "(+ (* a b b) (* b c))" " +: perhaps (+ (* a b b) (* b c)) -> (* b (+ (* a b) c))")
+ (lint-test "(+ (* a b c) (* b c))" " +: perhaps (+ (* a b c) (* b c)) -> (* b c (+ a 1))")
+ (lint-test "(+ (* a b) (* a b c d))" " +: perhaps (+ (* a b) (* a b c d)) -> (* a b (+ 1 (* c d)))")
+ (lint-test "(+ (* a b) (* c d))" "")
+ (lint-test "(+ (* a b) (* a b))" " +: perhaps (+ (* a b) (* a b)) -> (* a b 2)")
+ (lint-test "(exp (+ (* 0.5 (log hi)) (* 0.5 (log lo))))" " exp: perhaps (exp (+ (* 0.5 (log hi)) (* 0.5 (log lo)))) -> (exp (* 0.5 (+ (log hi) (log lo))))")
+
(lint-test "(* 2 3)" " *: perhaps (* 2 3) -> 6")
+ (lint-test "(* 2 (+))" " *: perhaps (* 2 (+)) -> 0")
(lint-test "(* (* 2 3) 4)" " *: perhaps (* (* 2 3) 4) -> 24")
(lint-test "(* (* x 3) 4)" " *: perhaps (* (* x 3) 4) -> (* 12 x)")
(lint-test "(* x)" " *: perhaps (* x) -> x")
(lint-test "(* x (*))" " *: perhaps (* x (*)) -> x")
(lint-test "(* 2 x 3 y 1/6)" " *: perhaps (* 2 x 3 y 1/6) -> (* x y)")
(lint-test "(* x -1)" " *: perhaps (* x -1) -> (- x)")
+ (lint-test "(* -1 x y)" " *: perhaps (* -1 x y) -> (- (* x y))")
(lint-test "(* x 1 1 1)" " *: perhaps (* x 1 1 1) -> x")
(lint-test "(* x 1 1.0 1)" " *: perhaps (* x 1 1.0 1) -> (* x 1.0)")
(lint-test "(* x y 2 0)" " *: perhaps (* x y 2 0) -> 0")
(lint-test "(* -1 x -1 -1)" " *: perhaps (* -1 x -1 -1) -> (- x)")
+ (lint-test "(* x (* y z) a)" " *: perhaps (* x (* y z) a) -> (* x y z a)")
+ (lint-test "(* (- x) (- y))" " *: perhaps (* (- x) (- y)) -> (* x y)")
+ (lint-test "(* 2.0 (inexact x))" " *: perhaps (* 2.0 (inexact x)) -> (* 2.0 x)")
+ (lint-test "(* (inexact x) 2.0)" " *: perhaps (* (inexact x) 2.0) -> (* x 2.0)")
+ (lint-test "(* (exp a) (exp b))" " *: perhaps (* (exp a) (exp b)) -> (exp (+ a b))")
+ (lint-test "(* 2.0 (random 1.0))" " *: perhaps (* 2.0 (random 1.0)) -> (random 2.0)")
+ (lint-test "(* (gcd a b) (lcm a b))" " *: perhaps (* (gcd a b) (lcm a b)) -> (abs (* a b))")
+ (lint-test "(* (/ x) (/ y z))" " *: perhaps (* (/ x) (/ y z)) -> (/ y (* x z))")
+ (lint-test "(* (/ x) (/ x z))" " *: perhaps (* (/ x) (/ x z)) -> (/ z)")
+ (lint-test "(* (/ x z) (/ y))" " *: perhaps (* (/ x z) (/ y)) -> (/ x (* z y))")
+ (lint-test "(* (/ y z) (/ y))" " *: perhaps (* (/ y z) (/ y)) -> (/ z)")
+ (lint-test "(* (/ x z) (/ y w v))" " *: perhaps (* (/ x z) (/ y w v)) -> (/ (* x y) (* z w v))")
+ (lint-test "(* (/ x) (/ y))" " *: perhaps (* (/ x) (/ y)) -> (/ (* x y))")
(lint-test "(- 1 2)" " -: perhaps (- 1 2) -> -1")
(lint-test "(- 1 (- 1 2))" " -: perhaps (- 1 (- 1 2)) -> 2")
@@ -84203,7 +85152,6 @@ etc
(lint-test "(- (- x))" " -: perhaps (- (- x)) -> x")
(lint-test "(- 0 x)" " -: perhaps (- 0 x) -> (- x)")
(lint-test "(- x 0)" " -: perhaps (- x 0) -> x")
- (lint-test "(+ x (- 1))" " +: perhaps (+ x (- 1)) -> (+ x -1)")
(lint-test "(- (- y x))" " -: perhaps (- (- y x)) -> (- x y)")
(lint-test "(- 3/2 1/2)" " -: perhaps (- 3/2 1/2) -> 1")
(lint-test "(- (- x y) z)" " -: perhaps (- (- x y) z) -> (- x y z)")
@@ -84214,8 +85162,14 @@ etc
(lint-test "(- 0.0 x)" "")
(lint-test "(- x (+ 0 x))" " -: perhaps (- x (+ 0 x)) -> 0")
(lint-test "(- (abs x) (abs x) y)" " -: perhaps (- (abs x) (abs x) y) -> (- y)")
- (lint-test "(- (abs x) (abs x) (abs x) y)" " -: perhaps (- (abs x) (abs x) (abs x) y) -> (- 0 (abs x) y)")
- (lint-test "(+ x (+ y 2) (+ z 3))" " +: perhaps (+ x (+ y 2) (+ z 3)) -> (+ 5 x y z)")
+ (lint-test "(- (abs x) (abs x) (abs x) y)" " -: perhaps (- (abs x) (abs x) (abs x) y) -> (- (+ (abs x) y))")
+ (lint-test "(- (- x) y)" " -: perhaps (- (- x) y) -> (- (+ x y))")
+ (lint-test "(- x (truncate x))" " -: perhaps (- x (truncate x)) -> (remainder x 1)")
+ (lint-test "(- x (+ y z))" " -: perhaps (- x (+ y z)) -> (- x y z)")
+ (lint-test "(- x (- y))" " -: perhaps (- x (- y)) -> (+ x y)")
+ (lint-test "(- (- x y) z w)" " -: perhaps (- (- x y) z w) -> (- x y z w)")
+ (lint-test "(- (- x y) (+ z w))" " -: perhaps (- (- x y) (+ z w)) -> (- x y z w)")
+ (lint-test "(- x -1)" " -: perhaps (- x -1) -> (+ x 1)")
(lint-test "(/ 2 3)" " /: perhaps (/ 2 3) -> 2/3")
(lint-test "(/ 1 x)" " /: perhaps (/ 1 x) -> (/ x)")
@@ -84225,7 +85179,8 @@ etc
(lint-test "(/ (/ x))" " /: perhaps (/ (/ x)) -> x")
(lint-test "(/ (log x) (log 2))" " /: perhaps (/ (log x) (log 2)) -> (log x 2)")
(lint-test "(/ (log x) (log y))" " /: perhaps (/ (log x) (log y)) -> (log x y)")
- (lint-test "(/ x (/ y))" "") ; ideally (* x y)
+ (lint-test "(/ x (/ y))" " /: perhaps (/ x (/ y)) -> (* x y)")
+ (lint-test "(/ x (/ 1 y z))" " /: perhaps (/ x (/ 1 y z)) -> (* x y z)")
(lint-test "(/ x 1 1 1)" " /: perhaps (/ x 1 1 1) -> x")
(lint-test "(/ x a (* b 1 c) d)" " /: perhaps (/ x a (* b 1 c) d) -> (/ x a b c d)")
(lint-test "(/ 0 a (* b 1 c) d)" " /: perhaps (/ 0 a (* b 1 c) d) -> (/ 0 a b c d)")
@@ -84235,6 +85190,19 @@ etc
(lint-test "(/ (/ 1 a) (/ b c d))" " /: perhaps (/ (/ 1 a) (/ b c d)) -> (/ (* c d) (* a b))")
(lint-test "(/ (/ a) (/ b))" " /: perhaps (/ (/ a) (/ b)) -> (/ b a)")
(lint-test "(/ (/ a b c) (/ d e f))" " /: perhaps (/ (/ a b c) (/ d e f)) -> (/ (* a e f) (* b c d))")
+ (lint-test "(/ (/ a b) c)" " /: perhaps (/ (/ a b) c) -> (/ a b c)")
+ (lint-test "(/ a b a)" " /: perhaps (/ a b a) -> (/ b)")
+ (lint-test "(/ a b a c)" " /: perhaps (/ a b a c) -> (/ 1 b c)")
+ (lint-test "(/ a (* b a))" " /: perhaps (/ a (* b a)) -> (/ b)")
+ (lint-test "(/ a (* b a c))" " /: perhaps (/ a (* b a c)) -> (/ 1 b c)")
+ (lint-test "(/ 2.0 (inexact x))" " /: perhaps (/ 2.0 (inexact x)) -> (/ 2.0 x)")
+ (lint-test "(/ (inexact x) 2.0)" " /: perhaps (/ (inexact x) 2.0) -> (/ x 2.0)")
+ (lint-test "(/ (- x) (- y))" " /: perhaps (/ (- x) (- y)) -> (/ x y)")
+ (lint-test "(/ x (/ y z))" " /: perhaps (/ x (/ y z)) -> (/ (* x z) y)")
+ (lint-test "(/ 3 (/ -3 x))" " /: perhaps (/ 3 (/ -3 x)) -> (- x)")
+ (lint-test "(/ 2/3 (/ 3/2 x))" " /: perhaps (/ 2/3 (/ 3/2 x)) -> (* 4/9 x)")
+; (lint-test "(/ x (* y z))" " /: perhaps (/ x (* y z)) -> (/ x y z)")
+ (lint-test "(/ x (/ y))" " /: perhaps (/ x (/ y)) -> (* x y)")
(lint-test "(sin (asin x))" " sin: perhaps (sin (asin x)) -> x")
(lint-test "(sin 0)" " sin: perhaps (sin 0) -> 0")
@@ -84246,6 +85214,7 @@ etc
(lint-test "(cos 0)" " cos: perhaps (cos 0) -> 1")
(lint-test "(exp (* (+ x y) (log (+ y 1))))" " exp: perhaps (exp (* (+ x y) (log (+ y 1)))) -> (expt (+ y 1) (+ x y))")
(lint-test "(exp (* (log x) a))" " exp: perhaps (exp (* (log x) a)) -> (expt x a)")
+ (lint-test "(exp (log (* x y)))" " exp: perhaps (exp (log (* x y))) -> (* x y)")
(lint-test "(acosh (cosh 0))" " acosh: perhaps (acosh (cosh 0)) -> (acosh 1)")
(lint-test "(exp (log 1))" " exp: perhaps (exp (log 1)) -> 1")
(if with-bignums
@@ -84272,16 +85241,22 @@ etc
(lint-test "(complex (- x 0) 2)" " complex: perhaps (complex (- x 0) 2) -> (complex x 2)")
(lint-test "(floor 3.4)" " floor: perhaps (floor 3.4) -> 3")
- (lint-test "(round 3.4+i)" " round: round's argument should be a real?: 3.4+1i: (round 3.4+1i)")
- (lint-test "(string-ref (round x) str)"
- " string-ref: string-ref's argument 1 should be a string?: (round x): (string-ref (round x) str)")
- (lint-test "(string-ref x (cons 1 2))"
- " string-ref: string-ref's argument 2 should be an integer?: (cons 1 2): (string-ref x (cons 1 2))")
+ (lint-test "(round 3.4+i)" " round: in (round 3.4+1i), round's argument should be real, but 3.4+1i is complex?")
(lint-test "(ceiling (floor 2.1))" " ceiling: perhaps (ceiling (floor 2.1)) -> 2")
(lint-test "(ceiling (floor x))" " ceiling: perhaps (ceiling (floor x)) -> (floor x)")
(lint-test "(truncate 2/3)" " truncate: perhaps (truncate 2/3) -> 0")
(lint-test "(truncate (/ 2 3))" " truncate: perhaps (truncate (/ 2 3)) -> 0")
(lint-test "(truncate (/ 12 (* 2 3)))" " truncate: perhaps (truncate (/ 12 (* 2 3))) -> 2")
+ (lint-test "(truncate (* 2.0 (inexact->exact (log 3))))" " truncate: perhaps (truncate (* 2.0 (inexact->exact (log 3)))) -> (truncate (* 2.0 (log 3)))")
+ (lint-test "(truncate (inexact->exact (log 3)))" " truncate: perhaps (truncate (inexact->exact (log 3))) -> (truncate (log 3))")
+ (lint-test "(round (random 10))" " round: perhaps (round (random 10)) -> (random 10)")
+ (lint-test "(floor (random 10.0))" " floor: perhaps (floor (random 10.0)) -> (random 10)")
+
+ (lint-test "(inexact->exact (numerator x))" "inexact->exact: perhaps (inexact->exact (numerator x)) -> (numerator x)")
+ (lint-test "(exact->inexact (real-part x))" "") ; if complex?
+ (lint-test "(inexact->exact (random 10))" " inexact->exact: perhaps (inexact->exact (random 10)) -> (random 10)")
+ (lint-test "(exact->inexact (random 10))" "") ; this can't be changed to (random 10.0)
+ (lint-test "(inexact->exact (floor x))" " inexact->exact: perhaps (inexact->exact (floor x)) -> (floor x)")
(lint-test "(abs (magnitude 1+i))" " abs: perhaps (abs (magnitude 1+1i)) -> (magnitude 1+1i)")
(lint-test "(magnitude 2/3)" " magnitude: perhaps use abs here: (magnitude 2/3) magnitude: perhaps (magnitude 2/3) -> 2/3")
@@ -84290,6 +85265,8 @@ etc
(lint-test "(magnitude (real-part z))" " magnitude: perhaps use abs here: (magnitude (real-part z))")
(lint-test "(abs (denominator x))" " abs: perhaps (abs (denominator x)) -> (denominator x)")
(lint-test "(abs (modulo x 2))" " abs: perhaps (abs (modulo x 2)) -> (modulo x 2)")
+ (lint-test "(abs () ())" " abs: abs has too many arguments: (abs () ())
+ abs: in (abs () ()), abs's argument 1 should be real, but () is null?")
(lint-test "(real-part 3.0)" " real-part: perhaps (real-part 3.0) -> 3.0")
(lint-test "(imag-part 3.0)" " imag-part: perhaps (imag-part 3.0) -> 0.0")
@@ -84302,8 +85279,8 @@ etc
(lint-test "(imag-part (vector-ref x i))" "")
(lint-test "(imag-part (x i))" "")
- (lint-test "(string? (number->string x))" " string?: perhaps (string? (number->string x)) -> (number->string x)")
- (lint-test "(number? (string->number x))" " number?: perhaps (number? (string->number x)) -> (string->number x)")
+ (lint-test "(string? (number->string x))" " string?: number->string always returns a string, so (string? (number->string x)) -> #t")
+ (lint-test "(number? (string->number x))" " number?: string->number returns either #f or a number, so (number? (string->number x)) -> (string->number x)")
(lint-test "(numerator 1/3)" " numerator: perhaps (numerator 1/3) -> 1")
(lint-test "(numerator 3)" " numerator: perhaps (numerator 3) -> 3")
@@ -84319,13 +85296,17 @@ etc
(lint-test "(random 0 y)" "")
(lint-test "(lognot 1)" " lognot: perhaps (lognot 1) -> -2")
- (lint-test "(lognot 1/2)" " lognot: lognot's argument should be an integer?: 1/2: (lognot 1/2)")
+ (lint-test "(lognot 1/2)" " lognot: in (lognot 1/2), lognot's argument should be an integer, but 1/2 is rational?")
(if with-bignums
(lint-test "(ash 2 64)" " ash: perhaps (ash 2 64) -> 36893488147419103232")
(lint-test "(ash 2 64)" ""))
(lint-test "(ash 1 7)" " ash: perhaps (ash 1 7) -> 128")
- (lint-test "(complex 1.0 0)" " complex: perhaps (complex 1.0 0) -> 1.0")
+ (lint-test "(ash x 0)" " ash: perhaps (ash x 0) -> x")
+ (lint-test "(quotient (remainder x y) y)" " quotient: perhaps (quotient (remainder x y) y) -> 0")
+ (lint-test "(ash 0 x)" " ash: perhaps (ash 0 x) -> 0")
+ (lint-test "(modulo (abs x) y)" " modulo: perhaps (modulo (abs x) y) -> (modulo x y)")
+ (lint-test "(complex 1.0 0)" " complex: perhaps (complex 1.0 0) -> 1.0")
(lint-test "(expt 0 x)" " expt: perhaps (expt 0 x) -> 0")
(lint-test "(expt x 0)" " expt: perhaps (expt x 0) -> 1")
(lint-test "(expt (* 2 x) 1)" " expt: perhaps (expt (* 2 x) 1) -> (* 2 x)")
@@ -84378,10 +85359,11 @@ etc
(lint-test "(lcm x y 0 3)" " lcm: perhaps (lcm x y 0 3) -> 0")
(lint-test "(gcd 12 18)" " gcd: perhaps (gcd 12 18) -> 6")
(lint-test "(gcd x 0)" " gcd: perhaps (gcd x 0) -> (abs x)")
- (lint-test "(* (gcd a b) (lcm a b))" " *: perhaps (* (gcd a b) (lcm a b)) -> (abs (* a b))")
(lint-test "(lcm 12 18)" " lcm: perhaps (lcm 12 18) -> 36")
(lint-test "(lcm x)" " lcm: perhaps (lcm x) -> (abs x)")
(lint-test "(lcm x x x)" " lcm: perhaps (lcm x x x) -> (abs x)")
+ (lint-test "(if (negative? (gcd x y)) a b)" " if: perhaps (if (negative? (gcd x y)) a b) -> b")
+ (lint-test "(gcd (random x) (random x))" "")
(lint-test "(max x)" " max: perhaps (max x) -> x")
(lint-test "(max 3 4 5)" " max: perhaps (max 3 4 5) -> 5")
@@ -84397,6 +85379,7 @@ etc
(lint-test "(max (min x 3) (min x 3))" " max: this looks odd: (max (min x 3) (min x 3)) max: perhaps (max (min x 3) (min x 3)) -> (min x 3)")
(lint-test "(min x (max y x))" " min: perhaps (min x (max y x)) -> x")
(lint-test "(max (min y x) x)" " max: perhaps (max (min y x) x) -> x")
+ (lint-test "(max 3 (min x 3))" " max: perhaps (max 3 (min x 3)) -> 3")
(lint-test "(min x (max y z (+ 21 x) x (* y z)))" " min: perhaps (min x (max y z (+ 21 x) x (* y z))) -> x")
(lint-test "(equal? x y z)" " equal?: equal? has too many arguments: (equal? x y z)")
@@ -84405,20 +85388,52 @@ etc
(lint-test "(= x 0.0)" "")
(lint-test "(= x 1.0 x)" " =: it looks odd to have repeated arguments in (= x 1.0 x)")
(lint-test "(= (- x y) 0)" " =: perhaps (= (- x y) 0) -> (= x y)")
+ (lint-test "(= 0.0 (- x y))" " =: perhaps (= 0.0 (- x y)) -> (= x y)")
(lint-test "(= (- (abs x) 2) 0)" " =: perhaps (= (- (abs x) 2) 0) -> (= (abs x) 2)")
+ (lint-test "(= (length x) 0)" " =: perhaps (assuming x is a list), (= (length x) 0) -> (null? x)")
+ (lint-test "(= (length x) 1)" " =: perhaps (assuming x is a list), (= (length x) 1) -> (and (pair? x) (null? (cdr x)))")
+
+ (lint-test "(zero? (- x))" " zero?: perhaps (zero? (- x)) -> (zero? x)")
+ (lint-test "(zero? (- x y))" " zero?: perhaps (zero? (- x y)) -> (= x y)")
+ (lint-test "(zero? (- x y z))" " zero?: perhaps (zero? (- x y z)) -> (= x (+ y z))")
+ (lint-test "(positive? (- x))" " positive?: perhaps (positive? (- x)) -> (negative? x)")
+ (lint-test "(positive? (- x y))" " positive?: perhaps (positive? (- x y)) -> (> x y)")
+ (lint-test "(positive? (- x y z))" " positive?: perhaps (positive? (- x y z)) -> (> x (+ y z))")
+ (lint-test "(negative? (- x))" " negative?: perhaps (negative? (- x)) -> (positive? x)")
+ (lint-test "(negative? (- x y))" " negative?: perhaps (negative? (- x y)) -> (< x y)")
+ (lint-test "(negative? (- x y z))" " negative?: perhaps (negative? (- x y z)) -> (< x (+ y z))")
+
+ (lint-test "(+ #e21 x)" " this #e is dumb, #e21 -> 21")
+ (lint-test "(+ #i1.0 x)" " this #i is dumb, #i1.0 -> 1.0")
+ (lint-test "(+ #e1+i x)" " #e can't handle complex numbers, #e1+i -> 1+1i reader[0]: unknown # object: #e1+i")
+ (lint-test "(+ #e1.0 x)" " perhaps #e1.0 -> 1")
+ (lint-test "(+ #d1 x)" " #d is pointless, #d1 -> 1")
+ (lint-test "(+ #i1 x)" " perhaps #i1 -> 1.0")
+ (lint-test "(+ 1 +i)" "+i is not a number in s7")
+
+ (lint-test "(char? '#\\a)"
+ " char?: perhaps (char? '#\\a) -> #t
+ char?: (char? '#\\a) is always #t
+ char?: quote is not needed here: '#\\a")
+ (lint-test "(string? '\"a\")"
+ " string?: perhaps (string? '\"a\") -> #t
+ string?: (string? '\"a\") is always #t
+ string?: quote is not needed here: '\"a\"")
(lint-test "(memq 1.0 x)" " memq: (memq 1.0 x): perhaps memq -> memv")
(lint-test "(assq \"test\" x)" " assq: (assq \"test\" x): perhaps assq -> assoc")
- (lint-test "(assq (list 1 2) x)" " assq: (assq (list 1 2) x): perhaps assq -> assoc")
+ (lint-test "(assq (cons 1 2) x)" " assq: (assq (cons 1 2) x): perhaps assq -> assoc")
(lint-test "(assv #(0) x)" " assv: (assv #(0) x): perhaps assv -> assoc")
- (lint-test "(member 'a x (lambda (a b c) (eq? a b)))" " member: member equality function (optional 3rd arg) should take two arguments")
+ (lint-test "(member 'a x (lambda (a b c) (eq? a b)))" " member: member equality function (optional third arg) should take two arguments")
(lint-test "(member 'a x (lambda (a b) (eq? a (car b))))" " member: member might perhaps be assq")
(lint-test "(member y x (lambda (a b) (equal? a (car b))))" " member: member might perhaps be assoc")
(lint-test "(member 1 x (lambda (a b) (> a b)))" " member: perhaps (lambda (a b) (> a b)) -> >")
(lint-test "(member 1 x (lambda (a b) (> b a)))" " member: perhaps (lambda (a b) (> b a)) -> <")
(lint-test "(member 1 x abs)" " member: abs is a questionable member function")
- (lint-test "(member x (list \"asdf\"))" " member: perhaps (member x (list \"asdf\")) -> (string=? x \"asdf\")")
- (lint-test "(member x (list \"asd\" \"abc\" \"asd\"))" " member: duplicated entry \"asd\" in (list \"asd\" \"abc\" \"asd\")")
+ (lint-test "(member x (list \"asdf\"))" " member: perhaps (member x (list \"asdf\")) -> (string=? x \"asdf\")")
+ (lint-test "(member x (list \"asd\" \"abc\" \"asd\"))"
+ " member: duplicated entry \"asd\" in (list \"asd\" \"abc\" \"asd\")
+ member: perhaps (list \"asd\" \"abc\" \"asd\") -> '(\"asd\" \"abc\" \"asd\")")
(lint-test "(memq x '(1))" " memq: perhaps (memq x '(1)) -> (= x 1)")
(lint-test "(memq x '(begin))" " memq: perhaps (memq x '(begin)) -> (eq? x 'begin)")
(lint-test "(memq x (list 'car))" " memq: perhaps (memq x (list 'car)) -> (eq? x 'car)")
@@ -84429,6 +85444,22 @@ etc
(lint-test "(memv x '(#f #\\c a 1 () :a))" "")
(lint-test "(memq x '(a b a c))" " memq: duplicated entry a in '(a b a c)")
(lint-test "(assq x '((a . 1)))" "")
+ (lint-test "(member x (list \"a\" \"b\"))" " member: perhaps (list \"a\" \"b\") -> '(\"a\" \"b\")")
+ (lint-test "(memq x (list 'a 'b 'x))" " memq: perhaps (list 'a 'b 'x) -> '(a b x)")
+ (lint-test "(memq x (map car y))" " memq: perhaps use assoc: (memq x (map car y)) -> (assq x y)")
+ (lint-test "(memq #t (map null? items))" " memq: perhaps (memq #t (map null? items)) -> (memq () items)")
+ (lint-test "(memq #t (map cadr items))" " memq: perhaps avoid 'map: (memq #t (map cadr items)) -> (member #t items (lambda (a b) (cadr b)))")
+ (lint-test "(memq #t (map b items))" " memq: perhaps avoid 'map: (memq #t (map b items)) -> (member #t items (lambda (a c) (b c)))")
+ (lint-test "(member x (map floor items))" " member: perhaps avoid 'map: (member x (map floor items)) -> (member x items (lambda (a b) (equal? a (floor b))))")
+ (lint-test "(member x (map b items))" " member: perhaps avoid 'map: (member x (map b items)) -> (member x items (lambda (a c) (equal? a (b c))))")
+ (lint-test "(member x (cons y z))" " member: perhaps avoid 'cons: (member x (cons y z)) -> (or (equal? x y) (member x z))")
+ (lint-test "(member x (append (list x) y))"
+ " member: perhaps (member x (append (list x) y)) -> (or (equal? x x) (member x y))
+ member: perhaps (append (list x) y) -> (cons x y)")
+ (lint-test "(memq (string->symbol x) (map string->symbol y))" " memq: perhaps (memq (string->symbol x) (map string->symbol y)) -> (member x y string=?)")
+ (lint-test "(memv #\\= (string->list x))" " memv: perhaps (memv #\\= (string->list x)) -> (char-position #\\= x)")
+ (lint-test "(memv #\\= (string->list x start end))" " memv: perhaps (memv #\\= (string->list x start end)) -> (char-position #\\= x start end)")
+ (lint-test "(memv (string-ref s 0) (string->list x))" " memv: perhaps (memv (string-ref s 0) (string->list x)) -> (char-position (string-ref s 0) x)")
(lint-test "(if #f x y)" " if: if test is never true: (if #f x y) if: perhaps (if #f x y) -> y")
(lint-test "(if #t #f)" " if: if test is never false: (if #t #f) if: perhaps (if #t #f) -> #f")
@@ -84446,6 +85477,8 @@ etc
(lint-test "(if x #t y)" " if: perhaps (if x #t y) -> (or x y)")
(lint-test "(if (not x) y #t)" " if: perhaps (if (not x) y #t) -> (or x y)")
(lint-test "(if (not x) #f y)" " if: perhaps (if (not x) #f y) -> (and x y)")
+ (lint-test "(if x x y)" " if: perhaps (if x x y) -> (or x y)")
+ (lint-test "(if (not x) y x)" " if: perhaps (if (not x) y x) -> (or x y)")
(lint-test "(if (< 1 2) x y)" " if: perhaps (if (< 1 2) x y) -> x")
(lint-test "(if (and x z) y #f)" " if: perhaps (if (and x z) y #f) -> (and x z y)")
(lint-test "(if (and x z) (and y w) #f)" " if: perhaps (if (and x z) (and y w) #f) -> (and x z y w)")
@@ -84457,40 +85490,559 @@ etc
(lint-test "(if y)" " if: if has too few clauses: (if y)")
(lint-test "(if y z a b)" " if: if has too many clauses: (if y z a b)")
(lint-test "(if x y (if z y))" " if: perhaps (if x y (if z y)) -> (if (or x z) y)")
- (lint-test "(if x y (if x y))" " if: perhaps (if x y (if x y)) -> (if x y)")
+ (lint-test "(if x y (if x y))" " if: perhaps (if x y (if x y)) -> (if x y) if: perhaps (if x y (if x y)) -> (if x y)")
(lint-test "(if x (if x y))" " if: perhaps (if x (if x y)) -> (if x y)")
(lint-test "(if x (set! y #t) (set! y #f))" " if: perhaps (if x (set! y #t) (set! y #f)) -> (set! y x)")
+ (lint-test "(if x (f 1 2 1) (f 1 2 2))" " if: perhaps (if x (f 1 2 1) (f 1 2 2)) -> (f 1 2 (if x 1 2))")
+ (lint-test "(if x (f 1 1 1) (f 1 2 1))" " if: perhaps (if x (f 1 1 1) (f 1 2 1)) -> (f 1 (if x 1 2) 1)")
+ (lint-test "(if x (f (+ x 1) (* y 2) (+ x 1)) (f (+ x 1) (+ x 1) (+ x 1)))"
+ " if: perhaps (if x (f (+ x 1) (* y 2) (+ x 1)) (f (+ x 1) (+ x 1) (+ x 1))) -> (f (+ x 1) (if x (* y 2) (+ x 1)) (+ x 1))")
+ (lint-test "(if (and (= x y) z) (+ x 1) #f)" " if: perhaps (if (and (= x y) z) (+ x 1) #f) -> (and (= x y) z (+ x 1))")
+
+ (lint-test "(if x (set! y #f) (set! y #t))" " if: perhaps (if x (set! y #f) (set! y #t)) -> (set! y (not x))")
+ (lint-test "(if x (set! y x) (set! y 21))" " if: perhaps (if x (set! y x) (set! y 21)) -> (set! y (or x 21))")
+ (lint-test "(if x (set! y z) (set! y w))" " if: perhaps (if x (set! y z) (set! y w)) -> (set! y (if x z w))")
+ (lint-test "(if x (+ y 1) (- y 1))" "") ; here we deliberately leave the function alone
+ (lint-test "(if x (set! y 1) (set! y (+ x 1)))" " if: perhaps (if x (set! y 1) (set! y (+ x 1))) -> (set! y (if x 1 (+ x 1)))")
+ (lint-test "(if x (set! y (+ x 1)) (set! y 1))" " if: perhaps (if x (set! y (+ x 1)) (set! y 1)) -> (set! y (if x (+ x 1) 1))")
+
(lint-test "(if x (if y z))" " if: perhaps (if x (if y z)) -> (if (and x y) z)")
(lint-test "(if (cadr x) (if (cadr x) 0))" " if: perhaps (if (cadr x) (if (cadr x) 0)) -> (if (cadr x) 0)")
- (lint-test "(if (cadr x) 3 (if (not (cadr x)) 4))" " if: pointless repetition of if test: (if (cadr x) 3 (if (not (cadr x)) 4)) -> (if (cadr x) 3 4)")
- (lint-test "(if (cadr x) 3 (if (not (cadr x)) 4 5))" " if: pointless repetition of if test: (if (cadr x) 3 (if (not (cadr x)) 4 5)) -> (if (cadr x) 3 4)")
+ (lint-test "(if (cadr x) 3 (if (not (cadr x)) 4))" " if: perhaps (if (cadr x) 3 (if (not (cadr x)) 4)) -> (if (cadr x) 3 4)")
+ (lint-test "(if (cadr x) 3 (if (not (cadr x)) 4 5))" " if: perhaps (if (cadr x) 3 (if (not (cadr x)) 4 5)) -> (if (cadr x) 3 4)")
(lint-test "(if x x y)" " if: perhaps (if x x y) -> (or x y)")
+ (lint-test "(if (not x) x y)" " if: perhaps (if (not x) x y) -> (and x y)")
+ (lint-test "(if x (not x) y)" " if: perhaps (if x (not x) y) -> (and (not x) y)")
+ (lint-test "(if (not x) y x)" " if: perhaps (if (not x) y x) -> (or x y)")
+ (lint-test "(if x y (not x))" " if: perhaps (if x y (not x)) -> (or (not x) y)")
+
+ (lint-test "(if a A A)" " if: if is not needed here: (if a A A) -> A")
+ (lint-test "(if A A (if B B C))" " if: perhaps (if A A (if B B C)) -> (or A (if B B C)) if: perhaps (if B B C) -> (or B C)")
+ (lint-test "(if a (if b A) A)" " if: perhaps (if a (if b A) A) -> (if (or (not a) b) A)")
+ (lint-test "(if a (if (not a) B) A)" " if: perhaps (if a (if (not a) B) A) -> (if (not a) A)")
+ (lint-test "(if a (if (not a) B C) A)" " if: perhaps (if a (if (not a) B C) A) -> (if a C A)")
+ (lint-test "(if a A (if b B A))" " if: perhaps (if a A (if b B A)) -> (if (or a (not b)) A B)")
+ (lint-test "(if a A (if b A B))" " if: perhaps (if a A (if b A B)) -> (if (or a b) A B)")
+ (lint-test "(if a (if b B A) A)" " if: perhaps (if a (if b B A) A) -> (if (and a b) B A)")
+ (lint-test "(if a (if b A B) A)" " if: perhaps (if a (if b A B) A) -> (if (and a (not b)) B A)")
+ (lint-test "(if a A (if (not a) B))" " if: perhaps (if a A (if (not a) B)) -> (if a A B)")
+
+ (lint-test "(if A (if B C D) D)" " if: perhaps (if A (if B C D) D) -> (if (and A B) C D)")
+ (lint-test "(if A (if B C D) C)" " if: perhaps (if A (if B C D) C) -> (if (and A (not B)) D C)")
+ (lint-test "(if A B (if C B D))" " if: perhaps (if A B (if C B D)) -> (if (or A C) B D)")
+ (lint-test "(if A B (if C D B))" " if: perhaps (if A B (if C D B)) -> (if (or A (not C)) B D)")
+ (lint-test "(if A (and B C) (and B D))" " if: perhaps (if A (and B C) (and B D)) -> (and B (if A C D))")
+ (lint-test "(if A (or B C) (or B D))" " if: perhaps (if A (or B C) (or B D)) -> (or B (if A C D))")
+ (lint-test "(if A (and B C) (and D C))" " if: perhaps (if A (and B C) (and D C)) -> (and (if A B D) C)")
+ (lint-test "(if A (or B C) (or D C))" " if: perhaps (if A (or B C) (or D C)) -> (or (if A B D) C)")
+
+ (lint-test "(if a (if b A B) (if b B A))"
+ " if: perhaps (if a (if b A B) (if b B A)) -> (if (eq? (not a) (not b)) A B)")
+ (lint-test "(if (not a) (if b A B) (if b B A))"
+ " if: perhaps (if (not a) (if b A B) (if b B A)) -> (if (eq? (not a) (not b)) B A)")
+ (lint-test "(if (not a) (if (not b) A B) (if (not b) B A))"
+ " if: perhaps (if (not a) (if (not b) A B) (if (not b) B A)) -> (if (eq? (not a) (not b)) A B)")
+ (lint-test "(if a (if (not b) A B) (if (not b) B A))"
+ " if: perhaps (if a (if (not b) A B) (if (not b) B A)) -> (if (eq? (not a) (not b)) B A)")
+ (lint-test "(if a (if b A B) (if b A B))"
+ " if: if is not needed here: (if a (if b A B) (if b A B)) -> (if b A B)")
+
+ (lint-test "(if A (if B C #f) #f)" " if: perhaps (if A (if B C #f) #f) -> (and A B C) if: perhaps (if B C #f) -> (and B C)")
+ (lint-test "(if A (if B #f D) #f)" " if: perhaps (if A (if B #f D) #f) -> (and A (not B) D) if: perhaps (if B #f D) -> (and (not B) D)")
+ (lint-test "(if A #f (if C #f D))" " if: perhaps (if A #f (if C #f D)) -> (and (not (or A C)) D) if: perhaps (if C #f D) -> (and (not C) D)")
+ (lint-test "(if A #f (if C D #f))" " if: perhaps (if A #f (if C D #f)) -> (and (not A) C D) if: perhaps (if C D #f) -> (and C D)")
+ (lint-test "(if A (if B d c) (if B d a))" " if: perhaps (if A (if B d c) (if B d a)) -> (if B d (if A c a))")
+ (lint-test "(if A (if B c a) (if B d a))" " if: perhaps (if A (if B c a) (if B d a)) -> (if B (if A c d) a)")
+
+ (lint-test "(if (> (random 10) 1) (> (random 10) 1) x)" "")
+ (lint-test "(if (assq (string->symbol x) y) (assq (string->symbol x) y) z)"
+ " if: perhaps (if (assq (string->symbol x) y) (assq (string->symbol x) y) z) -> (or (assq (string->symbol x) y) z)")
(lint-test "(if x y x)" " if: perhaps (if x y x) -> (and x y)")
- (lint-test "(if (> x 1) (> x 1) (< x 2))" " if: perhaps (if (> x 1) (> x 1) (< x 2)) -> (or (> x 1) (< x 2))")
+ (lint-test "(if (> x 1) (> x 1) (< x 2))" " if: perhaps (if (> x 1) (> x 1) (< x 2)) -> #t")
(lint-test "(if x x x)" " if: perhaps (if x x x) -> x if: if is not needed here: (if x x x) -> x")
(lint-test "(if x x)" " if: perhaps (if x x) -> (or x #<unspecified>)")
(lint-test "(if (> x 1) (> x 1))" " if: perhaps (if (> x 1) (> x 1)) -> (or (> x 1) #<unspecified>)")
(lint-test "(if (display x) (display x) y)" "")
- (lint-test "(if (= x 1) 2 (if (= x 3) 2 3))" " if: perhaps (if (= x 1) 2 (if (= x 3) 2 3)) -> (if (memv x '(1 3)) 2 3)")
- (lint-test "(if z x z)" " if: perhaps (if z x z) -> (and z x)")
- (lint-test "(begin (if x (y)) (if x (z)) (if x (w)) 32)" " begin: perhaps combine repeated if's: (if x (y)) ... (if x (w)) -> (when x (y) ... (w))")
- (lint-test "(begin (if x (y)) (if x (z)) (if x (w)))" " begin: perhaps combine repeated if's: (if x (y)) ... (if x (w)) -> (when x (y) ... (w))")
- (lint-test "(begin (if x (y)) (if x (z)) 32)" "")
- (lint-test "(begin (if x (y)) (if x (z)))" "")
- (lint-test "(begin (if x (y)) (if x (z)) (v) (if x (w)))" "")
- (lint-test "(begin (if x (y)) (if x (z)) (v) (if x (w)) 12)" "")
+ (lint-test "(if (= x 1) 2 (if (= x 3) 2 3))" " if: perhaps (if (= x 1) 2 (if (= x 3) 2 3)) -> (if (member x '(1 3) =) 2 3)")
+ (lint-test "(if a b (if c d (if e f g)))" " if: perhaps use cond: (if a b (if c d (if e f g))) -> (cond (a b) (c d) (e f) (else g))")
+ (lint-test "(if a b (if c d (if e f)))" " if: perhaps use cond: (if a b (if c d (if e f))) -> (cond (a b) (c d) (e f))")
+ (lint-test "(if a (begin (b) c) (if d e (if f g (begin (h) i))))"
+ " if: perhaps use cond: (if a (begin (b) c) (if d e (if f g (begin (h) i)))) -> (cond (a (b) c) (d e) (f g) (else (h) i))")
+ (lint-test "(if (f x) (g (f x)))" " if: perhaps (if (f x) (g (f x))) -> (cond ((f x) => g))")
+ (lint-test "(if (f x) (g (f x)) z)" " if: perhaps (if (f x) (g (f x)) z) -> (cond ((f x) => g) (else z))")
+ (lint-test "(if x (set! y z) (set! w z))" "")
+ (lint-test "(if x (set! y x) (set! y #f))" " if: perhaps (if x (set! y x) (set! y #f)) -> (set! y x)")
+ (lint-test "(if x (set! y z) (set! y w))" " if: perhaps (if x (set! y z) (set! y w)) -> (set! y (if x z w))")
+ (lint-test "(if x (set! y (+ 1 z)) (set! y (+ 1 w)))" " if: perhaps (if x (set! y (+ 1 z)) (set! y (+ 1 w))) -> (set! y (if x (+ 1 z) (+ 1 w)))")
+ (lint-test "(if (< x y) (set! x y))" " if: perhaps (if (< x y) (set! x y)) -> (set! x (max x y))")
+ (lint-test "(if (<= y x) (set! x y))" " if: perhaps (if (<= y x) (set! x y)) -> (set! x (min x y))")
+ (lint-test "(if (> x y) (set! x y))" " if: perhaps (if (> x y) (set! x y)) -> (set! x (min x y))")
+ (lint-test "(if (>= y x) (set! x y))" " if: perhaps (if (>= y x) (set! x y)) -> (set! x (max x y))")
+ (lint-test "(if (< x y) x y)" " if: perhaps (if (< x y) x y) -> (min x y)")
+ (lint-test "(if (< x y) y x)" " if: perhaps (if (< x y) y x) -> (max y x)")
+ (lint-test "(if (> x y) x y)" " if: perhaps (if (> x y) x y) -> (max x y)")
+ (lint-test "(if (> x y) y x)" " if: perhaps (if (> x y) y x) -> (min y x)")
+ (lint-test "(if (= x y) x y)" " if: perhaps (if (= x y) x y) -> y")
+ (lint-test "(if (= x y) y x)" " if: perhaps (if (= x y) y x) -> x")
+ (lint-test "(if (pair? x) #t #f)" " if: perhaps (if (pair? x) #t #f) -> (pair? x)")
+ (lint-test "(if (pair? x) #t z)" " if: perhaps (if (pair? x) #t z) -> (or (pair? x) z)")
+ (lint-test "(if x (not y) (not z))" " if: perhaps (if x (not y) (not z)) -> (not (if x y z))")
+
+ (lint-test "(if x y (cond ((= y z) 2) (else 3)))"
+ " if: perhaps (if x y (cond ((= y z) 2) (else 3))) -> (cond (x y) ((= y z) 2) (else 3))")
+ (lint-test "(if x y (cond ((= y z) 2) ((= y 2) 3)))"
+ " if: perhaps (if x y (cond ((= y z) 2) ((= y 2) 3))) -> (cond (x y) ((= y z) 2) ((= y 2) 3))")
+ (lint-test "(if (eof-object? x) 32 (case x ((#\\a) 3) (else 4)))"
+ " if: perhaps (if (eof-object? x) 32 (case x ((#\\a) 3) (else 4))) -> (case x ((#<eof>) 32) ((#\\a) 3) (else 4))
+ if: perhaps (case x ((#\\a) 3) (else 4)) -> (if (eqv? x #\\a) 3 4)")
+ (lint-test "(if (< x 0) (if (< y 0) (if (< z 0) (+ a b c d e f g h i j k l m n o p q r s) z) y) x)"
+ " if: perhaps (if (< x 0) (if (< y 0) (if (< z 0) (+ a b c d e f g h i j k l m n o p q r... ->
+ (cond ((>= x 0) x) ((>= y 0) y) ((>= z 0) z) (else (+ a b c d e f g h i j k l m n o p q r s)))")
+ (lint-test "(if (< x 0) (if (< y 0) y (if (< z 0) z (+ a b c d e f g h i j k l m n o p q r s))) x)"
+ " if: perhaps (if (< x 0) (if (< y 0) y (if (< z 0) z (+ a b c d e f g h i j k l m n o p... ->
+ (cond ((>= x 0) x) ((< y 0) y) ((< z 0) z) (else (+ a b c d e f g h i j k l m n o p q r s)))")
+ (lint-test "(if (< x 0) x (if (< y 0) (if (< z 0) (+ a b c d e f g h i j k l m n o p q r s) z) y))"
+ " if: perhaps (if (< x 0) x (if (< y 0) (if (< z 0) (+ a b c d e f g h i j k l m n o p q... ->
+ (cond ((< x 0) x) ((>= y 0) y) ((>= z 0) z) (else (+ a b c d e f g h i j k l m n o p q r s)))")
+ (lint-test "(if (< x 1) (let ((y (+ x 1)) (z (- x 1))) (+ y z)) (let ((y (+ x 1)) (z (+ x 2))) (- y z)))"
+ " if: perhaps (if (< x 1) (let ((y (+ x 1)) (z (- x 1))) (+ y z)) (let ((y (+ x 1)) (z... ->
+ (let ((y (+ x 1))) (if (< x 1) (let ((z (- x 1))) (+ y z)) (let ((z (+ x 2))) (- y z))))
+ if: perhaps (let ((y (+ x 1)) (z (- x 1))) (+ y z)) -> (+ (+ x 1) (- x 1))
+ if: perhaps (let ((y (+ x 1)) (z (+ x 2))) (- y z)) -> (- (+ x 1) (+ x 2))")
+ (lint-test "(if (< x 1) (let ((y (+ x 1)) (z (- x 1))) (+ y z)) (let ((y (+ x 1)) (z (- x 1))) (- y z)))"
+ " if: perhaps (if (< x 1) (let ((y (+ x 1)) (z (- x 1))) (+ y z)) (let ((y (+ x 1)) (z... ->
+ (let ((y (+ x 1)) (z (- x 1))) (if (< x 1) (+ y z) (- y z)))
+ if: perhaps (let ((y (+ x 1)) (z (- x 1))) (+ y z)) -> (+ (+ x 1) (- x 1))
+ if: perhaps (let ((y (+ x 1)) (z (- x 1))) (- y z)) -> (- (+ x 1) (- x 1))")
+
+ (lint-test "(if a (if b d e) (if c d e))" " if: perhaps (if a (if b d e) (if c d e)) -> (if (if a b c) d e)")
+ (lint-test "(if a (if b d) (if c d))" " if: perhaps (if a (if b d) (if c d)) -> (if (if a b c) d)")
+ (lint-test "(if a (if (f b) d) (if (f c) d))" " if: perhaps (if a (if (f b) d) (if (f c) d)) -> (if (if a (f b) (f c)) d)")
+ (lint-test "(if a (if b c d) d)" " if: perhaps (if a (if b c d) d) -> (if (and a b) c d)")
+
+ (lint-test "(if x y (if (not x) z w))" " if: perhaps (if x y (if (not x) z w)) -> (if x y z)")
+ (lint-test "(if x y (if (not x) z))" " if: perhaps (if x y (if (not x) z)) -> (if x y z)")
+ (lint-test "(if x y (if x z))" " if: perhaps (if x y (if x z)) -> (if x y)")
+ (lint-test "(if x y (if x z w))" " if: perhaps (if x y (if x z w)) -> (if x y w)")
+ (lint-test "(if x (if x z w) y)" " if: perhaps (if x (if x z w) y) -> (if x z y)")
+ (lint-test "(if x (if x z w))" " if: perhaps (if x (if x z w)) -> (if x z w)")
+ (lint-test "(if x (if x z) w)" " if: perhaps (if x (if x z) w) -> (if x z w)")
+ (lint-test "(if x (if x y))" " if: perhaps (if x (if x y)) -> (if x y)")
+ (lint-test "(if x (if (not x) z w) y)" " if: perhaps (if x (if (not x) z w) y) -> (if x w y)")
+ (lint-test "(if x (if (not x) z w))" " if: perhaps (if x (if (not x) z w)) -> w")
+ (lint-test "(if x (if (not x) z) w)" " if: perhaps (if x (if (not x) z) w) -> (if (not x) w)")
+
+ (lint-test "(if A (and B C) (and B D))" " if: perhaps (if A (and B C) (and B D)) -> (and B (if A C D))")
+ (lint-test "(if A (and B C E) (and B D E))" " if: perhaps (if A (and B C E) (and B D E)) -> (and B (if A C D) E)")
+ (lint-test "(if A (list B C) (list B D))" " if: perhaps (if A (list B C) (list B D)) -> (list B (if A C D))")
+ (lint-test "(if A (+ B C) (+ B D))" " if: perhaps (if A (+ B C) (+ B D)) -> (+ B (if A C D))")
+ (lint-test "(if A (< B C) (< B D))" " if: perhaps (if A (< B C) (< B D)) -> (< B (if A C D))")
+
+ (lint-test "(if A (list B C E) (list B D))" " if: perhaps (if A (list B C E) (list B D)) -> (list B (if A (values C E) D))")
+ (lint-test "(if A (+ B C E) (+ B D))" " if: perhaps (if A (+ B C E) (+ B D)) -> (+ B (if A (+ C E) D))")
+ (lint-test "(if A (< B C E) (< B D))" " if: perhaps (if A (< B C E) (< B D)) -> (< B (if A (values C E) D))")
+ (lint-test "(if A (and B C E) (and B D))" " if: perhaps (if A (and B C E) (and B D)) -> (and B (if A (and C E) D))")
+ (lint-test "(if A (and B C E) (and B D F))" " if: perhaps (if A (and B C E) (and B D F)) -> (and B (if A (and C E) (and D F)))")
+ (lint-test "(if A (or B C E) (or B D))" " if: perhaps (if A (or B C E) (or B D)) -> (or B (if A (or C E) D))")
+ (lint-test "(if A (or B C E) (or B D F))" " if: perhaps (if A (or B C E) (or B D F)) -> (or B (if A (or C E) (or D F)))")
+ (lint-test "(if A (or B C E) (or B C D F))" " if: perhaps (if A (or B C E) (or B C D F)) -> (or B C (if A E (or D F)))")
+ (lint-test "(if A (or B C) (or B C D F))" "")
+ (lint-test "(if A (+ B E C) (+ D E C))" " if: perhaps (if A (+ B E C) (+ D E C)) -> (+ (if A B D) E C)")
+ (lint-test "(if A (+ B B E C) (+ D D E C))" " if: perhaps (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C)")
+ (lint-test "(if A (if B C D) (if (not B) C D))" " if: perhaps (if A (if B C D) (if (not B) C D)) -> (if (eq? (not A) (not B)) C D)")
+ (lint-test "(if A (if (not B) C D) (if B C D))" " if: perhaps (if A (if (not B) C D) (if B C D)) -> (if (not (eq? (not A) (not B))) C D)")
+ (lint-test "(if A (if B C D) (if E C D))" " if: perhaps (if A (if B C D) (if E C D)) -> (if (if A B E) C D)")
+ (lint-test "(+ (if A B C) (if A C D) y)" " +: perhaps (+ (if A B C) (if A C D) y) -> (+ (if A (values B C) (values C D)) y)")
+ (lint-test "(begin (if A B C) (if (and A D) Z))"
+ " begin: this could be omitted: (if A B C)
+ begin: perhaps (... (if A B C) (if (and A D) Z) ...) -> (... (if A (begin B (if D Z)) C) ...)")
+ (lint-test "(begin (if A B) (if (and A C) D))"
+ " begin: this could be omitted: (if A B)
+ begin: perhaps (... (if A B) (if (and A C) D) ...) -> (... (if A (begin B (if C D))) ...)")
+
+ (lint-test "(if A (if B (+ x 1)) (if B (- x 1)))"
+ " if: perhaps (if A (if B (+ x 1)) (if B (- x 1))) -> (if B (if A (+ x 1) (- x 1)))")
+ (lint-test "(if A (begin (f x) (g y)) (begin (f x) (g z)))"
+ " if: perhaps (if A (begin (f x) (g y)) (begin (f x) (g z))) -> (begin (f x) (if A (g y) (g z)))")
+ (lint-test "(if A (begin (f x) (g y)) (begin (f y) (g y)))"
+ " if: perhaps (if A (begin (f x) (g y)) (begin (f y) (g y))) -> (begin (if A (f x) (f y)) (g y))")
+ (lint-test "(if A (begin (f x) (g y) (h z)) (begin (f x) (g x) (h z)))"
+ " if: perhaps (if A (begin (f x) (g y) (h z)) (begin (f x) (g x) (h z))) -> (begin (f x) (if A (g y) (g x)) (h z))")
+ (lint-test "(if (not x) (display (+ y 1)) (display x))"
+ " if: perhaps (if (not x) (display (+ y 1)) (display x)) -> (if x (display x) (display (+ y 1)))")
+ (lint-test "(if a A (if b A (if c A B)))"
+ " if: perhaps use cond: (if a A (if b A (if c A B))) -> (cond (a A) (b A) (c A) (else B))
+ if: perhaps (if a A (if b A (if c A B))) -> (if (or a b c) A B)
+ if: perhaps (if b A (if c A B)) -> (if (or b c) A B)")
+ (lint-test "(begin (if x (display x) y) z)" " begin: this branch is pointless: y in (if x (display x) y)")
+ (lint-test "(begin (if x z (display x)) z)" " begin: this branch is pointless: z in (if x z (display x))")
+ (lint-test "(begin (if x (begin (display x) z)) z)" " begin: this is pointless: z in (begin (display x) z)")
+ (lint-test "(begin (if x (begin (display y) (+ x 1)) (begin (display x) z)) z)"
+ " begin: this is pointless: (+ x 1) in (begin (display y) (+ x 1))
+ begin: this is pointless: z in (begin (display x) z)")
+ (lint-test "(begin (let () (display x)) y)" " begin: pointless let: (let () (display x))")
+
+ (lint-test "(let ((list x)) (if (null? list) 3 2))" " let: perhaps (let ((list x)) (if (null? list) 3 2)) -> (if (null? x) 3 2)")
+ (lint-test "(null? (string->list x))" " null?: perhaps (null? (string->list x)) -> (zero? (length x))")
+ (lint-test "(memq x (if (memq y '(< <=)) '(< <=) '(> >=)))" "") ; this is checking the ->simple-type escape
+ (lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "") ; make sure we don't try to rewrite quasiquote
+
+ (let ((old-one *report-one-armed-if*))
+ (set! *report-one-armed-if* #t)
+ (lint-test "(if a (begin (set! x y) z))" " if: perhaps (if a (begin (set! x y) z)) -> (when a (set! x y) z)")
+ (lint-test "(if (not a) (begin (set! x y) z))" " if: perhaps (if (not a) (begin (set! x y) z)) -> (unless a (set! x y) z)")
+ (lint-test "(if a (set! x y))" " if: perhaps (if a (set! x y)) -> (when a (set! x y))")
+ (lint-test "(if (not a) (set! x y))" " if: perhaps (if (not a) (set! x y)) -> (unless a (set! x y))")
+ (set! *report-one-armed-if* old-one))
+
+ (let ((old-doc *report-doc-strings*))
+ (set! *report-doc-strings* #t)
+ (lint-test "(let () (define (hiho a) \"hiho is a function\" (+ a 1)) (hiho 1))"
+ " let: perhaps (... (define (hiho a) \"hiho is a function\" (+ a 1)) (hiho 1)) -> (... (let ((a 1)) (+ a 1)))
+ hiho: old-style doc string: \"hiho is a function\", in s7 use 'documentation:
+ (define hiho
+ (let ((documentation \"hiho is a function\"))
+ (lambda (a)
+ (+ a 1))))")
+ (set! *report-doc-strings* old-doc))
+
+ (let ((old-undef *report-undefined-identifiers*))
+ (set! *report-undefined-identifiers* #t)
+ (lint-test "(let ((x 1)) (cdr? x))" " let: perhaps (let ((x 1)) (cdr? x)) -> (cdr? 1) this identifier was not defined: cdr?")
+ (lint-test "(let ((x 1)) (+ x (aaa)))" " this identifier was not defined: aaa")
+ (lint-test "(let ((x 1)) (+ x (zzz) (aaa)))" " the following identifiers were not defined: aaa zzz")
+ (set! *report-undefined-identifiers* old-undef))
+
+ (let ((old-shadow *report-shadowed-variables*))
+ (set! *report-shadowed-variables* #t)
+ (lint-test "(let ((x 1)) (+ (let ((x 2)) (+ x 1)) x))"
+ " let: let variable x in (x 2) shadows an earlier declaration let: perhaps (let ((x 2)) (+ x 1)) -> (+ 2 1)")
+ (set! *report-shadowed-variables* old-shadow))
+
+ (lint-test "(when (not a) (set! x y))" " when: perhaps (when (not a) (set! x y)) -> (unless a (set! x y))")
+ (lint-test "(unless (not a) (set! x y))" " unless: perhaps (unless (not a) (set! x y)) -> (when a (set! x y))")
+
+ (lint-test "(begin (if x (y)) (if x (z)) 32)" " begin: perhaps (... (if x (y)) (if x (z)) ...) -> (... (when x (y) (z)) ...)")
+ (lint-test "(begin (if x (y)) (if x (z)))" " begin: perhaps (... (if x (y)) (if x (z)) ...) -> (... (when x (y) (z)) ...)")
+ (lint-test "(begin (if x (y)) (if x (z)) (v) (if x (w)))" " begin: perhaps (... (if x (y)) (if x (z)) ...) -> (... (when x (y) (z)) ...)")
+ (lint-test "(begin (if x (y)) (if x (z)) (v) (if x (w)) 12)" " begin: perhaps (... (if x (y)) (if x (z)) ...) -> (... (when x (y) (z)) ...)")
+
+ (lint-test "(begin (if (< x 0) (display y)) (if (< x 0) z))"
+ " begin: perhaps (... (if (< x 0) (display y)) (if (< x 0) z) ...) ->
+ (... (when (< x 0) (display y) z) ...)")
+ (lint-test "(begin (if (< x 0) (display y) (display (- y 1))) (if (< x 0) z))"
+ " begin: perhaps (... (if (< x 0) (display y) (display (- y 1))) (if (< x 0) z) ...) ->
+ (... (if (< x 0) (begin (display y) z) (begin (display (- y 1)))) ...)")
+ (lint-test "(begin (if (< x 0) (begin (display y) (set! y 3)) (display (- y 1))) (if (< x 0) z (begin (display (+ z 1)) (- z 1))))"
+ " begin: perhaps (... (if (< x 0) (begin (display y) (set! y 3)) (display (- y 1))) (if (<... ->
+ (... (if (< x 0) (begin (display y) (set! y 3) z) (begin (display (- y 1)) (display (+ z 1)) (- z 1))) ...)")
+
+ (lint-test "(cond . 1)" " cond: cond is messed up: (cond . 1)")
+ (lint-test "(cond 1)" " cond: cond clause 1 in (cond 1) is not a pair?")
+ (lint-test "(cond ((< 3 1) 2))"
+ " cond: cond test (< 3 1) is never true: (cond ((< 3 1) 2))
+ cond: cond test is always false: ((< 3 1) 2)
+ cond: perhaps (cond ((< 3 1) 2)) -> (cond (#f 2))")
+ (lint-test "(cond (else 2) (x 3))" " cond: cond else clause is not the last: (cond (else 2) (x 3))")
+ (lint-test "(cond (x => abs))" "")
+ (lint-test "(cond (x))" " cond: perhaps (cond (x)) -> x")
+ (lint-test "(cond (x =>))" " cond: cond => target is messed up: (x =>)")
+ (lint-test "(cond (x #f) (#t #t))" " cond: perhaps (cond (x #f) (#t #t)) -> (not x)")
+ (lint-test "(cond (x #t) (else #f))" " cond: perhaps (cond (x #t) (else #f)) -> x")
+ (lint-test "(cond (x #t) (else y))" "")
+ (lint-test "(cond (x #f) (else y))" " cond: perhaps (cond (x #f) (else y)) -> (and (not x) y)")
+ (lint-test "(cond (x #f) (else (f y) g))" " cond: perhaps (cond (x #f) (else (f y) g)) -> (and (not x) (begin (f y) g))")
+ (lint-test "(cond (x #t) (else #t))" " cond: perhaps (cond (x #t) (else #t)) -> #t")
+ (lint-test "(cond ((not x) #f) (else y))" " cond: perhaps (cond ((not x) #f) (else y)) -> (and x y)")
+ (lint-test "(cond ((null? x) #t) (else y))"
+ " cond: this #t could be omitted: ((null? x) #t) cond: perhaps (cond ((null? x) #t) (else y)) -> (or (null? x) y)")
+ (lint-test "(cond ((= x 1) 2) (else 2))" " cond: perhaps (cond ((= x 1) 2) (else 2)) -> 2")
+ (lint-test "(cond ((and (display x) x) 32) (#t 32))" "")
+ (lint-test "(cond (x y) (z 32) (else 32))" " cond: this clause could be omitted: (z 32)")
+ (lint-test "(cond ((= x 1) (display \"a\") 32) (#t (display \"a\") 32))"
+ " cond: perhaps (cond ((= x 1) (display \"a\") 32) (#t (display \"a\") 32)) -> (begin (display \"a\") 32)")
+ (lint-test "(cond ((= x 1) 32))" " cond: perhaps (cond ((= x 1) 32)) -> (if (= x 1) 32)")
+ (lint-test "(cond ((and (display 32) (= x 1)) 1) (#t 1))" "")
+ (lint-test "(cond ((< x 1) 2) (else (cond ((< y 3) 2) (#t 4))))"
+ " cond: else clause could be folded into the outer cond:
+ (cond ((< x 1) 2) (else (cond ((< y 3) 2) (#t 4)))) -> (cond ((< x 1) 2) ((< y 3) 2) (#t 4))")
+ (lint-test "(cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5))"
+ " cond: cond test (< x 2) is never true: (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5))
+ cond: cond test repeated: ((< x 2) 5)
+ cond: cond test is always false: ((< x 2) 5)
+ cond: perhaps (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) -> (cond ((< x 2) 3) ((> x 0) 4) (#f 5))")
+ (lint-test "(cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2))"
+ " cond: perhaps (cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2)) -> (cond ((not (= x 1)) (+ x 1)) (#t 2))")
+ (lint-test "(cond ((= x 3) 4) ((= x 2) 4) ((= x 1) 4) (else 5))"
+ " cond: perhaps (cond ((= x 3) 4) ((= x 2) 4) ((= x 1) 4) (else 5)) -> (case x ((3 2 1) 4) (else 5))")
+ (lint-test "(cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4) (else 5))"
+ " cond: perhaps (cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4) (else 5)) -> (case x ((3) 3) ((2 1) 4) (else 5))")
+ (lint-test "(cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4))"
+ " cond: perhaps (cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4)) -> (case x ((3) 3) ((2 1) 4))")
+ (lint-test "(cond (a) (b) (c))" " cond: perhaps (cond (a) (b) (c)) -> (cond ((or a b c)))")
+ (lint-test "(cond ((= x 0) x) ((= x 1) (= x 1)))"
+ " cond: no need to repeat the test: ((= x 1) (= x 1)) -> ((= x 1))
+ cond: perhaps use case instead of cond: (cond ((= x 0) x) ((= x 1) (= x 1))) -> (case x ((0) x) ((1) (= x 1)))")
+ (lint-test "(cond (x => expt))" " cond: => target (expt) may be unhappy: (x => expt)")
+ (lint-test "(cond (x (abs x)))" " cond: perhaps use => here: (x (abs x)) -> (x => abs)")
+ (lint-test "(cond ((> x 2) (not (> x 2))))" " cond: perhaps use => here: ((> x 2) (not (> x 2))) -> ((> x 2) => not)")
+ (lint-test "(cond (x #t) (y #t) (else #f))" " cond: perhaps (cond (x #t) (y #t) (else #f)) -> (or x y)")
+ (lint-test "(cond (x #f) (y #f) (else #t))" " cond: perhaps (cond (x #f) (y #f) (else #t)) -> (not (or x y))")
+ (lint-test "(cond (x y) ('else z))" " cond: odd cond clause test: is 'else supposed to be else? ('else z)")
+ (lint-test "(cond ((x) y) ((not (x)) z))" " cond: perhaps (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z))")
+
+ (lint-test "(cond (x (let ((z w)) (+ x z)) y) (else 2))"
+ " cond: this could be omitted: (let ((z w)) (+ x z)) cond: perhaps (let ((z w)) (+ x z)) -> (+ x w)")
+ (lint-test "(cond (x (if x y z) (+ x 1)) (z 2))" " cond: this could be omitted: (if x y z)")
+ (lint-test "(cond ((g x) `(c ,x) `(c ,y)))"
+ " cond: this could be omitted: ({list} 'c x)
+ cond: perhaps (cond ((g x) ({list} 'c x) ({list} 'c y))) -> (when (g x) ({list} 'c x) ({list} 'c y))")
+ (lint-test "(cond ((= x 1) 2) ((= x 2) 3))" " cond: perhaps use case instead of cond: (cond ((= x 1) 2) ((= x 2) 3)) -> (case x ((1) 2) ((2) 3))")
+ (lint-test "(cond ((= x y) (begin (display x) y)) (else x))" " cond: redundant begin: (begin (display x) y)")
+ (lint-test "(cond ((= x y) y) (else (begin (display x) x)))"
+ " cond: redundant begin: (begin (display x) x) cond: display returns its first argument, so this could be omitted: x")
+ (lint-test "(cond ((= x y) z) (else #<unspecified>))" " cond: this #<unspecified> is redundant: (else #<unspecified>)")
+ (lint-test "(cond (x y) (y z (else 3)))" " cond: this could be omitted: z cond: perhaps cond else clause is misplaced: (else 3) in (y z (else 3))")
+ (lint-test "(cond (x y) (y z (#t 3)))" " cond: this could be omitted: z cond: perhaps cond else clause is misplaced: (#t 3) in (y z (#t 3))")
+ (lint-test "(cond (< x 1) (else 1))" " cond: strange cond test: < in (< x 1) is a procedure cond: this could be omitted: x")
+ (lint-test "(cond ((memq x '(a b)) 3) ((eq? x 'c) 4) ((or (eq? x 'd) (eq? 'e x)) 5) (else 6))"
+ " cond: perhaps use case instead of cond:
+ (cond ((memq x '(a b)) 3) ((eq? x 'c) 4) ((or (eq? x 'd) (eq? 'e x)) 5)... -> (case x ((a b) 3) ((c) 4) ((d e) 5) (else 6))")
+ (lint-test "(cond ((eq? x 'a) 1) ((not x) 2) (else 3))"
+ " cond: perhaps use case instead of cond: (cond ((eq? x 'a) 1) ((not x) 2) (else 3)) -> (case x ((a) 1) ((#f) 2) (else 3))")
+ (lint-test "(cond ((eof-object? x) 1) ((null? x) 2) ((not x) 3) (else 4))"
+ " cond: perhaps use case instead of cond:
+ (cond ((eof-object? x) 1) ((null? x) 2) ((not x) 3) (else 4)) -> (case x ((#<eof>) 1) ((()) 2) ((#f) 3) (else 4))")
+ (lint-test "(cond ((or (null? x) (not x)) 1) ((eq? x 'a) 3) (else 2))"
+ " cond: perhaps use case instead of cond:
+ (cond ((or (null? x) (not x)) 1) ((eq? x 'a) 3) (else 2)) -> (case x ((() #f) 1) ((a) 3) (else 2))")
+ (lint-test "(cond ((= x 0) 1) ((= x 2) 2) ((= x 3) (cond ((not y) 1) ((null? y) 2) ((eq? y 'a) 3) (else 4))) (else 5))"
+ " cond: perhaps use case instead of cond:
+ (cond ((not y) 1) ((null? y) 2) ((eq? y 'a) 3) (else 4)) -> (case y ((#f) 1) ((()) 2) ((a) 3) (else 4))
+ cond: perhaps use case instead of cond: (cond ((= x 0) 1) ((= x 2) 2) ((= x 3) (cond ((not y) 1) ((null? y) 2)... ->
+ (case x ((0) 1) ((2) 2) ((3) (cond ((not y) 1) ((null? y) 2) ((eq? y 'a) 3) (else 4))) (else 5))
+ cond: perhaps (cond ((= x 0) 1) ((= x 2) 2) ((= x 3) (cond ((not y) 1) ((null? y) 2)... ->
+ (cond ((= x 0) 1) ((= x 2) 2) ((not (= x 3)) 5) ((not y) 1) ((null? y) 2) ((eq? y 'a) 3) (else 4))")
+ (lint-test "(cond ((equal? x 'a) 1) ((equal? x 1) 2) (else 3))"
+ " cond: equal? could be eq? in (equal? x 'a)
+ cond: equal? could be eqv? in (equal? x 1)
+ cond: perhaps use case instead of cond: (cond ((equal? x 'a) 1) ((equal? x 1) 2) (else 3)) -> (case x ((a) 1) ((1) 2) (else 3))")
+ (lint-test "(cond ((= x 1) 1) (t 2))" " cond: odd cond clause test: is t supposed to be #t? (t 2)")
+ (lint-test "(cond (t 2))" " cond: odd cond clause test: is t supposed to be #t? (t 2)")
+ (lint-test "(cond ((memq x '(a b)) => car) ((eq? x 'c) 2))" "") ; this should not got to case because the => operator won't work the same
+ (lint-test "(cond ((char=? c #\\a) (set! x y)) ((char=? c #\\b) (set! y x)) (else (set! x z)))"
+ " cond: perhaps use case instead of cond: (cond ((char=? c #\\a) (set! x y)) ((char=? c #\\b) (set! y x)) (else (set! x z))) ->
+ (case c ((#\\a) (set! x y)) ((#\\b) (set! y x)) (else (set! x z)))")
+ (lint-test "(cond ((char-ci=? c #\\a) (set! x y)) ((char=? c #\\b) (set! y x)) (else (set! x z)))"
+ " cond: perhaps use case instead of cond: (cond ((char-ci=? c #\\a) (set! x y)) ((char=? c #\\b) (set! y x)) (else... ->
+ (case c ((#\\a #\\A) (set! x y)) ((#\\b) (set! y x)) (else (set! x z)))")
+ (lint-test "(cond ((null? x) 1) ((= x 1) 2) ((boolean? x) 3) (else 4))"
+ " cond: perhaps use case instead of cond: (cond ((null? x) 1) ((= x 1) 2) ((boolean? x) 3) (else 4)) ->
+ (case x ((()) 1) ((1) 2) ((#t #f) 3) (else 4))")
+ (lint-test "(cond ((< x 1) 1) ((string? y) 2))" "") ; check a simplification bug
+ (lint-test "(cond ((eof-object? x)) ((zero? x)))"
+ " cond: perhaps use case instead of cond: (cond ((eof-object? x)) ((zero? x))) -> (case x ((#<eof>) #t) ((0 0.0) #t))")
+ (lint-test "(cond ((= 3 (length eq)) (caddr eq)) (else #f))"
+ " cond: perhaps (cond ((= 3 (length eq)) (caddr eq)) (else #f)) -> (and (= 3 (length eq)) (caddr eq))")
+ (lint-test "(cond ((= 3 (length eq)) (caddr eq)) (else #t))"
+ " cond: perhaps (cond ((= 3 (length eq)) (caddr eq)) (else #t)) -> (or (not (= 3 (length eq))) (caddr eq))")
+ (lint-test "(cond ((= x y) #f) (else (abs x)))" " cond: perhaps (cond ((= x y) #f) (else (abs x))) -> (and (not (= x y)) (abs x))")
+ (lint-test "(cond ((and (= x y) z) (+ x 1)) (else #f))"
+ " cond: perhaps (cond ((and (= x y) z) (+ x 1)) (else #f)) -> (and (= x y) z (+ x 1))")
+ (lint-test "(cond (a A) (else A))" " cond: perhaps (cond (a A) (else A)) -> A")
+ (lint-test "(cond ((a)) (else A))" " cond: perhaps (cond ((a)) (else A)) -> (or (a) A)")
+ (lint-test "(cond (a A) (else (if b B)))"
+ " cond: else clause could be folded into the outer cond: (cond (a A) (else (if b B))) -> (cond (a A) (b B))")
+ (lint-test "(cond (a A) (else (if b B C)))"
+ " cond: else clause could be folded into the outer cond: (cond (a A) (else (if b B C))) -> (cond (a A) (b B) (else C))")
+ (lint-test "(cond (a A) (else (if b (begin (B) D) (begin (C) E))))"
+ " cond: else clause could be folded into the outer cond:
+ (cond (a A) (else (if b (begin (B) D) (begin (C) E)))) -> (cond (a A) (b (B) D) (else (C) E))")
+ (lint-test "(cond (a A) (else (when b B)))"
+ " cond: else clause could be folded into the outer cond: (cond (a A) (else (when b B))) -> (cond (a A) (b B))")
+ (lint-test "(cond (a A) (else (unless b B)))"
+ " cond: else clause could be folded into the outer cond: (cond (a A) (else (unless b B))) -> (cond (a A) ((not b) B))")
+ (lint-test "(cond (A) (B) (else C))" " cond: perhaps (cond (A) (B) (else C)) -> (or A B C)")
+ (lint-test "(cond (A) (B) (else (C) D))" " cond: perhaps (cond (A) (B) (else (C) D)) -> (or A B (begin (C) D))")
+ (lint-test "(cond (A) (B) (C))" " cond: perhaps (cond (A) (B) (C)) -> (cond ((or A B C)))") ; (or A B C #<unspecified>) ??
+ (lint-test "(cond ((A) B) ((or C D)) (else E))"
+ " cond: perhaps (cond ((A) B) ((or C D)) (else E)) -> (cond ((A) B) (else (or C D E)))")
+
+ (lint-test "(cond (A (cond (B c) (else D))) (else E))"
+ " cond: perhaps (cond (A (cond (B c) (else D))) (else E)) -> (cond ((not A) E) (B c) (else D))")
+ (lint-test "(cond (A (cond (B c) (else D))))"
+ " cond: perhaps (cond (A (cond (B c) (else D)))) -> (if A (cond (B c) (else D)))
+ cond: perhaps (cond (A (cond (B c) (else D)))) -> (cond ((not A) #<unspecified>) (B c) (else D))")
+ (lint-test "(cond (A B) (C (cond (D d) (else E))) (else F))"
+ " cond: perhaps (cond (A B) (C (cond (D d) (else E))) (else F)) -> (cond (A B) ((not C) F) (D d) (else E))")
+ (lint-test "(cond (A B) (C (if D d E)) (else F))"
+ " cond: perhaps (cond (A B) (C (if D d E)) (else F)) -> (cond (A B) ((not C) F) (D d) (else E))")
+ (lint-test "(cond (A B) ((not C) (cond (D d) (else E))) (else F))"
+ " cond: perhaps (cond (A B) ((not C) (cond (D d) (else E))) (else F)) -> (cond (A B) (C F) (D d) (else E))")
+ (lint-test "(cond (A B) ((< C 1) (cond (D d) (else E))) (else F))"
+ " cond: perhaps (cond (A B) ((< C 1) (cond (D d) (else E))) (else F)) -> (cond (A B) ((>= C 1) F) (D d) (else E))")
+
+ (lint-test "(cond ((string=? x \"a\") 1) ((string=? x \"b\") 2) ((string=? x \"c\") 3) (else 4))"
+ " cond: perhaps (cond ((string=? x \"a\") 1) ((string=? x \"b\") 2) ((string=? x \"c\") 3) (else 4)) ->
+ (cond ((assq (string->symbol x) '((a . 1) (b . 2) (c . 3))) => cdr) (else 4))")
+ (lint-test "(cond ((any-op x) 1) ((eq? x 'b) 2) ((eq? x 'c) 3) (else 4))"
+ " cond: perhaps (cond ((any-op x) 1) ((eq? x 'b) 2) ((eq? x 'c) 3) (else 4)) ->
+ (cond ((any-op x) 1) ((assq x '((b . 2) (c . 3))) => cdr) (else 4))")
+ (lint-test "(cond ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7) (else 1.852))"
+ " cond: perhaps (cond ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7) (else 1.852)) ->
+ (cond ((assoc order '((1 . 1.0) (2 . 1.3)) =) => cdr) ((< order 9) 1.7) (else 1.852))")
+ (lint-test "(cond ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7))"
+ " cond: perhaps (cond ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7)) ->
+ (cond ((assoc order '((1 . 1.0) (2 . 1.3)) =) => cdr) ((< order 9) 1.7))")
+ (lint-test "(cond ((< order 8) 1.6) ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7))"
+ " cond: perhaps (cond ((< order 8) 1.6) ((= order 1) 1.0) ((= order 2) 1.3) ((< order 9) 1.7)) ->
+ (cond ((< order 8) 1.6) ((assoc order '((1 . 1.0) (2 . 1.3)) =) => cdr) ((< order 9) 1.7))")
+ (lint-test "(cond ((and (integer? x) (exact? x) (integer? y) (exact? y)) 2) (else 3))"
+ " cond: perhaps (cond ((and (integer? x) (exact? x) (integer? y) (exact? y)) 2) (else 3)) ->
+ (cond ((and (integer? x) (integer? y)) 2) (else 3))")
+ (lint-test "(cond ((and (integer? x) (exact? y) (integer? y) (exact? x)) 2) (else 3))"
+ " cond: perhaps (cond ((and (integer? x) (exact? y) (integer? y) (exact? x)) 2) (else 3)) ->
+ (cond ((and (integer? x) (integer? y)) 2) (else 3))")
+ (lint-test "(cond ((integer? x) (+ x 1)) ((real? x) (- x 1.0)) (else (+ x 1)))"
+ " cond: perhaps (cond ((integer? x) (+ x 1)) ((real? x) (- x 1.0)) (else (+ x 1))) ->
+ (if (or (integer? x) (not (real? x))) (+ x 1) (- x 1.0))")
+ (lint-test "(cond ((complex? x) (+ x 1)) ((not (integer? x)) 0) (else (+ x 1)))"
+ " cond: perhaps (cond ((complex? x) (+ x 1)) ((not (integer? x)) 0) (else (+ x 1))) ->
+ (if (complex? x) (+ x 1) 0)")
+ (lint-test "(cond (A a) (B b) (else a))" " cond: perhaps (cond (A a) (B b) (else a)) -> (if (or A (not B)) a b)")
+ (lint-test "(cond (A #f) (B b) (else #f))" " cond: perhaps (cond (A #f) (B b) (else #f)) -> (and (not A) B b)")
+ (lint-test "(cond (A #f) (B #t) (else #f))" " cond: perhaps (cond (A #f) (B #t) (else #f)) -> (and (not A) B)")
+ (lint-test "(cond (A #t) (B b) (else #t))" " cond: perhaps (cond (A #t) (B b) (else #t)) -> (or A (not B) b)")
+ (lint-test "(cond (A #t) (B #f) (else #t))" " cond: perhaps (cond (A #t) (B #f) (else #t)) -> (or A (not B))")
+ (lint-test "(cond (A a) (B a) (else b))" " cond: perhaps (cond (A a) (B a) (else b)) -> (cond ((or A B) a) (else b))")
+ (lint-test "(cond ((and A B) c) (B d) (else e))" " cond: perhaps (cond ((and A B) c) (B d) (else e)) -> (cond (B (if A c d)) (else e))")
+ (lint-test "(cond ((and A B) c) (A d) (else e))" " cond: perhaps (cond ((and A B) c) (A d) (else e)) -> (cond (A (if B c d)) (else e))")
+ (lint-test "(cond (A B) ((or A C) D))" " cond: perhaps (cond (A B) ((or A C) D)) -> (cond (A B) (C D))")
+ (lint-test "(cond (A B) ((or A C) D) (C E))"
+ " cond: cond test C is never true: (cond (A B) ((or A C) D) (C E))
+ cond: cond test is always false: (C E)
+ cond: perhaps (cond (A B) ((or A C) D) (C E)) -> (cond (A B) (C D) (#f E))")
+ (lint-test "(cond ((< x 1) 21) ((< x 2) 32) ((or (< x 1) (> x 3)) 33))"
+ " cond: perhaps (cond ((< x 1) 21) ((< x 2) 32) ((or (< x 1) (> x 3)) 33)) -> (cond ((assoc x '((1 . 21) (2 . 32)) <) => cdr) ((> x 3) 33))")
+ (lint-test "(cond ((not x) (display (+ y 1))) (else (display x)))"
+ " cond: perhaps (cond ((not x) (display (+ y 1))) (else (display x))) -> (display (if (not x) (+ y 1) x))
+ cond: perhaps (cond ((not x) (display (+ y 1))) (else (display x))) -> (if x (display x) (display (+ y 1)))")
+ (lint-test "(cond ((not x) (display (+ y 1)) z) (else (display x) a))"
+ " cond: perhaps (cond ((not x) (display (+ y 1)) z) (else (display x) a)) -> (cond (x (display x) a) (else (display (+ y 1)) z))")
+ (lint-test "(begin (cond (x y) (z (display a) (+ a 1))) z)"
+ " begin: this is pointless: y in (x y)
+ begin: this is pointless: (+ a 1) in (z (display a) (+ a 1))")
+ (lint-test "(begin (cond ((A) (f B)) ((< C 1) (cond ((D) (f d)) (else (f E))))) x)"
+ " begin: perhaps (cond ((D) (f d)) (else (f E))) -> (f (if (D) d E))
+ begin: perhaps (cond ((A) (f B)) ((< C 1) (cond ((D) (f d)) (else (f E))))) -> (cond ((A) (f B)) ((>= C 1)) ((D) (f d)) (else (f E)))")
+ (lint-test "(cond ((A) (f B)) ((< C 1) (cond ((D) (f d)) (else (f E)))))"
+ " cond: perhaps (cond ((D) (f d)) (else (f E))) -> (f (if (D) d E))
+ cond: perhaps (cond ((A) (f B)) ((< C 1) (cond ((D) (f d)) (else (f E))))) -> (cond ((A) (f B)) ((>= C 1) #<unspecified>) ((D) (f d)) (else (f E)))")
+ (lint-test "(cond ((= x 0) 1) ((= x 3) (cond ((not y) 1) ((pair? y) 2) ((eq? y 'a) 3) (else 4))) ((< x 200) 2) (else 5))"
+ " cond: perhaps (cond ((= x 0) 1) ((= x 3) (cond ((not y) 1) ((pair? y) 2) ((eq? y 'a) 3)... ->
+ (cond ((= x 0) 1)
+ ((not (= x 3)) (if (< x 200) 2 5))
+ ((not y) 1)
+ ((pair? y) 2)
+ ((eq? y 'a) 3)
+ (else 4))")
+
+ (lint-test "(cond ((< x 1) (+ x 1)) (else (+ x 2)))"
+ " cond: perhaps (cond ((< x 1) (+ x 1)) (else (+ x 2))) -> (+ x (if (< x 1) 1 2))")
+ (lint-test "(cond ((< x 1) (fx1 x y z)) (else (fx1 x z z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y z)) (else (fx1 x z z))) -> (fx1 x (if (< x 1) y z) z)")
+ (lint-test "(cond ((< x 1) (fx1 x y z)) (else (fx1 x z a z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y z)) (else (fx1 x z a z))) -> (fx1 x (if (< x 1) y (values z a)) z)")
+ (lint-test "(cond ((< x 1) (fx1 x y z)) (else (fx1 z z y z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y z)) (else (fx1 z z y z))) -> (fx1 (if (< x 1) x (values z z)) y z)")
+ (lint-test "(cond ((< x 1) (fx1 x z)) (else (fx1 x z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x z)) (else (fx1 x z))) -> (fx1 x z)")
+ (lint-test "(cond ((< x 1) (fx1 x y y z)) (else (fx1 x y z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y y z)) (else (fx1 x y z))) -> (fx1 x y (if (< x 1) (values y z) z))")
+ (lint-test "(cond ((< x 1) (fx1 x y y z)) (else (fx1 x z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y y z)) (else (fx1 x z))) -> (fx1 x (if (< x 1) (values y y z) z))")
+ (lint-test "(cond ((< x 1) (fx1 x y z)) (else (fx1 x y y z)))"
+ " cond: perhaps (cond ((< x 1) (fx1 x y z)) (else (fx1 x y y z))) -> (fx1 x y (if (< x 1) z (values y z)))")
+ (lint-test "(cond ((< x 1) (list)) (else (list x)))" "")
+ (lint-test "(cond ((< x 1) (list x)) (else (list)))" "")
+ (lint-test "(cond ((< x 1) (list x)) (else (list x y)))"
+ " cond: perhaps (cond ((< x 1) (list x)) (else (list x y))) -> (list (if (< x 1) x (values x y)))")
+ (lint-test "(cond ((< x 1) (list x y)) (else (list x)))"
+ " cond: perhaps (cond ((< x 1) (list x y)) (else (list x))) -> (list (if (< x 1) (values x y) x))")
+ (lint-test "(cond ((< x 1) (+ x 1)) ((< y 1) (+ x 3)) (else (+ x 2)))"
+ " cond: perhaps (cond ((< x 1) (+ x 1)) ((< y 1) (+ x 3)) (else (+ x 2))) -> (+ x (cond ((< x 1) 1) ((< y 1) 3) (else 2)))")
+ (lint-test "(cond ((< x 1) (+ x 1 y)) ((< y 1) (+ x 3 y)) (else (+ x 2 y)))"
+ " cond: perhaps (cond ((< x 1) (+ x 1 y)) ((< y 1) (+ x 3 y)) (else (+ x 2 y))) -> (+ x (cond ((< x 1) 1) ((< y 1) 3) (else 2)) y)")
+ (lint-test "(cond (else (+ x 1)))" " cond: perhaps (cond (else (+ x 1))) -> (+ x 1)")
+ (lint-test "(cond ((< x 1) (log x 2)) ((< x 2) (log x 3)) (else (error 'oops)))"
+ " cond: perhaps (cond ((< x 1) (log x 2)) ((< x 2) (log x 3)) (else (error 'oops))) -> (log x (cond ((< x 1) 2) ((< x 2) 3) (else (error 'oops))))")
+
+ (lint-test "(when (and (< x 1) y) (if z (display z)))"
+ " when: perhaps (when (and (< x 1) y) (if z (display z))) -> (when (and (< x 1) y z) (display z))")
+ (lint-test "(when y (if z (display z)))"
+ " when: perhaps (when y (if z (display z))) -> (when (and y z) (display z))")
+ (lint-test "(when y (if (or (< x 1) z) (display z)))"
+ " when: perhaps (when y (if (or (< x 1) z) (display z))) -> (when (and y (or (< x 1) z)) (display z))")
+ (lint-test "(when (and (< x 1) y) (when z (display z) x))"
+ " when: perhaps (when (and (< x 1) y) (when z (display z) x)) -> (when (and (< x 1) y z) (display z) x)")
+ (lint-test "(unless (and (< x 1) y) (if z (display z)))"
+ " unless: perhaps (unless (and (< x 1) y) (if z (display z))) -> (when (and (not (and (< x 1) y)) z) (display z))")
+ (lint-test "(unless y (if z (display z)))"
+ " unless: perhaps (unless y (if z (display z))) -> (when (and (not y) z) (display z))")
+ (lint-test "(unless y (if (or (< x 1) z) (display z)))"
+ " unless: perhaps (unless y (if (or (< x 1) z) (display z))) -> (when (and (not y) (or (< x 1) z)) (display z))")
+ (lint-test "(unless (and (< x 1) y) (when z (display z) x))"
+ " unless: perhaps (unless (and (< x 1) y) (when z (display z) x)) -> (when (and (not (and (< x 1) y)) z) (display z) x)")
+ (lint-test "(unless (and (< x 1) y) (unless z (display z) x))"
+ " unless: perhaps (unless (and (< x 1) y) (unless z (display z) x)) -> (unless (or (and (< x 1) y) z) (display z) x)")
+ (lint-test "(if (and (< x 1) y) (when z (display z) x))"
+ " if: perhaps (if (and (< x 1) y) (when z (display z) x)) -> (when (and (< x 1) y z) (display z) x)")
+ (lint-test "(if (and (< x 1) y) (unless z (display z) x))"
+ " if: perhaps (if (and (< x 1) y) (unless z (display z) x)) -> (when (and (< x 1) y (not z)) (display z) x)")
(lint-test "(car (cons 1 2))" " car: (car (cons 1 2)) is the same as 1")
+ (lint-test "(car (string->list x))" " car: perhaps (car (string->list x)) -> (string-ref x 0)")
+ (lint-test "(car (string->list (symbol->string x)))" " car: perhaps (car (string->list (symbol->string x))) -> (string-ref (symbol->string x) 0)")
+ (lint-test "(set-car! (list-tail x y) z)" " set-car!: perhaps (set-car! (list-tail x y) z) -> (list-set! x y z)")
+ (lint-test "(set-car! (cdr x) y)" " set-car!: perhaps (set-car! (cdr x) y) -> (list-set! x 1 y)")
+ (lint-test "(set-car! (cddr (cdddr x)) y)" " set-car!: perhaps (set-car! (cddr (cdddr x)) y) -> (list-set! x 5 y)")
+ (lint-test "(car (list-tail x y))" " car: perhaps (car (list-tail x y)) -> (list-ref x y)")
+ (lint-test "(caddr (vector->list x))" " caddr: perhaps (caddr (vector->list x)) -> (vector-ref x 2)")
(lint-test "(and x x y)" " and: perhaps (and x x y) -> (and x y)")
(lint-test "(or x x y)" " or: perhaps (or x x y) -> (or x y)")
(lint-test "(or x (or x y))" " or: perhaps (or x (or x y)) -> (or x y)")
(lint-test "(< x 1 2 0 y)" " <: this comparison can't be true: (< x 1 2 0 y)")
+ (lint-test "(< (- x y) 0)" " <: perhaps (< (- x y) 0) -> (< x y)")
+ (lint-test "(> (- (log x) (log y)) 0.0)" " >: perhaps (> (- (log x) (log y)) 0.0) -> (> (log x) (log y))")
+ (lint-test "(< 0 (- x y))" " <: perhaps (< 0 (- x y)) -> (> x y)")
(lint-test "(< x 1 2 y)" "")
(lint-test "(< x 1 y)" "")
+ (lint-test "(< x x)" " <: this looks odd: (< x x)")
+ (lint-test "(< x y x)" " <: it looks odd to have repeated arguments in (< x y x) <: perhaps (< x y x) -> #f")
+ (lint-test "(< x x y)" " <: it looks odd to have repeated arguments in (< x x y) <: perhaps (< x x y) -> #f")
+ (lint-test "(<= x x y z)" " <=: it looks odd to have repeated arguments in (<= x x y z) <=: perhaps (<= x x y z) -> (= x y z)")
+ (lint-test "(<= x y x z x)" " <=: it looks odd to have repeated arguments in (<= x y x z x) <=: perhaps (<= x y x z x) -> (= x y z)")
+ (lint-test "(<= x x x)" " <=: it looks odd to have repeated arguments in (<= x x x) <=: perhaps (<= x x x) -> #t")
+ (lint-test "(> x y z y)" " >: it looks odd to have repeated arguments in (> x y z y) >: perhaps (> x y z y) -> #f")
(lint-test "(char>? x #\\a #\\b y)" " char>?: this comparison can't be true: (char>? x #\\a #\\b y)")
+ (lint-test "(< (char->integer x) 95)" " <: perhaps (< (char->integer x) 95) -> (char<? x #\\_)")
+ (lint-test "(>= (char->integer x) 90 (char->integer y))" " >=: perhaps (>= (char->integer x) 90 (char->integer y)) -> (char>=? x #\\Z y)")
+
(lint-test "(string>? \"a\" x \"b\" y)" " string>?: this comparison can't be true: (string>? \"a\" x \"b\" y)")
(lint-test "(copy (copy x))" " copy: (copy (copy x)) could be (copy x)")
-
+ (lint-test "(copy x x)" " copy: (copy x x) could be x")
+ (lint-test "(copy x y 1 0)" " copy: these copy indices make no sense: (copy x y 1 0)")
+ (lint-test "(copy x y 0 0)" " copy: these copy indices make no sense: (copy x y 0 0)")
+
+ (lint-test "(string-ref (symbol->string 'abs) 1)"
+ " string-ref: perhaps (string-ref (symbol->string 'abs) 1) -> #\\b
+ string-ref: perhaps (symbol->string 'abs) -> \"abs\"")
+ (lint-test "(string-ref (substring x 1) 2)" " string-ref: perhaps (string-ref (substring x 1) 2) -> (string-ref x (+ 2 1))")
+ (lint-test "(string-ref (make-string 3 #\\a) 1)" " string-ref: perhaps (string-ref (make-string 3 #\\a) 1) -> #\\a")
+ (lint-test "(string-ref (round x) str)"
+ " string-ref: in (string-ref (round x) str), string-ref's argument 1 should be a string, but (round x) is an integer?")
+ (lint-test "(string-ref x (cons 1 2))"
+ " string-ref: in (string-ref x (cons 1 2)), string-ref's argument 2 should be an integer, but (cons 1 2) is a pair?")
(lint-test "(string-copy (string-copy x))" " string-copy: (string-copy (string-copy x)) could be (string-copy x)")
(lint-test "(string-append x)" " string-append: perhaps (string-append x) -> x, or use copy")
(lint-test "(string-append \"\" \"\" x)" " string-append: perhaps (string-append \"\" \"\" x) -> x, or use copy")
@@ -84499,15 +86051,67 @@ etc
(lint-test "(string-append \"123\" \"456\")" " string-append: perhaps (string-append \"123\" \"456\") -> \"123456\"")
(lint-test "(string-append x (string-append y z))" " string-append: perhaps (string-append x (string-append y z)) -> (string-append x y z)")
(lint-test "(vector-append)" " vector-append: perhaps (vector-append) -> #()")
+ (lint-test "(vector-append x)" " vector-append: perhaps (vector-append x) -> (copy x)")
(lint-test "(vector-append #(1 2) (vector-append #(3)))" " vector-append: perhaps (vector-append #(1 2) (vector-append #(3))) -> #(1 2 3)")
(lint-test "(vector-append x (vector-append y z))" " vector-append: perhaps (vector-append x (vector-append y z)) -> (vector-append x y z)")
(lint-test "(object->string (object->string x))" " object->string: (object->string (object->string x)) could be (object->string x)")
(lint-test "(object->string x :else)" " object->string: bad second argument: :else")
- (lint-test "(display (format #f str x))" " display: (display (format #f str x)) could be (format #t str x)")
- (lint-test "(vector->list (list->vector x))" " vector->list: (vector->list (list->vector x)) could be (copy x)")
+ (lint-test "(display (format #f str x))" " display: perhaps (display (format #f str x)) -> (format () str x)")
+ (lint-test "(display (apply format #f str x) p)" " display: perhaps (display (apply format #f str x) p) -> (apply format p str x)")
+
(lint-test "(reverse (reverse x))" " reverse: (reverse (reverse x)) could be (copy x)")
+ (lint-test "(reverse (cdr (reverse x)))" " reverse: perhaps (reverse (cdr (reverse x))) -> (copy x (make-list (- (length x) 1)))")
+ (lint-test "(reverse (cons x (reverse y)))" " reverse: perhaps (reverse (cons x (reverse y))) -> (append y (list x))")
+ (lint-test "(reverse (list-tail (reverse slist) index))"
+ " reverse: perhaps (reverse (list-tail (reverse slist) index)) -> (copy slist (make-list (- (length slist) index)))")
+ (lint-test "(reverse (append (reverse b) res))" " reverse: perhaps (reverse (append (reverse b) res)) -> (append (reverse res) b)")
+
+; (lint-test "(let ((v (list 1 2))) (reverse! v) v)" "")
+; (lint-test "(let ((v1 (list 1 2))) (set! v1 (reverse! v1)))" "")
+
+ (lint-test "(vector->list (list->vector x))" " vector->list: (vector->list (list->vector x)) could be (copy x)")
(lint-test "(string->number (number->string x))" " string->number: (string->number (number->string x)) could be x")
+ (lint-test "(length (string->list x))" " length: perhaps (length (string->list x)) -> (length x)")
+ (lint-test "(length (vector->list x))" " length: perhaps (length (vector->list x)) -> (length x)")
+ (lint-test "(length (vector->list x 1))" " length: perhaps (length (vector->list x 1)) -> (- (length x) 1)")
+ (lint-test "(length (vector->list x 1 3))" " length: perhaps (length (vector->list x 1 3)) -> 2")
+ (lint-test "(length (vector->list x y 3))" " length: perhaps (length (vector->list x y 3)) -> (- 3 y)")
+ (lint-test "(list->string (vector->list x))" " list->string: perhaps (list->string (vector->list x)) -> (copy x (make-string (length x)))")
+ (lint-test "(list->vector (string->list x))" " list->vector: perhaps (list->vector (string->list x)) -> (copy x (make-vector (length x)))")
+ (lint-test "(vector->list (make-vector 3 #f))" " vector->list: perhaps (vector->list (make-vector 3 #f)) -> (make-list 3 #f)")
+ (lint-test "(list->vector (make-list 3 #f))" " list->vector: perhaps (list->vector (make-list 3 #f)) -> (make-vector 3 #f)")
+ (lint-test "(list->string (reverse x))" " list->string: perhaps (list->string (reverse x)) -> (reverse (apply string x))")
+ (lint-test "(list->vector (reverse (vector->list x)))" " list->vector: perhaps (list->vector (reverse (vector->list x))) -> (reverse x)")
+ (lint-test "(list->vector (reverse! (vector->list x)))" " list->vector: perhaps (list->vector (reverse! (vector->list x))) -> (reverse x)")
+ (lint-test "(list->vector (copy (vector->list x)))" " list->vector: perhaps (list->vector (copy (vector->list x))) -> (copy x)")
+ (lint-test "(list->string (reverse (string->list (substring str 1))))"
+ " list->string: perhaps (list->string (reverse (string->list (substring str 1)))) -> (reverse (substring str 1))")
+ (lint-test "(list->string (cdr (string->list x)))" " list->string: perhaps (list->string (cdr (string->list x))) -> (substring x 1)")
+ (lint-test "(list->vector (list-tail (vector->list x) y))"
+ " list->vector: perhaps (list->vector (list-tail (vector->list x) y)) -> (copy x (make-vector (- (length x) y))) ")
+ (lint-test "(string->list \"123\")" " string->list: perhaps (string->list \"123\") -> (#\\1 #\\2 #\\3)")
+ (lint-test "(list->vector '(1 2 3))" " list->vector: perhaps (list->vector '(1 2 3)) -> #(1 2 3)")
+ (lint-test "(list->vector (cons x '()))"
+ " list->vector: perhaps (list->vector (cons x '())) -> (vector x)
+ list->vector: perhaps (cons x '()) -> (list x)
+ list->vector: quote is not needed here: '()")
+ (lint-test "(list->vector (list x y z))" " list->vector: perhaps (list->vector (list x y z)) -> (vector x y z)")
+ (lint-test "(list->vector (append (vector->list x) (vector->list y)))"
+ " list->vector: perhaps (append (vector->list x) (vector->list y)) -> (vector->list (append x y))")
+ (lint-test "(list->string '(#\\a #\\b #\\c))" " list->string: perhaps (list->string '(#\\a #\\b #\\c)) -> \"abc\"")
+ (lint-test "(list->string (cons x '()))"
+ " list->string: perhaps (list->string (cons x '())) -> (string x)
+ list->string: perhaps (cons x '()) -> (list x)
+ list->string: quote is not needed here: '()")
+ (lint-test "(list->string (list x y z))" " list->string: perhaps (list->string (list x y z)) -> (string x y z)")
+ (lint-test "(list->vector (sort! (vector->list x) y))" " list->vector: perhaps (list->vector (sort! (vector->list x) y)) -> (sort! x y)")
+ (lint-test "(list->string (sort! (string->list x) y))" " list->string: perhaps (list->string (sort! (string->list x) y)) -> (sort! x y)")
+ (lint-test "(string->list x y y)" " string->list: leaving aside errors, (string->list x y y) is ()")
+ (lint-test "(symbol->keyword (string->symbol x))" " symbol->keyword: perhaps (symbol->keyword (string->symbol x)) -> (make-keyword x)")
+
+ (lint-test "(car (reverse x))" " car: perhaps (car (reverse x)) -> (list-ref x (- (length x) 1))")
+ (lint-test "(caddr (reverse! x))" " caddr: perhaps (caddr (reverse! x)) -> (list-ref x (- (length x) 3))")
(lint-test "(append 3)" " append: perhaps (append 3) -> 3")
(lint-test "(append)" " append: perhaps (append) -> ()")
@@ -84524,9 +86128,25 @@ etc
(lint-test "(append '(x) '((+ 1 2) #(0)))" " append: perhaps (append '(x) '((+ 1 2) #(0))) -> (list 'x '(+ 1 2) #(0))")
;; (equal? (list 'x '(+ 1 2) #(0)) (append '(x) '((+ 1 2) #(0)))) -> #t
(lint-test "(append (list x) (list y z) (list 1))" " append: perhaps (append (list x) (list y z) (list 1)) -> (list x y z 1)")
+ (lint-test "(append (list x y) '(z))" " append: perhaps (append (list x y) '(z)) -> (list x y 'z)")
+ (lint-test "(append (list x) y)" " append: perhaps (append (list x) y) -> (cons x y)")
+ (lint-test "(append (list x) (list y z))" " append: perhaps (append (list x) (list y z)) -> (list x y z)")
+ (lint-test "(append () '(1 2) 1)" " append: perhaps (append () '(1 2) 1) -> (append '(1 2) 1)")
+ (lint-test "(append '() (append) (list 1) (list) () (list 2) ())"
+ " append: perhaps (append '() (append) (list 1) (list) () (list 2) ()) -> (list 1 2) append: quote is not needed here: '()")
+ (lint-test "(append x y (append))" " append: perhaps (append x y (append)) -> (append x y ())")
+ (lint-test "(append x y ())" "")
(lint-test "(cons x (list y z))" " cons: perhaps (cons x (list y z)) -> (list x y z)")
(lint-test "(cons x (list))" " cons: perhaps (cons x (list)) -> (list x)")
+ (lint-test "(cons 1 ())" " cons: perhaps (cons 1 ()) -> (list 1)")
+ (lint-test "(cons a (cons b (cons c ())))" " cons: perhaps (cons a (cons b (cons c ()))) -> (list a b c)")
+ (lint-test "(cons a (cons b (list c)))" " cons: perhaps (cons a (cons b (list c))) -> (list a b c)")
+ (lint-test "(cons a (cons b (list c d)))" " cons: perhaps (cons a (cons b (list c d))) -> (list a b c d)")
+ (lint-test "(cons a (cons b c))" "")
+ (lint-test "(cons a (cons b (cons c '())))" " cons: perhaps (cons a (cons b (cons c '()))) -> (list a b c) cons: quote is not needed here: '()")
+ (lint-test "(cons (car x) (cdr x))" " cons: perhaps (cons (car x) (cdr x)) -> (copy x)")
+ (lint-test "(cons (cadar x) (cddar x))" " cons: perhaps (cons (cadar x) (cddar x)) -> (copy (cdar x))")
(lint-test "(sort! x abs)" " sort!: abs is a questionable sort! function")
(lint-test "(sort! x (lambda (a b) (< a b)))" " sort!: perhaps (lambda (a b) (< a b)) -> <")
@@ -84535,96 +86155,349 @@ etc
(lint-test "(-)" " -: - needs at least 1 argument: (-)")
(lint-test "(modulo 3)" " modulo: modulo needs 2 arguments: (modulo 3)")
- (lint-test "(let () (define* (f1 a b) (+ a b)) (f1 :c 1))" " let: f1 keyword argument :c (in (f1 :c 1)) does not match any argument in (a b)")
- (lint-test "(let () (define (f2 a b) (+ a b)) (f2 1 2 3))" " let: f2 has too many arguments: (f2 1 2 3)")
+ (lint-test "(let () (define* (f1 a b) (+ a b)) (f1 :c 1))"
+ " let: perhaps (... (define* (f1 a b) (+ a b)) (f1 :c 1)) -> (... (let ((a :c) (b 1)) (+ a b)))
+ let: f1 keyword argument :c (in (f1 :c 1)) does not match any argument in (a b)")
+ (lint-test "(let () (define (f2 a b) (+ a b)) (f2 1 2 3))"
+ " let: perhaps (... (define (f2 a b) (+ a b)) (f2 1 2 3)) -> (... (let ((a 1) (b 2)) (+ a b)))
+ f2: leaving aside +'s optional args, f2 could be (define f2 +)
+ let: f2 has too many arguments: (f2 1 2 3)")
(lint-test "(let () (define* (f3 a . b) (+ a b)) (f3 1 2 3))" "")
- (lint-test "(let () (define* (f4 (a #f)) a) (f4))" " f4: the default argument value is #f in define* (a #f)")
- (lint-test "(let () (define (f1 a) a) 32)" " let: let variable f1 not used")
- (lint-test "(letrec ((f1 (lambda (a) a))) 32)" " letrec: letrec variable f1 not used")
- (lint-test "(let () (define x 3) 32)" " let: let variable x not used")
- (lint-test "(let ((z 1)) (define x 12) (define (y a) a) 32)" " let: let variables x, y, z not used")
- (lint-test "(let ((z 1)) (define x 12) (define (y a) a) (+ z 32))" " let: let variables x, y not used")
- (lint-test "(let* ((a 1) (b 2) (c (+ a 1))) (* c 2))" " let*: let* variable b not used")
+ (lint-test "(let () (define* (f4 (a #f)) a) (f4))"
+ " let: perhaps (... (define* (f4 (a #f)) a) (f4)) -> (... (let ((a #f)) a))
+ f4: the default argument value is #f in define* (a #f)")
+ (lint-test "(let () (define (f1 a) a) 32)" " let: f1 not used, value: (define (f1 a) a)")
+ (lint-test "(letrec ((f1 (lambda (a) a))) 32)"
+ " letrec: letrec could be let: (letrec ((f1 (lambda (a) a))) 32)
+ letrec: f1 not used, initially: (lambda (a) a) from letrec")
+ (lint-test "(let () (define x 3) 32)" " let: x not used, initially: 3 from define")
+ (lint-test "(let ((z 1)) (define x 12) (define (y a) a) 32)"
+ " let: y not used, value: (define (y a) a)
+ let: x not used, initially: 12 from define
+ let: z not used, initially: 1 from let")
+ (lint-test "(let ((z 1)) (define x 12) (define (y a) a) (+ z 32))"
+ " let: y not used, value: (define (y a) a)
+ let: x not used, initially: 12 from define")
+ (lint-test "(let* ((a 1) (b 2) (c (+ a 1))) (* c 2))"
+ " let*: b not used, initially: 2 from let*
+ let*: perhaps (let* ((a 1) (b 2) (c (+ a 1))) (* c 2)) -> (let* ((a 1) (b 2)) (* (+ a 1) 2))")
(lint-test "(let () (define (f4 a . b) (+ a b)) (f4))" " let: f4 needs 1 argument: (f4)")
(lint-test "(let ((a)) #f)" " let: let variable value is missing? (a)")
(lint-test "(let ((a . 1)) #f)" " let: let binding is an improper list? (a . 1)")
+ (lint-test "(let ((a 1) . b) a)" " let: let variable list is not a proper list? ((a 1) . b)")
(lint-test "(let ((1 2)) #f)" " let: let variable is not a symbol? (1 2)")
(lint-test "(let ((pi 2)) #f)" " let: can't bind a constant: (pi 2)")
- (lint-test "(let ((:a 1)) :a)" " let: let variable is a keyword? (:a 1)")
- (lint-test "(let ((a 2) (a 3)) a)" " let: let variable a is declared twice let: let variable a not used")
+ (lint-test "(let ((:a 1)) :a)" " let: let variable is a keyword? (:a 1) let: perhaps (let ((:a 1)) :a) -> 1")
+ (lint-test "(let ((a 2) (a 3)) a)" " let: let variable a is declared twice let: a not used, initially: 2 from let")
(lint-test "(let (a) a)" " let: let binding is not a list? a")
(lint-test "(let ((a 1) (set! a 2)))" " let: let is messed up: (let ((a 1) (set! a 2)))")
- (lint-test "(let ((a 1)) (set! a 2))" " let: let variable a set, but not used")
- (lint-test "(let ((a 1)) #f)" " let: perhaps (let ((a 1)) #f) -> #f let: let variable a not used")
- (lint-test "(let ((x 1) (y 2)) (+ x y))" " let: perhaps (let ((x 1) (y 2)) (+ x y)) -> 3")
+ (lint-test "(let ((a 1)) (set! a 2))"
+ " let: a set, but not used: (set! a 2)
+ let: perhaps (let ((a 1)) (set! a 2)) -> 2")
+ (lint-test "(let ((a 1) (b (display 2))) (set! a 2))"
+ " let: b not used, initially: (display 2) from let
+ let: a set, but not used: (set! a 2)
+ let: perhaps (let ((a 1) (b (display 2))) (set! a 2)) -> (let ((b (display 2))) 2)")
+ (lint-test "(let ((a 1)) #f)" " let: a not used, initially: 1 from let")
(lint-test "(let :x ((i y)) (x i))" " let: bad let name: :x")
- (lint-test "(let xx () z)" " let: perhaps (let xx () z) -> z let: let variable xx not used")
-
+ (lint-test "(let xx () z)"
+ " let: perhaps (let xx () z) -> z
+ let: xx not used, value: (let xx () z)")
+ (lint-test "(let ((x (log y))) x)" " let: perhaps (let ((x (log y))) x) -> (log y)")
+ (lint-test "(let* ((x (log y))) x)" " let*: let* could be let: (let* ((x (log y))) x) let*: perhaps (let* ((x (log y))) x) -> (log y)")
+ (lint-test "(let* ((y 3) (x (log y))) x)" " let*: perhaps (let* ((y 3) (x (log y))) x) -> (let ((y 3)) (log y))")
+ (lint-test "(let ((y 3) (x (log z))) x)" " let: y not used, initially: 3 from let")
+ (lint-test "(let* ((z 3) (y z) (x (log y))) x)" " let*: perhaps (let* ((z 3) (y z) (x (log y))) x) -> (let* ((z 3) (y z)) (log y))")
+ (lint-test "(let* ((x 1) (x (+ x 1))) x)"
+ " let*: let* variable x is declared twice
+ let*: perhaps (let* ((x 1) (x (+ x 1))) x) -> (let ((x 1)) (+ x 1))")
+ (lint-test "(let* ((x 1) (x (+ y 1))) x)"
+ " let*: let* could be let: (let* ((x 1) (x (+ y 1))) x)
+ let*: let* variable x is declared twice
+ let*: x not used, initially: 1 from let*
+ let*: perhaps (let* ((x 1) (x (+ y 1))) x) -> (let ((x 1)) (+ y 1))")
+ (lint-test "(let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (+ a b c d)))"
+ " let*: perhaps (let* ((c (+ b 3)) (d (+ c 4))) (+ a b c d)) -> (let ((c (+ b 3))) (+ a b c (+ c 4)))
+ let*: perhaps (let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (+ a b c d))) ->
+ (let* ((a 1) (b (+ a 2)) (c (+ b 3)) (d (+ c 4))) (+ a b c d))")
+ (lint-test "(let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (display a) (+ a b c d)))"
+ " let*: perhaps (let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (display a) (+ a... ->
+ (let* ((a 1) (b (+ a 2)) (c (+ b 3)) (d (+ c 4))) (display a) ...)")
+ (lint-test "(let* ((a 1) (b (+ a 1))) b)" " let*: perhaps (let* ((a 1) (b (+ a 1))) b) -> (let ((a 1)) (+ a 1))")
+ (lint-test "(let* ((a 1) (b (+ a 1))) (+ a b))" " let*: perhaps (let* ((a 1) (b (+ a 1))) (+ a b)) -> (let ((a 1)) (+ a (+ a 1)))")
+ (lint-test "(let ((x (assoc y z))) (if x (cdr x)))"
+ " let: perhaps (let ((x (assoc y z))) (if x (cdr x))) -> (cond ((assoc y z) => cdr))")
+ (lint-test "(let ((x (assoc y z))) (if x (cdr x) 32))"
+ " let: perhaps (let ((x (assoc y z))) (if x (cdr x) 32)) -> (cond ((assoc y z) => cdr) (else 32))")
+ (lint-test "(let ((x (f y))) (and x (g x)))" " let: perhaps (let ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))")
+ (lint-test "(let ((x (f y))) (and x (g x)))" " let: perhaps (let ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))")
+ (lint-test "(let ((x (f y))) (or (not x) (g x)))" " let: perhaps (let ((x (f y))) (or (not x) (g x))) -> (cond ((f y) => g) (else #t))")
+ (lint-test "(let* ((x (f y))) (and x (g x)))"
+ " let*: let* could be let: (let* ((x (f y))) (and x (g x)))
+ let*: perhaps (let* ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))")
+ (lint-test "(let* ((x (f y))) (or (not x) (g x)))"
+ " let*: let* could be let: (let* ((x (f y))) (or (not x) (g x)))
+ let*: perhaps (let* ((x (f y))) (or (not x) (g x))) -> (cond ((f y) => g) (else #t))")
+ (lint-test "(let ((x (f y))) (if x (g x) x))"
+ " let: perhaps (let ((x (f y))) (if x (g x) x)) -> (cond ((f y) => g) (else #f))
+ let: perhaps (if x (g x) x) -> (and x (g x))")
+ (lint-test "(let ((x (assoc y z))) (if (pair? x) (g x) x))"
+ " let: perhaps (let ((x (assoc y z))) (if (pair? x) (g x) x)) -> (cond ((assoc y z) => g) (else #f))")
+ (lint-test "(let ((x (assoc y z))) (if (null? x) (g x)))"
+ " let: in (if (null? x) (g x)), x can't be null because assoc in (x (assoc y z)) only returns #f or a pair")
+ (lint-test "(let ((x (g y))) (if x x (g z)))"
+ " let: perhaps (let ((x (g y))) (if x x (g z))) -> (or (g y) (g z))
+ let: perhaps (if x x (g z)) -> (or x (g z))")
+ (lint-test "(let ((x (g y))) (if x #t #f))" " let: perhaps (let ((x (g y))) (if x #t #f)) -> (g y) let: perhaps (if x #t #f) -> x")
+ (lint-test "(let ((x (g y))) (if x (car (cddr x)) z))"
+ " let: perhaps (let ((x (g y))) (if x (car (cddr x)) z)) -> (cond ((g y) => caddr) (else z))
+ let: perhaps (car (cddr x)) -> (caddr x)")
+ (lint-test "(let ((x (f y))) (if (not x) y (g x)))" " let: perhaps (let ((x (f y))) (if (not x) y (g x))) -> (cond ((f y) => g) (else y))")
+ (lint-test "(let ((x (f y))) (cond (x (g x))))"
+ " let: perhaps (let ((x (f y))) (cond (x (g x)))) -> (cond ((f y) => g))
+ let: perhaps use => here: (x (g x)) -> (x => g)")
+ (lint-test "(let ((x (f y))) (cond (x (g x)) (else y)))"
+ " let: perhaps (let ((x (f y))) (cond (x (g x)) (else y))) -> (cond ((f y) => g) (else y))
+ let: perhaps use => here: (x (g x)) -> (x => g)")
+ (lint-test "(let ((x (f y))) (cond (x x) (else y)))"
+ " let: perhaps (let ((x (f y))) (cond (x x) (else y))) -> (or (f y) y)
+ let: no need to repeat the test: (x x) -> (x)")
+ (lint-test "(let ((x (f y))) (cond (x x) (else (g y) y)))"
+ " let: perhaps (let ((x (f y))) (cond (x x) (else (g y) y))) -> (or (f y) (begin (g y) y))
+ let: no need to repeat the test: (x x) -> (x)")
+ (lint-test "(let ((x (f y))) (cond (x (g x)) (y z) (else y)))"
+ " let: perhaps (let ((x (f y))) (cond (x (g x)) (y z) (else y))) -> (cond ((f y) => g) (y z) (else y))
+ let: perhaps use => here: (x (g x)) -> (x => g)")
+ (lint-test "(let ((x (f y))) (cond (x (set-cdr! x y)) (else y)))" "")
+ (lint-test "(let () (let ((a x)) (+ a 1)))"
+ " let: pointless let: (let () (let ((a x)) (+ a 1))) -> (let ((a x)) (+ a 1))
+ let: perhaps (let () (let ((a x)) (+ a 1))) -> (let ((a x)) (+ a 1))
+ let: perhaps (let ((a x)) (+ a 1)) -> (+ x 1)")
+ (lint-test "(let ((a x)) (let () (+ a 1)))"
+ " let: pointless let: (let ((a x)) (let () (+ a 1))) -> (let ((a x)) (+ a 1))
+ let: perhaps (let ((a x)) (let () (+ a 1))) -> (let () (+ x 1))
+ let: pointless let: (let () (+ a 1))
+ let: perhaps (let () (+ a 1)) -> (+ a 1)")
+ (lint-test "(let ((x 32)) (define x 33) x)"
+ " let: define returns the new value, so this could be omitted: x
+ let: let variable x is redefined in the let body. Perhaps use set! instead: (set! x 33)
+ let: x not used, initially: 32 from let")
+ (lint-test "(let ((x 32)) (define (x y) (+ y 33)) (x 1))"
+ " let: perhaps (... (define (x y) (+ y 33)) (x 1)) -> (... (let ((y 1)) (+ y 33)))
+ let: let variable x is declared twice
+ let: x not used, initially: 32 from let")
+ (lint-test "(let ((x (assq 'a y))) (set! z (if x (cadr x) 0)))"
+ " let: perhaps (let ((x (assq 'a y))) (set! z (if x (cadr x) 0))) -> (set! z (cond ((assq 'a y) => cadr) (else 0)))")
+ (lint-test "(let ((x (assq 'a y))) (g (if x (cadr x) 0) y))"
+ " let: perhaps (let ((x (assq 'a y))) (g (if x (cadr x) 0) y)) -> (g (cond ((assq 'a y) => cadr) (else 0)) y)")
+ (lint-test "(let ((x (assq 'a y))) (g (if x (cadr x)) y))"
+ " let: perhaps (let ((x (assq 'a y))) (g (if x (cadr x)) y)) -> (g (cond ((assq 'a y) => cadr)) y)")
+ (lint-test "(let ((x 1) (y 2) (z 3)) (+ x y z))" " let: perhaps (let ((x 1) (y 2) (z 3)) (+ x y z)) -> (+ 1 2 3)")
+ (lint-test "(let ((x 1)) (set! y x))" " let: perhaps (let ((x 1)) (set! y x)) -> (set! y 1)")
+ (lint-test "(let ((x (f 0)) (y (f 1))) (or x y))"
+ " let: perhaps, ignoring short-circuit issues, (let ((x (f 0)) (y (f 1))) (or x y)) -> (or (f 0) (f 1))")
+ (lint-test "(let ((x (undo-edit))) (set! y (or y x)))"
+ " let: perhaps, ignoring short-circuit issues, (let ((x (undo-edit))) (set! y (or y x))) -> (set! y (or y (undo-edit)))")
+
+ (lint-test "(let ((x 1)) (set! x 2) (+ x 1))"
+ " let: perhaps (let ((x 1)) (set! x 2) (+ x 1)) -> (let ((x 2)) (+ x 1))")
+ (lint-test "(let ((y 3) (x 1)) (set! x 2) (+ x y))"
+ " let: perhaps (let ((y 3) (x 1)) (set! x 2) (+ x y)) -> (let ((y 3) (x 2)) (+ x y))")
+ (lint-test "(let ((y 3) (x 1)) (set! x 2) (display x) (+ x y))"
+ " let: perhaps (let ((y 3) (x 1)) (set! x 2) (display x) (+ x y)) -> (let ((y 3) (x 2)) (display x) ...)")
+
+ (lint-test "(let ((x (f y))) (if x (g x) (set! x 3)))" "") ; too complicated to deal with this
+ (lint-test "(let* ((x (f y))) (if x (g x) (set! x 3)))" " let*: let* could be let: (let* ((x (f y))) (if x (g x) (set! x 3)))")
+ (lint-test "(let* ((z 1) (x (< z 2))) (if x (f x)))"
+ " let*: perhaps (let* ((z 1) (x (< z 2))) (if x (f x))) -> (let ((z 1)) (cond ((< z 2) => f)))")
+ (lint-test "(let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x)))"
+ " let*: perhaps (let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x))) -> (let* ((z 1) (y (+ z 2))) (cond ((< y 3) => f)))")
+ (lint-test "(let f0 ((i 1)) (if (> i 0) (f0 #() (- i 1))))" " f0: f0 has too many arguments: (f0 #() (- i 1))")
+ (lint-test "(letrec ((f0 (lambda (i) (if (> i 0) (f0 #() (- i 1)))))) (f0 1))"
+ " letrec: perhaps (letrec ((f0 (lambda (i) (if (> i 0) (f0 #() (- i 1)))))) (f0 1)) -> (let f0 ((i 1)) (if (> i 0) (f0 #() (- i 1))))")
+ (lint-test "(letrec ((f0 (lambda () (if (> i 0) (f0))))) (f0))"
+ " letrec: perhaps (letrec ((f0 (lambda () (if (> i 0) (f0))))) (f0)) -> (let f0 () (if (> i 0) (f0)))")
+
+ (lint-test "(let () (error 'oops \"an error\") #t)" " let: (error 'oops \"an error\") make this pointless: #t")
+ (lint-test "(let () (error 'oops \"an error\") (display \"oops\") #t)"
+ " let: (error 'oops \"an error\") makes the rest of the body unreachable: (... (display \"oops\") ...)")
+ (lint-test "(let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))))"
+ " let: perhaps (let ((d 4)) (+ a b c d)) -> (+ a b c 4)
+ let: perhaps (let ((c 3)) (let ((d 4)) (+ a b c d))) -> (let ((c 3) (d 4)) (+ a b c d))
+ let: perhaps (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))) -> (let ((b 2) (c 3) (d 4)) (+ a b c d))
+ let: perhaps (let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d))))) -> (let ((a 1) (b 2) (c 3) (d 4)) (+ a b c d))")
+ (lint-test "(let ((a 1)) (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))))"
+ " let: perhaps (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((b 2) (c 3) (d 4)) (display a) ...)
+ let: perhaps (let ((a 1)) (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d)))) -> (let ((a 1) (b 2) (c 3) (d 4)) (display a) ...)")
+ (lint-test "(let ((a 1) (b 2)) (let ((c 3) (d 4)) (display a) (+ b c d)))"
+ " let: perhaps (let ((a 1) (b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((a 1) (b 2) (c 3) (d 4)) (display a) ...)")
+ (lint-test "(let ((x 1) (y x)) (+ x y))"
+ " let: x in (y x) does not appear to be defined in the calling environment
+ let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)")
+ (lint-test "(let ((x 3)) (+ x (let ((x 1) (y x)) (+ x y))))"
+ " let: x in (y x) refers to the caller's x, not the let variable
+ let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)")
+ (lint-test "(let ((x 0)) (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (display x) (if (zero? x) (+ 1 (f52 x))))"
+ " let: perhaps (... (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (display x) (if... ->
+ (... (display x) (if (zero? x) (+ 1 (let* f52 ((a x)) (if (zero? a) x (f52 (- a 1)))))))
+ let: x is 0, so (zero? x) is #t")
+ (lint-test "(let ((x 0)) (define (f52) (if (zero? a) x (f52))) (f52))"
+ " let: perhaps (... (define (f52) (if (zero? a) x (f52))) (f52)) -> (... (let f52 () (if (zero? a) x (f52))))
+ x is used only in f52")
+ (lint-test "(let ((x 0)) (define (f52 x) (if (zero? a) x (f52 x))) (f52 x))"
+ " let: perhaps (... (define (f52 x) (if (zero? a) x (f52 x))) (f52 x)) -> (... (let f52 ((x x)) (if (zero? a) x (f52 x))))")
+ (lint-test "(let ((x 0)) (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (if (zero? x) (+ 1 (f52 x))))"
+ " let: perhaps (... (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (if (zero? x) (+... ->
+ (... (if (zero? x) (+ 1 (let* f52 ((a x)) (if (zero? a) x (f52 (- a 1)))))))
+ let: x is 0, so (zero? x) is #t")
+ (lint-test "(define (f x) (let ((y 2)) (set! x (+ x y)) (set! y (+ y 1)) (set! x (+ x 1)) (display x)))"
+ " f: (set! y (+ y 1)) in (let ((y 2)) (set! x (+ x y)) (set! y (+ y 1)) (set! x (+ x 1)) (display x)) could be omitted
+ f: this let could be tightened:
+ (let ((y 2)) (set! x (+ x y)) (set! y (+ y 1)) (set! x (+ x 1)) (display x)) ->
+ (let ((y 2))
+ (set! x (+ x y))
+ (set! y (+ y 1)))
+ (set! x (+ x 1)) ...")
+
+ (lint-test "(define (f a) (let ((x 1) (y 2) (z (vector 3))) (vector-set! z 0 (+ x 1)) (display y) (newline) (+ y (vector-ref z 0))))"
+ " f: the scope of x could be reduced:
+ (let ((x 1) (y 2) (z (vector 3))) (vector-set! z 0 (+ x 1)) (display y)... ->
+ (let ((y 2)
+ (z (vector 3)))
+ (let ((x 1))
+ (vector-set! z 0 (+ x 1)))
+ (display y)
+ ...)")
+
+ (lint-test "(define (f a) (let ((x 1) (y 2) (z (vector 3 4))) (vector-set! z 0 (+ x 1)) (display (vector-ref z x)) (set! y (+ y 1)) (newline) (+ y 1)))"
+ " f: the scope of x, z could be reduced:
+ (let ((x 1) (y 2) (z (vector 3 4))) (vector-set! z 0 (+ x 1)) (display... ->
+ (let ((y 2))
+ (let ((x 1)
+ (z (vector 3 4)))
+ (vector-set! z 0 (+ x 1))
+ (display (vector-ref z x)))
+ (set! y (+ y 1))
+ ...)")
+
+ (lint-test "(define (f a) (let* ((x 1) (y (+ x 2)) (z (vector 3))) (vector-set! z 0 (+ x 1)) (display y) (newline) (+ y x)))"
+ " f: the scope of z could be reduced:
+ (let* ((x 1) (y (+ x 2)) (z (vector 3))) (vector-set! z 0 (+ x 1))... ->
+ (let* ((x 1)
+ (y (+ x 2)))
+ (let ((z (vector 3)))
+ (vector-set! z 0 (+ x 1)))
+ (display y)
+ ...)")
+
+ (lint-test "(eq? x '())" " eq?: perhaps (eq? x '()) -> (null? x) eq?: quote is not needed here: '()")
+ (lint-test "(equal? x '#())" " equal?: quote is not needed here: '#()")
+ (lint-test "(equal? x '\"\")" " equal?: quote is not needed here: '\"\"")
+ (lint-test "(eq? x '#<unspecified>)" " eq?: quote is not needed here: '#<unspecified>")
+ (lint-test "(eq? x '#t)" " eq?: quote is not needed here: '#t")
+ (lint-test "(eq? x '#f)" " eq?: perhaps (eq? x '#f) -> (not x) eq?: quote is not needed here: '#f")
+ (lint-test "(equal? x '(1))" "")
+ (lint-test "(eqv? x '3)" " eqv?: quote is not needed here: '3")
+ (lint-test "(eq? x 'x)" "")
(lint-test "(eq? x 1.5)" " eq?: eq? should be eqv? in (eq? x 1.5)")
(lint-test "(eq? 3 x)" " eq?: eq? should be eqv? in (eq? 3 x)")
(lint-test "(eq? x (not x))" " eq?: this looks odd: (eq? x (not x))")
- (lint-test "(eq? #(0) #(0))" " eq?: this looks odd: (eq? #(0) #(0)) eq?: eq? should be equal? in (eq? #(0) #(0))")
- (lint-test "(eq? #() ())" " eq?: eq? should be equal? in (eq? #() ())")
+ (lint-test "(eq? #(0) #(0))"
+ " eq?: this looks odd: (eq? #(0) #(0)) eq?: perhaps (eq? #(0) #(0)) -> #f eq?: eq? should be equal? in (eq? #(0) #(0))")
+ (lint-test "(eq? #() ())" " eq?: perhaps (eq? #() ()) -> #f eq?: eq? should be equal? in (eq? #() ())")
+ (lint-test "(eqv? x #())" " eqv?: eqv? should be equal? in (eqv? x #())")
+ (lint-test "(eq? x \"\")" " eq?: eq? should be equal? in (eq? x \"\")")
+ (lint-test "(eq? #() (vector))" " eq?: eq? should be equal? in (eq? #() (vector))")
+ (lint-test "(eq? () (list))" " eq?: perhaps (eq? () (list)) -> #t")
+ (lint-test "(eqv? x (string))" " eqv?: eqv? should be equal? in (eqv? x (string)) eqv?: (string) could be \"\"")
(lint-test "(eq? (symbol->string x) z)" " eq?: eq? should be equal? in (eq? (symbol->string x) z)")
(lint-test "(eq? (symbol? x) #t)" " eq?: perhaps (eq? (symbol? x) #t) -> (symbol? x)")
(lint-test "(eq? (symbol? x) #f)" " eq?: perhaps (eq? (symbol? x) #f) -> (not (symbol? x))")
- (lint-test "(eq? x '())" " eq?: perhaps (eq? x '()) -> (null? x) eq?: quote is not needed here: '()")
- (lint-test "(eq? x '#\\a)" " eq?: eq? should be eqv? in (eq? x '#\\a)")
+ (lint-test "(eq? x '())" " eq?: perhaps (eq? x '()) -> (null? x) eq?: quote is not needed here: '()")
+ (lint-test "(eq? '() x)" " eq?: perhaps (eq? '() x) -> (null? x) eq?: quote is not needed here: '()")
+ (lint-test "(eq? x '#\\a)" " eq?: eq? should be eqv? in (eq? x '#\\a) eq?: quote is not needed here: '#\\a")
(lint-test "(eqv? x ())" " eqv?: eqv? could be null?: (eqv? x ()) -> (null? x)")
(lint-test "(eqv? x '())" " eqv?: eqv? could be null?: (eqv? x '()) -> (null? x) eqv?: quote is not needed here: '()")
(lint-test "(eqv? x #(0))" " eqv?: eqv? should be equal? in (eqv? x #(0))")
(lint-test "(eqv? x 'a)" " eqv?: eqv? could be eq? in (eqv? x 'a)")
(lint-test "(eqv? x #f)" " eqv?: eqv? could be not: (eqv? x #f) -> (not x)")
(lint-test "(equal? x 'a)" " equal?: equal? could be eq? in (equal? x 'a)")
- (lint-test "(equal? x (integer->char 96))" " equal?: equal? could be eqv? in (equal? x (integer->char 96))")
+ (lint-test "(equal? x (integer->char 96))" " equal?: equal? could be eqv? in (equal? x (integer->char 96)) equal?: perhaps (integer->char 96) -> #\\`")
(lint-test "(equal? x #f)" " equal?: equal? could be not: (equal? x #f) -> (not x)")
+ (lint-test "(equal? #f x)" " equal?: equal? could be not: (equal? #f x) -> (not x)")
(lint-test "(equal? x ())" " equal?: equal? could be null?: (equal? x ()) -> (null? x)")
(lint-test "(equal? x '())" " equal?: equal? could be null?: (equal? x '()) -> (null? x) equal?: quote is not needed here: '()")
(lint-test "(equal? (expt x y) z)" " equal?: equal? could be eqv? in (equal? (expt x y) z)")
(lint-test "(morally-equal? x 'a)" " morally-equal?: morally-equal? could be eq? in (morally-equal? x 'a)")
- (lint-test "(morally-equal? x 0)" " morally-equal?: morally-equal? could be eqv? in (morally-equal? x 0)")
+ (lint-test "(morally-equal? x 0)" "")
(lint-test "(morally-equal? x 0.0)" "")
+ (lint-test "(equal? (floor x) (round y))" " equal?: equal? could be eqv? or = in (equal? (floor x) (round y))")
+ (lint-test "(equal? (string x) (string-append y z))" " equal?: equal? could be string=? in (equal? (string x) (string-append y z))")
+ (lint-test "(eqv? (integer->char x) #\\null)" " eqv?: eqv? could be char=? in (eqv? (integer->char x) #\\null)")
+ (lint-test "(eq? #\\space (string-ref x 0))" " eq?: eq? should be eqv? or char=? in (eq? #\\space (string-ref x 0))")
+ (lint-test "(eq? (sin x) (cos y))" " eq?: eq? should be eqv? or = in (eq? (sin x) (cos y))")
+ (lint-test "(eqv? #\\Space x)" " reader[0]: unknown # object: #\\Space perhaps use #\\space instead")
+ (lint-test "(equal? (length x) (length y))" " equal?: equal? could be eqv? in (equal? (length x) (length y))")
+ (lint-test "(equal? (string->number x) (string->number y))" " equal?: equal? could be eqv? in (equal? (string->number x) (string->number y))")
+
+ (lint-test "(char-ci=? x #\\return)" " char-ci=?: char-ci=? could be char=? here: (char-ci=? x #\\return)")
(lint-test "(map abs '(1 2) '(3 4))" " map: map has too many arguments in: (map abs '(1 2) '(3 4))")
(lint-test "(map (lambda (a b) a) '(1 2))" " map: map has too few arguments in: (map (lambda (a b) a) '(1 2))")
(lint-test "(map (lambda (a) (abs a)) '(1 2 3))" " map: perhaps (lambda (a) (abs a)) -> abs")
(lint-test "(map abs (vector->list #(1 2)))" " map: (vector->list #(1 2)) could be simplified to: #(1 2) ; (map accepts non-list sequences)")
- (lint-test "(begin (map g123 x) x)" " begin: map could be for-each: (map g123 x)")
+ (lint-test "(begin (map g123 x) x)" " begin: map could be for-each: (for-each g123 x)")
(lint-test "(map log x x)" "")
- (lint-test "(catch #(0) (lambda () #f) (lambda a a))" " catch: catch tag #(0) is unreliable (catch uses eq? to match tags)")
- (lint-test "(catch 'hi x y)" "")
- (lint-test "(car #(0))" " car: car's argument should be a pair?: #(0): (car #(0))")
- (lint-test "(vector->list 1.4)" " vector->list: vector->list's argument should be a vector?: 1.4: (vector->list 1.4)")
- (lint-test "(vector-set! #(0 1) 0 2)" " vector-set!: perhaps (vector-set! #(0 1) 0 2) -> 2")
-
- (lint-test "(defmacro hi ())" " defmacro: defmacro declaration is messed up: (defmacro hi ())")
- (lint-test "(defmacro hi (a b a) a)" " defmacro: defmacro parameter is repeated: (a b a)")
- (lint-test "(define)" " define: (define) makes no sense")
- (lint-test "(define a)" " define: (define a) has no value?")
- (lint-test "(define a . b)" " define: (define a . b) makes no sense")
- (lint-test "(define a b c)" " define: (define a b c) has too many values?")
- (lint-test "(define a a)" " define: this define is either not needed, or is an error: (define a a)")
- (lint-test "(define #(0) 2)" " define: strange form: (define #(0) 2)")
- (lint-test "(define (f1 a) (abs a))" " f1: f1 could be (define f1 abs)")
- (lint-test "(define (f1 a b) \"a docstring\" (log a b))" " f1: f1 could be (define f1 log)")
- (lint-test "(lambda ())" " lambda: lambda is messed up in (lambda ())")
- (lint-test "(lambda (a b a) a)" " lambda: lambda parameter is repeated: (a b a)")
- (lint-test "((lambda () 32) 0)" " (lambda () 32): lambda has too many arguments: ((lambda () 32) 0)")
- (lint-test "((lambda (a b) (+ a b)) 1)" " (lambda (a b) (+ a b)): lambda has too few arguments: ((lambda (a b) (+ a b)) 1) (lambda (a b) (+ a b)): perhaps (lambda (a b) (+ a b)) -> +")
- (lint-test "(lambda* (:key a :optional b :rest c :allow-other-keys) a)"
- " lambda*: :optional and key are no longer accepted: (:key a :optional b :rest c :allow-other-keys)")
- (lint-test "(lambda* (a :rest) a)" " lambda*: :rest parameter needs a name: (a :rest)")
- (lint-test "(lambda* (a :allow-other-keys b) a)" " lambda*: :allow-other-keys should be at the end of the parameter list:(a :allow-other-keys b)")
- (lint-test "(lambda (a :b c) a)" " lambda: lambda arglist can't handle keywords (use lambda*)")
- (lint-test "(lambda (a b) (>= b a))" " lambda: perhaps (lambda (a b) (>= b a)) -> <=")
- (lint-test "(lambda (a b c) (/ a b c))" " lambda: perhaps (lambda (a b c) (/ a b c)) -> /")
+ (lint-test "(map f (map g h))" " map: perhaps (map f (map g h)) -> (map (lambda (_1_) (f (g _1_))) h)")
+ (lint-test "(for-each x (map g h))" " for-each: perhaps (for-each x (map g h)) -> (for-each (lambda (_1_) (x (g _1_))) h)")
+ (lint-test "(map f (map (lambda (x) (g x y)) h))" " map: perhaps (map f (map (lambda (x) (g x y)) h)) -> (map (lambda (_1_) (f (g _1_ y))) h)")
+ (lint-test "(map (lambda (x) (f x y)) (map g h))" " map: perhaps (map (lambda (x) (f x y)) (map g h)) -> (map (lambda (_1_) (f (g _1_) y)) h)")
+ (lint-test "(map (lambda (x) (f x y)) (map (lambda (y) (g z y)) h))"
+ " map: perhaps (map (lambda (x) (f x y)) (map (lambda (y) (g z y)) h)) -> (map (lambda (_1_) (f (g z _1_) y)) h)")
+ (lint-test "(map f (map (lambda (x) (g 'x x)) h))" " map: perhaps (map f (map (lambda (x) (g 'x x)) h)) -> (map (lambda (_1_) (f (g 'x _1_))) h)")
+ (lint-test "(map (lambda (x) (display 1) (f x)) (map g h))"
+ " map: perhaps (map (lambda (x) (display 1) (f x)) (map g h)) -> (map (lambda (_1_) (display 1) (f (g _1_))) h)")
+ (lint-test "(map (lambda (x) (display 1) (f x)) (map (lambda (y) (+ y 1)) h))"
+ " map: perhaps (map (lambda (x) (display 1) (f x)) (map (lambda (y) (+ y 1)) h)) -> (map (lambda (_1_) (display 1) (f (+ _1_ 1))) h)")
+ (lint-test "(map (lambda (x) x) lst)" " map: perhaps (map (lambda (x) x) lst) -> lst")
+ (lint-test "(for-each (lambda (x) (+ (abs x) 1)) lst)" " for-each: pointless for-each: (for-each (lambda (x) (+ (abs x) 1)) lst)")
+ (lint-test "(for-each x #\\a)" " for-each: in (for-each x #\\a), for-each's argument 2 should be a sequence, but #\\a is a char?")
+ (lint-test "(map f (cdr (vector->list v)))"
+ " map: map accepts vector arguments, so perhaps (cdr (vector->list v)) -> (make-shared-vector v (- (length v) 1) 1)")
+ (lint-test "(for-each f (list-tail (string->list str) x))"
+ " for-each: for-each accepts string arguments, so perhaps (list-tail (string->list str) x) -> (substring str x)")
+ (lint-test "(map char-downcase (string->list str))"
+ " map: (string->list str) could be simplified to: str ; (map accepts non-list sequences)
+ map: perhaps (map char-downcase (string->list str)) -> (string->list (string-downcase str))")
+ (lint-test "(for-each display (list a))"
+ " for-each: perhaps (for-each display (list a)) -> (display a)
+ for-each: perhaps (for-each display (list a)) -> (format () \"~A\" a)")
- (lint-test "(+ . 1)" " +: unexpected dot: (+ . 1)")
- (lint-test "(length (a . b))" " length: missing quote? (a . b) in (length (a . b))")
- (lint-test "(length ,a)" " length: stray comma? (unquote a) in (length (unquote a))")
+ (lint-test "(catch #(0) (lambda () #f) (lambda a a))" " catch: catch tag #(0) is unreliable (catch uses eq? to match tags)")
+ (lint-test "(catch 'hi x y)" "")
+
+ (lint-test "(car #(0))" " car: in (car #(0)), car's argument should be a pair, but #(0) is a vector?")
+ (lint-test "(vector->list 1.4)" " vector->list: in (vector->list 1.4), vector->list's argument should be a vector, but 1.4 is real?")
+ (lint-test "(vector-set! #(0 1) 0 2)" " vector-set!: #(0 1) is a constant that is discarded; perhaps (vector-set! #(0 1) 0 2) -> 2")
+ (lint-test "(list-set! (list 0 1) 0 2)" " list-set!: (list 0 1) is simply discarded; perhaps (list-set! (list 0 1) 0 2) -> 2")
+ (lint-test "(string-set! (make-string 3) 0 #\\a)"
+ " string-set!: (make-string 3) is simply discarded; perhaps (string-set! (make-string 3) 0 #\\a) -> #\\a")
+ (lint-test "(let ((x '(0 1))) (list-set! x 0 3.1))"
+ "let: perhaps (let ((x '(0 1))) (list-set! x 0 3.1)) -> (list-set! '(0 1) 0 3.1)
+ let: x's value, '(0 1), is a literal constant, so this set! is trouble: (list-set! x 0 3.1)")
+ (lint-test "(let ((c #(0 1))) (vector-set! c 0 1))"
+ "let: perhaps (let ((c #(0 1))) (vector-set! c 0 1)) -> (vector-set! #(0 1) 0 1)
+ let: c's value, #(0 1), is a literal constant, so this set! is trouble: (vector-set! c 0 1)")
+ (lint-test "(let ((x (vector 0 1))) (vector-set! x 0 1))"
+ " let: perhaps (let ((x (vector 0 1))) (vector-set! x 0 1)) -> (vector-set! (vector 0 1) 0 1)")
+ (lint-test "(let ((x (vector 0 1))) (string-set! x 0 #\\a))"
+ " let: perhaps (let ((x (vector 0 1))) (string-set! x 0 #\\a)) -> (string-set! (vector 0 1) 0 #\\a)
+ let: x is a vector, but string-set! in (string-set! x 0 #\\a) wants a string?")
+
+ (lint-test "(+ . 1)" " +: unexpected dot: (+ . 1)")
+ (lint-test "(length (a . b))" " length: missing quote? (a . b) in (length (a . b))")
+ (lint-test "(length ,a)" " length: stray comma? (unquote a) in (length (unquote a))")
- (lint-test "(let () (define (f1 a) a) (f1 2 3))" " let: f1 has too many arguments: (f1 2 3)")
- (lint-test "(let () (define-macro (f1 a) a) (f1 2 3))" " let: f1 has too many arguments: (f1 2 3)")
(lint-test "(set! a b c)" " set!: set! has too many arguments: (set! a b c)")
(lint-test "(set! a)" " set!: set! has too few arguments: (set! a)")
(lint-test "(set! (vector-ref v 0) 3)" " set!: vector-ref as target of set! (set! (vector-ref v 0) 3)")
@@ -84633,116 +86506,287 @@ etc
(lint-test "(set! a a)" " set!: pointless set! (set! a a)")
(lint-test "(begin (set! x (cons 1 z)) (set! x (cons 2 x)))" " begin: perhaps (set! x (cons 1 z)) (set! x (cons 2 x)) -> (set! x (cons 2 (cons 1 z)))")
(lint-test "(begin (set! x 0) (set! x 1))" " begin: this could be omitted: (set! x 0)")
+ (lint-test "(begin (set! x y) (set! x (+ x 1)))" " begin: perhaps (set! x y) (set! x (+ x 1)) -> (set! x (+ y 1))")
(lint-test "(quote 3)" " quote: quote is not needed here: '3")
(lint-test "(quote . 3)" " quote: stray dot in quote's arguments? (quote . 3)")
(lint-test "(quote 3 4)" " quote: quote has too many arguments: (quote 3 4)")
(lint-test "'#(0)" " quote: quote is not needed here: '#(0)")
- (lint-test "(cond . 1)" " cond: cond is messed up: (cond . 1)")
- (lint-test "(cond 1)" " cond: cond clause is messed up: 1")
- (lint-test "(cond ((< 3 1) 2))" " cond: cond test is never true: (cond ((< 3 1) 2)) cond: cond test is always false: ((< 3 1) 2)")
- (lint-test "(cond (else 2) (x 3))" " cond: cond else clause is not the last: (cond (else 2) (x 3))")
- (lint-test "(cond (x => abs))" "")
- (lint-test "(cond (x =>))" " cond: cond => target is messed up: (x =>)")
- (lint-test "(cond (x #f) (#t #t))" " cond: perhaps (cond (x #f) (#t #t)) -> (not x)")
- (lint-test "(cond (x #t) (else #f))" " cond: perhaps (cond (x #t) (else #f)) -> x")
- (lint-test "(cond ((= x 1) 2) (else 2))" " cond: perhaps (cond ((= x 1) 2) (else 2)) -> 2")
- (lint-test "(cond ((and (display x) x) 32) (#t 32))" "")
- (lint-test "(cond (x y) (z 32) (else 32))" " cond: this clause could be omitted: (z 32)")
- (lint-test "(cond ((= x 1) (display \"a\") 32) (#t (display \"a\") 32))"
- " cond: perhaps (cond ((= x 1) (display \"a\") 32) (#t (display \"a\") 32)) -> (begin (display \"a\") 32)")
- (lint-test "(cond ((= x 1) 32))" "")
- (lint-test "(cond ((and (display 32) (= x 1)) 1) (#t 1))" "")
- (lint-test "(cond ((< x 1) 2) (else (cond ((< y 3) 2) (#t 4))))"
- " cond: else clause cond could be folded into the outer cond: (else (cond ((< y 3) 2) (#t 4)))")
- (lint-test "(cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5))"
- " cond: cond test is never true: (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) cond: cond test repeated: ((< x 2) 5) cond: cond test is always false: ((< x 2) 5)")
- (lint-test "(cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2))"
- " cond: perhaps (cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2)) -> (cond ((or (< x 1) (> x 1)) (+ x 1)) (#t 2))")
- (lint-test "(cond ((= x 3) 4) ((= x 2) 4) ((= x 1) 4) (else 5))"
- " cond: perhaps (cond ((= x 3) 4) ((= x 2) 4) ((= x 1) 4) (else 5)) -> (cond ((memv x '(3 2 1)) 4) (else 5))")
- (lint-test "(cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4) (else 5))"
- " cond: perhaps (cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4) (else 5)) -> (cond ((= x 3) 3) ((memv x '(2 1)) 4) (else 5))")
- (lint-test "(cond (a) (b) (c))" " cond: perhaps (cond (a) (b) (c)) -> (cond ((or a b c)))")
- (lint-test "(cond ((= x 0) x) ((= x 1) (= x 1)))" " cond: no need to repeat the test: ((= x 1) (= x 1)) -> ((= x 1))")
- (lint-test "(cond (x => expt))" " cond: => target (expt) may be unhappy: (x => expt)")
- (lint-test "(cond (x (abs x)))" " cond: perhaps use => here: (x (abs x)) -> (x => abs)")
-
- (lint-test "(cond (x (let ((z w)) (+ x z)) y) (else 2))" " cond: this could be omitted: (let ((z w)) (+ x z))")
- (lint-test "(cond (x (if x y z) (+ x 1)) (z 2))" " cond: this could be omitted: (if x y z)")
-
(lint-test "(let () (when a (+ x 1)) y)" " let: this could be omitted: (when a (+ x 1))")
(lint-test "(let () (unless a (+ x 1)) y)" " let: this could be omitted: (unless a (+ x 1))")
(lint-test "(let () (cond ((< x y) 3) ((< y z) 4)) (+ x 1))" " let: this could be omitted: (cond ((< x y) 3) ((< y z) 4))")
- (lint-test "(let () (case x ((0) 1) (else 2)) x)" " let: this could be omitted: (case x ((0) 1) (else 2))")
- (lint-test "(begin (let ((a (+ x 1)) (b 2)) (+ a b)) 32)" " begin: this could be omitted: (let ((a (+ x 1)) (b 2)) (+ a b))")
+ (lint-test "(let () (case x ((0) 1) (else 2)) x)"
+ " let: this could be omitted: (case x ((0) 1) (else 2))
+ let: perhaps (case x ((0) 1) (else 2)) -> (if (eqv? x 0) 1 2)")
+ (lint-test "(begin (let ((a (+ x 1)) (b 2)) (+ a b)) 32)"
+ " begin: this could be omitted: (let ((a (+ x 1)) (b 2)) (+ a b))
+ begin: perhaps (let ((a (+ x 1)) (b 2)) (+ a b)) -> (+ (+ x 1) 2)")
(lint-test "(begin (if x y z) a)" " begin: this could be omitted: (if x y z)")
(lint-test "(lambda (a) (if x y z) a)" " lambda: this could be omitted: (if x y z)")
- (lint-test "(lambda (a) (case x ((0) 1) (else x)) a)" " lambda: this could be omitted: (case x ((0) 1) (else x))")
+ (lint-test "(lambda (a) (case x ((0) 1) (else x)) a)"
+ " lambda: this could be omitted: (case x ((0) 1) (else x))
+ lambda: perhaps (case x ((0) 1) (else x)) -> (if (eqv? x 0) 1 x)")
(lint-test "(let () (do ((i 0 (+ i 1))) ((= i 1))) x)"
" let: this could be omitted: (do ((i 0 (+ i 1))) ((= i 1))) let: this do-loop could be replaced by (): (do ((i 0 (+ i 1))) ((= i 1)))")
+ (lint-test "(let () (write-byte i) (write-byte i) (write-byte i) (write-byte i) (write-byte i) (newline))"
+ " let: perhaps (write-byte i)... -> (do ((_1_ 0 (+ _1_ 1))) ((= _1_ 5)) (write-byte i))")
+ (lint-test "(let () (write-byte 0) (write-byte 0) (write-byte 0) (write-byte 0) (write-byte 0))"
+ " let: perhaps (write-byte 0)... -> (do ((i 0 (+ i 1))) ((= i 5)) (write-byte 0))")
+ (lint-test "(let () (write-byte 0) (write-byte 1) (write-byte 2) (write-byte 3) (write-byte 4))"
+ " let: perhaps (write-byte 0)... -> (for-each write-byte '(0 1 2 3 4))")
+ (lint-test "(let () (write-byte 0) (write-byte 1) (write-byte 2) (write-byte 3) (write-byte (* x 2)))"
+ " let: perhaps (write-byte 0)... -> (for-each write-byte (vector 0 1 2 3 (* x 2)))")
+ (lint-test "(let () (writ 0) (writ 1) (writ 2) (writ 3) (writ (* x 2)))"
+ " let: assuming writ is not a macro, perhaps (... (writ 0) ...) -> (for-each writ (vector 0 1 2 3 (* x 2)))")
+ (lint-test "(let () (writ 0) (writ 1) (writ) (writ 3) (writ (* x 2)))" "")
+ (lint-test "(let () (writ 0 x) (writ 1 x) (writ 2 x) (writ 3 x) (writ 4 x))"
+ " let: perhaps (writ 0 x)... -> (for-each (lambda (arg) (writ arg x)) '(0 1 2 3 4))")
+ (lint-test "(let () (writ x 0) (writ x 1) (writ x 2) (writ x 3) (writ x (* x 2)))"
+ " let: assuming writ is not a macro, perhaps (... (writ x 0) ...) -> (for-each (lambda (arg) (writ x arg)) (vector 0 1 2 3 (* x 2)))")
+ (lint-test "(let () (writ x 0) (writ x 1) (writ y 2) (writ x 3) (writ x (* x 2)))" "")
+ (lint-test "(let () (writ (display x) 0) (writ (display x) 1) (writ (display x) 2) (writ (display x)))" "")
(lint-test "(case 3)" " case: case is messed up: (case 3)")
- (lint-test "(case 3 ((0) #t))" " case: case selector is a constant: (case 3 ((0) #t))")
- (lint-test "(case (list 1) ((0) #t))" " case: case selector may not work with eqv: (list 1) case: case key 0 in ((0) #t) is pointless")
+ (lint-test "(case 3 ((0) #t))"
+ " case: perhaps (case 3 ((0) #t)) -> (if (eqv? 3 0) #t)
+ case: case selector is a constant: (case 3 ((0) #t))")
+ (lint-test "(case (list 1) ((0) #t))"
+ " case: perhaps (case (list 1) ((0) #t)) -> (if (eqv? (list 1) 0) #t)
+ case: case selector may not work with eqv: (list 1)
+ case: case key 0 in ((0) #t) is pointless")
(lint-test "(case x (0))" " case: clause result is missing: (0) case: bad case key 0 in (0)")
(lint-test "(case x ((0)))" " case: clause result is missing: ((0))")
(lint-test "(case x ((0) 1) ((1) 2) ((3 0) 4))" " case: repeated case key 0 in ((3 0) 4)")
(lint-test "(case x ((0) 1) ((1) 2) ((3 . 0) 4))" " case: stray dot in case case key list: ((3 . 0) 4)")
- (lint-test "(case x ((#(0)) 2))" " case: case key #(0) in ((#(0)) 2) is unlikely to work (case uses eqv?)")
+ (lint-test "(case x ((#(0)) 2))"
+ " case: perhaps (case x ((#(0)) 2)) -> (if (eqv? x #(0)) 2)
+ case: case key #(0) in ((#(0)) 2) is unlikely to work (case uses eqv?)")
(lint-test "(case x (else 2) ((0) 1))" " case: case else clause is not the last: ((else 2) ((0) 1))")
(lint-test "(case x ((0) 32) (else 32))" " case: perhaps (case x ((0) 32) (else 32)) -> 32")
(lint-test "(case (string->symbol x) ((a) 1) ((2 3) 3))" " case: case key 2 in ((2 3) 3) is pointless case: case key 3 in ((2 3) 3) is pointless")
- (lint-test "(case c ((a) b) (else (begin (display d) e)))" " case: redundant begin: (begin (display d) e)")
-
- (lint-test "(case x ((0) 32) ((1) 32))" " case: perhaps (case x ((0) 32) ((1) 32)) -> (case x ((0 1) 32))")
- (lint-test "(case x ((0) 32) (else (case x ((1) 32))))" " case: perhaps (case x ((0) 32) (else (case x ((1) 32)))) -> (case x ((0 1) 32))")
- (lint-test "(case x ((0) 32) (else (case x ((1) 32)) x))" " case: this could be omitted: (case x ((1) 32))")
+ (lint-test "(case c ((a) b) (else (begin (display d) e)))"
+ " case: perhaps (case c ((a) b) (else (begin (display d) e))) -> (if (eq? c 'a) b (begin (display d) e))
+ case: redundant begin: (begin (display d) e)")
+ (lint-test "(case x ((0) 32) ((1) 32))" " case: perhaps merge keys (1) with (0): (case x ((0) 32) ((1) 32)) -> (case x ((0 1) 32))")
+ (lint-test "(case x ((0) 32) (else (case x ((1) 32))))"
+ " case: perhaps (case x ((0) 32) (else (case x ((1) 32)))) -> (if (eqv? x 0) 32 (case x ((1) 32)))
+ case: perhaps (case x ((1) 32)) -> (if (eqv? x 1) 32)
+ case: perhaps merge keys (1) with (0): (case x ((0) 32) (else (case x ((1) 32)))) -> (case x ((0 1) 32))")
+ (lint-test "(case x ((0) 32) (else (case x ((1) 32)) x))"
+ " case: this could be omitted: (case x ((1) 32))
+ case: perhaps (case x ((1) 32)) -> (if (eqv? x 1) 32)")
(lint-test "(case x ((0) (display 1) 2) (else (display 1) 2))"
" case: perhaps (case x ((0) (display 1) 2) (else (display 1) 2)) -> (begin (display 1) 2)")
- (lint-test "(case x (else (case x ((0) 1))))" " case: perhaps (case x (else (case x ((0) 1)))) -> (case x ((0) 1))")
+ (lint-test "(case x (else (case x ((0) 1))))"
+ " case: perhaps (case x ((0) 1)) -> (if (eqv? x 0) 1)
+ case: perhaps (case x (else (case x ((0) 1)))) -> (case x ((0) 1))")
(lint-test "(case x (else (case x (else 1))))" " case: perhaps (case x (else 1)) -> 1 case: perhaps (case x (else (case x (else 1)))) -> 1")
- (lint-test "(case x ((0) 1) ((1 2) 1))" " case: perhaps (case x ((0) 1) ((1 2) 1)) -> (case x ((0 1 2) 1))")
- (lint-test "(case x ((0 1) (abs x)))" " case: perhaps use => here: ((0 1) (abs x)) -> ((0 1) => abs)")
+ (lint-test "(case x ((0) 1) ((1 2) 1))" " case: perhaps merge keys (1 2) with (0): (case x ((0) 1) ((1 2) 1)) -> (case x ((0 1 2) 1))")
+ (lint-test "(case x ((0 1) (abs x)))"
+ " case: perhaps (case x ((0 1) (abs x))) -> (if (memv x '(0 1)) (abs x))
+ case: perhaps use => here: ((0 1) (abs x)) -> ((0 1) => abs)")
(lint-test "(case x ((a b a) 1) ((c) 2))" " case: repeated case key a in ((a b a) 1)")
+ (lint-test "(case x ((3) 2) ((4 8) 3) ((1) 3) ((0) 2))"
+ " case: perhaps merge keys (1) with (4 8), (0) with (3):
+ (case x ((3) 2) ((4 8) 3) ((1) 3) ((0) 2)) -> (case x ((0 3) 2) ((1 4 8) 3))")
+ (lint-test "(case x ((#\\1) 2) ((#\\space #\\c) 3) ((#\\x) 3) ((#\\null) 2))"
+ " case: perhaps merge keys (#\\x) with (#\\space #\\c), (#\\null) with (#\\1):
+ (case x ((#\\1) 2) ((#\\space #\\c) 3) ((#\\x) 3) ((#\\null) 2)) -> (case x ((#\\null #\\1) 2) ((#\\space #\\c #\\x) 3))")
+ (lint-test "(case ((1) 1) (t 2))" " case: bad case key t in (t 2)")
+ (lint-test "(case x ((a) #t) (else #f))" " case: perhaps (case x ((a) #t) (else #f)) -> (eq? x 'a)")
+ (lint-test "(case x ((a b) #f) (else #t))" " case: perhaps (case x ((a b) #f) (else #t)) -> (not (memq x '(a b)))")
+ (lint-test "(case x ((1 2) #t) (else #f))" " case: perhaps (case x ((1 2) #t) (else #f)) -> (memv x '(1 2))")
+ (lint-test "(case x ((2) #f) (else #t))" " case: perhaps (case x ((2) #f) (else #t)) -> (not (eqv? x 2))")
+ (lint-test "(case x ((1) y) ((2) z) (#t 3))" " case: bad case key #t in (#t 3)")
+ (lint-test "(case x ((a) y) ((b) z) (else (if (eq? x 'c) 32 (+ x 1))))"
+ " case: perhaps (case x ((a) y) ((b) z) (else (if (eq? x 'c) 32 (+ x 1)))) -> (case x ((a) y) ((b) z) ((c) 32) (else (+ x 1)))")
+ (lint-test "(case x ((a) y) ((b) z) (else (if (eq? x 'c) 32)))"
+ " case: perhaps (case x ((a) y) ((b) z) (else (if (eq? x 'c) 32))) -> (case x ((a) y) ((b) z) ((c) 32))")
+ (lint-test "(case x ((a) (+ y 1) z) ((b) (display x)) (else c))"
+ " case: this could be omitted: (+ y 1) case: perhaps use => here: ((b) (display x)) -> ((b) => display)")
+ (lint-test "(begin (case x ((a) (+ y 1) z) ((b) (display x)) (else c)) (display x))"
+ " begin: this could be omitted: z in ((a) (+ y 1) z)
+ begin: this could be simply #f: c in (else c)
+ begin: this could be omitted: (+ y 1)
+ begin: perhaps use => here: ((b) (display x)) -> ((b) => display)")
+
+ (lint-test "(case x (else 3))" " case: perhaps (case x (else 3)) -> 3")
+ (lint-test "(case x ((1) (+ x 1)) (else (+ x 3)))"
+ " case: perhaps (case x ((1) (+ x 1)) (else (+ x 3))) -> (+ x (if (eqv? x 1) 1 3))")
+ (lint-test "(case x ((#\\a #\\b) (+ x 1)) (else (+ x 3)))"
+ " case: perhaps (case x ((#\\a #\\b) (+ x 1)) (else (+ x 3))) -> (+ x (if (memv x '(#\\a #\\b)) 1 3))")
+ (lint-test "(case (+ x 1) ((1) (fx1 x y z)) ((2 3) (fx1 x y a)) (else (fx1 x y a b)))"
+ " case: perhaps (case (+ x 1) ((1) (fx1 x y z)) ((2 3) (fx1 x y a)) (else (fx1 x y a b))) -> (fx1 x y (case (+ x 1) ((1) z) ((2 3) a) (else (values a b))))")
+ (lint-test "(case x ((symbol) (display x) (+ x 1)))" " case: perhaps (case x ((symbol) (display x) (+ x 1))) -> (when (eq? x 'symbol) (display x) (+ x 1))")
+ (lint-test "(case x ((:symbol) (display x) (+ x 1)))" " case: perhaps (case x ((:symbol) (display x) (+ x 1))) -> (when (eq? x :symbol) (display x) (+ x 1))")
+ (lint-test "(case x ((0) (log x 2)) ((1) (log x 3)) (else (error 'oops)))"
+ " case: perhaps (case x ((0) (log x 2)) ((1) (log x 3)) (else (error 'oops))) -> (log x (case x ((0) 2) ((1) 3) (else (error 'oops))))")
(lint-test "(do ())" " do: do is messed up: (do ())")
(lint-test "(do () ())" " do: this do-loop could be replaced by (): (do () ())")
- (lint-test "(do ((x 2) y) ())" " do: do binding is not a list? y do: do variable x not used")
+ (lint-test "(do ((x 2) y) ())" " do: do binding is not a list? y do: x not used, initially: 2 from do")
(lint-test "(do ((x 2 1)) () x)" " do: this do-loop could be replaced by (): (do ((x 2 1)) () x) do: this could be omitted: x")
- (lint-test "(do ((x 2 1)) () (display 1))" " do: do variable x not used")
+ (lint-test "(do ((x 2 1)) () (display 1))" " do: x set, but not used: 2 from do")
+ (lint-test "(do ((x 2)) () (display 1))" " do: x not used, initially: 2 from do")
(lint-test "(do ((i 0 (+ i 1))) ((+ i 10) i))" " do: end test is never false: (+ i 10)")
(lint-test "(do ((i 0 (+ i 1))) (#f i))" " do: result is unreachable: (#f i)")
(lint-test "(do ((i 0 (+ i 0))) ((= i 10) i))" " do: perhaps (+ i 0) -> i")
(lint-test "(do ((i 0 (+ i 1))) ((= i len)) (string-set! s i #\\a))"
" do: perhaps (do ((i 0 (+ i 1))) ((= i len)) (string-set! s i #\\a)) -> (fill! s #\\a 0 len)")
+ (lint-test "(do ((i 2 (+ i 1))) ((= i len)) (string-set! s i #\\a))"
+ " do: perhaps (do ((i 2 (+ i 1))) ((= i len)) (string-set! s i #\\a)) -> (fill! s #\\a 2 len)")
+ (lint-test "(do ((i 2 (+ i 10))) ((= i len)) (string-set! s i #\\a))" "")
+
(lint-test "(do ((i 0 (+ i 1))) ((= i len)) (vector-set! v0 i (vector-ref v1 i)))"
" do: perhaps (do ((i 0 (+ i 1))) ((= i len)) (vector-set! v0 i (vector-ref v1 i))) -> (copy v1 v0 0 len)")
+ (lint-test "(do ((x 0 (+ x 1))) ((>= x c) #f) (vector-set! array x (list-ref cells x)))"
+ " do: perhaps (do ((x 0 (+ x 1))) ((>= x c) #f) (vector-set! array x (list-ref cells x))) -> (copy cells array 0 c)")
(lint-test "(do ((i 0 (+ 1 1))) ((= i 3) z))" " do: perhaps (+ 1 1) -> 2")
(lint-test "(do ((x lst (cdr lst))) ((null? x) y))" " do: this looks suspicious: (x lst (cdr lst))")
(lint-test "(do ((i 0 (+ i 1))) ((>= i len)) (display i))" "")
(lint-test "(do ((i 0 (+ i 1))) ((< i len)) (display i))" " do: do step looks like it doesn't match end test: (+ i 1) -> (< i len)")
(lint-test "(do ((i 0 (- i 1))) ((<= i len)) (display i))" "")
(lint-test "(do ((i 0 (- i 1))) ((> i len)) (display i))" " do: do step looks like it doesn't match end test: (- i 1) -> (> i len)")
- (lint-test "(do ((i 0 (+ i 1))) (= i 10) (display i))" " do: this could be omitted: (= i 10) do: perhaps missing parens: (= i 10)")
- (lint-test "(do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 10)) (display i))" " do: do variable j not used")
- (lint-test "(do ((i 0 (+ i j)) (j 0 (+ j 1))) ((= i 10)) (display i))" "") ; displays 00136
- (lint-test "(do ((i 0 j) (j 0 (+ j 1))) (display i))" "")
+ (lint-test "(do ((i 0 (+ i 1))) (= i 10) (display i))"
+ "do: this could be omitted: i
+ do: perhaps missing parens: (= i 10)
+ do: strange do end-test: = in (= i 10) is a procedure")
+ (lint-test "(do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 10)) (display i))" " do: j set, but not used: 0 from do")
+ (lint-test "(let ((x #t)) (do ((i 0 (+ i 1))) (x) (display i)))" "")
(lint-test "(do ((i 0 (display i))) ((x y) z))" "")
+ (lint-test "(do ((i 0 (+ i 1))) (abs i) (display i))" " do: strange do end-test: abs in (abs i) is a procedure")
+ (lint-test "(begin (do ((i 0 (+ i 1))) ((= i 10) i) (display i)) x)"
+ " begin: (do ((i 0 (+ i 1))) ((= i 10) i) (display i)): result i is not used")
+ (lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (display p))" "")
+ (let ((old-do *report-constant-expressions-in-do*))
+ (set! *report-constant-expressions-in-do* #t)
+ (lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (display x))"
+ " do: in (do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (display x)), (log z 2) appears to be constant")
+ (set! *report-constant-expressions-in-do* old-do))
+ (lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (do ((z z (+ z 1))) ((= z 0)) (display z)) (display x))" "")
+
+ (lint-test "(let ((xx 0)) (do ((x 1 (+ x 1)) (y x (- y 1))) ((= x 3) xx) (display y)))"
+ " let: x in (y x (- y 1)) does not appear to be defined in the calling environment
+ let: perhaps (let ((xx 0)) (do ((x 1 (+ x 1)) (y x (- y 1))) ((= x 3) xx) (display y))) -> (do ((xx 0) (x 1 (+ x 1)) (y x (- y 1))) ...)")
+ (lint-test "(let ((x 0)) (do ((x 1 (+ x 1)) (y x (- y 1))) ((= x 3)) (display y)))"
+ " let: x in (y x (- y 1)) refers to the caller's x, not the do-loop variable")
+ (lint-test "(let ((x 0)) (do ((x x (+ x 1)) (y x (- y 1))) ((= x 3)) (display y)))" "")
+ (lint-test "(let ((a 1) (b 2)) (do ((x a (+ x 1)) (y (+ b 1) (+ y 1))) ((= i 3)) (display (+ x y))))"
+ " let: perhaps (let ((a 1) (b 2)) (do ((x a (+ x 1)) (y (+ b 1) (+ y 1))) ((= i 3))... -> (do ((x 1 (+ x 1)) (y (+ 2 1) (+ y 1))) ...)")
+ (lint-test "(let ((a 1)) (do ((i a (+ i 1))) ((= i 3)) (display i)))"
+ " let: perhaps (let ((a 1)) (do ((i a (+ i 1))) ((= i 3)) (display i))) -> (do ((i 1 (+ i 1))) ...)")
+ (lint-test "(let ((a 1)) (do ((i a (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ i j))))"
+ " let: perhaps (let ((a 1)) (do ((i a (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ i j)))) -> (do ((i 1 (+ i 1)) (j 0 (+ j 1))) ...)")
+ (lint-test "(let ((a 1)) (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ a i j))))"
+ " let: perhaps (let ((a 1)) (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ a i j)))) -> (do ((a 1) (i 0 (+ i 1)) (j 0 (+ j 1))) ...)")
+ (lint-test "(let ((a 1)) (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ a i j))) 32)"
+ " let: perhaps (let ((a 1)) (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3)) (display (+ a i... -> (do ((a 1) (i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) 32) ...)")
+ (lint-test "(do ((i 0 (+ i j)) (j 0 (+ j 1))) ((= i 10)) (display i))" ; displays 00136
+ " do: perhaps (do ((i 0 (+ i j)) (j 0 (+ j 1))) ((= i 10)) (display i)) ->
+ (do ((i 0) (j 0 (+ j 1))) ((= i 10)) (display i) (set! i (+ i j)))")
+ (lint-test "(do ((i 0 j) (j 0 (+ j 1))) ((= i 2)) (display i))"
+ " do: perhaps (do ((i 0 j) (j 0 (+ j 1))) ((= i 2)) (display i)) ->
+ (do ((i 0) (j 0 (+ j 1))) ((= i 2)) (display i) (set! i j))")
+ (lint-test "(do ((i 0 (+ i j)) (j 0 (+ k 1)) (k 1)) ((= i 10)) (display (+ i j k)))"
+ " do: perhaps (do ((i 0 (+ i j)) (j 0 (+ k 1)) (k 1)) ((= i 10)) (display (+ i j k))) ->
+ (do ((i 0) (j 0 (+ k 1)) (k 1)) ((= i 10)) (display (+ i j k)) (set! i (+ i j)))")
+ (lint-test "(do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4)) (display (+ i j)))"
+ " do: this do loop is unreadable; perhaps (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4)) (display (+ i j))) ->
+ (let _1_ ((i 0)
+ (j 1)
+ (k 0))
+ (if (= k 4)
+ ()
+ (begin
+ (display (+ i j))
+ (_1_ j i (+ k 1)))))")
+ (lint-test "(do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 5) (set! x k) (+ k 1)) (display (+ i j)))"
+ " do: this do loop is unreadable; perhaps (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 5) (set! x k) (+ k 1)) (display... ->
+ (let _1_ ((i 0)
+ (j 1)
+ (k 0))
+ (if (= k 5)
+ (begin
+ (set! x k)
+ (+ k 1))
+ (begin
+ (display (+ i j))
+ (_1_ j i (+ k 1)))))")
+ (lint-test "(do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4) (+ i j k)))"
+ " do: this do loop is unreadable; perhaps (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4) (+ i j k))) ->
+ (let _1_ ((i 0) (j 1) (k 0)) (if (= k 4) (+ i j k) (_1_ j i (+ k 1))))")
;(lint-test "(byte-vector 3213)" " byte-vector: byte-vector's argument should be a byte?: 3213: (byte-vector 3213)")
(lint-test "(let ())" " let: let is messed up: (let ())")
(lint-test "(let ((x (lambda (a) (x 1)))) x)"
- " let: let variable x is called in its binding? Perhaps let should be letrec: ((x (lambda (a) (x 1))))")
- (lint-test "(let* ((x 1)) x)" " let*: let* could be let: (let* ((x 1)) x)")
- (lint-test "(let* ((x 1) (x x)) x)" " let*: let* variable x is declared twice")
- (lint-test "(let* ((x (g g0)) (y (g g0))) (+ x y))" "")
- (lint-test "(let* ((x 0) (y (g 0))) (+ x y))" "") ; no telling what g is or does
- (lint-test "(let () (define x 3) (define (y a) a) (g z))" " let: let variables y, x not used")
+ " let: let variable x is called in its binding? Perhaps let should be letrec: ((x (lambda (a) (x 1))))
+ let: perhaps (let ((x (lambda (a) (x 1)))) x) -> (lambda (a) (x 1))")
+ (lint-test "(let* ((x 1)) x)" " let*: let* could be let: (let* ((x 1)) x) let*: perhaps (let* ((x 1)) x) -> 1")
+ (lint-test "(let* ((x 1) (x x)) x)" " let*: let* variable x is declared twice let*: perhaps (let* ((x 1) (x x)) x) -> (let ((x 1)) x)")
+ (lint-test "(let* ((x (g g0)) (y (g g0))) (+ x y))"
+ " let*: perhaps (let* ((x (g g0)) (y (g g0))) (+ x y)) -> (let ((x (g g0))) (+ x (g g0)))")
+ (lint-test "(let* ((x 0) (y (g 0))) (+ x y))"
+ " let*: perhaps (let* ((x 0) (y (g 0))) (+ x y)) -> (let ((x 0)) (+ x (g 0)))")
+ (lint-test "(let ((x 0)) (let ((y (g 0))) (+ x y)))"
+ " let: perhaps (let ((y (g 0))) (+ x y)) -> (+ x (g 0))
+ let: perhaps (let ((x 0)) (let ((y (g 0))) (+ x y))) -> (let* ((x 0) (y (g 0))) (+ x y))")
+
+ (lint-test "(let* ((a 1) (b (+ a 1))) (let ((c (+ a b))) (display c)))"
+ " let*: perhaps (let ((c (+ a b))) (display c)) -> (display (+ a b))
+ let*: perhaps (let* ((a 1) (b (+ a 1))) (let ((c (+ a b))) (display c))) -> (let* ((a 1) (b (+ a 1)) (c (+ a b))) (display c))")
+ (lint-test "(let* ((a 1) (b (+ a 1))) (let* ((c (+ a b)) (d (+ c 1))) (display d)) (display a))"
+ " let*: perhaps (let* ((c (+ a b)) (d (+ c 1))) (display d)) -> (let ((c (+ a b))) (display (+ c 1)))")
+ (lint-test "(let* ((a 1) (b (+ a 1))) (let ((c (+ a b)) (d a)) (display (+ c d))))"
+ " let*: perhaps (let ((c (+ a b)) (d a)) (display (+ c d))) -> (display (+ (+ a b) a))")
+ (lint-test "(let* ((x (log y 2)) (y (log y 2)) (z (f x))) (+ x y z z))" " let*: y's value (log y 2) could be x")
+ (lint-test "(let* ((x (log a 2)) (y (log y 2)) (z (log y 2))) (+ x y z z))" "")
+ (lint-test "(let ((a 1)) (let ((b (+ a 1))) (+ a b)))"
+ " let: perhaps (let ((b (+ a 1))) (+ a b)) -> (+ a (+ a 1))
+ let: perhaps (let ((a 1)) (let ((b (+ a 1))) (+ a b))) -> (let* ((a 1) (b (+ a 1))) (+ a b))")
+ (lint-test "(let ((a 1)) (let ((b 2)) (+ a b)))"
+ " let: perhaps (let ((b 2)) (+ a b)) -> (+ a 2)
+ let: perhaps (let ((a 1)) (let ((b 2)) (+ a b))) -> (let ((a 1) (b 2)) (+ a b))")
+ (lint-test "(let ((a 1)) (let* ((b (+ a 1)) (c (* b 2))) (display (+ a b c))))"
+ " let: perhaps (let* ((b (+ a 1)) (c (* b 2))) (display (+ a b c))) -> (let ((b (+ a 1))) (display (+ a b (* b 2))))
+ let: perhaps (let ((a 1)) (let* ((b (+ a 1)) (c (* b 2))) (display (+ a b c)))) ->
+ (let* ((a 1) (b (+ a 1)) (c (* b 2))) (display (+ a b c)))")
+ (lint-test "(let ((x 1) (y 2)) (set! x (* y 2)) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x 1) (y 2)) (set! x (* y 2)) x) -> (let ((y 2)) (* y 2))")
+ (lint-test "(let ((x (read-byte)) (y 2)) (set! x (* y x)) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x (read-byte)) (y 2)) (set! x (* y x)) x) -> (let ((x (read-byte)) (y 2)) (* y x))")
+ (lint-test "(let ((x (read-byte)) (y 2)) (set! x (* y 2)))"
+ " let: x set, but not used: (set! x (* y 2))
+ let: perhaps (let ((x (read-byte)) (y 2)) (set! x (* y 2))) -> (let ((x (read-byte)) (y 2)) (* y 2))")
+ (lint-test "(let ((x 1) (y 2)) (set! x (* y x)) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x 1) (y 2)) (set! x (* y x)) x) -> (let ((x 1) (y 2)) (* y x))")
+ (lint-test "(let ((x 1)) (set! x (* 2 x)) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x 1)) (set! x (* 2 x)) x) -> (let ((x 1)) (* 2 x))")
+ (lint-test "(let ((x 1)) (set! x 2) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x 1)) (set! x 2) x) -> (let ((x 2)) x)")
+ (lint-test "(let ((x 1) (y (f g 2))) (let loop ((a (+ x 1)) (b y)) (loop a b)))"
+ " let: perhaps (let ((x 1) (y (f g 2))) (let loop ((a (+ x 1)) (b y)) (loop a b))) -> (let loop ((a (+ 1 1)) (b (f g 2))) (loop a b))")
+ (lint-test "(let loop ((i 0)) (+ i 1))" " let: loop not used, value: (let loop ((i 0)) (+ i 1))")
+
+ (lint-test "(let () (define x 3) (define (y a) a) (g z))"
+ " let: y not used, value: (define (y a) a)
+ let: x not used, initially: 3 from define")
(lint-test "(letrec () 1)" " letrec: letrec could be let: (letrec () 1)")
- (lint-test "(letrec* ((a (lambda b (a 1)))) a)" " letrec*: letrec* could be letrec? (letrec* ((a (lambda b (a 1)))) a)")
+ (lint-test "(letrec* ((a (lambda b (a 1)))) a)" " letrec*: letrec* could be letrec: (letrec* ((a (lambda b (a 1)))) a)")
+ (lint-test "(letrec* ((x 12) (x y)) x)"
+ " letrec*: letrec* could be let*: (letrec* ((x 12) (x y)) x)
+ letrec*: letrec* variable x is declared twice
+ letrec*: x not used, initially: 12 from letrec*")
+ (lint-test "(letrec ((x x)) x)" " letrec: (x x) is the same as (x #<undefined>) in letrec")
+ (lint-test "(letrec* ((x x)) x)"
+ " letrec*: letrec* could be letrec: (letrec* ((x x)) x) letrec*: (x x) is the same as (x #<undefined>) in letrec*")
(lint-test "(begin . 1)" " begin: stray dot in begin? (begin . 1)")
- (lint-test "(begin (map abs x) #f)" " begin: map could be for-each: (map abs x) begin: this could be omitted: (map abs x)")
+ (lint-test "(begin (map abs x) #f)" " begin: this could be omitted: (map abs x)")
+ (lint-test "(begin (map display x) #f)" " begin: map could be for-each: (for-each display x)")
(lint-test "(begin 1 #f)" " begin: this could be omitted: 1")
(lint-test "(begin (+ x y) 3)" " begin: this could be omitted: (+ x y)")
(lint-test "(begin (display 1) (begin #f))" " begin: redundant begin: (begin #f) begin: begin could be omitted: (begin #f)")
@@ -84753,7 +86797,7 @@ etc
(lint-test "(format)" " format: format needs at least 1 argument: (format) format: format has too few arguments: (format)")
(lint-test "(format (format #f str))" " format: redundant format: (format (format #f str))")
(lint-test "(format #f \"~H\" 1)" " format: unrecognized format directive: H in \"~H\", (format #f \"~H\" 1)")
- (lint-test "(format #f \"~^\")" " format: ~^ has ^ outside ~{~}?")
+ (lint-test "(format #f \"~^\")" " format: ~^ has ~^ outside ~{~}?")
(lint-test "(format #f \"~A\")" " format: format has too few arguments: (format #f \"~A\")")
(lint-test "(format #f \"~A\" 1 2)" " format: format has too many arguments: (format #f \"~A\" 1 2)")
(lint-test "(format #f \"asdf~\")" " format: format control string ends in tilde: (format #f \"asdf~\")")
@@ -84761,27 +86805,168 @@ etc
(lint-test "(format #f \"123\")" " format: (format #f \"123\") could be \"123\", (format is a no-op here)")
(lint-test "(format #f \"~nD\" 1 2)" "")
(lint-test "(format #f \"~n,nD\" 1 2 3)" "")
+ (lint-test "(format #f \"~%~&\")" " format: ~%~& in ~%~& could be ~%")
+ (lint-test "(format #f \"~~%~&\")" "")
+ (lint-test "(format #f \"1~%~&2\")" " format: ~%~& in 1~%~&2 could be ~%")
(lint-test "(format #f \"~nT\" 1 2)" " format: format has too many arguments: (format #f \"~nT\" 1 2)")
(lint-test "(format #f \"~nD\" 1)" " format: format has too few arguments: (format #f \"~nD\" 1)")
(lint-test "(format 1)" " format: format with one argument takes a string: (format 1)")
(lint-test "(format #f \"~NC ~W\" 1 #\\c 2)" "")
+ (lint-test "(format #f \"~4,3F\" x)" "")
+ (lint-test "(format #f \"~32T\")" "")
+ (lint-test "(format #f \"~a\\x00b\" x)"
+ " format: #\\null in a format control string will confuse both lint and format: \"~a\\x00b\" in (format #f \"~a\\x00b\" x)")
+ (lint-test "(let () (format #t \"~A\" x) x)" " let: perhaps use () with format since the string value is discarded: (format () \"~A\" x)")
+ (lint-test "(format #f \"~A\" (number->string x))" " format: format arg (number->string x) could be x")
+ (lint-test "(format #f \"~A\" (number->string x 16))"
+ " format: format arg (number->string x 16) could use the format directive ~X and change the argument to x")
+ (lint-test "(format #f \"~A\" (symbol->string 'x))"
+ " format: format arg (symbol->string 'x) could be 'x format: perhaps (symbol->string 'x) -> \"x\"")
+ (lint-test "(format #f \"~A\" (make-string len c))"
+ " format: format arg (make-string len c) could use the format directive ~NC and change the argument to ... len c ...")
+ (lint-test "(format #f \"~A\" (make-string len #\\space))"
+ " format: format arg (make-string len #\\space) could use the format directive ~NC and change the argument to ... len #\\space ...")
+
+ (lint-test "(for-each (lambda (x) (display x)) args)"
+ " for-each: perhaps (for-each (lambda (x) (display x)) args) -> (format () \"~{~A~}\" args) for-each: perhaps (lambda (x) (display x)) -> display")
+ (lint-test "(for-each (lambda (x) (display #\\space) (write x)) args)"
+ " for-each: perhaps (for-each (lambda (x) (display #\\space) (write x)) args) -> (format () \"~{ ~S~}\" args)")
+ (lint-test "(for-each (lambda (x) (newline port) (write-char x port)) args)"
+ " for-each: perhaps (for-each (lambda (x) (newline port) (write-char x port)) args) -> (format port \"~{~%~C~}\" args)")
+ (lint-test "(for-each (lambda (x) (newline port) (display (number->string x 16) port)) args)"
+ " for-each: perhaps (for-each (lambda (x) (newline port) (display (number->string x 16) port)) args) -> (format port \"~{~%~X~}\" args)")
+ (lint-test "(if (pair? x) (for-each display x))"
+ " if: perhaps (for-each display x) -> (format () \"~{~A~}\" x)")
+
+ (lint-test "(values 1)" " values: perhaps (values 1) -> 1")
+ (lint-test "(call-with-values p c)" " call-with-values: perhaps (call-with-values p c) -> (c (p))")
+ (lint-test "(call-with-values log c)" " call-with-values: log does not return multiple values")
+ (lint-test "(call-with-values (lambda x 0) list)" " call-with-values: (lambda x 0)'s parameter x will always be ()")
+ (lint-test "(call-with-values (lambda (x) 0) list)" " call-with-values: (lambda (x) 0) requires too many arguments")
+ (lint-test "(call-with-values (lambda () (f x)) cons)" " call-with-values: perhaps (call-with-values (lambda () (f x)) cons) -> (cons (f x))")
+ (lint-test "(call-with-values (lambda () (read-char p)) cons)" " call-with-values: (read-char p) does not return multiple values")
+ (lint-test "(call-with-values (lambda () (values 1 2 3)) list)"
+ " call-with-values: perhaps (call-with-values (lambda () (values 1 2 3)) list) -> (list 1 2 3)")
+ (lint-test "(call-with-values (lambda () (values 1 2)) abs)"
+ " call-with-values: call-with-values consumer abs wants 1 value, but producer (lambda () (values 1 2)) returns 2
+ call-with-values: perhaps (call-with-values (lambda () (values 1 2)) abs) -> (abs 1 2)")
+
+ (lint-test "(let () (define (fv a) (values (+ a 1) (- a 1))) (define (fw a b) (list (+ a 1) b)) (fw (fv 1)))" "")
+ (lint-test "(let () (define (fv a) (values (+ a 1) (- a 1))) (list (fv 1)))"
+ " let: perhaps (... (define (fv a) (values (+ a 1) (- a 1))) (list (fv 1))) -> (... (list (let ((a 1)) (values (+ a 1) (- a 1)))))")
+ (unless (provided? 'snd)
+ (lint-test "(let () (define (fv) (values 1 -1)) (call-with-values fv list))"
+ " let: perhaps (call-with-values fv list) -> (list (fv))")
+ (lint-test "(let () (define (fv) (values 1 -1)) (define (fw a b) (list (+ a 1) b)) (call-with-values fv fw))"
+ " let: perhaps (call-with-values fv fw) -> (fw (fv))"))
+ (lint-test "(receive (value submitter) (current-input-status elt) #f)"
+ " receive: perhaps (call-with-values (lambda () (current-input-status elt)) (lambda (value... ->
+ ((lambda (value submitter) #f) (current-input-status elt))")
+
+ (lint-test "(multiple-value-bind (a b) (f) b)" "")
+ (lint-test "(multiple-value-bind (a b) (values 2 3) b)" "")
+ (lint-test "(multiple-value-bind (a b c d) (values 2 (values 3 4) 5) (+ a b c d))"
+ " multiple-value-bind: perhaps (values 2 (values 3 4) 5) -> (values 2 3 4 5)")
+ (lint-test "(multiple-value-bind (a b) (values 1 2 3) b)" " multiple-value-bind: multiple-value-bind wants 2 values, but (values 1 2 3) returns 3")
+ (lint-test "(multiple-value-bind (a b) (f) (cons a b))" " multiple-value-bind: perhaps (multiple-value-bind (a b) (f) (cons a b)) -> (cons (f))")
+ (lint-test "(multiple-value-bind (a b) (values 1 2) (cons a b))"
+ " multiple-value-bind: perhaps (multiple-value-bind (a b) (values 1 2) (cons a b)) -> (cons (values 1 2))")
+ (lint-test "(let () (define (f1) (values 2 3 4)) (multiple-value-bind (a b) (f1) (+ a b)))"
+ " let: perhaps (... (define (f1) (values 2 3 4)) (multiple-value-bind (a b) (f1) (+ a b))) -> (... (multiple-value-bind (a b) (values 2 3 4) (+ a b)))
+ let: multiple-value-bind wants 2 values, but (f1) returns 3")
+ (lint-test "(let () (define (f1) (values 2)) (multiple-value-bind (a b) (f1) (+ a b)))"
+ " let: perhaps (... (define (f1) (values 2)) (multiple-value-bind (a b) (f1) (+ a b))) -> (... (multiple-value-bind (a b) (values 2) (+ a b)))
+ f1: perhaps (values 2) -> 2
+ let: multiple-value-bind wants 2 values, but (f1) returns 1")
+ (lint-test "(let () (multiple-value-bind (a b) ((lambda () (values 1 2 3))) (+ a b)))"
+ " let: multiple-value-bind wants 2 values, but ((lambda () (values 1 2 3))) returns 3
+ let: perhaps ((lambda () (values 1 2 3))) -> (values 1 2 3)")
+
+ (lint-test "(let*-values (((a b) (f x))) (+ a b))"
+ " let*-values: perhaps (let*-values (((a b) (f x))) (+ a b)) -> ((lambda (a b) (+ a b)) (f x))")
+ (lint-test "(let*-values (((a) (f x))) (+ a b))"
+ " let*-values: perhaps (let*-values (((a) (f x))) (+ a b)) -> (let ((a (f x))) (+ a b))")
+ (lint-test "(let*-values ((a (f x))) (apply + a))"
+ " let*-values: perhaps (let*-values ((a (f x))) (apply + a)) -> ((lambda a (apply + a)) (f x))")
+ (lint-test "(let*-values (((a b) (f x)) ((c) (g y))) (+ a b c))"
+ " let*-values: perhaps (let*-values (((a b) (f x)) ((c) (g y))) (+ a b c)) ->
+ ((lambda (a b) (let ((c (g y))) (+ a b c))) (f x))")
+ (lint-test "(let*-values (((a) (f x)) ((c d) (g y))) (display c) (+ a b c))"
+ " let*-values: perhaps (let*-values (((a) (f x)) ((c d) (g y))) (display c) (+ a b c)) ->
+ (let ((a (f x))) ((lambda (c d) (display c) (+ a b c)) (g y)))")
+ (lint-test "(let*-values (((a . b) (f x)) (c (g y))) (display c) (+ a b c))"
+ " let*-values: perhaps (let*-values (((a . b) (f x)) (c (g y))) (display c) (+ a b c)) ->
+ ((lambda (a . b) ((lambda c (display c) (+ a b c)) (g y))) (f x))")
+ (lint-test "(let*-values (((a . b) (f x)) (c (g y)) ((d e f) (h a b))) (display c) (+ a b c))"
+ " let*-values: perhaps (let*-values (((a . b) (f x)) (c (g y)) ((d e f) (h a b))) (display c) (+... ->
+ ((lambda (a . b) ((lambda c ((lambda (d e f) (display c) (+ a b c)) (h a b))) (g y))) (f x))")
+
+ (lint-test "(let-values (((x) (values 1))) x)"
+ " let-values: perhaps (let-values (((x) (values 1))) x) -> ((lambda (x) x) (values 1))
+ let-values: perhaps (values 1) -> 1")
+ (lint-test "(let-values ((x (values 1))) x)"
+ " let-values: perhaps (let-values ((x (values 1))) x) -> ((lambda x x) (values 1))
+ let-values: perhaps (values 1) -> 1")
+ (lint-test "(let-values (((x) (values 1)) ((y) (values 2))) (list x y))"
+ " let-values: perhaps (let-values (((x) (values 1)) ((y) (values 2))) (list x y)) ->
+ (with-let (apply sublet (curlet)
+ (list ((lambda (x) (values :x x)) (values 1))
+ ((lambda (y) (values :y y)) (values 2))))
+ (list x y))
+ let-values: perhaps (values 1) -> 1
+ let-values: perhaps (values 2) -> 2")
+ (lint-test "(let ((x 32)) (let-values (((x) (values 1)) ((y) (values (+ x 1)))) (list x y)))"
+ " let: perhaps (let-values (((x) (values 1)) ((y) (values (+ x 1)))) (list x y)) ->
+ (with-let (apply sublet (curlet)
+ (list ((lambda (x) (values :x x)) (values 1))
+ ((lambda (y) (values :y y)) (values (+ x 1)))))
+ (list x y))
+ let: perhaps (values 1) -> 1
+ let: perhaps (values (+ x 1)) -> (+ x 1)")
+ (lint-test "(let-values (((x y) (values 1 2))) (list x y))"
+ " let-values: perhaps (let-values (((x y) (values 1 2))) (list x y)) -> ((lambda (x y) (list x y)) (values 1 2))")
+ (lint-test "(let ((d 32)) (let-values (((a) 1) ((c d e) (values 3 4 5)) ((b) d)) (+ a b (* c d e))))"
+ " let: perhaps (let-values (((a) 1) ((c d e) (values 3 4 5)) ((b) d)) (+ a b (* c d e))) ->
+ (with-let (apply sublet (curlet)
+ (list ((lambda (a) (values :a a)) 1)
+ ((lambda (c d e) (values :c c :d d :e e)) (values 3 4 5))
+ ((lambda (b) (values :b b)) d)))
+ (+ a b (* c d e)))")
+ (lint-test "(let ((a 32) (b -1)) (let-values (((a b) (values 1 2)) ((x y) (values a b))) (list a b x y)))"
+ " let: perhaps (let-values (((a b) (values 1 2)) ((x y) (values a b))) (list a b x y)) ->
+ (with-let (apply sublet (curlet)
+ (list ((lambda (a b) (values :a a :b b)) (values 1 2))
+ ((lambda (x y) (values :x x :y y)) (values a b))))
+ (list a b x y))")
+
+ (lint-test "(let () (define-values (x y) (values 3 2)) (+ x y))"
+ " let: perhaps (define-values (x y) (values 3 2)) -> (varlet (curlet) ((lambda (x y) (curlet)) (values 3 2)))")
(lint-test "(open-output-file x \"fb+\")" " open-output-file: unexpected mode: (open-output-file x \"fb+\")")
(lint-test "(vector 1 2 . 3)" " vector: unexpected dot: (vector 1 2 . 3)")
(lint-test "(begin (display x) (newline) (display y) (newline))"
- " begin: perhaps ((display x) (newline) (display y) (newline)) -> (format () \"~A~%~A~%\" x y)")
+ " begin: perhaps (... (display x) (newline) (display y) (newline)) -> (format () \"~A~%~A~%\" x y)")
(lint-test "(begin (display x) (newline) (display y) (newline) 32)"
- " begin: perhaps ((display x) (newline) (display y) (newline)) -> (format () \"~A~%~A~%\" x y)")
+ " begin: perhaps (... (display x) (newline) (display y) (newline)) -> (format () \"~A~%~A~%\" x y)")
(lint-test "(begin (write x p) (newline p) (write-char #\\a p) (write-string \"bc\" p))"
- " begin: perhaps ((write x p) (newline p) (write-char #\\a p) (write-string \"bc\" p)) -> (format p \"~S~%abc\" x)")
+ " begin: perhaps (... (write x p) (newline p) (write-char #\\a p) (write-string \"bc\" p)) -> (format p \"~S~%abc\" x)")
(lint-test "(begin (newline) (set! x 1) (display x) (newline) (newline))"
- " begin: perhaps ((display x) (newline) (newline)) -> (format () \"~A~%~%\" x)")
+ " begin: perhaps (... (display x) (newline) (newline)) -> (format () \"~A~%~%\" x)")
(lint-test "(begin (write-string x p y z) (write-string \"1234\" p 1) (write-string \"5678\" p 2 3) (write-string \"abc\" p 2 z))"
- " begin: perhaps ((write-string x p y z) (write-string \"1234\" p 1) (write-string \"5678\" p 2 3) (write-string \"abc\" p 2 z)) -> (format p \"~A2347~A\" (substring x y z) (substring \"abc\" 2 z))")
+ " begin: perhaps
+ (... (write-string x p y z) (write-string \"1234\" p 1) (write-string \"5678\"... ->
+ (format p \"~A2347~A\" (substring x y z) (substring \"abc\" 2 z))")
+ (lint-test "(display x #f)" "") ; #f is ok here = no output
+
+ (lint-test "(+ 1 (begin (x y) #\\a))" " +: in (+ 1 (begin (x y) #\\a)), +'s argument 2 should be a number, but #\\a is a char?")
+ (lint-test "(+ 1 (cond ((x 1) 3) ((x 2) 1+i) ((x 3) '(1 2))))"
+ " +: in (+ 1 (cond ((x 1) 3) ((x 2) 1+1i) ((x 3) '(1 2)))), +'s argument 2 should be a number, but '(1 2) is a pair?")
+ (lint-test "(+ 1 (cond ((x 1) 3) ((x 2) 1+i) ((x 3) 1/2)))" "")
(lint-test "(substring x 0)" " substring: perhaps clearer: (substring x 0) -> (copy x)")
(lint-test "(substring (substring x 1) 2)" " substring: perhaps (substring (substring x 1) 2) -> (substring x 3)")
+ (lint-test "(substring x (+ y 1) (+ y 1))" " substring: leaving aside errors, (substring x (+ y 1) (+ y 1)) is \"\"")
(lint-test "(list-tail x 0)" " list-tail: perhaps (list-tail x 0) -> x")
(lint-test "(list-tail (list-tail x 1) 2)" " list-tail: perhaps (list-tail (list-tail x 1) 2) -> (list-tail x 3)")
(lint-test "(list-tail (list-tail x y) z)" " list-tail: perhaps (list-tail (list-tail x y) z) -> (list-tail x (+ y z))")
@@ -84798,44 +86983,146 @@ etc
(lint-test "(or 'a 'b)" " or: perhaps (or 'a 'b) -> 'a")
(lint-test "(or x x)" " or: perhaps (or x x) -> x")
(lint-test "(or x x y)" " or: perhaps (or x x y) -> (or x y)")
+ (lint-test "(or x y z z y)" " or: perhaps (or x y z z y) -> (or x y z)")
+ (lint-test "(or (and x (or y z)) x)" "") ; these 3 hit the (cur 0) code and the 8-way var code
+ (lint-test "(or (and x y z) x z)" "") ; I think these results are correct -- many truths...
+ (lint-test "(or (and x y z) x)" "")
+ (lint-test "(or (and x y) (and x z))" " or: perhaps (or (and x y) (and x z)) -> (and x (or y z))")
(lint-test "(or 1 x)" " or: perhaps (or 1 x) -> 1")
(lint-test "(or (or y) x)" " or: perhaps (or (or y) x) -> (or y x)")
(lint-test "(or (or y x) x)" " or: perhaps (or (or y x) x) -> (or y x)")
- (lint-test "(or x (not x))" " or: perhaps (or x (not x)) -> (or x #t)")
- (lint-test "(or (> x 1) (not (> x 1)))" " or: perhaps (or (> x 1) (not (> x 1))) -> (or (> x 1) #t)")
+ (lint-test "(or x (not x))" "")
(lint-test "(or x (and x y))" " or: perhaps (or x (and x y)) -> x")
+ (lint-test "(or (and x y) y)" " or: perhaps (or (and x y) y) -> y")
(lint-test "(or x #f y)" " or: perhaps (or x #f y) -> (or x y)")
(lint-test "(or x #f)" " or: perhaps (or x #f) -> x")
- (lint-test "(or x (not (and x y)))" " or: perhaps (or x (not (and x y))) -> (or x #t)")
+ (lint-test "(or x y #f)" " or: perhaps (or x y #f) -> (or x y)")
+ (lint-test "(or x #t)" "")
+ (lint-test "(or #t (display \"oops\"))" " or: perhaps (or #t (display \"oops\")) -> #t")
+ (lint-test "(or (pair? x) #t (even? y))" " or: perhaps (or (pair? x) #t (even? y)) -> (or (pair? x) #t)")
+ (lint-test "(or x (not (and x y)))" "") ; someday?
(lint-test "(or (pair? x) (list? x))" " or: perhaps (or (pair? x) (list? x)) -> (list? x)")
(lint-test "(or (number? x) (rational? x))" " or: perhaps (or (number? x) (rational? x)) -> (number? x)")
- (lint-test "(or (pair? x) (null? x))" "")
+ (lint-test "(or (pair? x) (null? x))" " or: perhaps (or (pair? x) (null? x)) -> (list? x)")
(lint-test "(or (list? x) (list? x))" " or: perhaps (or (list? x) (list? x)) -> (list? x)")
(lint-test "(or #f (= x 1))" " or: perhaps (or #f (= x 1)) -> (= x 1)")
- (lint-test "(or (integer? (cadr x)) (number? (cadr x)))" " or: perhaps (or (integer? (cadr x)) (number? (cadr x))) -> (number? (cadr x))")
- (lint-test "(or (eq? x 'a) (eq? x 'b) (eq? x 'c))" " or: perhaps (or (eq? x 'a) (eq? x 'b) (eq? x 'c)) -> (memq x '(a b c))")
- (lint-test "(or (= x 1) (= x 2) (= x 3))" " or: perhaps (or (= x 1) (= x 2) (= x 3)) -> (memv x '(1 2 3))")
- (lint-test "(or (equal? x #()) (equal? x #(1)))" " or: perhaps (or (equal? x #()) (equal? x #(1))) -> (member x '(#() #(1)))")
- (lint-test "(or (string=? x \"a\") (string=? x \"b\"))" " or: perhaps (or (string=? x \"a\") (string=? x \"b\")) -> (member x '(\"a\" \"b\") string=?)")
- (lint-test "(or (char=? (cadr x) #\\a) (char=? (cadr x) #\\b))" " or: perhaps (or (char=? (cadr x) #\\a) (char=? (cadr x) #\\b)) -> (memv (cadr x) '(#\\a #\\b))")
- (lint-test "(or (= (let ((z 1)) (display z) z) 1) (= (let ((z 1)) (display z) z) 2))" "")
+ (lint-test "(or (integer? (cadr x)) (number? (cadr x)))"
+ " or: perhaps (or (integer? (cadr x)) (number? (cadr x))) -> (number? (cadr x))")
+ (lint-test "(or (eq? x 'a) (eq? x 'b) (eq? x 'c))"
+ " or: perhaps (or (eq? x 'a) (eq? x 'b) (eq? x 'c)) -> (memq x '(a b c))")
+ (lint-test "(or (= x 1) (= x 2) (= x 3))"
+ " or: perhaps (or (= x 1) (= x 2) (= x 3)) -> (member x '(1 2 3) =)")
+ (lint-test "(or (equal? x #()) (equal? x #(1)))"
+ " or: perhaps (or (equal? x #()) (equal? x #(1))) -> (member x '(#() #(1)))")
+ (lint-test "(or (string=? x \"a\") (string=? x \"b\"))"
+ " or: perhaps (or (string=? x \"a\") (string=? x \"b\")) -> (member x '(\"a\" \"b\") string=?)")
+ (lint-test "(or (char=? (cadr x) #\\a) (char=? (cadr x) #\\b))"
+ " or: perhaps (or (char=? (cadr x) #\\a) (char=? (cadr x) #\\b)) -> (memv (cadr x) '(#\\a #\\b))")
+ (lint-test "(or (= (let ((z 1)) (display z) z) 1) (= (let ((z 1)) (display z) z) 2))"
+ " or: perhaps (or (= (let ((z 1)) (display z) z) 1) (= (let ((z 1)) (display z) z) 2)) -> (member (let ((z 1)) (display z) z) '(1 2) =)
+ or: display returns its first argument, so this could be omitted: z or: display returns its first argument, so this could be omitted: z")
(lint-test "(or (not (null? x)) (not (pair? x)))" " or: perhaps (or (not (null? x)) (not (pair? x))) -> #t")
+ (lint-test "(or (not (symbol? x)) (keyword? x))" "")
+ (lint-test "(or (not (= x 1)) (not (= y 1)))" " or: perhaps (or (not (= x 1)) (not (= y 1))) -> (not (= x 1 y))")
+ (lint-test "(or (char=? x #\\a) (char=? x #\\A))" " or: perhaps (or (char=? x #\\a) (char=? x #\\A)) -> (char-ci=? x #\\A)")
+ (lint-test "(or (string=? x \"a\") (string=? x \"A\"))" " or: perhaps (or (string=? x \"a\") (string=? x \"A\")) -> (string-ci=? x \"A\")")
+ (lint-test "(or (< x y) (= x y))" " or: perhaps (or (< x y) (= x y)) -> (<= x y)")
+ (lint-test "(or (eq? x #t) (eqv? #f x))" " or: perhaps (or (eq? x #t) (eqv? #f x)) -> (boolean? x) or: eqv? could be not: (eqv? #f x) -> (not x)")
+ (lint-test "(and (< x 1) (string? y))" "") ; check a simplification bug
+ (lint-test "(or (< x 1) (string? y))" "")
+ (lint-test "(or (= x 1) (= x 1))" " or: perhaps (or (= x 1) (= x 1)) -> (= x 1)")
(lint-test "(or (not (= x 1)) (not (= y 1)))" " or: perhaps (or (not (= x 1)) (not (= y 1))) -> (not (= x 1 y))")
- (lint-test "(or (char=? x #\\a) (char=? x #\\A))" " or: perhaps (or (char=? x #\\a) (char=? x #\\A)) -> (char-ci=? x #\\a)")
- (lint-test "(or (string=? x \"a\") (string=? x \"A\"))" " or: perhaps (or (string=? x \"a\") (string=? x \"A\")) -> (string-ci=? x \"a\")")
+ (lint-test "(or (not (= x 1)) (not (= x 2)))" " or: perhaps (or (not (= x 1)) (not (= x 2))) -> #t")
+ (lint-test "(or (not (= x y)) (not (= x z)))" " or: perhaps (or (not (= x y)) (not (= x z))) -> (not (= x y z))")
+ (lint-test "(or () (= x 1))" " or: perhaps (or () (= x 1)) -> ()")
+ (lint-test "(or #f #f)" " or: perhaps (or #f #f) -> #f")
+ (lint-test "(or (and (= n 2) (= d 2)) (and (= n 4) (= d 4)))" " or: perhaps (or (and (= n 2) (= d 2)) (and (= n 4) (= d 4))) -> (or (= n 2 d) (= n 4 d))")
+ (lint-test "(or (= n 2 d) (= n 4 d))" "")
+ (lint-test "(or (< x 1) (>= x 1))" " or: perhaps (or (< x 1) (>= x 1)) -> #t")
+ (lint-test "(or (< x 1) (< x 2))" " or: perhaps (or (< x 1) (< x 2)) -> (< x 2)")
+ (lint-test "(or (< x 1) (> x 2))" " or: perhaps (or (< x 1) (> x 2)) -> (not (<= 1 x 2))")
+ (lint-test "(or (<= x 1) (< x 1))" " or: perhaps (or (<= x 1) (< x 1)) -> (<= x 1)")
+ (lint-test "(or (< x 2) (> x 1))" " or: perhaps (or (< x 2) (> x 1)) -> #t")
+ (lint-test "(or (<= x 1) (<= 2 x))" " or: perhaps (or (<= x 1) (<= 2 x)) -> (not (< 1 x 2))")
+ (lint-test "(or (char<? x #\\1) (char>=? x #\\1))" " or: perhaps (or (char<? x #\\1) (char>=? x #\\1)) -> #t")
+ (lint-test "(or (string<? x \"1\") (string<? x \"2\"))" " or: perhaps (or (string<? x \"1\") (string<? x \"2\")) -> (string<? x \"2\")")
+ (lint-test "(or (integer? x) (< x 3) (> x 12))" " or: perhaps (or (integer? x) (< x 3) (> x 12)) -> (or (integer? x) (not (>= 12 x 3)))")
+ (lint-test "(or (zero? x) (positive? x))" " or: perhaps (or (zero? x) (positive? x)) -> (not (negative? x))")
+ (lint-test "(or (zero? x) (negative? x))" " or: perhaps (or (zero? x) (negative? x)) -> (not (positive? x))")
+
+ (lint-test "(or (and A B) (and (not A) (not B)))" " or: perhaps (or (and A B) (and (not A) (not B))) -> (eq? (not A) (not B))")
+ (lint-test "(or (and A (not B)) (and (not A) B))" " or: perhaps (or (and A (not B)) (and (not A) B)) -> (not (eq? (not A) (not B)))")
+ (lint-test "(or (and A B) (and (not A) C))" " or: perhaps (or (and A B) (and (not A) C)) -> (if A B C)")
+ (lint-test "(if (or (and A B) (and (not A) C)) 32)" " or: perhaps (or (and A B) (and (not A) C)) -> (if A B C)")
+ (lint-test "(or (and (not A) B) (and A C))" " or: perhaps (or (and (not A) B) (and A C)) -> (if A C B)")
+ (lint-test "(or (and A B) (and A C))" " or: perhaps (or (and A B) (and A C)) -> (and A (or B C))")
+ (lint-test "(or (and A B) (and C B))" " or: perhaps (or (and A B) (and C B)) -> (and (or A C) B)")
+ (lint-test "(and (or A B) (or A C))" " and: perhaps (and (or A B) (or A C)) -> (or A (and B C))")
+ (lint-test "(and (or A B) (or C B))" " and: perhaps (and (or A B) (or C B)) -> (or (and A C) B)")
+ (lint-test "(or (not A) (and A B))" " or: perhaps (or (not A) (and A B)) -> (or (not A) B)")
+ (lint-test "(or A (and (not A) B))" " or: perhaps (or A (and (not A) B)) -> (or A B)")
+
+ (lint-test "(or (and x y) (and x z) (and x w))" " or: perhaps (or (and x y) (and x z) (and x w)) -> (and x (or y z w))")
+ (lint-test "(or (and x y) (and z y) (and w y))" " or: perhaps (or (and x y) (and z y) (and w y)) -> (and (or x z w) y)")
+ (lint-test "(or (and x y w) (and x z) (and x a b))" " or: perhaps (or (and x y w) (and x z) (and x a b)) -> (and x (or (and y w) z (and a b)))")
+
+ (lint-test "(or (and (eq? x 'a) (< y 1)) (and (memq x '(b c)) (< y 2) (> z 1)) (and (null? x) (< y 3)))"
+ " or: perhaps (or (and (eq? x 'a) (< y 1)) (and (memq x '(b c)) (< y 2) (> z 1)) (and... ->
+ (case x ((a) (< y 1)) ((b c) (and (< y 2) (> z 1))) ((()) (< y 3)) (else #f))")
+ (lint-test "(or (and (eq? x 'a) (< y 1)) (and (memq x '(b c)) (< y 2) (> z 1)) (< y 3))" "")
+ (lint-test "(or (eq? x 'a) (eq? x 'b) (eq? x 'c) (and (< z 3) (< y 4)))"
+ " or: perhaps (or (eq? x 'a) (eq? x 'b) (eq? x 'c) (and (< z 3) (< y 4))) -> (or (memq x '(a b c)) (and (< z 3) (< y 4)))")
+ (lint-test "(or (< y 4) (eq? x 'a) (eq? x 'b) (eq? x 'c))" " or: perhaps (or (< y 4) (eq? x 'a) (eq? x 'b) (eq? x 'c)) -> (or (< y 4) (memq x '(a b c)))")
+ (lint-test "(or (> y 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (and (< z 3) (< y 4)))"
+ " or: perhaps (or (> y 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (and (< z 3) (< y 4))) -> (or (> y 32) (memq x '(a b c)) (and (< z 3) (< y 4)))")
+ (lint-test "(or (> y 32) (> z 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (< z 3) (< y 4))"
+ " or: perhaps (or (> y 32) (> z 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (< z 3) (< y 4)) -> (or (> y 32) (> z 32) (memq x '(a b c)) (< z 3) (< y 4))")
+ (lint-test "(or (> y 32) (> z 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (< z 3) (> z 4))"
+ " or: perhaps (or (> y 32) (> z 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (< z 3) (> z 4)) ->
+ (or (> y 32) (> z 32) (memq x '(a b c)) (not (<= 3 z 4)))")
+ (lint-test "(or (and (eq? x 'a) (< y 1)) (and (eq? x 'b) (< z 2)) (and (eq? x 'a) (< w 2)))" "")
+
+ (lint-test "(not (or (not x) (not y)))" " not: perhaps (not (or (not x) (not y))) -> (and x y)")
+ (lint-test "(not (or (not (< x y)) (not (equal? a b)) (not z)))"
+ " not: perhaps (not (or (not (< x y)) (not (equal? a b)) (not z))) -> (and (< x y) (equal? a b) z)")
+ (lint-test "(not (and (not x) (not y)))" " not: perhaps (not (and (not x) (not y))) -> (or x y)")
+ (lint-test "(not (and (not (< x y)) (not (equal? a b)) (not z)))"
+ " not: perhaps (not (and (not (< x y)) (not (equal? a b)) (not z))) -> (or (< x y) (equal? a b) z)")
+ (lint-test "(not (or (not x) (< y z) (not (< z x))))"
+ " not: perhaps (not (or (not x) (< y z) (not (< z x)))) -> (and x (>= y z) (< z x))")
+ (lint-test "(not (and (> x 2) (< x 5)))" " not: perhaps (not (and (> x 2) (< x 5))) -> (not (> 5 x 2))")
+ (lint-test "(not (and (> x 2) (not z)))" " not: perhaps (not (and (> x 2) (not z))) -> (or (<= x 2) z)")
+ (lint-test "(not (> x 1))" " not: perhaps (not (> x 1)) -> (<= x 1)")
+ (lint-test "(not (<= 1 x 2))" "")
+ (lint-test "(not (exact? x))" " not: perhaps (not (exact? x)) -> (inexact? x)")
+ (lint-test "(not (not x))" " paranoia: if you want a boolean, (not (not x)) -> (and x #t) not: perhaps (not (not x)) -> x")
+ (lint-test "(not (zero? (logand x (ash 1 z))))" " not: perhaps (not (zero? (logand x (ash 1 z)))) -> (logbit? x z)")
+ (lint-test "(not (zero? (logand x 64)))" " not: perhaps (not (zero? (logand x 64))) -> (logbit? x 6)")
+ (lint-test "(not x y)" " not: not has too many arguments: (not x y)")
+ (lint-test "(not (+ x y))" " not: perhaps (not (+ x y)) -> #f")
+ (lint-test "(not (list x y))" " not: perhaps (not (list x y)) -> #f")
+ (lint-test "(or (not (< x 2)) (not (> x 1)))" " or: perhaps (or (not (< x 2)) (not (> x 1))) -> (not (< 1 x 2))") ; confusing...
+ (lint-test "(or (string? x) (string=? x \"\"))" " or: perhaps (or (string? x) (string=? x \"\")) -> (string? x)")
+ (lint-test "(or (number? x) (= x 1.0))" " or: perhaps (or (number? x) (= x 1.0)) -> (number? x)")
+ (lint-test "(or (not x) (not (pair? x)))" " or: perhaps (or (not x) (not (pair? x))) -> (not (pair? x))")
+ (lint-test "(or (null? x) (not (list? x)))" " or: perhaps (or (null? x) (not (list? x))) -> (not (pair? x))")
+ (lint-test "(or (null? x) (not (string? x)))" " or: perhaps (or (null? x) (not (string? x))) -> (not (string? x))")
+ (lint-test "(or (null? x) (not (pair? x)))" " or: perhaps (or (null? x) (not (pair? x))) -> (not (pair? x))")
+ (lint-test "(or (pair? x) (not (pair? x)))" " or: perhaps (or (pair? x) (not (pair? x))) -> #t")
(lint-test "(and)" " and: perhaps (and) -> #t")
(lint-test "(and x)" " and: perhaps (and x) -> x")
(lint-test "(and x #t)" "")
+ (lint-test "(and x #f)" " and: perhaps (and x #f) -> #f")
+ (lint-test "(and #f (display \"oops\"))" " and: perhaps (and #f (display \"oops\")) -> #f")
+ (lint-test "(and (pair? x) #f (even? y))" " and: perhaps (and (pair? x) #f (even? y)) -> #f")
(lint-test "(and x (not x))" " and: perhaps (and x (not x)) -> #f")
(lint-test "(and x (and x y))" " and: perhaps (and x (and x y)) -> (and x y)")
- (lint-test "(and x (or x y))" " and: perhaps (and x (or x y)) -> x")
+ (lint-test "(and x (or x y))" " and: perhaps (and x (or x y)) -> x")
+ (lint-test "(and (or x y) x)" " and: perhaps (and (or x y) x) -> x")
+ (lint-test "(and (or x y) (or x z))" " and: perhaps (and (or x y) (or x z)) -> (or x (and y z))")
(lint-test "(and (number? x) (pair? x))" " and: perhaps (and (number? x) (pair? x)) -> #f")
- (lint-test "(not (> x 1))" " not: perhaps (not (> x 1)) -> (<= x 1)")
- (lint-test "(not (exact? x))" " not: perhaps (not (exact? x)) -> (inexact? x)")
- (lint-test "(not (not x))" " not: perhaps (not (not x)) -> x")
- (lint-test "(not (zero? (logand x (ash 1 z))))" " not: perhaps (not (zero? (logand x (ash 1 z)))) -> (logbit? x z)")
- (lint-test "(not x y)" " not: not has too many arguments: (not x y) not: perhaps (not x y) -> (not)")
+ (lint-test "(and x (pair? x))" " and: perhaps (and x (pair? x)) -> (pair? x)")
(lint-test "(and x (or y 123) z)" " and: perhaps (and x (or y 123) z) -> (and x z)")
(lint-test "(and (pair? x) (list? x))" " and: perhaps (and (pair? x) (list? x)) -> (pair? x)")
(lint-test "(and (number? x) (rational? x))" " and: perhaps (and (number? x) (rational? x)) -> (rational? x)")
@@ -84849,6 +87136,7 @@ etc
(lint-test "(and x y x y)" " and: perhaps (and x y x y) -> (and x y)")
(lint-test "(and x #f y)" " and: perhaps (and x #f y) -> #f")
(lint-test "(and x y #t z)" " and: perhaps (and x y #t z) -> (and x y z)")
+ (lint-test "(and x y z z y)" " and: perhaps (and x y z z y) -> (and x y z y)")
(lint-test "(and (g x) (g y) (g x))" "")
(lint-test "(and (cadr x) (car y) (cadr x))" "")
(lint-test "(and (cadr x) (car y) (cadr x) (car y))" " and: perhaps (and (cadr x) (car y) (cadr x) (car y)) -> (and (cadr x) (car y))")
@@ -84859,16 +87147,90 @@ etc
(lint-test "(and (integer? x) (number? x))" " and: perhaps (and (integer? x) (number? x)) -> (integer? x)")
(lint-test "(and x y #t)" "")
(lint-test "(and x y (integer? 1))" " and: perhaps (and x y (integer? 1)) -> (and x y #t)")
- (lint-test "(and x (or x y))" " and: perhaps (and x (or x y)) -> x")
(lint-test "(and x (or x))" " and: perhaps (and x (or x)) -> x")
(lint-test "(and (cadr x) (cadr x))" " and: perhaps (and (cadr x) (cadr x)) -> (cadr x)")
(lint-test "(and (< x y) (< y z))" " and: perhaps (and (< x y) (< y z)) -> (< x y z)")
+ (lint-test "(and (< x y) (< y z))" " and: perhaps (and (< x y) (< y z)) -> (< x y z)")
+ (lint-test "(and (< y z) (< x y))" " and: perhaps (and (< y z) (< x y)) -> (< x y z)")
+ (lint-test "(and (< x y) (< x y))" " and: perhaps (and (< x y) (< x y)) -> (< x y)")
+ (lint-test "(and (< x y) (< y x))" " and: perhaps (and (< x y) (< y x)) -> #f")
+ (lint-test "(and (< x y) (< z x))" " and: perhaps (and (< x y) (< z x)) -> (< z x y)")
+ (lint-test "(and (= x y) (= y z))" " and: perhaps (and (= x y) (= y z)) -> (= x y z)")
+ (lint-test "(and (= x y) (= x z))" " and: perhaps (and (= x y) (= x z)) -> (= x y z)")
+ (lint-test "(and (= x y) (= y x))" " and: perhaps (and (= x y) (= y x)) -> (= x y)")
+ (lint-test "(and (= x y) (= z x))" " and: perhaps (and (= x y) (= z x)) -> (= z x y)")
(lint-test "(and (>= x y) (>= z x))" " and: perhaps (and (>= x y) (>= z x)) -> (>= z x y)")
(lint-test "(and (>= x y) (>= x z))" "")
(lint-test "(and (= x y) (= x z))" " and: perhaps (and (= x y) (= x z)) -> (= x y z)")
(lint-test "(and (< x y) (> z y))" " and: perhaps (and (< x y) (> z y)) -> (< x y z)")
- (lint-test "(and (< x y) (< y (let ((z 1)) (display z) z)))" "")
+ (lint-test "(and (< x y) (< y (let ((z 1)) (display z) z)))" " and: display returns its first argument, so this could be omitted: z")
(lint-test "(and (pair? x) (null? x))" " and: perhaps (and (pair? x) (null? x)) -> #f")
+ (lint-test "(and (> x 1) (> x 2))" " and: perhaps (and (> x 1) (> x 2)) -> (> x 2)")
+ (lint-test "(and (< x 1) (< x 2))" " and: perhaps (and (< x 1) (< x 2)) -> (< x 1)")
+ (lint-test "(and (< x 1) (< 2 x))" " and: perhaps (and (< x 1) (< 2 x)) -> #f")
+ (lint-test "(and (> x 1) (> 2 x))" " and: perhaps (and (> x 1) (> 2 x)) -> (> 2 x 1)")
+ (lint-test "(and (integer? x) (exact? x))" " and: perhaps (and (integer? x) (exact? x)) -> (integer? x)")
+ (lint-test "(and (integer? x) #t)" " and: perhaps (and (integer? x) #t) -> (integer? x)")
+ (lint-test "(and (inexact? x) (real? x))" "") ; might be complex
+ (lint-test "(and (infinite? x) (number? x))" " and: perhaps (and (infinite? x) (number? x)) -> (infinite? x)")
+ (lint-test "(and (not (= x 1)) (not (= x 2)))" " and: perhaps (and (not (= x 1)) (not (= x 2))) -> (not (member x '(1 2) =))")
+ (lint-test "(and (not (list? x)) (not (pair? x)))" " and: perhaps (and (not (list? x)) (not (pair? x))) -> (not (list? x))")
+ (lint-test "(and (not (null? x)) (not (pair? x)))" " and: perhaps (and (not (null? x)) (not (pair? x))) -> (not (list? x))")
+ (lint-test "(and (not (null? x)) (not (list? x)))" " and: perhaps (and (not (null? x)) (not (list? x))) -> (not (list? x))")
+ (lint-test "(and (zero? x) (zero? y))" " and: perhaps (and (zero? x) (zero? y)) -> (= 0 x y)")
+ (lint-test "(and (string? x) (string=? x \"\"))" " and: perhaps (and (string? x) (string=? x \"\")) -> (equal? x \"\")")
+ (lint-test "(and (number? x) (= x 1.0))" " and: perhaps (and (number? x) (= x 1.0)) -> (memv x '(1 1.0))")
+ (lint-test "(and (real? x) (= x 1))" " and: perhaps (and (real? x) (= x 1)) -> (memv x '(1 1.0))")
+ (lint-test "(and (integer? x) (= x 1))" " and: perhaps (and (integer? x) (= x 1)) -> (eqv? x 1)")
+ (lint-test "(and (integer? x) (= x y))" "")
+ (lint-test "(and (complex? x) (= x y))" "")
+ (lint-test "(and (symbol? x) (eq? x 'a))" " and: perhaps (and (symbol? x) (eq? x 'a)) -> (eq? x 'a)")
+ (lint-test "(and (keyword? x) (eq? x :a))" " and: perhaps (and (keyword? x) (eq? x :a)) -> (eq? x :a)")
+ (lint-test "(or (= x 1) (not (and (not (= y 2)) (not (= z 3)))))"
+ " or: perhaps (or (= x 1) (not (and (not (= y 2)) (not (= z 3))))) -> (or (= x 1) (= y 2) (= z 3))")
+ (lint-test "(and (= x 1) (not (or (not (= y 2)) (not (= z 3)))))"
+ " and: perhaps (and (= x 1) (not (or (not (= y 2)) (not (= z 3))))) -> (and (= x 1) (= y 2) (= z 3))")
+ (lint-test "(and (pair? x) (not (list? x)))" " and: perhaps (and (pair? x) (not (list? x))) -> #f")
+ (lint-test "(and (list? x) (not (pair? x)))" " and: perhaps (and (list? x) (not (pair? x))) -> (null? x)")
+ (lint-test "(and (not (null? x)) (list? x))" " and: perhaps (and (not (null? x)) (list? x)) -> (pair? x)")
+ (lint-test "(and (pair? x) (not (null? x)))" " and: perhaps (and (pair? x) (not (null? x))) -> (pair? x)")
+ (lint-test "(and (pair? x) (not (string? x)))" " and: perhaps (and (pair? x) (not (string? x))) -> (pair? x)")
+ (lint-test "(and (not (pair? x)) (symbol? x))" " and: perhaps (and (not (pair? x)) (symbol? x)) -> (symbol? x)")
+ (lint-test "(and (symbol? x) (constant? x))" " and: perhaps (and (symbol? x) (constant? x)) -> (constant? x)")
+ (lint-test "(or (symbol? x) (constant? x))" " or: perhaps (or (symbol? x) (constant? x)) -> (symbol? x)")
+ (lint-test "(and (constant? x) (not (symbol? x)))" " and: perhaps (and (constant? x) (not (symbol? x))) -> #f")
+ (lint-test "(and (not (eof-object? x)) (char=? x #\\a))" " and: perhaps (and (not (eof-object? x)) (char=? x #\\a)) -> (eqv? x #\\a)")
+ (lint-test "(and (real? x) (not (rational? x)))" " and: perhaps (and (real? x) (not (rational? x))) -> (float? x)")
+ (lint-test "(and (list? x) (not (proper-list? x)))" "")
+ (lint-test "(and (real? x) (not (integer? x)))" "")
+ (lint-test "(and (not (complex? x)) (real? x))" " and: perhaps (and (not (complex? x)) (real? x)) -> #f")
+ (lint-test "(and (pair? x) (eq? x #<unspecified>))" " and: perhaps (and (pair? x) (eq? x #<unspecified>)) -> #f")
+ (lint-test "(and (eq? x 'a) (pair? x))" " and: perhaps (and (eq? x 'a) (pair? x)) -> #f")
+ (lint-test "(and (not (pair? x)) (or (not (pair? y)) (not (pair? z))))"
+ " and: perhaps (and (not (pair? x)) (or (not (pair? y)) (not (pair? z)))) -> (not (or (pair? x) (and (pair? y) (pair? z))))")
+ (lint-test "(or (not (pair? x)) (and (not (pair? y)) (not (pair? z))))"
+ " or: perhaps (or (not (pair? x)) (and (not (pair? y)) (not (pair? z)))) -> (not (and (pair? x) (or (pair? y) (pair? z))))")
+ (lint-test "(if (and (not (pair? x)) (not (pair? z))) 1 2)" " if: perhaps (and (not (pair? x)) (not (pair? z))) -> (not (or (pair? x) (pair? z)))")
+ (lint-test "(if (or (not (pair? x)) (not (pair? z))) 2 1)" " if: perhaps (or (not (pair? x)) (not (pair? z))) -> (not (and (pair? x) (pair? z)))")
+ (lint-test "(and (number? port) (exact? port) (integer? port))" " and: perhaps (and (number? port) (exact? port) (integer? port)) -> (integer? port)")
+ (lint-test "(and (number? port) (integer? port) (exact? port))" " and: perhaps (and (number? port) (integer? port) (exact? port)) -> (integer? port)")
+ (lint-test "(and (integer? port) (number? port) (real? port))" " and: perhaps (and (integer? port) (number? port) (real? port)) -> (integer? port)")
+ (lint-test "(and (real? port) (number? port) (integer? port))" " and: perhaps (and (real? port) (number? port) (integer? port)) -> (integer? port)")
+ (lint-test "(and (real? port) (integer? port) (integer? port))" " and: perhaps (and (real? port) (integer? port) (integer? port)) -> (integer? port)")
+ (lint-test "(and (real? port) (number? port) (integer? port) (even? port))"
+ " and: perhaps (and (real? port) (number? port) (integer? port) (even? port)) -> (and (integer? port) (even? port))")
+ (lint-test "(and (real? port) (number? port) (integer? port) (even? port) (positive? port))"
+ " and: perhaps (and (real? port) (number? port) (integer? port) (even? port) (positive? port)) ->
+ (and (integer? port) (even? port) (positive? port))")
+ (lint-test "(and (integer? x) (< x 12) (> x 3))" " and: perhaps (and (integer? x) (< x 12) (> x 3)) -> (and (integer? x) (> 12 x 3))")
+ (lint-test "(and (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))"
+ " and: perhaps (and (equal? (car a) (car b)) (equal? (cdr a) (cdr b))) -> (equal? a b)")
+ (lint-test "(and (equal? (caadr a) (caadr b)) (equal? (cdadr a) (cdadr b)))"
+ " and: perhaps (and (equal? (caadr a) (caadr b)) (equal? (cdadr a) (cdadr b))) -> (equal? (cadr a) (cadr b))")
+
+ (lint-test "(string-append x (if y z) x)"
+ " string-append: in (string-append x (if y z) x), string-append's argument 2 should be a string, but #<unspecified> is untyped")
+ (lint-test "(string-append x (if y z w) x)" "")
(lint-test "(car (car x))" " car: perhaps (car (car x)) -> (caar x)")
(lint-test "(cdr (cadr x))" " cdr: perhaps (cdr (cadr x)) -> (cdadr x)")
@@ -84883,81 +87245,267 @@ etc
(lint-test "(cadr (cddr (cdddr (cdr x))))" " cadr: perhaps (cadr (cddr (cdddr (cdr x)))) -> (list-ref x 7)")
(lint-test "(cddddr (cdddr (cddddr x)))" " cddddr: perhaps (cddddr (cdddr (cddddr x))) -> (list-tail x 11)")
- (lint-test "(let ((x 3) (y 5)) (set! x (+ x y)) (+ x y))" " let: this could be omitted: (+ x y)")
- (lint-test "(let ((x 3)) (set! x (+ x 1)) x)" " let: this could be omitted: x")
- (lint-test "(begin (vector-set! x 0 32) (vector-ref x 0))" " begin: this could be omitted: (vector-ref x 0)")
- (lint-test "(begin (list-set! x (* y 2) 32) (list-ref x (* y 2)))" " begin: this could be omitted: (list-ref x (* y 2))")
- (lint-test "(let () (vector-set! x 0 32) (vector-ref x 0))" " let: this could be omitted: (vector-ref x 0)")
- (lint-test "(let () (list-set! x (* y 2) 32) (list-ref x (* y 2)))" " let: this could be omitted: (list-ref x (* y 2))")
- (lint-test "(begin (z 1) (do ((i 0 (+ i 1))) ((= i n) 32)))" " begin: this do-loop could be replaced by 32: (do ((i 0 (+ i 1))) ((= i n) 32))")
- (lint-test "(vector-set! v i (vector-ref v i))" " vector-set!: redundant?: (vector-set! v i (vector-ref v i))")
- (lint-test "(list-set! v (+ i 1) (list-ref v (+ i 1)))" " list-set!: redundant?: (list-set! v (+ i 1) (list-ref v (+ i 1)))")
- (lint-test "(abs () ())" " abs: abs has too many arguments: (abs () ()) abs: abs's argument 1 should be a real?: (): (abs () ())")
- (lint-test "(vector-ref (vector-ref x 0) y)" " vector-ref: perhaps (vector-ref (vector-ref x 0) y) -> (x 0 y)")
+ (lint-test "(let ((x 3) (y 5)) (set! x (+ x y)) (+ x y))" " let: set! returns the new value, so this could be omitted: (+ x y)")
+ (lint-test "(let ((x 3)) (set! x (+ x 1)) x)"
+ " let: set! returns the new value, so this could be omitted: x
+ let: perhaps (let ((x 3)) (set! x (+ x 1)) x) -> (let ((x 3)) (+ x 1))")
+ (lint-test "(let ((x (list 1 2))) (set-car! x 3) (car x))" " let: set-car! returns the new value, so this could be omitted: (car x)")
+ (lint-test "(let ((x (list 1 2))) (set-cdr! x 3) (cdr y))" "")
+ (lint-test "(begin (vector-set! x 0 32) (vector-ref x 0))"
+ " begin: vector-set! returns the new value, so this could be omitted: (vector-ref x 0)")
+ (lint-test "(begin (list-set! x (* y 2) 32) (list-ref x (* y 2)))"
+ " begin: list-set! returns the new value, so this could be omitted: (list-ref x (* y 2))")
+ (lint-test "(let () (vector-set! x 0 32) (vector-ref x 0))"
+ " let: vector-set! returns the new value, so this could be omitted: (vector-ref x 0)")
+ (lint-test "(let () (list-set! x (* y 2) 32) (list-ref x (* y 2)))"
+ " let: list-set! returns the new value, so this could be omitted: (list-ref x (* y 2))")
+ (lint-test "(begin (vector-set! x 0 (* y 2)) (* y 2))"
+ " begin: vector-set! returns the new value, so this could be omitted: (* y 2)")
+ (lint-test "(begin (z 1) (do ((i 0 (+ i 1))) ((= i n) 32)))"
+ " begin: this do-loop could be replaced by 32: (do ((i 0 (+ i 1))) ((= i n) 32))")
+ (lint-test "(vector-set! v i (vector-ref v i))"
+ " vector-set!: redundant vector-set!: (vector-set! v i (vector-ref v i))")
+ (lint-test "(list-set! v (+ i 1) (list-ref v (+ i 1)))"
+ " list-set!: redundant list-set!: (list-set! v (+ i 1) (list-ref v (+ i 1)))")
+ (lint-test "(string-set! v (+ i 1) (string-ref v (+ i 1)))"
+ " string-set!: redundant string-set!: (string-set! v (+ i 1) (string-ref v (+ i 1)))")
+ (lint-test "(vector-ref (vector-ref x 0) y)"
+ " vector-ref: perhaps (vector-ref (vector-ref x 0) y) -> (x 0 y)")
+ (lint-test "(vector-ref (make-vector 3) 1)"
+ " vector-ref: this doesn't make much sense: (vector-ref (make-vector 3) 1)")
(lint-test "(list-ref (list-ref (list-ref (cadr x) (+ y 1)) (+ y 2)) (+ y 3))"
" list-ref: perhaps (list-ref (list-ref (list-ref (cadr x) (+ y 1)) (+ y 2)) (+ y 3)) -> ((cadr x) (+ y 1) (+ y 2) (+ y 3))")
(if (not pure-s7) (lint-test "(current-output-port 123)" " current-output-port: too many arguments: (current-output-port 123)"))
(lint-test "(copy (owlet))" " copy: (copy (owlet)) could be (owlet): owlet is copied internally")
- (lint-test "(gcd x '(asd))" " gcd: gcd's argument 2 should be a rational?: '(asd): (gcd x '(asd))")
+ (lint-test "(gcd x '(asd))" " gcd: in (gcd x '(asd)), gcd's argument 2 should be rational, but '(asd) is a list?")
(lint-test "(string #\\null)" "")
- (lint-test "(string (char->integer x))" " string: string's argument should be a char?: (char->integer x): (string (char->integer x))")
- (lint-test "(close-output-port 022120)" " close-output-port: close-output-port's argument should be a output-port?: 22120: (close-output-port 22120)")
- (lint-test "(close-input-port (log 32))" " close-input-port: close-input-port's argument should be an input-port?: (log 32): (close-input-port (log 32))")
- (lint-test "(call-with-exit (lambda (p) (+ x 1)))" " call-with-exit: exit-function appears to be unused: (call-with-exit (lambda (p) (+ x 1)))")
- (lint-test "(call-with-output-file file (lambda (p) (+ x 1)))" " call-with-output-file: port appears to be unused: (call-with-output-file file (lambda (p) (+ x 1)))")
+ (lint-test "(string (char->integer x))" " string: in (string (char->integer x)), string's argument should be a char, but (char->integer x) is an integer?")
+ (lint-test "(+ 1 (if x 0 #()))" " +: in (+ 1 (if x 0 #())), +'s argument 2 should be a number, but #() is a vector?")
+ (lint-test "(+ 1 (if x #() 0))" " +: in (+ 1 (if x #() 0)), +'s argument 2 should be a number, but #() is a vector?")
+ (lint-test "(+ 1 (dynamic-wind (lambda () #f) (lambda () #()) (lambda () #f)))"
+ " +: in (+ 1 (dynamic-wind (lambda () #f) (lambda () #()) (lambda () #f))), +'s argument 2 should be a number, but #() is a vector?
+ +: this dynamic-wind is pointless, (dynamic-wind (lambda () #f) (lambda () #()) (lambda () #f)) -> #()")
+ (lint-test "(+ 1 (do () ((x) (display 3) #())))" " +: in (+ 1 (do () ((x) (display 3) #()))), +'s argument 2 should be a number, but #() is a vector?")
+ (lint-test "(+ 1 (case x ((0) 1) ((1) #()) (else 2)))" " +: in (+ 1 (case x ((0) 1) ((1) #()) (else 2))), +'s argument 2 should be a number, but #() is a vector?")
+ (lint-test "(+ 1 (values 2 3) #\\a)" " +: in (+ 1 (values 2 3) #\\a), +'s argument 4 should be a number, but #\\a is a char?")
+ (lint-test "(+ 1 (values 2 #\\a) x)" " +: in (+ 1 (values 2 #\\a) x), +'s argument 3 should be a number, but #\\a is a char?")
+ (lint-test "(let () ((lambda (a b) (+ (* 2 a) b)) (values 1 2)))" "") ; don't complain: too few args
+
+ (lint-test "(close-output-port 022120)"
+ " close-output-port: in (close-output-port 22120), close-output-port's argument should be an output-port, but 22120 is an integer?")
+ (lint-test "(close-input-port (log 32))"
+ " close-input-port: in (close-input-port (log 32)), close-input-port's argument should be an input-port, but (log 32) is a number?")
+
+ (lint-test "(+ 1 (call-with-exit (lambda (rtn) (+ x (rtn #\\a)))))"
+ " +: in (+ 1 (call-with-exit (lambda (rtn) (+ x (rtn #\\a))))), +'s argument 2 should be a number, but #\\a is a char?")
+ (lint-test "(call-with-exit (lambda (p) (+ x 1)))"
+ " call-with-exit: call-with-exit exit function p appears to be unused: (call-with-exit (lambda (p) (+ x 1)))
+ call-with-exit: p not used, initially: :call/exit from call-with-exit")
+ (lint-test "(call-with-exit (lambda (return) (display x) (return (+ x y))))" " call-with-exit: return is redundant here: (return (+ x y))")
+ (lint-test "(call-with-exit (lambda (p) (+ p 1)))" " call-with-exit: p is a continuation, but + in (+ p 1) wants a number?")
+ (lint-test "(begin (call-with-exit (lambda (quit) (if (< x 0) (quit (+ x 1))) (display x))) (+ x 2))"
+ " begin: this call-with-exit return value will be ignored: (quit (+ x 1))")
+
+ (lint-test "(+ 1 (call/cc (lambda (c) (if x c (c 2)))))" "")
+ (lint-test "(+ 1 (call/cc (lambda (c) (if x (c 1) 2))))" " +: perhaps call/cc could be call-with-exit: (call/cc (lambda (c) (if x (c 1) 2)))")
+ (lint-test "(call/cc (lambda (p) (+ x (p 1))))" " call/cc: perhaps call/cc could be call-with-exit: (call/cc (lambda (p) (+ x (p 1))))")
+ (lint-test "(call/cc (lambda (p) p))" "")
+ (lint-test "(call/cc (lambda (p) (lambda () p)))" "")
+ (lint-test "(call/cc (lambda (p) (+ p 1)))" " call/cc: p is a continuation, but + in (+ p 1) wants a number?")
+
+ (lint-test "(call-with-output-file file (lambda (p) (+ x 1)))"
+ " call-with-output-file: p not used, initially: (open-output-file) from call-with-output-file")
+ (lint-test "(call-with-input-file \"file\" (lambda (p) (read-char p)))"
+ " call-with-input-file: perhaps (call-with-input-file \"file\" (lambda (p) (read-char p))) -> (call-with-input-file \"file\" read-char)")
(lint-test "(quasiquote 1 2)" " quasiquote: quasiquote has too many arguments: (quasiquote 1 2)")
(lint-test "(apply + 1)" " apply: last argument should be a list: (apply + 1)")
- (lint-test "(apply (lambda (x) (abs x)) y)" " apply: perhaps (lambda (x) (abs x)) -> abs")
+ (lint-test "(apply (lambda (x) (abs x)) y)"
+ " apply: perhaps (assuming y is a list of one element) (apply (lambda (x) (abs x)) y) -> (abs (car y))
+ apply: perhaps (lambda (x) (abs x)) -> abs")
+ (lint-test "(apply (lambda (x) (f x)) y)"
+ " apply: perhaps (assuming y is a list of one element) (apply (lambda (x) (f x)) y) -> (f (car y))
+ apply: perhaps (lambda (x) (f x)) -> f")
+ (lint-test "(apply (lambda (x) x) y)" " apply: perhaps (assuming y is a list of one element) (apply (lambda (x) x) y) -> (car y)")
(lint-test "(apply log (list x y))" " apply: perhaps (apply log (list x y)) -> (log x y)")
- (lint-test "(apply + 1 2 ())" " apply: perhaps (apply + 1 2 ()) -> 3")
+ (lint-test "(apply + 1 2 ())" " apply: perhaps (apply + 1 2 ()) -> (+ 1 2)")
+ (lint-test "(apply + '(1 2 3))" " apply: perhaps (apply + '(1 2 3)) -> (+ 1 2 3)")
+ (lint-test "(apply eq? '(a b))" " apply: perhaps (apply eq? '(a b)) -> (eq? 'a 'b)")
+ (lint-test "(apply f '(a b (c)))" " apply: perhaps (apply f '(a b (c))) -> (f 'a 'b '(c))")
+ (lint-test "(apply f ())" " apply: perhaps (apply f ()) -> (f)")
+ (lint-test "(apply list x)" " apply: perhaps (apply list x) -> x")
(lint-test "(apply real? 1 3 rest)" " apply: too many arguments for real?: (apply real? 1 3 rest)")
+ (lint-test "(apply f)" " apply: perhaps (apply f) -> (f)")
+ (lint-test "(apply + (cons a b))" " apply: perhaps (apply + (cons a b)) -> (apply + a b)")
+ (lint-test "(apply string (reverse chars))" " apply: perhaps (apply string (reverse chars)) -> (reverse (apply string chars))")
+ (lint-test "(apply + x y ())" " apply: perhaps (apply + x y ()) -> (+ x y)")
+ (lint-test "(apply log x '())" " apply: perhaps (apply log x '()) -> (log x) apply: quote is not needed here: '()")
+ (lint-test "(apply f (append (list y z) a b))" " apply: perhaps (apply f (append (list y z) a b)) -> (apply f y z (append a b))")
+ (lint-test "(apply f (append (list y z)))" " apply: perhaps (apply f (append (list y z))) -> (apply f y z ()) apply: perhaps (append (list y z)) -> (list y z)")
+ (lint-test "(apply f (append (list y z) a))" " apply: perhaps (apply f (append (list y z) a)) -> (apply f y z a)")
+ (lint-test "(apply map f (list x y))" " apply: perhaps (apply map f (list x y)) -> (map f x y)")
+ (lint-test "(apply string-append (map (lambda (x) (string-append x \" \")) input-files))"
+ " apply: perhaps (apply string-append (map (lambda (x) (string-append x \" \")) input-files)) -> (format #f \"~{~A ~}\" input-files)")
+ (lint-test "(apply string-append (map symbol->string args))"
+ " apply: perhaps (apply string-append (map symbol->string args)) -> (format #f \"~{~A~}\" args)")
+ (lint-test "(apply f y z (list a b))" " apply: perhaps (apply f y z (list a b)) -> (f y z a b)")
+ (lint-test "(apply append (map vector->list args))"
+ " apply: perhaps (apply append (map vector->list args)) -> (vector->list (apply append args))")
+
+ (lint-test "(eval '(+ 1 2))" " eval: perhaps (eval '(+ 1 2)) -> (+ 1 2)")
+ (lint-test "(eval 32)" " eval: this eval is pointless; perhaps (eval 32) -> 32")
+ (lint-test "(eval 'x)" " eval: perhaps (eval 'x) -> x")
+ (lint-test "(eval (string->symbol \"x\"))" " eval: perhaps (eval (string->symbol \"x\")) -> x")
+ (lint-test "(eval (read (open-input-string expr)))" " eval: perhaps (eval (read (open-input-string expr))) -> (eval-string expr)")
+
(lint-test "(with-let 123 123)" " with-let: with-let: first argument should be an environment: (with-let 123 123)")
- (lint-test "(with-let random .1)" " with-let: with-let: first argument should be an environment: (with-let random 0.1)")
(lint-test "(with-let (rootlet) 1)" "")
+ (lint-test "(string-length \"asdf\")" " string-length: perhaps (string-length \"asdf\") -> 4")
+ (lint-test "(> 0 (string-length x))" " >: string-length can't be negative: (> 0 (string-length x))")
+ (lint-test "(< (string-length x) 0)" " <: string-length can't be negative: (< (string-length x) 0)")
- (lint-test "(round '(1))" " round: round's argument should be a real?: '(1): (round '(1))")
+ (lint-test "(round '(1))" " round: in (round '(1)), round's argument should be real, but '(1) is a list?")
(lint-test "(round '1.2)" " round: quote is not needed here: '1.2")
- (lint-test "(round (integer->char 96))" " round: round's argument should be a real?: (integer->char 96): (round (integer->char 96))")
+ (lint-test "(round (integer->char 96))"
+ " round: in (round (integer->char 96)), round's argument should be real, but (integer->char 96) is a char?
+ round: perhaps (integer->char 96) -> #\\`")
(lint-test "(let ((v (make-vector 3))) (vector-set! v 3.14 #\\a))"
- " let: vector-set!'s argument 2 should be an integer?: 3.14: (vector-set! v 3.14 #\\a)")
+ "let: perhaps (let ((v (make-vector 3))) (vector-set! v 3.14 #\\a)) -> (vector-set! (make-vector 3) 3.14 #\\a)
+ let: in (vector-set! v 3.14 #\\a), vector-set!'s argument 2 should be an integer, but 3.14 is real?")
(lint-test "(let ((v (make-float-vector 3))) (float-vector-set! v 3.14 1))"
- " let: float-vector-set!'s argument 2 should be an integer?: 3.14: (float-vector-set! v 3.14 1)")
- (lint-test "(let ((v (make-float-vector 3))) (float-vector-set! v 1 3.14))" "")
+ "let: perhaps (let ((v (make-float-vector 3))) (float-vector-set! v 3.14 1)) -> (float-vector-set! (make-float-vector 3) 3.14 1)
+ let: in (float-vector-set! v 3.14 1), float-vector-set!'s argument 2 should be an integer, but 3.14 is real?")
+ (lint-test "(let ((v (make-float-vector 3))) (float-vector-set! v 1 3.14))"
+ "let: perhaps (let ((v (make-float-vector 3))) (float-vector-set! v 1 3.14)) -> (float-vector-set! (make-float-vector 3) 1 3.14)")
(lint-test "(let ((v (make-float-vector 3))) (float-vector-set! v 1 #\\a))"
- " let: float-vector-set!'s argument 3 should be a real?: #\\a: (float-vector-set! v 1 #\\a)")
- (lint-test "(append () '(1 2) 1)" "")
+ "let: perhaps (let ((v (make-float-vector 3))) (float-vector-set! v 1 #\\a)) -> (float-vector-set! (make-float-vector 3) 1 #\\a)
+ let: in (float-vector-set! v 1 #\\a), float-vector-set!'s argument 3 should be real, but #\\a is a char?")
(lint-test "(vector-set! (vector-ref a i) j x)" " vector-set!: perhaps (vector-set! (vector-ref a i) j x) -> (set! (a i j) x)")
- (lint-test "(round (char-position #\\a \"asb\"))" "")
+ (lint-test "(round (char-position #\\a \"asb\"))"
+ " round: in (round (char-position #\\a \"asb\")), round's argument should be real, but (char-position #\\a \"asb\") might also be boolean?")
(lint-test "(string-ref (char-position #\\a \"asb\") 1)"
- " string-ref: string-ref's argument 1 should be a string?: (char-position #\\a \"asb\"): (string-ref (char-position #\\a \"asb\") 1)")
+ " string-ref: in (string-ref (char-position #\\a \"asb\") 1),
+ string-ref's argument 1 should be a string, but (char-position #\\a \"asb\") is an integer or a boolean?")
(lint-test "(char-position \"xyz\" \"asb\")" "")
(lint-test "(if (null? (cons x y)) 1.0 0.0)" " if: perhaps (if (null? (cons x y)) 1.0 0.0) -> 0.0")
- (lint-test "(if (null (cdr x)) 0)" " if: misspelled 'null? in (null (cdr x))?")
- (lint-test "(if (pair? (sin x)) 1.0 0.0)" " if: perhaps (if (pair? (sin x)) 1.0 0.0) -> 0.0")
- (lint-test "(if (number? (sin x)) 1.0)" " if: perhaps (if (number? (sin x)) 1.0) -> 1.0")
- (lint-test "(if (number? (car x)) 1.0)" "")
- (lint-test "(if (real? (sin x)) 1.0)" "")
-
-; (lint-test "(real? (imag-part z))" "...") ; this should be reduced outside if...
-; (lint-test "(char? (string-ref z y))" "...")
-
- (lint-test "(if (number? 1.0) 1.0 0.0)" " if: perhaps (if (number? 1.0) 1.0 0.0) -> 1.0")
- (lint-test "(if (pair? 1.0) 1.0 0.0)" " if: perhaps (if (pair? 1.0) 1.0 0.0) -> 0.0")
- (lint-test "(if (symbol? (string->symbol x)) 0 1)" " if: perhaps (if (symbol? (string->symbol x)) 0 1) -> 0")
- (lint-test "(if (symbol? (symbol->string x)) 0 1)" " if: perhaps (if (symbol? (symbol->string x)) 0 1) -> 1")
- (lint-test "(and (symbol? x) (gensym? x))" " and: perhaps (and (symbol? x) (gensym? x)) -> (gensym? x)")
+ (lint-test "(if (null (cdr x)) 0)" " if: misspelled 'null? in (null (cdr x))?")
+ (lint-test "(if (pair? (sin x)) 1.0 0.0)" " if: perhaps (if (pair? (sin x)) 1.0 0.0) -> 0.0")
+ (lint-test "(if (number? (sin x)) 1.0)" " if: perhaps (if (number? (sin x)) 1.0) -> 1.0")
+ (lint-test "(if (number? (car x)) 1.0)" "")
+ (lint-test "(if (real? (sin x)) 1.0)" "")
+ (lint-test "(let ((list x)) (null? list))" " let: perhaps (let ((list x)) (null? list)) -> (null? x)")
+
+ (lint-test "(set! x (real? (imag-part z)))" "set!: perhaps (real? (imag-part z)) -> #t set!: (real? (imag-part z)) is always #t")
+ (lint-test "(let ((x (char? (string-ref z y)))) x)"
+ " let: perhaps (char? (string-ref z y)) -> #t
+ let: (char? (string-ref z y)) is always #t
+ let: perhaps (let ((x (char? (string-ref z y)))) x) -> (char? (string-ref z y))")
+ (lint-test "(case (number? (log x y)) ((#f) 0) ((#t) 1))" " case: perhaps (number? (log x y)) -> #t case: (number? (log x y)) is always #t")
+ (lint-test "(let () (define (f9 x) (write x)) (f9 (vector? (vector))))"
+ " let: perhaps (... (define (f9 x) (write x)) (f9 (vector? (vector)))) -> (... (let ((x (vector? (vector)))) (write x)))
+ f9: leaving aside write's optional arg, f9 could be (define f9 write)
+ let: perhaps (vector? (vector)) -> #t
+ let: (vector? (vector)) is always #t")
+ (lint-test "(display (string? (string)))"
+ " display: perhaps (string? (string)) -> #t
+ display: (string? (string)) is always #t
+ display: (string) could be \"\"")
+ (lint-test "(if (number? 1.0) 1.0 0.0)" " if: perhaps (if (number? 1.0) 1.0 0.0) -> 1.0")
+ (lint-test "(if (pair? 1.0) 1.0 0.0)" " if: perhaps (if (pair? 1.0) 1.0 0.0) -> 0.0")
+ (lint-test "(if (symbol? (string->symbol x)) 0 1)" " if: perhaps (if (symbol? (string->symbol x)) 0 1) -> 0")
+ (lint-test "(if (symbol? (symbol->string x)) 0 1)" " if: perhaps (if (symbol? (symbol->string x)) 0 1) -> 1")
+ (lint-test "(and (symbol? x) (gensym? x))" " and: perhaps (and (symbol? x) (gensym? x)) -> (gensym? x)")
(lint-test "(integer? (*s7* 'vector-print-length))" " integer?: unknown *s7* field: 'vector-print-length")
(lint-test "(dynamic-wind (lambda () (s7-version)) (lambda () (list)) (lambda () #f))"
- " dynamic-wind: perhaps (lambda () (s7-version)) -> s7-version dynamic-wind: perhaps (lambda () (list)) -> list")
- (lint-test "(lambda args (apply + args))" " lambda: perhaps (lambda args (apply + args)) -> +")
- (lint-test "(define-macro (mac a) `(+ ,,a 1))" " mac: define-macro probably has too many unquotes: ({list} '+ (unquote a) 1)")
-
+ " dynamic-wind: this could be omitted: (s7-version) in (lambda () (s7-version))
+ dynamic-wind: this dynamic-wind is pointless, (dynamic-wind (lambda () (s7-version)) (lambda () (list)) (lambda () #f)) -> (list)
+ dynamic-wind: perhaps (lambda () (s7-version)) -> s7-version
+ dynamic-wind: perhaps (lambda () (list)) -> list")
+ (lint-test "(lambda args (apply + args))" " lambda: perhaps (lambda args (apply + args)) -> +")
+ (lint-test "(define-macro (mac a) `(+ ,,a 1))" " mac: define-macro probably has too many unquotes: ({list} '+ (unquote a) 1)")
+ (lint-test "(let ((x 1) (y '(1 2))) `(,x , at y))"
+ " let: perhaps (let ((x 1) (y '(1 2))) ({list} x ({apply_values} y))) -> ({list} 1 ({apply_values} '(1 2)))")
+
+ (lint-test "(display #\\escape)" "")
;; these tickled a lint bug
(lint-test "(define :xxx 321)" " define: keywords are constants :xxx")
(lint-test "(define (:yyy a) a)" " define: keywords are constants :yyy")
-
+ (lint-test "(cons ((pair? x) 2) y)" " cons: cons's argument ((pair? x) 2) looks odd: pair? returns boolean? which is not applicable")
+
+ (lint-test "(let ((x 1) (y 2)) (if (= x 1) (begin (define (f1) x) (define (f2) (+ x 1)))) (f1 1))"
+ " let: f1 has too many arguments: (f1 1)
+ let: y not used, initially: 2 from let")
+ ;; ideally we'd also point out that f2 is unused
+ (lint-test "(let ((x 1) (y 2)) (when (= x 1) (begin (define (f1) x) (define (f2) (+ x 1)))) (f1 1))"
+ " let: redundant begin: (begin (define (f1) x) (define (f2) (+ x 1)))
+ let: f1 has too many arguments: (f1 1)
+ let: y not used, initially: 2 from let")
+ ;; and here also
+ (lint-test "(defmacro hi ())" " defmacro: defmacro declaration is messed up: (defmacro hi ())")
+ (lint-test "(defmacro hi (a b a) a)" " defmacro: defmacro parameter is repeated: (a b a) hi: defmacro parameter a is declared twice")
+ (lint-test "(defmacro hi (a b) `(+ ,a ,b))"
+ " defmacro: defmacro is deprecated; perhaps (defmacro hi (a b) ({list} '+ a b)) -> (define-macro (hi a b) ({list} '+ a b))")
+ (lint-test "(defmacro hi a `(+ ,a ,b))"
+ " defmacro: defmacro is deprecated; perhaps (defmacro hi a ({list} '+ a b)) -> (define-macro (hi . a) ({list} '+ a b))")
+ (lint-test "(define)" " define: (define) makes no sense")
+ (lint-test "(define a)" " define: (define a) has no value?")
+ (lint-test "(define a . b)" " define: (define a . b) makes no sense")
+ (lint-test "(define a b c)" " define: (define a b c) has too many values?")
+ (lint-test "(define a a)" " define: this define is either not needed, or is an error: (define a a)")
+ (lint-test "(define #(0) 2)" " define: strange form: (define #(0) 2)")
+ (lint-test "(define (f1 a) (abs a))" " f1: f1 could be (define f1 abs)")
+ (lint-test "(define (f1 a b) \"a docstring\" (log a b))" " f1: f1 could be (define f1 log)")
+ (lint-test "(let () (define (f1 a b) (* 2 (log a b))) (define (f2 a b) (f1 a b)) (f2 1 2))"
+ " f2: f2 could be (define f2 f1) f1 is called only in f2")
+ (lint-test "(define (f x) (define aaa 1) (define aaa 2) (+ aaa 1))"
+ " f: define variable aaa is redefined in the define body. Perhaps use set! instead: (set! aaa 2)
+ f: aaa not used, initially: 1 from define")
+ (lint-test "(lambda ())" " lambda: lambda is messed up in (lambda ())")
+ (lint-test "(lambda (a b a) a)" " lambda: lambda parameter is repeated: (a b a) lambda: lambda parameter a is declared twice")
+ (lint-test "((lambda () 32) 0)" " (lambda () 32): perhaps ((lambda () 32) 0) -> 32")
+ (lint-test "((lambda (a b) (+ a b)) 1)"
+ " (lambda (a b) (+ a b)): perhaps ((lambda (a b) (+ a b)) 1) -> (let ((a 1) (b #f)) (+ a b))
+ (lambda (a b) (+ a b)): perhaps (lambda (a b) (+ a b)) -> +")
+ (lint-test "(lambda* (:key a :optional b :rest c :allow-other-keys) a)" " lambda*: :key is no longer accepted: (:key a :optional b :rest ...")
+ (lint-test "(lambda* (a :rest) a)" " lambda*: :rest parameter needs a name: (a :rest)")
+ (lint-test "(lambda* (a :rest (b 1)) b)" " lambda*: :rest parameter can't specify a default value: (a :rest (b 1))")
+ (lint-test "(lambda* (a :allow-other-keys b) a)" " lambda*: :allow-other-keys should be at the end of the parameter list:(a :allow-other-keys b)")
+ (lint-test "(lambda (a :b c) a)" " lambda: lambda arglist can't handle keywords (use lambda*)")
+ (lint-test "(lambda (a b) (>= b a))" " lambda: perhaps (lambda (a b) (>= b a)) -> <=")
+ (lint-test "(lambda (a b c) (/ a b c))" " lambda: perhaps (lambda (a b c) (/ a b c)) -> /")
+ (lint-test "(lambda (a . b) (apply + a b))" " lambda: perhaps (lambda (a . b) (apply + a b)) -> +")
+ (lint-test "(lambda args (apply and args))" "")
+ (lint-test "(lambda (x y) (and x y))" "")
+ (lint-test "((lambda (x) x) 32)" " (lambda (x) x): perhaps ((lambda (x) x) 32) -> 32")
+ (lint-test "((lambda (x) (cdr (cdr (car x)))) z)"
+ " (lambda (x) (cdr (cdr (car x)))): perhaps ((lambda (x) (cdr (cdr (car x)))) z) -> (let ((x z)) (cdr (cdr (car x))))
+ (lambda (x) (cdr (cdr (car x)))): perhaps (lambda (x) (cdr (cdr (car x)))) -> cddar
+ (lambda (x) (cdr (cdr (car x)))): perhaps (cdr (cdr (car x))) -> (cddar x)")
+ (lint-test "((lambda () (+ x y)))" " (lambda () (+ x y)): perhaps ((lambda () (+ x y))) -> (+ x y)")
+ (lint-test "((lambda (x) (+ x 1)) y)" " (lambda (x) (+ x 1)): perhaps ((lambda (x) (+ x 1)) y) -> (let ((x y)) (+ x 1))")
+ (lint-test "((lambda x (+ (car x) 1)) y)" " (lambda x (+ (car x) 1)): perhaps ((lambda x (+ (car x) 1)) y) -> (let ((x (list y))) (+ (car x) 1))")
+ (lint-test "((lambda x (+ (car x) 1)) y z)" " (lambda x (+ (car x) 1)): perhaps ((lambda x (+ (car x) 1)) y z) -> (let ((x (list y z))) (+ (car x) 1))")
+ (lint-test "((lambda x (+ (car x) 1)))" " (lambda x (+ (car x) 1)): perhaps ((lambda x (+ (car x) 1))) -> (let ((x (list))) (+ (car x) 1))")
+ (lint-test "((lambda (x . y) (+ x (car y))) a b)"
+ " (lambda (x . y) (+ x (car y))): perhaps ((lambda (x . y) (+ x (car y))) a b) -> (let ((x a) (y (list b))) (+ x (car y)))")
+ (lint-test "((lambda* ((x 1)) (+ x 1)))" " (lambda* ((x 1)) (+ x 1)): perhaps ((lambda* ((x 1)) (+ x 1))) -> (let ((x 1)) (+ x 1))")
+ (lint-test "((lambda* ((x 1)) (+ x 1)) y)" " (lambda* ((x 1)) (+ x 1)): perhaps ((lambda* ((x 1)) (+ x 1)) y) -> (let ((x y)) (+ x 1))")
+ (lint-test "((lambda* (x (y 1)) (+ x y)) z)" " (lambda* (x (y 1)) (+ x y)): perhaps ((lambda* (x (y 1)) (+ x y)) z) -> (let* ((x z) (y 1)) (+ x y))")
+ (lint-test "((lambda* (x (y 1)) (+ x y)) a b)" " (lambda* (x (y 1)) (+ x y)): perhaps ((lambda* (x (y 1)) (+ x y)) a b) -> (let* ((x a) (y b)) (+ x y))")
+ (lint-test "((lambda* (x (y 1)) (+ x y)))" " (lambda* (x (y 1)) (+ x y)): perhaps ((lambda* (x (y 1)) (+ x y))) -> (let* ((x #f) (y 1)) (+ x y))")
+
+ (lint-test "(let () (define (f1 a) a) (f1 2 3))"
+ " let: perhaps (... (define (f1 a) a) (f1 2 3)) -> (... (let ((a 2)) a))
+ let: f1 has too many arguments: (f1 2 3)")
+ (lint-test "(let () (define-macro (m1 a) a) (m1 2 3))" " let: m1 has too many arguments: (m1 2 3)")
+ (lint-test "(let () (define-macro (m2 b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (+ a (m2 a))))"
+ " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a, +")
+ (lint-test "(let () (define-macro (m3 b) `(let ((a 12)) (+ (symbol->value ,b) a))) (let ((a 1)) (+ a (m3 'a))))"
+ " let: possible problematic macro expansion: (m3 'a) could conceivably collide with subsequently defined 'a")
+
+ (lint-test "(define pi (acos -1))" " define: (acos -1) is one of its many names, but pi a predefined constant in s7 pi: perhaps (acos -1) -> pi")
+ (lint-test "(+ x (atan 0 -1))" " +: perhaps (+ x (atan 0 -1)) -> (+ x pi)")
(lint-test "(define (f1) 32)" "")
(lint-test "(define (f2 a) a)" "")
(lint-test "(define (f3 . a) a)" "")
@@ -84978,54 +87526,98 @@ etc
(lint-test "(define f4 (lambda (a b) a))" "")
(lint-test "(define f5 (lambda (a . b) a))" "")
- (lint-test "(define-macro (f1) 32)" "")
+ (lint-test "(define-macro (f1) 32)" " define-macro: perhaps (define-macro (f1) 32) -> (define f1 32)")
(lint-test "(define-macro (f2 a) a)" "")
(lint-test "(define-macro (f3 . a) a)" "")
(lint-test "(define-macro (f4 a b) a)" "")
(lint-test "(define-macro (f5 a . b) a)" "")
(lint-test "(define-macro (f6 a b . c) a)" "")
- (lint-test "(let ((a 1)) (define (f1 b) (+ a b)) (f1 0))" "")
-
- (lint-test "(let f1 ((a 1)) a)" " let: let variable f1 not used")
+ (lint-test "(let ((a 1)) (define (f1 b) (+ a b)) (f1 0))"
+ " let: perhaps (... (define (f1 b) (+ a b)) (f1 0)) -> (... (let ((b 0)) (+ a b)))
+ a is used only in f1")
+ (lint-test "(let f1 ((a 1)) a)" " let: f1 not used, value: (let f1 ((a 1)) a) let: perhaps (let f1 ((a 1)) a) -> 1")
(lint-test "(let f1 ((a 1)) (f1 a))" "")
- (lint-test "(let f1 ((a 1)) (+ a (f1)))" " let: f1 needs 1 argument: (f1)")
- (lint-test "(let f1 ((a 1)) (f1 a 2))" " let: f1 has too many arguments: (f1 a 2)")
+ (lint-test "(let f1 ((a 1)) (+ a (f1)))" " f1: f1 needs 1 argument: (f1)")
+ (lint-test "(let f1 ((a 1)) (f1 a 2))" " f1: f1 has too many arguments: (f1 a 2)")
(lint-test "(define f7 (let ((a 1)) (lambda () a)))" "")
(lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7))" "")
- (lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7 1))" "...")
-
+; (lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7 1))" "...")
- (lint-test "(let () (define (f1) 32) (f1))" "")
- (lint-test "(let () (define (f1) 32) (f1 32))" " let: f1 has too many arguments: (f1 32)")
- (lint-test "(let () (define (f2 a) a) (f2))" " let: f2 needs 1 argument: (f2)")
- (lint-test "(let () (define (f2 a) a) (f2 3))" "")
- (lint-test "(let () (define (f2 a) a) (f2 3 32))" " let: f2 has too many arguments: (f2 3 32)")
+ (lint-test "(let () (define (f1) 32) (f1))" " let: perhaps (... (define (f1) 32) (f1)) -> (... 32)")
+ (lint-test "(let () (define (f1) 32) (f1 32))"
+ " let: perhaps (... (define (f1) 32) (f1 32)) -> (... 32)
+ let: f1 has too many arguments: (f1 32)")
+ (lint-test "(let () (define (f2 a) a) (f2))"
+ " let: perhaps (... (define (f2 a) a) (f2)) -> (... (let () a))
+ let: f2 needs 1 argument: (f2)")
+ (lint-test "(let () (define (f2 a) a) (f2 3))" " let: perhaps (... (define (f2 a) a) (f2 3)) -> (... (let ((a 3)) a))")
+ (lint-test "(let () (define (f2 a) a) (f2 3 32))"
+ " let: perhaps (... (define (f2 a) a) (f2 3 32)) -> (... (let ((a 3)) a))
+ let: f2 has too many arguments: (f2 3 32)")
(lint-test "(let () (define (f3 . a) a) (f3))" "")
(lint-test "(let () (define (f3 . a) a) (f3 1))" "")
(lint-test "(let () (define (f3 . a) a) (f3 1 2 3))" "")
- (lint-test "(let () (define (f4 a b) a) (f4))" " let: f4 needs 2 arguments: (f4)")
- (lint-test "(let () (define (f4 a b) a) (f4 1))" " let: f4 needs 2 arguments: (f4 1)")
- (lint-test "(let () (define (f4 a b) a) (f4 1 2))" "")
- (lint-test "(let () (define (f4 a b) a) (f4 1 2 3))" " let: f4 has too many arguments: (f4 1 2 3)")
- (lint-test "(let () (define (f5 a . b) a) (f5))" " let: f5 needs 1 argument: (f5)")
+ (lint-test "(let () (define (f4 a b) a) (f4))"
+ " let: perhaps (... (define (f4 a b) a) (f4)) -> (... (let () a))
+ let: f4 needs 2 arguments: (f4)")
+ (lint-test "(let () (define (f4 a b) a) (f4 1))"
+ " let: perhaps (... (define (f4 a b) a) (f4 1)) -> (... (let ((a 1)) a))
+ let: f4 needs 2 arguments: (f4 1)")
+ (lint-test "(let () (define (f4 a b) a) (f4 1 2))"
+ " let: perhaps (... (define (f4 a b) a) (f4 1 2)) -> (... (let ((a 1) (b 2)) a))
+ let: f4's parameter 2 is not used, but a value is passed: 2")
+ (lint-test "(let () (define (f4 a b) a) (f4 1 2 3))"
+ " let: perhaps (... (define (f4 a b) a) (f4 1 2 3)) -> (... (let ((a 1) (b 2)) a))
+ let: f4 has too many arguments: (f4 1 2 3)
+ let: f4's parameter 2 is not used, but a value is passed: 2")
+
+ (lint-test "(let () (define (f5 a . b) a) (f5))" " let: f5 needs 1 argument: (f5)")
(lint-test "(let () (define (f5 a . b) a) (f5 1))" "")
- (lint-test "(let () (define (f5 a . b) a) (f5 1 2))" "")
- (lint-test "(let () (define (f5 a . b) a) (f5 1 2 3 4))" "")
- (lint-test "(let () (define (f6 a b . c) a) (f6))" " let: f6 needs 2 arguments: (f6)")
- (lint-test "(let () (define (f6 a b . c) a) (f6 1))" " let: f6 needs 2 arguments: (f6 1)")
- (lint-test "(let () (define (f6 a b . c) a) (f6 1 2))" "")
- (lint-test "(let () (define (f6 a b . c) a) (f6 1 2 3))" "")
- (lint-test "(let () (define (f6 a b . c) a) (f6 1 2 3 4))" "")
+ (lint-test "(let () (define (f5 a . b) a) (f5 1 2))" " let: f5's parameter 2 is not used, but a value is passed: 2")
+ (lint-test "(let () (define (f5 a . b) a) (f5 1 2 3 4))" " let: f5's parameter 2 is not used, but a value is passed: 2")
+ (lint-test "(let () (define (f6 a b . c) a) (f6))" " let: f6 needs 2 arguments: (f6)")
+ (lint-test "(let () (define (f6 a b . c) a) (f6 1))" " let: f6 needs 2 arguments: (f6 1)")
+ (lint-test "(let () (define (f6 a b . c) a) (f6 1 2))" " let: f6's parameter 2 is not used, but a value is passed: 2")
+ (lint-test "(let () (define (f6 a b . c) a) (f6 1 2 3))"
+ " let: f6's parameter 2 is not used, but a value is passed: 2
+ let: f6's parameter 3 is not used, but a value is passed: 3")
+ (lint-test "(let () (define (f6 a b . c) a) (f6 1 2 3 4))"
+ " let: f6's parameter 2 is not used, but a value is passed: 2
+ let: f6's parameter 3 is not used, but a value is passed: 3")
+
+ (lint-test "(let () (define (f7 x) (+ x 1)) (f7 3) 4)"
+ " let: perhaps (... (define (f7 x) (+ x 1)) (f7 3) 4) -> (... (let ((x 3)) (+ x 1)) 4)
+ let: this could be omitted: (f7 3)")
+ (lint-test "(let () (define* (f7 x) (+ x 1)) (f7 3) 4)"
+ " let: perhaps (... (define* (f7 x) (+ x 1)) (f7 3) 4) -> (... (let ((x 3)) (+ x 1)) 4)
+ let: this could be omitted: (f7 3)")
+ (lint-test "(let () (define (f7 x) (display x)) (f7 3) 4)"
+ " let: perhaps (... (define (f7 x) (display x)) (f7 3) 4) -> (... (let ((x 3)) (display x)) 4)
+ f7: leaving aside display's optional arg, f7 could be (define f7 display)")
+ (lint-test "(let () (define (f7 x) (+ x 1)) (f7 (display 3)) 4)"
+ " let: perhaps (... (define (f7 x) (+ x 1)) (f7 (display 3)) 4) -> (... (let ((x (display 3))) (+ x 1)) 4)")
+ (lint-test "(let () (define* (f7 x) (+ x 1)) (let ((y 3)) (f7 y) 4))" " let: this could be omitted: (f7 y)")
+ (lint-test "(let () (define (f1 . x) (apply + x)) (f1 1 2))" " f1: f1 could be (define f1 +)")
+ (lint-test "(let () (define (f1 a . b) (apply + a b)) (f1 1 2))" " f1: f1 could be (define f1 +)")
+ (lint-test "(let () (define (f1 x) (abs x)) (f1 1))"
+ " let: perhaps (... (define (f1 x) (abs x)) (f1 1)) -> (... (let ((x 1)) (abs x)))
+ f1: f1 could be (define f1 abs)")
+ (lint-test "(let () (define (f1 x) (cdr (car x))) (f1 z))"
+ " let: perhaps (... (define (f1 x) (cdr (car x))) (f1 z)) -> (... (let ((x z)) (cdr (car x))))
+ f1: f1 could be (define f1 cdar)
+ f1: perhaps (cdr (car x)) -> (cdar x)")
(lint-test "(begin (define* (f1) 32) (f1))" " f1: define* could be define")
- (lint-test "(begin (define* (f1) 32) (f1 :a 1))" " f1: define* could be define begin: f1 has too many arguments: (f1 :a 1)")
+ (lint-test "(begin (define* (f1) 32) (f1 :a 1))"
+ " f1: define* could be define begin: f1 has too many arguments: (f1 :a 1) begin: f1 keyword argument :a (in (f1 :a 1)) does not match any argument in ()")
(lint-test "(begin (define* (f2 a) a) (f2))" "")
(lint-test "(begin (define* (f2 a) a) (f2 1))" "")
(lint-test "(begin (define* (f2 a) a) (f2 :a 1))" "")
(lint-test "(begin (define* (f2 a) a) (f2 :b 1))" " begin: f2 keyword argument :b (in (f2 :b 1)) does not match any argument in (a)")
- (lint-test "(begin (define* (f2 a) a) (f2 :a 1 2))" " begin: f2 has too many arguments: (f2 :a 1 2)")
- (lint-test "(begin (define* (f2 a) a) (f2 :a 1 :a 2))" " begin: f2 has too many arguments: (f2 :a 1 :a 2)")
+ (lint-test "(begin (define* (f2 a) a) (f2 :a 1 2))"
+ " begin: f2 has too many arguments: (f2 :a 1 2) begin: non-keyword argument 2 follows previous keyword")
+ (lint-test "(begin (define* (f2 a) a) (f2 :a 1 :a 2))" " begin: f2 has too many arguments: (f2 :a 1 :a 2) begin: :a is repeated in (:a 1 :a 2)")
(lint-test "(begin (define* (f2 a) a) (f2 1 2))" " begin: f2 has too many arguments: (f2 1 2)")
(lint-test "(begin (define* (f3 . a) a) (f3))" "")
(lint-test "(begin (define* (f3 . a) a) (f3 1))" "")
@@ -85037,33 +87629,761 @@ etc
(lint-test "(begin (define* (f4 a (b 2)) a) (f4 :c 1))" " begin: f4 keyword argument :c (in (f4 :c 1)) does not match any argument in (a (b 2))")
(lint-test "(begin (define* (f4 a (b 2)) a) (f4 :a 1 :c 2))" " begin: f4 keyword argument :c (in (f4 :a 1 :c 2)) does not match any argument in (a (b 2))")
(lint-test "(begin (define* (f4 a (b 2)) a) (f4 :a 1 :b 2))" "")
+ (lint-test "(begin (define* (f4 a (b 2)) a) (f4 1 :a 1 :b 2))" " begin: f4 has too many arguments: (f4 1 :a 1 :b 2)")
(lint-test "(begin (define* (f5 a :rest b) a) (f5))" "")
(lint-test "(begin (define* (f5 a :rest b) a) (f5 1))" "")
(lint-test "(begin (define* (f5 a :rest b) a) (f5 1 2 3))" "")
(lint-test "(begin (define* (f5 a :rest b) a) (f5 :b 1))" "")
- (lint-test "(begin (define* (f5 a :rest b) a) (f5 :a 1 2 3))" "")
+ (lint-test "(begin (define* (f5 a :rest b) a) (f5 :a 1 2 3))" " begin: non-keyword argument 2 follows previous keyword")
(lint-test "(begin (define* (f6 a b :allow-other-keys) a) (f6))" "")
(lint-test "(begin (define* (f6 a b :allow-other-keys) a) (f6 :a 1 :b 2 :c 3))" "")
-
-
- (lint-test "(let () (define (f8 a b) (+ 1 (f8 2 3))) (f8 1 2))" "")
- (lint-test "(let () (define (f8 a b) ((lambda (c) (f8 c 3)) 1)) (f8 1 2))" "")
+ (lint-test "(let () (define (f8 a) (+ a 1)) (string-ref (f8 1) 2))"
+ " let: perhaps (... (define (f8 a) (+ a 1)) (string-ref (f8 1) 2)) -> (... (string-ref (let ((a 1)) (+ a 1)) 2))
+ let: in (string-ref (f8 1) 2), string-ref's argument 1 should be a string, but (f8 1) is a number?")
+ (lint-test "(begin (define (f11 x) (+ x 1)) (f11 (integer->char 2)))"
+ " begin: in (f11 (integer->char 2)), f11's argument should be a number, but (integer->char 2) is a char?")
+ (lint-test "(begin (define (f12 x) (log x 2)) (f12 \"asdf\"))"
+ " begin: in (f12 \"asdf\"), f12's argument should be a number, but \"asdf\" is a string?")
+ (lint-test "(+ a #\\a 2)" " +: in (+ a #\\a 2), +'s argument 2 should be a number, but #\\a is a char?")
+ (lint-test "(begin (define (f13 x) (string-ref x 0)) (f13 #(0 1 2)))"
+ " begin: in (f13 #(0 1 2)), f13's argument should be a string, but #(0 1 2) is a vector?")
+ (lint-test "(begin (define (f14 x) (float-vector-set! v x 1.0)) (f14 1+i))"
+ " begin: in (f14 1+1i), f14's argument should be an integer, but 1+1i is a number?")
+ (lint-test "(begin (define (f14 x) (float-vector-set! x 1 1.0)) (f14 1+i))"
+ " begin: in (f14 1+1i), f14's argument should be a float-vector, but 1+1i is a number?")
+ (lint-test "(begin (define (f14 x) (* 2 (float-vector-set! x 1 1.0))) (f14 1+i))"
+ " begin: in (f14 1+1i), f14's argument should be a float-vector, but 1+1i is a number?")
+ (lint-test "(begin (define (f15 x) (* 2 (+ x 1))) (f15 #()))"
+ " begin: in (f15 #()), f15's argument should be a number, but #() is a vector?")
+ (lint-test "(begin (define (f16 x) (vector-set! v 1 x)) (f16 #f))" "")
+ (lint-test "(begin (define (f16 y x) (vector-set! v (f y) 2) (vector-set! v (f y) x)) (f16 0 #f))" "")
+ (lint-test "(begin (define (f16 y x z) (vector-set! z (f y) x)) (f16 0 #f #()))" "")
+
+ (lint-test "(let ((fv (float-vector 1 2 3))) (fv 1))" " let: perhaps (let ((fv (float-vector 1 2 3))) (fv 1)) -> ((float-vector 1 2 3) 1)")
+ (lint-test "(let ((fv (inlet 'a 1))) (fv 'a))" " let: perhaps (let ((fv (inlet 'a 1))) (fv 'a)) -> ((inlet 'a 1) 'a)")
+ (lint-test "(let ((fv (float-vector 1 2 3))) (fv -1))"
+ " let: perhaps (let ((fv (float-vector 1 2 3))) (fv -1)) -> ((float-vector 1 2 3) -1)
+ let: fv's index -1 is negative")
+ (lint-test "(let ((fv (float-vector 1 2 3))) (fv 10))"
+ " let: perhaps (let ((fv (float-vector 1 2 3))) (fv 10)) -> ((float-vector 1 2 3) 10)
+ let: fv has length 3, but index is 10")
+ (lint-test "(let ((fv (float-vector 1 2 3))) (set! (fv 1) #\\a))" " let: fv wants real, but the value in (set! (fv 1) #\\a) is a char?")
+ (lint-test "(let ((fv (float-vector 1 2 3))) (set! (fv 10) 1.5))" " let: fv has length 3, but index is 10")
+ (lint-test "(let ((fv (make-float-vector 3))) (set! (fv 10) 1.5))" " let: fv has length 3, but index is 10")
+ (lint-test "(let ((fv (make-float-vector 3))) (set! (fv 0) (floor x)))" "")
+ (lint-test "(let ((fv (make-float-vector 3))) (+ 1 (fv 3)))" " let: fv has length 3, but index is 3")
+ (lint-test "(let ((fv (make-string 3))) (+ 1 (fv 1)))" "") ; someday...
+
+ (lint-test "(let () (define (f8 a b) (+ 1 (f8 2 3))) (f8 1 2))"
+ " let: perhaps (... (define (f8 a b) (+ 1 (f8 2 3))) (f8 1 2)) -> (... (let f8 ((a 1) (b 2)) (+ 1 (f8 2 3))))
+ let: f8's parameter 1 is not used, but a value is passed: 1
+ let: f8's parameter 2 is not used, but a value is passed: 2")
+ (lint-test "(let () (define (f8 a b) ((lambda (c) (f8 c 3)) 1)) (f8 1 2))"
+ " let: perhaps (... (define (f8 a b) ((lambda (c) (f8 c 3)) 1)) (f8 1 2)) -> (... (let f8 ((a 1) (b 2)) ((lambda (c) (f8 c 3)) 1)))
+ f8: perhaps ((lambda (c) (f8 c 3)) 1) -> (let ((c 1)) (f8 c 3))
+ let: f8's parameter 1 is not used, but a value is passed: 1
+ let: f8's parameter 2 is not used, but a value is passed: 2")
(lint-test "(let () (define (f1) 32) (set! f1 4) (+ 1 f1))" "")
+ (lint-test "(let () (define (f1) 32) (+ 1 f1))" " let: f1 is a procedure, but + in (+ 1 f1) wants a number?")
(lint-test "(let () (define f10 (lambda (a) a)) (set! f10 (lambda (a b) (+ a b))) (f10 1 2))" " let: perhaps (lambda (a b) (+ a b)) -> +")
+ (lint-test "(begin (define (f20 x y) (+ y 1)) (f20 (+ z 1) z))" " begin: f20's parameter 1 is not used, but a value is passed: (+ z 1)")
+ (lint-test "(begin (define (f21 x y) (set! x 3) (+ y 1)) (f21 (+ z 1) z))"
+ " begin: f21's parameter 1's value is not used, but a value is passed: (+ z 1)")
+ (lint-test "(begin (define (f22 x) (case y ((0) `(+ ,x 1)) (else #f))) (f22 2))"
+ " f22: perhaps (case y ((0) ({list} '+ x 1)) (else #f)) -> (and (eqv? y 0) ({list} '+ x 1))")
+ (lint-test "(begin (define (f23 x) (+ y 1)) (define (f24 x) (f23 (+ x 1))) (f24 0))"
+ " f24: f23's parameter 1 is not used, but a value is passed: (+ x 1)")
+ (lint-test "(begin (define x 1) `#(,x))" ; this can be expanded: (lambda (x) #((unquote x)))
+ " begin: quasiquoted vectors are not supported: #((unquote x))")
+ (lint-test "(begin (define-macro (m1 x y) `(+ ,y 1)) (m1 a b))" " begin: m1's parameter 1 is not used, but a value is passed: a")
+ (lint-test "(begin (define (f30 x) (if (> x 0) (f30 #() (- x 1)))) (f30 1))" " f30: f30 has too many arguments: (f30 #() (- x 1))")
+
+ (lint-test "(let () (define plus (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z) (+ x y z)) (args (apply + args)))) (plus))"
+ " plus: repeated parameter list? (x y) in (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z) (+ x y z)) (args (apply + args)))")
+ (lint-test "(case-lambda ((a b) (+ a b)))"
+ " case-lambda: perhaps (case-lambda ((a b) (+ a b))) -> (lambda (a b) (+ a b))")
+ (lint-test "(case-lambda \"a doc string\" ((a b) (+ a b)))"
+ " case-lambda: perhaps (case-lambda \"a doc string\" ((a b) (+ a b))) -> (let ((documentation \"a doc string\")) (lambda (a b) (+ a b)))")
+ (lint-test "(case-lambda (() (display x #f)) ((y) (display x y)))"
+ " case-lambda: perhaps (case-lambda (() (display x #f)) ((y) (display x y))) -> (lambda* (y) (display x y))")
+ (lint-test "(case-lambda (() (+ x 0)) ((y) (+ x y)))"
+ " case-lambda: perhaps (+ x 0) -> x
+ case-lambda: perhaps (case-lambda (() (+ x 0)) ((y) (+ x y))) -> (lambda* ((y 0)) (+ x y))")
+ (lint-test "(case-lambda ((x) (log x 2)) ((x y) (log x y)))"
+ " case-lambda: perhaps (case-lambda ((x) (log x 2)) ((x y) (log x y))) -> (lambda* (x (y 2)) (log x y))")
+ (lint-test "(case-lambda ((x) (log x 2)) ((y x) (log x y)))" "")
+ (lint-test "(case-lambda ((x) (log x 2)) ((y x z) (log x y)))" "")
+
+ (lint-test "(let loop ((pi 1.0) (+ pi 1)))"
+ " let: in (let loop ((pi 1.0) (+ pi 1))), lambda parameter 'pi is a constant
+ let: can't bind a constant: (pi 1.0)
+ let: let binding is messed up: (+ pi 1)
+ let: loop not used, value: (let loop ((pi 1.0) (+ pi 1)))")
+ (lint-test "(define (f12 pi) pi)" " define: f12 parameter can't be a constant: (f12 pi)")
+ (lint-test "(define* (f12 (pi 1.0)) pi)" "f12: parameter can't be a constant: ((pi 1.0))")
+ (lint-test "(define (f12 :key) :key)" " define: f12 parameter can't be a keyword: (f12 :key)")
+ (lint-test "(define :a 3)" " define: keywords are constants :a")
+ (lint-test "(let () (define most-positive-fixnum 32) most-positive-fixnum)"
+ " let: most-positive-fixnum is a constant in s7: (define most-positive-fixnum 32)
+ let: define returns the new value, so this could be omitted: most-positive-fixnum")
+ (lint-test "(let () (define-constant __lt1__ 32) (set! __lt1__ 3) (+ __lt1__ 1))"
+ " let: can't set! __lt1__ in (set! __lt1__ 3) (it is a constant: 32)")
+ (lint-test "(let () (define (f1 x) (+ x 1)) f1)" " let: define returns the new value, so this could be omitted: f1")
+ (lint-test "(let () (define (f1 x) (f2 (+ x 1))) (define (f2 x) x) (f1 3))" "")
+ (lint-test "(let () (define (f1 a) (let ((a (vector->list a))) (car a))) (f1 #(0)))"
+ " let: perhaps (... (define (f1 a) (let ((a (vector->list a))) (car a))) (f1 #(0))) -> (... (let ((a #(0))) (let ((a (vector->list a))) (car a))))
+ f1: perhaps (let ((a (vector->list a))) (car a)) -> (car (vector->list a))")
+ (lint-test "(car (vector->list a))" " car: perhaps (car (vector->list a)) -> (vector-ref a 0)")
+
+ (lint-test "(null? (list))" " null?: perhaps (null? (list)) -> #t")
+ (lint-test "(null? (list 1))" " null?: perhaps (null? (list 1)) -> #f")
+ (lint-test "(pair? (list))" " pair?: perhaps (pair? (list)) -> #f")
+ (lint-test "(pair? (list 1))" " pair?: perhaps (pair? (list 1)) -> #t")
+ (lint-test "(proper-list? (list))" " proper-list?: perhaps (proper-list? (list)) -> #t proper-list?: (proper-list? (list)) is always #t")
+ (lint-test "(proper-list? (list 1))" " proper-list?: perhaps (proper-list? (list 1)) -> #t proper-list?: (proper-list? (list 1)) is always #t")
+ (lint-test "(or (list? e) (null? e))" " or: perhaps (or (list? e) (null? e)) -> (list? e)")
+ (lint-test "(or (list? e) (pair? e))" " or: perhaps (or (list? e) (pair? e)) -> (list? e)")
+ (lint-test "(or (proper-list? e) (null? e))" " or: perhaps (or (proper-list? e) (null? e)) -> (proper-list? e)")
+ (lint-test "(or (proper-list? e) (pair? e))" "")
+ (lint-test "(and (list? e) (null? e))" " and: perhaps (and (list? e) (null? e)) -> (null? e)")
+ (lint-test "(and (list? e) (pair? e))" " and: perhaps (and (list? e) (pair? e)) -> (pair? e)")
+ (lint-test "(and (proper-list? e) (null? e))" " and: perhaps (and (proper-list? e) (null? e)) -> (null? e)")
+ (lint-test "(and (proper-list? e) (pair? e))" "")
+ (lint-test "(let ((x 1/2)) (integer? x))" " let: perhaps (let ((x 1/2)) (integer? x)) -> (integer? 1/2) let: x is 1/2, so (integer? x) is #f")
+ (lint-test "(let ((x 1/2)) (real? x))" " let: perhaps (let ((x 1/2)) (real? x)) -> (real? 1/2) let: x is rational, so (real? x) is #t")
+ (lint-test "(let ((x 1/2)) (rational? x))" " let: perhaps (let ((x 1/2)) (rational? x)) -> (rational? 1/2) let: x is rational, so (rational? x) is #t")
+ (lint-test "(let ((x 1/2)) (pair? x))" " let: perhaps (let ((x 1/2)) (pair? x)) -> (pair? 1/2) let: x is rational, so (pair? x) is #f")
+ (lint-test "(let ((x ())) (list? x))" " let: perhaps (let ((x ())) (list? x)) -> (list? ())")
+ (lint-test "(let ((x (list 1))) (list? x))"
+ " let: perhaps (let ((x (list 1))) (list? x)) -> (list? (list 1))
+ let: x is a proper-list, so (list? x) is #t")
+ (lint-test "(let ((x \"a\") (y \"\")) (eq? x y))" " let: perhaps (let ((x \"a\") (y \"\")) (eq? x y)) -> (eq? \"a\" \"\")")
+ (lint-test "(let ((x 12)) (set! x 32) (integer? x))"
+ " let: x is an integer, so (integer? x) is #t
+ let: perhaps (let ((x 12)) (set! x 32) (integer? x)) -> (let ((x 32)) (integer? x))")
+ (lint-test "(and (char-alphabetic? x) (char? x))" " and: perhaps (and (char-alphabetic? x) (char? x)) -> (char-alphabetic? x)")
+ (lint-test "(or (char-numeric? x) (char? x))" " or: perhaps (or (char-numeric? x) (char? x)) -> (char? x)")
+ (lint-test "(or (char-numeric? x) (char-whitespace? x))" "")
+ (lint-test "(and (char-alphabetic? x) (pair? x))" " and: perhaps (and (char-alphabetic? x) (pair? x)) -> #f")
+ (lint-test "(and (char? x) (char-numeric? x))" "")
+ (lint-test "(char=? #\\a (read-char p))"
+ " char=?: in (char=? #\\a (read-char p)), char=?'s argument 2 should be a char, but (read-char p) might also be eof-object?")
+ (lint-test "(< (string->number x) 0)"
+ " <: in (< (string->number x) 0), <'s argument 1 should be real, but (string->number x) might also be boolean?")
+ (lint-test "(vector-ref v (+ i 1))" "")
+
+ (lint-test "(or (number? x) (nan? x))" " or: perhaps (or (number? x) (nan? x)) -> (number? x)")
+ (lint-test "(and (infinite? x) (nan? x))" " and: perhaps (and (infinite? x) (nan? x)) -> #f")
+ (lint-test "(and (real? x) (nan? x))" "")
+ (lint-test "(and (< x 3) (< x 4))" " and: perhaps (and (< x 3) (< x 4)) -> (< x 3)")
+ (lint-test "(and (inexact? x) (exact? x))" " and: perhaps (and (inexact? x) (exact? x)) -> #f")
+ (lint-test "(and (inexact? x) (rational? x))" " and: perhaps (and (inexact? x) (rational? x)) -> #f")
+ (lint-test "(and (inexact? x) (even? x))" " and: perhaps (and (inexact? x) (even? x)) -> #f")
+ (lint-test "(and (integer? x) (even? x))" "")
+ (lint-test "(and (odd? x) (integer? x))" " and: perhaps (and (odd? x) (integer? x)) -> (odd? x)")
+ (lint-test "(and (odd? x) (even? x))" " and: perhaps (and (odd? x) (even? x)) -> #f")
+ (lint-test "(and (= x 0) (zero? x))" "") ; someday?
+ (lint-test "(and (inexact? x) (float? x))" " and: perhaps (and (inexact? x) (float? x)) -> (float? x)")
+ (lint-test "(or (inexact? x) (float? x))" " or: perhaps (or (inexact? x) (float? x)) -> (inexact? x)")
+ (lint-test "(or (float? x) (inexact? x))" " or: perhaps (or (float? x) (inexact? x)) -> (inexact? x)")
+ (lint-test "(and (float? x) (inexact? x))" " and: perhaps (and (float? x) (inexact? x)) -> (float? x)")
+ (lint-test "(and (symbol? x) (defined? x))" "") ; this avoids a type error if not a symbol, so can't be reduced
+ (lint-test "(and (defined? x) (symbol? x))" " and: perhaps (and (defined? x) (symbol? x)) -> (defined? x)")
+ (lint-test "(and (negative? x) (not (real? x)))" " and: perhaps (and (negative? x) (not (real? x))) -> #f")
+ (lint-test "(and (positive? x) (real? x))" " and: perhaps (and (positive? x) (real? x)) -> (positive? x)")
+ (lint-test "(or (real? x) (zero? x))" " or: perhaps (or (real? x) (zero? x)) -> (real? x)")
+ (lint-test "(and (zero? x) (negative? x))" " and: perhaps (and (zero? x) (negative? x)) -> #f")
+ (lint-test "(and (real? x) (not (inexact? x)))" " and: perhaps (and (real? x) (not (inexact? x))) -> (rational? x)")
+ (lint-test "(and (exact? x) (not (inexact? x)))" " and: perhaps (and (exact? x) (not (inexact? x))) -> (exact? x)")
+ (lint-test "(and (real? x) (not (zero? x)))" "") ; this is correct
+ (lint-test "(and (even? x) (not (real? x)))" " and: perhaps (and (even? x) (not (real? x))) -> #f")
+ (lint-test "(and (exact? x) (zero? x))" " and: perhaps (and (exact? x) (zero? x)) -> (eqv? x 0)")
+ (lint-test "(and (zero? x) (inexact? x))" " and: perhaps (and (zero? x) (inexact? x)) -> (eqv? x 0.0)")
+ (lint-test "(and (pair? x) (+ x 1))" "in (and (pair? x) (+ x 1)), x is a pair, but + wants a number?")
+ (lint-test "(and (boolean? x) (not x))" " and: perhaps (and (boolean? x) (not x)) -> (not x)")
+ (lint-test "(and (boolean? x) (eq? x #f))" " and: perhaps (and (boolean? x) (eq? x #f)) -> (eq? x #f) and: perhaps (eq? x #f) -> (not x)")
+ (lint-test "(list? (make-list 1))" " list?: perhaps (list? (make-list 1)) -> #t list?: (list? (make-list 1)) is always #t")
+ (lint-test "(number? (+ 1 x))" " number?: perhaps (number? (+ 1 x)) -> #t number?: (number? (+ 1 x)) is always #t")
+ (lint-test "(number? (make-list 1))" " number?: perhaps (number? (make-list 1)) -> #f number?: (number? (make-list 1)) is always #f")
+ (lint-test "(pair? (member x y))" " pair?: member returns either #f or a pair, so (pair? (member x y)) -> (member x y)")
+ (lint-test "(null? (member x y))" " null?: perhaps (null? (member x y)) -> #f null?: (null? (member x y)) is always #f")
+ (lint-test "(integer? (char-position x y))" " integer?: char-position returns either #f or an integer, so (integer? (char-position x y)) -> (char-position x y)")
+ (lint-test "(car (member x y))"
+ " car: in (car (member x y)), car's argument should be a pair, but (member x y) might also be boolean?
+ car: (car (member x y)) is x, or an error")
+; (lint-test "(if (and x (pair? x) (symbol? (cadr x))) x)" "")
+ (lint-test "(catch #t (lambda () (char=? (read-char p) #\\newline)) (lambda arg 'error))" "")
+ (lint-test "(if (and (<= 12 x) (<= x 15)) 2 3)" " if: perhaps (and (<= 12 x) (<= x 15)) -> (<= 12 x 15)")
+ (lint-test "(and x (set! x (zero? (random 2))) (not x))" "")
+ (lint-test "(string-append x , \"b\")" "")
+ (lint-test "(string-append x , y)" " string-append: stray comma? (unquote y) in (string-append x (unquote y))")
+ (lint-test "`(+ ,x 1)" "")
+ (lint-test "(let ((x (list 23 1 3))) (sort! x <) x)" "")
+ (lint-test "(let ((x (list 23 1 3))) (reverse! x) x)" " let: reverse! might leave x in an undefined state; perhaps (set! x (reverse! x))")
+; (lint-test "(if (and (list? x) (car x)) 3)" "")
+ (lint-test "(if (and (list? x) (not (null? x)) (car x)) 3)" "")
+ (lint-test "(if x (map f x))" " if: perhaps (if x (map f x)) -> (if (sequence? x) (map f x))")
+ (lint-test "(let ((x 0)) (/ 21 x))" " let: perhaps (let ((x 0)) (/ 21 x)) -> (/ 21 0) let: x is 0, so (/ 21 x) is an error")
+ (lint-test "(cond ((> x 0) => abs) (else y))" " cond: in ((> x 0) => abs), (> x 0) returns a a boolean, but abs expects real?")
+
+ (lint-test "(for-each (lambda (x) (display x port)) (list y z 123))"
+ " for-each: perhaps (for-each (lambda (x) (display x port)) (list y z 123)) -> (format port \"~{~A~}\" (list y z 123))")
+ (lint-test "(for-each (lambda (x) (write-string x port)) (list y z \"123\"))"
+ " for-each: perhaps (for-each (lambda (x) (write-string x port)) (list y z \"123\")) -> (format port \"~{~A~}\" (list y z \"123\"))")
+ (lint-test "(map (cut a) (list packages))" " map: perhaps (map (cut a) (list packages)) -> (list ((cut a) packages))")
+ (lint-test "(map abs (list packages))" " map: perhaps (map abs (list packages)) -> (list (abs packages))")
+ (lint-test "(map string->symbol (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\"))"
+ " map: perhaps (map string->symbol (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\")) -> '(IOPAD IPAD OPAD HIGH LOW)")
+ (lint-test "(list->string (list h1 h2))" " list->string: perhaps (list->string (list h1 h2)) -> (string h1 h2)")
+ (lint-test "(string-append (list->string (make-list indent #\\space)) str)"
+ " string-append: perhaps (list->string (make-list indent #\\space)) -> (make-string indent #\\space)")
+ (lint-test "(string-append (string #\\C) \"ZLl*()def\")"
+ " string-append: perhaps (string-append (string #\\C) \"ZLl*()def\") -> \"CZLl*()def\"
+ string-append: (string #\\C) could be \"C\"")
+ (lint-test "(string-append \"USER \" user (string #\\return) (string #\\newline))"
+ " string-append: perhaps (string-append \"USER \" user (string #\\return) (string #\\newline)) ->
+ (string-append \"USER \" user (string #\\return #\\newline))")
+ (lint-test "(string=? (string (string-ref file-line 0)) \"*\")"
+ " string=?: perhaps (string=? (string (string-ref file-line 0)) \"*\") -> (char=? (string-ref file-line 0) #\\*)")
+ (lint-test "(for-each display (list 1 a #\\newline))"
+ " for-each: perhaps (for-each display (list 1 a #\\newline)) -> (format () \"~A~A~A\" 1 a #\\newline)")
+ (lint-test "(for-each write-string (list a \"asdf\" (substring x 1)))"
+ " for-each: perhaps (for-each write-string (list a \"asdf\" (substring x 1))) -> (format () \"~A~A~A\" a \"asdf\" (substring x 1))")
+ (lint-test "(for-each write (append b (list 1 a #\\newline)))"
+ " for-each: perhaps (for-each write (append b (list 1 a #\\newline))) -> (format () \"~{~S~}\" (append b (list 1 a #\\newline)))")
+ (lint-test "(for-each write-char (append b (list a #\\newline)))"
+ " for-each: perhaps (for-each write-char (append b (list a #\\newline))) -> (format () \"~{~A~}\" (append b (list a #\\newline)))")
+
+ ;; this is a write.scm lint-pp bug regression test
+ (lint-test "(define (any-random amount e) (letrec ((next-random (lambda () (let ((x 32)) (if (<= y (envelope-interp x e)) (next-random)))))) (next-random)))"
+ " any-random: perhaps (letrec ((next-random (lambda () (let ((x 32)) (if (<= y (envelope-interp... ->
+ (let next-random ()
+ (let ((x 32))
+ (if (<= y (envelope-interp x e))
+ (next-random))))")
+
+ (lint-test "(let ()
+ (define (f11 a b) (if (positive? a) (+ a b) b))
+ (define (f14 x y) (if (positive? x) (+ x y) y))
+ (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): f14 could be (define f14 f11)")
+ (lint-test "(let ((x (let () (define (f11 a b) (if (positive? a) (+ a b) b)) (f11 1 2))))
+ (define (f14 x y) (if (positive? x) (+ x y) y))
+ (+ x (f14 1 2)))"
+ " let: perhaps (... (define (f11 a b) (if (positive? a) (+ a b) b)) (f11 1 2)) -> (... (let ((a 1) (b 2)) (if (positive? a) (+ a b) b)))
+ let: perhaps (... (define (f14 x y) (if (positive? x) (+ x y) y)) (+ x (f14 1 2))) -> (... (+ x (let ((x 1) (y 2)) (if (positive? x) (+ x y) y))))")
+ (lint-test "(let ()
+ (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b))
+ (define (f14 x y) (if (positive? x) (+ x y) y))
+ (+ (f11 1 2) (f14 1 2)))"
+ " let (line 1): perhaps (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b)) ->
+ (define (f11 a b) (if (positive? a) (+ a b) b))")
+ (lint-test "(let ()
+ (define (f11 a b) (if (positive? a) (+ a b) b))
+ (define (f14 y x) (if (positive? x) (+ x y) y))
+ (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
+ (lint-test "(let ()
+ (define (f11 b a) (if (positive? a) (+ a b) b))
+ (define (f14 x y) (if (positive? x) (+ x y) y))
+ (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 y x)")
+ (lint-test "(let ()
+ (define (f1 x) (set! x 32) (log x 2.0))
+ (define (f2 y) (set! y 32) (log y 2.0))
+ (+ (f1 0) (f2 0)))" " f2 (line 2): f2 could be (define f2 f1)")
+ (lint-test "(let ()
+ (define (f11 a b) (if (positive? a) (+ a b) b))
+ (let ((z (if (positive? a1) (+ a1 b1) b1)))
+ (+ z (f11 1 2))))" " let (line 2): perhaps (if (positive? a1) (+ a1 b1) b1) -> (f11 a1 b1)")
+ (lint-test "(let ()
+ (define (f11 a b) (if (positive? a) (+ a b) b))
+ (define f14 (lambda (x y) (if (positive? x) (+ x y) y)))
+ (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
+ (lint-test "(let ()
+ (define f11 (let () (lambda (a b) (if (positive? a) (+ a b) b))))
+ (define (f14 x y) (if (positive? x) (+ x y) y))
+ (+ (f11 1 2) (f14 1 2)))"
+ " f11 (line 1): pointless let: (let () (lambda (a b) (if (positive? a) (+ a b) b))) -> (lambda (a b) (if (positive? a) (+ a b) b))
+ f14 (line 2): f14 could be (define f14 f11)")
+ (lint-test "(let ()
+ (define (f11 a b) (if (positive? a) (+ a b) b))
+ (define (f14 x y) (if (positive? x) (+ x (log y)) (log y)))
+ (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x (log y)) (log y)) -> (f11 x (log y))")
+ (lint-test "(let ()
+ (define union (let ((z 32)) (set! x (lambda (y) (+ z y))) (lambda args args)))
+ (union 1 2))" "")
+ (lint-test "(let ()
+ (define (f11 a b) (let ((z (+ a 1))) (if (positive? z) (+ a b) b)))
+ (define (f14 x y) (let ((w (+ x 1))) (if (positive? w) (+ x y) y)))
+ (+ (f11 1 2) (f14 1 2)))"
+ " f11 (line 1): perhaps (let ((z (+ a 1))) (if (positive? z) (+ a b) b)) -> (if (positive? (+ a 1)) (+ a b) b)
+ f14 (line 2): f14 could be (define f14 f11)
+ f14 (line 2): perhaps (let ((w (+ x 1))) (if (positive? w) (+ x y) y)) -> (if (positive? (+ x 1)) (+ x y) y)")
+ (lint-test "(let ()
+ (define (f11 a b) (let ((z (+ a 1))) (if (positive? z) (+ a b) b)))
+ (define (f14 x . y) (let ((w (+ x 1))) (if (positive? w) (+ x y) y)))
+ (+ (f11 1 2) (f14 1 2)))"
+ " f11 (line 1): perhaps (let ((z (+ a 1))) (if (positive? z) (+ a b) b)) -> (if (positive? (+ a 1)) (+ a b) b)
+ f14 (line 2): perhaps (let ((w (+ x 1))) (if (positive? w) (+ x y) y)) -> (if (positive? (+ x 1)) (+ x y) y)")
+ (lint-test "(let ()
+ (define (f11 a b) (let ((z (+ a 1))) (if (positive? z) (+ a b) b)))
+ (define (f14 x y z) (let ((w (+ x 1))) (if (positive? w) (+ x y) y)))
+ (+ (f11 1 2) (f14 1 2 3)))"
+ " f11 (line 1): perhaps (let ((z (+ a 1))) (if (positive? z) (+ a b) b)) -> (if (positive? (+ a 1)) (+ a b) b)
+ f14 (line 2): perhaps (let ((w (+ x 1))) (if (positive? w) (+ x y) y)) -> (f11 x y)
+ f14 (line 2): perhaps (let ((w (+ x 1))) (if (positive? w) (+ x y) y)) -> (if (positive? (+ x 1)) (+ x y) y)
+ let (line 3): f14's parameter 3 is not used, but a value is passed: 3")
+ (lint-test "(let ()
+ (define (f11 a b) (let ((z (+ a 1))) (if (positive? z) (+ a b) b)))
+ (define (f14 x y) (let ((w (+ x 1)) (ww 1)) (if (positive? w) (+ x y) y)))
+ (+ (f11 1 2) (f14 1 2)))"
+ " f11 (line 1): perhaps (let ((z (+ a 1))) (if (positive? z) (+ a b) b)) -> (if (positive? (+ a 1)) (+ a b) b)
+ f14 (line 2): ww not used, initially: 1 from let")
+ (lint-test "(let ()
+ (define (f12 a b) (let* ((z (+ a 1)) (zz z)) (if (positive? z) (+ a b) zz)))
+ (define (f15 x y) (let* ((w (+ x 1)) (ww w)) (if (positive? w) (+ x y) ww)))
+ (+ (f12 1 2) (f15 1 2)))"
+ " f12 (line 1): perhaps (let* ((z (+ a 1)) (zz z)) (if (positive? z) (+ a b) zz)) -> (let ((z (+ a 1))) (if (positive? z) (+ a b) z))
+ f15 (line 2): f15 could be (define f15 f12)
+ f15 (line 2): perhaps (let* ((w (+ x 1)) (ww w)) (if (positive? w) (+ x y) ww)) -> (let ((w (+ x 1))) (if (positive? w) (+ x y) w))")
+ (lint-test "(let ()
+ (define (f16 x) (do ((i 0 (+ i 1))) ((= i x)) (display i)))
+ (define (f17 y) (do ((k 0 (+ k 1))) ((= k y)) (display k)))
+ (f16 2) (f17 2))" " f17 (line 2): f17 could be (define f17 f16)")
+ (lint-test "(let ()
+ (define (f18 a b) (let ((z (lambda (c) (+ c 1)))) (if (positive? (z 1)) (+ a b) b)))
+ (define (f19 x y) (let ((w (lambda (d) (+ d 1)))) (if (positive? (w 1)) (+ x y) y)))
+ (+ (f18 1 2) (f19 1 2)))"
+ " f18 (line 1): perhaps (let ((z (lambda (c) (+ c 1)))) (if (positive? (z 1)) (+ a b) b)) -> (if (positive? (let ((c 1)) (+ c 1))) (+ a b) b)
+ f19 (line 2): f19 could be (define f19 f18)
+ f19 (line 2): perhaps (let ((w (lambda (d) (+ d 1)))) (if (positive? (w 1)) (+ x y) y)) -> (if (positive? (let ((d 1)) (+ d 1))) (+ x y) y)")
+ (lint-test "(let ()
+ (define (f20 a) (define (f20a b) (+ (* 2 b) a)) (f20a a))
+ (define (f21 x) (define (f21a c) (+ (* 2 c) x)) (f21a x))
+ (+ (f20 1) (f21 2)))"
+ " let (line 1): perhaps (define (f20 a) (define (f20a b) (+ (* 2 b) a)) (f20a a)) -> (define (f20 a) (let ((b a)) (+ (* 2 b) a)))
+ let (line 2): perhaps (define (f21 x) (define (f21a c) (+ (* 2 c) x)) (f21a x)) -> (define (f21 x) (let ((c x)) (+ (* 2 c) x)))
+ f21 (line 2): f21 could be (define f21 f20)")
+ (lint-test "(let ()
+ (define (f20 a) (define f20a (lambda (b) (+ (* 2 b) a))) (f20a a))
+ (define (f21 x) (define f21a (lambda (c) (+ (* 2 c) x))) (f21a x))
+ (+ (f20 1) (f21 2)))" " f21 (line 2): f21 could be (define f21 f20)")
+ (lint-test "(let ()
+ (define (f22 a) (lambda (b) (+ (* 2 b) a)))
+ (define (f23 x) (lambda (c) (+ (* 2 c) x)))
+ (+ ((f22 1) 2) ((f23 2) 3)))" " f23 (line 2): f23 could be (define f23 f22)")
+ (lint-test "(let ()
+ (define (f22 a) (lambda* ((b 21)) (+ (* 2 b) a)))
+ (define (f23 x) (lambda* ((c 21)) (+ (* 2 c) x)))
+ (+ ((f22 1) 2) ((f23 2) 3)))" " f23 (line 2): f23 could be (define f23 f22)")
+ (lint-test "(let ()
+ (define (f1 x) (abs (* 2 (+ (car x) 1))))
+ (define (f2 . x) (abs (* 2 (+ (car x) 1))))
+ (+ (f1 '(2)) (f2 3)))" "") ; these should not match!
+ (lint-test "(let ()
+ (define (f1 . x) (abs (* 2 (+ (car x) 1))))
+ (define (f2 x) (abs (* 2 (+ (car x) 1))))
+ (+ (f1 2) (f2 '(3))))" "") ; these should not match!
+ (lint-test "(let ()
+ (define (f24 aa) (let ((z (+ aa 1))) (if (positive? z) (f24 (+ aa 1)) 0)))
+ (define (f25 x) (let ((w (+ x 1))) (if (positive? w) (f25 (+ x 1)) 0)))
+ (+ (f24 2) (f25 2)))"
+ " f24 (line 1): (+ aa 1) is z in (let ((z (+ aa 1))) (if (positive? z) (f24 (+ aa 1)) 0))
+ f25 (line 2): f25 could be (define f25 f24)
+ f25 (line 2): (+ x 1) is w in (let ((w (+ x 1))) (if (positive? w) (f25 (+ x 1)) 0))")
+ (lint-test "(let ()
+ (define* (f26 (aa 1)) (let ((z (+ aa 1))) (if (positive? z) (f26 (+ aa 1)) 0)))
+ (define* (f27 (x 1)) (let ((w (+ x 1))) (if (positive? w) (f27 (+ x 1)) 0)))
+ (+ (f26 2) (f27 2)))"
+ " f26 (line 1): (+ aa 1) is z in (let ((z (+ aa 1))) (if (positive? z) (f26 (+ aa 1)) 0))
+ f27 (line 2): f27 could be (define f27 f26)
+ f27 (line 2): (+ x 1) is w in (let ((w (+ x 1))) (if (positive? w) (f27 (+ x 1)) 0))")
+ (lint-test "(let ()
+ (define (f31 a b) (if (> a 0) (+ a b) b))
+ (define (f32 x y) (if (< 0 x) (+ x y) y))
+ (+ (f31 1 2) (f32 1 2)))" " f32 (line 2): f32 could be (define f32 f31)")
+ (lint-test "(let ()
+ (define (f31 a b) (if (> a 0) (+ a b) b))
+ (define (f32 x y) (if (< 0 y) (+ x y) y))
+ (+ (f31 1 2) (f32 1 2)))" "")
+ (lint-test "(let () (define (f32) (let ((xx 1)) (set! xx 2) (+ xx 1))) (f32) 3)"
+ " let: perhaps (... (define (f32) (let ((xx 1)) (set! xx 2) (+ xx 1))) (f32) 3) -> (... (let ((xx 1)) (set! xx 2) (+ xx 1)) 3)
+ f32: perhaps (let ((xx 1)) (set! xx 2) (+ xx 1)) -> (let ((xx 2)) (+ xx 1))
+ let: this could be omitted: (f32)")
+ (lint-test "(let ((xx 1)) (set! xx 2) (abs xx) xx)"
+ " let: this could be omitted: (abs xx)
+ let: perhaps (let ((xx 1)) (set! xx 2) (abs xx) xx) -> (let ((xx 2)) (abs xx) ...)")
+ (lint-test "(let () (define (f32) (let ((xx 1)) (set! xxx 2) (+ xx 1))) (f32) 3)"
+ " let: perhaps (... (define (f32) (let ((xx 1)) (set! xxx 2) (+ xx 1))) (f32) 3) ->
+ (... (let ((xx 1)) (set! xxx 2) (+ xx 1)) 3)")
+ (lint-test "(let () (define (f32 x) (let ((xx (car x))) (vector-set! xx 0 2) xx)) (f32 (list (vector 1))) 3)"
+ " let: perhaps (... (define (f32 x) (let ((xx (car x))) (vector-set! xx 0 2) xx)) (f32... ->
+ (... (let ((x (list (vector 1)))) (let ((xx (car x))) (vector-set! xx 0 2) xx)) 3)")
+ (lint-test "(let () (define* (f1 x (y 0)) (+ x y 1)) (+ (f1 2) (f1 2 3) (f1 3) (f1 4) (f1 5) (f1 6)))" "")
+ (lint-test "(define f1 (let ((a abs)) (lambda (b) (if (> b 0) (+ (a b) b) b))))
+ (define f2 (let ((a log)) (lambda (b) (if (> b 0) (+ (a b) b) b))))" "")
+
+ (lint-test "(define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b))"
+ " define: perhaps (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b)) ->
+ (define (f11 a b) (if (positive? a) (+ a b) b))")
+ (lint-test "(define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 b a))"
+ " define: perhaps (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 b a)) ->
+ (define (f11 a b) (let ((a b) (b a)) (if (positive? a) (+ a b) b)))")
+ (lint-test "(define (f11 a b) (define (f12 a b) (display a) (if (positive? a) (+ a b) b)) (f12 a b))"
+ " define: perhaps (define (f11 a b) (define (f12 a b) (display a) (if (positive? a) (+ a b)... ->
+ (define (f11 a b) (display a) (if (positive? a) (+ a b) b))")
+ (lint-test "(define (f11 a b) (define (f12) (if (positive? a) (+ a b) b)) (f12))"
+ " define: perhaps (define (f11 a b) (define (f12) (if (positive? a) (+ a b) b)) (f12)) ->
+ (define (f11 a b) (if (positive? a) (+ a b) b))")
+ (lint-test "(define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) x)) (f12 (+ a 1) (* b 2)))"
+ " define: perhaps (define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) x)) (f12 (+... ->
+ (define (f11 a b) (let ((x (+ a 1)) (y (* b 2))) (if (positive? x) (+ x y) x)))")
+ (lint-test "(define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x))) (f12 (+ a 1) (* b 2)))"
+ " define: perhaps (define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x)))... ->
+ (define (f11 a b) (let f12 ((x (+ a 1)) (y (* b 2))) (if (positive? x) (+ x y) (f12 1 x))))")
+ (lint-test "(define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x))) (+ a (f12 (+ a 1) (* b 2))))"
+ " define: perhaps (define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x)))... ->
+ (define (f11 a b) (+ a (let f12 ((x (+ a 1)) (y (* b 2))) (if (positive? x) (+ x y) (f12 1 x)))))")
+ (lint-test "(define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x))) (display b) (+ a (f12 (+ a 1) (* b 2))))"
+ " define: perhaps (define (f11 a b) (define (f12 x y) (if (positive? x) (+ x y) (f12 1 x)))... ->
+ (define (f11 a b) (display b) (+ a (let f12 ((x (+ a 1)) (y (* b 2))) (if (positive? x) (+ x y) (f12 1 x)))))")
+ (lint-test "(define (f11) (define (f12) (if (positive? a) (+ a b) (f12))) (f12))"
+ " define: perhaps (define (f11) (define (f12) (if (positive? a) (+ a b) (f12))) (f12)) ->
+ (define (f11) (if (positive? a) (+ a b) (f11)))")
+
+ (lint-test "(let () (define (f40 x) (+ x 1)) (define (f41 y z) (y (+ z 1))) (f41 f40 2))" "")
+ (lint-test "(let () (define (f41 y z) (y (+ z 1))) (f41 abs 2))"
+ " let: perhaps (... (define (f41 y z) (y (+ z 1))) (f41 abs 2)) -> (... (let ((y abs) (z 2)) (y (+ z 1))))")
+ (lint-test "(let () (define (f42 y z) (y (+ z 1))) (f42 (lambda (a) (+ a 1)) 2))"
+ " let: perhaps (... (define (f42 y z) (y (+ z 1))) (f42 (lambda (a) (+ a 1)) 2)) -> (... (let ((y (lambda (a) (+ a 1))) (z 2)) (y (+ z 1))))")
+
+ (lint-test "(define f43 (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (f0 (+ b 1)))))"
+ " define: letrec could be let: (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (f0 (+ b 1))))
+ define: perhaps (define f43 (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (f0 (+ b 1))))) ->
+ (define (f43 b) (let f0 ((a (+ b 1))) (+ a 1)))")
+
+ (lint-test "(define f43 (letrec ((f0 (lambda (a b) (+ (f0 a b) 1)))) (lambda (b) (f0 b 0))))"
+ " define: perhaps (define f43 (letrec ((f0 (lambda (a b) (+ (f0 a b) 1)))) (lambda (b) (f0 b 0)))) ->
+ (define (f43 b) (let f0 ((a b) (b 0)) (+ (f0 a b) 1)))")
+
+ (lint-test "(define f43 (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (if (> b 0) (f0 (+ b 1))))))"
+ " define: letrec could be let: (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (if (> b 0) (f0 (+ b 1)))))
+ define: perhaps (define f43 (letrec ((f0 (lambda (a) (+ a 1)))) (lambda (b) (if (> b 0)... ->
+ (define (f43 b) (if (> b 0) (let f0 ((a (+ b 1))) (+ a 1))))")
+
+ (lint-test "(lambda (c) (letrec ((f0 (lambda (a) (+ a 1)))) (f0 (+ c 1))))"
+ " lambda: letrec could be let: (letrec ((f0 (lambda (a) (+ a 1)))) (f0 (+ c 1)))
+ lambda: perhaps (letrec ((f0 (lambda (a) (+ a 1)))) (f0 (+ c 1))) -> (let f0 ((a (+ c 1))) (+ a 1))")
+ (lint-test "(lambda (c) (letrec ((f0 (lambda (a) (+ a c 1)))) (let ((c 32)) (f0 (+ c 1)))))"
+ " lambda: letrec could be let: (letrec ((f0 (lambda (a) (+ a c 1)))) (let ((c 32)) (f0 (+ c 1))))
+ lambda: perhaps (let ((c 32)) (f0 (+ c 1))) -> (f0 (+ 32 1))")
+ (lint-test "(let ((x (lambda (y) (+ y (x (- y 1)))))) (x 2))"
+ " let: let variable x is called in its binding? Perhaps let should be letrec: ((x (lambda (y) (+ y (x (- y 1))))))
+ let: perhaps (let ((x (lambda (y) (+ y (x (- y 1)))))) (x 2)) -> (let ((y 2)) (+ y (x (- y 1))))")
+ (lint-test "(let () (define (f60 x) (* 2 x)) (+ 1 (f60 y)))"
+ " let: perhaps (... (define (f60 x) (* 2 x)) (+ 1 (f60 y))) -> (... (+ 1 (let ((x y)) (* 2 x))))")
+ (lint-test "(let () (define f60 (let ((a (lambda (x) (* 2 x)))) a)) (+ 1 (f60 y)))"
+ " f60: perhaps (let ((a (lambda (x) (* 2 x)))) a) -> (lambda (x) (* 2 x))")
+ (lint-test "(let ((x 2)) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0)))"
+ " let: perhaps (let ((x 2)) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0))) -> (let loop ((y 2)) (if (positive? y) (loop (- y 1)) 0))")
+ (lint-test "(let ((f60 (lambda (x) (* 2 x)))) (+ 1 (f60 y)))"
+ " let: perhaps (let ((f60 (lambda (x) (* 2 x)))) (+ 1 (f60 y))) -> (+ 1 (let ((x y)) (* 2 x)))")
+ (lint-test "(define (f61 x) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0)))"
+ " define: perhaps (define (f61 x) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0))) -> (define (f61 y) (if (positive? y) (f61 (- y 1)) 0))")
+ (lint-test "(define (f61 x) (let loop ((x x)) (if (positive? x) (loop (- x 1)) 0)))"
+ " define: perhaps (define (f61 x) (let loop ((x x)) (if (positive? x) (loop (- x 1)) 0))) -> (define (f61 x) (if (positive? x) (f61 (- x 1)) 0))")
+ (lint-test "(define (f61) (let loop () (if (positive? x) (loop) 0)))"
+ " define: perhaps (define (f61) (let loop () (if (positive? x) (loop) 0))) -> (define (f61) (if (positive? x) (f61) 0))")
+
+ (lint-test "(let () (define (get-xyzzy a) (+ 1 (car a)))
+ (define (set-xyzzy a b) (cons (+ a 1) b))
+ (set-xyzzy x (get-xyzzy y)))"
+ "let: perhaps use dilambda and generalized set! for get-xyzzy and set-xyzzy:
+ replace (get-xyzzy ...) with (xyzzy ...) and (set-xyzzy ... b) with (set! (xyzzy ...) b)
+ (define xyzzy (dilambda (lambda (a) (+ 1 (car a))) (lambda (a b) (cons (+ a 1) b))))")
+ (lint-test "(let () (define (xyzzy-ref a) (+ 1 (car a)))
+ (define (xyzzy-set! a b) (cons (+ a 1) b))
+ (xyzzy-set! x (xyzzy-ref y)))"
+ "let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
+ replace (xyzzy-ref ...) with (xyzzy ...) and (xyzzy-set! ... b) with (set! (xyzzy ...) b)
+ (define xyzzy (dilambda (lambda (a) (+ 1 (car a))) (lambda (a b) (cons (+ a 1) b))))")
+ (lint-test "(let () (define (get-xyzzy) (+ 1 (car a)))
+ (define (set-xyzzy b) (set! z b))
+ (set-xyzzy x) (get-xyzzy))"
+ "let: perhaps use dilambda and generalized set! for get-xyzzy and set-xyzzy:
+ replace (get-xyzzy) with (xyzzy) and (set-xyzzy b) with (set! (xyzzy) b)
+ (define xyzzy (dilambda (lambda () (+ 1 (car a))) (lambda (b) (set! z b))))")
+ (lint-test "(let () (define (xyzzy-ref xyzzy b) (+ b (car xyzzy)))
+ (define (xyzzy-set! xyzzy b c) (list (+ xyzzy c) b))
+ (xyzzy-set! obj (xyzzy-ref obj y) z))"
+ "let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
+ replace (xyzzy-ref ...) with (xyzzy ...) and (xyzzy-set! ... c) with (set! (xyzzy ...) c)
+ (define xyzzy (dilambda (lambda (_1_ b) (+ b (car _1_))) (lambda (_1_ b c) (list (+ _1_ c) b))))")
+ (lint-test "(let () (define (xyz-get-zy xyzzy b) (+ b (car xyzzy)))
+ (define (xyz-set-zy xyzzy b c) (list (+ xyzzy c) b))
+ (xyz-set-zy obj (xyz-get-zy obj y) z))"
+ "let: perhaps use dilambda and generalized set! for xyz-get-zy and xyz-set-zy:
+ replace (xyz-get-zy ...) with (xyz-zy ...) and (xyz-set-zy ... c) with (set! (xyz-zy ...) c)
+ (define xyz-zy (dilambda (lambda (xyzzy b) (+ b (car xyzzy))) (lambda (xyzzy b c) (list (+ xyzzy c) b))))")
+
+ (lint-test "(define (f70 a b) (let ((a a) (b b)) (+ a b)))"
+ " define: in (define (f70 a b) (let ((a a) (b b)) (+ a b))) this let binding is pointless: (a a)
+ define: in (define (f70 a b) (let ((a a) (b b)) (+ a b))) this let binding is pointless: (b b)
+ f70: perhaps (let ((a a) (b b)) (+ a b)) -> (+ a b)")
+ (lint-test "(let () (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) (f74 2))"
+ " let: perhaps (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) -> (define (f74 c) (f74 (+ c 1)))")
+ (lint-test "(let () (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) (f74 2))"
+ " let: perhaps (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) -> (define (f74 b) (f74 (+ b 1)))")
+ (lint-test "(let () (define f74 (lambda (b) (let loop ((b b) (c 0)) (loop (+ b c))))) (f74 2))"
+ " loop: loop needs 2 arguments: (loop (+ b c))
+ let: a toss-up -- perhaps (define f74 (lambda (b) (let loop ((b b) (c 0)) (loop (+ b c))))) -> (define* (f74 b (c 0)) (f74 (+ b c)))")
+
+ (lint-test "(let () (define (f1 x) (+ x 1)) (define (f2 a) (+ (a 1) 1)) (let ((b (f1 2))) (f2 f1) (+ b (f1 2) (f1 2) (f1 2))))" "")
+ (lint-test "(let () (define (f1 x) (+ x 1)) (let ((b (f1 2))) (+ b (f1 2) (f1 2) (f1 2))))" " let: f1's 'x parameter is always 2 (4 calls)")
+
+ (let ((old-arity *report-func-as-arg-arity-mismatch*))
+ (set! *report-func-as-arg-arity-mismatch* #t)
+ (lint-test "(let () (define (f43 x) (+ x 1)) (define (f44 y z) (y (+ z 1) abs)) (f44 f43 2))"
+ " let: f44's parameter y is passed f43 and called (y (+ z 1) abs), but f43 takes only 1 argument")
+ (lint-test "(let () (define (f45 x) (+ x 1)) (define (f46 y z) (if z (y))) (f46 f45 2))"
+ " let: f46's parameter y is passed f45 and called (y), but f45 needs 1 argument")
+ (lint-test "(let () (define (f47 y z) (y (+ z 1) abs)) (f47 abs 2))"
+ " let: perhaps (... (define (f47 y z) (y (+ z 1) abs)) (f47 abs 2)) -> (... (let ((y abs) (z 2)) (y (+ z 1) abs)))
+ let: f47's parameter y is passed abs and called (y (+ z 1) abs), but abs takes only 1 argument")
+ (lint-test "(let () (define (f48 y z) (if z (y))) (f48 abs 2))"
+ " let: perhaps (... (define (f48 y z) (if z (y))) (f48 abs 2)) -> (... (let ((y abs) (z 2)) (if z (y))))
+ let: f48's parameter y is passed abs and called (y), but abs needs 1 argument")
+ (lint-test "(let () (define (f49 y z) (y (+ z 1))) (f49 (lambda () (+ a 1)) 2))"
+ " let: perhaps (... (define (f49 y z) (y (+ z 1))) (f49 (lambda () (+ a 1)) 2)) -> (... (let ((y (lambda () (+ a 1))) (z 2)) (y (+ z 1))))
+ let: f49's parameter y is passed (lambda () (+ a 1)) and called (y (+ z 1)), but (lambda () (+ a 1)) takes only 0 arguments")
+ (lint-test "(let () (define (f50 y z) (y (+ z 1))) (f50 (lambda (a b) (+ a 1)) 2))"
+ " let: perhaps (... (define (f50 y z) (y (+ z 1))) (f50 (lambda (a b) (+ a 1)) 2)) ->
+ (... (let ((y (lambda (a b) (+ a 1))) (z 2)) (y (+ z 1))))
+ let: f50's parameter y is passed (lambda (a b) (+ a 1)) and called (y (+ z 1)), but (lambda (a b) (+ a 1)) needs 2 arguments")
+ (set! *report-func-as-arg-arity-mismatch* old-arity))
+
+ (lint-test "(let ((x (read-byte)) (y (read-byte))) (- x y))"
+ " let: order of evaluation of let's bindings is unspecified, so (let ((x (read-byte)) (y (read-byte))) (- x y)) is trouble
+ let: perhaps (let ((x (read-byte)) (y (read-byte))) (- x y)) -> (- (read-byte) (read-byte))")
+ (lint-test "(list (read port) (read-char port))"
+ " list: order of evaluation of list's arguments is unspecified, so (list (read port) (read-char port)) is trouble")
+ (lint-test "(list (read port) (read-char))" "")
+ (lint-test "(list (set! x 3) (+ x 1))"
+ " list: order of evaluation of list's arguments is unspecified, so (list (set! x 3) (+ x 1)) is trouble")
+ (lint-test "(list (throw 'oops) 1 2)" "")
+ (lint-test "(list (throw 'oops) 1 (read-byte))"
+ " list: order of evaluation of list's arguments is unspecified, so (list (throw 'oops) 1 (read-byte)) is trouble")
+
+ (lint-test "(and (< 0 x) (< x 1))" " and: perhaps (and (< 0 x) (< x 1)) -> (< 0 x 1)")
+ (lint-test "(and (< 1 x) (< x 1))" " and: perhaps (and (< 1 x) (< x 1)) -> #f")
+ (lint-test "(and (< 1 x) (< x 0))" " and: perhaps (and (< 1 x) (< x 0)) -> #f")
+ (lint-test "(and (<= 0 x) (<= x 1))" " and: perhaps (and (<= 0 x) (<= x 1)) -> (<= 0 x 1)")
+ (lint-test "(and (<= 1 x) (<= x 1))" " and: perhaps (and (<= 1 x) (<= x 1)) -> (= 1 x)")
+ (lint-test "(and (<= 1 x) (<= x 0))" " and: perhaps (and (<= 1 x) (<= x 0)) -> #f")
+ (lint-test "(and (< 0 x) (<= x 1))" "")
+ (lint-test "(and (< 1 x) (<= x 1))" " and: perhaps (and (< 1 x) (<= x 1)) -> #f")
+ (lint-test "(and (< 1 x) (<= x 0))" " and: perhaps (and (< 1 x) (<= x 0)) -> #f")
+ (lint-test "(and (<= 0 x) (< x 1))" "")
+ (lint-test "(and (<= 1 x) (< x 1))" " and: perhaps (and (<= 1 x) (< x 1)) -> #f")
+ (lint-test "(and (<= 1 x) (< x 0))" " and: perhaps (and (<= 1 x) (< x 0)) -> #f")
+ (lint-test "(or (< 0 x) (< x 1))" " or: perhaps (or (< 0 x) (< x 1)) -> #t")
+ (lint-test "(or (< 1 x) (< x 1))" " or: perhaps (or (< 1 x) (< x 1)) -> (not (= x 1))")
+ (lint-test "(or (< 1 x) (< x 0))" " or: perhaps (or (< 1 x) (< x 0)) -> (not (>= 1 x 0))")
+ (lint-test "(or (<= 0 x) (<= x 1))" " or: perhaps (or (<= 0 x) (<= x 1)) -> #t")
+ (lint-test "(or (<= 1 x) (<= x 1))" " or: perhaps (or (<= 1 x) (<= x 1)) -> #t")
+ (lint-test "(or (<= 1 x) (<= x 0))" " or: perhaps (or (<= 1 x) (<= x 0)) -> (not (> 1 x 0))")
+ (lint-test "(or (< 0 x) (<= x 1))" " or: perhaps (or (< 0 x) (<= x 1)) -> #t")
+ (lint-test "(or (< 1 x) (<= x 1))" " or: perhaps (or (< 1 x) (<= x 1)) -> #t")
+ (lint-test "(or (< 1 x) (<= x 0))" "")
+ (lint-test "(or (<= 0 x) (< x 1))" " or: perhaps (or (<= 0 x) (< x 1)) -> #t")
+ (lint-test "(or (<= 1 x) (< x 1))" " or: perhaps (or (<= 1 x) (< x 1)) -> #t")
+ (lint-test "(or (<= 1 x) (< x 0))" "")
+ (lint-test "(or (< x 0) (> x 9))" " or: perhaps (or (< x 0) (> x 9)) -> (not (<= 0 x 9))")
+ (lint-test "(or (> 0 x) (> x 9))" " or: perhaps (or (> 0 x) (> x 9)) -> (not (<= 0 x 9))")
+ (lint-test "(or (>= 0 x) (>= x 9))" " or: perhaps (or (>= 0 x) (>= x 9)) -> (not (< 0 x 9))")
+ (lint-test "(or (> x 9) (< x 0))" " or: perhaps (or (> x 9) (< x 0)) -> (not (>= 9 x 0))")
+
+ (lint-test "(< 0 x 1)" "")
+ (lint-test "(< 1 x 1)" " <: it looks odd to have repeated arguments in (< 1 x 1) <: this comparison can't be true: (< 1 x 1) <: perhaps (< 1 x 1) -> #f")
+ (lint-test "(< 1 x 0)" " <: this comparison can't be true: (< 1 x 0)") ; return #f!
+ (lint-test "(<= 0 x 1)" "")
+ (lint-test "(<= 1 x 1)" " <=: it looks odd to have repeated arguments in (<= 1 x 1) <=: perhaps (<= 1 x 1) -> (= 1 x)")
+ (lint-test "(<= 1 x 0)" " <=: this comparison can't be true: (<= 1 x 0)")
+
+ (lint-test "(if (>= (length x) 1) y z)" " if: perhaps (assuming x is a proper list), (>= (length x) 1) -> (pair? x)")
+; (lint-test "(if (> (length x) 1) y z)" " if: perhaps (assuming x is a proper list), (> (length x) 1) -> (and (pair? x) (pair? (cdr x)))")
+ (lint-test "(if (< (length x) 1) y z)" " if: perhaps (assuming x is a proper list), (< (length x) 1) -> (null? x)")
+ (lint-test "(if (<= (length x) 1) y z)" " if: perhaps (assuming x is a proper list), (<= (length x) 1) -> (or (null? x) (null? (cdr x)))")
+ (lint-test "(if (= (length x) 1) y z)" " if: perhaps (assuming x is a list), (= (length x) 1) -> (and (pair? x) (null? (cdr x)))")
+ (lint-test "(if (>= (length x) 0) y z)" " if: perhaps (assuming x is a proper list), (>= (length x) 0) -> (list? x)")
+ (lint-test "(if (> (length x) 0) y z)" " if: perhaps (assuming x is a proper list), (> (length x) 0) -> (pair? x)")
+ (lint-test "(if (< (length x) 0) y z)" " if: perhaps (< (length x) 0) -> (and (pair? x) (not (proper-list? x)))")
+ (lint-test "(if (<= (length x) 0) y z)" " if: perhaps (assuming x is a proper list), (<= (length x) 0) -> (null? x)")
+ (lint-test "(if (= (length x) 0) y z)" " if: perhaps (assuming x is a list), (= (length x) 0) -> (null? x)")
+ (lint-test "(if (>= 0 (length x)) y z)" " if: perhaps (assuming x is a proper list), (>= 0 (length x)) -> (null? x)")
+ (lint-test "(if (> 0 (length x)) y z)" " if: perhaps (> 0 (length x)) -> (and (pair? x) (not (proper-list? x)))")
+ (lint-test "(if (< 0 (length x)) y z)" " if: perhaps (assuming x is a proper list), (< 0 (length x)) -> (pair? x)")
+ (lint-test "(if (<= 0 (length x)) y z)" " if: perhaps (assuming x is a proper list), (<= 0 (length x)) -> (list? x)")
+ (lint-test "(if (= 0 (length x)) y z)" " if: perhaps (assuming x is a list), (= 0 (length x)) -> (null? x)")
+ (lint-test "(if (>= 1 (length x)) y z)" " if: perhaps (assuming x is a proper list), (>= 1 (length x)) -> (or (null? x) (null? (cdr x)))")
+ (lint-test "(if (> 1 (length x)) y z)" " if: perhaps (assuming x is a proper list), (> 1 (length x)) -> (null? x)")
+; (lint-test "(if (< 1 (length x)) y z)" " if: perhaps (assuming x is a proper list), (< 1 (length x)) -> (and (pair? x) (pair? (cdr x)))")
+ (lint-test "(if (<= 1 (length x)) y z)" " if: perhaps (assuming x is a proper list), (<= 1 (length x)) -> (pair? x)")
+ (lint-test "(if (= 1 (length x)) y z)" " if: perhaps (assuming x is a list), (= 1 (length x)) -> (and (pair? x) (null? (cdr x)))")
+ (lint-test "(if (null? x) () (map abs x))" " if: perhaps (if (null? x) () (map abs x)) -> (map abs x)")
+
+ (lint-test "(define ((foo x) y) (list x y))"
+ " define: strange form: (define ((foo x) y) (list x y))
+ define: perhaps (define ((foo x) y) (list x y)) -> (define (foo x) (lambda (y) (list x y)))")
+ (lint-test "(define ((foo x) y) (+ (* -1 x) y))"
+ " define: strange form: (define ((foo x) y) (+ (* -1 x) y))
+ define: perhaps (define ((foo x) y) (+ (* -1 x) y)) -> (define (foo x) (lambda (y) (+ (* -1 x) y)))
+ foo: perhaps (+ (* -1 x) y) -> (- y x)")
+
+ ;; this needs work (never #f vars are tricky)
+ (lint-test "(equal? x abs)" " equal?: equal? could be eq? in (equal? x abs)")
+ (lint-test "(equal? x begin)" " equal?: equal? could be eq? in (equal? x begin)")
+ (lint-test "(equal? x lint)" "")
+
+; (lint-test "(let ((x ())) (set! x (cons 1 x)) (if x 3 2))" " let: x is never #f, so (if x 3 2) is 3")
+; (lint-test "(let ((x ())) (if x 3 2))" " let: x is never #f, so (if x 3 2) is 3")
+ (lint-test "(let ((x ())) (if (pair? x) 3 2))" " let: perhaps (let ((x ())) (if (pair? x) 3 2)) -> (if (pair? ()) 3 2)")
+
+; (lint-test "(let ((x 0)) (if x 3 2))" " let: x is never #f, so (if x 3 2) is 3")
+ (lint-test "(let ((x 0)) (if (zero? x) 3 2))"
+ " let: perhaps (let ((x 0)) (if (zero? x) 3 2)) -> (if (zero? 0) 3 2)
+ let: x is 0, so (zero? x) is #t")
+ (lint-test "(let ((x 0)) (set! x ()) (if x 3 2))" " let: perhaps (let ((x 0)) (set! x ()) (if x 3 2)) -> (let ((x ())) (if x 3 2))")
+ (lint-test "(let ((x 0)) (set! x ()) (if (null? x) 3 2))"
+ " let: perhaps (let ((x 0)) (set! x ()) (if (null? x) 3 2)) -> (let ((x ())) (if (null? x) 3 2))")
+ (lint-test "(let ((x 0)) (display x) (set! x ()) (if (null? x) 3 2))" "")
+
+; (lint-test "(let ((x 0)) (when x 3))" " let: x is never #f, so (when x 3) is 3")
+ (lint-test "(let ((x 0)) (when (zero? x) 3))"
+ " let: perhaps (let ((x 0)) (when (zero? x) 3)) -> (when (zero? 0) 3)
+ let: x is 0, so (zero? x) is #t")
+ (lint-test "(let ((x 0)) (set! x ()) (unless x 3))" " let: perhaps (let ((x 0)) (set! x ()) (unless x 3)) -> (let ((x ())) (unless x 3))")
+
+ (lint-test "(let ((x 0)) (cond (x 3) (else 4)))" "")
+ (lint-test "(let ((x 0)) (cond ((zero? x) 3) (else 4)))" " let: x is 0, so (zero? x) is #t")
+ (lint-test "(let ((x 0)) (set! x ()) (cond (x 3) (else 4)))"
+ " let: perhaps (let ((x 0)) (set! x ()) (cond (x 3) (else 4))) -> (let ((x ())) (cond (x 3) (else 4)))")
+
+ (lint-test "(let ((x 0)) (case x ((0) 3) (else 4)))" " let: perhaps (case x ((0) 3) (else 4)) -> (if (eqv? x 0) 3 4)")
+ (lint-test "(let ((x 0)) (do ((i x (+ i 1))) ((= i 0))))"
+ " let: this do-loop could be replaced by (): (do ((i x (+ i 1))) ((= i 0)))
+ let: perhaps (let ((x 0)) (do ((i x (+ i 1))) ((= i 0)))) -> (do ((i 0 (+ i 1))) ...)")
+
+ (lint-test "(if (or (eq? x abs) (eq? x case) (eq? x null?)) 3 2)" "")
+ (lint-test "(cond ((eq? x begin) 1) ((eq? x reader-cond) 2) ((eq? x lint) 3))" "")
+ (lint-test "(cond ((eq? x 'begin) 1) ((eq? x 'reader-cond) 2) ((eq? x 'lint) 3))"
+ " cond: perhaps use case instead of cond:
+ (cond ((eq? x 'begin) 1) ((eq? x 'reader-cond) 2) ((eq? x 'lint) 3)) -> (case x ((begin) 1) ((reader-cond) 2) ((lint) 3))")
+
+ (lint-test "(let ((x (getenv \"HOME\"))) (if x (display x)))"
+ " let: perhaps (let ((x (getenv \"HOME\"))) (if x (display x))) -> (cond ((getenv \"HOME\") => display))
+ let: x is never #f, so (if x (display x)) is (display x)")
+ (lint-test "(and-let* ((x (f y))) (abs x))" " and-let*: perhaps (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs))")
+ (lint-test "(let () (define* (f51 (a 3)) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1))"
+ " let: perhaps (... (define* (f51 (a 3)) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1)) ->
+ (... (let* f51 ((a -1)) (if (zero? a) 3 (f51 (- a 1)))))")
+ (lint-test "(let () (define* (f51 (a 3) b) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1))"
+ " let: perhaps (... (define* (f51 (a 3) b) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1)) ->
+ (... (let* f51 ((a -1) (b #f)) (if (zero? a) 3 (f51 (- a 1)))))")
+ (lint-test "(let () (define* (f51 (a 3) (b 32)) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1))"
+ " let: perhaps (... (define* (f51 (a 3) (b 32)) (if (zero? a) 3 (f51 (- a 1)))) (f51 -1)) ->
+ (... (let* f51 ((a -1) (b 32)) (if (zero? a) 3 (f51 (- a 1)))))")
+ (lint-test "(let () (lambda (a b) (+ a (* 2 b))))" " let: pointless let: (let () (lambda (a b) (+ a (* 2 b)))) -> (lambda (a b) (+ a (* 2 b)))")
+ (lint-test "(let () (define (f x) x) (do ((i 0 (+ i 1))) ((= i 10)) (f i)))"
+ " let: this do-loop could be replaced by (): (do ((i 0 (+ i 1))) ((= i 10)) (f i))
+ let: this could be omitted: (f i)
+ let: perhaps (do ((i 0 (+ i 1))) ((= i 10)) (f i)) -> (do ((i 0 (+ i 1))) ((= i 10)) i)")
+ (lint-test "(let () (define (f x) (abs (* 2 x))) (do ((i 0 (+ i 1))) ((= i 10)) (f i)))"
+ " let: this do-loop could be replaced by (): (do ((i 0 (+ i 1))) ((= i 10)) (f i))
+ let: this could be omitted: (f i)
+ let: perhaps (do ((i 0 (+ i 1))) ((= i 10)) (f i)) -> (do ((i 0 (+ i 1))) ((= i 10)) (abs (* 2 i)))")
+
+ (lint-test "(let ((x 1)) (and x (< x 1)))"
+ " in (and x (< x 1)), perhaps change (and x ...) to (and (real? x) ...)
+ let: x is an integer, so (and x (< x 1)) -> (< x 1)")
+ (lint-test "(let ((x 1)) (and (< x 1) x))" "")
+ (lint-test "(let ((x 1)) (and x (< x 1) x))" " let: x is an integer, so (and x (< x 1) x) -> (and (< x 1) x)")
+ (lint-test "(let ((x 1)) (not x))" " let: perhaps (let ((x 1)) (not x)) -> (not 1) let: x is an integer, so (not x) -> #f")
+
+ (lint-test "(let ((l 1)) (+ l 1))" " let: perhaps (let ((l 1)) (+ l 1)) -> (+ 1 1) let: \"l\" is a really bad variable name")
+ (lint-test "(let ((let 1)) (+ let 1))" " let: perhaps (let ((let 1)) (+ let 1)) -> (+ 1 1) let: let variable named let is asking for trouble")
+ (let ((old-report *report-bad-variable-names*))
+ (set! *report-bad-variable-names* '(info data))
+ (lint-test "(let ((data 1)) (+ data 32))"
+ " let: perhaps (let ((data 1)) (+ data 32)) -> (+ 1 32)
+ let: surely there's a better name for this variable than data")
+ (lint-test "(let ((info1 32) (info-1 31)) (+ info1 info-1))"
+ " let: perhaps (let ((info1 32) (info-1 31)) (+ info1 info-1)) -> (+ 32 31)
+ let: surely there's a better name for this variable than info-1
+ let: surely there's a better name for this variable than info1")
+ (set! *report-bad-variable-names* old-report))
+
+ (let ((old-report *report-built-in-functions-used-as-variables*))
+ (set! *report-built-in-functions-used-as-variables* #t)
+ (lint-test "(let ((list 3)) (display list))"
+ " let: perhaps (let ((list 3)) (display list)) -> (display 3)
+ let: let variable named list is asking for trouble")
+ (lint-test "(let ((cond 3)) (display cond))"
+ " let: perhaps (let ((cond 3)) (display cond)) -> (display 3)
+ let: let variable named cond is asking for trouble")
+ (lint-test "(let () (define (f50 abs) (abs -1)) (f50 positive?))"
+ " let: perhaps (... (define (f50 abs) (abs -1)) (f50 positive?)) -> (... (let ((abs positive?)) (abs -1)))
+ let: f50's parameter abs is called (abs -1) : find a less confusing parameter name!
+ f50: f50 parameter named abs is asking for trouble")
+ (lint-test "(let () (define (f50 abs) (positive? abs)) (f50 -1))"
+ " let: perhaps (... (define (f50 abs) (positive? abs)) (f50 -1)) -> (... (let ((abs -1)) (positive? abs)))
+ f50: f50 could be (define f50 positive?)
+ f50: f50 parameter named abs is asking for trouble")
+ (set! *report-built-in-functions-used-as-variables* old-report))
+
+ (lint-test "(error 'error \"ERROR SOMEWHERE UP TO HERE\")" " error: There's no need to shout: (error 'error \"ERROR SOMEWHERE UP TO HERE\")")
+
(when (provided? 'snd)
(lint-test "(if (real? (oscil x)) 1.0 0.0)" " if: perhaps (if (real? (oscil x)) 1.0 0.0) -> 1.0")
(lint-test "(if (pair? (oscil x)) 1.0 0.0)" " if: perhaps (if (pair? (oscil x)) 1.0 0.0) -> 0.0")
(lint-test "(if (float? (oscil x)) 1.0 0.0)" " if: perhaps (if (float? (oscil x)) 1.0 0.0) -> 1.0")
- (lint-test "(radians->hz 3.4+i)" " radians->hz: radians->hz's argument should be a real?: 3.4+1i: (radians->hz 3.4+1i)")
+ (lint-test "(radians->hz 3.4+i)" " radians->hz: in (radians->hz 3.4+1i), radians->hz's argument should be real, but 3.4+1i is complex?")
(lint-test "(string-ref (radians->hz x) 3)"
- " string-ref: string-ref's argument 1 should be a string?: (radians->hz x): (string-ref (radians->hz x) 3)")
-
+ " string-ref: in (string-ref (radians->hz x) 3), string-ref's argument 1 should be a string, but (radians->hz x) is a float?")
(lint-test "(set! (print-length) \"asd\")" " set!: print-length: new value should be an integer?: string?: (set! (print-length) \"asd\")")
(lint-test "(set! (print-length) 9)" "")
(lint-test "(set! (show-indices) 32)" " set!: show-indices: new value should be a boolean?: integer?: (set! (show-indices) 32)")
(lint-test "(set! (show-indices) #t)" "")
- )
+ (lint-test "(let () (mus-header-type-name 121))" " let: mus-header-type-name's argument, 121, should be an integer between 1 and 70")
+ (lint-test "(let () (mus-header-type-name 2))" "")
+ (lint-test "(let () (mus-header-type-name 3.5))" " let: in (mus-header-type-name 3.5), mus-header-type-name's argument should be an integer, but 3.5 is real?")
+ (lint-test "(let () (mus-header-type-name mus-aiff))" "")
+
+ (when (provided? 'snd-gtk)
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) GTK_POS_TOP)" "")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) GTK_RELIEF_HALF)"
+ " gtk_scale_set_value_pos: gtk_scale_set_value_pos's argument, GTK_RELIEF_HALF, should be GTK_POS_RIGHT")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) GDK_RELEASE_MASK)"
+ " gtk_scale_set_value_pos: gtk_scale_set_value_pos's argument, GDK_RELEASE_MASK, should be between 0 and 3")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) 1)"
+ " gtk_scale_set_value_pos: gtk_scale_set_value_pos's argument, 1, should be GTK_POS_RIGHT")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) 10)"
+ " gtk_scale_set_value_pos: gtk_scale_set_value_pos's argument, 10, should be between 0 and 3")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) x)" "")
+ (lint-test "(gtk_scale_set_value_pos (GTK_SCALE scale) 1/2)"
+ " gtk_scale_set_value_pos: in (gtk_scale_set_value_pos (GTK_SCALE scale) 1/2),
+ gtk_scale_set_value_pos's argument 2 should be an integer, but 1/2 is rational?")
+ ))
+
+#|
+ ;; a way to test internal lint functions:
+ (define fmatch (*lint* 'function-match))
+ (define walkfunc (*lint* 'lint-walk-function))
+ (define (f1 x) (if (< x 3) (+ x 1) (+ x 2)))
+ (let ((e (walkfunc 'define 'f1 '(x) '((if (< x 3) (+ x 1) (+ x 2))) '(define (f1 x) (if (< x 3) (+ x 1) (+ x 2))) ())))
+ (fmatch 'tester '(if (< y 3) (+ y 1) (+ y 2)) e))
+ (define sequal? (*lint* 'structures-equal?))
+ (sequal? '(if (< y 3) (+ y 1) (+ y 2)) '(if (< x 3) (+ x 1) (+ x 2)) '((y . :unset)) () ())
+|#
(define f321
(let ((signature '(float? integer?)))
@@ -85071,11 +88391,56 @@ etc
(if (integer? int)
(* 1.0 int)
(error 'wrong-type-arg "~A: ~A is not an integer" f321 int)))))
- (lint-test "(string-ref (f321 3) 2)" " string-ref: string-ref's argument 1 should be a string?: (f321 3): (string-ref (f321 3) 2)")
+ (lint-test "(string-ref (f321 3) 2)" " string-ref: in (string-ref (f321 3) 2), string-ref's argument 1 should be a string, but (f321 3) is a float?")
(set! reader-cond #f)
)
+#|
+;; here's a reasonably complete test of part of the 'or handling
+(let ((ops #(not = null? eof-object? boolean? eq? eqv? equal? memq memv member char=? string=? char-ci=? string-ci=? zero?))
+ (op-args #(2 3 2 2 2 3 3 3 3 3 3 3 3 3 3 2))
+ (xvals #(0 10000 1.0 10000.0 1+i 1/2 #\a #\A "a" "A" "" #() #(#f) #<eof> () #f #t a b (1 10000)))
+ (yvals #(0 10000 1.0 10000.0 1+i 1/2 #\a #\A "a" "A" "" #() #(#f) #<eof> () #f #t a b (1 10000)))
+ ;; val list must be repeated else we'll get bogus eq? -> #t hits
+ (val-quoted #(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t)))
+ (for-each
+ (lambda (t1 t1-args)
+ (for-each
+ (lambda (t2 t2-args)
+ (for-each
+ (lambda (x)
+ (for-each
+ (lambda (y q)
+ (catch #t
+ (lambda ()
+ (let ((f1 (if (= t1-args 2) `(,t1 x) (if q `(,t1 x ',y) `(,t1 x ,y))))
+ (f2 (if (= t2-args 2) `(,t2 x) (if q `(,t2 x ',y) `(,t2 x ,y))))
+ (x1 (if q `(x ',x) `(x ,x))))
+ (let ((result (eval `(let (,x1) (or ,f1 ,f2))))) ; check for errors in basic expr
+ (let ((val (call-with-output-string
+ (lambda (op)
+ (call-with-input-string (format #f "(let (~S) (or ~S ~S))" x1 f1 f2)
+ (lambda (ip)
+ (lint ip op)))))))
+ (when (positive? (length val))
+ (let ((pos (and (not (string-position "let: " val)) ; ignore various eqx problems that lint will report
+ (string-position " -> " val))))
+ (when pos
+ (let ((form (with-input-from-string (substring val (+ pos 3)) read)))
+ (let ((new-val (eval form)))
+ (when (not (eq? (not result) (not new-val)))
+ (format *stderr* "(let (~S) (or ~S ~S)) -> ~S~% ~A -> ~S~%"
+ x1 f1 f2 result
+ (substring val (+ pos 3)) new-val)))))))))))
+ (lambda (type info)
+ 'error)))
+ yvals val-quoted))
+ xvals))
+ ops op-args))
+ ops op-args))
+|#
+
#|
@@ -85265,6 +88630,14 @@ apparently in solaris, it's NaN.0 not nan.0?
(format *stderr* "~A " s)))
(symbol-table))
+ (for-each
+ (lambda (s)
+ (if (and (procedure? (symbol->value s))
+ (let ((p (procedure-signature (symbol->value s))))
+ (and (pair? p) (pair? (car p)) (memq 'boolean? (car p)))))
+ (format *stderr* "~A " s)))
+ (symbol-table))
+
(for-each
(lambda (s)
(if (and (dilambda? (symbol->value s))
@@ -85299,5 +88672,3 @@ apparently in solaris, it's NaN.0 not nan.0?
(s7-version)
(if s7test-exits (exit))
-
-
diff --git a/s7webserver/Makefile b/s7webserver/Makefile
new file mode 100644
index 0000000..62b6ad9
--- /dev/null
+++ b/s7webserver/Makefile
@@ -0,0 +1,34 @@
+CC ?= gcc
+CCC ?= g++
+PKG ?= pkg-config
+MOC ?= moc-qt4
+QMAKE ?= qmake-qt4
+
+all: s7webserver
+
+clean:
+ rm -fr *.o mus-config.h master.tar.gz qhttpserver-master.tar.gz qhttpserver-master s7webserver moc_s7webserver.cpp
+
+s7webserver: s7webserver.o qhttpserver-master/lib/libqhttpserver.a s7.o mus-config.h
+ $(CCC) s7webserver.o `$(PKG) --libs QtNetwork` qhttpserver-master/lib/libqhttpserver.a s7.o -ldl -o s7webserver
+
+s7webserver.o: s7webserver.h s7webserver.cpp moc_s7webserver.cpp qhttpserver-master/lib/libqhttpserver.a mus-config.h
+ $(CCC) -c s7webserver.cpp `$(PKG) --cflags QtNetwork` -Iqhttpserver-master/src -I. -I.. -Wall -Werror -Wno-error=unused-variable -Wno-error=unused-function
+
+moc_s7webserver.cpp: s7webserver.h qhttpserver-master/lib/libqhttpserver.a mus-config.h
+ $(MOC) -DCOMPILING_S7WEBSERVER s7webserver.h -o moc_s7webserver.cpp
+
+s7.o: ../s7.c ../s7.h mus-config.h
+ $(CC) -c ../s7.c -I. -I..
+
+mus-config.h:
+ touch mus-config.h
+
+qhttpserver-master/lib/libqhttpserver.a:
+ rm -fr qhttpserver-master.tar.gz qhttpserver-master
+ wget https://github.com/kmatheussen/qhttpserver/archive/master.tar.gz
+ mv master.tar.gz qhttpserver-master.tar.gz
+ tar xvzf qhttpserver-master.tar.gz
+ echo "CONFIG += staticlib" >> qhttpserver-master/src/src.pro
+ cd qhttpserver-master && $(QMAKE)
+ cd qhttpserver-master && make
diff --git a/s7webserver/s7webserver.cpp b/s7webserver/s7webserver.cpp
new file mode 100644
index 0000000..4026462
--- /dev/null
+++ b/s7webserver/s7webserver.cpp
@@ -0,0 +1,313 @@
+/*
+ Written by Kjetil Matheussen: k.s.matheussen at notam02.no
+
+ See s7webserver.h for instructions on how to compile the server.
+*/
+
+
+#include <unistd.h>
+
+#include "s7.h"
+
+#define COMPILING_S7WEBSERVER 1
+#include "s7webserver.h"
+#include "moc_s7webserver.cpp"
+
+#include <QCoreApplication>
+
+#include <qhttpserver.h>
+#include <qhttprequest.h>
+#include <qhttpresponse.h>
+
+
+S7WebServer::S7WebServer(s7_scheme *s7, int portnumber)
+ : s7(s7)
+ , portnumber(portnumber)
+ , verbose(false)
+ , very_verbose(false)
+{
+ QHttpServer *server = new QHttpServer(this);
+ connect(server, SIGNAL(newRequest(QHttpRequest*, QHttpResponse*)),
+ this, SLOT(handleRequest(QHttpRequest*, QHttpResponse*)));
+
+ has_started = server->listen(QHostAddress::Any, portnumber);
+}
+
+
+void S7WebServer::handleRequest(QHttpRequest *req, QHttpResponse *resp)
+{
+ new S7WebServerResponder(this, req, resp);
+}
+
+
+// function written by Rick Taube for common music (https://ccrma.stanford.edu/software/snd/snd/s7.html#repl)
+static bool is_balanced(std::string str)
+{
+ int parens = 0;
+ int quotes = 0;
+ unsigned i = 0;
+ while (i < str.size())
+ {
+ if (str[i] == ';')
+ {
+ for (i = i + 1; i < str.size(); i++)
+ {
+ if (str[i] == '\n')
+ break;
+ }
+ }
+ else if (str[i] == '"')
+ {
+ if (i == 0 || str[i - 1] != '\\')
+ {
+ quotes = 1;
+ for (i = i + 1; i < str.size(); i++)
+ {
+ if (str[i] == '"' && str[i - 1] != '\\')
+ {
+ quotes = 0;
+ break;
+ }
+ }
+ if (quotes)
+ return false;
+ }
+ }
+ else if (str[i] == '(')
+ parens++;
+ else if (str[i] == ')')
+ parens--;
+ i++;
+ }
+ return (parens == 0) && (quotes == 0);
+}
+
+
+// function written by Rick Taube for common music (https://ccrma.stanford.edu/software/snd/snd/s7.html#repl)
+static bool is_white(std::string str)
+{
+ for (unsigned i = 0; (i < str.size() && str[i] != ';'); i++)
+ if (str[i] != ' ' && str[i] != '\n' && str[i] != '\t')
+ return false;
+ return true;
+}
+
+
+S7WebServerResponder::S7WebServerResponder(S7WebServer *s7webserver, QHttpRequest *request, QHttpResponse *response)
+ : s7webserver(s7webserver)
+ , request(request)
+ , response(response)
+{
+ if (s7webserver->very_verbose)
+ printf("responder got something\n");
+
+ response->setHeader("Content-Type", "text/plain");
+ response->setHeader("Access-Control-Allow-Origin", "*");
+
+ response->writeHead(200);
+
+ connect(request, SIGNAL(data(const QByteArray&)), this, SLOT(accumulate(const QByteArray&)));
+ connect(request, SIGNAL(end()), this, SLOT(reply()));
+ connect(response, SIGNAL(done()), this, SLOT(deleteLater()));
+}
+
+
+void S7WebServerResponder::accumulate(const QByteArray &data)
+{
+ s7webserver->input_code_so_far += data.data();
+ if (s7webserver->very_verbose)
+ printf("code so far: %s\n",s7webserver->input_code_so_far.c_str());
+}
+
+
+static void my_print(s7_scheme *sc, unsigned char c, s7_pointer port)
+{
+
+ S7WebServerResponder *current_responder = static_cast<S7WebServerResponder*>(s7_c_pointer(s7_name_to_value(sc, "s7webserver-current-responder")));
+
+ if (current_responder==NULL || current_responder->s7webserver->verbose)
+ putchar(c);
+
+ if (current_responder != NULL) {
+ current_responder->response->write(QByteArray().append(c));
+ current_responder->response->flush();
+ current_responder->response->waitForBytesWritten();
+ }
+}
+
+
+static void set_s7webserver_current_responder(s7_scheme *sc, S7WebServerResponder *responder){
+ s7_pointer current_responder = s7_make_c_pointer(sc, responder);
+ s7_symbol_set_value(sc, s7_make_symbol(sc, "s7webserver-current-responder"), current_responder);
+}
+
+void S7WebServerResponder::reply()
+{
+ if (s7webserver->very_verbose)
+ printf("Code so far: -%s-\n",s7webserver->input_code_so_far.c_str());
+
+ if (!is_balanced(s7webserver->input_code_so_far)) {
+ response->end(QByteArray("")); //-unbalanced, waiting for more input-"));
+ s7webserver->input_code_so_far += "\n";
+ return;
+ }
+
+ if(is_white(s7webserver->input_code_so_far)) {
+ response->end(QByteArray(""));
+ s7webserver->input_code_so_far = "";
+ return;
+ }
+
+ // Code in here mostly copied from https://ccrma.stanford.edu/software/snd/snd/s7.html#Cerrors
+
+
+ // evaluate with error handling
+ {
+ s7_scheme *s7 = s7webserver->s7;
+
+ int gc_loc = -1;
+
+ /* trap error messages */
+ s7_pointer old_port = s7_set_current_error_port(s7, s7_open_output_string(s7));
+ if (old_port != s7_nil(s7))
+ gc_loc = s7_gc_protect(s7, old_port);
+
+
+ {
+ // call eval
+ set_s7webserver_current_responder(s7, this);
+
+ s7_pointer result = s7_eval_c_string(s7, s7webserver->input_code_so_far.c_str());
+
+ set_s7webserver_current_responder(s7, NULL);
+
+ {
+ const char *result_as_string = s7_object_to_c_string(s7, result);
+ if (s7webserver->verbose)
+ printf("result: %s\n",result_as_string);
+
+ {
+ QByteArray array("result: ");
+ array.append(QByteArray(result_as_string));
+
+ {
+ /* look for error messages */
+ const char *errmsg = s7_get_output_string(s7, s7_current_error_port(s7));
+
+ /* if we got something, wrap it in "[]" */
+ if ((errmsg) && (*errmsg)) {
+ if (s7webserver->verbose)
+ fprintf(stdout, "error message: [%s]\n", errmsg);
+ array.append(QByteArray(errmsg));
+ }
+ }
+
+ response->end(array);
+ }
+ }
+ }
+
+ s7_close_output_port(s7, s7_current_error_port(s7));
+ s7_set_current_error_port(s7, old_port);
+
+ if (gc_loc != -1)
+ s7_gc_unprotect_at(s7, gc_loc);
+ }
+
+ s7webserver->input_code_so_far = "";
+}
+
+
+S7WebServer *s7webserver_create(s7_scheme *s7, int portnum, bool find_first_free_portnum){
+
+ // Start QCoreApplication if it hasn't already been started.
+ if (QCoreApplication::instance()==NULL){
+ static int argc = 1;
+ static const char *argv[1] = {"snd"};
+ new QCoreApplication(argc, (char**)argv);
+ }
+
+ s7_define_variable(s7, "s7webserver-current-responder", s7_make_c_pointer(s7, NULL));
+
+ s7_set_current_output_port(s7, s7_open_output_function(s7, my_print));
+
+ try_again:
+
+ S7WebServer *s7webserver = new S7WebServer(s7, portnum);
+
+ if (s7webserver->has_started==false) {
+ delete s7webserver;
+ s7webserver = NULL;
+
+ if (find_first_free_portnum) {
+ printf("s7webserver: Failed to open port %d, trying port %d instead.\n",portnum,portnum+1);
+ portnum++;
+ goto try_again;
+ }
+ }
+
+ return s7webserver;
+}
+
+void s7webserver_call_very_often(void){
+ QCoreApplication::processEvents();
+}
+
+void s7webserver_set_verbose(S7WebServer *s7webserver, bool verbose) {
+ s7webserver->verbose = verbose;
+}
+
+
+void s7webserver_set_very_verbose(S7WebServer *s7webserver, bool very_verbose) {
+ s7webserver->very_verbose = very_verbose;
+}
+
+int s7webserver_get_portnumber(S7WebServer *s7webserver){
+ return s7webserver->portnumber;
+}
+
+void s7webserver_delete(S7WebServer *s7webserver){
+ delete s7webserver;
+}
+
+
+#ifdef WITH_MAIN
+int main(int argc, char **argv){
+ if (argc<=1) {
+ printf("Usage: s7webserver portnumber [-verbose] [-very-verbose]\n");
+ return -1;
+ }
+
+ int portnumber = atoi(argv[1]);
+
+ bool verbose = argc>=3 && !strcmp(argv[2],"-verbose");
+ verbose = verbose || (argc>=4 && !strcmp(argv[3],"-verbose"));
+
+ bool very_verbose = argc>=3 && !strcmp(argv[2],"-very-verbose");
+ very_verbose = very_verbose || (argc>=4 && !strcmp(argv[3],"-very-verbose"));
+
+ if (very_verbose)
+ verbose = true;
+
+ QCoreApplication app(argc, argv);
+
+ s7_scheme *s7 = s7_init();
+ if (s7==NULL) {
+ fprintf(stderr, "Can't start s7 scheme");
+ return -2;
+ }
+
+ s7webserver_t *s7webserver = s7webserver_create(s7, portnumber, true);
+ if (s7webserver==NULL){
+ fprintf(stderr, "Unable to start server. Port may be in use\n");
+ return -3;
+ }
+
+ s7webserver_set_verbose(s7webserver, verbose);
+ s7webserver_set_very_verbose(s7webserver, very_verbose);
+
+ printf("S7 server started on port %d. (verbose=%s) (very_verbose=%s)\n", s7webserver->portnumber, s7webserver->verbose==true?"true":"false", s7webserver->very_verbose==true?"true":"false");
+
+ app.exec();
+}
+#endif
diff --git a/s7webserver/s7webserver.h b/s7webserver/s7webserver.h
new file mode 100644
index 0000000..77b7fcf
--- /dev/null
+++ b/s7webserver/s7webserver.h
@@ -0,0 +1,103 @@
+/*
+ Written by Kjetil Matheussen: k.s.matheussen at notam02.no
+
+ Requires qhttpserver, written by Nikhil Marathe:
+ $wget https://github.com/kmatheussen/qhttpserver/archive/master.tar.gz
+
+
+ * Ways to access it:
+
+ * Using curl:
+ curl -i -X POST -H "Content-Type: text/plain" -d '(display 50)' http://localhost:5080
+
+ * Using s7webserver_repl.py:
+ ./s7webserver_repl.py
+
+ * Using a browser:
+ firefox s7webserver_repl.html
+
+
+ * The C API:
+
+ s7webserver *s7webserver_create(s7_scheme *s7, int portnum, bool find_first_free_portnum);
+ void s7webserver_set_verbose(s7webserver *s7server, bool verbose);
+ void s7webserver_set_very_verbose(s7webserver *s7webserver, bool very_verbose);
+ int s7webserver_get_portnumber(s7webserver *s7webserver);
+ void s7webserver_delete(s7webserver *s7server);
+*/
+
+
+#ifndef S7WEBSERVER_H
+#define S7WEBSERVER_H
+
+#ifdef __cplusplus
+
+#ifdef COMPILING_S7WEBSERVER
+
+#include "qhttpserverfwd.h"
+
+#include <QObject>
+#include <QScopedPointer>
+
+
+struct S7WebServer : public QObject
+{
+ Q_OBJECT
+
+public:
+ S7WebServer(s7_scheme *s7, int portnumber);
+ s7_scheme *s7;
+ int portnumber;
+ bool verbose;
+ bool very_verbose;
+ bool has_started;
+ std::string input_code_so_far;
+
+private slots:
+ void handleRequest(QHttpRequest *req, QHttpResponse *resp);
+};
+
+
+class S7WebServerResponder : public QObject
+{
+ Q_OBJECT
+
+public:
+ S7WebServerResponder(S7WebServer *s7server, QHttpRequest *req, QHttpResponse *resp);
+
+ S7WebServer *s7webserver;
+
+private:
+ QScopedPointer<QHttpRequest> request;
+
+public:
+ QHttpResponse *response;
+
+signals:
+ void done();
+
+private slots:
+ void accumulate(const QByteArray &data);
+ void reply();
+};
+
+#endif // COMPILING_S7WEBSERVER
+
+extern "C" {
+
+#endif // __cplusplus
+
+typedef struct S7WebServer s7webserver_t;
+
+s7webserver_t *s7webserver_create(s7_scheme *s7, int portnumber, bool find_first_free_portnum);
+void s7webserver_call_very_often(void); // Should be called approx. 20 times per second in non-qt programs.
+void s7webserver_set_verbose(s7webserver_t *s7server, bool verbose); // default is false
+void s7webserver_set_very_verbose(s7webserver_t *s7webserver, bool very_verbose); // default is false
+int s7webserver_get_portnumber(s7webserver_t *s7webserver);
+void s7webserver_delete(s7webserver_t *s7server);
+
+#ifdef __cplusplus
+}
+#endif // __cplusplus
+
+#endif // S7WEBSERVER_H
diff --git a/s7webserver/s7webserver_repl.html b/s7webserver/s7webserver_repl.html
new file mode 100644
index 0000000..e58fc68
--- /dev/null
+++ b/s7webserver/s7webserver_repl.html
@@ -0,0 +1,122 @@
+<!DOCTYPE html>
+
+<!-- This file is based on the "echo.html" example in jq-console: http://replit.github.io/jq-console/ -->
+
+<html>
+ <head>
+ <style>
+ html, body {
+ background-color: #333;
+ color: white;
+ font-family: monospace;
+ margin: 0;
+ padding: 0;
+ }
+ /* The console container element */
+ #console {
+ height: 400px;
+ width: 750px;
+ position:relative;
+ background-color: black;
+ border: 2px solid #CCC;
+ margin: 0 auto;
+ margin-top: 50px;
+ }
+ /* The inner console element. */
+ .jqconsole {
+ padding: 10px;
+ }
+ /* The cursor. */
+ .jqconsole-cursor {
+ background-color: gray;
+ }
+ /* The cursor color when the console looses focus. */
+ .jqconsole-blurred .jqconsole-cursor {
+ background-color: #666;
+ }
+ /* The current prompt text color */
+ .jqconsole-prompt {
+ color: #0d0;
+ }
+ /* The command history */
+ .jqconsole-old-prompt {
+ color: #0b0;
+ font-weight: normal;
+ }
+ /* The text color when in input mode. */
+ .jqconsole-input {
+ color: #dd0;
+ }
+ /* Previously entered input. */
+ .jqconsole-old-input {
+ color: #bb0;
+ font-weight: normal;
+ }
+ /* The text color of the output. */
+ .jqconsole-output {
+ color: white;
+ }
+ </style>
+ </head>
+ <body>
+
+ <div id="console"></div>
+ <script src="http://ajax.googleapis.com/ajax/libs/jquery/2.1.0/jquery.min.js" type="text/javascript" charset="utf-8"></script>
+ <script src="jqconsole.min.js" type="text/javascript" charset="utf-8"></script>
+ <script>
+
+ $(function () {
+ function formatErrorMessage(jqXHR, exception) { // function copied from http://stackoverflow.com/questions/377644/jquery-ajax-error-handling-show-custom-exception-messages
+ if (jqXHR.status === 0) {
+ return ('Not connected.\nPlease verify your network connection.');
+ } else if (jqXHR.status == 404) {
+ return ('The requested page not found. [404]');
+ } else if (jqXHR.status == 500) {
+ return ('Internal Server Error [500].');
+ } else if (exception === 'parsererror') {
+ return ('Requested JSON parse failed.');
+ } else if (exception === 'timeout') {
+ return ('Time out error.');
+ } else if (exception === 'abort') {
+ return ('Ajax request aborted.');
+ } else {
+ return ('Uncaught Error.\n' + jqXHR.responseText);
+ }
+ }
+
+ var jqconsole = $('#console').jqconsole('S7 scheme\n', '>>> ');
+ var startPrompt = function () {
+ // Start the prompt with history enabled.
+ jqconsole.Prompt(true, function (input) {
+ // Output input with the class jqconsole-output.
+ $.ajax({
+ type: "POST",
+ contentType: "text/plain",
+ data: input,
+ dataType: "text",
+ url: url.value,
+ success: function (data, status, xhr) {
+ jqconsole.Write(data+"\n");
+ },
+ error: function (xhr, status, thrown) {
+ jqconsole.Write(formatErrorMessage(xhr, status)+"\n")
+ }
+ });
+
+ startPrompt();
+ });
+ };
+ startPrompt();
+ });
+ </script>
+
+ <center>
+ URL: <input type="text" id="TEXTBOX_ID" value="http://localhost:6080">
+ <script type="text/javascript">
+ var url = document.getElementById('TEXTBOX_ID');
+ </script>
+ <br>
+ </center>
+
+</body>
+</html>
diff --git a/s7webserver/s7webserver_repl.py b/s7webserver/s7webserver_repl.py
new file mode 100755
index 0000000..f55849b
--- /dev/null
+++ b/s7webserver/s7webserver_repl.py
@@ -0,0 +1,67 @@
+#! /usr/bin/env python
+
+# Written by Kjetil Matheussen: k.s.matheussen at notam02.no
+
+
+import sys
+import urllib2
+import readline
+
+headers = {"Content-type": "text/plain", "Accept": "text/plain"}
+
+def post(url, data):
+ request = urllib2.Request(url, data, headers)
+ try:
+ response = urllib2.urlopen(request)
+ except urllib2.URLError:
+ print "<Unable to contact Radium>"
+ return
+
+ all_data = ""
+
+ data = response.read(1)
+ while data:
+ all_data = all_data + data
+ sys.stdout.write( '%s' % data )
+ sys.stdout.flush()
+ data = response.read(1)
+ response.close()
+
+ return all_data
+
+
+def get_input(prompt):
+ try:
+ return raw_input(prompt)
+ except EOFError:
+ sys.exit(0)
+
+
+def start(prompt, url):
+ line = get_input(prompt+" ")
+ while True:
+ result = post(url, line)
+ if result=="":
+ line = get_input("")
+ else:
+ print
+ line = get_input(prompt+" ")
+
+
+if __name__ == "__main__":
+
+ prompt = "s7> "
+ url = "http://localhost:6080"
+
+ if len(sys.argv)>1:
+ if (sys.argv[1].startswith("-")):
+ print "Usage: s7repl <prompt> <url>"
+ print " Default value for <prompt> is \"s7> \""
+ print " Default value for <url> is http://localhost:6080"
+ sys.exit(0)
+ prompt = sys.argv[1]
+
+ if len(sys.argv)>2:
+ url = sys.argv[2]
+
+ start(prompt, url)
diff --git a/selection.scm b/selection.scm
index 47b1667..72948c5 100644
--- a/selection.scm
+++ b/selection.scm
@@ -78,12 +78,12 @@
(lambda ()
(let ((sndlist ()))
(if (selection?)
- (map (lambda (snd)
- (do ((i (- (channels snd) 1) (- i 1)))
- ((< i 0))
- (if (selection-member? snd i)
- (set! sndlist (cons (list snd i) sndlist)))))
- (sounds)))
+ (for-each (lambda (snd)
+ (do ((i (- (channels snd) 1) (- i 1)))
+ ((< i 0))
+ (if (selection-member? snd i)
+ (set! sndlist (cons (list snd i) sndlist)))))
+ (sounds)))
sndlist))))
@@ -139,12 +139,12 @@ restores the previous selection (if any). It returns whatever 'thunk' returned.
(set! seldata (append seldata (list (selection-position) (selection-framples)))))
(make-selection beg (- (+ beg dur) 1) snd chn)
(let ((result (thunk)))
- (if seldata
+ (if (not seldata)
+ (unselect-all)
(make-selection (caddr seldata)
(- (+ (caddr seldata) (cadddr seldata)) 1)
(car seldata)
- (cadr seldata))
- (unselect-all))
+ (cadr seldata)))
result)))))
diff --git a/singer.scm b/singer.scm
index ba6b6fa..85fc84e 100644
--- a/singer.scm
+++ b/singer.scm
@@ -32,15 +32,13 @@
(durs (map car data))
(dur (apply + durs))
(begs (let ((bg beg))
- (append (list beg)
- (map (lambda (x)
- (set! bg (+ bg x)))
- durs))))
+ (cons beg
+ (map (lambda (x)
+ (set! bg (+ bg x)))
+ durs))))
(beg-samps (map seconds->samples begs)))
- (let ((change-times (let* ((len (length beg-samps))
- (nbegs (append beg-samps (list (beg-samps (- len 1))))))
- (apply vector nbegs)))
+ (let ((change-times (apply vector (append beg-samps (list (beg-samps (- (length beg-samps) 1))))))
(shps (map cadr data))
(glts (map caddr data))
@@ -256,8 +254,8 @@
(set! temp (/ one-over-two-pi b-a))
(set! temp1 (- 1.0 ca2))
(set! (sines 1) (* (+ ca2 (* (- sa2 (sin b2)) temp)) temp1 one-over-two-pi))
- (set! (cosines 1) (* (+ (- sa2) (* (- ca2 (cos b2)) temp)) temp1 one-over-two-pi))))
- (set! (sines 1) (+ (sines 1) (* (+ 0.75 (- ca2) (* (cos (* 2 a2)) 0.25)) one-over-two-pi)))
+ (set! (cosines 1) (* (- (* (- ca2 (cos b2)) temp) sa2) temp1 one-over-two-pi))))
+ (set! (sines 1) (+ (sines 1) (* (- (+ 0.75 (* (cos (* 2 a2)) 0.25)) ca2) one-over-two-pi)))
(set! (cosines 1) (+ (cosines 1) (- (* (- sa2 (* (sin (* 2 a2)) 0.25)) one-over-two-pi) (* a 0.5))))
(do ((k 2 (+ k 1))
(ka2 (* 2 a2) (+ ka2 a2))
@@ -268,7 +266,7 @@
(begin
(set! temp (/ one-over-two-pi (* b-a k)))
(set! (sines k) (* (+ (cos ka2) (* (- (sin ka2) (sin (* k b2))) temp)) (/ temp1 k)))
- (set! (cosines k) (* (+ (- (sin ka2)) (* (- (cos ka2) (cos (* k b2))) temp)) (/ temp1 k)))))
+ (set! (cosines k) (* (- (* (- (cos ka2) (cos (* k b2))) temp) (sin ka2)) (/ temp1 k)))))
(set! (sines k) (+ (sines k)
(/ (- 1.0 (cos ka2)) k)
(/ (* (- (cos ka1) 1.0) 0.5) (- k 1))
@@ -307,10 +305,7 @@
(if (> (abs (- (shape-data j) (shape-data k))) .001)
(set! new-tract #t)))
(set! last-sfd new-sfd)))
- (if (= last-gfd -1)
- (set! last-gfd 0)
- (let ((new-gfd (+ last-gfd 2)))
- (set! last-gfd new-gfd)))
+ (set! last-gfd (if (= last-gfd -1) 0 (+ last-gfd 2)))
(set! next-offset (floor (change-times (+ offset 1))))
(set! delta (/ 1.0 (- next-offset i)))))
@@ -328,70 +323,66 @@
(if (> (abs (- (target-radii j) (radii j))) 0.001)
(set! change-radii #t)))))
- (if (or first-tract change-radii)
- (begin
- (if (not new-tract)
- (begin
- (float-vector-multiply! radii radii-poles)
- (copy target-radii target-temp)
- (float-vector-multiply! target-temp radii-pole-gains)
- (float-vector-add! radii target-temp)
- ;; (do ((j 0 (+ j 1))) ((= j tractlength+8))
- ;; (float-vector-set! radii j (+ (* (float-vector-ref radii j) (float-vector-ref radii-poles j))
- ;; (* (float-vector-ref target-radii j) (float-vector-ref radii-pole-gains j)))))
- ))
- ;; set tract shape
- (let ((tj 1.0)
- (tk 0.0))
- (do ((k 0 (+ k 1))
- (j 1 (+ j 1)))
- ((= j tractlength))
- (set! tk tj)
- (if (zero? (float-vector-ref radii j))
- (set! tj 1e-10)
- (set! tj (* (float-vector-ref radii k) (float-vector-ref radii k))))
- (float-vector-set! coeffs j (/ (- tk tj) (+ tk tj)))))
-
- (set! glot-refl-gain (radii tractlength-1))
- (set! lip-refl-gain (radii tractlength))
- (set! noise-pos (floor (radii tractlength+1)))
- (set! noise-gain (radii (+ tractlength 2)))
-
- (let ((temp1 (radii (+ tractlength 3)))
- (r (radii (+ tractlength 4)))
- (t2 (radii (+ tractlength 5)))
- (r2 (radii (+ tractlength 6))))
- (let (;; fricative noise generator (set noise angle and radius)
- (noise-angle (hz->radians temp1))
- (noise-angle2 (hz->radians t2))
- (noise-radius r)
- (noise-radius2 r2))
- (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) noise-radius))
- (noise-b (* noise-radius noise-radius))
- (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) noise-radius2))
- (noise-b2 (* noise-radius2 noise-radius2)))
- (set! (noisev 0) (+ noise-a noise-a2))
- (set! (noisev 1) (+ noise-b noise-b2 (* noise-a noise-a2)))
- (set! (noisev 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))
- (set! (noisev 3) (* noise-b2 noise-b)))))
-
- (set! lip-radius (radii tractlength-2))
- (set! velum-pos (radii (+ tractlength 7)))
- (let ((leftradius (radii (- noseposition 2)))
- (velumradius velum-pos)
- (rightradius (radii (- noseposition 1))))
- (let ((temp1 0.0)
- (temp 0.0))
- ;; nasal tract (set nasal shape)
- (set! temp (- rightradius velumradius))
- (if (< temp 0.0) (set! temp 0.0))
- (set! alpha1 (* leftradius leftradius))
- (set! alpha2 (* temp temp))
- (set! alpha3 (* velumradius velumradius))
- (set! temp1 (/ 2.0 (+ alpha1 alpha2 alpha3)))
- (set! alpha1 (* alpha1 temp1))
- (set! alpha2 (* alpha2 temp1))
- (set! alpha3 (* alpha3 temp1))))))
+ (when (or first-tract change-radii)
+ (if (not new-tract)
+ (begin
+ (float-vector-multiply! radii radii-poles)
+ (copy target-radii target-temp)
+ (float-vector-multiply! target-temp radii-pole-gains)
+ (float-vector-add! radii target-temp)
+ ;; (do ((j 0 (+ j 1))) ((= j tractlength+8))
+ ;; (float-vector-set! radii j (+ (* (float-vector-ref radii j) (float-vector-ref radii-poles j))
+ ;; (* (float-vector-ref target-radii j) (float-vector-ref radii-pole-gains j)))))
+ ))
+ ;; set tract shape
+ (do ((tj 1.0)
+ (tk 0.0)
+ (k 0 (+ k 1))
+ (j 1 (+ j 1)))
+ ((= j tractlength))
+ (set! tk tj)
+ (set! tj (if (zero? (float-vector-ref radii j))
+ 1e-10
+ (* (float-vector-ref radii k) (float-vector-ref radii k))))
+ (float-vector-set! coeffs j (/ (- tk tj) (+ tk tj))))
+
+ (set! glot-refl-gain (radii tractlength-1))
+ (set! lip-refl-gain (radii tractlength))
+ (set! noise-pos (floor (radii tractlength+1)))
+ (set! noise-gain (radii (+ tractlength 2)))
+
+ (let ((temp1 (radii (+ tractlength 3)))
+ (r (radii (+ tractlength 4)))
+ (t2 (radii (+ tractlength 5)))
+ (r2 (radii (+ tractlength 6))))
+ (let (;; fricative noise generator (set noise angle and radius)
+ (noise-angle (hz->radians temp1))
+ (noise-angle2 (hz->radians t2))
+ (noise-radius r)
+ (noise-radius2 r2))
+ (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) noise-radius))
+ (noise-b (* noise-radius noise-radius))
+ (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) noise-radius2))
+ (noise-b2 (* noise-radius2 noise-radius2)))
+ (set! (noisev 0) (+ noise-a noise-a2))
+ (set! (noisev 1) (+ noise-b noise-b2 (* noise-a noise-a2)))
+ (set! (noisev 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))
+ (set! (noisev 3) (* noise-b2 noise-b)))))
+
+ (set! lip-radius (radii tractlength-2))
+ (set! velum-pos (radii (+ tractlength 7)))
+ (let ((leftradius (radii (- noseposition 2)))
+ (velumradius velum-pos)
+ (rightradius (radii (- noseposition 1))))
+ (let ((temp (max (- rightradius velumradius) 0.0)))
+ ;; nasal tract (set nasal shape)
+ (set! alpha1 (* leftradius leftradius))
+ (set! alpha2 (* temp temp)))
+ (set! alpha3 (* velumradius velumradius)))
+ (let ((temp1 (/ 2.0 (+ alpha1 alpha2 alpha3))))
+ (set! alpha1 (* alpha1 temp1))
+ (set! alpha2 (* alpha2 temp1))
+ (set! alpha3 (* alpha3 temp1))))
(if new-tract
(begin
@@ -414,9 +405,9 @@
(set! table-location (+ table-location table-increment))
(if (>= table-location table-size)
(set! table-location (- table-location table-size)))
- (let ((int-loc (floor table-location)))
- (let ((table1 (glot-table int-loc)))
- (set! glotsamp (+ glotsamp (* (env glot-env) (+ table1 (* s-glot-mix (- (glot-table2 int-loc) table1))))))))))
+ (let* ((int-loc (floor table-location))
+ (table1 (glot-table int-loc)))
+ (set! glotsamp (+ glotsamp (* (env glot-env) (+ table1 (* s-glot-mix (- (glot-table2 int-loc) table1)))))))))
;; next tract tick
(let ((j 0)
@@ -450,9 +441,10 @@
(set! nose-last-minus-refl (- nose-reftemp plussamp))
(set! nose-last-plus-refl (- nose-reftemp minussamp)))
(begin
- (if (not (= velum-pos 0.0))
- (set! time-nose-closed 0)
- (set! time-nose-closed (+ time-nose-closed 1))) ; added 1 bil 17-Apr-11 but didn't test it
+ (set! time-nose-closed
+ (if (= velum-pos 0.0)
+ (+ time-nose-closed 1) ; added 1 bil 17-Apr-11 but didn't test it
+ 0))
;; nasal tick
(let ((nose-reftemp (+ (* alpha1 plussamp) (* alpha2 minussamp) (* alpha3 (nose2 1)))))
(let (;(nose-t1 0.0)
@@ -462,9 +454,8 @@
(set! nose-last-plus-refl (- nose-reftemp minussamp))
(set! nose-reftemp (* (nose-coeffs 1) (- plus-in (nose2 2))))
(set! (nose2 1) (+ (nose2 2) nose-reftemp))
- (set! nose-temp (+ plus-in nose-reftemp))
- (set! nose-temp (singer-nose-filter noselength-1 nose-temp nose1 nose2 nose-coeffs))
+ (set! nose-temp (singer-nose-filter noselength-1 (+ plus-in nose-reftemp) nose1 nose2 nose-coeffs))
#|
(do ((j 2 (+ j 1))
(k 1 (+ k 1)))
@@ -484,12 +475,10 @@
(set! nose-filt (nose1 noselength-1))
(set! nose-last-output (* (+ nose-filt nose-filt1) 0.5))))))
(set! (dline2 j) nose-last-minus-refl))
-
(set! (dline1 (- j 1)) temp)
- (set! temp nose-last-plus-refl)
;; j always starts at 4, goes to 8 so this loop can be unrolled, but doing so doesn't make a big difference
- (set! temp (singer-filter noseposition tractlength-1 temp dline1 dline2 coeffs))
+ (set! temp (singer-filter noseposition tractlength-1 nose-last-plus-refl dline1 dline2 coeffs))
#|
(let ((x 0.0))
(do ((j (+ noseposition 1) (+ j 1))
diff --git a/snd-0.h b/snd-0.h
index df3b022..78bde27 100644
--- a/snd-0.h
+++ b/snd-0.h
@@ -1807,6 +1807,18 @@ typedef enum {NO_REQUESTOR, FROM_UPDATE, FROM_VIEW_FILES, FROM_DRAG_AND_DROP, FR
#endif
#define DEFAULT_LISTENER_PROMPT ">"
+#define stdin_prompt(ss) ss->Stdin_Prompt
+#if HAVE_SCHEME
+ #define set_stdin_prompt(a) \
+ do {\
+ ss->Stdin_Prompt = a; \
+ s7_symbol_set_value(s7, ss->stdin_prompt_symbol, s7_make_string(s7, ss->Stdin_Prompt));\
+ } while (0)
+#else
+ #define set_stdin_prompt(a) ss->Stdin_Prompt = a
+#endif
+#define DEFAULT_STDIN_PROMPT ""
+
#define print_length(ss) ss->Print_Length
#if HAVE_SCHEME
#define set_print_length(a) \
diff --git a/snd-1.h b/snd-1.h
index 11fc4da..d4a1e99 100644
--- a/snd-1.h
+++ b/snd-1.h
@@ -484,7 +484,7 @@ typedef struct snd_state {
bool With_GL, With_Relative_Panes;
int Print_Length, Dac_Size, View_Files_Sort;
bool Dac_Combines_Channels, Show_Selection_Transform, With_Mix_Tags, Selection_Creates_Region;
- char *Save_State_File, *Listener_Prompt;
+ char *Save_State_File, *Listener_Prompt, *Stdin_Prompt;
mus_float_t Enved_Base, Enved_Power, Auto_Update_Interval;
bool Enved_With_Wave, Graphs_Horizontal, With_Background_Processes, With_File_Monitor;
env_type_t Enved_Style;
@@ -546,7 +546,7 @@ typedef struct snd_state {
with_gl_symbol, with_relative_panes_symbol,
print_length_symbol, dac_size_symbol, view_files_sort_symbol,
dac_combines_channels_symbol, show_selection_transform_symbol, with_mix_tags_symbol, selection_creates_region_symbol,
- save_state_file_symbol, listener_prompt_symbol,
+ save_state_file_symbol, listener_prompt_symbol, stdin_prompt_symbol,
enved_base_symbol, enved_power_symbol, auto_update_interval_symbol,
enved_with_wave_symbol, graphs_horizontal_symbol, with_background_processes_symbol, with_file_monitor_symbol,
enved_style_symbol,
diff --git a/snd-chn.c b/snd-chn.c
index ba5ac22..ac4a0e6 100644
--- a/snd-chn.c
+++ b/snd-chn.c
@@ -2549,10 +2549,12 @@ static void make_fft_graph(chan_info *cp, axis_info *fap, graphics_context *ax,
color_t old_color;
old_color = get_foreground_color(ax);
set_foreground_color(ax, cp->combined_data_color);
- draw_grf_points(cp->dot_size, ax, lines_to_draw, fap, 0.0, cp->transform_graph_style);
+ /* draw_grf_points(cp->dot_size, ax, lines_to_draw, fap, 0.0, cp->transform_graph_style); */
+ /* ^ this messes up dB graph if line-style is lollipops or filled -- see also below */
+ draw_grf_points(cp->dot_size, ax, lines_to_draw, fap, fap->y0, cp->transform_graph_style);
set_foreground_color(ax, old_color);
}
- else draw_grf_points(cp->dot_size, ax, lines_to_draw, fap, 0.0, cp->transform_graph_style);
+ else draw_grf_points(cp->dot_size, ax, lines_to_draw, fap, fap->y0, cp->transform_graph_style);
}
if (cp->printing)
diff --git a/snd-dac.c b/snd-dac.c
index 2d188be..6372809 100644
--- a/snd-dac.c
+++ b/snd-dac.c
@@ -29,7 +29,7 @@ typedef struct dac_info {
bool expanding, reverbing, filtering; /* these need lots of preparation, so they're noticed only at the start */
int audio_chan; /* where channel's output is going (wrap-around if not enough audio output channels) */
int slot;
- mus_float_t *a; /* filter coeffs */
+ mus_float_t *a; /* filter coeffs */
int a_size; /* user can change filter order while playing (sigh...) */
snd_fd *chn_fd; /* sampler, null if DAC_Xen */
spd_info *spd;
@@ -428,8 +428,8 @@ static void free_dac_info(dac_info *dp, play_stop_t reason)
if (dp->stop_procedure_gc_loc != NOT_A_GC_LOC)
{
Xen_call_with_1_arg(dp->stop_procedure,
- C_int_to_Xen_integer((int)reason),
- "play stop procedure");
+ C_int_to_Xen_integer((int)reason),
+ "play stop procedure");
snd_unprotect_at(dp->stop_procedure_gc_loc);
dp->stop_procedure = Xen_false;
dp->stop_procedure_gc_loc = NOT_A_GC_LOC;
@@ -1499,7 +1499,7 @@ static dac_info *play_selection_1(play_process_t background, Xen stop_proc)
ends[i] = si->begs[i] + selection_len();
dp = play_channels_1(si->cps, si->chans, si->begs, ends, background, C_int_to_Xen_integer(AT_CURRENT_EDIT_POSITION), true, stop_proc, NULL, 0);
-
+ /* dp->dac_sample is the reader */
si = free_sync_info(si); /* does not free samplers */
free(ends);
}
@@ -1572,13 +1572,7 @@ static int fill_dac_buffers(int write_ok)
int i;
bool cursor_change = false;
int framples;
- mus_float_t *revin;
- dac_info *dp;
snd_info *sp;
- mus_float_t *buf;
-#if (HAVE_OSS || HAVE_ALSA)
- mus_float_t **dev_bufs;
-#endif
framples = snd_dacp->framples;
/* clear buffers */
@@ -1592,6 +1586,10 @@ static int fill_dac_buffers(int write_ok)
cursor_change = false;
else
{
+ dac_info *dp;
+ mus_float_t *buf;
+ mus_float_t *revin;
+
if (Xen_hook_has_list(play_hook))
run_hook(play_hook,
Xen_list_1(C_int_to_Xen_integer(framples)),
@@ -1887,6 +1885,7 @@ static int fill_dac_buffers(int write_ok)
#if (HAVE_OSS || HAVE_ALSA)
if (write_ok == WRITE_TO_DAC)
{
+ mus_float_t **dev_bufs;
dev_bufs = dac_buffers;
for (i = 0; i < snd_dacp->devices; i++)
if (dev_fd[i] != -1)
diff --git a/snd-edits.c b/snd-edits.c
index 31d75f0..a860708 100644
--- a/snd-edits.c
+++ b/snd-edits.c
@@ -7321,7 +7321,7 @@ static Xen g_save_edit_history(Xen filename, Xen snd, Xen chn)
if (!mcf) return(Xen_false);
fd = FOPEN(mcf, "w");
- if (mcf) free(mcf);
+ free(mcf);
if (fd)
{
diff --git a/snd-file.c b/snd-file.c
index 6cca733..52a7ab6 100644
--- a/snd-file.c
+++ b/snd-file.c
@@ -509,10 +509,6 @@ void init_sound_file_extensions(void)
add_sound_file_extension("mp3");
#endif
-#if HAVE_TTA
- add_sound_file_extension("tta");
-#endif
-
#if HAVE_WAVPACK
add_sound_file_extension("wv");
#endif
@@ -1977,12 +1973,12 @@ bool run_before_save_as_hook(snd_info *sp, const char *save_as_filename, bool se
/* -------- file dialog header/data choices -------- */
enum {H_NEXT, H_AIFC, H_RIFF, H_RF64, H_RAW, H_AIFF, H_IRCAM, H_NIST, H_CAFF, /* the "built-in" choices for output */
- H_OGG, H_FLAC, H_SPEEX, H_TTA, H_WAVPACK, /* readable/writable via external programs */
+ H_OGG, H_FLAC, H_SPEEX, H_WAVPACK, /* readable/writable via external programs */
H_MPEG, H_MIDI, /* readable via external programs */
H_SIZE};
static int h_num_sample_types[H_SIZE] = {12 /* next */, 13 /* aifc */, 8 /* riff */, 8 /* rf64 */, 18 /* raw */, 4 /* aiff */, 5 /* ircam */, 7 /* nist */, 13 /* caff */,
- 1 /* ogg */, 1 /* flac */, 1 /* speex */, 1 /* tta */, 1 /*wavpack */,
+ 1 /* ogg */, 1 /* flac */, 1 /* speex */, 1 /*wavpack */,
1 /* mpeg */, 1 /* midi */};
#define H_DFS_MAX 18
@@ -2003,18 +1999,17 @@ static mus_sample_t h_dfs[H_SIZE][H_DFS_MAX] = { /* next */ {MUS_BFLOAT, MUS_BS
/* ogg */ {MUS_LSHORT},
/* flac */ {MUS_LSHORT},
/* speex */ {MUS_LSHORT},
- /* tta */ {MUS_LSHORT},
/* wavpack */ {MUS_LSHORT},
/* readonly */ {MUS_UNKNOWN_SAMPLE}, {MUS_UNKNOWN_SAMPLE}
};
static const char *h_df_names[H_SIZE][H_DFS_MAX];
static const char *h_names[H_SIZE] = {"au/next ", "aifc ", "wave ", "rf64 ", "raw ", "aiff ", "ircam ", "nist ", "caff ",
- "ogg ", "flac ", "speex ", "tta ", "wavpack",
+ "ogg ", "flac ", "speex ", "wavpack",
"mpeg ", "midi "};
static mus_header_t h_pos_to_type[H_SIZE] = {MUS_NEXT, MUS_AIFC, MUS_RIFF, MUS_RF64, MUS_RAW, MUS_AIFF, MUS_IRCAM, MUS_NIST, MUS_CAFF,
MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER,
- MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER};
+ MUS_UNKNOWN_HEADER, MUS_UNKNOWN_HEADER};
static int h_type_to_pos[MUS_NUM_HEADERS];
static int h_type_to_h[MUS_NUM_HEADERS];
@@ -2086,7 +2081,6 @@ void initialize_sample_type_lists(void)
h_type_to_h[MUS_SPEEX] = H_SPEEX;
h_type_to_h[MUS_MIDI] = H_MIDI;
h_type_to_h[MUS_MPEG] = H_MPEG;
- h_type_to_h[MUS_TTA] = H_TTA;
h_type_to_h[MUS_WAVPACK] = H_WAVPACK;
i = 9;
@@ -2106,11 +2100,6 @@ void initialize_sample_type_lists(void)
h_pos_to_type[i++] = MUS_SPEEX;
#endif
-#if HAVE_TTA
- h_type_to_pos[MUS_TTA] = i;
- h_pos_to_type[i++] = MUS_TTA;
-#endif
-
#if HAVE_WAVPACK
h_type_to_pos[MUS_WAVPACK] = i;
h_pos_to_type[i++] = MUS_WAVPACK;
@@ -2172,11 +2161,6 @@ const char **short_writable_headers(int *len)
writable_headers[i++] = h_names[H_SPEEX];
#endif
-#if HAVE_TTA
- /* ttaenc -e in out */
- writable_headers[i++] = h_names[H_TTA];
-#endif
-
#if HAVE_WAVPACK
/* wavpack in -o out */
writable_headers[i++] = h_names[H_WAVPACK];
@@ -2239,10 +2223,6 @@ const char **short_readable_headers(int *len)
readable_headers[i++] = h_names[H_MIDI];
#endif
-#if HAVE_TTA
- readable_headers[i++] = h_names[H_TTA];
-#endif
-
#if HAVE_WAVPACK
readable_headers[i++] = h_names[H_WAVPACK];
#endif
@@ -2305,7 +2285,6 @@ bool header_is_encoded(mus_header_t header_type)
(header_type == MUS_SPEEX) ||
(header_type == MUS_MPEG) ||
(header_type == MUS_MIDI) ||
- (header_type == MUS_TTA) ||
(header_type == MUS_WAVPACK)
);
}
@@ -2376,12 +2355,6 @@ void snd_encode(mus_header_t type, const char *input_filename, const char *outpu
break;
#endif
-#if HAVE_TTA
- case MUS_TTA:
- command = mus_format("%s -e %s -o %s", PATH_TTA, ifile, ofile);
- break;
-#endif
-
#if HAVE_WAVPACK
case MUS_WAVPACK:
command = mus_format("%s %s -o %s", PATH_WAVPACK, ifile, ofile);
@@ -2455,12 +2428,6 @@ int snd_decode(mus_header_t type, const char *input_filename, const char *output
break;
#endif
-#if HAVE_TTA
- case MUS_TTA:
- command = mus_format("%s -d %s -o %s", PATH_TTA, ifile, ofile);
- break;
-#endif
-
#if HAVE_WAVPACK
case MUS_WAVPACK:
command = mus_format("%s %s -o %s", PATH_WVUNPACK, ifile, ofile);
diff --git a/snd-gl.scm b/snd-gl.scm
index 61bd29b..5cc957d 100644
--- a/snd-gl.scm
+++ b/snd-gl.scm
@@ -21,7 +21,8 @@
(let* ((cx (snd-gl-context))
(dpy ((*motif* 'XtDisplay) (cadr (main-widgets))))
(version (glXQueryVersion dpy 0 0)))
- (if (car version)
+ (if (not (car version))
+ (snd-print "no GL found!")
(let ((visuals ((*motif* 'XGetVisualInfo) dpy 0 (list 'XVisualInfo 0))))
(glXMakeCurrent dpy ((*motif* 'XtWindow) (cadr (main-widgets))) cx)
(snd-print (format #f "GL version: ~A.~A, (~A ~A ~A)~%"
@@ -32,40 +33,38 @@
(if (glXIsDirect dpy cx) ", direct rendering support" "")))
(for-each
(lambda (visual)
- (if (= (cadr (glXGetConfig dpy visual GLX_USE_GL)) 1)
- ;; found a visual that can support GL
- (let ((buffersize (cadr (glXGetConfig dpy visual GLX_BUFFER_SIZE)))
- (level (cadr (glXGetConfig dpy visual GLX_LEVEL)))
- (rgba (cadr (glXGetConfig dpy visual GLX_RGBA)))
- (doublebuffer (cadr (glXGetConfig dpy visual GLX_DOUBLEBUFFER)))
- (stereo (cadr (glXGetConfig dpy visual GLX_STEREO)))
- (auxbuffers (cadr (glXGetConfig dpy visual GLX_AUX_BUFFERS)))
- (redsize (cadr (glXGetConfig dpy visual GLX_RED_SIZE)))
- (bluesize (cadr (glXGetConfig dpy visual GLX_BLUE_SIZE)))
- (greensize (cadr (glXGetConfig dpy visual GLX_GREEN_SIZE)))
- (alphasize (cadr (glXGetConfig dpy visual GLX_ALPHA_SIZE)))
- (depthsize (cadr (glXGetConfig dpy visual GLX_DEPTH_SIZE)))
- (stencilsize (cadr (glXGetConfig dpy visual GLX_STENCIL_SIZE)))
- (acredsize (cadr (glXGetConfig dpy visual GLX_ACCUM_RED_SIZE)))
- (acgreensize (cadr (glXGetConfig dpy visual GLX_ACCUM_GREEN_SIZE)))
- (acbluesize (cadr (glXGetConfig dpy visual GLX_ACCUM_BLUE_SIZE)))
- (acalphasize (cadr (glXGetConfig dpy visual GLX_ACCUM_ALPHA_SIZE))))
- (snd-print (format #f " id: #x~X depth: ~D class: ~S~%" ((*motif* '.visualid) visual) ((*motif* '.depth) visual) (class-of ((*motif* '.class) visual))))
- (snd-print (format #f " buffersize: ~D, level: ~D, rgba: ~A, doublebuffer: ~A, stereo: ~A~%"
- buffersize level
- (if (= rgba 1) "#t" "#f")
- (if (= doublebuffer 1) "#t" "#f")
- (if (= stereo 1) "#t" "#f")))
- (snd-print (format #f " r: ~A, g: ~D, b: ~D, alpha: ~D, accum-r: ~D, accum-g: ~D, accum-b: ~D, accum-alpha: ~D~%"
- redsize greensize bluesize alphasize
- acredsize acgreensize acbluesize acalphasize))
- (snd-print (format #f " auxbuffs: ~D, depth: ~D, acalpha: ~D~%"
- auxbuffers depthsize stencilsize))
-
-
- )))
- visuals))
- (snd-print "no GL found!"))))))
+ (when (= (cadr (glXGetConfig dpy visual GLX_USE_GL)) 1)
+ ;; found a visual that can support GL
+ (let ((buffersize (cadr (glXGetConfig dpy visual GLX_BUFFER_SIZE)))
+ (level (cadr (glXGetConfig dpy visual GLX_LEVEL)))
+ (rgba (cadr (glXGetConfig dpy visual GLX_RGBA)))
+ (doublebuffer (cadr (glXGetConfig dpy visual GLX_DOUBLEBUFFER)))
+ (stereo (cadr (glXGetConfig dpy visual GLX_STEREO)))
+ (auxbuffers (cadr (glXGetConfig dpy visual GLX_AUX_BUFFERS)))
+ (redsize (cadr (glXGetConfig dpy visual GLX_RED_SIZE)))
+ (bluesize (cadr (glXGetConfig dpy visual GLX_BLUE_SIZE)))
+ (greensize (cadr (glXGetConfig dpy visual GLX_GREEN_SIZE)))
+ (alphasize (cadr (glXGetConfig dpy visual GLX_ALPHA_SIZE)))
+ (depthsize (cadr (glXGetConfig dpy visual GLX_DEPTH_SIZE)))
+ (stencilsize (cadr (glXGetConfig dpy visual GLX_STENCIL_SIZE)))
+ (acredsize (cadr (glXGetConfig dpy visual GLX_ACCUM_RED_SIZE)))
+ (acgreensize (cadr (glXGetConfig dpy visual GLX_ACCUM_GREEN_SIZE)))
+ (acbluesize (cadr (glXGetConfig dpy visual GLX_ACCUM_BLUE_SIZE)))
+ (acalphasize (cadr (glXGetConfig dpy visual GLX_ACCUM_ALPHA_SIZE))))
+ (for-each snd-print (vector (format #f " id: #x~X depth: ~D class: ~S~%"
+ ((*motif* '.visualid) visual) ((*motif* '.depth) visual) (class-of ((*motif* '.class) visual)))
+ (format #f " buffersize: ~D, level: ~D, rgba: ~A, doublebuffer: ~A, stereo: ~A~%"
+ buffersize level
+ (if (= rgba 1) "#t" "#f")
+ (if (= doublebuffer 1) "#t" "#f")
+ (if (= stereo 1) "#t" "#f"))
+ (format #f " r: ~A, g: ~D, b: ~D, alpha: ~D, accum-r: ~D, accum-g: ~D, accum-b: ~D, accum-alpha: ~D~%"
+ redsize greensize bluesize alphasize
+ acredsize acgreensize acbluesize acalphasize)
+ (format #f " auxbuffs: ~D, depth: ~D, acalpha: ~D~%"
+ auxbuffers depthsize stencilsize))))))
+ visuals)))))))
+
;;; -------- dump GL state
@@ -73,84 +72,84 @@
(define (gl-dump-state)
;; based on Mesa/util/dumpstate.c by Stephane Rehel
- (format #t "GL_CURRENT_COLOR: ~A~%" (glGetFloatv GL_CURRENT_COLOR))
- (format #t "GL_CURRENT_INDEX: ~A~%" (glGetIntegerv GL_CURRENT_INDEX))
- (format #t "GL_CURRENT_TEXTURE_COORDS: ~A~%" (glGetFloatv GL_CURRENT_TEXTURE_COORDS))
- (format #t "GL_CURRENT_NORMAL: ~A~%" (glGetFloatv GL_CURRENT_NORMAL))
- (format #t "GL_CURRENT_RASTER_POSITION: ~A~%" (glGetFloatv GL_CURRENT_RASTER_POSITION))
- (format #t "GL_CURRENT_RASTER_DISTANCE: ~A~%" (glGetFloatv GL_CURRENT_RASTER_DISTANCE))
- (format #t "GL_CURRENT_RASTER_COLOR: ~A~%" (glGetFloatv GL_CURRENT_RASTER_COLOR))
- (format #t "GL_CURRENT_RASTER_INDEX: ~A~%" (glGetIntegerv GL_CURRENT_RASTER_INDEX))
- (format #t "GL_CURRENT_RASTER_TEXTURE_COORDS: ~A~%" (glGetFloatv GL_CURRENT_RASTER_TEXTURE_COORDS))
- (format #t "GL_CURRENT_RASTER_POSITION_VALID: ~A~%" (glGetBooleanv GL_CURRENT_RASTER_POSITION_VALID))
- (format #t "GL_EDGE_FLAG: ~A~%" (glGetBooleanv GL_EDGE_FLAG))
- (format #t "GL_VERTEX_ARRAY: ~A~%" (glGetBooleanv GL_VERTEX_ARRAY))
- (format #t "GL_VERTEX_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_SIZE))
- (format #t "GL_VERTEX_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_TYPE))
- (format #t "GL_VERTEX_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_STRIDE))
- (format #t "GL_VERTEX_ARRAY_POINTER: ~A~%" (glGetPointerv GL_VERTEX_ARRAY_POINTER))
- (format #t "GL_NORMAL_ARRAY: ~A~%" (glGetBooleanv GL_NORMAL_ARRAY))
- (format #t "GL_NORMAL_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_NORMAL_ARRAY_TYPE))
- (format #t "GL_NORMAL_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_NORMAL_ARRAY_STRIDE))
- (format #t "GL_NORMAL_ARRAY_POINTER: ~A~%" (glGetPointerv GL_NORMAL_ARRAY_POINTER))
- (format #t "GL_COLOR_ARRAY: ~A~%" (glGetBooleanv GL_COLOR_ARRAY))
- (format #t "GL_COLOR_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_SIZE))
- (format #t "GL_COLOR_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_TYPE))
- (format #t "GL_COLOR_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_STRIDE))
- (format #t "GL_COLOR_ARRAY_POINTER: ~A~%" (glGetPointerv GL_COLOR_ARRAY_POINTER))
- (format #t "GL_INDEX_ARRAY: ~A~%" (glGetBooleanv GL_INDEX_ARRAY))
- (format #t "GL_INDEX_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_INDEX_ARRAY_TYPE))
- (format #t "GL_INDEX_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_INDEX_ARRAY_STRIDE))
- (format #t "GL_INDEX_ARRAY_POINTER: ~A~%" (glGetPointerv GL_INDEX_ARRAY_POINTER))
- (format #t "GL_TEXTURE_COORD_ARRAY: ~A~%" (glGetBooleanv GL_TEXTURE_COORD_ARRAY))
- (format #t "GL_TEXTURE_COORD_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_SIZE))
- (format #t "GL_TEXTURE_COORD_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_TYPE))
- (format #t "GL_TEXTURE_COORD_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_STRIDE))
- (format #t "GL_TEXTURE_COORD_ARRAY_POINTER: ~A~%" (glGetPointerv GL_TEXTURE_COORD_ARRAY_POINTER))
- (format #t "GL_EDGE_FLAG_ARRAY: ~A~%" (glGetBooleanv GL_EDGE_FLAG_ARRAY))
- (format #t "GL_EDGE_FLAG_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_EDGE_FLAG_ARRAY_STRIDE))
- (format #t "GL_EDGE_FLAG_ARRAY_POINTER: ~A~%" (glGetPointerv GL_EDGE_FLAG_ARRAY_POINTER))
- (format #t "GL_MODELVIEW_MATRIX: ~A~%" (glGetFloatv GL_MODELVIEW_MATRIX))
- (format #t "GL_PROJECTION_MATRIX: ~A~%" (glGetFloatv GL_PROJECTION_MATRIX))
- (format #t "GL_TEXTURE_MATRIX: ~A~%" (glGetFloatv GL_TEXTURE_MATRIX))
- (format #t "GL_VIEWPORT: ~A~%" (glGetIntegerv GL_VIEWPORT))
- (format #t "GL_DEPTH_RANGE: ~A~%" (glGetFloatv GL_DEPTH_RANGE))
- (format #t "GL_MODELVIEW_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MODELVIEW_STACK_DEPTH))
- (format #t "GL_PROJECTION_STACK_DEPTH: ~A~%" (glGetIntegerv GL_PROJECTION_STACK_DEPTH))
- (format #t "GL_TEXTURE_STACK_DEPTH: ~A~%" (glGetIntegerv GL_TEXTURE_STACK_DEPTH))
- (format #t "GL_MATRIX_MODE: ~A~%" (glGetIntegerv GL_MATRIX_MODE))
- (format #t "GL_NORMALIZE: ~A~%" (glGetBooleanv GL_NORMALIZE))
- (format #t "GL_CLIP_PLANE0: ~A~%" (glGetBooleanv GL_CLIP_PLANE0))
- (format #t "GL_CLIP_PLANE1: ~A~%" (glGetBooleanv GL_CLIP_PLANE1))
- (format #t "GL_CLIP_PLANE2: ~A~%" (glGetBooleanv GL_CLIP_PLANE2))
- (format #t "GL_CLIP_PLANE3: ~A~%" (glGetBooleanv GL_CLIP_PLANE3))
- (format #t "GL_CLIP_PLANE4: ~A~%" (glGetBooleanv GL_CLIP_PLANE4))
- (format #t "GL_CLIP_PLANE5: ~A~%" (glGetBooleanv GL_CLIP_PLANE5))
- (format #t "GL_FOG_COLOR: ~A~%" (glGetFloatv GL_FOG_COLOR))
- (format #t "GL_FOG_INDEX: ~A~%" (glGetIntegerv GL_FOG_INDEX))
- (format #t "GL_FOG_DENSITY: ~A~%" (glGetFloatv GL_FOG_DENSITY))
- (format #t "GL_FOG_START: ~A~%" (glGetFloatv GL_FOG_START))
- (format #t "GL_FOG_END: ~A~%" (glGetFloatv GL_FOG_END))
- (format #t "GL_FOG_MODE: ~A~%" (glGetIntegerv GL_FOG_MODE))
- (format #t "GL_FOG: ~A~%" (glGetBooleanv GL_FOG))
- (format #t "GL_SHADE_MODEL: ~A~%" (glGetIntegerv GL_SHADE_MODEL))
- (format #t "GL_LIGHTING: ~A~%" (glGetBooleanv GL_LIGHTING))
- (format #t "GL_COLOR_MATERIAL: ~A~%" (glGetBooleanv GL_COLOR_MATERIAL))
- (format #t "GL_COLOR_MATERIAL_PARAMETER: ~A~%" (glGetIntegerv GL_COLOR_MATERIAL_PARAMETER))
- (format #t "GL_COLOR_MATERIAL_FACE: ~A~%" (glGetIntegerv GL_COLOR_MATERIAL_FACE))
- (format #t "GL_BACK GL_AMBIENT: ~A~%" (glGetMaterialfv GL_BACK GL_AMBIENT))
- (format #t "GL_FRONT GL_AMBIENT: ~A~%" (glGetMaterialfv GL_FRONT GL_AMBIENT))
- (format #t "GL_BACK GL_DIFFUSE: ~A~%" (glGetMaterialfv GL_BACK GL_DIFFUSE))
- (format #t "GL_FRONT GL_DIFFUSE: ~A~%" (glGetMaterialfv GL_FRONT GL_DIFFUSE))
- (format #t "GL_BACK GL_SPECULAR: ~A~%" (glGetMaterialfv GL_BACK GL_SPECULAR))
- (format #t "GL_FRONT GL_SPECULAR: ~A~%" (glGetMaterialfv GL_FRONT GL_SPECULAR))
- (format #t "GL_BACK GL_EMISSION: ~A~%" (glGetMaterialfv GL_BACK GL_EMISSION))
- (format #t "GL_FRONT GL_EMISSION: ~A~%" (glGetMaterialfv GL_FRONT GL_EMISSION))
- (format #t "GL_BACK GL_SHININESS: ~A~%" (glGetMaterialfv GL_BACK GL_SHININESS))
- (format #t "GL_FRONT GL_SHININESS: ~A~%" (glGetMaterialfv GL_FRONT GL_SHININESS))
- (format #t "GL_LIGHT_MODEL_AMBIENT: ~A~%" (glGetFloatv GL_LIGHT_MODEL_AMBIENT))
- (format #t "GL_LIGHT_MODEL_LOCAL_VIEWER: ~A~%" (glGetBooleanv GL_LIGHT_MODEL_LOCAL_VIEWER))
- (format #t "GL_LIGHT_MODEL_TWO_SIDE: ~A~%" (glGetBooleanv GL_LIGHT_MODEL_TWO_SIDE))
+ (format () "GL_CURRENT_COLOR: ~A~%" (glGetFloatv GL_CURRENT_COLOR))
+ (format () "GL_CURRENT_INDEX: ~A~%" (glGetIntegerv GL_CURRENT_INDEX))
+ (format () "GL_CURRENT_TEXTURE_COORDS: ~A~%" (glGetFloatv GL_CURRENT_TEXTURE_COORDS))
+ (format () "GL_CURRENT_NORMAL: ~A~%" (glGetFloatv GL_CURRENT_NORMAL))
+ (format () "GL_CURRENT_RASTER_POSITION: ~A~%" (glGetFloatv GL_CURRENT_RASTER_POSITION))
+ (format () "GL_CURRENT_RASTER_DISTANCE: ~A~%" (glGetFloatv GL_CURRENT_RASTER_DISTANCE))
+ (format () "GL_CURRENT_RASTER_COLOR: ~A~%" (glGetFloatv GL_CURRENT_RASTER_COLOR))
+ (format () "GL_CURRENT_RASTER_INDEX: ~A~%" (glGetIntegerv GL_CURRENT_RASTER_INDEX))
+ (format () "GL_CURRENT_RASTER_TEXTURE_COORDS: ~A~%" (glGetFloatv GL_CURRENT_RASTER_TEXTURE_COORDS))
+ (format () "GL_CURRENT_RASTER_POSITION_VALID: ~A~%" (glGetBooleanv GL_CURRENT_RASTER_POSITION_VALID))
+ (format () "GL_EDGE_FLAG: ~A~%" (glGetBooleanv GL_EDGE_FLAG))
+ (format () "GL_VERTEX_ARRAY: ~A~%" (glGetBooleanv GL_VERTEX_ARRAY))
+ (format () "GL_VERTEX_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_SIZE))
+ (format () "GL_VERTEX_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_TYPE))
+ (format () "GL_VERTEX_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_VERTEX_ARRAY_STRIDE))
+ (format () "GL_VERTEX_ARRAY_POINTER: ~A~%" (glGetPointerv GL_VERTEX_ARRAY_POINTER))
+ (format () "GL_NORMAL_ARRAY: ~A~%" (glGetBooleanv GL_NORMAL_ARRAY))
+ (format () "GL_NORMAL_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_NORMAL_ARRAY_TYPE))
+ (format () "GL_NORMAL_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_NORMAL_ARRAY_STRIDE))
+ (format () "GL_NORMAL_ARRAY_POINTER: ~A~%" (glGetPointerv GL_NORMAL_ARRAY_POINTER))
+ (format () "GL_COLOR_ARRAY: ~A~%" (glGetBooleanv GL_COLOR_ARRAY))
+ (format () "GL_COLOR_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_SIZE))
+ (format () "GL_COLOR_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_TYPE))
+ (format () "GL_COLOR_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_COLOR_ARRAY_STRIDE))
+ (format () "GL_COLOR_ARRAY_POINTER: ~A~%" (glGetPointerv GL_COLOR_ARRAY_POINTER))
+ (format () "GL_INDEX_ARRAY: ~A~%" (glGetBooleanv GL_INDEX_ARRAY))
+ (format () "GL_INDEX_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_INDEX_ARRAY_TYPE))
+ (format () "GL_INDEX_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_INDEX_ARRAY_STRIDE))
+ (format () "GL_INDEX_ARRAY_POINTER: ~A~%" (glGetPointerv GL_INDEX_ARRAY_POINTER))
+ (format () "GL_TEXTURE_COORD_ARRAY: ~A~%" (glGetBooleanv GL_TEXTURE_COORD_ARRAY))
+ (format () "GL_TEXTURE_COORD_ARRAY_SIZE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_SIZE))
+ (format () "GL_TEXTURE_COORD_ARRAY_TYPE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_TYPE))
+ (format () "GL_TEXTURE_COORD_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_TEXTURE_COORD_ARRAY_STRIDE))
+ (format () "GL_TEXTURE_COORD_ARRAY_POINTER: ~A~%" (glGetPointerv GL_TEXTURE_COORD_ARRAY_POINTER))
+ (format () "GL_EDGE_FLAG_ARRAY: ~A~%" (glGetBooleanv GL_EDGE_FLAG_ARRAY))
+ (format () "GL_EDGE_FLAG_ARRAY_STRIDE: ~A~%" (glGetIntegerv GL_EDGE_FLAG_ARRAY_STRIDE))
+ (format () "GL_EDGE_FLAG_ARRAY_POINTER: ~A~%" (glGetPointerv GL_EDGE_FLAG_ARRAY_POINTER))
+ (format () "GL_MODELVIEW_MATRIX: ~A~%" (glGetFloatv GL_MODELVIEW_MATRIX))
+ (format () "GL_PROJECTION_MATRIX: ~A~%" (glGetFloatv GL_PROJECTION_MATRIX))
+ (format () "GL_TEXTURE_MATRIX: ~A~%" (glGetFloatv GL_TEXTURE_MATRIX))
+ (format () "GL_VIEWPORT: ~A~%" (glGetIntegerv GL_VIEWPORT))
+ (format () "GL_DEPTH_RANGE: ~A~%" (glGetFloatv GL_DEPTH_RANGE))
+ (format () "GL_MODELVIEW_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MODELVIEW_STACK_DEPTH))
+ (format () "GL_PROJECTION_STACK_DEPTH: ~A~%" (glGetIntegerv GL_PROJECTION_STACK_DEPTH))
+ (format () "GL_TEXTURE_STACK_DEPTH: ~A~%" (glGetIntegerv GL_TEXTURE_STACK_DEPTH))
+ (format () "GL_MATRIX_MODE: ~A~%" (glGetIntegerv GL_MATRIX_MODE))
+ (format () "GL_NORMALIZE: ~A~%" (glGetBooleanv GL_NORMALIZE))
+ (format () "GL_CLIP_PLANE0: ~A~%" (glGetBooleanv GL_CLIP_PLANE0))
+ (format () "GL_CLIP_PLANE1: ~A~%" (glGetBooleanv GL_CLIP_PLANE1))
+ (format () "GL_CLIP_PLANE2: ~A~%" (glGetBooleanv GL_CLIP_PLANE2))
+ (format () "GL_CLIP_PLANE3: ~A~%" (glGetBooleanv GL_CLIP_PLANE3))
+ (format () "GL_CLIP_PLANE4: ~A~%" (glGetBooleanv GL_CLIP_PLANE4))
+ (format () "GL_CLIP_PLANE5: ~A~%" (glGetBooleanv GL_CLIP_PLANE5))
+ (format () "GL_FOG_COLOR: ~A~%" (glGetFloatv GL_FOG_COLOR))
+ (format () "GL_FOG_INDEX: ~A~%" (glGetIntegerv GL_FOG_INDEX))
+ (format () "GL_FOG_DENSITY: ~A~%" (glGetFloatv GL_FOG_DENSITY))
+ (format () "GL_FOG_START: ~A~%" (glGetFloatv GL_FOG_START))
+ (format () "GL_FOG_END: ~A~%" (glGetFloatv GL_FOG_END))
+ (format () "GL_FOG_MODE: ~A~%" (glGetIntegerv GL_FOG_MODE))
+ (format () "GL_FOG: ~A~%" (glGetBooleanv GL_FOG))
+ (format () "GL_SHADE_MODEL: ~A~%" (glGetIntegerv GL_SHADE_MODEL))
+ (format () "GL_LIGHTING: ~A~%" (glGetBooleanv GL_LIGHTING))
+ (format () "GL_COLOR_MATERIAL: ~A~%" (glGetBooleanv GL_COLOR_MATERIAL))
+ (format () "GL_COLOR_MATERIAL_PARAMETER: ~A~%" (glGetIntegerv GL_COLOR_MATERIAL_PARAMETER))
+ (format () "GL_COLOR_MATERIAL_FACE: ~A~%" (glGetIntegerv GL_COLOR_MATERIAL_FACE))
+ (format () "GL_BACK GL_AMBIENT: ~A~%" (glGetMaterialfv GL_BACK GL_AMBIENT))
+ (format () "GL_FRONT GL_AMBIENT: ~A~%" (glGetMaterialfv GL_FRONT GL_AMBIENT))
+ (format () "GL_BACK GL_DIFFUSE: ~A~%" (glGetMaterialfv GL_BACK GL_DIFFUSE))
+ (format () "GL_FRONT GL_DIFFUSE: ~A~%" (glGetMaterialfv GL_FRONT GL_DIFFUSE))
+ (format () "GL_BACK GL_SPECULAR: ~A~%" (glGetMaterialfv GL_BACK GL_SPECULAR))
+ (format () "GL_FRONT GL_SPECULAR: ~A~%" (glGetMaterialfv GL_FRONT GL_SPECULAR))
+ (format () "GL_BACK GL_EMISSION: ~A~%" (glGetMaterialfv GL_BACK GL_EMISSION))
+ (format () "GL_FRONT GL_EMISSION: ~A~%" (glGetMaterialfv GL_FRONT GL_EMISSION))
+ (format () "GL_BACK GL_SHININESS: ~A~%" (glGetMaterialfv GL_BACK GL_SHININESS))
+ (format () "GL_FRONT GL_SHININESS: ~A~%" (glGetMaterialfv GL_FRONT GL_SHININESS))
+ (format () "GL_LIGHT_MODEL_AMBIENT: ~A~%" (glGetFloatv GL_LIGHT_MODEL_AMBIENT))
+ (format () "GL_LIGHT_MODEL_LOCAL_VIEWER: ~A~%" (glGetBooleanv GL_LIGHT_MODEL_LOCAL_VIEWER))
+ (format () "GL_LIGHT_MODEL_TWO_SIDE: ~A~%" (glGetBooleanv GL_LIGHT_MODEL_TWO_SIDE))
(let ((nlights (car (glGetIntegerv GL_MAX_LIGHTS))))
(do ((i 0 (+ 1 i)))
@@ -161,150 +160,146 @@
(glGetFloatv i AMBIENT)
(glGetFloatv i DIFFUSE)
(glGetFloatv i SPECULAR)
- (glGetLightfv i POSITION)
- (glGetLightfv i CONSTANT_ATTENUATION)
- (glGetLightfv i LINEAR_ATTENUATION)
- (glGetLightfv i QUADRATIC_ATTENUATION)
- (glGetLightfv i SPOT_DIRECTION)
- (glGetLightfv i SPOT_EXPONENT)
- (glGetLightfv i SPOT_CUTOFF)
- ))))
+ (for-each
+ (lambda (arg)
+ (glGetLightfv i arg))
+ (vector POSITION CONSTANT_ATTENUATION LINEAR_ATTENUATION QUADRATIC_ATTENUATION SPOT_DIRECTION SPOT_EXPONENT SPOT_CUTOFF))))))
- (format #t "GL_POINT_SIZE: ~A~%" (glGetFloatv GL_POINT_SIZE))
- (format #t "GL_POINT_SMOOTH: ~A~%" (glGetBooleanv GL_POINT_SMOOTH))
- (format #t "GL_LINE_WIDTH: ~A~%" (glGetFloatv GL_LINE_WIDTH))
- (format #t "GL_LINE_SMOOTH: ~A~%" (glGetBooleanv GL_LINE_SMOOTH))
- (format #t "GL_LINE_STIPPLE_PATTERN: ~A~%" (glGetIntegerv GL_LINE_STIPPLE_PATTERN))
- (format #t "GL_LINE_STIPPLE_REPEAT: ~A~%" (glGetIntegerv GL_LINE_STIPPLE_REPEAT))
- (format #t "GL_LINE_STIPPLE: ~A~%" (glGetBooleanv GL_LINE_STIPPLE))
- (format #t "GL_CULL_FACE: ~A~%" (glGetBooleanv GL_CULL_FACE))
- (format #t "GL_CULL_FACE_MODE: ~A~%" (glGetIntegerv GL_CULL_FACE_MODE))
- (format #t "GL_FRONT_FACE: ~A~%" (glGetIntegerv GL_FRONT_FACE))
- (format #t "GL_POLYGON_SMOOTH: ~A~%" (glGetBooleanv GL_POLYGON_SMOOTH))
- (format #t "GL_POLYGON_MODE: ~A~%" (glGetIntegerv GL_POLYGON_MODE))
- (format #t "GL_POLYGON_OFFSET_FACTOR: ~A~%" (glGetFloatv GL_POLYGON_OFFSET_FACTOR))
- (format #t "GL_POLYGON_OFFSET_UNITS: ~A~%" (glGetFloatv GL_POLYGON_OFFSET_UNITS))
- (format #t "GL_POLYGON_OFFSET_POINT: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_POINT))
- (format #t "GL_POLYGON_OFFSET_LINE: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_LINE))
- (format #t "GL_POLYGON_OFFSET_FILL: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_FILL))
- (format #t "GL_POLYGON_STIPPLE: ~A~%" (glGetBooleanv GL_POLYGON_STIPPLE))
- (format #t "GL_TEXTURE_1D: ~A~%" (glGetBooleanv GL_TEXTURE_1D))
- (format #t "GL_TEXTURE_2D: ~A~%" (glGetBooleanv GL_TEXTURE_2D))
- (format #t "GL_TEXTURE_BINDING_1D: ~A~%" (glGetIntegerv GL_TEXTURE_BINDING_1D))
- (format #t "GL_TEXTURE_BINDING_2D: ~A~%" (glGetIntegerv GL_TEXTURE_BINDING_2D))
- (format #t "GL_TEXTURE_GEN_S: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_S))
- (format #t "GL_TEXTURE_GEN_T: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_T))
- (format #t "GL_TEXTURE_GEN_R: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_R))
- (format #t "GL_TEXTURE_GEN_Q: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_Q))
- (format #t "GL_SCISSOR_TEST: ~A~%" (glGetBooleanv GL_SCISSOR_TEST))
- (format #t "GL_SCISSOR_BOX: ~A~%" (glGetIntegerv GL_SCISSOR_BOX))
- (format #t "GL_ALPHA_TEST: ~A~%" (glGetBooleanv GL_ALPHA_TEST))
- (format #t "GL_ALPHA_TEST_FUNC: ~A~%" (glGetIntegerv GL_ALPHA_TEST_FUNC))
- (format #t "GL_ALPHA_TEST_REF: ~A~%" (glGetFloatv GL_ALPHA_TEST_REF))
- (format #t "GL_STENCIL_TEST: ~A~%" (glGetBooleanv GL_STENCIL_TEST))
- (format #t "GL_STENCIL_FUNC: ~A~%" (glGetIntegerv GL_STENCIL_FUNC))
- (format #t "GL_STENCIL_VALUE_MASK: ~A~%" (glGetIntegerv GL_STENCIL_VALUE_MASK))
- (format #t "GL_STENCIL_REF: ~A~%" (glGetIntegerv GL_STENCIL_REF))
- (format #t "GL_STENCIL_FAIL: ~A~%" (glGetIntegerv GL_STENCIL_FAIL))
- (format #t "GL_STENCIL_PASS_DEPTH_FAIL: ~A~%" (glGetIntegerv GL_STENCIL_PASS_DEPTH_FAIL))
- (format #t "GL_STENCIL_PASS_DEPTH_PASS: ~A~%" (glGetIntegerv GL_STENCIL_PASS_DEPTH_PASS))
- (format #t "GL_DEPTH_TEST: ~A~%" (glGetBooleanv GL_DEPTH_TEST))
- (format #t "GL_DEPTH_FUNC: ~A~%" (glGetIntegerv GL_DEPTH_FUNC))
- (format #t "GL_BLEND: ~A~%" (glGetBooleanv GL_BLEND))
- (format #t "GL_BLEND_SRC: ~A~%" (glGetIntegerv GL_BLEND_SRC))
- (format #t "GL_BLEND_DST: ~A~%" (glGetIntegerv GL_BLEND_DST))
- (format #t "GL_DITHER: ~A~%" (glGetBooleanv GL_DITHER))
- (format #t "GL_LOGIC_OP: ~A~%" (glGetBooleanv GL_LOGIC_OP))
- (format #t "GL_COLOR_LOGIC_OP: ~A~%" (glGetBooleanv GL_COLOR_LOGIC_OP))
- (format #t "GL_DRAW_BUFFER: ~A~%" (glGetIntegerv GL_DRAW_BUFFER))
- (format #t "GL_INDEX_WRITEMASK: ~A~%" (glGetIntegerv GL_INDEX_WRITEMASK))
- (format #t "GL_COLOR_WRITEMASK: ~A~%" (glGetBooleanv GL_COLOR_WRITEMASK))
- (format #t "GL_DEPTH_WRITEMASK: ~A~%" (glGetBooleanv GL_DEPTH_WRITEMASK))
- (format #t "GL_STENCIL_WRITEMASK: ~A~%" (glGetIntegerv GL_STENCIL_WRITEMASK))
- (format #t "GL_COLOR_CLEAR_VALUE: ~A~%" (glGetFloatv GL_COLOR_CLEAR_VALUE))
- (format #t "GL_INDEX_CLEAR_VALUE: ~A~%" (glGetIntegerv GL_INDEX_CLEAR_VALUE))
- (format #t "GL_DEPTH_CLEAR_VALUE: ~A~%" (glGetFloatv GL_DEPTH_CLEAR_VALUE))
- (format #t "GL_STENCIL_CLEAR_VALUE: ~A~%" (glGetIntegerv GL_STENCIL_CLEAR_VALUE))
- (format #t "GL_ACCUM_CLEAR_VALUE: ~A~%" (glGetFloatv GL_ACCUM_CLEAR_VALUE))
- (format #t "GL_UNPACK_SWAP_BYTES: ~A~%" (glGetBooleanv GL_UNPACK_SWAP_BYTES))
- (format #t "GL_UNPACK_LSB_FIRST: ~A~%" (glGetBooleanv GL_UNPACK_LSB_FIRST))
- (format #t "GL_UNPACK_ROW_LENGTH: ~A~%" (glGetIntegerv GL_UNPACK_ROW_LENGTH))
- (format #t "GL_UNPACK_SKIP_ROWS: ~A~%" (glGetIntegerv GL_UNPACK_SKIP_ROWS))
- (format #t "GL_UNPACK_SKIP_PIXELS: ~A~%" (glGetIntegerv GL_UNPACK_SKIP_PIXELS))
- (format #t "GL_UNPACK_ALIGNMENT: ~A~%" (glGetIntegerv GL_UNPACK_ALIGNMENT))
- (format #t "GL_PACK_SWAP_BYTES: ~A~%" (glGetBooleanv GL_PACK_SWAP_BYTES))
- (format #t "GL_PACK_LSB_FIRST: ~A~%" (glGetBooleanv GL_PACK_LSB_FIRST))
- (format #t "GL_PACK_ROW_LENGTH: ~A~%" (glGetIntegerv GL_PACK_ROW_LENGTH))
- (format #t "GL_PACK_SKIP_ROWS: ~A~%" (glGetIntegerv GL_PACK_SKIP_ROWS))
- (format #t "GL_PACK_SKIP_PIXELS: ~A~%" (glGetIntegerv GL_PACK_SKIP_PIXELS))
- (format #t "GL_PACK_ALIGNMENT: ~A~%" (glGetIntegerv GL_PACK_ALIGNMENT))
- (format #t "GL_MAP_COLOR: ~A~%" (glGetBooleanv GL_MAP_COLOR))
- (format #t "GL_MAP_STENCIL: ~A~%" (glGetBooleanv GL_MAP_STENCIL))
- (format #t "GL_INDEX_SHIFT: ~A~%" (glGetIntegerv GL_INDEX_SHIFT))
- (format #t "GL_INDEX_OFFSET: ~A~%" (glGetIntegerv GL_INDEX_OFFSET))
- (format #t "GL_RED_SCALE: ~A~%" (glGetFloatv GL_RED_SCALE))
- (format #t "GL_GREEN_SCALE: ~A~%" (glGetFloatv GL_GREEN_SCALE))
- (format #t "GL_BLUE_SCALE: ~A~%" (glGetFloatv GL_BLUE_SCALE))
- (format #t "GL_ALPHA_SCALE: ~A~%" (glGetFloatv GL_ALPHA_SCALE))
- (format #t "GL_DEPTH_SCALE: ~A~%" (glGetFloatv GL_DEPTH_SCALE))
- (format #t "GL_RED_BIAS: ~A~%" (glGetFloatv GL_RED_BIAS))
- (format #t "GL_GREEN_BIAS: ~A~%" (glGetFloatv GL_GREEN_BIAS))
- (format #t "GL_BLUE_BIAS: ~A~%" (glGetFloatv GL_BLUE_BIAS))
- (format #t "GL_ALPHA_BIAS: ~A~%" (glGetFloatv GL_ALPHA_BIAS))
- (format #t "GL_DEPTH_BIAS: ~A~%" (glGetFloatv GL_DEPTH_BIAS))
- (format #t "GL_ZOOM_X: ~A~%" (glGetFloatv GL_ZOOM_X))
- (format #t "GL_ZOOM_Y: ~A~%" (glGetFloatv GL_ZOOM_Y))
- (format #t "GL_READ_BUFFER: ~A~%" (glGetIntegerv GL_READ_BUFFER))
- (format #t "GL_AUTO_NORMAL: ~A~%" (glGetBooleanv GL_AUTO_NORMAL))
- (format #t "GL_PERSPECTIVE_CORRECTION_HINT: ~A~%" (glGetIntegerv GL_PERSPECTIVE_CORRECTION_HINT))
- (format #t "GL_POINT_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_POINT_SMOOTH_HINT))
- (format #t "GL_LINE_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_LINE_SMOOTH_HINT))
- (format #t "GL_POLYGON_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_POLYGON_SMOOTH_HINT))
- (format #t "GL_FOG_HINT: ~A~%" (glGetIntegerv GL_FOG_HINT))
- (format #t "GL_MAX_LIGHTS: ~A~%" (glGetIntegerv GL_MAX_LIGHTS))
- (format #t "GL_MAX_CLIP_PLANES: ~A~%" (glGetIntegerv GL_MAX_CLIP_PLANES))
- (format #t "GL_MAX_MODELVIEW_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_MODELVIEW_STACK_DEPTH))
- (format #t "GL_MAX_PROJECTION_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_PROJECTION_STACK_DEPTH))
- (format #t "GL_MAX_TEXTURE_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_TEXTURE_STACK_DEPTH))
- (format #t "GL_SUBPIXEL_BITS: ~A~%" (glGetIntegerv GL_SUBPIXEL_BITS))
- (format #t "GL_MAX_TEXTURE_SIZE: ~A~%" (glGetIntegerv GL_MAX_TEXTURE_SIZE))
- (format #t "GL_MAX_PIXEL_MAP_TABLE: ~A~%" (glGetIntegerv GL_MAX_PIXEL_MAP_TABLE))
- (format #t "GL_MAX_NAME_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_NAME_STACK_DEPTH))
- (format #t "GL_MAX_LIST_NESTING: ~A~%" (glGetIntegerv GL_MAX_LIST_NESTING))
- (format #t "GL_MAX_EVAL_ORDER: ~A~%" (glGetIntegerv GL_MAX_EVAL_ORDER))
- (format #t "GL_MAX_VIEWPORT_DIMS: ~A~%" (glGetIntegerv GL_MAX_VIEWPORT_DIMS))
- (format #t "GL_MAX_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_ATTRIB_STACK_DEPTH))
- (format #t "GL_MAX_CLIENT_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_CLIENT_ATTRIB_STACK_DEPTH))
- (format #t "GL_AUX_BUFFERS: ~A~%" (glGetIntegerv GL_AUX_BUFFERS))
- (format #t "GL_RGBA_MODE: ~A~%" (glGetBooleanv GL_RGBA_MODE))
- (format #t "GL_INDEX_MODE: ~A~%" (glGetBooleanv GL_INDEX_MODE))
- (format #t "GL_DOUBLEBUFFER: ~A~%" (glGetBooleanv GL_DOUBLEBUFFER))
- (format #t "GL_STEREO: ~A~%" (glGetBooleanv GL_STEREO))
- (format #t "GL_LINE_WIDTH_RANGE: ~A~%" (glGetFloatv GL_LINE_WIDTH_RANGE))
- (format #t "GL_LINE_WIDTH_GRANULARITY: ~A~%" (glGetFloatv GL_LINE_WIDTH_GRANULARITY))
- (format #t "GL_RED_BITS: ~A~%" (glGetIntegerv GL_RED_BITS))
- (format #t "GL_GREEN_BITS: ~A~%" (glGetIntegerv GL_GREEN_BITS))
- (format #t "GL_BLUE_BITS: ~A~%" (glGetIntegerv GL_BLUE_BITS))
- (format #t "GL_ALPHA_BITS: ~A~%" (glGetIntegerv GL_ALPHA_BITS))
- (format #t "GL_INDEX_BITS: ~A~%" (glGetIntegerv GL_INDEX_BITS))
- (format #t "GL_DEPTH_BITS: ~A~%" (glGetIntegerv GL_DEPTH_BITS))
- (format #t "GL_STENCIL_BITS: ~A~%" (glGetIntegerv GL_STENCIL_BITS))
- (format #t "GL_ACCUM_RED_BITS: ~A~%" (glGetIntegerv GL_ACCUM_RED_BITS))
- (format #t "GL_ACCUM_GREEN_BITS: ~A~%" (glGetIntegerv GL_ACCUM_GREEN_BITS))
- (format #t "GL_ACCUM_BLUE_BITS: ~A~%" (glGetIntegerv GL_ACCUM_BLUE_BITS))
- (format #t "GL_ACCUM_ALPHA_BITS: ~A~%" (glGetIntegerv GL_ACCUM_ALPHA_BITS))
- (format #t "GL_LIST_BASE: ~A~%" (glGetIntegerv GL_LIST_BASE))
- (format #t "GL_LIST_INDEX: ~A~%" (glGetIntegerv GL_LIST_INDEX))
- (format #t "GL_LIST_MODE: ~A~%" (glGetIntegerv GL_LIST_MODE))
- (format #t "GL_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_ATTRIB_STACK_DEPTH))
- (format #t "GL_CLIENT_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_CLIENT_ATTRIB_STACK_DEPTH))
- (format #t "GL_NAME_STACK_DEPTH: ~A~%" (glGetIntegerv GL_NAME_STACK_DEPTH))
- (format #t "GL_RENDER_MODE: ~A~%" (glGetIntegerv GL_RENDER_MODE))
- (format #t "GL_SELECTION_BUFFER_POINTER: ~A~%" (glGetPointerv GL_SELECTION_BUFFER_POINTER))
- (format #t "GL_SELECTION_BUFFER_SIZE: ~A~%" (glGetIntegerv GL_SELECTION_BUFFER_SIZE))
- (format #t "GL_FEEDBACK_BUFFER_POINTER: ~A~%" (glGetPointerv GL_FEEDBACK_BUFFER_POINTER))
- (format #t "GL_FEEDBACK_BUFFER_SIZE: ~A~%" (glGetIntegerv GL_FEEDBACK_BUFFER_SIZE))
- (format #t "GL_FEEDBACK_BUFFER_TYPE: ~A~%" (glGetIntegerv GL_FEEDBACK_BUFFER_TYPE))
+ (format () "GL_POINT_SIZE: ~A~%" (glGetFloatv GL_POINT_SIZE))
+ (format () "GL_POINT_SMOOTH: ~A~%" (glGetBooleanv GL_POINT_SMOOTH))
+ (format () "GL_LINE_WIDTH: ~A~%" (glGetFloatv GL_LINE_WIDTH))
+ (format () "GL_LINE_SMOOTH: ~A~%" (glGetBooleanv GL_LINE_SMOOTH))
+ (format () "GL_LINE_STIPPLE_PATTERN: ~A~%" (glGetIntegerv GL_LINE_STIPPLE_PATTERN))
+ (format () "GL_LINE_STIPPLE_REPEAT: ~A~%" (glGetIntegerv GL_LINE_STIPPLE_REPEAT))
+ (format () "GL_LINE_STIPPLE: ~A~%" (glGetBooleanv GL_LINE_STIPPLE))
+ (format () "GL_CULL_FACE: ~A~%" (glGetBooleanv GL_CULL_FACE))
+ (format () "GL_CULL_FACE_MODE: ~A~%" (glGetIntegerv GL_CULL_FACE_MODE))
+ (format () "GL_FRONT_FACE: ~A~%" (glGetIntegerv GL_FRONT_FACE))
+ (format () "GL_POLYGON_SMOOTH: ~A~%" (glGetBooleanv GL_POLYGON_SMOOTH))
+ (format () "GL_POLYGON_MODE: ~A~%" (glGetIntegerv GL_POLYGON_MODE))
+ (format () "GL_POLYGON_OFFSET_FACTOR: ~A~%" (glGetFloatv GL_POLYGON_OFFSET_FACTOR))
+ (format () "GL_POLYGON_OFFSET_UNITS: ~A~%" (glGetFloatv GL_POLYGON_OFFSET_UNITS))
+ (format () "GL_POLYGON_OFFSET_POINT: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_POINT))
+ (format () "GL_POLYGON_OFFSET_LINE: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_LINE))
+ (format () "GL_POLYGON_OFFSET_FILL: ~A~%" (glGetBooleanv GL_POLYGON_OFFSET_FILL))
+ (format () "GL_POLYGON_STIPPLE: ~A~%" (glGetBooleanv GL_POLYGON_STIPPLE))
+ (format () "GL_TEXTURE_1D: ~A~%" (glGetBooleanv GL_TEXTURE_1D))
+ (format () "GL_TEXTURE_2D: ~A~%" (glGetBooleanv GL_TEXTURE_2D))
+ (format () "GL_TEXTURE_BINDING_1D: ~A~%" (glGetIntegerv GL_TEXTURE_BINDING_1D))
+ (format () "GL_TEXTURE_BINDING_2D: ~A~%" (glGetIntegerv GL_TEXTURE_BINDING_2D))
+ (format () "GL_TEXTURE_GEN_S: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_S))
+ (format () "GL_TEXTURE_GEN_T: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_T))
+ (format () "GL_TEXTURE_GEN_R: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_R))
+ (format () "GL_TEXTURE_GEN_Q: ~A~%" (glGetBooleanv GL_TEXTURE_GEN_Q))
+ (format () "GL_SCISSOR_TEST: ~A~%" (glGetBooleanv GL_SCISSOR_TEST))
+ (format () "GL_SCISSOR_BOX: ~A~%" (glGetIntegerv GL_SCISSOR_BOX))
+ (format () "GL_ALPHA_TEST: ~A~%" (glGetBooleanv GL_ALPHA_TEST))
+ (format () "GL_ALPHA_TEST_FUNC: ~A~%" (glGetIntegerv GL_ALPHA_TEST_FUNC))
+ (format () "GL_ALPHA_TEST_REF: ~A~%" (glGetFloatv GL_ALPHA_TEST_REF))
+ (format () "GL_STENCIL_TEST: ~A~%" (glGetBooleanv GL_STENCIL_TEST))
+ (format () "GL_STENCIL_FUNC: ~A~%" (glGetIntegerv GL_STENCIL_FUNC))
+ (format () "GL_STENCIL_VALUE_MASK: ~A~%" (glGetIntegerv GL_STENCIL_VALUE_MASK))
+ (format () "GL_STENCIL_REF: ~A~%" (glGetIntegerv GL_STENCIL_REF))
+ (format () "GL_STENCIL_FAIL: ~A~%" (glGetIntegerv GL_STENCIL_FAIL))
+ (format () "GL_STENCIL_PASS_DEPTH_FAIL: ~A~%" (glGetIntegerv GL_STENCIL_PASS_DEPTH_FAIL))
+ (format () "GL_STENCIL_PASS_DEPTH_PASS: ~A~%" (glGetIntegerv GL_STENCIL_PASS_DEPTH_PASS))
+ (format () "GL_DEPTH_TEST: ~A~%" (glGetBooleanv GL_DEPTH_TEST))
+ (format () "GL_DEPTH_FUNC: ~A~%" (glGetIntegerv GL_DEPTH_FUNC))
+ (format () "GL_BLEND: ~A~%" (glGetBooleanv GL_BLEND))
+ (format () "GL_BLEND_SRC: ~A~%" (glGetIntegerv GL_BLEND_SRC))
+ (format () "GL_BLEND_DST: ~A~%" (glGetIntegerv GL_BLEND_DST))
+ (format () "GL_DITHER: ~A~%" (glGetBooleanv GL_DITHER))
+ (format () "GL_LOGIC_OP: ~A~%" (glGetBooleanv GL_LOGIC_OP))
+ (format () "GL_COLOR_LOGIC_OP: ~A~%" (glGetBooleanv GL_COLOR_LOGIC_OP))
+ (format () "GL_DRAW_BUFFER: ~A~%" (glGetIntegerv GL_DRAW_BUFFER))
+ (format () "GL_INDEX_WRITEMASK: ~A~%" (glGetIntegerv GL_INDEX_WRITEMASK))
+ (format () "GL_COLOR_WRITEMASK: ~A~%" (glGetBooleanv GL_COLOR_WRITEMASK))
+ (format () "GL_DEPTH_WRITEMASK: ~A~%" (glGetBooleanv GL_DEPTH_WRITEMASK))
+ (format () "GL_STENCIL_WRITEMASK: ~A~%" (glGetIntegerv GL_STENCIL_WRITEMASK))
+ (format () "GL_COLOR_CLEAR_VALUE: ~A~%" (glGetFloatv GL_COLOR_CLEAR_VALUE))
+ (format () "GL_INDEX_CLEAR_VALUE: ~A~%" (glGetIntegerv GL_INDEX_CLEAR_VALUE))
+ (format () "GL_DEPTH_CLEAR_VALUE: ~A~%" (glGetFloatv GL_DEPTH_CLEAR_VALUE))
+ (format () "GL_STENCIL_CLEAR_VALUE: ~A~%" (glGetIntegerv GL_STENCIL_CLEAR_VALUE))
+ (format () "GL_ACCUM_CLEAR_VALUE: ~A~%" (glGetFloatv GL_ACCUM_CLEAR_VALUE))
+ (format () "GL_UNPACK_SWAP_BYTES: ~A~%" (glGetBooleanv GL_UNPACK_SWAP_BYTES))
+ (format () "GL_UNPACK_LSB_FIRST: ~A~%" (glGetBooleanv GL_UNPACK_LSB_FIRST))
+ (format () "GL_UNPACK_ROW_LENGTH: ~A~%" (glGetIntegerv GL_UNPACK_ROW_LENGTH))
+ (format () "GL_UNPACK_SKIP_ROWS: ~A~%" (glGetIntegerv GL_UNPACK_SKIP_ROWS))
+ (format () "GL_UNPACK_SKIP_PIXELS: ~A~%" (glGetIntegerv GL_UNPACK_SKIP_PIXELS))
+ (format () "GL_UNPACK_ALIGNMENT: ~A~%" (glGetIntegerv GL_UNPACK_ALIGNMENT))
+ (format () "GL_PACK_SWAP_BYTES: ~A~%" (glGetBooleanv GL_PACK_SWAP_BYTES))
+ (format () "GL_PACK_LSB_FIRST: ~A~%" (glGetBooleanv GL_PACK_LSB_FIRST))
+ (format () "GL_PACK_ROW_LENGTH: ~A~%" (glGetIntegerv GL_PACK_ROW_LENGTH))
+ (format () "GL_PACK_SKIP_ROWS: ~A~%" (glGetIntegerv GL_PACK_SKIP_ROWS))
+ (format () "GL_PACK_SKIP_PIXELS: ~A~%" (glGetIntegerv GL_PACK_SKIP_PIXELS))
+ (format () "GL_PACK_ALIGNMENT: ~A~%" (glGetIntegerv GL_PACK_ALIGNMENT))
+ (format () "GL_MAP_COLOR: ~A~%" (glGetBooleanv GL_MAP_COLOR))
+ (format () "GL_MAP_STENCIL: ~A~%" (glGetBooleanv GL_MAP_STENCIL))
+ (format () "GL_INDEX_SHIFT: ~A~%" (glGetIntegerv GL_INDEX_SHIFT))
+ (format () "GL_INDEX_OFFSET: ~A~%" (glGetIntegerv GL_INDEX_OFFSET))
+ (format () "GL_RED_SCALE: ~A~%" (glGetFloatv GL_RED_SCALE))
+ (format () "GL_GREEN_SCALE: ~A~%" (glGetFloatv GL_GREEN_SCALE))
+ (format () "GL_BLUE_SCALE: ~A~%" (glGetFloatv GL_BLUE_SCALE))
+ (format () "GL_ALPHA_SCALE: ~A~%" (glGetFloatv GL_ALPHA_SCALE))
+ (format () "GL_DEPTH_SCALE: ~A~%" (glGetFloatv GL_DEPTH_SCALE))
+ (format () "GL_RED_BIAS: ~A~%" (glGetFloatv GL_RED_BIAS))
+ (format () "GL_GREEN_BIAS: ~A~%" (glGetFloatv GL_GREEN_BIAS))
+ (format () "GL_BLUE_BIAS: ~A~%" (glGetFloatv GL_BLUE_BIAS))
+ (format () "GL_ALPHA_BIAS: ~A~%" (glGetFloatv GL_ALPHA_BIAS))
+ (format () "GL_DEPTH_BIAS: ~A~%" (glGetFloatv GL_DEPTH_BIAS))
+ (format () "GL_ZOOM_X: ~A~%" (glGetFloatv GL_ZOOM_X))
+ (format () "GL_ZOOM_Y: ~A~%" (glGetFloatv GL_ZOOM_Y))
+ (format () "GL_READ_BUFFER: ~A~%" (glGetIntegerv GL_READ_BUFFER))
+ (format () "GL_AUTO_NORMAL: ~A~%" (glGetBooleanv GL_AUTO_NORMAL))
+ (format () "GL_PERSPECTIVE_CORRECTION_HINT: ~A~%" (glGetIntegerv GL_PERSPECTIVE_CORRECTION_HINT))
+ (format () "GL_POINT_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_POINT_SMOOTH_HINT))
+ (format () "GL_LINE_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_LINE_SMOOTH_HINT))
+ (format () "GL_POLYGON_SMOOTH_HINT: ~A~%" (glGetIntegerv GL_POLYGON_SMOOTH_HINT))
+ (format () "GL_FOG_HINT: ~A~%" (glGetIntegerv GL_FOG_HINT))
+ (format () "GL_MAX_LIGHTS: ~A~%" (glGetIntegerv GL_MAX_LIGHTS))
+ (format () "GL_MAX_CLIP_PLANES: ~A~%" (glGetIntegerv GL_MAX_CLIP_PLANES))
+ (format () "GL_MAX_MODELVIEW_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_MODELVIEW_STACK_DEPTH))
+ (format () "GL_MAX_PROJECTION_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_PROJECTION_STACK_DEPTH))
+ (format () "GL_MAX_TEXTURE_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_TEXTURE_STACK_DEPTH))
+ (format () "GL_SUBPIXEL_BITS: ~A~%" (glGetIntegerv GL_SUBPIXEL_BITS))
+ (format () "GL_MAX_TEXTURE_SIZE: ~A~%" (glGetIntegerv GL_MAX_TEXTURE_SIZE))
+ (format () "GL_MAX_PIXEL_MAP_TABLE: ~A~%" (glGetIntegerv GL_MAX_PIXEL_MAP_TABLE))
+ (format () "GL_MAX_NAME_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_NAME_STACK_DEPTH))
+ (format () "GL_MAX_LIST_NESTING: ~A~%" (glGetIntegerv GL_MAX_LIST_NESTING))
+ (format () "GL_MAX_EVAL_ORDER: ~A~%" (glGetIntegerv GL_MAX_EVAL_ORDER))
+ (format () "GL_MAX_VIEWPORT_DIMS: ~A~%" (glGetIntegerv GL_MAX_VIEWPORT_DIMS))
+ (format () "GL_MAX_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_ATTRIB_STACK_DEPTH))
+ (format () "GL_MAX_CLIENT_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_MAX_CLIENT_ATTRIB_STACK_DEPTH))
+ (format () "GL_AUX_BUFFERS: ~A~%" (glGetIntegerv GL_AUX_BUFFERS))
+ (format () "GL_RGBA_MODE: ~A~%" (glGetBooleanv GL_RGBA_MODE))
+ (format () "GL_INDEX_MODE: ~A~%" (glGetBooleanv GL_INDEX_MODE))
+ (format () "GL_DOUBLEBUFFER: ~A~%" (glGetBooleanv GL_DOUBLEBUFFER))
+ (format () "GL_STEREO: ~A~%" (glGetBooleanv GL_STEREO))
+ (format () "GL_LINE_WIDTH_RANGE: ~A~%" (glGetFloatv GL_LINE_WIDTH_RANGE))
+ (format () "GL_LINE_WIDTH_GRANULARITY: ~A~%" (glGetFloatv GL_LINE_WIDTH_GRANULARITY))
+ (format () "GL_RED_BITS: ~A~%" (glGetIntegerv GL_RED_BITS))
+ (format () "GL_GREEN_BITS: ~A~%" (glGetIntegerv GL_GREEN_BITS))
+ (format () "GL_BLUE_BITS: ~A~%" (glGetIntegerv GL_BLUE_BITS))
+ (format () "GL_ALPHA_BITS: ~A~%" (glGetIntegerv GL_ALPHA_BITS))
+ (format () "GL_INDEX_BITS: ~A~%" (glGetIntegerv GL_INDEX_BITS))
+ (format () "GL_DEPTH_BITS: ~A~%" (glGetIntegerv GL_DEPTH_BITS))
+ (format () "GL_STENCIL_BITS: ~A~%" (glGetIntegerv GL_STENCIL_BITS))
+ (format () "GL_ACCUM_RED_BITS: ~A~%" (glGetIntegerv GL_ACCUM_RED_BITS))
+ (format () "GL_ACCUM_GREEN_BITS: ~A~%" (glGetIntegerv GL_ACCUM_GREEN_BITS))
+ (format () "GL_ACCUM_BLUE_BITS: ~A~%" (glGetIntegerv GL_ACCUM_BLUE_BITS))
+ (format () "GL_ACCUM_ALPHA_BITS: ~A~%" (glGetIntegerv GL_ACCUM_ALPHA_BITS))
+ (format () "GL_LIST_BASE: ~A~%" (glGetIntegerv GL_LIST_BASE))
+ (format () "GL_LIST_INDEX: ~A~%" (glGetIntegerv GL_LIST_INDEX))
+ (format () "GL_LIST_MODE: ~A~%" (glGetIntegerv GL_LIST_MODE))
+ (format () "GL_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_ATTRIB_STACK_DEPTH))
+ (format () "GL_CLIENT_ATTRIB_STACK_DEPTH: ~A~%" (glGetIntegerv GL_CLIENT_ATTRIB_STACK_DEPTH))
+ (format () "GL_NAME_STACK_DEPTH: ~A~%" (glGetIntegerv GL_NAME_STACK_DEPTH))
+ (format () "GL_RENDER_MODE: ~A~%" (glGetIntegerv GL_RENDER_MODE))
+ (format () "GL_SELECTION_BUFFER_POINTER: ~A~%" (glGetPointerv GL_SELECTION_BUFFER_POINTER))
+ (format () "GL_SELECTION_BUFFER_SIZE: ~A~%" (glGetIntegerv GL_SELECTION_BUFFER_SIZE))
+ (format () "GL_FEEDBACK_BUFFER_POINTER: ~A~%" (glGetPointerv GL_FEEDBACK_BUFFER_POINTER))
+ (format () "GL_FEEDBACK_BUFFER_SIZE: ~A~%" (glGetIntegerv GL_FEEDBACK_BUFFER_SIZE))
+ (format () "GL_FEEDBACK_BUFFER_TYPE: ~A~%" (glGetIntegerv GL_FEEDBACK_BUFFER_TYPE))
)
@@ -313,76 +308,75 @@
(require snd-snd-motif.scm)
(define complexify
- (let ((gl-list #f)
- (drawer #f))
+ (let ((drawer #f))
- (define (redraw-graph)
- (let ((win ((*motif* 'XtWindow) drawer))
- (dpy ((*motif* 'XtDisplay) drawer))
- (cx (snd-gl-context)))
- (glXMakeCurrent dpy win cx)
- (if gl-list (glDeleteLists gl-list 1))
- (set! gl-list (glGenLists 1))
- (glEnable GL_DEPTH_TEST)
- (glShadeModel GL_SMOOTH)
- (glClearDepth 1.0)
- (glClearColor 1.0 1.0 1.0 1.0)
- (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
- (let ((rl (channel->float-vector (left-sample) 512))
- (im (make-float-vector 512 0.0)))
- (mus-fft rl im)
- (let ((peak (* 2 (max (float-vector-peak rl) (float-vector-peak im)))))
- (float-vector-scale! rl (/ 1.0 peak))
- (float-vector-scale! im (/ 1.0 peak)))
- ;; display each element in the complex plane rotated to stack along the x axis
- (glNewList gl-list GL_COMPILE)
- (glBegin GL_LINES)
- (apply glColor3f (color->list *data-color*))
- (do ((i 0 (+ 1 i)))
- ((= i 256))
- (glVertex3f (/ i 256.0) 0.0 0.0)
- (glVertex3f (/ i 256.0) (rl i) (im i)))
- (glEnd)
- (glEndList))
- (let ((vals ((*motif* 'XtVaGetValues) drawer (list (*motif* 'XmNwidth) 0 (*motif* 'XmNheight) 0))))
- (glViewport 0 0 (list-ref vals 1) (list-ref vals 3)))
- (glMatrixMode GL_PROJECTION)
- (glLoadIdentity)
- (glOrtho -0.2 1.0 -1.5 1.0 -1.0 1.0)
- (glRotatef *spectro-x-angle* 1.0 0.0 0.0)
- (glRotatef *spectro-y-angle* 0.0 1.0 0.0)
- (glRotatef *spectro-z-angle* 0.0 0.0 1.0)
- (glScalef *spectro-x-scale* *spectro-y-scale* *spectro-z-scale*)
- (glCallList gl-list)
- (glXSwapBuffers dpy win)
- (glDrawBuffer GL_BACK)))
+ (define redraw-graph
+ (let ((gl-list #f))
+ (lambda ()
+ (let ((win ((*motif* 'XtWindow) drawer))
+ (dpy ((*motif* 'XtDisplay) drawer)))
+ (glXMakeCurrent dpy win (snd-gl-context))
+ (if gl-list (glDeleteLists gl-list 1))
+ (set! gl-list (glGenLists 1))
+ (glEnable GL_DEPTH_TEST)
+ (glShadeModel GL_SMOOTH)
+ (glClearDepth 1.0)
+ (glClearColor 1.0 1.0 1.0 1.0)
+ (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+ (let ((rl (channel->float-vector (left-sample) 512))
+ (im (make-float-vector 512 0.0)))
+ (mus-fft rl im)
+ (let ((peak (* 2 (max (float-vector-peak rl) (float-vector-peak im)))))
+ (float-vector-scale! rl (/ 1.0 peak))
+ (float-vector-scale! im (/ 1.0 peak)))
+ ;; display each element in the complex plane rotated to stack along the x axis
+ (glNewList gl-list GL_COMPILE)
+ (glBegin GL_LINES)
+ (apply glColor3f (color->list *data-color*))
+ (do ((i 0 (+ 1 i)))
+ ((= i 256))
+ (glVertex3f (/ i 256.0) 0.0 0.0)
+ (glVertex3f (/ i 256.0) (rl i) (im i)))
+ (glEnd)
+ (glEndList))
+ (let ((vals ((*motif* 'XtVaGetValues) drawer (list (*motif* 'XmNwidth) 0 (*motif* 'XmNheight) 0))))
+ (glViewport 0 0 (list-ref vals 1) (list-ref vals 3)))
+ (glMatrixMode GL_PROJECTION)
+ (glLoadIdentity)
+ (glOrtho -0.2 1.0 -1.5 1.0 -1.0 1.0)
+ (glRotatef *spectro-x-angle* 1.0 0.0 0.0)
+ (glRotatef *spectro-y-angle* 0.0 1.0 0.0)
+ (glRotatef *spectro-z-angle* 0.0 0.0 1.0)
+ (glScalef *spectro-x-scale* *spectro-y-scale* *spectro-z-scale*)
+ (glCallList gl-list)
+ (glXSwapBuffers dpy win)
+ (glDrawBuffer GL_BACK)))))
- (define (add-main-pane name type args)
- ((*motif* 'XtCreateManagedWidget) name type (list-ref (main-widgets) 3) args))
-
- (lambda ()
- (if (not drawer)
- (let ((outer (with-let (sublet *motif*)
- (add-main-pane "Waterfall" xmFormWidgetClass
- (list XmNbackground *basic-color*
- XmNpaneMinimum 320)))))
- (set! drawer (with-let (sublet *motif* 'outer outer)
- (XtCreateManagedWidget "draw" xmDrawingAreaWidgetClass outer
- (list XmNbackground *graph-color*
- XmNforeground *data-color*
- XmNleftAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM))))
- (set! *spectro-x-angle* 210.0)
- (set! *spectro-y-angle* 60.0)
- (set! *spectro-z-angle* 30.0)
- (set! *spectro-x-scale* 3.0)
- ((*motif* 'XtAddCallback) drawer (*motif* 'XmNresizeCallback) (lambda (w context info) (redraw-graph)))
- ((*motif* 'XtAddCallback) drawer (*motif* 'XmNexposeCallback) (lambda (w context info) (redraw-graph)))
- (hook-push after-graph-hook (lambda (hook) (redraw-graph)))
- (hook-push orientation-hook (lambda (hook) (redraw-graph)))
- (hook-push color-hook (lambda (hook) (redraw-graph))))))))
-)
+ (define (add-main-pane name type args)
+ ((*motif* 'XtCreateManagedWidget) name type (list-ref (main-widgets) 3) args))
+
+ (lambda ()
+ (unless drawer
+ (let ((outer (with-let (sublet *motif*)
+ (add-main-pane "Waterfall" xmFormWidgetClass
+ (list XmNbackground *basic-color*
+ XmNpaneMinimum 320)))))
+ (set! drawer (with-let (sublet *motif* 'outer outer)
+ (XtCreateManagedWidget "draw" xmDrawingAreaWidgetClass outer
+ (list XmNbackground *graph-color*
+ XmNforeground *data-color*
+ XmNleftAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM)))))
+ (set! *spectro-x-angle* 210.0)
+ (set! *spectro-y-angle* 60.0)
+ (set! *spectro-z-angle* 30.0)
+ (set! *spectro-x-scale* 3.0)
+ ((*motif* 'XtAddCallback) drawer (*motif* 'XmNresizeCallback) (lambda (w context info) (redraw-graph)))
+ ((*motif* 'XtAddCallback) drawer (*motif* 'XmNexposeCallback) (lambda (w context info) (redraw-graph)))
+ (hook-push after-graph-hook (lambda (hook) (redraw-graph)))
+ (hook-push orientation-hook (lambda (hook) (redraw-graph)))
+ (hook-push color-hook (lambda (hook) (redraw-graph))))))))
(define complexify (*gl* 'complexify))
diff --git a/snd-gmain.c b/snd-gmain.c
index f32cd64..ec8ff3b 100644
--- a/snd-gmain.c
+++ b/snd-gmain.c
@@ -582,7 +582,7 @@ void snd_doit(int argc, char **argv)
init_gtk();
#endif
- MAIN_PANE(ss) = gtk_vbox_new(false, 0); /* not homogenous, spacing 0 */
+ MAIN_PANE(ss) = gtk_vbox_new(false, 0); /* not homogeneous, spacing 0 */
#if (GTK_CHECK_VERSION(3, 0, 0))
init_gtk();
diff --git a/snd-gtk.scm b/snd-gtk.scm
index 7067cff..0256364 100644
--- a/snd-gtk.scm
+++ b/snd-gtk.scm
@@ -413,13 +413,10 @@
(let ((labelled-snds ()))
(define (kmg num)
- (if (<= num 0)
- "disk full!"
- (if (> num 1024)
- (if (> num (* 1024 1024))
- (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0)))
- (format #f "space: ~6,3FM" (/ num 1024.0)))
- (format #f "space: ~10DK" num))))
+ (cond ((<= num 0) "disk full!")
+ ((<= num 1024) (format #f "space: ~10DK" num))
+ ((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0))))
+ (else (format #f "space: ~6,3FM" (/ num 1024.0)))))
(define (show-label data)
(if (sound? (car data))
@@ -428,10 +425,10 @@
(g_timeout_add 10000 show-label data) ; every 10 seconds recheck space
0)))
- (define (find-if pred l)
- (cond ((null? l) #f)
- ((pred (car l)) (car l))
- (else (find-if pred (cdr l)))))
+ (define (find-if pred lst)
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (find-if pred (cdr lst)))))
(lambda (hook)
;; (show-disk-space snd) adds a label to snd's status-area area showing the current free space (for use with after-open-hook)
@@ -480,9 +477,9 @@
(define snd-clock-icon
(lambda (snd hour)
(let* ((window (GDK_WINDOW (gtk_widget_get_window ((sound-widgets snd) 8))))
- (cr (gdk_cairo_create window))
- (bg (color->list *basic-color*)))
- (cairo_set_source_rgb cr (car bg) (cadr bg) (caddr bg))
+ (cr (gdk_cairo_create window)))
+ (let ((bg (color->list *basic-color*)))
+ (cairo_set_source_rgb cr (car bg) (cadr bg) (caddr bg)))
(cairo_rectangle cr 0 0 16 16) ; icon bg
(cairo_fill cr)
(cairo_set_source_rgb cr 1.0 1.0 1.0)
@@ -503,11 +500,10 @@
(define (snd-happy-face snd progress)
(let* ((window (GDK_WINDOW (gtk_widget_get_window ((sound-widgets snd) 8))))
(cr (gdk_cairo_create window))
- (bg (color->list *basic-color*))
(fc (list 1.0 progress 0.0)))
-
- ;; overall background
- (cairo_set_source_rgb cr (car bg) (cadr bg) (caddr bg))
+ (let ((bg (color->list *basic-color*)))
+ ;; overall background
+ (cairo_set_source_rgb cr (car bg) (cadr bg) (caddr bg)))
(cairo_rectangle cr 0 0 16 16)
(cairo_fill cr)
@@ -565,15 +561,18 @@
(define (find-free-dialog ds)
(and (pair? ds)
- (if (not (cadr (car ds)))
+ (pair? (car ds))
+ (pair? (cdar ds))
+ (if (cadar ds)
+ (find-free-dialog (cdr ds))
(begin
(set! ((car ds) 1) #t)
- (caar ds))
- (find-free-dialog (cdr ds)))))
+ (caar ds)))))
+
(lambda args
;; (file-select func title dir filter help)
- (let* ((func (and (> (length args) 0) (args 0)))
- (title (if (> (length args) 1) (args 1) "select file"))
+ (let* ((func (and (pair? args) (args 0)))
+ (title (if (and (pair? args) (pair? (cdr args))) (args 1) "select file"))
(dir (if (> (length args) 2) (args 2) "."))
(dialog (or (find-free-dialog file-selector-dialogs)
(GTK_FILE_CHOOSER_DIALOG (gtk_file_chooser_dialog_new
@@ -803,16 +802,15 @@
(case type
((text)
;; add a horizontal pair: label text
- (let ((label (gtk_label_new var-label))
- (hbox (gtk_box_new GTK_ORIENTATION_HORIZONTAL 0))
- (text (gtk_label_new "")))
- (gtk_box_pack_start (GTK_BOX pane) hbox #f #f 2)
- (gtk_widget_show hbox)
- (gtk_box_pack_start (GTK_BOX hbox) label #f #f 6)
-
- (gtk_widget_set_halign (GTK_WIDGET label) GTK_ALIGN_START)
- (gtk_widget_show label)
- (gtk_box_pack_start (GTK_BOX hbox) text #t #t 6)
+ (let ((text (gtk_label_new "")))
+ (let ((hbox (gtk_box_new GTK_ORIENTATION_HORIZONTAL 0)))
+ (let ((label (gtk_label_new var-label)))
+ (gtk_box_pack_start (GTK_BOX pane) hbox #f #f 2)
+ (gtk_widget_show hbox)
+ (gtk_box_pack_start (GTK_BOX hbox) label #f #f 6)
+ (gtk_widget_set_halign (GTK_WIDGET label) GTK_ALIGN_START)
+ (gtk_widget_show label))
+ (gtk_box_pack_start (GTK_BOX hbox) text #t #t 6))
(gtk_widget_set_halign (GTK_WIDGET text) GTK_ALIGN_START)
(gtk_widget_show text)
text))
@@ -866,9 +864,7 @@
(set! (data loc) var)
(if (time-graph? snd) (update-time-graph snd))
(if (transform-graph? snd) (update-transform-graph snd))
- (if (= (+ loc 1) len)
- (set! (cursor snd 0) 0)
- (set! (cursor snd 0) (+ loc 1))))
+ (set! (cursor snd 0) (if (= (+ loc 1) len) 0 (+ loc 1))))
(if (GTK_IS_PROGRESS_BAR (car widget))
;; "thermometer"
(let ((y0 (cadr widget))
diff --git a/snd-help.c b/snd-help.c
index a69aabb..44bd572 100644
--- a/snd-help.c
+++ b/snd-help.c
@@ -370,7 +370,7 @@ char *version_info(void)
", mpfr: ", mpfr_get_version(),
", mpc: ", mpc_get_version(),
#endif
-#ifdef __DATE__
+#if (defined(__DATE__)) && (!(defined(REPRODUCIBLE_BUILD)))
"\n Compiled ", __DATE__, " ", __TIME__,
#endif
#ifdef __VERSION__
@@ -1693,7 +1693,7 @@ The control filter functions are:\n\
filter coefficients (read-only currently)\n\
\n\
" S_filter_control_envelope " (:optional snd)\n\
- filter (frequency reponse) envelope\n\
+ filter (frequency response) envelope\n\
\n\
" S_filter_control_in_dB " (:optional snd)\n\
The filter dB button. If " PROC_TRUE ", the graph is displayed in dB.\n\
diff --git a/snd-kbd.c b/snd-kbd.c
index 139d3e5..fa541e8 100644
--- a/snd-kbd.c
+++ b/snd-kbd.c
@@ -1601,7 +1601,6 @@ static Xen g_bind_key_1(Xen key, Xen state, Xen code, Xen cx_extended, Xen origi
set_keymap_entry(k, s, 0, Xen_undefined, e, NULL, NULL);
else
{
- char buf[256];
int args;
const char *comment = NULL, *prefs = NULL;
args = Xen_required_args(code);
@@ -1617,7 +1616,11 @@ static Xen g_bind_key_1(Xen key, Xen state, Xen code, Xen cx_extended, Xen origi
}
if (Xen_is_string(origin))
comment = Xen_string_to_C_string(origin);
- else comment = make_key_name(buf, 256, k, s, e);
+ else
+ {
+ char buf[256];
+ comment = make_key_name(buf, 256, k, s, e);
+ }
if (Xen_is_string(prefs_info)) prefs = Xen_string_to_C_string(prefs_info);
set_keymap_entry(k, s, args, code, e, comment, prefs);
}
diff --git a/snd-listener.c b/snd-listener.c
index ede742e..d18d6ee 100644
--- a/snd-listener.c
+++ b/snd-listener.c
@@ -186,7 +186,7 @@ static Xen g_listener_prompt(void) {return(C_string_to_Xen_string(listener_promp
static Xen g_set_listener_prompt(Xen val)
{
char *new_prompt;
- #define H_listener_prompt "(" S_listener_prompt "): the current lisp listener prompt character ('>') "
+ #define H_listener_prompt "(" S_listener_prompt "): the current lisp listener prompt string (\">\") "
Xen_check_type(Xen_is_string(val), val, 1, S_set S_listener_prompt, "a string");
if (listener_prompt(ss)) free(listener_prompt(ss));
@@ -202,6 +202,27 @@ static Xen g_set_listener_prompt(Xen val)
}
+static Xen g_stdin_prompt(void) {return(C_string_to_Xen_string(stdin_prompt(ss)));}
+
+static Xen g_set_stdin_prompt(Xen val)
+{
+ char *new_prompt;
+ #define H_stdin_prompt "(" S_stdin_prompt "): the current stdin prompt string"
+ Xen_check_type(Xen_is_string(val), val, 1, S_set S_stdin_prompt, "a string");
+
+ if (stdin_prompt(ss)) free(stdin_prompt(ss));
+ new_prompt = mus_strdup(Xen_string_to_C_string(val));
+ if (new_prompt == NULL)
+ {
+ new_prompt = (char *)malloc(sizeof(char));
+ new_prompt[0] = 0;
+ }
+ set_stdin_prompt((char *)new_prompt);
+
+ return(val);
+}
+
+
static Xen g_snd_completion(Xen text)
{
/* perhaps callable from emacs? */
@@ -247,6 +268,8 @@ Xen_wrap_no_args(g_show_listener_w, g_show_listener)
Xen_wrap_1_arg(g_set_show_listener_w, g_set_show_listener)
Xen_wrap_no_args(g_listener_prompt_w, g_listener_prompt)
Xen_wrap_1_arg(g_set_listener_prompt_w, g_set_listener_prompt)
+Xen_wrap_no_args(g_stdin_prompt_w, g_stdin_prompt)
+Xen_wrap_1_arg(g_set_stdin_prompt_w, g_set_stdin_prompt)
Xen_wrap_1_arg(g_snd_completion_w, g_snd_completion)
Xen_wrap_no_args(g_listener_colorized_w, g_listener_colorized)
Xen_wrap_1_arg(g_listener_set_colorized_w, g_listener_set_colorized)
@@ -256,6 +279,7 @@ Xen_wrap_1_arg(g_listener_set_colorized_w, g_listener_set_colorized)
static s7_pointer acc_listener_colorized(s7_scheme *sc, s7_pointer args) {return(g_listener_set_colorized(s7_cadr(args)));}
#endif
static s7_pointer acc_listener_prompt(s7_scheme *sc, s7_pointer args) {return(g_set_listener_prompt(s7_cadr(args)));}
+static s7_pointer acc_stdin_prompt(s7_scheme *sc, s7_pointer args) {return(g_set_stdin_prompt(s7_cadr(args)));}
#endif
void g_init_listener(void)
@@ -265,6 +289,7 @@ void g_init_listener(void)
Xen_define_dilambda(S_show_listener, g_show_listener_w, H_show_listener, S_set S_show_listener, g_set_show_listener_w, 0, 0, 1, 0);
Xen_define_dilambda(S_listener_prompt, g_listener_prompt_w, H_listener_prompt, S_set S_listener_prompt, g_set_listener_prompt_w, 0, 0, 1, 0);
+ Xen_define_dilambda(S_stdin_prompt, g_stdin_prompt_w, H_stdin_prompt, S_set S_stdin_prompt, g_set_stdin_prompt_w, 0, 0, 1, 0);
Xen_define_dilambda(S_listener_colorized, g_listener_colorized_w, H_listener_colorized,
S_set S_listener_colorized, g_listener_set_colorized_w, 0, 0, 1, 0);
@@ -280,7 +305,9 @@ If it returns true, Snd assumes you've dealt the text yourself, and does not try
s7_symbol_set_documentation(s7, ss->listener_colorized_symbol, "*listener-colorized*: number of vector elements to print in the listener (default: 12)");
s7_symbol_set_access(s7, ss->listener_colorized_symbol, s7_make_function(s7, "[acc-" S_listener_colorized "]", acc_listener_colorized, 2, 0, false, "accessor"));
#endif
- s7_symbol_set_documentation(s7, ss->listener_prompt_symbol, "*listener-prompt*: the current lisp listener prompt character ('>') ");
+ s7_symbol_set_documentation(s7, ss->listener_prompt_symbol, "*listener-prompt*: the current lisp listener prompt string (\">\") ");
s7_symbol_set_access(s7, ss->listener_prompt_symbol, s7_make_function(s7, "[acc-" S_listener_prompt "]", acc_listener_prompt, 2, 0, false, "accessor"));
+ s7_symbol_set_documentation(s7, ss->stdin_prompt_symbol, "*stdin-prompt*: the current stdin prompt string");
+ s7_symbol_set_access(s7, ss->stdin_prompt_symbol, s7_make_function(s7, "[acc-" S_stdin_prompt "]", acc_stdin_prompt, 2, 0, false, "accessor"));
#endif
}
diff --git a/snd-main.c b/snd-main.c
index 5c0309d..4b7905a 100644
--- a/snd-main.c
+++ b/snd-main.c
@@ -1339,20 +1339,6 @@ static char *file_extension(char *arg)
#endif
-#if (!DISABLE_DEPRECATED)
-static Xen start_hook;
-
-static bool dont_start(char *filename)
-{
- Xen res = Xen_false;
- if (Xen_hook_has_list(start_hook))
- res = run_or_hook(start_hook,
- Xen_list_1(C_string_to_Xen_string(filename)),
- S_start_hook);
- return(Xen_is_true(res));
-}
-#endif
-
static char *startup_filename = NULL;
static int script_arg = 0, script_argn = 0;
static char **script_args;
@@ -1508,12 +1494,7 @@ int handle_next_startup_arg(int auto_open_ctr, char **auto_open_file_names, bool
else
{
if (startup_filename == NULL)
- {
- startup_filename = mus_strdup(argname);
-#if (!DISABLE_DEPRECATED)
- if (dont_start(startup_filename)) snd_exit(1);
-#endif
- }
+ startup_filename = mus_strdup(argname);
ss->open_requestor = FROM_STARTUP;
if (snd_open_file(argname, FILE_READ_WRITE) == NULL)
{
@@ -2364,11 +2345,6 @@ void g_init_main(void)
Xen_define_typed_dilambda(S_ladspa_dir, g_ladspa_dir_w, H_ladspa_dir,
S_set S_ladspa_dir, g_set_ladspa_dir_w, 0, 0, 1, 0, pl_s, pl_ss);
-#if (!DISABLE_DEPRECATED)
-#define H_start_hook S_start_hook " (name): called upon start-up. If it returns " PROC_TRUE ", snd exits immediately."
- start_hook = Xen_define_hook(S_start_hook, "(make-hook 'name)", 1, H_start_hook);
-#endif
-
#define H_before_exit_hook S_before_exit_hook " (): called upon exit. If it returns " PROC_TRUE ", Snd does not exit."
before_exit_hook = Xen_define_hook(S_before_exit_hook, "(make-hook)", 0, H_before_exit_hook);
diff --git a/snd-motif.c b/snd-motif.c
index dfa6405..591ee06 100644
--- a/snd-motif.c
+++ b/snd-motif.c
@@ -13,6 +13,30 @@
#endif
+/* In case of X error that simply exits without any stack trace, first
+ *
+ * XSynchronize(dpy, true);
+ * XSync(dpy, true);
+ *
+ * around line 30817 (where ss->mainapp gets set)
+ * then if still trouble, make an X error handler:
+ *
+ * static XErrorHandler old_handler = (XErrorHandler) 0;
+ * static int ApplicationErrorHandler(Display *display, XErrorEvent *theEvent)
+ * {
+ * (void) fprintf(stderr, "Xlib error: error code %d request code %d\n", theEvent->error_code, theEvent->request_code);
+ * abort();
+ * return 0;
+ * }
+ *
+ * and at the same point as before
+ *
+ * old_handler = XSetErrorHandler(ApplicationErrorHandler);
+ *
+ * code 8 seems to mean a newly created window is unhappy (tooltip for example)
+ */
+
+
static XmRenderTable get_xm_font(XFontStruct *ignore, const char *font, const char *tag)
{
XmRendition tmp;
@@ -9389,12 +9413,12 @@ static void file_change_directory_callback(Widget w, XtPointer context, XtPointe
{
/* save current directory list position */
position_t position = 0;
- XmString *strs;
+ XmString *strs = NULL;
XtVaGetValues(w,
XmNtopItemPosition, &position,
XmNselectedItems, &strs,
NULL);
- if (position > 1) /* 1 = .. */
+ if ((strs) && (position > 1)) /* 1 = .. */
{
char *filename = NULL;
filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
@@ -9436,13 +9460,13 @@ static void sort_files_and_redisplay(file_pattern_info *fp)
char *selected_filename = NULL;
{
- XmString *strs;
+ XmString *strs = NULL;
int selections = 0;
XtVaGetValues(XmFileSelectionBoxGetChild(fp->dialog, XmDIALOG_LIST),
XmNselectedItems, &strs,
XmNselectedItemCount, &selections,
NULL);
- if ((selections > 0) && (strs[0]))
+ if ((selections > 0) && (strs) && (strs[0]))
selected_filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
}
@@ -9790,24 +9814,25 @@ static bool is_plausible_sound_file(const char *name)
static void file_dialog_select_callback(Widget w, XtPointer context, XtPointer info)
{
file_dialog_info *fd = (file_dialog_info *)context;
- XmString *strs;
- char *filename = NULL;
+ XmString *strs = NULL;
XtVaGetValues(w, XmNselectedItems, &strs, NULL);
- filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
- if (filename)
+ if (strs) /* can be null if click in empty space */
{
- if (is_plausible_sound_file(filename)) /* forces header read to avoid later unwanted error possibility */
- post_file_info(fd, filename);
- XtFree(filename);
- }
- else unpost_file_info(fd);
+ char *filename;
+ position_t position = 0;
+ filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
+ if (filename)
+ {
+ if (is_plausible_sound_file(filename)) /* forces header read to avoid later unwanted error possibility */
+ post_file_info(fd, filename);
+ XtFree(filename);
+ }
+ else unpost_file_info(fd);
- {
- /* save current list position */
- position_t position = 0;
- XtVaGetValues(w, XmNtopItemPosition, &position, NULL);
- dirpos_update(fd->fp->dir_list, fd->fp->current_files->dir_name, position);
- }
+ /* save current list position */
+ XtVaGetValues(w, XmNtopItemPosition, &position, NULL);
+ dirpos_update(fd->fp->dir_list, fd->fp->current_files->dir_name, position);
+ }
}
@@ -11832,18 +11857,21 @@ static void save_as_dialog_select_callback(Widget w, XtPointer context, XtPointe
{
#if WITH_AUDIO
dialog_play_info *dp = (dialog_play_info *)context;
- char *filename = NULL;
- XmString *strs;
+ XmString *strs = NULL;
XtVaGetValues(w, XmNselectedItems, &strs, NULL);
- filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
- if ((filename) && (is_sound_file(filename)))
- XtManageChild(dp->play_button);
- else
+ if (strs)
{
- if (XtIsManaged(dp->play_button))
- XtUnmanageChild(dp->play_button);
+ char *filename;
+ filename = (char *)XmStringUnparse(strs[0], NULL, XmCHARSET_TEXT, XmCHARSET_TEXT, NULL, 0, XmOUTPUT_ALL);
+ if ((filename) && (is_sound_file(filename)))
+ XtManageChild(dp->play_button);
+ else
+ {
+ if (XtIsManaged(dp->play_button))
+ XtUnmanageChild(dp->play_button);
+ }
+ if (filename) XtFree(filename);
}
- if (filename) XtFree(filename);
#endif
}
@@ -22137,21 +22165,27 @@ void post_lisp_popup_menu(void *e) {}
/* ---------------- tooltips ---------------- */
static Widget tooltip_shell = NULL;
-static Widget tooltip_label = NULL;
+#if (!HAVE_GL)
+ static Widget tooltip_label = NULL;
+#endif
static timeout_result_t tool_proc = 0, quit_proc = 0;
static Time tool_last_time = 0;
static Position tool_x, tool_y;
static Widget tool_w;
+#if (!HAVE_GL)
static void leave_tooltip(XtPointer tooltip, XtIntervalId *id)
{
XtUnmanageChild(tooltip_shell);
quit_proc = 0;
}
-
+#endif
static void handle_tooltip(XtPointer tooltip, XtIntervalId *id)
{
+#if (!HAVE_GL)
+ /* if GL, we get a segfault here -- I don't know why */
+
char *tip = (char *)tooltip;
Position rx, ry;
XmString str;
@@ -22175,6 +22209,7 @@ static void handle_tooltip(XtPointer tooltip, XtIntervalId *id)
XtVaSetValues(tooltip_shell, XmNx, rx, XmNy, ry, NULL);
XtManageChild(tooltip_shell);
quit_proc = XtAppAddTimeOut(MAIN_APP(ss), (unsigned long)10000, (XtTimerCallbackProc)leave_tooltip, NULL);
+#endif
}
@@ -23678,13 +23713,16 @@ static void motif_listener_completion(Widget w, XEvent *event, char **str, Cardi
if ((completions_pane) &&
(XtIsManaged(completions_pane)))
{
- XmString *strs;
+ XmString *strs = NULL;
XtVaGetValues(completions_list,
XmNselectedItems, &strs,
NULL);
- perform_completion(strs[0]);
- XtUnmanageChild(completions_pane);
- return;
+ if (strs)
+ {
+ perform_completion(strs[0]);
+ XtUnmanageChild(completions_pane);
+ return;
+ }
}
end = XmTextGetInsertionPosition(w);
@@ -24226,12 +24264,15 @@ static void Listener_Return(Widget w, XEvent *event, char **str, Cardinal *num)
if ((completions_pane) &&
(XtIsManaged(completions_pane)))
{
- XmString *strs;
+ XmString *strs = NULL;
XtVaGetValues(completions_list,
XmNselectedItems, &strs,
NULL);
- perform_completion(strs[0]);
- XtUnmanageChild(completions_pane);
+ if (strs)
+ {
+ perform_completion(strs[0]);
+ XtUnmanageChild(completions_pane);
+ }
}
else XtCallActionProc(w, "activate", event, str, *num);
}
diff --git a/snd-motif.scm b/snd-motif.scm
index 81a00c0..a8e5b52 100644
--- a/snd-motif.scm
+++ b/snd-motif.scm
@@ -37,10 +37,10 @@
(with-let *motif*
- (define (find-if pred l)
- (cond ((null? l) #f)
- ((pred (car l)) (car l))
- (else (find-if pred (cdr l)))))
+ (define (find-if pred lst)
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (find-if pred (cdr lst)))))
(define load-font
(let ((documentation "(load-font name) loads the font 'name', returning the font id"))
@@ -78,9 +78,7 @@
(do ((i 0 (+ i 1)))
((= i len) new-str)
(let ((c (str i)))
- (if (memq c '(#\\ #\/))
- (set! (new-str i) #\_)
- (set! (new-str i) c))))))))
+ (set! (new-str i) (if (memq c '(#\\ #\/)) #\_ c))))))))
;;; -------- apply func to every widget belonging to w (and w) --------
@@ -112,19 +110,18 @@
(define display-widget-tree
(let ((documentation "(display-widget-tree widget) displays the hierarchy of widgets beneath 'widget'"))
(lambda (widget)
- (define (display-widget w spaces)
+ (let display-widget ((w widget)
+ (spaces ""))
(let ((name (XtName w)))
(if (or (not (string? name))
- (= (length name) 0))
+ (string=? name ""))
(set! name "<unnamed>"))
- (format #t "~A~A~%" spaces name)
+ (format () "~A~A~%" spaces name)
(if (XtIsComposite w)
- (for-each
- (lambda (n)
- (display-widget n (string-append spaces " ")))
- (cadr (XtGetValues w (list XmNchildren 0) 1))))))
- (display-widget widget ""))))
-
+ (for-each (lambda (n)
+ (display-widget n (string-append spaces " ")))
+ (cadr (XtGetValues w (list XmNchildren 0) 1)))))))))
+
(define set-main-color-of-widget
(let ((documentation "(set-main-color-of-widget w) sets the background color of widget 'w'"))
(lambda (w)
@@ -132,9 +129,7 @@
w
(lambda (n)
(if (XtIsWidget n)
- (if (XmIsScrollBar n)
- (XmChangeColor n *position-color*)
- (XmChangeColor n *basic-color*))))))))
+ (XmChangeColor n (if (XmIsScrollBar n) *position-color* *basic-color*))))))))
(define host-name
(let ((documentation "(host-name) -> name of current machine"))
@@ -206,13 +201,11 @@
(lambda (n)
(XmStringGenerate
n #f XmCHARSET_TEXT
- (if (= (channels n) 1)
- "one"
- (if (= (channels n) 2)
- "two"
- (if (= (channels n) 4)
- "four"
- "three")))))
+ (case (channels n)
+ ((1) "one")
+ ((2) "two")
+ ((3) "three")
+ (else "four"))))
files)))
(XtSetValues widget
(list XmNfileListItems fileTable
@@ -241,7 +234,7 @@
(lambda (widget context info)
;; same as built-in "ok" callback, but does not "unmanage" the dialog
(let ((filename (XmStringUnparse (.value info) #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (format #t "filename: ~A~%" filename)
+ (format () "filename: ~A~%" filename)
(if (file-exists? filename)
(if (not (directory? filename))
@@ -651,22 +644,15 @@
(let ((documentation "(make-pixmap w strs) creates a pixmap using the X/Xpm string-based pixmap description"))
(lambda (widget strs) ; strs is list of strings as in arrow-strs above
(and (defined? 'XpmAttributes)
- (let* ((attr (XpmAttributes))
- (symb (XpmColorSymbol "basiccolor" #f *basic-color*))
- (dpy (XtDisplay widget))
- (win (XtWindow widget))
- (scr (DefaultScreen dpy))
- (depth (cadr (XtGetValues widget (list XmNdepth 0))))
- (colormap (cadr (XtGetValues widget (list XmNcolormap 0)))))
- (set! (.depth attr) depth)
- (set! (.colormap attr) colormap)
- (set! (.visual attr) (DefaultVisual dpy scr))
- (set! (.colorsymbols attr) (list symb))
+ (let ((attr (XpmAttributes))
+ (dpy (XtDisplay widget)))
+ (set! (.depth attr) (cadr (XtGetValues widget (list XmNdepth 0))))
+ (set! (.colormap attr) (cadr (XtGetValues widget (list XmNcolormap 0))))
+ (set! (.visual attr) (DefaultVisual dpy (DefaultScreen dpy)))
+ (set! (.colorsymbols attr) (list (XpmColorSymbol "basiccolor" #f *basic-color*)))
(set! (.numsymbols attr) 1)
(set! (.valuemask attr) (logior XpmColorSymbols XpmDepth XpmColormap XpmVisual))
- (cadr (XpmCreatePixmapFromData dpy win strs attr)))))))
-
- ; (XtSetValues ((sound-widgets) 8) (list XmNlabelPixmap (make-pixmap (cadr (main-widgets)) arrow-strs))))
+ (cadr (XpmCreatePixmapFromData dpy (XtWindow widget) strs attr)))))))
;;; if you have a nice background pixmap, you can map it over all of Snd with:
#|
@@ -1041,9 +1027,7 @@
(let ((mark-lists ()))
(dilambda
(lambda (snd chn)
- (let ((dat (find-mark-list snd chn mark-lists)))
- (and dat
- (caddr dat))))
+ (cond ((find-mark-list snd chn mark-lists) => caddr) (else #f)))
(lambda (snd chn wid)
(set! mark-lists (cons (list snd chn wid) mark-lists))))))
@@ -1087,30 +1071,30 @@
(set! (mark-list snd chn) (list snd chn mlist))))
(let ((new-marks (marks snd chn)))
- (if (> (length new-marks) current-mark-list-length)
- (let ((lst (mark-list snd chn)))
- (do ((i current-mark-list-length (+ i 1)))
- ((= i (length new-marks)))
- (let ((tf (XtCreateWidget "field" xmTextFieldWidgetClass lst
- (list XmNbackground *basic-color*))))
- (XtAddCallback tf XmNfocusCallback
- (lambda (w c i)
- (XtSetValues w (list XmNbackground (white-pixel)))))
- (XtAddCallback tf XmNlosingFocusCallback
- (lambda (w c i)
- (XtSetValues w (list XmNbackground *basic-color*))))
- (XtAddCallback tf XmNactivateCallback
- (lambda (w c i)
- (let* ((id (integer->mark (cadr (XtGetValues w (list XmNuserData 0)))))
- (txt (cadr (XtGetValues w (list XmNvalue 0))))
- (samp (and (string? txt)
- (> (length txt) 0)
- (string->number txt))))
- (if samp
- (if (mark? id)
- (set! (mark-sample id) samp))
- (delete-mark id))
- (XtSetValues w (list XmNbackground *basic-color*)))))))))
+ (when (> (length new-marks) current-mark-list-length)
+ (let ((lst (mark-list snd chn)))
+ (do ((i current-mark-list-length (+ i 1)))
+ ((= i (length new-marks)))
+ (let ((tf (XtCreateWidget "field" xmTextFieldWidgetClass lst
+ (list XmNbackground *basic-color*))))
+ (XtAddCallback tf XmNfocusCallback
+ (lambda (w c i)
+ (XtSetValues w (list XmNbackground (white-pixel)))))
+ (XtAddCallback tf XmNlosingFocusCallback
+ (lambda (w c i)
+ (XtSetValues w (list XmNbackground *basic-color*))))
+ (XtAddCallback tf XmNactivateCallback
+ (lambda (w c i)
+ (let* ((id (integer->mark (cadr (XtGetValues w (list XmNuserData 0)))))
+ (txt (cadr (XtGetValues w (list XmNvalue 0))))
+ (samp (and (string? txt)
+ (> (length txt) 0)
+ (string->number txt))))
+ (if samp
+ (if (mark? id)
+ (set! (mark-sample id) samp))
+ (delete-mark id))
+ (XtSetValues w (list XmNbackground *basic-color*)))))))))
(set! (mark-list-length snd chn) (length new-marks))
(let ((lst (mark-list snd chn)))
@@ -1185,19 +1169,23 @@
;; (list (list widget inuse func title help) ...)
(define (find-free-dialog ds)
(and (pair? ds)
- (if (not (cadr (car ds)))
+ (pair? (car ds))
+ (pair? (cdar ds))
+ (if (cadar ds)
+ (find-free-dialog (cdr ds))
(begin
(set! ((car ds) 1) #t)
- (caar ds))
- (find-free-dialog (cdr ds)))))
+ (caar ds)))))
+
(define (find-dialog-widget wid ds)
(and (pair? ds)
+ (pair? (car ds))
(if (equal? wid (caar ds))
(car ds)
(find-dialog-widget wid (cdr ds)))))
(lambda args
;; (file-select func title dir filter help)
- (let* ((func (and (> (length args) 0) (args 0)))
+ (let* ((func (and (pair? args) (args 0)))
(title (if (> (length args) 1) (args 1) "select file"))
(dir (if (> (length args) 2) (args 2) "."))
(filter (if (> (length args) 3) (args 3) "*"))
@@ -1239,14 +1227,14 @@
(if (not help)
(XtUnmanageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))
(XtManageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON)))
- (let ((dirstr (XmStringCreateLocalized dir))
- (patstr (XmStringCreateLocalized filter))
+ (let ((patstr (XmStringCreateLocalized filter))
(titlestr (XmStringCreateLocalized title)))
- (XtSetValues dialog
- (list XmNdirectory dirstr
- XmNpattern patstr
- XmNdialogTitle titlestr))
- (XmStringFree dirstr)
+ (let ((dirstr (XmStringCreateLocalized dir)))
+ (XtSetValues dialog
+ (list XmNdirectory dirstr
+ XmNpattern patstr
+ XmNdialogTitle titlestr))
+ (XmStringFree dirstr))
(XmStringFree patstr)
(XmStringFree titlestr)
(XtManageChild dialog))))))
@@ -1275,9 +1263,9 @@
(XSetForeground dpy dgc *basic-color*)
(XFillRectangle dpy pixwin dgc 0 0 16 16)
(XSetForeground dpy dgc (white-pixel))
- (XFillArc dpy pixwin dgc 1 1 14 14 0 (* 64 360))
+ (XFillArc dpy pixwin dgc 1 1 14 14 0 23040) ; (* 64 360))
(XSetForeground dpy dgc (black-pixel))
- (XDrawArc dpy pixwin dgc 1 1 14 14 0 (* 64 360))
+ (XDrawArc dpy pixwin dgc 1 1 14 14 0 23040) ; (* 64 360))
(XDrawLine dpy pixwin dgc 8 8
(+ 8 (round (* 7 (sin (* i (/ 3.1416 6.0))))))
(- 8 (round (* 7 (cos (* i (/ 3.1416 6.0)))))))))
@@ -1309,14 +1297,17 @@
(bottom-margin 6)
(left-margin 2)
(right-margin 2)
- (ay1 top-margin)
- (ay0 (- height bottom-margin))
(range (/ (- height top-margin bottom-margin) 2)))
- (define (y->grfy y height)
- (min ay0
- (max ay1
- (round (+ ay1
- (* height (- 1.0 y)))))))
+
+ (define y->grfy
+ (let ((ay1 top-margin)
+ (ay0 (- height bottom-margin)))
+ (lambda (y height)
+ (min ay0
+ (max ay1
+ (round (+ ay1
+ (* height (- 1.0 y)))))))))
+
(let* ((ly (y->grfy (pts 0) range))
(lx left-margin)
(len (length pts))
@@ -1367,16 +1358,14 @@
(dilambda
(lambda (data) (data 3))
(lambda (data val) (set! (data 3) val))))
- #|
+#|
(define (sound-button-data button)
- (define (sb-data lst)
- (if (null? lst)
- #f
- (if (equal? button (sound-button (car lst)))
- (car lst)
- (sb-data (cdr lst)))))
+ (define (sb-data lst)
+ (if (null? lst) #f
+ (if (equal? button (sound-button (car lst))) (car lst)
+ (sb-data (cdr lst)))))
(sb-data sound-buttons))
- |#
+|#
(define (make-sound-button-pixmap dpy wn data width height)
(if (pair? (sound-button-peaks data))
(let ((mins (car (sound-button-peaks data)))
@@ -1730,7 +1719,7 @@
(define make-channel-drop-site
(let ((documentation "(make-channel-drop-site snd) adds a drop site pane to the current channel"))
(lambda args
- (let* ((snd (if (> (length args) 0) (car args) (selected-sound)))
+ (let* ((snd (if (pair? args) (car args) (selected-sound)))
(chn (selected-channel snd))
(widget (add-channel-pane snd chn "drop here" xmDrawingAreaWidgetClass
(list XmNbackground (white-pixel)
@@ -1746,8 +1735,8 @@
XmNdropProc
(lambda (w c i)
;; i is the callback data (XmDropProcCallbackStruct), c is always #f
- (if (or (not (= (.dropAction i) XmDROP))
- (not (= (.operation i) XmDROP_COPY)))
+ (if (not (and (= (.dropAction i) XmDROP)
+ (= (.operation i) XmDROP_COPY)))
(set! (.dropSiteStatus i) XmINVALID_DROP_SITE)
(begin
(set! (.operation i) XmDROP_COPY) ; tell system drop has succeeded
@@ -1773,8 +1762,8 @@
(car (channel-widgets snd chn))
(list XmNdropProc
(lambda (w c i)
- (if (or (not (= (.dropAction i) XmDROP))
- (not (= (.operation i) XmDROP_COPY)))
+ (if (not (and (= (.dropAction i) XmDROP)
+ (= (.operation i) XmDROP_COPY)))
(set! (.dropSiteStatus i) XmINVALID_DROP_SITE)
(begin
(set! (.operation i) XmDROP_COPY)
@@ -1802,13 +1791,11 @@
(define show-disk-space
(let ((labelled-snds ()))
(define (kmg num)
- (if (<= num 0)
- "disk full!"
- (if (> num 1024)
- (if (> num (* 1024 1024))
- (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0)))
- (format #f "space: ~6,3FM" (/ num 1024.0)))
- (format #f "space: ~10DK" num))))
+ (cond ((<= num 0) "disk full!")
+ ((<= num 1024) (format #f "space: ~10DK" num))
+ ((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0))))
+ (else (format #f "space: ~6,3FM" (/ num 1024.0)))))
+
(define (show-label data id)
(if (sound? (car data))
(let* ((space (kmg (disk-kspace (file-name (car data)))))
@@ -1821,35 +1808,35 @@
(lambda (hook)
(let* ((snd (hook 'snd))
(previous-label (find-if (lambda (n) (equal? (car n) snd)) labelled-snds)))
- (if (not previous-label)
- (if (not snd)
- (snd-error "no sound found for disk space label")
- (let* ((app (car (main-widgets)))
- (widgets (sound-widgets snd))
- (status-area (widgets 3))
- (unite-button (widgets 6))
- (sync-button (widgets 9))
- (name-form (XtParent status-area)) ; "snd-name-form"
- (space (kmg (disk-kspace (file-name snd))))
- (str (XmStringCreateLocalized space)))
- (set! showing-disk-space #t)
- (XtUnmanageChild status-area)
- (XtVaSetValues status-area (list XmNrightAttachment XmATTACH_NONE))
- (let ((new-label (XtCreateManagedWidget "space:" xmLabelWidgetClass name-form
- (list XmNbackground *basic-color*
- XmNleftAttachment XmATTACH_NONE
- XmNlabelString str
- XmNrightAttachment XmATTACH_WIDGET
- XmNrightWidget (if (XtIsManaged unite-button)
- unite-button
- sync-button)
- XmNtopAttachment XmATTACH_FORM))))
- (XtVaSetValues status-area (list XmNrightWidget new-label XmNrightAttachment XmATTACH_WIDGET))
- (XtManageChild status-area)
- (XmStringFree str)
- (set! previous-label (list snd new-label app))
- (set! labelled-snds (cons previous-label labelled-snds))
- (XtAppAddTimeOut (caddr previous-label) 10000 show-label previous-label))))))))))
+ (unless previous-label
+ (if (not snd)
+ (snd-error "no sound found for disk space label")
+ (let* ((app (car (main-widgets)))
+ (widgets (sound-widgets snd))
+ (status-area (widgets 3))
+ (unite-button (widgets 6))
+ (sync-button (widgets 9))
+ (name-form (XtParent status-area)) ; "snd-name-form"
+ (space (kmg (disk-kspace (file-name snd))))
+ (str (XmStringCreateLocalized space)))
+ (set! showing-disk-space #t)
+ (XtUnmanageChild status-area)
+ (XtVaSetValues status-area (list XmNrightAttachment XmATTACH_NONE))
+ (let ((new-label (XtCreateManagedWidget "space:" xmLabelWidgetClass name-form
+ (list XmNbackground *basic-color*
+ XmNleftAttachment XmATTACH_NONE
+ XmNlabelString str
+ XmNrightAttachment XmATTACH_WIDGET
+ XmNrightWidget (if (XtIsManaged unite-button)
+ unite-button
+ sync-button)
+ XmNtopAttachment XmATTACH_FORM))))
+ (XtVaSetValues status-area (list XmNrightWidget new-label XmNrightAttachment XmATTACH_WIDGET))
+ (XtManageChild status-area)
+ (XmStringFree str)
+ (set! previous-label (list snd new-label app))
+ (set! labelled-snds (cons previous-label labelled-snds))
+ (XtAppAddTimeOut (caddr previous-label) 10000 show-label previous-label))))))))))
@@ -1867,24 +1854,14 @@
(define (number-name chan) (if (= chan 0) "amp-number" (format #f "amp-number-~D" chan)))
(define (scroller-name chan) (if (= chan 0) "amp" (format #f "amp-~D" chan)))
- (define (amp->scroll minval val maxval)
- (if (<= val minval) 0
- (if (>= val maxval) 9000
- (if (>= val 1.0)
- (floor (* 4500 (+ 1.0 (/ (- val 1.0) (- maxval 1.0)))))
- (floor (* 4500 (/ (- val minval) (- 1.0 minval))))))))
-
- (define (scroll->amp snd val)
- (if (<= val 0)
- (car (amp-control-bounds snd))
- (if (>= val 9000)
- (cadr (amp-control-bounds snd))
- (if (> val 4500)
- (+ (* (- (/ val 4500.0) 1.0) (- (cadr (amp-control-bounds snd)) 1.0)) 1.0)
- (+ (* val (/ (- 1.0 (car (amp-control-bounds snd))) 4500.0)) (car (amp-control-bounds snd)))))))
-
(define (amp-callback w c info)
;; c is (list number-widget snd chan)
+ (define (scroll->amp snd val)
+ (cond ((<= val 0) (car (amp-control-bounds snd)))
+ ((>= val 9000) (cadr (amp-control-bounds snd)))
+ ((> val 4500) (+ (* (- (/ val 4500.0) 1.0) (- (cadr (amp-control-bounds snd)) 1.0)) 1.0))
+ (else (+ (* val (/ (- 1.0 (car (amp-control-bounds snd))) 4500.0)) (car (amp-control-bounds snd))))))
+
(let* ((snd (cadr c))
(amp (scroll->amp snd (.value info)))
(ampstr (XmStringCreateLocalized (format #f "~,3F " amp)))
@@ -1912,123 +1889,124 @@
(XtSetValues number (list XmNlabelString ampstr))
(XmStringFree ampstr)))
- (define (make-amp-control snd chan parent)
- (let* ((s1 (XmStringCreateLocalized "amp:"))
- (label (XtCreateManagedWidget (label-name chan) xmPushButtonWidgetClass parent
- (list XmNbackground *basic-color*
- XmNalignment XmALIGNMENT_BEGINNING
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNlabelString s1
- XmNmarginHeight 1
- XmNrecomputeSize #f
- XmNshadowThickness 0
- XmNhighlightThickness 0
- XmNfillOnArm #f)))
- (s2 (XmStringCreateLocalized "1.000 "))
- (number (XtCreateManagedWidget (number-name chan) xmLabelWidgetClass parent
- (list XmNbackground *basic-color*
- XmNalignment XmALIGNMENT_BEGINNING
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget label
- XmNbottomAttachment XmATTACH_NONE
- XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget label
- XmNrightAttachment XmATTACH_NONE
- XmNlabelString s2
- XmNmarginHeight 1
- XmNmarginRight 3
- XmNrecomputeSize #f)))
- (scroll (XtCreateManagedWidget (scroller-name chan) xmScrollBarWidgetClass parent
- (list XmNbackground *position-color*
- XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
- XmNtopWidget label
- XmNbottomAttachment XmATTACH_NONE
- XmNheight 16
- XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget number
- XmNrightAttachment XmATTACH_FORM
- XmNorientation XmHORIZONTAL
- XmNmaximum 10000
- XmNvalue 4500
- XmNdragCallback (list amp-callback (list number snd chan))
- XmNvalueChangedCallback (list amp-callback (list number snd chan))))))
- (XtOverrideTranslations scroll
- (XtParseTranslationTable "c<Btn1Down>: Select()
+ (define (amp-controls-reflect-chans snd)
+
+ (define (make-amp-control snd chan parent)
+ (let* ((s1 (XmStringCreateLocalized "amp:"))
+ (label (XtCreateManagedWidget (label-name chan) xmPushButtonWidgetClass parent
+ (list XmNbackground *basic-color*
+ XmNalignment XmALIGNMENT_BEGINNING
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNlabelString s1
+ XmNmarginHeight 1
+ XmNrecomputeSize #f
+ XmNshadowThickness 0
+ XmNhighlightThickness 0
+ XmNfillOnArm #f)))
+ (s2 (XmStringCreateLocalized "1.000 ")))
+ (let* ((number (XtCreateManagedWidget (number-name chan) xmLabelWidgetClass parent
+ (list XmNbackground *basic-color*
+ XmNalignment XmALIGNMENT_BEGINNING
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget label
+ XmNbottomAttachment XmATTACH_NONE
+ XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget label
+ XmNrightAttachment XmATTACH_NONE
+ XmNlabelString s2
+ XmNmarginHeight 1
+ XmNmarginRight 3
+ XmNrecomputeSize #f)))
+ (scroll (XtCreateManagedWidget (scroller-name chan) xmScrollBarWidgetClass parent
+ (list XmNbackground *position-color*
+ XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
+ XmNtopWidget label
+ XmNbottomAttachment XmATTACH_NONE
+ XmNheight 16
+ XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget number
+ XmNrightAttachment XmATTACH_FORM
+ XmNorientation XmHORIZONTAL
+ XmNmaximum 10000
+ XmNvalue 4500
+ XmNdragCallback (list amp-callback (list number snd chan))
+ XmNvalueChangedCallback (list amp-callback (list number snd chan))))))
+ (XtOverrideTranslations scroll
+ (XtParseTranslationTable "c<Btn1Down>: Select()
c<Btn1Motion>: Moved()
c<Btn1Up>: Release()"))
-
- (XtAddCallback label XmNactivateCallback (lambda (w c i)
- (reset-to-one scroll number)))
- (XmStringFree s1)
- (XmStringFree s2)
- label))
-
- (define (amp-controls-reflect-chans snd)
+
+ (XtAddCallback label XmNactivateCallback (lambda (w c i)
+ (reset-to-one scroll number))))
+ (XmStringFree s1)
+ (XmStringFree s2)
+ label))
+
(let* ((wids (sound-widgets snd))
(ctrls (wids 2))
(snd-amp (find-child ctrls "snd-amp"))
(chns (channels snd)))
- (if (Widget? snd-amp)
- (let ((height (cadr (XtGetValues ctrls (list XmNheight 0))))
- (panemin (cadr (XtGetValues ctrls (list XmNpaneMinimum 0))))
- (panemax (cadr (XtGetValues ctrls (list XmNpaneMaximum 0)))))
- (XtUnmanageChild ctrls)
-
- (if (not (sound-property 'amp-controls snd))
- (let ((orig-amp (find-child snd-amp "amp")))
- (XtOverrideTranslations orig-amp
- (XtParseTranslationTable "c<Btn1Down>: Select()
+ (when (Widget? snd-amp)
+ (let ((height (cadr (XtGetValues ctrls (list XmNheight 0))))
+ (panemin (cadr (XtGetValues ctrls (list XmNpaneMinimum 0))))
+ (panemax (cadr (XtGetValues ctrls (list XmNpaneMaximum 0)))))
+ (XtUnmanageChild ctrls)
+
+ (if (not (sound-property 'amp-controls snd))
+ (let ((orig-amp (find-child snd-amp "amp")))
+ (XtOverrideTranslations orig-amp
+ (XtParseTranslationTable "c<Btn1Down>: Select()
c<Btn1Motion>: Moved()
c<Btn1Up>: Release()"))
- (XtAddCallback orig-amp XmNdragCallback
- (lambda (w c info)
- (if (and (.event info) (not (= (logand (.state (.event info)) ControlMask) 0)))
- (do ((i 1 (+ i 1)))
- ((= i chns))
- (let* ((ampscr (find-child snd-amp (scroller-name i)))
- (ampvals (XmScrollBarGetValues ampscr)))
- (XmScrollBarSetValues ampscr (.value info) (cadr ampvals) (caddr ampvals) (cadddr ampvals) #t))))))))
- (let ((existing-controls (or (sound-property 'amp-controls snd) 1)))
- (if (< existing-controls chns)
- (begin
- (if (> height 20)
- (set! height (+ height (* 18 (- chns existing-controls)))))
- (do ((i existing-controls (+ i 1)))
- ((= i chns))
- (make-amp-control snd i snd-amp))
- (set! (sound-property 'amp-controls snd) chns)
- (set! existing-controls chns)))
- (do ((i 0 (+ i 1)))
- ((= i existing-controls))
- (let ((ampc (find-child snd-amp (label-name i)))
- (ampn (find-child snd-amp (number-name i)))
- (amp (find-child snd-amp (scroller-name i))))
- (XtUnmanageChild ampc)
- (XtUnmanageChild ampn)
- (XtUnmanageChild amp)))
- (do ((i 0 (+ i 1)))
- ((= i chns))
- (let ((ampc (find-child snd-amp (label-name i)))
- (ampn (find-child snd-amp (number-name i)))
- (amp (find-child snd-amp (scroller-name i)))
- (next-amp (and (< i (- chns 1))
+ (XtAddCallback orig-amp XmNdragCallback
+ (lambda (w c info)
+ (if (and (.event info) (not (= (logand (.state (.event info)) ControlMask) 0)))
+ (do ((i 1 (+ i 1)))
+ ((= i chns))
+ (let* ((ampscr (find-child snd-amp (scroller-name i)))
+ (ampvals (XmScrollBarGetValues ampscr)))
+ (XmScrollBarSetValues ampscr (.value info) (cadr ampvals) (caddr ampvals) (cadddr ampvals) #t))))))))
+ (let ((existing-controls (or (sound-property 'amp-controls snd) 1)))
+ (if (< existing-controls chns)
+ (begin
+ (if (> height 20)
+ (set! height (+ height (* 18 (- chns existing-controls)))))
+ (do ((i existing-controls (+ i 1)))
+ ((= i chns))
+ (make-amp-control snd i snd-amp))
+ (set! (sound-property 'amp-controls snd) chns)
+ (set! existing-controls chns)))
+ (do ((i 0 (+ i 1)))
+ ((= i existing-controls))
+ (let ((ampc (find-child snd-amp (label-name i)))
+ (ampn (find-child snd-amp (number-name i)))
+ (amp (find-child snd-amp (scroller-name i))))
+ (XtUnmanageChild ampc)
+ (XtUnmanageChild ampn)
+ (XtUnmanageChild amp)))
+ (do ((i 0 (+ i 1)))
+ ((= i chns))
+ (let ((ampc (find-child snd-amp (label-name i)))
+ (ampn (find-child snd-amp (number-name i)))
+ (amp (find-child snd-amp (scroller-name i))))
+ (let ((next-amp (and (< i (- chns 1))
(find-child snd-amp (label-name (+ i 1))))))
(reset-to-one amp ampn)
- (if next-amp
- (XtSetValues ampc (list XmNtopAttachment XmATTACH_WIDGET
- XmNtopWidget next-amp))
- (XtSetValues ampc (list XmNtopAttachment XmATTACH_FORM)))
- (XtManageChild ampc)
- (XtManageChild ampn)
- (XtManageChild amp))))
-
- (XtSetValues ctrls (list XmNpaneMinimum height XmNpaneMaximum height))
- (XtManageChild ctrls)
- (XtSetValues ctrls (list XmNpaneMinimum panemin XmNpaneMaximum panemax))))))
+ (XtSetValues ampc (if next-amp
+ (list XmNtopAttachment XmATTACH_WIDGET
+ XmNtopWidget next-amp)
+ (list XmNtopAttachment XmATTACH_FORM))))
+ (XtManageChild ampc)
+ (XtManageChild ampn)
+ (XtManageChild amp))))
+
+ (XtSetValues ctrls (list XmNpaneMinimum height XmNpaneMaximum height))
+ (XtManageChild ctrls)
+ (XtSetValues ctrls (list XmNpaneMinimum panemin XmNpaneMaximum panemax))))))
(define (amp-controls-clear snd)
(if (> (channels snd) 1)
@@ -2046,7 +2024,6 @@
(hook-push after-open-hook (lambda (hook) (amp-controls-reflect-chans (hook 'snd))))
(hook-push after-apply-controls-hook (lambda (hook) (amp-controls-clear (hook 'snd)))))))
- ;(add-amp-controls)
;;; -------- remove top level menu
@@ -2084,88 +2061,84 @@
(add-to-menu 0 "Rename"
(lambda ()
;; open dialog to get new name, save-as that name, open
- (if (not rename-dialog)
- ;; make a standard dialog
- (let* ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "Rename" XmFONTLIST_DEFAULT_TAG))
- (new-dialog (XmCreateTemplateDialog
- (cadr (main-widgets)) "Rename"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNokLabelString xok
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNbackground *basic-color*
- XmNtransient #f))))
- (for-each
- (lambda (button color)
- (XtVaSetValues
- (XmMessageBoxGetChild new-dialog button)
- (list XmNarmColor *selection-color*
- XmNbackground color)))
- (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
- (list *highlight-color* *highlight-color* *highlight-color*))
-
- (XtAddCallback new-dialog XmNcancelCallback
- (lambda (w c i) (XtUnmanageChild w)))
-
- (XtAddCallback new-dialog XmNhelpCallback
- (lambda (w c i)
- (help-dialog "Rename" "give a new file name to rename the currently selected sound")))
-
- (XtAddCallback new-dialog XmNokCallback
- (lambda (w c i)
- (let ((new-name (XmTextFieldGetString rename-text)))
- (if (and (string? new-name)
- (> (length new-name) 0)
- (selected-sound))
- (let ();(current-name (file-name)))
- (save-sound-as new-name)
- (close-sound)
+ (unless rename-dialog
+ ;; make a standard dialog
+ (let* ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "Rename" XmFONTLIST_DEFAULT_TAG))
+ (new-dialog (XmCreateTemplateDialog
+ (cadr (main-widgets)) "Rename"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNokLabelString xok
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNbackground *basic-color*
+ XmNtransient #f))))
+ (for-each
+ (lambda (button color)
+ (XtVaSetValues
+ (XmMessageBoxGetChild new-dialog button)
+ (list XmNarmColor *selection-color*
+ XmNbackground color)))
+ (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
+ (list *highlight-color* *highlight-color* *highlight-color*))
+
+ (XtAddCallback new-dialog XmNcancelCallback
+ (lambda (w c i) (XtUnmanageChild w)))
+
+ (XtAddCallback new-dialog XmNhelpCallback
+ (lambda (w c i)
+ (help-dialog "Rename" "give a new file name to rename the currently selected sound")))
+
+ (XtAddCallback new-dialog XmNokCallback
+ (lambda (w c i)
+ (let ((new-name (XmTextFieldGetString rename-text)))
+ (if (and (string? new-name)
+ (> (length new-name) 0)
+ (selected-sound))
+ (let ();(current-name (file-name)))
+ (save-sound-as new-name)
+ (close-sound)
;(rename-file current-name new-name) ; was this from Guile?
;(system (format #f "mv ~A ~A" new-name current-name)) ; surely it should be (delete-file current-name)?
- (open-sound new-name)
- (XtUnmanageChild w))))))
-
- (XmStringFree xhelp)
- (XmStringFree xok)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
- (set! rename-dialog new-dialog)
-
- (let* ((mainform (XtCreateManagedWidget "formd" xmRowColumnWidgetClass rename-dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild rename-dialog XmDIALOG_SEPARATOR)
- XmNorientation XmVERTICAL
- XmNbackground *basic-color*)))
- (label (XtCreateManagedWidget "new name:" xmLabelWidgetClass mainform
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_NONE
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*))))
- (set! rename-text
- (XtCreateManagedWidget "newname" xmTextFieldWidgetClass mainform
- (list XmNleftAttachment XmATTACH_WIDGET
- XmNleftWidget label
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_FORM
- XmNbackground *basic-color*)))
- (XtAddEventHandler rename-text EnterWindowMask #f
- (lambda (w context ev flag)
- (XmProcessTraversal w XmTRAVERSE_CURRENT)
- (XtSetValues w (list XmNbackground (white-pixel)))))
- (XtAddEventHandler rename-text LeaveWindowMask #f
- (lambda (w context ev flag)
- (XtSetValues w (list XmNbackground *basic-color*)))))))
+ (open-sound new-name)
+ (XtUnmanageChild w))))))
+ (for-each XmStringFree (vector xhelp xok xdismiss titlestr))
+ (set! rename-dialog new-dialog)
+
+ (let* ((mainform (XtCreateManagedWidget "formd" xmRowColumnWidgetClass rename-dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild rename-dialog XmDIALOG_SEPARATOR)
+ XmNorientation XmVERTICAL
+ XmNbackground *basic-color*)))
+ (label (XtCreateManagedWidget "new name:" xmLabelWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_NONE
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*))))
+ (set! rename-text
+ (XtCreateManagedWidget "newname" xmTextFieldWidgetClass mainform
+ (list XmNleftAttachment XmATTACH_WIDGET
+ XmNleftWidget label
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_FORM
+ XmNbackground *basic-color*)))
+ (XtAddEventHandler rename-text EnterWindowMask #f
+ (lambda (w context ev flag)
+ (XmProcessTraversal w XmTRAVERSE_CURRENT)
+ (XtSetValues w (list XmNbackground (white-pixel)))))
+ (XtAddEventHandler rename-text LeaveWindowMask #f
+ (lambda (w context ev flag)
+ (XtSetValues w (list XmNbackground *basic-color*)))))))
(if (not (XtIsManaged rename-dialog))
(XtManageChild rename-dialog)
(raise-dialog rename-dialog)))
@@ -2245,8 +2218,7 @@
(lambda (widget tip)
(let ((tool-proc #f)
(quit-proc #f)
- (timeout 500) ; millisecs after mouse enters widget to tip display
- (quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
+
(last-time 0)) ; try to squelch "fluttering"
(define (stop-tooltip)
@@ -2261,37 +2233,40 @@
(if (and tooltip-shell (XtIsManaged tooltip-shell))
(XtUnmanageChild tooltip-shell)))
- (define (start-tooltip ev)
- (if (and *with-tooltips*
- (not tool-proc))
- (set! tool-proc (XtAppAddTimeOut
- (car (main-widgets))
- timeout
- (lambda (data id)
- (if (not tooltip-shell)
- (begin
- (set! tooltip-shell (XtCreatePopupShell
- tip
- overrideShellWidgetClass
- (cadr (main-widgets))
- (list XmNallowShellResize #t)))
- (set! tooltip-label
- (XtCreateManagedWidget
- tip
- xmLabelWidgetClass
- tooltip-shell
- (list XmNrecomputeSize #t
- XmNbackground *highlight-color*))))
- (change-label tooltip-label tip))
- (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
- (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
- (XtManageChild tooltip-shell)
- (set! quit-proc (XtAppAddTimeOut
- (car (main-widgets))
- quittime
- (lambda (data id)
- (XtUnmanageChild tooltip-shell)
- (set! quit-proc #f)))))))))
+ (define start-tooltip
+ (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
+ (timeout 500)) ; millisecs after mouse enters widget to tip display
+ (lambda (ev)
+ (if (and *with-tooltips*
+ (not tool-proc))
+ (set! tool-proc (XtAppAddTimeOut
+ (car (main-widgets))
+ timeout
+ (lambda (data id)
+ (if tooltip-shell
+ (change-label tooltip-label tip)
+ (begin
+ (set! tooltip-shell (XtCreatePopupShell
+ tip
+ overrideShellWidgetClass
+ (cadr (main-widgets))
+ (list XmNallowShellResize #t)))
+ (set! tooltip-label
+ (XtCreateManagedWidget
+ tip
+ xmLabelWidgetClass
+ tooltip-shell
+ (list XmNrecomputeSize #t
+ XmNbackground *highlight-color*)))))
+ (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
+ (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
+ (XtManageChild tooltip-shell)
+ (set! quit-proc (XtAppAddTimeOut
+ (car (main-widgets))
+ quittime
+ (lambda (data id)
+ (XtUnmanageChild tooltip-shell)
+ (set! quit-proc #f)))))))))))
(XtAddEventHandler widget EnterWindowMask #f
(lambda (w c ev flag)
@@ -2340,7 +2315,7 @@
(while happy
(let ((name (XGetAtomName dpy (list 'Atom i))))
(if (string? name)
- (format #t "~D: ~A~%" i name)
+ (format () "~D: ~A~%" i name)
(set! happy #f)))
(set! i (+ i 1)))
(XSetErrorHandler #f)))))
@@ -2349,76 +2324,77 @@
;;; -------- enable C-s and C-r in listener
(define add-find-to-listener
- (let ((dialog #f)
- (find-text #f)
- (find-forward #t)
- (find-new #t)
+ (let ((find-forward #t)
(listener-text ((main-widgets) 4))
- (shell (cadr (main-widgets)))
(snd-app (car (main-widgets))))
(lambda ()
-
- (define (start-dialog)
- (if (not dialog)
- (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
- (set! dialog (XmCreateMessageDialog shell
- "Find"
- (list XmNcancelLabelString xdismiss
- XmNokLabelString xfind
- XmNhelpLabelString xhelp
- XmNautoUnmanage #f
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNtransient #f
- XmNbackground *basic-color*)))
- (for-each
- (lambda (button color)
- (XtVaSetValues (XmMessageBoxGetChild dialog button)
- (list XmNarmColor *selection-color*
- XmNbackground color)))
- (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
- (list *highlight-color* *highlight-color* *highlight-color*))
- (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
- (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
- (XtAddCallback dialog XmNokCallback (lambda (w context info)
- (let* ((search-str (XmTextFieldGetString find-text))
- (len (length search-str))
- (pos (XmTextFindString listener-text
- (+ (XmTextGetCursorPosition listener-text)
- (if find-new 0 (if find-forward 1 -1)))
- search-str
- (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
- (if (not pos)
- (set! pos (XmTextFindString listener-text
- (if find-forward 0 (XmTextGetLastPosition listener-text))
- search-str
- (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
- (if (number? pos)
- (begin
- (XmTextSetInsertionPosition listener-text pos)
- (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
- (XtAppAddTimeOut snd-app 200
- (lambda (context id)
- (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
- (set! find-new #f))))
- (XmStringFree xhelp)
- (XmStringFree xdismiss)
- (XmStringFree xfind)
- (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
- XmNbackground *basic-color*)))
- (XtAddCallback find-text XmNfocusCallback
- (lambda (w c i)
- (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
- (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
- (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
- (XtManageChild dialog))
+
+ (define start-dialog
+ (let ((shell (cadr (main-widgets)))
+ (dialog #f)
+ (find-new #t)
+ (find-text #f))
+ (lambda ()
+ (unless dialog
+ (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
+ (set! dialog (XmCreateMessageDialog shell
+ "Find"
+ (list XmNcancelLabelString xdismiss
+ XmNokLabelString xfind
+ XmNhelpLabelString xhelp
+ XmNautoUnmanage #f
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNtransient #f
+ XmNbackground *basic-color*)))
+ (for-each
+ (lambda (button color)
+ (XtVaSetValues (XmMessageBoxGetChild dialog button)
+ (list XmNarmColor *selection-color*
+ XmNbackground color)))
+ (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
+ (list *highlight-color* *highlight-color* *highlight-color*))
+ (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
+ (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
+ (XtAddCallback dialog XmNokCallback (lambda (w context info)
+ (let* ((search-str (XmTextFieldGetString find-text))
+ (len (length search-str))
+ (pos (XmTextFindString listener-text
+ (+ (XmTextGetCursorPosition listener-text)
+ (if find-new 0 (if find-forward 1 -1)))
+ search-str
+ (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+ (if (not pos)
+ (set! pos (XmTextFindString listener-text
+ (if find-forward 0 (XmTextGetLastPosition listener-text))
+ search-str
+ (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+ (if (number? pos)
+ (begin
+ (XmTextSetInsertionPosition listener-text pos)
+ (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
+ (XtAppAddTimeOut snd-app 200
+ (lambda (context id)
+ (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
+ (set! find-new #f))))
+ (XmStringFree xhelp)
+ (XmStringFree xdismiss)
+ (XmStringFree xfind)
+ (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
+ XmNbackground *basic-color*)))
+ (XtAddCallback find-text XmNfocusCallback
+ (lambda (w c i)
+ (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
+ (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
+ (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
+ (XtManageChild dialog))))
(XtAppAddActions snd-app
(list (list "search-forward"
@@ -2622,9 +2598,7 @@ display widget; type = 'text, 'meter, 'graph, 'spectrum, 'scale"))
(set! (data loc) var)
(if (time-graph? snd) (update-time-graph snd))
(if (transform-graph? snd) (update-transform-graph snd))
- (if (= (+ loc 1) len)
- (set! (cursor snd 0) 0)
- (set! (cursor snd 0) (+ loc 1))))))
+ (set! cursor (if (= (+ loc 1) len) 0 (+ loc 1))))))
var)))
(define variable-display-reset
@@ -2660,53 +2634,53 @@ display widget; type = 'text, 'meter, 'graph, 'spectrum, 'scale"))
(let ((maxed-snds ()))
(lambda (snd)
(let ((previous-minmax (find-if (lambda (n) (equal? (car n) snd)) maxed-snds)))
- (if (not previous-minmax)
- (let* ((widgets (sound-widgets snd))
- (status-area (widgets 3))
- (play-button (widgets 4))
- (cur-size (cadr (XtVaGetValues (car widgets) (list XmNheight 0)))))
- (XtUnmanageChild play-button)
- (let* ((name-form (XtParent status-area)) ; "snd-name-form"
- (new-minmax (XtCreateManagedWidget "." xmPushButtonWidgetClass name-form
- (list XmNbackground *basic-color*
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNmarginWidth 2
- XmNmarginHeight 0
- XmNshadowThickness 0
- ))))
- (XtVaSetValues play-button (list XmNrightAttachment XmATTACH_WIDGET
- XmNrightWidget new-minmax))
- (XtManageChild play-button)
- (XtAddCallback
- new-minmax XmNactivateCallback
- (lambda (w c i)
- (let ((mv (find-if (lambda (n) (equal? (car n) c)) maxed-snds)))
- (if mv
- (let ((maxed (caddr mv)))
- (if maxed
- (begin
- (set! (mv 3) (cadr (XtVaGetValues (car (sound-widgets c)) (list XmNheight 0))))
- (set! (mv 4) (show-controls c))
- (do ((i 0 (+ i 1)))
- ((= i (channels c)))
- (XtUnmanageChild ((channel-widgets c i) 10)))
- (set! (show-controls c) #f)
- (XmChangeColor new-minmax (make-color 1 1 0))
- (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum 25)))
- (let ((prev-size (mv 3)))
- (do ((i 0 (+ i 1)))
- ((= i (channels c)))
- (XtManageChild ((channel-widgets c i) 10)))
- (if (mv 4) (set! (show-controls c) #t))
- (XmChangeColor new-minmax *basic-color*)
- (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum prev-size XmNpaneMinimum (- prev-size 1)))
- (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum 1000 XmNpaneMinimum 1))))
- (set! (mv 2) (not maxed))))))
- snd)
-
- (set! previous-minmax (list snd new-minmax #t cur-size (show-controls snd)))
- (set! maxed-snds (cons previous-minmax maxed-snds)))))
+ (unless previous-minmax
+ (let* ((widgets (sound-widgets snd))
+ (status-area (widgets 3))
+ (play-button (widgets 4))
+ (cur-size (cadr (XtVaGetValues (car widgets) (list XmNheight 0)))))
+ (XtUnmanageChild play-button)
+ (let* ((name-form (XtParent status-area)) ; "snd-name-form"
+ (new-minmax (XtCreateManagedWidget "." xmPushButtonWidgetClass name-form
+ (list XmNbackground *basic-color*
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNmarginWidth 2
+ XmNmarginHeight 0
+ XmNshadowThickness 0
+ ))))
+ (XtVaSetValues play-button (list XmNrightAttachment XmATTACH_WIDGET
+ XmNrightWidget new-minmax))
+ (XtManageChild play-button)
+ (XtAddCallback
+ new-minmax XmNactivateCallback
+ (lambda (w c i)
+ (let ((mv (find-if (lambda (n) (equal? (car n) c)) maxed-snds)))
+ (when mv
+ (let ((maxed (caddr mv)))
+ (if maxed
+ (begin
+ (set! (mv 3) (cadr (XtVaGetValues (car (sound-widgets c)) (list XmNheight 0))))
+ (set! (mv 4) (show-controls c))
+ (do ((i 0 (+ i 1)))
+ ((= i (channels c)))
+ (XtUnmanageChild ((channel-widgets c i) 10)))
+ (set! (show-controls c) #f)
+ (XmChangeColor new-minmax (make-color 1 1 0))
+ (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum 25)))
+ (let ((prev-size (mv 3)))
+ (do ((i 0 (+ i 1)))
+ ((= i (channels c)))
+ (XtManageChild ((channel-widgets c i) 10)))
+ (if (mv 4) (set! (show-controls c) #t))
+ (XmChangeColor new-minmax *basic-color*)
+ (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum prev-size XmNpaneMinimum (- prev-size 1)))
+ (XtVaSetValues (car (sound-widgets c)) (list XmNpaneMaximum 1000 XmNpaneMinimum 1))))
+ (set! (mv 2) (not maxed))))))
+ snd)
+
+ (set! previous-minmax (list snd new-minmax #t cur-size (show-controls snd)))
+ (set! maxed-snds (cons previous-minmax maxed-snds)))))
#f))))
@@ -2732,10 +2706,10 @@ display widget; type = 'text, 'meter, 'graph, 'spectrum, 'scale"))
(define notebook-with-top-tabs
(let ((documentation "(notebook-with-top-tabs) posts the list of open sounds across the top of the Snd window (like the Emacs buffer list)"))
(lambda ()
- (let ((nb ((main-widgets) 3)))
- (XtVaSetValues nb (list XmNorientation XmVERTICAL
- XmNbindingType XmNONE
- XmNbackPagePlacement XmTOP_RIGHT))))))
+ (XtVaSetValues ((main-widgets) 3)
+ (list XmNorientation XmVERTICAL
+ XmNbindingType XmNONE
+ XmNbackPagePlacement XmTOP_RIGHT)))))
#|
diff --git a/snd-nogui.c b/snd-nogui.c
index 9de8cb7..dee91d9 100644
--- a/snd-nogui.c
+++ b/snd-nogui.c
@@ -472,8 +472,8 @@ void snd_doit(int argc, char **argv)
Xen_eval_C_string("def set_mark_color (m) false end");
Xen_eval_C_string("def mix_color () false end");
Xen_eval_C_string("def set_mix_color (m) false end");
- Xen_eval_C_string("def combined_data_color (a b) false end");
- Xen_eval_C_string("def set_combined_data_color (a b c) false end");
+ Xen_eval_C_string("def combined_data_color (a, b) false end");
+ Xen_eval_C_string("def set_combined_data_color (a, b, c) false end");
Xen_eval_C_string("def position_color () false end");
Xen_eval_C_string("def set_position_color (a) false end");
Xen_eval_C_string("def foreground_color () false end");
diff --git a/snd-sig.c b/snd-sig.c
index e19bce1..ed7ed1d 100644
--- a/snd-sig.c
+++ b/snd-sig.c
@@ -557,8 +557,8 @@ bool scale_to(snd_info *sp, chan_info *cp, mus_float_t *ur_scalers, int len, boo
(datum_size <= 2))
{
if (datum_size == 2)
- scalers[0] = 32767.0 / 32768.0;
- else scalers[0] = 127.0 / 128.0;
+ scalers[i] = 32767.0 / 32768.0;
+ else scalers[i] = 127.0 / 128.0;
}
scalers[i] /= val;
}
@@ -3396,7 +3396,7 @@ static Xen map_channel_to_temp_file(chan_info *cp, snd_fd *sf, Xen proc, mus_lon
free_file_info(hdr);
free(data[0]);
free(data);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (reporting) finish_progress_report(cp);
if (ss->stopped_explicitly)
@@ -3446,6 +3446,8 @@ static bool tree_memq(s7_scheme *sc, s7_pointer symbol, s7_pointer tree)
(tree_memq(sc, symbol, s7_cdr(tree))));
return(false);
}
+
+static s7_pointer gc_vect;
#endif
static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t beg, mus_long_t num, int pos, const char *caller)
@@ -3461,13 +3463,11 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
int gc_loc, proc_loc;
bool use_apply;
s7_pointer arg_list, body, e, slot;
- s7_pointer (*eval)(s7_scheme *sc, s7_pointer code, s7_pointer e);
arg_list = xen_nil;
body = xen_nil;
e = xen_nil;
slot = xen_nil;
- eval = NULL;
body = s7_closure_body(s7, proc);
if ((s7_is_pair(body)) &&
@@ -3607,10 +3607,14 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
use_apply = false;
if (s7_is_null(s7, s7_cdr(body)))
{
- eval = s7_eval_form;
body = s7_car(body);
}
- else eval = s7_eval;
+ else
+ {
+ body = s7_cons(s7, s7_make_symbol(s7, "begin"), body);
+ s7_vector_set(s7, gc_vect, 0, body);
+ }
+ /* fprintf(stderr, "eval %s\n", DISPLAY(body)); */
}
else
{
@@ -3643,7 +3647,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
else
{
s7_slot_set_value(s7, slot, s7_make_real(s7, in_data[kp]));
- res = eval(s7, body, e);
+ res = s7_eval(s7, body, e);
}
#else
res = Xen_unprotected_call_with_1_arg(proc, C_double_to_Xen_real((double)read_sample(sf)));
@@ -3703,7 +3707,8 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
}
}
}
- sf = free_snd_fd(sf);
+
+ free_snd_fd(sf);
#if HAVE_SCHEME
free(in_data);
s7_gc_unprotect_at(s7, gc_loc);
@@ -3880,13 +3885,11 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
int gc_loc;
bool use_apply;
s7_pointer body, e, slot;
- s7_pointer (*eval)(s7_scheme *sc, s7_pointer code, s7_pointer e);
arg_list = xen_nil;
body = xen_nil;
e = xen_nil;
slot = xen_nil;
- eval = NULL;
body = s7_closure_body(s7, proc);
if ((s7_is_pair(body)) &&
@@ -3976,10 +3979,14 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
if (s7_is_null(s7, s7_cdr(body)))
{
- eval = s7_eval_form;
body = s7_car(body);
}
- else eval = s7_eval;
+ else
+ {
+ body = s7_cons(s7, s7_make_symbol(s7, "begin"), body);
+ s7_vector_set(s7, gc_vect, 0, body);
+ }
+ /* fprintf(stderr, "eval %s\n", DISPLAY(body)); */
}
else
{
@@ -4009,7 +4016,7 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
else
{
s7_slot_set_value(s7, slot, s7_make_real(s7, read_sample(sf)));
- res = eval(s7, body, e);
+ res = s7_eval(s7, body, e);
}
#else
@@ -6526,6 +6533,9 @@ void g_init_sig(void)
s7_symbol_set_access(s7, ss->sinc_width_symbol, s7_make_function(s7, "[acc-" S_sinc_width "]", acc_sinc_width, 2, 0, false, "accessor"));
s7_symbol_set_documentation(s7, ss->sinc_width_symbol, "*sinc-width*: sampling rate conversion sinc width (10).");
+
+ gc_vect = s7_make_vector(s7, 1);
+ s7_gc_protect(s7, gc_vect);
#endif
}
diff --git a/snd-strings.h b/snd-strings.h
index c9e9c82..90e6b0f 100644
--- a/snd-strings.h
+++ b/snd-strings.h
@@ -591,12 +591,12 @@
#define S_src_channel "src-channel"
#define S_src_selection "src-selection"
#define S_src_sound "src-sound"
-#define S_start_hook "start-hook"
#define S_start_playing "start-playing"
#define S_start_playing_hook "start-playing-hook"
#define S_start_playing_selection_hook "start-playing-selection-hook"
#define S_start_progress_report "start-progress-report"
#define S_status_report "status-report"
+#define S_stdin_prompt "stdin-prompt"
#define S_stop_player "stop-player"
#define S_stop_playing "stop-playing"
#define S_stop_playing_hook "stop-playing-hook"
diff --git a/snd-test.rb b/snd-test.rb
index dda5069..8709046 100644
--- a/snd-test.rb
+++ b/snd-test.rb
@@ -2,13 +2,13 @@
# Translator/Author: Michael Scholz <mi-scholz at users.sourceforge.net>
# Created: 05/02/18 10:18:34
-# Changed: 15/03/05 13:28:53
+# Changed: 16/03/06 15:04:53
# Tags: FIXME - something is wrong
# XXX - info marker
#
# Tested with:
-# Snd 15.x
+# Snd 16.x
# Ruby 2.x.x
#
# Reads init file ./.sndtest.rb or ~/.sndtest.rb for global variables,
@@ -6516,7 +6516,6 @@ def test_05_08
if $with_test_motif
edhist = channel_widgets(ind, 0)[7]
edp = RXtParent(edhist)
- pmax = RXtVaGetValues(edp, [RXmNpaneMaximum, 0]).cadr
RXtUnmanageChild(edp)
RXtVaSetValues(edp, [RXmNpaneMinimum, 100])
RXtManageChild(edp)
@@ -11405,7 +11404,7 @@ def analog_filter_tests
f1 = make_inverse_chebyshev_bandstop(8, 0.1, 0.4, 90)
vals = sweep2bins(f1, 10)
snd_test_any_neq(vals[0], 0.5, :f05equal?, "inverse_chebyshev bs 8 90 max")
- v0 = vals[1]
+ v0 = vals[1]
v1 = vct(0.505, 0.325, 0, 0, 0, 0, 0, 0, 0.270, 0.506)
v2 = vct(0.506, 0.328, 0, 0, 0, 0, 0, 0, 0.269, 0.509)
v3 = vct(0.501, 0.327, 0, 0, 0, 0, 0, 0, 0.268, 0.506)
@@ -22802,7 +22801,6 @@ def test_13_02
if $with_test_motif
edhist = channel_widgets(ind, 0)[7]
edp = RXtParent(edhist)
- pmax = RXtVaGetValues(edp, [RXmNpaneMaximum, 0]).cadr
RXtUnmanageChild(edp)
RXtVaSetValues(edp, [RXmNpaneMinimum, 100])
RXtManageChild(edp)
@@ -22986,23 +22984,31 @@ def test_13_02
if $with_test_motif
edhist = channel_widgets(ind, 0)[7]
edp = RXtParent(edhist)
- pmax = RXtVaGetValues(edp, [RXmNpaneMaximum, 0]).cadr
RXtUnmanageChild(edp)
- RXtVaSetValues(edp, [RXmNpaneMinimum, 100])
+ RXtVaSetValues(edp, [RXmNpaneMinimum, 1])
RXtManageChild(edp)
end
close_sound(ind)
+ reset_all_hooks
#
# before|after-save-as-hook
#
hook_called = false
- $before_save_as_hook.add_hook!("snd-test") do |snd, fname, sel, sr, type, fmt, com|
- if sr != srate(snd)
- channels(snd).times do |chn|
- src_channel(srate(snd).to_f / sr, 0, false, snd, chn)
+ $before_save_as_hook.add_hook!("snd-test") do |s1, f, sel, sr, type, fmt, com|
+ if sr != srate(s1)
+ channels(s1).times do |chn|
+ src_channel(srate(s1).to_f / sr, 0, false, s1, chn)
+ end
+ Snd.catch do
+ save_sound_as(f, s1,
+ :header_type, fmt,
+ :sample_type, type,
+ :srate, sr,
+ :comment, com)
+ end
+ channels(s1).times do |chn|
+ undo_edit(1, s1, chn)
end
- save_sound_as(fname, snd, :header_type, type, :sample_type, fmt, :srate, sr, :comment, com)
- channels(snd).times do |chn| undo_edit(1, snd, chn) end
hook_called = true
true
else
@@ -23026,10 +23032,10 @@ def test_13_02
$before_save_as_hook.remove_hook!("snd-test")
#
need_save_as_undo = false
- $before_save_as_hook.add_hook!("snd-test") do |snd, fname, sel, sr, type, fmt, com|
+ $before_save_as_hook.add_hook!("snd-test") do |s1, f, sel, sr, type, fmt, com|
need_save_as_undo = false
- if sr != srate(snd)
- src_sound(srate(snd).to_f / sr, 1.0, snd)
+ if sr != srate(s1)
+ src_sound(srate(s1).to_f / sr, 1.0, s1)
need_save_as_undo = true
end
false
@@ -35546,7 +35552,7 @@ def test_28_03
$clm_srate = old_clm_srate
# now try everything! (all we care about here is that Snd keeps running)
random_args = [1.5, [0, 1], 1234, true]
- main_args = [1.5, [0, 1], 1234, $vct_3, $color_95, sqrt(-1.0), $delay_32, :feedback, false]
+ main_args = [1.5, [0, 1], 1234, $vct_3, $color_95, sqrt(-1.0), $delay_32, false]
few_args = [1.5, [0, 1], 1234, sqrt(-1.0), $delay_32, true]
fewer_args = [1.5, $vct_3, sqrt(-1.0)]
less_args = $all_args ? main_args : few_args
diff --git a/snd-test.scm b/snd-test.scm
index e2569cc..1e3d6aa 100644
--- a/snd-test.scm
+++ b/snd-test.scm
@@ -1,46 +1,44 @@
;;; Snd tests
;;;
-;;; test 0: constants [554]
-;;; test 1: defaults [1226]
-;;; test 2: headers [1596]
-;;; test 3: variables [1911]
-;;; test 4: sndlib [2475]
-;;; test 5: simple overall checks [4490]
-;;; test 6: float-vectors [9242]
-;;; test 7: colors [9513]
-;;; test 8: clm [10032]
-;;; test 9: mix [22115]
-;;; test 10: marks [23894]
-;;; test 11: dialogs [24832]
-;;; test 12: extensions [25005]
-;;; test 13: menus, edit lists, hooks, etc [25271]
-;;; test 14: all together now [26604]
-;;; test 15: chan-local vars [27487]
-;;; test 16: regularized funcs [29224]
-;;; test 17: dialogs and graphics [32973]
-;;; test 18: save and restore [33085]
-;;; test 19: transforms [34737]
-;;; test 20: new stuff [36837]
-;;; test 21: optimizer [38030]
-;;; test 22: with-sound [40924]
-;;; test 23: X/Xt/Xm [43909]
-;;; test 24: GL [47583]
-;;; test 25: errors [47706]
-;;; test 26: s7 [49224]
-;;; test all done [49295]
-;;; test the end [49477]
+;;; test 0: constants [420]
+;;; test 1: defaults [1090]
+;;; test 2: headers [1460]
+;;; test 3: variables [1775]
+;;; test 4: sndlib [2335]
+;;; test 5: simple overall checks [4215]
+;;; test 6: float-vectors [8940]
+;;; test 7: colors [9215]
+;;; test 8: clm [9715]
+;;; test 9: mix [21738]
+;;; test 10: marks [23516]
+;;; test 11: dialogs [24451]
+;;; test 12: extensions [24620]
+;;; test 13: menus, edit lists, hooks, etc [24884]
+;;; test 14: all together now [26170]
+;;; test 15: chan-local vars [27047]
+;;; test 16: regularized funcs [28775]
+;;; test 17: dialogs and graphics [32488]
+;;; test 18: save and restore [32599]
+;;; test 19: transforms [34229]
+;;; test 20: new stuff [36403]
+;;; test 21: optimizer [37590]
+;;; test 22: with-sound [40251]
+;;; test 23: X/Xt/Xm [43153]
+;;; test 24: GL [46773]
+;;; test 25: errors [46896]
+;;; test 26: s7 [48321]
+;;; test all done [48391]
+;;; test the end [48574]
;;; (set! (hook-functions *load-hook*) (list (lambda (hook) (format *stderr* "loading ~S...~%" (hook 'name)))))
-;(set! (*s7* 'gc-stats) 6)
+;(set! (*s7* 'gc-stats) #t)
(when (provided? 'pure-s7)
(define (make-polar mag ang)
(if (and (real? mag) (real? ang))
(complex (* mag (cos ang)) (* mag (sin ang)))
- (error 'wrong-type-arg "make-polar args should be real")))
- (define (memq a b) (member a b eq?))
- (define (memv a b) (member a b eqv?)))
+ (error 'wrong-type-arg "make-polar args should be real"))))
(define tests 1)
(define keep-going #f)
@@ -48,16 +46,6 @@
(define test-at-random 0)
(if (<= tests 0) (set! tests 1))
-#|
-(set! *#readers*
- (cons (cons #\_ (lambda (str)
- (if (string=? str "__line__")
- (port-line-number)
- #f)))
- *#readers*))
-|#
-(set! *#readers* (cons (cons #\_ _snd-line-reader_) *#readers*))
-
(define (copy-file source dest) (system (string-append "cp " source " " dest)))
(define-expansion (fill-float-vector v body)
@@ -73,102 +61,13 @@
((= i len) (set! *output* #f) ,v)
(outa i ,body))))
-(define* (cfft! data n (dir 1))
- (if (not n) (set! n (length data)))
- (let ((t0 (complex 0.0 (* pi dir))))
- (do ((i 0 (+ i 1))
- (j 0))
- ((= i n))
- (if (> j i)
- (let ((temp (data j)))
- (set! (data j) (data i))
- (set! (data i) temp)))
- (let ((m (/ n 2)))
- (do ()
- ((or (< m 2) (< j m)))
- (set! j (- j m))
- (set! m (/ m 2)))
- (set! j (+ j m))))
- (let ((ipow (floor (log n 2)))
- (prev 1))
- (do ((lg 0 (+ lg 1))
- (mmax 2 (* mmax 2))
- (pow (/ n 2) (/ pow 2))
- (theta t0 (* theta 0.5)))
- ((= lg ipow))
- (let ((wpc (exp theta))
- (wc 1.0))
- (do ((ii 0 (+ ii 1)))
- ((= ii prev))
- (do ((jj 0 (+ jj 1))
- (i ii (+ i mmax))
- (j (+ ii prev) (+ j mmax)))
- ((>= jj pow))
- (let ((tc (* wc (data j))))
- (set! (data j) (- (data i) tc))
- (set! (data i) (+ (data i) tc))))
- (set! wc (* wc wpc)))
- (set! prev mmax))))
- data))
-
-(define* (fft! rl im n (dir 1))
- (if (not im)
- (set! im (make-float-vector (length rl))))
- (if (not n)
- (set! n (length rl)))
- (do ((i 0 (+ i 1))
- (j 0))
- ((= i n))
- (if (> j i)
- (let ((tempr (rl j))
- (tempi (im j)))
- (set! (rl j) (rl i))
- (set! (im j) (im i))
- (set! (rl i) tempr)
- (set! (im i) tempi)))
- (let ((m (/ n 2)))
- (do ()
- ((or (< m 2) (< j m)))
- (set! j (- j m))
- (set! m (/ m 2)))
- (set! j (+ j m))))
- (let ((ipow (floor (log n 2)))
- (prev 1))
- (do ((lg 0 (+ lg 1))
- (mmax 2 (* mmax 2))
- (pow (/ n 2) (/ pow 2))
- (theta (* pi dir) (* theta 0.5)))
- ((= lg ipow))
- (let ((wpr (cos theta))
- (wpi (sin theta))
- (wr 1.0)
- (wi 0.0))
- (do ((ii 0 (+ ii 1)))
- ((= ii prev))
- (do ((jj 0 (+ jj 1))
- (i ii (+ i mmax))
- (j (+ ii prev) (+ j mmax)))
- ((>= jj pow))
- (let ((tempr (- (* wr (rl j)) (* wi (im j))))
- (tempi (+ (* wr (im j)) (* wi (rl j)))))
- (set! (rl j) (- (rl i) tempr))
- (set! (im j) (- (im i) tempi))
- (set! (rl i) (+ (rl i) tempr))
- (set! (im i) (+ (im i) tempi))))
- (let ((wtemp wr))
- (set! wr (- (* wr wpr) (* wi wpi)))
- (set! wi (+ (* wi wpr) (* wtemp wpi)))))
- (set! prev mmax))))
- rl)
-
(if (not (defined? 'snd-test)) (define snd-test -1))
(define full-test (< snd-test 0))
(define total-tests 26)
(if (not (defined? 'with-exit)) (define with-exit (< snd-test 0)))
-(define s7test-exits #f)
(define test-number -1)
-(define-constant (snd-display line . args)
+(define-constant (snd-display-1 line . args)
(let ((str (if (null? (cdr args))
(car args)
(if (or (string? (car args))
@@ -180,12 +79,15 @@
(if (not (provided? 'snd-nogui))
(snd-print (format #f "~%~A: ~A" line str)))))
+(define-expansion (snd-display . args)
+ `(snd-display-1 ,(port-line-number) , at args))
+
(define with-big-file #f)
(define big-file-name "/home/bil/zap/sounds/bigger.snd")
(if with-big-file
(begin
(set! with-big-file (file-exists? big-file-name))
- (if (not with-big-file) (snd-display #__line__ ";no big file"))))
+ (if (not with-big-file) (snd-display ";no big file"))))
(define big-file-framples 0)
(define original-save-dir (or *save-dir* "~/zap/snd"))
@@ -212,14 +114,11 @@
(define sf-dir "/sf1")
(if (not (file-exists? (string-append home-dir "/cl/oboe.snd")))
- (if (file-exists? "/export/home/bil/cl/oboe.snd")
- (set! home-dir "/export/home/bil")
- (if (file-exists? "/Users/bil/cl/oboe.snd")
- (set! home-dir "/Users/bil")
- (if (file-exists? "/users/b/bil/cl/oboe.snd")
- (set! home-dir "/users/b/bil")
- (if (file-exists? "/usr/home/bil/cl/oboe.snd")
- (set! home-dir "/usr/home/bil"))))))
+ (cond ((file-exists? "/export/home/bil/cl/oboe.snd") (set! home-dir "/export/home/bil"))
+ ((file-exists? "/Users/bil/cl/oboe.snd") (set! home-dir "/Users/bil"))
+ ((file-exists? "/users/b/bil/cl/oboe.snd") (set! home-dir "/users/b/bil"))
+ ((file-exists? "/usr/home/bil/cl/oboe.snd") (set! home-dir "/usr/home/bil"))))
+
(define cwd (string-append (getcwd) "/"))
(define sf-dir1 (string-append home-dir sf-dir "/"))
@@ -229,7 +128,7 @@
(set! sf-dir1 (string-append home-dir sf-dir "/"))
(if (not (file-exists? (string-append sf-dir1 "alaw.wav")))
(begin
- (snd-display #__line__ ";;;can't find sf directory!")
+ (snd-display ";;;can't find sf directory!")
(set! sf-dir1 #f)))))
(set! sf-dir sf-dir1)
@@ -238,7 +137,7 @@
(lambda (file)
(if (not (file-exists? file))
(begin
- (format #t "copying ~A~%" file)
+ (format () "copying ~A~%" file)
(copy-file (string-append home-dir "/cl/" file) (string-append (getcwd) "/" file)))))
(list "4.aiff" "2.snd" "obtest.snd" "oboe.snd" "pistol.snd" "1a.snd" "now.snd" "fyow.snd"
"storm.snd" "z.snd" "1.snd" "cardinal.snd" "now.snd.scm" "2a.snd" "4a.snd" "zero.snd"
@@ -335,40 +234,8 @@
(define (vvequal v0 v1)
(mus-arrays-equal? v0 v1 .00002))
-(define (vmaxdiff v0 v1)
- (float-vector-peak (float-vector-subtract! (copy v0) v1)))
-
-(define (within-.01? a b) (< (abs (- a b)) .01))
-
-(define-constant (string-=? a b) ;(format *stderr* "str: ~A ~A~%" a b)
- (or (string=? a b)
- (and (or (char-position #\- a)
- (char-position #\- b))
- (let ((alen (length a))
- (blen (length b))
- (j 0)
- (happy #t))
- (do ((i 0 (+ i 1)))
- ((or (not happy)
- (= i alen))
- (and happy
- (= j blen)))
- (let ((ac (a i))
- (bc (b j)))
- (if (char=? ac bc)
- (set! j (+ j 1))
- (if (not (and (char=? ac #\-)
- (<= i (- alen 7))
- (string=? (substring a i (+ i 6)) "-0.000")))
- (if (and (char=? bc #\-)
- (<= j (- blen 7))
- (string=? (substring b j (+ j 6)) "-0.000"))
- (begin
- (set! j (+ j 1))
- (if (not (char=? ac (b j)))
- (set! happy #f)
- (set! j (+ j 1))))
- (set! happy #f))))))))))
+(define (within-.01? b) (< (abs (- 1.0 b)) .01))
+(define (very-close? a b) (< (abs (- a b)) .01))
(define dismiss-all-dialogs
(let ((documentation "(dismiss-all-dialogs) hides all dialogs"))
@@ -408,17 +275,12 @@
(lambda* (snd chn edpos)
(catch #t
(lambda () (display-edits snd chn edpos))
- (lambda args (snd-display #__line__ ";display-edits error: ~A" args))))))
-
-(define (safe-divide a b)
- (if (zero? b)
- a
- (/ a b)))
+ (lambda args (snd-display ";display-edits error: ~A" args))))))
(define timings (make-vector (+ total-tests 1) 0))
(define default-srate *clm-srate*)
-(snd-display #__line__ ";;~A" (snd-version))
+(snd-display ";;~A" (snd-version))
(if (not (defined? 'before-test-hook)) (define before-test-hook (make-hook 'n)))
(if (not (defined? 'after-test-hook)) (define after-test-hook (make-hook 'n)))
(set! (hook-functions before-test-hook) ())
@@ -429,11 +291,11 @@
(set! *clipping* #f)
(set! (mus-clipping) #f) ; this cost me a morning of confusion!
(set! test-number n)
- (set! (timings n) (real-time))
- (snd-display #__line__ ";test ~D" n)
+ (if (> (length timings) n)
+ (set! (timings n) (real-time)))
+ (snd-display ";test ~D" n)
)))
-
(define (clear-save-state-files)
(for-each forget-region (regions))
(system (format #f "rm -f ~A/snd_*" (or *save-dir* original-save-dir)))
@@ -452,35 +314,26 @@
(set! *ask-about-unsaved-edits* #f)
(if (pair? (sounds))
(begin
- (snd-display #__line__ ";end test ~D: open sounds: ~A" n (map short-file-name (sounds)))
+ (snd-display ";end test ~D: open sounds: ~A" n (map short-file-name (sounds)))
(for-each close-sound (sounds))))
(if (number? (vector-ref timings n))
(set! (timings n) (hundred (- (real-time) (vector-ref timings n))))))))
(define overall-start-time (real-time))
-(snd-display #__line__ ";~A~%" (strftime "%d-%b %H:%M %Z" (localtime (current-time))))
+(snd-display ";~A~%" (strftime "%d-%b %H:%M %Z" (localtime (current-time))))
(define (log-mem tst)
- (if (> tests 1) (snd-display #__line__ ";test ~D:~D " test-number (+ 1 tst))))
+ (if (> tests 1) (snd-display ";test ~D:~D " test-number (+ 1 tst))))
(define-macro (without-errors func)
`(catch #t ; but this also squelches syntax errors!
- (lambda ()
- ,func)
- (lambda args
- (car args))))
+ (lambda ()
+ ,func)
+ (lambda args
+ (car args))))
(require snd-hooks.scm snd-ws.scm)
-(define (set-arity-ok func args)
- (let ((arit (if (dilambda? func)
- (arity (procedure-setter func))
- (and (procedure? (procedure-setter func))
- (arity (procedure-setter func))))))
- (and (pair? arit)
- (>= args (car arit))
- (<= args (cdr arit)))))
-
(define* (scale-sound-by scl beg dur snd chn edpos)
(if (integer? chn)
(scale-channel scl beg dur snd chn edpos)
@@ -491,15 +344,16 @@
(define* (scale-sound-to norm beg dur snd chn)
(if (integer? chn)
(let ((mx (maxamp snd chn)))
- (if (and (not (= mx 0.0))
- (not (= mx norm)))
+ (if (not (or (= mx 0.0)
+ (= mx norm)))
(scale-channel (/ norm mx) beg dur snd chn)))
(let ((mx (apply max (maxamp snd #t))))
- (if (and (not (= mx 0.0))
- (not (= mx norm)))
- (do ((i 0 (+ i 1)))
+ (if (not (or (= mx 0.0)
+ (= mx norm)))
+ (do ((nmx (/ norm mx))
+ (i 0 (+ i 1)))
((= i (channels snd)))
- (scale-channel (/ norm mx) beg dur snd i))))))
+ (scale-channel nmx beg dur snd i))))))
(define (file->floats file) (samples 0 (framples file) file))
@@ -516,9 +370,9 @@
(let ((arg (script-arg))
(args (script-args)))
(if (not (string=? (args (- arg 1)) "-l"))
- (snd-display #__line__ ";script-args[~A]: ~A (~A)?" (- arg 1) (args (- arg 1)) args))
+ (snd-display ";script-args[~A]: ~A (~A)?" (- arg 1) (args (- arg 1)) args))
(if (not (string=? (args arg) "snd-test"))
- (snd-display #__line__ ";script-args[~A]: ~A (~A)?" arg (args arg) args))
+ (snd-display ";script-args[~A]: ~A (~A)?" arg (args arg) args))
(if (> (length args) (+ 1 arg))
(begin
;; test-number tests
@@ -541,12 +395,7 @@
(define default-file-buffer-size *clm-file-buffer-size*)
-;(set! *clm-file-buffer-size* default-file-buffer-size)
-
-(if (not (defined? 'pi))
- (snd-display #__line__ ";pi is not defined!")
- (if (fneq pi 3.14159)
- (snd-display #__line__ ";pi is ~A" pi)))
+ ;(set! *clm-file-buffer-size* default-file-buffer-size)
;;; ---------------- test 0: constants ----------------
@@ -557,7 +406,7 @@
(if (pair? lst)
(begin
(if (not (= (cadr lst) (caddr lst)))
- (snd-display #__line__ ";~A is not ~A (~A)~%"
+ (snd-display ";~A is not ~A (~A)~%"
(car lst) (cadr lst) (caddr lst)))
(test-constants (cdddr lst)))))))
@@ -565,7 +414,7 @@
(pair? (mixes))
(pair? (marks))
(pair? (regions)))
- (snd-display #__line__ ";start up: ~A ~A ~A ~A" (sounds) (mixes) (marks) (regions)))
+ (snd-display ";start up: ~A ~A ~A ~A" (sounds) (mixes) (marks) (regions)))
(test-constants
(list
'enved-amplitude enved-amplitude 0
@@ -720,498 +569,488 @@
))
(if (not (equal? *region-graph-style* graph-lines))
- (snd-display #__line__ ";region-graph-style set default: ~A" *region-graph-style*))
+ (snd-display ";region-graph-style set default: ~A" *region-graph-style*))
(if *ask-about-unsaved-edits*
- (snd-display #__line__ ";ask-about-unsaved-edits set default: ~A" *ask-about-unsaved-edits*))
+ (snd-display ";ask-about-unsaved-edits set default: ~A" *ask-about-unsaved-edits*))
(if (not (boolean? *show-full-duration*))
- (snd-display #__line__ ";show-full-duration set default: ~A" *show-full-duration*))
+ (snd-display ";show-full-duration set default: ~A" *show-full-duration*))
(if *show-full-range*
- (snd-display #__line__ ";show-full-range set default: ~A" *show-full-range*))
+ (snd-display ";show-full-range set default: ~A" *show-full-range*))
(if (fneq *initial-beg* 0.0)
- (snd-display #__line__ ";initial-beg set default: ~A" *initial-beg*))
+ (snd-display ";initial-beg set default: ~A" *initial-beg*))
(if (fneq *initial-dur* 0.1)
- (snd-display #__line__ ";initial-dur set default: ~A" *initial-dur*))
+ (snd-display ";initial-dur set default: ~A" *initial-dur*))
(if *ask-before-overwrite*
- (snd-display #__line__ ";ask-before-overwrite set default: ~A" *ask-before-overwrite*))
+ (snd-display ";ask-before-overwrite set default: ~A" *ask-before-overwrite*))
(if (not *auto-resize*)
- (snd-display #__line__ ";auto-resize set default: ~A" *auto-resize*))
+ (snd-display ";auto-resize set default: ~A" *auto-resize*))
(if *auto-update*
- (snd-display #__line__ ";auto-update set default: ~A" *auto-update*))
+ (snd-display ";auto-update set default: ~A" *auto-update*))
(if (not (eqv? *channel-style* 1 ))
- (snd-display #__line__ ";channel-style set default: ~A" *channel-style*))
+ (snd-display ";channel-style set default: ~A" *channel-style*))
(if (and (fneq *color-cutoff* 0.003 ) (fneq *color-cutoff* 0.001))
- (snd-display #__line__ ";color-cutoff set default: ~A" *color-cutoff*))
+ (snd-display ";color-cutoff set default: ~A" *color-cutoff*))
(if (not *color-inverted*)
- (snd-display #__line__ ";color-inverted set default: ~A" *color-inverted*))
+ (snd-display ";color-inverted set default: ~A" *color-inverted*))
(if (fneq *color-scale* 1.0 )
- (snd-display #__line__ ";color-scale set default: ~A" *color-scale*))
+ (snd-display ";color-scale set default: ~A" *color-scale*))
(if (fneq *auto-update-interval* 60.0 )
- (snd-display #__line__ ";auto-update-interval set default: ~A" *auto-update-interval*))
+ (snd-display ";auto-update-interval set default: ~A" *auto-update-interval*))
(if (fneq *cursor-update-interval* 0.05 )
- (snd-display #__line__ ";cursor-update-interval set default: ~A" *cursor-update-interval*))
+ (snd-display ";cursor-update-interval set default: ~A" *cursor-update-interval*))
(if (not (= *cursor-location-offset* 0))
- (snd-display #__line__ ";cursor-location-offset set default: ~A" *cursor-location-offset*))
+ (snd-display ";cursor-location-offset set default: ~A" *cursor-location-offset*))
(if (not *dac-combines-channels*)
- (snd-display #__line__ ";dac-combines-channels set default: ~A" *dac-combines-channels*))
+ (snd-display ";dac-combines-channels set default: ~A" *dac-combines-channels*))
(if (not (eqv? *dac-size* 256 ))
- (snd-display #__line__ ";dac-size set default: ~A" *dac-size*))
+ (snd-display ";dac-size set default: ~A" *dac-size*))
(if *clipping*
- (snd-display #__line__ ";clipping set default: ~A" *clipping*))
+ (snd-display ";clipping set default: ~A" *clipping*))
(if (not (eqv? *default-output-chans* 1 ))
- (snd-display #__line__ ";default-output-chans set default: ~A" *default-output-chans*))
- (if (and (not (equal? *default-output-sample-type* mus-bdouble))
- (not (equal? *default-output-sample-type* mus-ldouble)))
- (snd-display #__line__ ";default-output-sample-type set default: ~A" *default-output-sample-type*))
+ (snd-display ";default-output-chans set default: ~A" *default-output-chans*))
+ (if (not (or (equal? *default-output-sample-type* mus-bdouble)
+ (equal? *default-output-sample-type* mus-ldouble)))
+ (snd-display ";default-output-sample-type set default: ~A" *default-output-sample-type*))
(if (not (eqv? *default-output-srate* 44100 ))
- (snd-display #__line__ ";default-output-srate set default: ~A" *default-output-srate*))
+ (snd-display ";default-output-srate set default: ~A" *default-output-srate*))
(if (not (equal? *default-output-header-type* mus-next))
- (snd-display #__line__ ";default-output-header-type set default: ~A" *default-output-header-type*))
+ (snd-display ";default-output-header-type set default: ~A" *default-output-header-type*))
(if (not (eqv? *dot-size* 1 ))
- (snd-display #__line__ ";dot-size set default: ~A" *dot-size*))
+ (snd-display ";dot-size set default: ~A" *dot-size*))
(if (not (eqv? *cursor-size* 15 ))
- (snd-display #__line__ ";cursor-size set default: ~A" *cursor-size*))
+ (snd-display ";cursor-size set default: ~A" *cursor-size*))
(if (not (equal? *cursor-style* cursor-cross ))
- (snd-display #__line__ ";cursor-style set default: ~A" *cursor-style*))
+ (snd-display ";cursor-style set default: ~A" *cursor-style*))
(if (not (equal? *tracking-cursor-style* cursor-line ))
- (snd-display #__line__ ";tracking-cursor-style set default: ~A" *tracking-cursor-style*))
+ (snd-display ";tracking-cursor-style set default: ~A" *tracking-cursor-style*))
(if (fneq *enved-base* 1.0 )
- (snd-display #__line__ ";enved-base set default: ~A" *enved-base*))
+ (snd-display ";enved-base set default: ~A" *enved-base*))
(if (not (enved-clip?))
- (snd-display #__line__ ";enved-clip? set default: ~A" (enved-clip?)))
+ (snd-display ";enved-clip? set default: ~A" (enved-clip?)))
(if (not (enved-filter))
- (snd-display #__line__ ";enved-filter set default: ~A" (enved-filter)))
+ (snd-display ";enved-filter set default: ~A" (enved-filter)))
(if (not (eqv? *enved-filter-order* 40))
- (snd-display #__line__ ";enved-filter-order set default: ~A" *enved-filter-order*))
+ (snd-display ";enved-filter-order set default: ~A" *enved-filter-order*))
(if (enved-in-dB)
- (snd-display #__line__ ";enved-in-dB set default: ~A" (enved-in-dB)))
+ (snd-display ";enved-in-dB set default: ~A" (enved-in-dB)))
(if (not (equal? *enved-style* envelope-linear ))
- (snd-display #__line__ ";enved-style set default: ~A" *enved-style*))
+ (snd-display ";enved-style set default: ~A" *enved-style*))
(if (fneq *enved-power* 3.0)
- (snd-display #__line__ ";enved-power set default: ~A" *enved-power*))
+ (snd-display ";enved-power set default: ~A" *enved-power*))
(if (not (eqv? *enved-target* 0 ))
- (snd-display #__line__ ";enved-target set default: ~A" *enved-target*))
+ (snd-display ";enved-target set default: ~A" *enved-target*))
(if *enved-wave?*
- (snd-display #__line__ ";enved-wave? set default: ~A" *enved-wave?*))
+ (snd-display ";enved-wave? set default: ~A" *enved-wave?*))
(if (and with-gui
(pair? (enved-envelope)))
- (snd-display #__line__ ";enved-envelope set default: ~A" (enved-envelope)))
+ (snd-display ";enved-envelope set default: ~A" (enved-envelope)))
(if (not (equal? *eps-file* "snd.eps" ))
- (snd-display #__line__ ";eps-file set default: ~A" *eps-file*))
+ (snd-display ";eps-file set default: ~A" *eps-file*))
(if (fneq *eps-bottom-margin* 0.0)
- (snd-display #__line__ ";eps-bottom-margin set default: ~A" *eps-bottom-margin*))
+ (snd-display ";eps-bottom-margin set default: ~A" *eps-bottom-margin*))
(if (fneq *eps-left-margin* 0.0)
- (snd-display #__line__ ";eps-left-margin set default: ~A" *eps-left-margin*))
+ (snd-display ";eps-left-margin set default: ~A" *eps-left-margin*))
(if (fneq *eps-size* 1.0)
- (snd-display #__line__ ";eps-size set default: ~A" *eps-size*))
+ (snd-display ";eps-size set default: ~A" *eps-size*))
(if (fneq *fft-window-alpha* 0.0 )
- (snd-display #__line__ ";fft-window-alpha set default: ~A" *fft-window-alpha*))
+ (snd-display ";fft-window-alpha set default: ~A" *fft-window-alpha*))
(if (fneq *fft-window-beta* 0.0 )
- (snd-display #__line__ ";fft-window-beta set default: ~A" *fft-window-beta*))
+ (snd-display ";fft-window-beta set default: ~A" *fft-window-beta*))
(if *fft-log-frequency*
- (snd-display #__line__ ";fft-log-frequency set default: ~A" *fft-log-frequency*))
+ (snd-display ";fft-log-frequency set default: ~A" *fft-log-frequency*))
(if *fft-log-magnitude*
- (snd-display #__line__ ";fft-log-magnitude set default: ~A" *fft-log-magnitude*))
+ (snd-display ";fft-log-magnitude set default: ~A" *fft-log-magnitude*))
(if *fft-with-phases*
- (snd-display #__line__ ";fft-with-phases set default: ~A" *fft-with-phases*))
- (if (not (member *transform-size* (list 1024 4096)))
- (snd-display #__line__ ";transform-size set default: ~A" *transform-size*))
+ (snd-display ";fft-with-phases set default: ~A" *fft-with-phases*))
+ (if (not (member *transform-size* '(1024 4096)))
+ (snd-display ";transform-size set default: ~A" *transform-size*))
(if (not (equal? *transform-graph-type* graph-once))
- (snd-display #__line__ ";transform-graph-type set default: ~A" *transform-graph-type*))
+ (snd-display ";transform-graph-type set default: ~A" *transform-graph-type*))
(if (not (eqv? *fft-window* 6 ))
- (snd-display #__line__ ";fft-window set default: ~A" *fft-window*))
+ (snd-display ";fft-window set default: ~A" *fft-window*))
(if (not (eqv? *graph-cursor* 34))
- (snd-display #__line__ ";graph-cursor set default: ~A" *graph-cursor*))
+ (snd-display ";graph-cursor set default: ~A" *graph-cursor*))
(if (not (equal? *graph-style* graph-lines ))
- (snd-display #__line__ ";graph-style set default: ~A" *graph-style*))
+ (snd-display ";graph-style set default: ~A" *graph-style*))
(if (not *graphs-horizontal*)
- (snd-display #__line__ ";graphs-horizontal set default: ~A" *graphs-horizontal*))
+ (snd-display ";graphs-horizontal set default: ~A" *graphs-horizontal*))
(if (not (equal? *html-dir* "."))
- (snd-display #__line__ ";html-dir set default: ~A" *html-dir*))
+ (snd-display ";html-dir set default: ~A" *html-dir*))
(if (not (equal? *html-program* "firefox"))
- (snd-display #__line__ ";html-program set default: ~A" *html-program*))
+ (snd-display ";html-program set default: ~A" *html-program*))
(if (not *just-sounds*)
- (snd-display #__line__ ";just-sounds set default: ~A" *just-sounds*))
+ (snd-display ";just-sounds set default: ~A" *just-sounds*))
(if (not (string? *listener-prompt*))
- (snd-display #__line__ ";listener-prompt set default: ~A" *listener-prompt*))
- (if (not (eqv? *max-transform-peaks* 100))
- (snd-display #__line__ ";max-transform-peaks set default: ~A" *max-transform-peaks*))
- (if (not (eqv? *max-transform-peaks* 100))
- (snd-display #__line__ ";max-transform-peaks set -123: ~A" *max-transform-peaks*))
+ (snd-display ";listener-prompt set default: ~A" *listener-prompt*))
+ (if (not (string? *stdin-prompt*))
+ (snd-display ";stdin-prompt set default: ~A" *stdin-prompt*))
+ (unless (eqv? *max-transform-peaks* 100)
+ (snd-display ";max-transform-peaks set default: ~A" *max-transform-peaks*))
(if (not (eqv? *max-regions* 16 ))
- (snd-display #__line__ ";max-regions set default: ~A" *max-regions*))
+ (snd-display ";max-regions set default: ~A" *max-regions*))
(if (fneq *min-dB* -60.0 )
- (snd-display #__line__ ";min-dB set default: ~A" *min-dB*))
+ (snd-display ";min-dB set default: ~A" *min-dB*))
(if (fneq *log-freq-start* 32.0 )
- (snd-display #__line__ ";log-freq-start set default: ~A" *log-freq-start*))
+ (snd-display ";log-freq-start set default: ~A" *log-freq-start*))
(if (not *selection-creates-region*)
- (snd-display #__line__ ";selection-creates-region set default: ~A" *selection-creates-region*))
+ (snd-display ";selection-creates-region set default: ~A" *selection-creates-region*))
(if (not (equal? *transform-normalization* normalize-by-channel))
- (snd-display #__line__ ";transform-normalization set default: ~A" *transform-normalization*))
+ (snd-display ";transform-normalization set default: ~A" *transform-normalization*))
(if (and with-motif
(not (eqv? (view-files-sort) 0 )))
- (snd-display #__line__ ";view-files-sort set default: ~A" (view-files-sort)))
+ (snd-display ";view-files-sort set default: ~A" (view-files-sort)))
(if (not (member *print-length* '(12 32) ))
- (snd-display #__line__ ";print-length set default: ~A" *print-length*))
+ (snd-display ";print-length set default: ~A" *print-length*))
(if (not (eqv? *play-arrow-size* 10 ))
- (snd-display #__line__ ";play-arrow-size set default: ~A" *play-arrow-size*))
+ (snd-display ";play-arrow-size set default: ~A" *play-arrow-size*))
(if (not (equal? *save-state-file* "saved-snd.scm" ))
- (snd-display #__line__ ";save-state-file set default: ~A" *save-state-file*))
+ (snd-display ";save-state-file set default: ~A" *save-state-file*))
(if (not (eqv? *show-axes* 1))
- (snd-display #__line__ ";show-axes set default: ~A" *show-axes*))
+ (snd-display ";show-axes set default: ~A" *show-axes*))
(if (not (boolean? *show-transform-peaks*))
- (snd-display #__line__ ";show-transform-peaks set default: ~A" *show-transform-peaks*))
+ (snd-display ";show-transform-peaks set default: ~A" *show-transform-peaks*))
(if (not (boolean? *show-indices*))
- (snd-display #__line__ ";show-indices set default: ~A" *show-indices*))
+ (snd-display ";show-indices set default: ~A" *show-indices*))
(if (not *show-marks*)
- (snd-display #__line__ ";show-marks set default: ~A" *show-marks*))
+ (snd-display ";show-marks set default: ~A" *show-marks*))
(if (not *show-mix-waveforms*)
- (snd-display #__line__ ";show-mix-waveforms set default: ~A" *show-mix-waveforms*))
+ (snd-display ";show-mix-waveforms set default: ~A" *show-mix-waveforms*))
(if *show-selection-transform*
- (snd-display #__line__ ";show-selection-transform set default: ~A" *show-selection-transform*))
+ (snd-display ";show-selection-transform set default: ~A" *show-selection-transform*))
(if *show-y-zero*
- (snd-display #__line__ ";show-y-zero set default: ~A" *show-y-zero*))
+ (snd-display ";show-y-zero set default: ~A" *show-y-zero*))
(if *show-grid*
- (snd-display #__line__ ";show-grid set default: ~A" *show-grid*))
+ (snd-display ";show-grid set default: ~A" *show-grid*))
(if (fneq *grid-density* 1.0)
- (snd-display #__line__ ";grid-density set default: ~A" *grid-density*))
+ (snd-display ";grid-density set default: ~A" *grid-density*))
(if *show-sonogram-cursor*
- (snd-display #__line__ ";show-sonogram-cursor set default: ~A" *show-sonogram-cursor*))
+ (snd-display ";show-sonogram-cursor set default: ~A" *show-sonogram-cursor*))
(if (not (eqv? *sinc-width* 10 ))
- (snd-display #__line__ ";sinc-width set default: ~A" *sinc-width*))
+ (snd-display ";sinc-width set default: ~A" *sinc-width*))
(if (fneq *spectrum-end* 1.0)
- (snd-display #__line__ ";spectrum-end set default: ~A" *spectrum-end*))
+ (snd-display ";spectrum-end set default: ~A" *spectrum-end*))
(if (not (eqv? *spectro-hop* 4 ))
- (snd-display #__line__ ";spectro-hop set default: ~A" *spectro-hop*))
+ (snd-display ";spectro-hop set default: ~A" *spectro-hop*))
(if (fneq *spectrum-start* 0.0 )
- (snd-display #__line__ ";spectrum-start set default: ~A" *spectrum-start*))
+ (snd-display ";spectrum-start set default: ~A" *spectrum-start*))
(if (fneq *spectro-x-angle* (if (provided? 'gl) 300.0 90.0))
- (snd-display #__line__ ";spectro-x-angle set default: ~A" *spectro-x-angle*))
+ (snd-display ";spectro-x-angle set default: ~A" *spectro-x-angle*))
(if (fneq *spectro-x-scale* (if (provided? 'gl) 1.5 1.0))
- (snd-display #__line__ ";spectro-x-scale set default: ~A" *spectro-x-scale*))
+ (snd-display ";spectro-x-scale set default: ~A" *spectro-x-scale*))
(if (fneq *spectro-y-angle* (if (provided? 'gl) 320.0 0.0))
- (snd-display #__line__ ";spectro-y-angle set default: ~A" *spectro-y-angle*))
+ (snd-display ";spectro-y-angle set default: ~A" *spectro-y-angle*))
(if (fneq *spectro-y-scale* 1.0 )
- (snd-display #__line__ ";spectro-y-scale set default: ~A" *spectro-y-scale*))
+ (snd-display ";spectro-y-scale set default: ~A" *spectro-y-scale*))
(if (fneq *spectro-z-angle* (if (provided? 'gl) 0.0 358.0))
- (snd-display #__line__ ";spectro-z-angle set default: ~A" *spectro-z-angle*))
+ (snd-display ";spectro-z-angle set default: ~A" *spectro-z-angle*))
(if (fneq *spectro-z-scale* (if (provided? 'gl) 1.0 0.1))
- (snd-display #__line__ ";spectro-z-scale set default: ~A" *spectro-z-scale*))
+ (snd-display ";spectro-z-scale set default: ~A" *spectro-z-scale*))
(if (and *temp-dir* (not (equal? *temp-dir* "/home/bil/zap/tmp")))
- (snd-display #__line__ ";temp-dir set default: ~A" *temp-dir*))
+ (snd-display ";temp-dir set default: ~A" *temp-dir*))
(if (not (equal? *ladspa-dir* "" ))
- (snd-display #__line__ ";ladspa-dir set default: ~A" *ladspa-dir*))
+ (snd-display ";ladspa-dir set default: ~A" *ladspa-dir*))
(if (and *peak-env-dir* (not (equal? *peak-env-dir* "/home/bil/peaks")))
- (snd-display #__line__ ";peak-env-dir set default: ~A" *peak-env-dir*))
- (if (and (not (equal? *tiny-font* "6x12"))
- (not (equal? *tiny-font* "Sans 8")))
- (snd-display #__line__ ";tiny-font set default: ~A" *tiny-font*))
+ (snd-display ";peak-env-dir set default: ~A" *peak-env-dir*))
+ (if (not (member *tiny-font* '("6x12" "Sans 8")))
+ (snd-display ";tiny-font set default: ~A" *tiny-font*))
(if (not (equal? *transform-type* fourier-transform ))
- (snd-display #__line__ ";transform-type set default: ~A" *transform-type*))
+ (snd-display ";transform-type set default: ~A" *transform-type*))
(if (not (eq? *with-file-monitor* #t))
- (snd-display #__line__ ";with-file-monitor set default: ~A" *with-file-monitor*))
+ (snd-display ";with-file-monitor set default: ~A" *with-file-monitor*))
(if (not (eqv? *clm-table-size* 512))
- (snd-display #__line__ ";clm-table-size set default: ~A" *clm-table-size*))
- (if (not (eqv? *clm-table-size* 512))
- (snd-display #__line__ ";*clm-table-size*: ~A" *clm-table-size*))
+ (snd-display ";clm-table-size set default: ~A" *clm-table-size*))
(if (fneq *clm-default-frequency* 0.0)
- (snd-display #__line__ ";clm-default-frequency set default: ~A" *clm-default-frequency*))
+ (snd-display ";clm-default-frequency set default: ~A" *clm-default-frequency*))
(if (fneq *clm-default-frequency* 0.0)
- (snd-display #__line__ ";*clm-default-frequency*: ~A" *clm-default-frequency*))
+ (snd-display ";*clm-default-frequency*: ~A" *clm-default-frequency*))
(if (not (boolean? *with-verbose-cursor*))
- (snd-display #__line__ ";with-verbose-cursor set default: ~A" *with-verbose-cursor*))
+ (snd-display ";with-verbose-cursor set default: ~A" *with-verbose-cursor*))
(if (not (boolean? *with-inset-graph*))
- (snd-display #__line__ ";with-inset-graph set default: ~A" *with-inset-graph*))
+ (snd-display ";with-inset-graph set default: ~A" *with-inset-graph*))
(if (not *with-interrupts*)
- (snd-display #__line__ ";with-interrupts set default: ~A" *with-interrupts*))
+ (snd-display ";with-interrupts set default: ~A" *with-interrupts*))
(if *remember-sound-state*
- (snd-display #__line__ ";remember-sound-state set default: ~A" *remember-sound-state*))
+ (snd-display ";remember-sound-state set default: ~A" *remember-sound-state*))
(if *with-smpte-label*
- (snd-display #__line__ ";with-smpte-label set default: ~A" *with-smpte-label*))
+ (snd-display ";with-smpte-label set default: ~A" *with-smpte-label*))
(if (not (eq? *with-toolbar* (provided? 'snd-gtk)))
- (snd-display #__line__ ";with-toolbar set default: ~A" *with-toolbar*))
+ (snd-display ";with-toolbar set default: ~A" *with-toolbar*))
(if (not *with-tooltips*)
- (snd-display #__line__ ";with-tooltips set default: ~A" *with-tooltips*))
+ (snd-display ";with-tooltips set default: ~A" *with-tooltips*))
(if (not (boolean? *with-menu-icons*))
- (snd-display #__line__ ";with-menu-icons set default: ~A" *with-menu-icons*))
+ (snd-display ";with-menu-icons set default: ~A" *with-menu-icons*))
(if *save-as-dialog-src*
- (snd-display #__line__ ";save-as-dialog-src set default: ~A" *save-as-dialog-src*))
+ (snd-display ";save-as-dialog-src set default: ~A" *save-as-dialog-src*))
(if *save-as-dialog-auto-comment*
- (snd-display #__line__ ";save-as-dialog-auto-comment set default: ~A" *save-as-dialog-auto-comment*))
+ (snd-display ";save-as-dialog-auto-comment set default: ~A" *save-as-dialog-auto-comment*))
(if (not (boolean? *with-pointer-focus*))
- (snd-display #__line__ ";with-pointer-focus set default: ~A" *with-pointer-focus*))
+ (snd-display ";with-pointer-focus set default: ~A" *with-pointer-focus*))
(if (not (eqv? *wavelet-type* 0 ))
- (snd-display #__line__ ";wavelet-type set default: ~A" *wavelet-type*))
+ (snd-display ";wavelet-type set default: ~A" *wavelet-type*))
(if (not (equal? *time-graph-type* graph-once))
- (snd-display #__line__ ";time-graph-type set default: ~A" *time-graph-type*))
+ (snd-display ";time-graph-type set default: ~A" *time-graph-type*))
(if (not (eqv? *wavo-hop* 3 ))
- (snd-display #__line__ ";wavo-hop set default: ~A" *wavo-hop*))
+ (snd-display ";wavo-hop set default: ~A" *wavo-hop*))
(if (not (eqv? *wavo-trace* 64 ))
- (snd-display #__line__ ";wavo-trace set default: ~A" *wavo-trace*))
+ (snd-display ";wavo-trace set default: ~A" *wavo-trace*))
(if (not (eqv? *x-axis-style* 0 ))
- (snd-display #__line__ ";x-axis-style set default: ~A" *x-axis-style*))
+ (snd-display ";x-axis-style set default: ~A" *x-axis-style*))
(if (fneq *beats-per-minute* 60.0 )
- (snd-display #__line__ ";beats-per-minute set default: ~A" *beats-per-minute*))
+ (snd-display ";beats-per-minute set default: ~A" *beats-per-minute*))
(if (not (= *beats-per-measure* 4))
- (snd-display #__line__ ";beats-per-measure set default: ~A" *beats-per-measure*))
- (if (not (eqv? *zero-pad* 0))
- (snd-display #__line__ ";zero-pad set default: ~A" *zero-pad*))
+ (snd-display ";beats-per-measure set default: ~A" *beats-per-measure*))
(if (not (eqv? *zero-pad* 0))
- (snd-display #__line__ ";zero-pad set -123: ~A" *zero-pad*))
+ (snd-display ";zero-pad set default: ~A" *zero-pad*))
(if (not (null? (zero-pad #t #t)))
- (snd-display #__line__ ";zero-pad #t: ~A" (zero-pad #t #t)))
+ (snd-display ";zero-pad #t: ~A" (zero-pad #t #t)))
(if (not (eqv? *zoom-focus-style* 2 ))
- (snd-display #__line__ ";zoom-focus-style set default: ~A" *zoom-focus-style*))
+ (snd-display ";zoom-focus-style set default: ~A" *zoom-focus-style*))
(if (not (equal? *sync-style* sync-by-sound ))
- (snd-display #__line__ ";sync-style set default: ~A" *sync-style*))
+ (snd-display ";sync-style set default: ~A" *sync-style*))
(if (not (eqv? *mix-waveform-height* 20 ))
- (snd-display #__line__ ";mix-waveform-height set default: ~A" *mix-waveform-height*))
+ (snd-display ";mix-waveform-height set default: ~A" *mix-waveform-height*))
(if (not (eqv? *mix-tag-width* 6))
- (snd-display #__line__ ";mix-tag-width set default: ~A" *mix-tag-width*))
+ (snd-display ";mix-tag-width set default: ~A" *mix-tag-width*))
(if (not (eqv? *mix-tag-height* 14))
- (snd-display #__line__ ";mix-tag-height set default: ~A" *mix-tag-height*))
+ (snd-display ";mix-tag-height set default: ~A" *mix-tag-height*))
(if (not (eqv? *mark-tag-width* 10))
- (snd-display #__line__ ";mark-tag-width set default: ~A" *mark-tag-width*))
+ (snd-display ";mark-tag-width set default: ~A" *mark-tag-width*))
(if (not (eqv? *mark-tag-height* 4))
- (snd-display #__line__ ";mark-tag-height set default: ~A" *mark-tag-height*))
+ (snd-display ";mark-tag-height set default: ~A" *mark-tag-height*))
(if (not (equal? *region-graph-style* graph-lines))
- (snd-display #__line__ ";* region-graph-style set default: ~A" *region-graph-style*))
+ (snd-display ";* region-graph-style set default: ~A" *region-graph-style*))
(if *ask-about-unsaved-edits*
- (snd-display #__line__ ";* ask-about-unsaved-edits set default: ~A" *ask-about-unsaved-edits*))
+ (snd-display ";* ask-about-unsaved-edits set default: ~A" *ask-about-unsaved-edits*))
(if *show-full-range*
- (snd-display #__line__ ";* show-full-range set default: ~A" *show-full-range*))
+ (snd-display ";* show-full-range set default: ~A" *show-full-range*))
(if (fneq *initial-beg* 0.0)
- (snd-display #__line__ ";* initial-beg set default: ~A" *initial-beg*))
+ (snd-display ";* initial-beg set default: ~A" *initial-beg*))
(if (fneq *initial-dur* 0.1)
- (snd-display #__line__ ";* initial-dur set default: ~A" *initial-dur*))
+ (snd-display ";* initial-dur set default: ~A" *initial-dur*))
(if *ask-before-overwrite*
- (snd-display #__line__ ";* ask-before-overwrite set default: ~A" *ask-before-overwrite*))
+ (snd-display ";* ask-before-overwrite set default: ~A" *ask-before-overwrite*))
(if (not *auto-resize*)
- (snd-display #__line__ ";* auto-resize set default: ~A" *auto-resize*))
+ (snd-display ";* auto-resize set default: ~A" *auto-resize*))
(if *auto-update*
- (snd-display #__line__ ";* auto-update set default: ~A" *auto-update*))
+ (snd-display ";* auto-update set default: ~A" *auto-update*))
(if (not (eqv? *channel-style* 1 ))
- (snd-display #__line__ ";* channel-style set default: ~A" *channel-style*))
+ (snd-display ";* channel-style set default: ~A" *channel-style*))
(if (and (fneq *color-cutoff* 0.003 ) (fneq *color-cutoff* 0.001))
- (snd-display #__line__ ";* color-cutoff set default: ~A" *color-cutoff*))
+ (snd-display ";* color-cutoff set default: ~A" *color-cutoff*))
(if (not (eq? *color-inverted* #t))
- (snd-display #__line__ ";* color-inverted set default: ~A" *color-inverted*))
+ (snd-display ";* color-inverted set default: ~A" *color-inverted*))
(if (fneq *color-scale* 1.0 )
- (snd-display #__line__ ";* color-scale set default: ~A" *color-scale*))
+ (snd-display ";* color-scale set default: ~A" *color-scale*))
(if (fneq *auto-update-interval* 60.0 )
- (snd-display #__line__ ";* auto-update-interval set default: ~A" *auto-update-interval*))
+ (snd-display ";* auto-update-interval set default: ~A" *auto-update-interval*))
(if (fneq *cursor-update-interval* 0.05 )
- (snd-display #__line__ ";* cursor-update-interval set default: ~A" *cursor-update-interval*))
+ (snd-display ";* cursor-update-interval set default: ~A" *cursor-update-interval*))
(if (not (= *cursor-location-offset* 0))
- (snd-display #__line__ ";* cursor-location-offset set default: ~A" *cursor-location-offset*))
+ (snd-display ";* cursor-location-offset set default: ~A" *cursor-location-offset*))
(if (not (eq? *dac-combines-channels* #t))
- (snd-display #__line__ ";* dac-combines-channels set default: ~A" *dac-combines-channels*))
+ (snd-display ";* dac-combines-channels set default: ~A" *dac-combines-channels*))
(if (not (eqv? *dac-size* 256 ))
- (snd-display #__line__ ";* dac-size set default: ~A" *dac-size*))
+ (snd-display ";* dac-size set default: ~A" *dac-size*))
(if *clipping*
- (snd-display #__line__ ";* clipping set default: ~A" *clipping*))
+ (snd-display ";* clipping set default: ~A" *clipping*))
(if (not (eqv? *default-output-chans* 1 ))
- (snd-display #__line__ ";* default-output-chans set default: ~A" *default-output-chans*))
- (if (and (not (equal? *default-output-sample-type* mus-bdouble))
- (not (equal? *default-output-sample-type* mus-ldouble)))
- (snd-display #__line__ ";* default-output-sample-type set default: ~A" *default-output-sample-type*))
+ (snd-display ";* default-output-chans set default: ~A" *default-output-chans*))
+ (if (not (or (equal? *default-output-sample-type* mus-bdouble)
+ (equal? *default-output-sample-type* mus-ldouble)))
+ (snd-display ";* default-output-sample-type set default: ~A" *default-output-sample-type*))
(if (not (eqv? *default-output-srate* 44100 ))
- (snd-display #__line__ ";* default-output-srate set default: ~A" *default-output-srate*))
+ (snd-display ";* default-output-srate set default: ~A" *default-output-srate*))
(if (not (equal? *default-output-header-type* mus-next))
- (snd-display #__line__ ";* default-output-header-type set default: ~A" *default-output-header-type*))
+ (snd-display ";* default-output-header-type set default: ~A" *default-output-header-type*))
(if (not (eqv? *dot-size* 1 ))
- (snd-display #__line__ ";* dot-size set default: ~A" *dot-size*))
+ (snd-display ";* dot-size set default: ~A" *dot-size*))
(if (not (eqv? *cursor-size* 15 ))
- (snd-display #__line__ ";* cursor-size set default: ~A" *cursor-size*))
+ (snd-display ";* cursor-size set default: ~A" *cursor-size*))
(if (not (equal? *cursor-style* cursor-cross ))
- (snd-display #__line__ ";* cursor-style set default: ~A" *cursor-style*))
+ (snd-display ";* cursor-style set default: ~A" *cursor-style*))
(if (not (equal? *tracking-cursor-style* cursor-line ))
- (snd-display #__line__ ";* tracking-cursor-style set default: ~A" *tracking-cursor-style*))
+ (snd-display ";* tracking-cursor-style set default: ~A" *tracking-cursor-style*))
(if (fneq *enved-base* 1.0 )
- (snd-display #__line__ ";* enved-base set default: ~A" *enved-base*))
+ (snd-display ";* enved-base set default: ~A" *enved-base*))
(if (not (eqv? *enved-filter-order* 40))
- (snd-display #__line__ ";* enved-filter-order set default: ~A" *enved-filter-order*))
+ (snd-display ";* enved-filter-order set default: ~A" *enved-filter-order*))
(if (not (equal? *enved-style* envelope-linear ))
- (snd-display #__line__ ";* enved-style set default: ~A" *enved-style*))
+ (snd-display ";* enved-style set default: ~A" *enved-style*))
(if (fneq *enved-power* 3.0)
- (snd-display #__line__ ";* enved-power set default: ~A" *enved-power*))
+ (snd-display ";* enved-power set default: ~A" *enved-power*))
(if (not (eqv? *enved-target* 0 ))
- (snd-display #__line__ ";* enved-target set default: ~A" *enved-target*))
+ (snd-display ";* enved-target set default: ~A" *enved-target*))
(if *enved-wave?*
- (snd-display #__line__ ";* enved-wave? set default: ~A" *enved-wave?*))
+ (snd-display ";* enved-wave? set default: ~A" *enved-wave?*))
(if (not (equal? *eps-file* "snd.eps" ))
- (snd-display #__line__ ";* eps-file set default: ~A" *eps-file*))
+ (snd-display ";* eps-file set default: ~A" *eps-file*))
(if (fneq *eps-bottom-margin* 0.0)
- (snd-display #__line__ ";* eps-bottom-margin set default: ~A" *eps-bottom-margin*))
+ (snd-display ";* eps-bottom-margin set default: ~A" *eps-bottom-margin*))
(if (fneq *eps-left-margin* 0.0)
- (snd-display #__line__ ";* eps-left-margin set default: ~A" *eps-left-margin*))
+ (snd-display ";* eps-left-margin set default: ~A" *eps-left-margin*))
(if (fneq *eps-size* 1.0)
- (snd-display #__line__ ";* eps-size set default: ~A" *eps-size*))
+ (snd-display ";* eps-size set default: ~A" *eps-size*))
(if (fneq *fft-window-alpha* 0.0 )
- (snd-display #__line__ ";* fft-window-alpha set default: ~A" *fft-window-alpha*))
+ (snd-display ";* fft-window-alpha set default: ~A" *fft-window-alpha*))
(if (fneq *fft-window-beta* 0.0 )
- (snd-display #__line__ ";* fft-window-beta set default: ~A" *fft-window-beta*))
+ (snd-display ";* fft-window-beta set default: ~A" *fft-window-beta*))
(if *fft-log-frequency*
- (snd-display #__line__ ";* fft-log-frequency set default: ~A" *fft-log-frequency*))
+ (snd-display ";* fft-log-frequency set default: ~A" *fft-log-frequency*))
(if *fft-log-magnitude*
- (snd-display #__line__ ";* fft-log-magnitude set default: ~A" *fft-log-magnitude*))
+ (snd-display ";* fft-log-magnitude set default: ~A" *fft-log-magnitude*))
(if *fft-with-phases*
- (snd-display #__line__ ";* fft-with-phases set default: ~A" *fft-with-phases*))
- (if (not (member *transform-size* (list 1024 4096)))
- (snd-display #__line__ ";* transform-size set default: ~A" *transform-size*))
+ (snd-display ";* fft-with-phases set default: ~A" *fft-with-phases*))
+ (if (not (member *transform-size* '(1024 4096)))
+ (snd-display ";* transform-size set default: ~A" *transform-size*))
(if (not (equal? *transform-graph-type* graph-once))
- (snd-display #__line__ ";* transform-graph-type set default: ~A" *transform-graph-type*))
+ (snd-display ";* transform-graph-type set default: ~A" *transform-graph-type*))
(if (not (eqv? *fft-window* 6 ))
- (snd-display #__line__ ";* fft-window set default: ~A" *fft-window*))
+ (snd-display ";* fft-window set default: ~A" *fft-window*))
(if (not (eqv? *graph-cursor* 34))
- (snd-display #__line__ ";* graph-cursor set default: ~A" *graph-cursor*))
+ (snd-display ";* graph-cursor set default: ~A" *graph-cursor*))
(if (not (equal? *graph-style* graph-lines ))
- (snd-display #__line__ ";* graph-style set default: ~A" *graph-style*))
+ (snd-display ";* graph-style set default: ~A" *graph-style*))
(if (not *graphs-horizontal*)
- (snd-display #__line__ ";* graphs-horizontal set default: ~A" *graphs-horizontal*))
+ (snd-display ";* graphs-horizontal set default: ~A" *graphs-horizontal*))
(if (not (equal? *html-dir* "."))
- (snd-display #__line__ ";* html-dir set default: ~A" *html-dir*))
+ (snd-display ";* html-dir set default: ~A" *html-dir*))
(if (not (equal? *html-program* "firefox"))
- (snd-display #__line__ ";* html-program set default: ~A" *html-program*))
+ (snd-display ";* html-program set default: ~A" *html-program*))
(if (not *just-sounds*)
- (snd-display #__line__ ";* just-sounds set default: ~A" *just-sounds*))
+ (snd-display ";* just-sounds set default: ~A" *just-sounds*))
(if (not (eqv? *max-transform-peaks* 100))
- (snd-display #__line__ ";* max-transform-peaks set default: ~A" *max-transform-peaks*))
- (if (not (eqv? *max-transform-peaks* 100))
- (snd-display #__line__ ";* max-transform-peaks set -123: ~A" *max-transform-peaks*))
+ (snd-display ";* max-transform-peaks set default: ~A" *max-transform-peaks*))
(if (not (eqv? *max-regions* 16 ))
- (snd-display #__line__ ";* max-regions set default: ~A" *max-regions*))
+ (snd-display ";* max-regions set default: ~A" *max-regions*))
(if (fneq *min-dB* -60.0 )
- (snd-display #__line__ ";* min-dB set default: ~A" *min-dB*))
+ (snd-display ";* min-dB set default: ~A" *min-dB*))
(if (fneq *log-freq-start* 32.0 )
- (snd-display #__line__ ";* log-freq-start set default: ~A" *log-freq-start*))
+ (snd-display ";* log-freq-start set default: ~A" *log-freq-start*))
(if (not (eq? *selection-creates-region* #t ))
- (snd-display #__line__ ";* selection-creates-region set default: ~A" *selection-creates-region*))
+ (snd-display ";* selection-creates-region set default: ~A" *selection-creates-region*))
(if (not (equal? *transform-normalization* normalize-by-channel))
- (snd-display #__line__ ";* transform-normalization set default: ~A" *transform-normalization*))
+ (snd-display ";* transform-normalization set default: ~A" *transform-normalization*))
(if (and with-motif
(not (eqv? *view-files-sort* 0 )) )
- (snd-display #__line__ ";* view-files-sort set default: ~A" *view-files-sort*))
+ (snd-display ";* view-files-sort set default: ~A" *view-files-sort*))
(if (not (eqv? *play-arrow-size* 10 ))
- (snd-display #__line__ ";* play-arrow-size set default: ~A" *play-arrow-size*))
+ (snd-display ";* play-arrow-size set default: ~A" *play-arrow-size*))
(if (not (equal? *save-state-file* "saved-snd.scm" ))
- (snd-display #__line__ ";* save-state-file set default: ~A" *save-state-file*))
+ (snd-display ";* save-state-file set default: ~A" *save-state-file*))
(if (not (eqv? *show-axes* 1))
- (snd-display #__line__ ";* show-axes set default: ~A" *show-axes*))
+ (snd-display ";* show-axes set default: ~A" *show-axes*))
(if (not *show-marks*)
- (snd-display #__line__ ";* show-marks set default: ~A" *show-marks*))
+ (snd-display ";* show-marks set default: ~A" *show-marks*))
(if (not *show-mix-waveforms*)
- (snd-display #__line__ ";* show-mix-waveforms set default: ~A" *show-mix-waveforms*))
+ (snd-display ";* show-mix-waveforms set default: ~A" *show-mix-waveforms*))
(if *show-selection-transform*
- (snd-display #__line__ ";* show-selection-transform set default: ~A" *show-selection-transform*))
+ (snd-display ";* show-selection-transform set default: ~A" *show-selection-transform*))
(if *show-y-zero*
- (snd-display #__line__ ";* show-y-zero set default: ~A" *show-y-zero*))
+ (snd-display ";* show-y-zero set default: ~A" *show-y-zero*))
(if *show-grid*
- (snd-display #__line__ ";* show-grid set default: ~A" *show-grid*))
+ (snd-display ";* show-grid set default: ~A" *show-grid*))
(if (fneq *grid-density* 1.0)
- (snd-display #__line__ ";* grid-density set default: ~A" *grid-density*))
+ (snd-display ";* grid-density set default: ~A" *grid-density*))
(if *show-sonogram-cursor*
- (snd-display #__line__ ";* show-sonogram-cursor set default: ~A" *show-sonogram-cursor*))
+ (snd-display ";* show-sonogram-cursor set default: ~A" *show-sonogram-cursor*))
(if (not (eqv? *sinc-width* 10 ))
- (snd-display #__line__ ";* sinc-width set default: ~A" *sinc-width*))
+ (snd-display ";* sinc-width set default: ~A" *sinc-width*))
(if (fneq *spectrum-end* 1.0)
- (snd-display #__line__ ";* spectrum-end set default: ~A" *spectrum-end*))
+ (snd-display ";* spectrum-end set default: ~A" *spectrum-end*))
(if (not (eqv? *spectro-hop* 4 ))
- (snd-display #__line__ ";* spectro-hop set default: ~A" *spectro-hop*))
+ (snd-display ";* spectro-hop set default: ~A" *spectro-hop*))
(if (fneq *spectrum-start* 0.0 )
- (snd-display #__line__ ";* spectrum-start set default: ~A" *spectrum-start*))
+ (snd-display ";* spectrum-start set default: ~A" *spectrum-start*))
(if (fneq *spectro-x-angle* (if (provided? 'gl) 300.0 90.0))
- (snd-display #__line__ ";* spectro-x-angle set default: ~A" *spectro-x-angle*))
+ (snd-display ";* spectro-x-angle set default: ~A" *spectro-x-angle*))
(if (fneq *spectro-x-scale* (if (provided? 'gl) 1.5 1.0))
- (snd-display #__line__ ";* spectro-x-scale set default: ~A" *spectro-x-scale*))
+ (snd-display ";* spectro-x-scale set default: ~A" *spectro-x-scale*))
(if (fneq *spectro-y-angle* (if (provided? 'gl) 320.0 0.0))
- (snd-display #__line__ ";* spectro-y-angle set default: ~A" *spectro-y-angle*))
+ (snd-display ";* spectro-y-angle set default: ~A" *spectro-y-angle*))
(if (fneq *spectro-y-scale* 1.0 )
- (snd-display #__line__ ";* spectro-y-scale set default: ~A" *spectro-y-scale*))
+ (snd-display ";* spectro-y-scale set default: ~A" *spectro-y-scale*))
(if (fneq *spectro-z-angle* (if (provided? 'gl) 0.0 358.0))
- (snd-display #__line__ ";* spectro-z-angle set default: ~A" *spectro-z-angle*))
+ (snd-display ";* spectro-z-angle set default: ~A" *spectro-z-angle*))
(if (fneq *spectro-z-scale* (if (provided? 'gl) 1.0 0.1))
- (snd-display #__line__ ";* spectro-z-scale set default: ~A" *spectro-z-scale*))
- (if (and (not (equal? *tiny-font* "6x12"))
- (not (equal? *tiny-font* "Sans 8")))
- (snd-display #__line__ ";* tiny-font set default: ~A" *tiny-font*))
+ (snd-display ";* spectro-z-scale set default: ~A" *spectro-z-scale*))
+ (if (not (member *tiny-font* '("6x12" "Sans 8")))
+ (snd-display ";* tiny-font set default: ~A" *tiny-font*))
(if (not *with-file-monitor*)
- (snd-display #__line__ ";* with-file-monitor set default: ~A" *with-file-monitor*))
+ (snd-display ";* with-file-monitor set default: ~A" *with-file-monitor*))
(if (not *with-interrupts*)
- (snd-display #__line__ ";* with-interrupts set default: ~A" *with-interrupts*))
+ (snd-display ";* with-interrupts set default: ~A" *with-interrupts*))
(if *remember-sound-state*
- (snd-display #__line__ ";* remember-sound-state set default: ~A" *remember-sound-state*))
+ (snd-display ";* remember-sound-state set default: ~A" *remember-sound-state*))
(if *with-smpte-label*
- (snd-display #__line__ ";* with-smpte-label set default: ~A" *with-smpte-label*))
+ (snd-display ";* with-smpte-label set default: ~A" *with-smpte-label*))
(if (not (eq? *with-toolbar* (provided? 'snd-gtk)))
- (snd-display #__line__ ";* with-toolbar set default: ~A" *with-toolbar*))
+ (snd-display ";* with-toolbar set default: ~A" *with-toolbar*))
(if (not *with-tooltips*)
- (snd-display #__line__ ";* with-tooltips set default: ~A" *with-tooltips*))
+ (snd-display ";* with-tooltips set default: ~A" *with-tooltips*))
(if *save-as-dialog-src*
- (snd-display #__line__ ";* save-as-dialog-src set default: ~A" *save-as-dialog-src*))
+ (snd-display ";* save-as-dialog-src set default: ~A" *save-as-dialog-src*))
(if *save-as-dialog-auto-comment*
- (snd-display #__line__ ";* save-as-dialog-auto-comment set default: ~A" *save-as-dialog-auto-comment*))
+ (snd-display ";* save-as-dialog-auto-comment set default: ~A" *save-as-dialog-auto-comment*))
(if (not (eqv? *wavelet-type* 0 ))
- (snd-display #__line__ ";* wavelet-type set default: ~A" *wavelet-type*))
+ (snd-display ";* wavelet-type set default: ~A" *wavelet-type*))
(if (not (equal? *time-graph-type* graph-once))
- (snd-display #__line__ ";* time-graph-type set default: ~A" *time-graph-type*))
+ (snd-display ";* time-graph-type set default: ~A" *time-graph-type*))
(if (not (eqv? *wavo-hop* 3 ))
- (snd-display #__line__ ";* wavo-hop set default: ~A" *wavo-hop*))
+ (snd-display ";* wavo-hop set default: ~A" *wavo-hop*))
(if (not (eqv? *wavo-trace* 64 ))
- (snd-display #__line__ ";* wavo-trace set default: ~A" *wavo-trace*))
+ (snd-display ";* wavo-trace set default: ~A" *wavo-trace*))
(if (not (eqv? *x-axis-style* 0 ))
- (snd-display #__line__ ";* x-axis-style set default: ~A" *x-axis-style*))
+ (snd-display ";* x-axis-style set default: ~A" *x-axis-style*))
(if (fneq *beats-per-minute* 60.0 )
- (snd-display #__line__ ";* beats-per-minute set default: ~A" *beats-per-minute*))
+ (snd-display ";* beats-per-minute set default: ~A" *beats-per-minute*))
(if (not (= *beats-per-measure* 4))
- (snd-display #__line__ ";* beats-per-measure set default: ~A" *beats-per-measure*))
+ (snd-display ";* beats-per-measure set default: ~A" *beats-per-measure*))
(if (not (eqv? *zero-pad* 0))
- (snd-display #__line__ ";* zero-pad set default: ~A" *zero-pad*))
+ (snd-display ";* zero-pad set default: ~A" *zero-pad*))
(if (not (eqv? *zoom-focus-style* 2 ))
- (snd-display #__line__ ";* zoom-focus-style set default: ~A" *zoom-focus-style*))
+ (snd-display ";* zoom-focus-style set default: ~A" *zoom-focus-style*))
(if (not (equal? *sync-style* sync-by-sound ))
- (snd-display #__line__ ";* sync-style set default: ~A" *sync-style*))
+ (snd-display ";* sync-style set default: ~A" *sync-style*))
(if (not (eqv? *mix-waveform-height* 20 ))
- (snd-display #__line__ ";* mix-waveform-height set default: ~A" *mix-waveform-height*))
+ (snd-display ";* mix-waveform-height set default: ~A" *mix-waveform-height*))
(if (not (eqv? *mix-tag-width* 6))
- (snd-display #__line__ ";* mix-tag-width set default: ~A" *mix-tag-width*))
+ (snd-display ";* mix-tag-width set default: ~A" *mix-tag-width*))
(if (not (eqv? *mix-tag-height* 14))
- (snd-display #__line__ ";* mix-tag-height set default: ~A" *mix-tag-height*))
+ (snd-display ";* mix-tag-height set default: ~A" *mix-tag-height*))
(if (not (eqv? *mark-tag-width* 10))
- (snd-display #__line__ ";* mark-tag-width set default: ~A" *mark-tag-width*))
+ (snd-display ";* mark-tag-width set default: ~A" *mark-tag-width*))
(if (not (eqv? *mark-tag-height* 4))
- (snd-display #__line__ ";* mark-tag-height set default: ~A" *mark-tag-height*))
+ (snd-display ";* mark-tag-height set default: ~A" *mark-tag-height*))
(if (and with-motif
(not (= (view-files-sort) 0)))
- (snd-display #__line__ ";view-files-sort def: ~A" (view-files-sort)))
+ (snd-display ";view-files-sort def: ~A" (view-files-sort)))
- (if (> most-positive-fixnum (expt 2 36))
- (begin
- (let ((old-max-malloc *mus-max-malloc*))
- (set! *mus-max-malloc* (expt 2 36))
- (if (not (= *mus-max-malloc* (expt 2 36)))
- (snd-display #__line__ ";mus-max-malloc as bignum: ~A" *mus-max-malloc*))
- (set! *mus-max-malloc* old-max-malloc))
-
- (let ((old-max-table-size *mus-max-table-size*))
- (set! *mus-max-table-size* (expt 2 36))
- (if (not (= *mus-max-table-size* (expt 2 36)))
- (snd-display #__line__ ";mus-max-table-size as bignum: ~A" *mus-max-table-size*))
- (set! *mus-max-table-size* old-max-table-size))))
+ (let ((old-max-malloc *mus-max-malloc*))
+ (set! *mus-max-malloc* (expt 2 36))
+ (if (not (= *mus-max-malloc* (expt 2 36)))
+ (snd-display ";mus-max-malloc as bignum: ~A" *mus-max-malloc*))
+ (set! *mus-max-malloc* old-max-malloc))
+
+ (let ((old-max-table-size *mus-max-table-size*))
+ (set! *mus-max-table-size* (expt 2 36))
+ (if (not (= *mus-max-table-size* (expt 2 36)))
+ (snd-display ";mus-max-table-size as bignum: ~A" *mus-max-table-size*))
+ (set! *mus-max-table-size* old-max-table-size))
(if (not (provided? 'snd-gtk))
(for-each
(lambda (func name)
(let ((val (func)))
(set! (func) "8x123")
- (if (or (not (string? (func)))
- (not (string=? val (func))))
- (snd-display #__line__ ";set ~A to bogus value: ~A ~A" name val (func)))))
+ (if (not (and (string? (func))
+ (string=? val (func))))
+ (snd-display ";set ~A to bogus value: ~A ~A" name val (func)))))
(list axis-label-font axis-numbers-font tiny-font peaks-font bold-peaks-font)
(list 'axis-label-font 'axis-numbers-font 'tiny-font 'peaks-font 'bold-peaks-font)))
@@ -1250,14 +1089,13 @@
(lambda (lst)
(if (pair? lst)
(begin
- (if (and (not (equal? (cadr lst) (caddr lst)))
- (or (not (pair? (caddr lst)))
- (not (member (cadr lst) (caddr lst)))))
- (if (and (number? (caddr lst))
- (not (rational? (caddr lst))))
- (if (fneq (cadr lst) (caddr lst))
- (snd-display #__line__ ";~A is not ~A (~A)" (car lst) (caddr lst) (cadr lst)))
- (snd-display #__line__ ";~A is not ~A (~A)" (car lst) (caddr lst) (cadr lst))))
+ (if (and (not (or (equal? (cadr lst) (caddr lst))
+ (and (pair? (caddr lst))
+ (member (cadr lst) (caddr lst)))))
+ (or (not (number? (caddr lst)))
+ (rational? (caddr lst))
+ (fneq (cadr lst) (caddr lst)))) ; right! not my fault!
+ (snd-display ";~A is not ~A (~A)" (car lst) (caddr lst) (cadr lst)))
(test-defaults (cdddr lst)))))))
(for-each close-sound (sounds)) ; in case others opened elsewhere
@@ -1426,42 +1264,42 @@
'zero-pad *zero-pad* 0
'zoom-focus-style *zoom-focus-style* 2
))
- (if *snd-opened-sound* (snd-display #__line__ ";*snd-opened-sound*: ~A" *snd-opened-sound*))
+ (if *snd-opened-sound* (snd-display ";*snd-opened-sound*: ~A" *snd-opened-sound*))
(let ((s (open-sound "oboe.snd")))
(letrec ((test-vars
(lambda (lst)
- (if (pair? lst)
- (let* ((args (car lst))
- (name (args 0))
- (getfnc (args 1))
- (setfnc (lambda (val) (set! (getfnc) val)))
- (initval (args 2))
- (newval (args 3))
- (star-name (args 4)))
- (setfnc newval)
- (let ((nowval (symbol->value star-name)))
- (if (and (not (equal? newval nowval))
- (or (not (list? newval))
- (not (feql newval nowval))))
+ (when (pair? lst)
+ (let* ((args (car lst))
+ (name (args 0))
+ (getfnc (args 1))
+ (setfnc (lambda (val) (set! (getfnc) val)))
+ (initval (args 2))
+ (newval (args 3))
+ (star-name (args 4)))
+ (setfnc newval)
+ (let ((nowval (symbol->value star-name)))
+ (if (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (if (and (number? newval) (not (rational? newval)))
+ (if (> (abs (- newval nowval)) .01)
+ (snd-display ";~A is not ~A (~A)" star-name newval nowval))
+ (snd-display ";~A is not ~A (~A)" star-name newval nowval)))
+ (eval `(set! ,star-name ,initval))
+ (if (not (morally-equal? (getfnc) initval))
+ (snd-display ";* ~A is not ~A" name initval))
+ (eval `(set! ,star-name ,newval))
+ (let ((nowval (getfnc)))
+ (if (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
(if (and (number? newval) (not (rational? newval)))
(if (> (abs (- newval nowval)) .01)
- (snd-display #__line__ ";~A is not ~A (~A)" star-name newval nowval))
- (snd-display #__line__ ";~A is not ~A (~A)" star-name newval nowval)))
- (eval `(set! ,star-name ,initval))
- (if (not (morally-equal? (getfnc) initval))
- (snd-display #__line__ ";* ~A is not ~A" name initval))
- (eval `(set! ,star-name ,newval))
- (let ((nowval (getfnc)))
- (if (and (not (equal? newval nowval))
- (or (not (list? newval))
- (not (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display #__line__ ";set! ~A is not ~A (~A)" star-name newval nowval))
- (snd-display #__line__ ";set! ~A is not ~A (~A)" star-name newval nowval)))
- (setfnc initval))
- (test-vars (cdr lst))))))))
+ (snd-display ";set! ~A is not ~A (~A)" star-name newval nowval))
+ (snd-display ";set! ~A is not ~A (~A)" star-name newval nowval)))
+ (setfnc initval))
+ (test-vars (cdr lst))))))))
(test-vars
(list
(list 'ask-about-unsaved-edits ask-about-unsaved-edits #f #t '*ask-about-unsaved-edits*)
@@ -1522,6 +1360,7 @@
(list 'initial-dur initial-dur 0.1 1.0 '*initial-dur*)
(list 'just-sounds just-sounds #f #t '*just-sounds*)
(list 'listener-prompt listener-prompt ">" ":" '*listener-prompt*)
+ (list 'stdin-prompt stdin-prompt ">" "" '*stdin-prompt*)
(list 'max-transform-peaks max-transform-peaks 100 10 '*max-transform-peaks*)
(list 'max-regions max-regions 16 6 '*max-regions*)
(list 'min-dB min-dB -60.0 -90.0 '*min-dB*)
@@ -1564,7 +1403,10 @@
(list 'speed-control-style speed-control-style 0 1 '*speed-control-style*)
(list 'speed-control-tones speed-control-tones 12 18 '*speed-control-tones*)
(list 'sync-style sync-style sync-by-sound sync-all '*sync-style*)
- (list 'tiny-font tiny-font (if (provided? 'snd-gtk) "Sans 8" "6x12") (if (provided? 'snd-gtk) "Monospace 10" "9x15") '*tiny-font*)
+ (list 'tiny-font tiny-font (if (provided? 'snd-gtk)
+ (values "Sans 8" "Monospace 10")
+ (values "6x12" "9x15"))
+ '*tiny-font*)
(list 'with-verbose-cursor with-verbose-cursor #f #t '*with-verbose-cursor*)
(list 'wavelet-type wavelet-type 0 1 '*wavelet-type*)
(list 'time-graph-type time-graph-type graph-once graph-as-wavogram '*time-graph-type*)
@@ -1593,325 +1435,323 @@
;;; ---------------- test 2: headers ----------------
(define (snd_test_2)
- (if (string? sf-dir)
- (letrec ((test-headers
- (lambda (base-files)
- (if (pair? base-files)
- (let ((testf (car base-files)))
- (let ((file (string-append sf-dir (testf 0))))
- (if (file-exists? file)
- (begin
- (if (not (equal? (mus-sound-chans file) (testf 1)))
- (snd-display #__line__ ";~A: chans ~A is not ~A"
- (testf 0)
- (mus-sound-chans file)
- (testf 1)))
- (if (not (equal? (mus-sound-srate file) (testf 2)))
- (snd-display #__line__ ";~A: srate ~A is not ~A"
- (testf 0)
- (mus-sound-srate file)
- (testf 2)))
- (if (fneq (mus-sound-duration file) (testf 3))
- (snd-display #__line__ ";~A: duration ~A is not ~A"
- (testf 0)
- (mus-sound-duration file)
- (testf 3)))
- (if (and (not (= (mus-sound-sample-type file) mus-unknown-sample))
- (not (= (mus-sound-header-type file) 27)) ; bogus header on test case (comdisco)
- (< (+ (mus-sound-length file) 1)
- (* (mus-sound-datum-size file) (mus-sound-duration file)
- (mus-sound-srate file) (mus-sound-chans file))))
- (snd-display #__line__ ";mus-sound-length ~A: ~A (~A)" file
- (mus-sound-length file)
- (* (mus-sound-duration file) (mus-sound-srate file)
- (mus-sound-chans file) (mus-sound-datum-size file))))
- (if (fneq (/ (mus-sound-framples file) (mus-sound-srate file)) (mus-sound-duration file))
- (snd-display #__line__ ";mus-sound-framples ~A: ~A (~A ~A)" file
- (mus-sound-framples file)
- (mus-sound-duration file)
- (/ (mus-sound-framples file) (mus-sound-srate file))))
- (if (> (abs (- (mus-sound-framples file) (/ (mus-sound-samples file) (mus-sound-chans file)))) 1)
- (snd-display #__line__ ";mus-sound-samples ~A: ~A ~A" file
- (mus-sound-samples file)
- (* (mus-sound-framples file) (mus-sound-chans file))))
- (if (not (equal? (mus-header-type-name (mus-sound-header-type file)) (testf 4)))
- (snd-display #__line__ ";~A: type ~A is not ~A"
- (testf 0)
- (mus-header-type-name (mus-sound-header-type file))
- (testf 4)))
- (if (not (equal? (mus-sample-type-name (mus-sound-sample-type file)) (testf 5)))
- (snd-display #__line__ ";~A: type ~A is not ~A"
- (testf 0)
- (mus-sample-type-name (mus-sound-sample-type file))
- (testf 5)))
- (let ((lst (mus-sound-loop-info file)))
- (if (> (length testf) 6)
- (begin
- (if (not (equal? (car lst) (testf 6)))
- (snd-display #__line__ ";~A: loop start: ~A" (car lst) (testf 6)))
- (if (not (equal? (cadr lst) (testf 7)))
- (snd-display #__line__ ";~A: loop end: ~A" (cadr lst) (testf 7))))
- (if (pair? lst)
- (snd-display #__line__ ";~A thinks it has loop info: ~A" file lst))))
- (mus-sound-forget file))
- (snd-display #__line__ ";~A missing?" file))
- (test-headers (cdr base-files))))))))
-
- ;; need to make sure raw defaults are consistent with following tests
- (let ((ind (open-raw-sound :file (string-append sf-dir "addf8.nh") :channels 2 :srate 44100 :sample-type mus-bshort)))
- (if (sound? ind) (close-sound ind)))
- (catch #t
- (lambda ()
- (if (not (= (mus-sound-header-type (string-append sf-dir "midi60.mid")) -1)) (snd-display #__line__ ";midi60?")))
- (lambda args args))
- (test-headers
- (list
- (list "5_secs.aiff" 1 44100 5.303107 "AIFF" "big endian short (16 bits)")
- (list "8svx-8.snd" 1 22050 1.88766443729401 "SVX8" "signed byte (8 bits)")
- (list "Fnonull.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
- (list "Pmiscck.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
- (list "Pmiscck.wav" 1 8000 0.00112499995157123 "RIFF" "mulaw (8 bits)")
+ (when (string? sf-dir)
+ (letrec ((test-headers
+ (lambda (base-files)
+ (when (pair? base-files)
+ (let* ((testf (car base-files))
+ (file (string-append sf-dir (testf 0))))
+ (if (not (file-exists? file))
+ (snd-display ";~A missing?" file)
+ (begin
+ (if (not (equal? (mus-sound-chans file) (testf 1)))
+ (snd-display ";~A: chans ~A is not ~A"
+ (testf 0)
+ (mus-sound-chans file)
+ (testf 1)))
+ (if (not (equal? (mus-sound-srate file) (testf 2)))
+ (snd-display ";~A: srate ~A is not ~A"
+ (testf 0)
+ (mus-sound-srate file)
+ (testf 2)))
+ (if (fneq (mus-sound-duration file) (testf 3))
+ (snd-display ";~A: duration ~A is not ~A"
+ (testf 0)
+ (mus-sound-duration file)
+ (testf 3)))
+ (if (not (or (= (mus-sound-sample-type file) mus-unknown-sample)
+ (= (mus-sound-header-type file) 27)
+ (>= (+ (mus-sound-length file) 1)
+ (* (mus-sound-datum-size file) (mus-sound-duration file) (mus-sound-srate file)
+ (mus-sound-chans file)))))
+ (snd-display ";mus-sound-length ~A: ~A (~A)" file
+ (mus-sound-length file)
+ (* (mus-sound-duration file) (mus-sound-srate file)
+ (mus-sound-chans file) (mus-sound-datum-size file))))
+ (if (fneq (/ (mus-sound-framples file) (mus-sound-srate file)) (mus-sound-duration file))
+ (snd-display ";mus-sound-framples ~A: ~A (~A ~A)" file
+ (mus-sound-framples file)
+ (mus-sound-duration file)
+ (/ (mus-sound-framples file) (mus-sound-srate file))))
+ (if (> (abs (- (mus-sound-framples file) (/ (mus-sound-samples file) (mus-sound-chans file)))) 1)
+ (snd-display ";mus-sound-samples ~A: ~A ~A" file
+ (mus-sound-samples file)
+ (* (mus-sound-framples file) (mus-sound-chans file))))
+ (if (not (equal? (mus-header-type-name (mus-sound-header-type file)) (testf 4)))
+ (snd-display ";~A: type ~A is not ~A"
+ (testf 0)
+ (mus-header-type-name (mus-sound-header-type file))
+ (testf 4)))
+ (if (not (equal? (mus-sample-type-name (mus-sound-sample-type file)) (testf 5)))
+ (snd-display ";~A: type ~A is not ~A"
+ (testf 0)
+ (mus-sample-type-name (mus-sound-sample-type file))
+ (testf 5)))
+ (let ((lst (mus-sound-loop-info file)))
+ (if (> (length testf) 6)
+ (begin
+ (if (not (equal? (car lst) (testf 6)))
+ (snd-display ";~A: loop start: ~A" (car lst) (testf 6)))
+ (if (not (equal? (cadr lst) (testf 7)))
+ (snd-display ";~A: loop end: ~A" (cadr lst) (testf 7))))
+ (if (pair? lst)
+ (snd-display ";~A thinks it has loop info: ~A" file lst))))
+ (mus-sound-forget file)))
+ (test-headers (cdr base-files)))))))
+
+ ;; need to make sure raw defaults are consistent with following tests
+ (let ((ind (open-raw-sound :file (string-append sf-dir "addf8.nh") :channels 2 :srate 44100 :sample-type mus-bshort)))
+ (if (sound? ind) (close-sound ind)))
+ (catch #t
+ (lambda ()
+ (if (not (= (mus-sound-header-type (string-append sf-dir "midi60.mid")) -1)) (snd-display ";midi60?")))
+ (lambda args args))
+ (test-headers
+ (list
+ (list "5_secs.aiff" 1 44100 5.303107 "AIFF" "big endian short (16 bits)")
+ (list "8svx-8.snd" 1 22050 1.88766443729401 "SVX8" "signed byte (8 bits)")
+ (list "Fnonull.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
+ (list "Pmiscck.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
+ (list "Pmiscck.wav" 1 8000 0.00112499995157123 "RIFF" "mulaw (8 bits)")
; (list "Pnossnd.aif" 1 8000 0.0 "AIFC" "mulaw (8 bits)")
- (list "Poffset.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
- (list "Porder.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
- (list "Ptjunk.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
- (list "Ptjunk.wav" 1 8000 0.00112499995157123 "RIFF" "mulaw (8 bits)")
- (list "SINE24-S.WAV" 2 44100 2.0 "RIFF" "little endian int (24 bits)")
- (list "a1.asf" 1 16000 3.73656249046326 "asf" "unknown")
- (list "a2.asf" 1 8000 4.63062477111816 "asf" "unknown")
- (list "addf8.afsp" 1 8000 2.9760000705719 "Sun/Next" "big endian short (16 bits)")
- (list "addf8.d" 1 8000 2.9760000705719 "SPPACK" "big endian short (16 bits)")
- (list "addf8.dwd" 1 8000 2.9760000705719 "DiamondWare" "little endian short (16 bits)")
- (list "addf8.nh" 2 44100 0.269931972026825 "raw (no header)" "big endian short (16 bits)")
- (list "addf8.sd" 1 8000 2.9760000705719 "ESPS" "big endian short (16 bits)")
- (list "addf8.sf_mipseb" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
- (list "addf8.sf_sun" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
- (list "addf8.sf_vax_b" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
- (list "addf8.wav" 1 8000 2.9760000705719 "RIFF" "little endian short (16 bits)")
- (list "aebass.krz" 1 44100 3.0 "Kurzweil 2000" "big endian short (16 bits)")
- (list "aiff-16.snd" 2 44100 0.746666669845581 "AIFF" "big endian short (16 bits)")
- (list "aiff-8.snd" 2 44100 0.746666669845581 "AIFF" "signed byte (8 bits)")
- (list "alaw.aifc" 1 44100 0.0367800444364548 "AIFC" "alaw (8 bits)")
- (list "alaw.wav" 1 11025 8.70666694641113 "RIFF" "alaw (8 bits)")
- (list "astor_basia.mp2" 2 44100 1.02179133892059 "raw (no header)" "big endian short (16 bits)")
- (list "c.asf" 1 8000 21.3681259155273 "asf" "unknown")
- (list "ce-c3.w02" 1 33000 3.88848495483398 "TX-16W" "unknown")
- (list "ce-c4.w03" 1 33000 2.91618180274963 "TX-16W" "unknown")
- (list "ce-d2.w01" 1 33000 3.46439385414124 "TX-16W" "unknown")
- (list "clbonef.wav" 1 22050 2.57832193374634 "RIFF" "little endian float (32 bits)")
- (list "cranker.krz" 1 44100 3.48267579078674 "Kurzweil 2000" "big endian short (16 bits)")
- (list "d40130.aif" 1 10000 0.100000001490116 "AIFF" "big endian short (16 bits)")
- (list "d40130.au" 1 10000 0.100000001490116 "Sun/Next" "big endian short (16 bits)")
- (list "d40130.dsf" 1 8000 0.125 "Delusion" "little endian short (16 bits)")
- (list "d40130.fsm" 1 8000 0.125249996781349 "Farandole" "little endian short (16 bits)")
- (list "d40130.iff" 1 10000 0.100000001490116 "SVX8" "signed byte (8 bits)")
- (list "d40130.pat" 1 10000 0.100000001490116 "Gravis Ultrasound patch" "little endian short (16 bits)")
- (list "d40130.sds" 1 10000 0.100000001490116 "MIDI sample dump" "unknown")
- (list "d40130.sdx" 1 10000 0.100000001490116 "Sample dump" "unsigned little endian short (16 bits)")
- (list "d40130.sf" 1 10000 0.100000001490116 "IRCAM" "little endian short (16 bits)")
- (list "d40130.smp" 1 8000 0.125 "SMP" "little endian short (16 bits)")
- (list "d40130.sou" 1 8000 0.125 "SBStudioII" "little endian short (16 bits)")
- (list "d40130.st3" 1 8000 0.125 "Digiplayer ST3" "unsigned little endian short (16 bits)")
- (list "d40130.uwf" 1 8000 0.125249996781349 "Ultratracker" "little endian short (16 bits)")
- (list "d40130.voc" 1 10000 0.100100003182888 "VOC" "unsigned byte (8 bits)")
- (list "d40130.w00" 1 16000 0.0625 "TX-16W" "unknown")
- (list "d40130.wav" 1 10000 0.100000001490116 "RIFF" "little endian short (16 bits)")
- (list "d43.wav" 1 10000 0.100000001490116 "RIFF" "little endian short (16 bits)")
- (list "digit0v0.aiff" 1 8000 0.560000002384186 "AIFC" "big endian short (16 bits)")
- (list "esps-16.snd" 1 8000 3.09737491607666 "ESPS" "big endian short (16 bits)")
- (list "forest.aiff" 2 44100 3.907143 "AIFF" "big endian short (16 bits)" 24981 144332)
-; (list "g721.au" 1 11025 4.35328817367554 "Sun/Next" "unknown")
-; (list "g722.aifc" 1 44100 0.0184353739023209 "AIFC" "unknown")
- (list "gong.wve" 1 8000 3.96799993515015 "PSION" "alaw (8 bits)")
- (list "gsm610.wav" 1 11025 1.7687075138092 "RIFF" "unknown")
- (list "inrs-16.snd" 1 8000 2.46399998664856 "INRS" "little endian short (16 bits)")
- (list "kirk.wve" 1 8000 1.40799999237061 "PSION" "alaw (8 bits)")
- (list "loop.aiff" 1 44100 0.0367120169103146 "AIFC" "big endian short (16 bits)" 12 23)
- (list "m.asf" 1 8000 64.9646224975586 "asf" "unknown")
- (list "mary-sun4.sig" 1 8000 4.47612476348877 "Comdisco SPW signal" "big endian double (64 bits)")
- (list "mocksong.wav" 1 11025 7.86956930160522 "RIFF" "little endian short (16 bits)")
- (list "mono24.wav" 1 22050 1.98997735977173 "RIFF" "little endian int (24 bits)")
- (list "msadpcm.wav" 1 11025 4.43501138687134 "RIFF" "unknown")
- (list "n8.snd" 1 44100 0.0367800444364548 "Sun/Next" "signed byte (8 bits)")
- (list "nasahal.aif" 1 11025 9.89841270446777 "AIFF" "signed byte (8 bits)")
- (list "nasahal.avi" 1 11025 10.4327440261841 "AVI" "little endian short (16 bits)")
- (list "nasahal.dig" 1 11025 9.89841270446777 "Sound Designer 1" "big endian short (16 bits)")
- (list "nasahal.ivc" 2 44100 0.449002265930176 "raw (no header)" "big endian short (16 bits)")
- (list "nasahal.pat" 1 11025 3.95410442352295 "Gravis Ultrasound patch" "unsigned byte (8 bits)")
- (list "nasahal.snd" 1 11025 9.89841270446777 "SNDT" "unsigned byte (8 bits)")
- (list "nasahal.svx" 1 11025 9.89841270446777 "SVX8" "signed byte (8 bits)")
- (list "nasahal.v8" 1 8000 13.6412496566772 "Covox V8" "unsigned byte (8 bits)")
- (list "nasahal.voc" 1 11025 9.89941024780273 "VOC" "unsigned byte (8 bits)")
- (list "nasahal.vox" 2 44100 0.224444448947906 "raw (no header)" "big endian short (16 bits)")
- (list "nasahal8.wav" 1 11025 9.89841270446777 "RIFF" "unsigned byte (8 bits)")
- (list "nasahalad.smp" 1 11025 4.94920635223389 "Goldwave sample" "little endian short (16 bits)")
- (list "next-16.snd" 1 22050 1.00004529953003 "Sun/Next" "big endian short (16 bits)")
- (list "next-8.snd" 1 22050 0.226757362484932 "Sun/Next" "signed byte (8 bits)")
- (list "next-dbl.snd" 1 22050 0.226757362484932 "Sun/Next" "big endian double (64 bits)")
- (list "oboe.ldbl" 1 22050 2.30512475967407 "RIFF" "little endian double (64 bits)")
- (list "next-flt.snd" 1 22050 0.226757362484932 "Sun/Next" "big endian float (32 bits)")
- (list "aifc-float.snd" 1 22050 0.226757362484932 "AIFC" "big endian float (32 bits)")
- (list "next-mulaw.snd" 1 8012 2.03295063972473 "Sun/Next" "mulaw (8 bits)")
- (list "next24.snd" 1 44100 0.0367800444364548 "Sun/Next" "big endian int (24 bits)")
- (list "nist-01.wav" 1 16000 2.26912498474121 "NIST" "little endian short (16 bits)")
- (list "nist-10.wav" 1 16000 2.26912498474121 "NIST" "big endian short (16 bits)")
- (list "nist-16.snd" 1 16000 1.02400004863739 "NIST" "big endian short (16 bits)")
- (list "nist-shortpack.wav" 1 16000 4.53824996948242 "NIST" "unknown")
- (list "none.aifc" 1 44100 0.0367800444364548 "AIFC" "big endian short (16 bits)")
- (list "nylon2.wav" 2 22050 1.14376413822174 "RIFF" "unknown")
- (list "o2.adf" 1 44100 0.036780 "CSRE adf" "little endian short (16 bits)")
- (list "o2.avr" 1 44100 0.0183900222182274 "AVR" "big endian short (16 bits)")
- (list "o2.bicsf" 1 44100 0.0367800444364548 "IRCAM" "big endian short (16 bits)")
- (list "o2.mpeg1" 2 44100 0.00709750549867749 "raw (no header)" "big endian short (16 bits)")
- (list "o2.sd2" 2 44100 0.0183900222182274 "raw (no header)" "big endian short (16 bits)")
- (list "o2.sf2" 1 44100 0.0367800444364548 "SoundFont" "little endian short (16 bits)")
- (list "o2.smp" 1 8000 0.202749997377396 "SMP" "little endian short (16 bits)")
- (list "o2.voc" 1 44100 0.0368934236466885 "VOC" "little endian short (16 bits)")
- (list "o2.wave" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
- (list "o2_12bit.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
- (list "o2_18bit.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian int (24 bits)")
-; (list "o2_711u.wave" 1 44100 0.0367800444364548 "RIFF" "mulaw (8 bits)")
-; (list "o2_722.snd" 1 44100 0.0183900222182274 "Sun/Next" "unknown")
-; (list "o2_726.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
-; (list "o2_726.snd" 1 44100 0.0230158735066652 "Sun/Next" "unknown")
-; (list "o2_728.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
- (list "o2_8.iff" 1 44100 0.0367800444364548 "SVX8" "signed byte (8 bits)")
- (list "o2_8.voc" 1 44100 0.0370294786989689 "VOC" "unsigned byte (8 bits)")
- (list "o2_dvi.wave" 1 44100 0.0232199542224407 "RIFF" "unknown")
- (list "o2_float.bicsf" 1 44100 0.0367800444364548 "IRCAM" "big endian float (32 bits)")
- (list "o2_gsm.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
- (list "o2_u8.avr" 1 44100 0.0367800444364548 "AVR" "unsigned byte (8 bits)")
- (list "o2_u8.wave" 1 44100 0.0367800444364548 "RIFF" "unsigned byte (8 bits)")
- (list "o28.mpc" 1 44100 0.036780 "AKAI 4" "little endian short (16 bits)")
-; (list "oboe.g721" 1 22050 1.15287983417511 "Sun/Next" "unknown")
-; (list "oboe.g723_24" 1 22050 0.864761888980865 "Sun/Next" "unknown")
-; (list "oboe.g723_40" 1 22050 1.44126987457275 "Sun/Next" "unknown")
- (list "oboe.kts" 1 22050 2.305125 "Korg" "big endian short (16 bits)")
- (list "oboe.its" 1 22050 2.305125 "Impulse Tracker" "little endian short (16 bits)")
- (list "oboe.sf2" 1 22050 2.30512475967407 "SoundFont" "little endian short (16 bits)")
- (list "oboe.paf" 1 22050 2.305125 "Ensoniq Paris" "big endian short (16 bits)")
- (list "oboe.pf1" 1 22050 2.305125 "Ensoniq Paris" "little endian short (16 bits)")
- (list "oboe.smp" 1 22050 2.305125 "snack SMP" "little endian short (16 bits)")
- (list "oboe.rf64" 1 22050 2.305125 "rf64" "little endian short (16 bits)")
- (list "oboe-be32.caf" 1 22050 2.305125 "caff" "normalized big endian int (32 bits)")
- (list "oboe-bf64.caf" 1 22050 2.305125 "caff" "big endian double (64 bits)")
- (list "oboe-lf32.caf" 1 22050 2.305125 "caff" "little endian float (32 bits)")
- (list "oboe-ulaw.caf" 1 22050 2.305125 "caff" "mulaw (8 bits)")
- (list "oboe.nsp" 1 22050 2.305125 "CSL" "little endian short (16 bits)")
-; (list "oboe.nvf" 1 8000 6.353500 "Creative NVF" "unknown")
- (list "oboe-ulaw.voc" 1 22050 2.305669 "VOC" "mulaw (8 bits)")
- (list "oboe-lf32.sf" 1 22050 2.305669 "IRCAM" "little endian float (32 bits)")
- (list "oboe.wfp" 1 22050 2.305125 "Turtle Beach" "little endian short (16 bits)")
- (list "oboe.sox" 1 22050 2.305125 "Sox" "normalized little endian int (32 bits)")
- (list "oki.snd" 2 44100 0.0041950112208724 "raw (no header)" "big endian short (16 bits)")
- (list "oki.wav" 1 44100 0.016780 "RIFF" "unknown")
- (list "orv-dvi-adpcm.wav" 1 44100 1.92725622653961 "RIFF" "unknown")
- (list "riff-16.snd" 1 22050 1.88766443729401 "RIFF" "little endian short (16 bits)")
- (list "riff-8-u.snd" 1 11025 0.506848096847534 "RIFF" "unsigned byte (8 bits)")
- (list "rooster.wve" 1 8000 2.04800009727478 "PSION" "alaw (8 bits)")
- (list "sd1-16.snd" 1 44100 0.400544226169586 "Sound Designer 1" "big endian short (16 bits)")
+ (list "Poffset.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
+ (list "Porder.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
+ (list "Ptjunk.aif" 1 8000 0.00112499995157123 "AIFC" "mulaw (8 bits)")
+ (list "Ptjunk.wav" 1 8000 0.00112499995157123 "RIFF" "mulaw (8 bits)")
+ (list "SINE24-S.WAV" 2 44100 2.0 "RIFF" "little endian int (24 bits)")
+ (list "a1.asf" 1 16000 3.73656249046326 "asf" "unknown")
+ (list "a2.asf" 1 8000 4.63062477111816 "asf" "unknown")
+ (list "addf8.afsp" 1 8000 2.9760000705719 "Sun/Next" "big endian short (16 bits)")
+ (list "addf8.d" 1 8000 2.9760000705719 "SPPACK" "big endian short (16 bits)")
+ (list "addf8.dwd" 1 8000 2.9760000705719 "DiamondWare" "little endian short (16 bits)")
+ (list "addf8.nh" 2 44100 0.269931972026825 "raw (no header)" "big endian short (16 bits)")
+ (list "addf8.sd" 1 8000 2.9760000705719 "ESPS" "big endian short (16 bits)")
+ (list "addf8.sf_mipseb" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
+ (list "addf8.sf_sun" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
+ (list "addf8.sf_vax_b" 1 8000 2.9760000705719 "IRCAM" "big endian short (16 bits)")
+ (list "addf8.wav" 1 8000 2.9760000705719 "RIFF" "little endian short (16 bits)")
+ (list "aebass.krz" 1 44100 3.0 "Kurzweil 2000" "big endian short (16 bits)")
+ (list "aiff-16.snd" 2 44100 0.746666669845581 "AIFF" "big endian short (16 bits)")
+ (list "aiff-8.snd" 2 44100 0.746666669845581 "AIFF" "signed byte (8 bits)")
+ (list "alaw.aifc" 1 44100 0.0367800444364548 "AIFC" "alaw (8 bits)")
+ (list "alaw.wav" 1 11025 8.70666694641113 "RIFF" "alaw (8 bits)")
+ (list "astor_basia.mp2" 2 44100 1.02179133892059 "raw (no header)" "big endian short (16 bits)")
+ (list "c.asf" 1 8000 21.3681259155273 "asf" "unknown")
+ (list "ce-c3.w02" 1 33000 3.88848495483398 "TX-16W" "unknown")
+ (list "ce-c4.w03" 1 33000 2.91618180274963 "TX-16W" "unknown")
+ (list "ce-d2.w01" 1 33000 3.46439385414124 "TX-16W" "unknown")
+ (list "clbonef.wav" 1 22050 2.57832193374634 "RIFF" "little endian float (32 bits)")
+ (list "cranker.krz" 1 44100 3.48267579078674 "Kurzweil 2000" "big endian short (16 bits)")
+ (list "d40130.aif" 1 10000 0.100000001490116 "AIFF" "big endian short (16 bits)")
+ (list "d40130.au" 1 10000 0.100000001490116 "Sun/Next" "big endian short (16 bits)")
+ (list "d40130.dsf" 1 8000 0.125 "Delusion" "little endian short (16 bits)")
+ (list "d40130.fsm" 1 8000 0.125249996781349 "Farandole" "little endian short (16 bits)")
+ (list "d40130.iff" 1 10000 0.100000001490116 "SVX8" "signed byte (8 bits)")
+ (list "d40130.pat" 1 10000 0.100000001490116 "Gravis Ultrasound patch" "little endian short (16 bits)")
+ (list "d40130.sds" 1 10000 0.100000001490116 "MIDI sample dump" "unknown")
+ (list "d40130.sdx" 1 10000 0.100000001490116 "Sample dump" "unsigned little endian short (16 bits)")
+ (list "d40130.sf" 1 10000 0.100000001490116 "IRCAM" "little endian short (16 bits)")
+ (list "d40130.smp" 1 8000 0.125 "SMP" "little endian short (16 bits)")
+ (list "d40130.sou" 1 8000 0.125 "SBStudioII" "little endian short (16 bits)")
+ (list "d40130.st3" 1 8000 0.125 "Digiplayer ST3" "unsigned little endian short (16 bits)")
+ (list "d40130.uwf" 1 8000 0.125249996781349 "Ultratracker" "little endian short (16 bits)")
+ (list "d40130.voc" 1 10000 0.100100003182888 "VOC" "unsigned byte (8 bits)")
+ (list "d40130.w00" 1 16000 0.0625 "TX-16W" "unknown")
+ (list "d40130.wav" 1 10000 0.100000001490116 "RIFF" "little endian short (16 bits)")
+ (list "d43.wav" 1 10000 0.100000001490116 "RIFF" "little endian short (16 bits)")
+ (list "digit0v0.aiff" 1 8000 0.560000002384186 "AIFC" "big endian short (16 bits)")
+ (list "esps-16.snd" 1 8000 3.09737491607666 "ESPS" "big endian short (16 bits)")
+ (list "forest.aiff" 2 44100 3.907143 "AIFF" "big endian short (16 bits)" 24981 144332)
+ ; (list "g721.au" 1 11025 4.35328817367554 "Sun/Next" "unknown")
+ ; (list "g722.aifc" 1 44100 0.0184353739023209 "AIFC" "unknown")
+ (list "gong.wve" 1 8000 3.96799993515015 "PSION" "alaw (8 bits)")
+ (list "gsm610.wav" 1 11025 1.7687075138092 "RIFF" "unknown")
+ (list "inrs-16.snd" 1 8000 2.46399998664856 "INRS" "little endian short (16 bits)")
+ (list "kirk.wve" 1 8000 1.40799999237061 "PSION" "alaw (8 bits)")
+ (list "loop.aiff" 1 44100 0.0367120169103146 "AIFC" "big endian short (16 bits)" 12 23)
+ (list "m.asf" 1 8000 64.9646224975586 "asf" "unknown")
+ (list "mary-sun4.sig" 1 8000 4.47612476348877 "Comdisco SPW signal" "big endian double (64 bits)")
+ (list "mocksong.wav" 1 11025 7.86956930160522 "RIFF" "little endian short (16 bits)")
+ (list "mono24.wav" 1 22050 1.98997735977173 "RIFF" "little endian int (24 bits)")
+ (list "msadpcm.wav" 1 11025 4.43501138687134 "RIFF" "unknown")
+ (list "n8.snd" 1 44100 0.0367800444364548 "Sun/Next" "signed byte (8 bits)")
+ (list "nasahal.aif" 1 11025 9.89841270446777 "AIFF" "signed byte (8 bits)")
+ (list "nasahal.avi" 1 11025 10.4327440261841 "AVI" "little endian short (16 bits)")
+ (list "nasahal.dig" 1 11025 9.89841270446777 "Sound Designer 1" "big endian short (16 bits)")
+ (list "nasahal.ivc" 2 44100 0.449002265930176 "raw (no header)" "big endian short (16 bits)")
+ (list "nasahal.pat" 1 11025 3.95410442352295 "Gravis Ultrasound patch" "unsigned byte (8 bits)")
+ (list "nasahal.snd" 1 11025 9.89841270446777 "SNDT" "unsigned byte (8 bits)")
+ (list "nasahal.svx" 1 11025 9.89841270446777 "SVX8" "signed byte (8 bits)")
+ (list "nasahal.v8" 1 8000 13.6412496566772 "Covox V8" "unsigned byte (8 bits)")
+ (list "nasahal.voc" 1 11025 9.89941024780273 "VOC" "unsigned byte (8 bits)")
+ (list "nasahal.vox" 2 44100 0.224444448947906 "raw (no header)" "big endian short (16 bits)")
+ (list "nasahal8.wav" 1 11025 9.89841270446777 "RIFF" "unsigned byte (8 bits)")
+ (list "nasahalad.smp" 1 11025 4.94920635223389 "Goldwave sample" "little endian short (16 bits)")
+ (list "next-16.snd" 1 22050 1.00004529953003 "Sun/Next" "big endian short (16 bits)")
+ (list "next-8.snd" 1 22050 0.226757362484932 "Sun/Next" "signed byte (8 bits)")
+ (list "next-dbl.snd" 1 22050 0.226757362484932 "Sun/Next" "big endian double (64 bits)")
+ (list "oboe.ldbl" 1 22050 2.30512475967407 "RIFF" "little endian double (64 bits)")
+ (list "next-flt.snd" 1 22050 0.226757362484932 "Sun/Next" "big endian float (32 bits)")
+ (list "aifc-float.snd" 1 22050 0.226757362484932 "AIFC" "big endian float (32 bits)")
+ (list "next-mulaw.snd" 1 8012 2.03295063972473 "Sun/Next" "mulaw (8 bits)")
+ (list "next24.snd" 1 44100 0.0367800444364548 "Sun/Next" "big endian int (24 bits)")
+ (list "nist-01.wav" 1 16000 2.26912498474121 "NIST" "little endian short (16 bits)")
+ (list "nist-10.wav" 1 16000 2.26912498474121 "NIST" "big endian short (16 bits)")
+ (list "nist-16.snd" 1 16000 1.02400004863739 "NIST" "big endian short (16 bits)")
+ (list "nist-shortpack.wav" 1 16000 4.53824996948242 "NIST" "unknown")
+ (list "none.aifc" 1 44100 0.0367800444364548 "AIFC" "big endian short (16 bits)")
+ (list "nylon2.wav" 2 22050 1.14376413822174 "RIFF" "unknown")
+ (list "o2.adf" 1 44100 0.036780 "CSRE adf" "little endian short (16 bits)")
+ (list "o2.avr" 1 44100 0.0183900222182274 "AVR" "big endian short (16 bits)")
+ (list "o2.bicsf" 1 44100 0.0367800444364548 "IRCAM" "big endian short (16 bits)")
+ (list "o2.mpeg1" 2 44100 0.00709750549867749 "raw (no header)" "big endian short (16 bits)")
+ (list "o2.sd2" 2 44100 0.0183900222182274 "raw (no header)" "big endian short (16 bits)")
+ (list "o2.sf2" 1 44100 0.0367800444364548 "SoundFont" "little endian short (16 bits)")
+ (list "o2.smp" 1 8000 0.202749997377396 "SMP" "little endian short (16 bits)")
+ (list "o2.voc" 1 44100 0.0368934236466885 "VOC" "little endian short (16 bits)")
+ (list "o2.wave" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
+ (list "o2_12bit.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
+ (list "o2_18bit.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian int (24 bits)")
+ ; (list "o2_711u.wave" 1 44100 0.0367800444364548 "RIFF" "mulaw (8 bits)")
+ ; (list "o2_722.snd" 1 44100 0.0183900222182274 "Sun/Next" "unknown")
+ ; (list "o2_726.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
+ ; (list "o2_726.snd" 1 44100 0.0230158735066652 "Sun/Next" "unknown")
+ ; (list "o2_728.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
+ (list "o2_8.iff" 1 44100 0.0367800444364548 "SVX8" "signed byte (8 bits)")
+ (list "o2_8.voc" 1 44100 0.0370294786989689 "VOC" "unsigned byte (8 bits)")
+ (list "o2_dvi.wave" 1 44100 0.0232199542224407 "RIFF" "unknown")
+ (list "o2_float.bicsf" 1 44100 0.0367800444364548 "IRCAM" "big endian float (32 bits)")
+ (list "o2_gsm.aiff" 1 8000 0.0367499999701977 "AIFC" "unknown")
+ (list "o2_u8.avr" 1 44100 0.0367800444364548 "AVR" "unsigned byte (8 bits)")
+ (list "o2_u8.wave" 1 44100 0.0367800444364548 "RIFF" "unsigned byte (8 bits)")
+ (list "o28.mpc" 1 44100 0.036780 "AKAI 4" "little endian short (16 bits)")
+ ; (list "oboe.g721" 1 22050 1.15287983417511 "Sun/Next" "unknown")
+ ; (list "oboe.g723_24" 1 22050 0.864761888980865 "Sun/Next" "unknown")
+ ; (list "oboe.g723_40" 1 22050 1.44126987457275 "Sun/Next" "unknown")
+ (list "oboe.kts" 1 22050 2.305125 "Korg" "big endian short (16 bits)")
+ (list "oboe.its" 1 22050 2.305125 "Impulse Tracker" "little endian short (16 bits)")
+ (list "oboe.sf2" 1 22050 2.30512475967407 "SoundFont" "little endian short (16 bits)")
+ (list "oboe.paf" 1 22050 2.305125 "Ensoniq Paris" "big endian short (16 bits)")
+ (list "oboe.pf1" 1 22050 2.305125 "Ensoniq Paris" "little endian short (16 bits)")
+ (list "oboe.smp" 1 22050 2.305125 "snack SMP" "little endian short (16 bits)")
+ (list "oboe.rf64" 1 22050 2.305125 "rf64" "little endian short (16 bits)")
+ (list "oboe-be32.caf" 1 22050 2.305125 "caff" "normalized big endian int (32 bits)")
+ (list "oboe-bf64.caf" 1 22050 2.305125 "caff" "big endian double (64 bits)")
+ (list "oboe-lf32.caf" 1 22050 2.305125 "caff" "little endian float (32 bits)")
+ (list "oboe-ulaw.caf" 1 22050 2.305125 "caff" "mulaw (8 bits)")
+ (list "oboe.nsp" 1 22050 2.305125 "CSL" "little endian short (16 bits)")
+ ; (list "oboe.nvf" 1 8000 6.353500 "Creative NVF" "unknown")
+ (list "oboe-ulaw.voc" 1 22050 2.305669 "VOC" "mulaw (8 bits)")
+ (list "oboe-lf32.sf" 1 22050 2.305669 "IRCAM" "little endian float (32 bits)")
+ (list "oboe.wfp" 1 22050 2.305125 "Turtle Beach" "little endian short (16 bits)")
+ (list "oboe.sox" 1 22050 2.305125 "Sox" "normalized little endian int (32 bits)")
+ (list "oki.snd" 2 44100 0.0041950112208724 "raw (no header)" "big endian short (16 bits)")
+ (list "oki.wav" 1 44100 0.016780 "RIFF" "unknown")
+ (list "orv-dvi-adpcm.wav" 1 44100 1.92725622653961 "RIFF" "unknown")
+ (list "riff-16.snd" 1 22050 1.88766443729401 "RIFF" "little endian short (16 bits)")
+ (list "riff-8-u.snd" 1 11025 0.506848096847534 "RIFF" "unsigned byte (8 bits)")
+ (list "rooster.wve" 1 8000 2.04800009727478 "PSION" "alaw (8 bits)")
+ (list "sd1-16.snd" 1 44100 0.400544226169586 "Sound Designer 1" "big endian short (16 bits)")
; (list "segfault.snd" 16777216 576061440 1.24986669902682e-7 "Sun/Next" "unknown")
- (list "sf-16.snd" 1 22050 1.88766443729401 "IRCAM" "big endian short (16 bits)")
- (list "si654.adc" 1 16000 6.71362495422363 "ADC/OGI" "big endian short (16 bits)")
- (list "smp-16.snd" 1 8000 5.2028751373291 "SMP" "little endian short (16 bits)")
- (list "sound.pat" 1 8000 1.95050001144409 "Gravis Ultrasound patch" "unsigned little endian short (16 bits)")
- (list "sound.sap" 1 8000 1.95050001144409 "Goldwave sample" "little endian short (16 bits)")
- (list "sound.sds" 1 8000 1.95050001144409 "MIDI sample dump" "unknown")
- (list "sound.sfr" 1 8000 1.95050001144409 "SRFS" "little endian short (16 bits)")
- (list "sound.v8" 1 8000 1.95050001144409 "Covox V8" "unsigned byte (8 bits)")
- (list "sound.vox" 2 44100 0.044217687100172 "raw (no header)" "big endian short (16 bits)")
- (list "step.omf" 1 11025 8.70666694641113 "OMF" "signed byte (8 bits)")
- (list "step.qt" 1 11025 8.70630359649658 "Quicktime" "unsigned byte (8 bits)")
- (list "sun-16-afsp.snd" 1 8000 2.9760000705719 "Sun/Next" "big endian short (16 bits)")
- (list "sun-mulaw.snd" 1 8000 4.61950016021729 "Sun/Next" "mulaw (8 bits)")
- (list "sw1038t_short.wav" 2 8000 6.0 "NIST" "mulaw (8 bits)")
- (list "swirl.pat" 1 22050 1.0619500875473 "Gravis Ultrasound patch" "unsigned little endian short (16 bits)")
- (list "sy85.snd" 1 8000 5.05600023269653 "Sy-85" "big endian short (16 bits)")
- (list "sy99.snd" 1 8000 4.54400014877319 "Sy-99" "big endian short (16 bits)")
- (list "telephone.wav" 1 16000 2.27881240844727 "NIST" "little endian short (16 bits)")
- (list "trumps22.adp" 1 22050 3.092880 "RIFF" "unknown")
- (list "truspech.wav" 1 8000 1.1599999666214 "RIFF" "unknown")
- (list "ulaw.aifc" 1 44100 0.0367800444364548 "AIFC" "mulaw (8 bits)")
- (list "voc-8-u.snd" 1 8000 1.49937498569489 "VOC" "unsigned byte (8 bits)")
- (list "o28.voc" 1 44100 0.036893 "VOC" "little endian short (16 bits)")
- (list "voxware.wav" 1 8000 0.324000000953674 "RIFF" "unknown")
- (list "wd.w00" 1 8000 0.202749997377396 "Sy-99" "big endian short (16 bits)")
- (list "wd1.smp" 1 8000 0.202749997377396 "SMP" "little endian short (16 bits)")
- (list "wd1.wav" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
- (list "wheel.mat" 2 44100 0.145646259188652 "raw (no header)" "big endian short (16 bits)")
- (list "b8.pvf" 1 44100 0.036803 "Portable Voice Format" "signed byte (8 bits)")
- (list "b16.pvf" 1 44100 0.036803 "Portable Voice Format" "big endian short (16 bits)")
- (list "b32.pvf" 1 44100 0.036803 "Portable Voice Format" "big endian int (32 bits)")
- (list "water.voc" 2 32000 42.3463897705078 "VOC" "little endian short (16 bits)")
- (list "wood.dsf" 1 8000 0.202749997377396 "Delusion" "little endian short (16 bits)")
- (list "wood.dvi" 1 22100 0.0278733037412167 "RIFF" "unknown")
- (list "wood.dwd" 1 22100 0.0733936652541161 "DiamondWare" "signed byte (8 bits)")
- (list "wood.fsm" 1 8000 0.202999994158745 "Farandole" "little endian short (16 bits)")
- (list "wood.mad" 1 22100 0.0372398197650909 "RIFF" "unknown")
- (list "wood.maud" 1 44100 0.0183900222182274 "MAUD" "big endian short (16 bits)")
- (list "wood.pat" 1 22100 0.0733936652541161 "Gravis Ultrasound patch" "little endian short (16 bits)")
- (list "wood.riff" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
- (list "wood.rifx" 1 44100 0.0367800444364548 "RIFF" "big endian short (16 bits)")
- (list "wood.sds" 1 22100 0.0733936652541161 "MIDI sample dump" "unknown")
- (list "wood.sdx" 1 22100 0.0733936652541161 "Sample dump" "unsigned little endian short (16 bits)")
- (list "wood.sf" 1 44100 0.0367800444364548 "IRCAM" "big endian short (16 bits)")
- (list "wood.sndr" 2 44100 0.0092290248721838 "raw (no header)" "big endian short (16 bits)")
- (list "wood.sndt" 1 44100 0.0367800444364548 "SNDT" "unsigned byte (8 bits)")
- (list "wood.st3" 1 8000 0.202749997377396 "Digiplayer ST3" "unsigned little endian short (16 bits)")
- (list "wood.uwf" 1 8000 0.202999994158745 "Ultratracker" "little endian short (16 bits)")
- (list "wood.w00" 1 16000 0.101374998688698 "TX-16W" "unknown")
- (list "wood12.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
- (list "wood16.dwd" 2 44100 0.0367800444364548 "DiamondWare" "little endian short (16 bits)")
- (list "wood16.wav" 2 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
- (list "wood16.nsp" 2 44100 0.0367800444364548 "CSL" "little endian short (16 bits)")
- (list "wood16.smp" 2 44100 0.0367800444364548 "snack SMP" "little endian short (16 bits)")
- (list "wood24.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian int (24 bits)")
- (list "woodblock.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
- (list "woodflt.snd" 1 44100 0.0367800444364548 "Sun/Next" "big endian float (32 bits)")
- (list "RealDrums.sf2" 1 44100 6.39725637435913 "SoundFont" "little endian short (16 bits)")
- (list "32bit.sf" 1 44100 4.6 "IRCAM" "little endian float (32 bits, unscaled)")
- (list "PCM_48_8bit_m.w64" 1 48000 0.375 "SoundForge" "unsigned byte (8 bits)")
- (list "oboe.sf6" 1 22050 2.305125 "SoundForge" "little endian short (16 bits)")
- (list "addf8.24we" 1 8000 2.976000 "RIFF" "little endian int (24 bits)")
- (list "hybrid.snd" 1 44100 4.600000 "BICSF" "big endian float (32 bits)")
- (list "litmanna.sf" 1 44100 .533 "IRCAM" "little endian short (16 bits)")
- (list "M1F1-float64C-AFsp.aif" 2 8000 2.9366 "AIFC" "big endian double (64 bits)")
- (list "MacBoing.wav" 1 11127 0.696 "RIFF" "unsigned byte (8 bits)")
- (list "t15.aiff" 2 44100 135.00 "AIFC" "little endian short (16 bits)")
- (list "tomf8.aud" 1 8000 2.016000 "INRS" "little endian short (16 bits)")
- (list "Xhs001x.nsp" 1 10000 6.017400 "CSL" "little endian short (16 bits)")
- (list "zulu_a4.w11" 1 33000 1.21987879276276 "TX-16W" "unknown" 23342 40042)))
-
- (for-each (lambda (in-name real-name)
- (if (not (string=? (mus-expand-filename in-name) real-name))
- (snd-display #__line__ ";mus-expand-filename ~A -> ~A" in-name (mus-expand-filename in-name)))
- (if (file-exists? "/home/bil/./sf1/o2.voc")
- (let ((ind (open-sound in-name)))
- (if (not (sound? ind))
- (snd-display #__line__ ";can't open ~A" in-name)
- (begin
- (if (not (string=? (file-name ind) real-name))
- (snd-display #__line__ ";expand file name ~A: ~A" in-name (file-name ind)))
- (close-sound ind))))))
- (list "/home/bil/./sf1/o2.voc" "~/./sf1/o2.voc" "~/cl/../sf1/o2.voc" "/home/bil/cl/../sf1/o2.voc")
- (list "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc"))
-
- (let ((lst (mus-sound-mark-info (string-append sf-dir "forest.aiff"))))
- (if (not (equal? lst '((4 0) (3 0) (2 144332) (1 24981))))
- (snd-display #__line__ ";mus-sound-mark-info forest: ~A" lst)))
- (let ((lst (mus-sound-mark-info (string-append sf-dir "traffic.aiff"))))
- (if (not (equal? lst '((4 1) (3 0) (2 171931) (1 99461))))
- (snd-display #__line__ ";mus-sound-mark-info traffic: ~A" lst)))
- )))
+ (list "sf-16.snd" 1 22050 1.88766443729401 "IRCAM" "big endian short (16 bits)")
+ (list "si654.adc" 1 16000 6.71362495422363 "ADC/OGI" "big endian short (16 bits)")
+ (list "smp-16.snd" 1 8000 5.2028751373291 "SMP" "little endian short (16 bits)")
+ (list "sound.pat" 1 8000 1.95050001144409 "Gravis Ultrasound patch" "unsigned little endian short (16 bits)")
+ (list "sound.sap" 1 8000 1.95050001144409 "Goldwave sample" "little endian short (16 bits)")
+ (list "sound.sds" 1 8000 1.95050001144409 "MIDI sample dump" "unknown")
+ (list "sound.sfr" 1 8000 1.95050001144409 "SRFS" "little endian short (16 bits)")
+ (list "sound.v8" 1 8000 1.95050001144409 "Covox V8" "unsigned byte (8 bits)")
+ (list "sound.vox" 2 44100 0.044217687100172 "raw (no header)" "big endian short (16 bits)")
+ (list "step.omf" 1 11025 8.70666694641113 "OMF" "signed byte (8 bits)")
+ (list "step.qt" 1 11025 8.70630359649658 "Quicktime" "unsigned byte (8 bits)")
+ (list "sun-16-afsp.snd" 1 8000 2.9760000705719 "Sun/Next" "big endian short (16 bits)")
+ (list "sun-mulaw.snd" 1 8000 4.61950016021729 "Sun/Next" "mulaw (8 bits)")
+ (list "sw1038t_short.wav" 2 8000 6.0 "NIST" "mulaw (8 bits)")
+ (list "swirl.pat" 1 22050 1.0619500875473 "Gravis Ultrasound patch" "unsigned little endian short (16 bits)")
+ (list "sy85.snd" 1 8000 5.05600023269653 "Sy-85" "big endian short (16 bits)")
+ (list "sy99.snd" 1 8000 4.54400014877319 "Sy-99" "big endian short (16 bits)")
+ (list "telephone.wav" 1 16000 2.27881240844727 "NIST" "little endian short (16 bits)")
+ (list "trumps22.adp" 1 22050 3.092880 "RIFF" "unknown")
+ (list "truspech.wav" 1 8000 1.1599999666214 "RIFF" "unknown")
+ (list "ulaw.aifc" 1 44100 0.0367800444364548 "AIFC" "mulaw (8 bits)")
+ (list "voc-8-u.snd" 1 8000 1.49937498569489 "VOC" "unsigned byte (8 bits)")
+ (list "o28.voc" 1 44100 0.036893 "VOC" "little endian short (16 bits)")
+ (list "voxware.wav" 1 8000 0.324000000953674 "RIFF" "unknown")
+ (list "wd.w00" 1 8000 0.202749997377396 "Sy-99" "big endian short (16 bits)")
+ (list "wd1.smp" 1 8000 0.202749997377396 "SMP" "little endian short (16 bits)")
+ (list "wd1.wav" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
+ (list "wheel.mat" 2 44100 0.145646259188652 "raw (no header)" "big endian short (16 bits)")
+ (list "b8.pvf" 1 44100 0.036803 "Portable Voice Format" "signed byte (8 bits)")
+ (list "b16.pvf" 1 44100 0.036803 "Portable Voice Format" "big endian short (16 bits)")
+ (list "b32.pvf" 1 44100 0.036803 "Portable Voice Format" "big endian int (32 bits)")
+ (list "water.voc" 2 32000 42.3463897705078 "VOC" "little endian short (16 bits)")
+ (list "wood.dsf" 1 8000 0.202749997377396 "Delusion" "little endian short (16 bits)")
+ (list "wood.dvi" 1 22100 0.0278733037412167 "RIFF" "unknown")
+ (list "wood.dwd" 1 22100 0.0733936652541161 "DiamondWare" "signed byte (8 bits)")
+ (list "wood.fsm" 1 8000 0.202999994158745 "Farandole" "little endian short (16 bits)")
+ (list "wood.mad" 1 22100 0.0372398197650909 "RIFF" "unknown")
+ (list "wood.maud" 1 44100 0.0183900222182274 "MAUD" "big endian short (16 bits)")
+ (list "wood.pat" 1 22100 0.0733936652541161 "Gravis Ultrasound patch" "little endian short (16 bits)")
+ (list "wood.riff" 1 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
+ (list "wood.rifx" 1 44100 0.0367800444364548 "RIFF" "big endian short (16 bits)")
+ (list "wood.sds" 1 22100 0.0733936652541161 "MIDI sample dump" "unknown")
+ (list "wood.sdx" 1 22100 0.0733936652541161 "Sample dump" "unsigned little endian short (16 bits)")
+ (list "wood.sf" 1 44100 0.0367800444364548 "IRCAM" "big endian short (16 bits)")
+ (list "wood.sndr" 2 44100 0.0092290248721838 "raw (no header)" "big endian short (16 bits)")
+ (list "wood.sndt" 1 44100 0.0367800444364548 "SNDT" "unsigned byte (8 bits)")
+ (list "wood.st3" 1 8000 0.202749997377396 "Digiplayer ST3" "unsigned little endian short (16 bits)")
+ (list "wood.uwf" 1 8000 0.202999994158745 "Ultratracker" "little endian short (16 bits)")
+ (list "wood.w00" 1 16000 0.101374998688698 "TX-16W" "unknown")
+ (list "wood12.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
+ (list "wood16.dwd" 2 44100 0.0367800444364548 "DiamondWare" "little endian short (16 bits)")
+ (list "wood16.wav" 2 44100 0.0367800444364548 "RIFF" "little endian short (16 bits)")
+ (list "wood16.nsp" 2 44100 0.0367800444364548 "CSL" "little endian short (16 bits)")
+ (list "wood16.smp" 2 44100 0.0367800444364548 "snack SMP" "little endian short (16 bits)")
+ (list "wood24.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian int (24 bits)")
+ (list "woodblock.aiff" 1 44100 0.0367800444364548 "AIFF" "big endian short (16 bits)")
+ (list "woodflt.snd" 1 44100 0.0367800444364548 "Sun/Next" "big endian float (32 bits)")
+ (list "RealDrums.sf2" 1 44100 6.39725637435913 "SoundFont" "little endian short (16 bits)")
+ (list "32bit.sf" 1 44100 4.6 "IRCAM" "little endian float (32 bits, unscaled)")
+ (list "PCM_48_8bit_m.w64" 1 48000 0.375 "SoundForge" "unsigned byte (8 bits)")
+ (list "oboe.sf6" 1 22050 2.305125 "SoundForge" "little endian short (16 bits)")
+ (list "addf8.24we" 1 8000 2.976000 "RIFF" "little endian int (24 bits)")
+ (list "hybrid.snd" 1 44100 4.600000 "BICSF" "big endian float (32 bits)")
+ (list "litmanna.sf" 1 44100 .533 "IRCAM" "little endian short (16 bits)")
+ (list "M1F1-float64C-AFsp.aif" 2 8000 2.9366 "AIFC" "big endian double (64 bits)")
+ (list "MacBoing.wav" 1 11127 0.696 "RIFF" "unsigned byte (8 bits)")
+ (list "t15.aiff" 2 44100 135.00 "AIFC" "little endian short (16 bits)")
+ (list "tomf8.aud" 1 8000 2.016000 "INRS" "little endian short (16 bits)")
+ (list "Xhs001x.nsp" 1 10000 6.017400 "CSL" "little endian short (16 bits)")
+ (list "zulu_a4.w11" 1 33000 1.21987879276276 "TX-16W" "unknown" 23342 40042)))
+
+ (for-each (lambda (in-name real-name)
+ (if (not (string=? (mus-expand-filename in-name) real-name))
+ (snd-display ";mus-expand-filename ~A -> ~A" in-name (mus-expand-filename in-name)))
+ (if (file-exists? "/home/bil/./sf1/o2.voc")
+ (let ((ind (open-sound in-name)))
+ (if (not (sound? ind))
+ (snd-display ";can't open ~A" in-name)
+ (begin
+ (if (not (string=? (file-name ind) real-name))
+ (snd-display ";expand file name ~A: ~A" in-name (file-name ind)))
+ (close-sound ind))))))
+ (list "/home/bil/./sf1/o2.voc" "~/./sf1/o2.voc" "~/cl/../sf1/o2.voc" "/home/bil/cl/../sf1/o2.voc")
+ (list "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc"))
+
+ (let ((lst (mus-sound-mark-info (string-append sf-dir "forest.aiff"))))
+ (if (not (equal? lst '((4 0) (3 0) (2 144332) (1 24981))))
+ (snd-display ";mus-sound-mark-info forest: ~A" lst)))
+ (let ((lst (mus-sound-mark-info (string-append sf-dir "traffic.aiff"))))
+ (if (not (equal? lst '((4 1) (3 0) (2 171931) (1 99461))))
+ (snd-display ";mus-sound-mark-info traffic: ~A" lst)))
+ )))
;;; ---------------- test 3: variables ----------------
(define (snd_test_3)
- (let ((ind #f))
-
- (set! ind (open-sound "oboe.snd"))
+ (let ((ind (open-sound "oboe.snd")))
(if (and (file-exists? "funcs.scm")
(not (defined? 'swellf)))
(load "funcs.scm"))
@@ -1920,54 +1760,52 @@
(lambda ()
(set! *temp-dir* (string-append home-dir "/test"))
(if (not (string=? *temp-dir* (string-append home-dir "/test")))
- (snd-display #__line__ ";set temp-dir: ~A?" *temp-dir*)))
+ (snd-display ";set temp-dir: ~A?" *temp-dir*)))
(lambda args args))
- (if td
- (set! *temp-dir* td)
- (set! *temp-dir* "")))
- (if (fneq (sample 1000) 0.0328) (snd-display #__line__ ";sample: ~A?" (sample 1000)))
+ (set! *temp-dir* (or td "")))
+ (if (fneq (sample 1000) 0.0328) (snd-display ";sample: ~A?" (sample 1000)))
(when with-gui
(set! *show-controls* #t)
(let ((wid (enved-dialog) ))
(if (not (equal? wid ((dialog-widgets) 1)))
- (snd-display #__line__ ";enved-dialog -> ~A ~A" wid ((dialog-widgets) 1))))
- ;(if (not ((dialog-widgets) 1)) (snd-display #__line__ ";enved-dialog?"))
+ (snd-display ";enved-dialog -> ~A ~A" wid ((dialog-widgets) 1))))
+ ;(if (not ((dialog-widgets) 1)) (snd-display ";enved-dialog?"))
(set! (enved-envelope) '(0.0 0.0 1.0 1.0 2.0 0.0))
(if (not (equal? (enved-envelope) (list 0.0 0.0 1.0 1.0 2.0 0.0)))
- (snd-display #__line__ ";set enved-envelope to self: ~A?" (enved-envelope)))
+ (snd-display ";set enved-envelope to self: ~A?" (enved-envelope)))
(letrec ((test-vars
(lambda (lst)
- (if (pair? lst)
- (let* ((name ((car lst) 0))
- (getfnc ((car lst) 1))
- (setfnc (lambda (val) (set! (getfnc) val)))
- (initval ((car lst) 2))
- (newval ((car lst) 3)))
-
- (setfnc newval)
+ (when (pair? lst)
+ (let* ((name ((car lst) 0))
+ (getfnc ((car lst) 1))
+ (setfnc (lambda (val) (set! (getfnc) val)))
+ (initval ((car lst) 2))
+ (newval ((car lst) 3)))
+
+ (setfnc newval)
+ (let ((nowval (getfnc)))
+ (if (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (if (and (number? newval) (not (rational? newval)))
+ (if (> (abs (- newval nowval)) .01)
+ (snd-display ";~A is not ~A (~A)" name newval nowval))
+ (snd-display ";~A is not ~A (~A)" name newval nowval)))
+ (setfnc initval)
+ (set! (getfnc) newval)
(let ((nowval (getfnc)))
- (if (and (not (equal? newval nowval))
- (or (not (list? newval))
- (not (feql newval nowval))))
+ (if (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
(if (and (number? newval) (not (rational? newval)))
(if (> (abs (- newval nowval)) .01)
- (snd-display #__line__ ";~A is not ~A (~A)" name newval nowval))
- (snd-display #__line__ ";~A is not ~A (~A)" name newval nowval)))
- (setfnc initval)
- (set! (getfnc) newval)
- (let ((nowval (getfnc)))
- (if (and (not (equal? newval nowval))
- (or (not (list? newval))
- (not (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display #__line__ ";set! ~A is not ~A (~A)" name newval nowval))
- (snd-display #__line__ ";set! ~A is not ~A (~A)" name newval nowval)))
- (setfnc initval))
- (test-vars (cdr lst))))))))
+ (snd-display ";set! ~A is not ~A (~A)" name newval nowval))
+ (snd-display ";set! ~A is not ~A (~A)" name newval nowval)))
+ (setfnc initval))
+ (test-vars (cdr lst))))))))
(test-vars
(list
(list 'amp-control amp-control 1.0 0.5)
@@ -2040,6 +1878,7 @@
(list 'initial-dur initial-dur 0.1 1.0)
(list 'just-sounds just-sounds #f #t)
(list 'listener-prompt listener-prompt ">" ":")
+ (list 'stdin-prompt stdin-prompt "" ">")
(list 'max-transform-peaks max-transform-peaks 100 10)
(list 'max-regions max-regions 16 6)
(list 'min-dB min-dB -60.0 -90.0)
@@ -2091,7 +1930,9 @@
(list 'speed-control-tones speed-control-tones 12 18)
(list 'sync sync 0 1)
(list 'sync-style sync-style sync-by-sound sync-all)
- (list 'tiny-font tiny-font (if (provided? 'snd-gtk) "Sans 8" "6x12") (if (provided? 'snd-gtk) "Monospace 10" "9x15"))
+ (list 'tiny-font tiny-font (if (provided? 'snd-gtk)
+ (values "Sans 8" "Monospace 10")
+ (values "6x12" "9x15")))
(list 'transform-type transform-type fourier-transform autocorrelation)
(list 'with-verbose-cursor with-verbose-cursor #f #t)
(list 'wavelet-type wavelet-type 0 1)
@@ -2125,7 +1966,7 @@
(lambda args (car args)))
(let ((nowval (getfnc)))
(if (equal? n nowval)
- (snd-display #__line__ ";(bad set) ~A = ~A (~A)" name n initval))
+ (snd-display ";(bad set) ~A = ~A (~A)" name n initval))
(setfnc initval)))
newvals)
(test-bad-args (cdr lst)))))))
@@ -2184,46 +2025,46 @@
(set! (window-width) 300)
(set! (window-height) 300)
(if (<= (window-width) 30)
- (snd-display #__line__ ";window width: ~A is not 300?" (window-width)))
+ (snd-display ";window width: ~A is not 300?" (window-width)))
(if (<= (window-height) 30)
- (snd-display #__line__ ";window height: ~A is not 300?" (window-height)))
+ (snd-display ";window height: ~A is not 300?" (window-height)))
; (set! (window-x) 123)
; (set! (window-y) 321)
; (if (not (equal? (window-x) 123))
- ; (snd-display #__line__ ";window x: ~A is not 123?" (window-x)))
+ ; (snd-display ";window x: ~A is not 123?" (window-x)))
; (if (not (equal? (window-y) 321))
- ; (snd-display #__line__ ";window y: ~A is not 321?" (window-y)))
+ ; (snd-display ";window y: ~A is not 321?" (window-y)))
; (set! (window-y) 10) ; get it back out of harm's way
(set! *color-scale* 100.0)
- (if (fneq *color-scale* 100.0) (snd-display #__line__ ";color-scale to 100: ~A" *color-scale*))
+ (if (fneq *color-scale* 100.0) (snd-display ";color-scale to 100: ~A" *color-scale*))
(if (procedure? (search-procedure))
- (snd-display #__line__ ";global search procedure: ~A?" (search-procedure)))
+ (snd-display ";global search procedure: ~A?" (search-procedure)))
(set! (search-procedure) (lambda (y) (> y .1)))
(if (not (procedure? (search-procedure)))
- (snd-display #__line__ ";set global search procedure: ~A?" (search-procedure)))
+ (snd-display ";set global search procedure: ~A?" (search-procedure)))
(if (not ((search-procedure) .2))
- (snd-display #__line__ ";search > .1 .2"))
+ (snd-display ";search > .1 .2"))
(if ((search-procedure) .02)
- (snd-display #__line__ ";search > .1 .02"))
+ (snd-display ";search > .1 .02"))
(set! (search-procedure) (lambda (y) (< y 0.0)))
(if ((search-procedure) .02)
- (snd-display #__line__ ";search < 0.0 .02"))
+ (snd-display ";search < 0.0 .02"))
(set! (search-procedure) #f)
(if (procedure? (search-procedure))
- (snd-display #__line__ ";global search procedure after reset: ~A?" (search-procedure)))
+ (snd-display ";global search procedure after reset: ~A?" (search-procedure)))
(set! (search-procedure) (lambda (y) (> y .1)))
(if (not (procedure? (search-procedure)))
- (snd-display #__line__ ";set global search procedure: ~A?" (search-procedure)))
+ (snd-display ";set global search procedure: ~A?" (search-procedure)))
(set! *enved-filter-order* 5)
- (if (not (= *enved-filter-order* 6)) (snd-display #__line__ ";set enved-filter-order 5: ~A" *enved-filter-order*))
+ (if (not (= *enved-filter-order* 6)) (snd-display ";set enved-filter-order 5: ~A" *enved-filter-order*))
(if with-gui
(begin
(set! (enved-envelope) 'zero_to_one) ; funcs.scm above
- (if (not (feql (enved-envelope) zero_to_one)) (snd-display #__line__ ";set symbol enved-envelope: ~A ~A" (enved-envelope) zero_to_one))
+ (if (not (feql (enved-envelope) zero_to_one)) (snd-display ";set symbol enved-envelope: ~A ~A" (enved-envelope) zero_to_one))
(set! (enved-envelope) "mod_down")
- (if (not (feql (enved-envelope) mod_down)) (snd-display #__line__ ";set string enved-envelope: ~A ~A" (enved-envelope) mod_down))))
+ (if (not (feql (enved-envelope) mod_down)) (snd-display ";set string enved-envelope: ~A ~A" (enved-envelope) mod_down))))
(dismiss-all-dialogs))
(close-sound ind)
@@ -2429,7 +2270,7 @@
'speed-control-bounds 'speed-control-style 'speed-control-tones 'square-wave 'square-wave?
'squelch-update 'srate 'src 'src-channel 'src-selection
'src-sound 'src? 'ssb-am 'ssb-am?
- 'start-playing 'start-playing-hook 'start-playing-selection-hook 'start-progress-report
+ 'start-playing 'start-playing-hook 'start-playing-selection-hook 'start-progress-report 'stdin-prompt
'stop-player 'stop-playing 'stop-playing-hook 'stop-playing-selection-hook 'ncos
'ncos? 'nsin 'nsin? 'swap-channels 'sync 'sync-style 'sync-none 'sync-all 'sync-by-sound
'sync-max 'syncd-marks 'table-lookup 'table-lookup? 'tap 'tap?
@@ -2466,7 +2307,7 @@
(set! undef (cons n undef))))
names)
(if (pair? undef)
- (snd-display #__line__ ";undefined: ~A" undef)))
+ (snd-display ";undefined: ~A" undef)))
))
@@ -2479,2009 +2320,1845 @@
(require snd-mix.scm snd-env.scm)
-(definstrument (out-samps beg chan data)
- (let ((len (length data)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (out-any (+ beg i) (data i) chan))))
-
-(definstrument (out-samps-invert beg chan data)
- (let ((len (length data)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (out-any (+ beg i) (- (data i)) chan))))
-
(define (snd_test_4)
- (define (frame->byte file fr)
- (+ (mus-sound-data-location file)
- (* (mus-sound-chans file)
- (mus-sound-datum-size file)
- fr)))
-
(do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
(log-mem clmtest)
(clear-listener)
- (let ((chns (mus-sound-chans "oboe.snd"))
- (dl (mus-sound-data-location "oboe.snd"))
- (fr (mus-sound-framples "oboe.snd"))
- (smps (mus-sound-samples "oboe.snd"))
- (len (mus-sound-length "oboe.snd"))
- (size (mus-sound-datum-size "oboe.snd"))
- (com (mus-sound-comment "oboe.snd"))
- (sr (mus-sound-srate "oboe.snd"))
- (m1 (mus-sound-maxamp-exists? "oboe.snd"))
- (mal (mus-sound-maxamp "oboe.snd"))
- (mz (mus-sound-maxamp "z.snd"))
- (bytes (mus-bytes-per-sample (mus-sound-sample-type "oboe.snd"))))
+ (let ((mz (mus-sound-maxamp "z.snd")))
(if (or (not (= (car mz) 0))
(fneq (cadr mz) 0.0))
- (snd-display #__line__ ";mus-sound-maxamp z.snd: ~A (~A ~A)" mz (not (= (car mz) 0)) (fneq (cadr mz) 0.0)))
- (let ((formats (list mus-bshort mus-lshort mus-mulaw mus-alaw mus-byte mus-ubyte mus-bfloat mus-lfloat
- mus-bint mus-lint mus-bintn mus-lintn mus-b24int mus-l24int mus-bdouble mus-ldouble
- mus-ubshort mus-ulshort mus-bdouble-unscaled mus-ldouble-unscaled mus-bfloat-unscaled
- mus-lfloat-unscaled))
- (sizes (list 2 2 1 1 1 1 4 4
- 4 4 4 4 3 3 8 8
- 2 2 8 8 4
- 4)))
- (for-each
- (lambda (frm siz)
- (if (not (= (mus-bytes-per-sample frm) siz))
- (snd-display #__line__ ";mus-bytes-per-sample ~A: ~A" (mus-sample-type-name frm) siz)))
- formats
- sizes))
- (if (not (string=? (mus-sample-type->string mus-bshort) "mus-bshort"))
- (snd-display #__line__ ";mus-sample-type->string: ~A" (mus-sample-type->string mus-bshort)))
- (if (not (string=? (mus-header-type->string mus-aifc) "mus-aifc"))
- (snd-display #__line__ ";mus-header-type->string: ~A" (mus-header-type->string mus-aifc)))
- (mus-sound-report-cache "hiho.tmp")
- (let ((p (open-input-file "hiho.tmp")))
- (if (not p)
- (snd-display #__line__ ";mus-sound-report-cache->hiho.tmp failed?")
- (let ((line (read-line p)))
- (if (or (not (string? line))
- (and (not (string=? line "sound table:"))
- (not (string=? line (string-append "sound table:" (string #\newline))))))
- (snd-display #__line__ ";print-cache 1: ~A?" line))
- (close-input-port p)
- (delete-file "hiho.tmp"))))
- (if (not (= chns 1)) (snd-display #__line__ ";oboe: mus-sound-chans ~D?" chns))
- (if (not (= dl 28)) (snd-display #__line__ ";oboe: mus-sound-data-location ~D (~A)?" dl (= dl 28)))
- (if (not (= fr 50828)) (snd-display #__line__ ";oboe: mus-sound-framples ~D?" fr))
- (if (not (= smps 50828)) (snd-display #__line__ ";oboe: mus-sound-samples ~D?" smps))
- (if (not (= len (+ 28 (* 2 50828)))) (snd-display #__line__ ";oboe: mus-sound-length ~D?" len))
- (if (not (= size 2)) (snd-display #__line__ ";oboe: mus-sound-datum-size ~D?" size))
- (if (not (= bytes 2)) (snd-display #__line__ ";oboe: sound-bytes ~D?" bytes))
- (if (not (= sr 22050)) (snd-display #__line__ ";oboe: mus-sound-srate ~D?" sr))
- (if (and m1 (= clmtest 0)) (snd-display #__line__ ";oboe: mus-sound-maxamp-exists before maxamp: ~A" m1))
- (if (not (mus-sound-maxamp-exists? "oboe.snd"))
- (snd-display #__line__ ";oboe: not mus-sound-maxamp-exists after maxamp: ~A" (mus-sound-maxamp-exists? "oboe.snd")))
-
- (if (= clmtest 0)
- (let ((vals (mus-header-raw-defaults)))
- (if (or (not (list? vals))
- (not (= (length vals) 3)))
- (snd-display #__line__ ";mus-header-raw-defaults: ~A" vals)
- (let ((sr (car vals))
- (chns (cadr vals))
- (frm (caddr vals)))
- (if (not (= sr 44100)) (snd-display #__line__ ";mus-header-raw-defaults srate: ~A" sr))
- (if (not (= chns 2)) (snd-display #__line__ ";mus-header-raw-defaults chns: ~A" chns))
- (if (not (= frm mus-bshort)) (snd-display #__line__ ";mus-header-raw-defaults format: ~A: ~A" frm (mus-sample-type-name frm)))))))
- (set! (mus-header-raw-defaults) (list 12345 3 mus-bdouble-unscaled))
- (let ((vals (mus-header-raw-defaults)))
- (if (or (not (list? vals))
- (not (= (length vals) 3)))
- (snd-display #__line__ ";set mus-header-raw-defaults: ~A" vals)
- (let ((sr (car vals))
- (chns (cadr vals))
- (frm (caddr vals)))
- (if (not (= sr 12345)) (snd-display #__line__ ";set mus-header-raw-defaults srate: ~A" sr))
- (if (not (= chns 3)) (snd-display #__line__ ";set mus-header-raw-defaults chns: ~A" chns))
- (if (not (= frm mus-bdouble-unscaled)) (snd-display #__line__ ";set mus-header-raw-defaults format: ~A: ~A" frm (mus-sample-type-name frm))))))
- (set! (mus-header-raw-defaults) (list 44100 2 mus-bshort))
-
- (let ((str (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "oboe.snd")))))
- (if (not (string=? str "23-Nov 06:56 PST"))
- (snd-display #__line__ ";mus-sound-write-date oboe.snd: ~A?" str)))
- (let ((str (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "pistol.snd")))))
- (if (not (string=? str "23-Nov 06:56 PST"))
- (snd-display #__line__ ";mus-sound-write-date pistol.snd: ~A?" str)))
-
- (let ((index (open-sound "oboe.snd"))
- (long-file-name (let ((name "test"))
- (do ((i 0 (+ i 1)))
- ((= i 10)) ; 40 is about the limit in Linux (256 char limit here from OS, not Snd)
- (set! name (string-append name "-test")))
- (string-append name ".snd"))))
- (if (variable-graph? index) (snd-display #__line__ ";variable-graph thinks anything is a graph..."))
- (if (player? index) (snd-display #__line__ ";player? thinks anything is a player..."))
- (if (not (sound? index)) (snd-display #__line__ ";~A is not a sound?" index))
- (if (sound? #f) (snd-display #__line__ ";sound? #f -> #t?"))
- (if (sound? #t) (snd-display #__line__ ";sound? #t -> #t?"))
- (save-sound-as long-file-name index)
- (close-sound index)
- (set! index (open-sound long-file-name))
- (if (not (sound? index)) (snd-display #__line__ ";can't find test...snd"))
- (if (or (< (length (file-name index)) (length long-file-name))
- (< (length (short-file-name index)) (length long-file-name)))
- (snd-display #__line__ ";file-name lengths: ~A ~A ~A"
- (length (file-name index))
- (length (short-file-name index))
- (length long-file-name)))
- (close-sound index)
- (mus-sound-forget long-file-name)
- (delete-file long-file-name))
-
- (let ((old-sound-path *mus-sound-path*)
- (new-path (if (provided? 'osx) "/Users/bil/sf1" "/home/bil/sf1")))
- (set! *mus-sound-path* (list new-path))
- (let ((ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f))))
- (if (not (sound? ind))
- (snd-display #__line__ ";*mus-sound-path*: ~A~%" ind)
- (begin
- (close-sound ind)
- (set! (mus-sound-path) (list new-path))
- (set! ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f)))
- (if (not (sound? ind))
- (snd-display #__line__ ";(mus-sound-path): ~A~%" ind)
- (close-sound ind)))))
- (set! *mus-sound-path* old-sound-path))
-
- (let ((fsnd (string-append sf-dir "forest.aiff")))
- (if (file-exists? fsnd)
+ (snd-display ";mus-sound-maxamp z.snd: ~A (~A ~A)" mz (not (= (car mz) 0)) (fneq (cadr mz) 0.0))))
+ (let ((formats (list mus-bshort mus-lshort mus-mulaw mus-alaw mus-byte mus-ubyte mus-bfloat mus-lfloat
+ mus-bint mus-lint mus-bintn mus-lintn mus-b24int mus-l24int mus-bdouble mus-ldouble
+ mus-ubshort mus-ulshort mus-bdouble-unscaled mus-ldouble-unscaled mus-bfloat-unscaled
+ mus-lfloat-unscaled))
+ (sizes (list 2 2 1 1 1 1 4 4
+ 4 4 4 4 3 3 8 8
+ 2 2 8 8 4
+ 4)))
+ (for-each
+ (lambda (frm siz)
+ (if (not (= (mus-bytes-per-sample frm) siz))
+ (snd-display ";mus-bytes-per-sample ~A: ~A" (mus-sample-type-name frm) siz)))
+ formats
+ sizes))
+ (if (not (string=? (mus-sample-type->string mus-bshort) "mus-bshort"))
+ (snd-display ";mus-sample-type->string: ~A" (mus-sample-type->string mus-bshort)))
+ (if (not (string=? (mus-header-type->string mus-aifc) "mus-aifc"))
+ (snd-display ";mus-header-type->string: ~A" (mus-header-type->string mus-aifc)))
+ (mus-sound-report-cache "hiho.tmp")
+ (let ((p (open-input-file "hiho.tmp")))
+ (let ((line (read-line p)))
+ (if (not (member line '("sound table:" "sound table:\n")))
+ (snd-display ";print-cache 1: ~A?" line))
+ (close-input-port p)
+ (delete-file "hiho.tmp")))
+ (let ((chns (mus-sound-chans "oboe.snd")))
+ (if (not (= chns 1)) (snd-display ";oboe: mus-sound-chans ~D?" chns)))
+ (if (= clmtest 0)
+ (let ((m1 (mus-sound-maxamp-exists? "oboe.snd")))
+ (if (and m1 (= clmtest 0)) (snd-display ";oboe: mus-sound-maxamp-exists before maxamp: ~A" m1))
+ (let ((mal (mus-sound-maxamp "oboe.snd")))
+ (if (fneq (cadr mal) .14724) (snd-display ";oboe: mus-sound-maxamp ~F?" (cadr mal)))
+ (if (not (= (car mal) 24971)) (snd-display ";oboe: mus-sound-maxamp at ~D?" (car mal))))
+ (if (not (mus-sound-maxamp-exists? "oboe.snd"))
+ (snd-display ";oboe: not mus-sound-maxamp-exists after maxamp: ~A" (mus-sound-maxamp-exists? "oboe.snd")))))
+ (let ((dl (mus-sound-data-location "oboe.snd")))
+ (if (not (= dl 28)) (snd-display ";oboe: mus-sound-data-location ~D (~A)?" dl (= dl 28))))
+ (let ((fr (mus-sound-framples "oboe.snd")))
+ (if (not (= fr 50828)) (snd-display ";oboe: mus-sound-framples ~D?" fr)))
+ (let ((smps (mus-sound-samples "oboe.snd")))
+ (if (not (= smps 50828)) (snd-display ";oboe: mus-sound-samples ~D?" smps)))
+ (let ((len (mus-sound-length "oboe.snd")))
+ (if (not (= len 101684)) (snd-display ";oboe: mus-sound-length ~D?" len)))
+ (let ((size (mus-sound-datum-size "oboe.snd")))
+ (if (not (= size 2)) (snd-display ";oboe: mus-sound-datum-size ~D?" size)))
+ (let ((bytes (mus-bytes-per-sample (mus-sound-sample-type "oboe.snd"))))
+ (if (not (= bytes 2)) (snd-display ";oboe: sound-bytes ~D?" bytes)))
+ (let ((sr (mus-sound-srate "oboe.snd")))
+ (if (not (= sr 22050)) (snd-display ";oboe: mus-sound-srate ~D?" sr)))
+
+ (if (= clmtest 0)
+ (let ((vals (mus-header-raw-defaults)))
+ (if (not (and (list? vals)
+ (= (length vals) 3)))
+ (snd-display ";mus-header-raw-defaults: ~A" vals)
+ (let ((sr (car vals))
+ (chns (cadr vals))
+ (frm (caddr vals)))
+ (if (not (= sr 44100)) (snd-display ";mus-header-raw-defaults srate: ~A" sr))
+ (if (not (= chns 2)) (snd-display ";mus-header-raw-defaults chns: ~A" chns))
+ (if (not (= frm mus-bshort)) (snd-display ";mus-header-raw-defaults format: ~A: ~A" frm (mus-sample-type-name frm)))))))
+ (set! (mus-header-raw-defaults) (list 12345 3 mus-bdouble-unscaled))
+ (let ((vals (mus-header-raw-defaults)))
+ (if (not (and (list? vals)
+ (= (length vals) 3)))
+ (snd-display ";set mus-header-raw-defaults: ~A" vals)
+ (let ((sr (car vals))
+ (chns (cadr vals))
+ (frm (caddr vals)))
+ (if (not (= sr 12345)) (snd-display ";set mus-header-raw-defaults srate: ~A" sr))
+ (if (not (= chns 3)) (snd-display ";set mus-header-raw-defaults chns: ~A" chns))
+ (if (not (= frm mus-bdouble-unscaled)) (snd-display ";set mus-header-raw-defaults format: ~A: ~A" frm (mus-sample-type-name frm))))))
+ (set! (mus-header-raw-defaults) (list 44100 2 mus-bshort))
+
+ (let ((str (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "oboe.snd")))))
+ (if (not (string=? str "23-Nov 06:56 PST"))
+ (snd-display ";mus-sound-write-date oboe.snd: ~A?" str)))
+ (let ((str (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "pistol.snd")))))
+ (if (not (string=? str "23-Nov 06:56 PST"))
+ (snd-display ";mus-sound-write-date pistol.snd: ~A?" str)))
+
+ (let ((index (open-sound "oboe.snd"))
+ (long-file-name (let ((name "test"))
+ (do ((i 0 (+ i 1)))
+ ((= i 10)) ; 40 is about the limit in Linux (256 char limit here from OS, not Snd)
+ (set! name (string-append name "-test")))
+ (string-append name ".snd"))))
+ (if (variable-graph? index) (snd-display ";variable-graph thinks anything is a graph..."))
+ (if (player? index) (snd-display ";player? thinks anything is a player..."))
+ (if (not (sound? index)) (snd-display ";~A is not a sound?" index))
+ (if (sound? #f) (snd-display ";sound? #f -> #t?"))
+ (if (sound? #t) (snd-display ";sound? #t -> #t?"))
+ (save-sound-as long-file-name index)
+ (close-sound index)
+ (set! index (open-sound long-file-name))
+ (if (not (sound? index)) (snd-display ";can't find test...snd"))
+ (if (or (< (length (file-name index)) (length long-file-name))
+ (< (length (short-file-name index)) (length long-file-name)))
+ (snd-display ";file-name lengths: ~A ~A ~A"
+ (length (file-name index))
+ (length (short-file-name index))
+ (length long-file-name)))
+ (close-sound index)
+ (mus-sound-forget long-file-name)
+ (delete-file long-file-name))
+
+ (let ((old-sound-path *mus-sound-path*)
+ (new-path (if (provided? 'osx) "/Users/bil/sf1" "/home/bil/sf1")))
+ (set! *mus-sound-path* (list new-path))
+ (let ((ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f))))
+ (if (not (sound? ind))
+ (snd-display ";*mus-sound-path*: ~A~%" ind)
(begin
- (system (format #f "cp ~A fmv.snd" fsnd))
- (let ((index (open-sound "fmv.snd")))
- (if (not (equal? (sound-loop-info index) (mus-sound-loop-info fsnd)))
- (snd-display #__line__ ";loop-info: ~A ~A" (sound-loop-info index) (mus-sound-loop-info fsnd)))
- (set! (sound-loop-info index) (list 12000 14000 1 2 3 4))
- (if (not (equal? (sound-loop-info index) (list 12000 14000 1 2 3 4 1 1)))
- (snd-display #__line__ ";set loop-info: ~A" (sound-loop-info index)))
- (save-sound-as "fmv1.snd" index :header-type mus-aifc)
- (close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 12000 14000 1 2 3 4 1 1)))
- (snd-display #__line__ ";saved loop-info: ~A" (mus-sound-loop-info "fmv1.snd"))))))
- (let ((index (open-sound "oboe.snd")))
- (save-sound-as "fmv.snd" index :header-type mus-aifc)
- (close-sound index))
- (let ((index (open-sound "fmv.snd")))
- (if (not (null? (sound-loop-info index)))
- (snd-display #__line__ ";null loop-info: ~A" (sound-loop-info index)))
- (set! (sound-loop-info index) (list 1200 1400 4 3 2 1))
- (if (not (equal? (sound-loop-info index) (list 1200 1400 4 3 2 1 1 1)))
- (snd-display #__line__ ";set null loop-info: ~A" (sound-loop-info index)))
- (save-sound-as "fmv1.snd" :sound index :header-type mus-aifc)
- (close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 4 3 2 1 1 1)))
- (snd-display #__line__ ";saved null loop-info: ~A" (mus-sound-loop-info "fmv1.snd"))))
- (let ((index (open-sound "fmv.snd")))
- (set! (sound-loop-info) (list 1200 1400 4 3 2 1 1 0))
- (if (not (equal? (sound-loop-info index) (list 1200 1400 0 0 2 1 1 0)))
- (snd-display #__line__ ";set null loop-info (no mode1): ~A" (sound-loop-info index)))
- (save-sound-as "fmv1.snd" index :header-type mus-aifc)
- (close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 0 0 2 1 1 0)))
- (snd-display #__line__ ";saved null loop-info (no mode1): ~A" (mus-sound-loop-info "fmv1.snd")))))
-
- (if (> (length com) 0) (snd-display #__line__ ";oboe: mus-sound-comment ~A?" com))
+ (close-sound ind)
+ (set! (mus-sound-path) (list new-path))
+ (set! ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f)))
+ (if (sound? ind)
+ (close-sound ind)
+ (snd-display ";(mus-sound-path): ~A~%" ind)))))
+ (set! *mus-sound-path* old-sound-path))
+
+ (let ((fsnd (string-append sf-dir "forest.aiff")))
+ (if (file-exists? fsnd)
+ (begin
+ (system (format #f "cp ~A fmv.snd" fsnd))
+ (let ((index (open-sound "fmv.snd")))
+ (if (not (equal? (sound-loop-info index) (mus-sound-loop-info fsnd)))
+ (snd-display ";loop-info: ~A ~A" (sound-loop-info index) (mus-sound-loop-info fsnd)))
+ (set! (sound-loop-info index) (list 12000 14000 1 2 3 4))
+ (if (not (equal? (sound-loop-info index) (list 12000 14000 1 2 3 4 1 1)))
+ (snd-display ";set loop-info: ~A" (sound-loop-info index)))
+ (save-sound-as "fmv1.snd" index :header-type mus-aifc)
+ (close-sound index)
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 12000 14000 1 2 3 4 1 1)))
+ (snd-display ";saved loop-info: ~A" (mus-sound-loop-info "fmv1.snd")))))))
+ (let ((index (open-sound "oboe.snd")))
+ (save-sound-as "fmv.snd" index :header-type mus-aifc)
+ (close-sound index))
+ (let ((index (open-sound "fmv.snd")))
+ (if (not (null? (sound-loop-info index)))
+ (snd-display ";null loop-info: ~A" (sound-loop-info index)))
+ (set! (sound-loop-info index) (list 1200 1400 4 3 2 1))
+ (if (not (equal? (sound-loop-info index) (list 1200 1400 4 3 2 1 1 1)))
+ (snd-display ";set null loop-info: ~A" (sound-loop-info index)))
+ (save-sound-as "fmv1.snd" :sound index :header-type mus-aifc)
+ (close-sound index)
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 4 3 2 1 1 1)))
+ (snd-display ";saved null loop-info: ~A" (mus-sound-loop-info "fmv1.snd"))))
+ (let ((index (open-sound "fmv.snd")))
+ (set! (sound-loop-info) (list 1200 1400 4 3 2 1 1 0))
+ (if (not (equal? (sound-loop-info index) (list 1200 1400 0 0 2 1 1 0)))
+ (snd-display ";set null loop-info (no mode1): ~A" (sound-loop-info index)))
+ (save-sound-as "fmv1.snd" index :header-type mus-aifc)
+ (close-sound index)
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 0 0 2 1 1 0)))
+ (snd-display ";saved null loop-info (no mode1): ~A" (mus-sound-loop-info "fmv1.snd"))))
+
+ (let ((com (mus-sound-comment "oboe.snd")))
+ (if (not (equal? com "")) (snd-display ";oboe: mus-sound-comment ~A?" com))
(let ((fsnd (string-append sf-dir "nasahal8.wav")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com))
- (not (string=? com
- (string-append "ICRD: 1997-02-22"
- (string #\newline)
- "IENG: Paul R. Roger"
- (string #\newline)
- "ISFT: Sound Forge 4.0"
- (string #\newline)))))
- (snd-display #__line__ ";mus-sound-comment \"nasahal8.wav\") -> ~A?" com)))))
+ (if (not (equal? com "ICRD: 1997-02-22\nIENG: Paul R. Roger\nISFT: Sound Forge 4.0\n"))
+ (snd-display ";mus-sound-comment \"nasahal8.wav\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "8svx-8.snd")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "File created by Sound Exchange ")))
- (snd-display #__line__ ";mus-sound-comment \"8svx-8.snd\") -> ~A?" com)))))
+ (if (not (equal? com "File created by Sound Exchange "))
+ (snd-display ";mus-sound-comment \"8svx-8.snd\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "sun-16-afsp.snd")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "AFspdate:1981/02/11 23:03:34 UTC")))
- (snd-display #__line__ ";mus-sound-comment \"sun-16-afsp.snd\") -> ~A?" com)))))
+ (if (not (equal? com "AFspdate:1981/02/11 23:03:34 UTC"))
+ (snd-display ";mus-sound-comment \"sun-16-afsp.snd\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "smp-16.snd")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "Converted using Sox. ")))
- (snd-display #__line__ ";mus-sound-comment \"smp-16.snd\") -> ~A?" com)))))
+ (if (not (equal? com "Converted using Sox. "))
+ (snd-display ";mus-sound-comment \"smp-16.snd\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "d40130.au")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "1994 Jesus Villena")))
- (snd-display #__line__ ";mus-sound-comment \"d40130.au\") -> ~A?" com)))))
+ (if (not (equal? com "1994 Jesus Villena"))
+ (snd-display ";mus-sound-comment \"d40130.au\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "wood.maud")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "file written by SOX MAUD-export ")))
- (snd-display #__line__ ";mus-sound-comment \"wood.maud\") -> ~A?" com)))))
+ (if (not (equal? com "file written by SOX MAUD-export "))
+ (snd-display ";mus-sound-comment \"wood.maud\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "addf8.sf_mipseb")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com))
- (not (string=? com "date=\"Feb 11 18:03:34 1981\" info=\"Original recorded at 20 kHz, 15-bit D/A, digitally filtered and resampled\" speaker=\"AMK female\" text=\"Add the sum to the product of these three.\" ")))
- (snd-display #__line__ ";mus-sound-comment \"addf8.sf_mipseb\") -> ~A?" com)))))
+ (if (not (equal? com "date=\"Feb 11 18:03:34 1981\" info=\"Original recorded at 20 kHz, 15-bit D/A, digitally filtered and resampled\" speaker=\"AMK female\" text=\"Add the sum to the product of these three.\" "))
+ (snd-display ";mus-sound-comment \"addf8.sf_mipseb\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "mary-sun4.sig")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com (string-append "MARY HAD A LITTLE LAMB" (string #\newline)))))
- (snd-display #__line__ ";mus-sound-comment \"mary-sun4.sig\") -> ~A?" com)))))
+ (if (not (equal? com "MARY HAD A LITTLE LAMB\n"))
+ (snd-display ";mus-sound-comment \"mary-sun4.sig\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "nasahal.pat")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "This patch saved with Sound Forge 3.0.")))
- (snd-display #__line__ ";mus-sound-comment \"nasahal.pat\") -> ~A?" com)))))
+ (if (not (equal? com "This patch saved with Sound Forge 3.0."))
+ (snd-display ";mus-sound-comment \"nasahal.pat\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "next-16.snd")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com))
- (not (string=? com ";Written on Mon 1-Jul-91 at 12:10 PDT at localhost (NeXT) using Allegro CL and clm of 25-June-91")))
- (snd-display #__line__ ";mus-sound-comment \"next-16.snd\") -> ~A?" com)))))
+ (if (not (equal? com ";Written on Mon 1-Jul-91 at 12:10 PDT at localhost (NeXT) using Allegro CL and clm of 25-June-91"))
+ (snd-display ";mus-sound-comment \"next-16.snd\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "wood16.nsp")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "Created by Snack ")))
- (snd-display #__line__ ";mus-sound-comment \"wood16.nsp\") -> ~A?" com)))))
+ (if (not (equal? com "Created by Snack "))
+ (snd-display ";mus-sound-comment \"wood16.nsp\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "wood.sdx")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "1994 Jesus Villena")))
- (snd-display #__line__ ";mus-sound-comment \"wood.sdx\") -> ~A?" com)))))
+ (if (not (equal? com "1994 Jesus Villena"))
+ (snd-display ";mus-sound-comment \"wood.sdx\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "clmcom.aif")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com "this is a comment")))
- (snd-display #__line__ ";mus-sound-comment \"clmcom.aif\") -> ~A?" com)))))
+ (if (not (equal? com "this is a comment"))
+ (snd-display ";mus-sound-comment \"clmcom.aif\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "anno.aif")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com)) (not (string=? com (string-append "1994 Jesus Villena" (string #\newline)))))
- (snd-display #__line__ ";mus-sound-comment \"anno.aif\") -> ~A?" com)))))
+ (if (not (equal? com "1994 Jesus Villena\n"))
+ (snd-display ";mus-sound-comment \"anno.aif\") -> ~A?" com)))))
(let ((fsnd (string-append sf-dir "telephone.wav")))
(if (file-exists? fsnd)
(begin
(set! com (mus-sound-comment fsnd))
- (if (or (not (string? com))
- (not (string=? com (string-append "sample_byte_format -s2 01"
- (string #\newline)
- "channel_count -i 1"
- (string #\newline)
- "sample_count -i 36461"
- (string #\newline)
- "sample_rate -i 16000"
- (string #\newline)
- "sample_n_bytes -i 2"
- (string #\newline)
- "sample_sig_bits -i 16"
- (string #\newline)))))
- (snd-display #__line__ ";mus-sound-comment \"telephone.wav\") -> ~A?" com)))))
-
- (if (not (string? (mus-sound-comment (string-append sf-dir "traffic.aiff"))))
- (snd-display #__line__ ";mus-sound-comment traffic: ~A" (mus-sound-comment (string-append sf-dir "traffic.aiff"))))
-
- (if (= clmtest 0)
- (begin
- (if (fneq (cadr mal) .14724) (snd-display #__line__ ";oboe: mus-sound-maxamp ~F?" (cadr mal)))
- (if (not (= (car mal) 24971)) (snd-display #__line__ ";oboe: mus-sound-maxamp at ~D?" (car mal)))))
- (if (and (not (= (mus-sound-type-specifier "oboe.snd") #x646e732e)) ;little endian reader
- (not (= (mus-sound-type-specifier "oboe.snd") #x2e736e64))) ;big endian reader
- (snd-display #__line__ ";oboe: mus-sound-type-specifier: ~X?" (mus-sound-type-specifier "oboe.snd")))
- (if (not (string=? (strftime "%d-%b-%Y %H:%M" (localtime (file-write-date "oboe.snd"))) "23-Nov-2012 06:56"))
- (snd-display #__line__ ";oboe: file-write-date: ~A?" (strftime "%d-%b-%Y %H:%M" (localtime (file-write-date "oboe.snd")))))
+ (if (not (equal? com "sample_byte_format -s2 01\nchannel_count -i 1\nsample_count -i 36461\nsample_rate -i 16000\nsample_n_bytes -i 2\nsample_sig_bits -i 16\n"))
+ (snd-display ";mus-sound-comment \"telephone.wav\") -> ~A?" com))))))
+
+ (if (not (string? (mus-sound-comment (string-append sf-dir "traffic.aiff"))))
+ (snd-display ";mus-sound-comment traffic: ~A" (mus-sound-comment (string-append sf-dir "traffic.aiff"))))
+
+ (if (not (member (mus-sound-type-specifier "oboe.snd") '(#x646e732e #x2e736e64) =))
+ (snd-display ";oboe: mus-sound-type-specifier: ~X?" (mus-sound-type-specifier "oboe.snd")))
+ (if (not (string=? (strftime "%d-%b-%Y %H:%M" (localtime (file-write-date "oboe.snd"))) "23-Nov-2012 06:56"))
+ (snd-display ";oboe: file-write-date: ~A?" (strftime "%d-%b-%Y %H:%M" (localtime (file-write-date "oboe.snd")))))
; (mus-sound-forget "oboe.snd")
+
+ (let ((lasth (do ((i 1 (+ i 1)))
+ ((string=? (mus-header-type-name i) "unknown") i))))
+ (if (< lasth 50) (snd-display ";header-type[~A] = ~A" lasth (mus-header-type-name lasth))))
+ (let ((lasth (do ((i 1 (+ i 1)))
+ ((string=? (mus-sample-type-name i) "unknown") i))))
+ (if (< lasth 10) (snd-display ";sample-type[~A] = ~A" lasth (mus-sample-type-name lasth))))
+
+ (when with-gui
+ (set! *transform-normalization* dont-normalize)
+ (if (not (= *transform-normalization* dont-normalize))
+ (snd-display ";set-transform-normalization none -> ~A" *transform-normalization*))
+ (set! *transform-normalization* normalize-globally)
+ (if (not (= *transform-normalization* normalize-globally))
+ (snd-display ";set-transform-normalization globally -> ~A" *transform-normalization*))
+ (set! *transform-normalization* normalize-by-channel)
+ (if (not (= *transform-normalization* normalize-by-channel))
+ (snd-display ";set-transform-normalization channel -> ~A" *transform-normalization*)))
+
+ (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "set-samples test" 100)))
+ (set! (samples 10 3) (make-float-vector 3 .1))
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";1 set samples 0 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (set! (samples 20 3 ind 0) (make-float-vector 3 .1))
+ (if (not (vequal (channel->float-vector 10 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";2 set samples 10 for .1: ~A" (channel->float-vector 10 20 ind 0)))
+ (set! (samples 30 3 ind 0 #f "a name") (make-float-vector 3 .1))
+ (if (not (vequal (channel->float-vector 20 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";3 set samples 20 for .1: ~A" (channel->float-vector 20 20 ind 0)))
+ (set! (samples 0 3 ind 0 #f "a name" 0 1) (make-float-vector 3 .2))
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .2 .2 .2 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";4 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (if (not (vequal (channel->float-vector 20 20 ind 0) (make-float-vector 20 0.0)))
+ (snd-display ";5 set samples 20 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (let ((nd (new-sound "fmv1.snd" :channels 2)))
+ (float-vector->channel (make-float-vector 10 .5) 0 10 nd 0)
+ (float-vector->channel (make-float-vector 10 .3) 0 10 nd 1)
+ (save-sound-as "fmv1.snd" nd)
+ (close-sound nd))
+ (if (not (file-exists? "fmv1.snd")) (snd-display ";fmv1 not saved??"))
+ (set! (samples 0 10 ind 0 #f "another name" 1) "fmv1.snd")
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 .1 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";6 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (set! (samples 5 6 ind 0 #f "another name 7" 0) "fmv1.snd")
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .5 .5 .5 .5 .5 .5 .1 .1 0 0 0 0 0 0 0)))
+ (snd-display ";7 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (revert-sound ind)
+ (set! (samples 0 10 ind 0 #f "another name 8" 1 0 #f) "fmv1.snd")
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 0 0 0 0 0 0 0 0 0 0)))
+ (snd-display ";8 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (set! (samples 10 10 ind 0 #f "another name 9" 0 0) "fmv1.snd")
+ (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)))
+ (snd-display ";9 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
+ (set! (samples 20 10) "fmv1.snd")
+ (if (not (vequal (channel->float-vector 10 20 ind 0) (make-float-vector 20 .5)))
+ (snd-display ";10 set samples 0 at 1 for .1: ~A" (channel->float-vector 10 20 ind 0)))
+ (revert-sound ind)
+ (set! (samples 0 10 ind 0 #t "another name" 1 0 #f) "fmv1.snd")
+ (if (not (= (framples ind 0) 10)) (snd-display ";11 set-samples truncate to ~A" (framples ind 0)))
+ (revert-sound ind)
+ (delete-file "fmv1.snd")
- (let ((lasth (do ((i 1 (+ i 1)))
- ((string=? (mus-header-type-name i) "unknown") i))))
- (if (< lasth 50) (snd-display #__line__ ";header-type[~A] = ~A" lasth (mus-header-type-name lasth))))
- (let ((lasth (do ((i 1 (+ i 1)))
- ((string=? (mus-sample-type-name i) "unknown") i))))
- (if (< lasth 10) (snd-display #__line__ ";sample-type[~A] = ~A" lasth (mus-sample-type-name lasth))))
-
- (when with-gui
- (set! *transform-normalization* dont-normalize)
- (if (not (= *transform-normalization* dont-normalize))
- (snd-display #__line__ ";set-transform-normalization none -> ~A" *transform-normalization*))
- (set! *transform-normalization* normalize-globally)
- (if (not (= *transform-normalization* normalize-globally))
- (snd-display #__line__ ";set-transform-normalization globally -> ~A" *transform-normalization*))
- (set! *transform-normalization* normalize-by-channel)
- (if (not (= *transform-normalization* normalize-by-channel))
- (snd-display #__line__ ";set-transform-normalization channel -> ~A" *transform-normalization*)))
-
- (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "set-samples test" 100)))
- (set! (samples 10 3) (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";1 set samples 0 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (set! (samples 20 3 ind 0) (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 10 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";2 set samples 10 for .1: ~A" (channel->float-vector 10 20 ind 0)))
- (set! (samples 30 3 ind 0 #f "a name") (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 20 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";3 set samples 20 for .1: ~A" (channel->float-vector 20 20 ind 0)))
- (set! (samples 0 3 ind 0 #f "a name" 0 1) (make-float-vector 3 .2))
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .2 .2 .2 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";4 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (if (not (vequal (channel->float-vector 20 20 ind 0) (make-float-vector 20 0.0)))
- (snd-display #__line__ ";5 set samples 20 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (let ((nd (new-sound "fmv1.snd" :channels 2)))
- (float-vector->channel (make-float-vector 10 .5) 0 10 nd 0)
- (float-vector->channel (make-float-vector 10 .3) 0 10 nd 1)
- (save-sound-as "fmv1.snd" nd)
- (close-sound nd))
- (if (not (file-exists? "fmv1.snd")) (snd-display #__line__ ";fmv1 not saved??"))
- (set! (samples 0 10 ind 0 #f "another name" 1) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 .1 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";6 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (set! (samples 5 6 ind 0 #f "another name 7" 0) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .5 .5 .5 .5 .5 .5 .1 .1 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";7 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (revert-sound ind)
- (set! (samples 0 10 ind 0 #f "another name 8" 1 0 #f) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";8 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (set! (samples 10 10 ind 0 #f "another name 9" 0 0) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)))
- (snd-display #__line__ ";9 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (set! (samples 20 10) "fmv1.snd")
- (if (not (vequal (channel->float-vector 10 20 ind 0) (make-float-vector 20 .5)))
- (snd-display #__line__ ";10 set samples 0 at 1 for .1: ~A" (channel->float-vector 10 20 ind 0)))
- (revert-sound ind)
- (set! (samples 0 10 ind 0 #t "another name" 1 0 #f) "fmv1.snd")
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";11 set-samples truncate to ~A" (framples ind 0)))
- (revert-sound ind)
- (delete-file "fmv1.snd")
-
- ;; now try to confuse it
- (let ((tag (catch #t
- (lambda () (set! (samples 0 10 ind 0) "fmv1.snd"))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-file)) (snd-display #__line__ ";set-samples, no such file: ~A" tag)))
- (let ((nd (new-sound "fmv1.snd" :channels 1)))
- (float-vector->channel (make-float-vector 10 .5) 0 10 nd 0)
- (save-sound-as "fmv1.snd" nd)
- (close-sound nd))
- (let ((tag (catch #t
- (lambda () (set! (samples 0 10 ind 0 #f "another name" 1) "fmv1.snd")) ; chan 1 does not exist
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-channel)) (snd-display #__line__ ";set-samples no such channel: ~A" tag)))
- (let ((tag (catch #t
- (lambda () (set! (samples 0 10 ind 0 #f "another name" -1) "fmv1.snd"))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-channel)) (snd-display #__line__ ";set-samples no such channel (-1): ~A" tag)))
- (let ((tag (catch #t
- (lambda () (set! (samples 0 -10) "fmv1.snd"))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";set-samples (-10): ~A" tag)))
- (let ((tag (catch #t
- (lambda () (set! (samples -10 10) "fmv1.snd"))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-sample)) (snd-display #__line__ ";set-samples (beg -10): ~A" tag)))
- (close-sound ind))
-
- (let ((len 100))
- (for-each
- (lambda (type allowed-diff)
- (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next))
- (v (make-float-vector len))
- (maxdiff 0.0)
- (maxpos #f))
- (set! (v 0) 0.999)
- (set! (v 1) -1.0)
- (set! (v 2) .1)
- (set! (v 3) -.1)
- (set! (v 4) .01)
- (set! (v 5) -.01)
- (set! (v 4) .001)
- (set! (v 5) -.001)
- (set! (v 6) 0.0)
- (do ((i 7 (+ i 1)))
+ ;; now try to confuse it
+ (let ((tag (catch #t
+ (lambda () (set! (samples 0 10 ind 0) "fmv1.snd"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-file)) (snd-display ";set-samples, no such file: ~A" tag)))
+ (let ((nd (new-sound "fmv1.snd" :channels 1)))
+ (float-vector->channel (make-float-vector 10 .5) 0 10 nd 0)
+ (save-sound-as "fmv1.snd" nd)
+ (close-sound nd))
+ (let ((tag (catch #t
+ (lambda () (set! (samples 0 10 ind 0 #f "another name" 1) "fmv1.snd")) ; chan 1 does not exist
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-channel)) (snd-display ";set-samples no such channel: ~A" tag)))
+ (let ((tag (catch #t
+ (lambda () (set! (samples 0 10 ind 0 #f "another name" -1) "fmv1.snd"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-channel)) (snd-display ";set-samples no such channel (-1): ~A" tag)))
+ (let ((tag (catch #t
+ (lambda () (set! (samples 0 -10) "fmv1.snd"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";set-samples (-10): ~A" tag)))
+ (let ((tag (catch #t
+ (lambda () (set! (samples -10 10) "fmv1.snd"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-sample)) (snd-display ";set-samples (beg -10): ~A" tag)))
+ (close-sound ind))
+
+ (let ((len 100))
+ (for-each
+ (lambda (type allowed-diff)
+ (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next))
+ (v (make-float-vector len))
+ (maxdiff 0.0)
+ (maxpos #f))
+ (set! (v 0) 0.999)
+ (set! (v 1) -1.0)
+ (set! (v 2) .1)
+ (set! (v 3) -.1)
+ (set! (v 4) .01)
+ (set! (v 5) -.01)
+ (set! (v 4) .001)
+ (set! (v 5) -.001)
+ (set! (v 6) 0.0)
+ (do ((i 7 (+ i 1)))
+ ((= i len))
+ (let ((val (random 1.9999)))
+ (if (not (>= 2.0 val 0.0))
+ (snd-display ";random 2.0 -> ~A?" val))
+ (set! (v i) (- 1.0 val))))
+ (float-vector->channel v 0 len ind 0)
+ (save-sound-as "test1.snd" ind :header-type mus-next :sample-type type)
+ (close-sound ind)
+ (set! ind (open-sound "test1.snd"))
+ (let ((v1 (channel->float-vector 0 len ind 0)))
+ (do ((i 0 (+ i 1)))
((= i len))
- (let ((val (random 1.9999)))
- (if (or (> val 2.0)
- (< val 0.0))
- (snd-display #__line__ ";random 2.0 -> ~A?" val))
- (set! (v i) (- 1.0 val))))
- (float-vector->channel v 0 len ind 0)
- (save-sound-as "test1.snd" ind :header-type mus-next :sample-type type)
- (close-sound ind)
- (set! ind (open-sound "test1.snd"))
- (let ((v1 (channel->float-vector 0 len ind 0)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let ((diff (abs (- (v i) (v1 i)))))
- (if (> diff maxdiff)
- (begin
- (set! maxdiff diff)
- (set! maxpos i)))))
- (if (> maxdiff allowed-diff)
- (snd-display #__line__ ";[line 2841] ~A: ~A at ~A (~A ~A)"
- (mus-sample-type-name type)
- maxdiff maxpos
- (v maxpos) (v1 maxpos)))
- (close-sound ind))))
- (list mus-bshort mus-lshort mus-mulaw mus-alaw mus-byte
- mus-lfloat mus-bint mus-lint mus-b24int mus-l24int
- mus-ubshort mus-ulshort mus-ubyte mus-bfloat mus-bdouble
- mus-ldouble)
- (list (expt 2 -15) (expt 2 -15) 0.02 0.02 (expt 2 -7)
- (expt 2 -23) (expt 2 -23) (expt 2 -23) (expt 2 -23) (expt 2 -23) ; assuming sndlib bits=24 here (if int)
- (expt 2 -15) (expt 2 -15) (expt 2 -7) (expt 2 -23) (expt 2 -23)
- (expt 2 -23))))
-
- (let* ((ob (view-sound "oboe.snd"))
- (samp (sample 1000 ob))
- (old-comment (mus-sound-comment "oboe.snd"))
- (str (string-append "written "
- (strftime "%a %d-%b-%Y %H:%M %Z"
- (localtime (current-time))))))
- (set! (comment ob) str)
- (let ((tag (catch #t
- (lambda ()
- (save-sound-as "test.snd" ob :header-type mus-aifc :sample-type mus-bdouble))
- (lambda args (car args)))))
- (if (eq? tag 'cannot-save) (snd-display #__line__ ";save-sound-as test.snd write trouble")))
- (set! *filter-control-in-hz* #t)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-aifc))
- (snd-display #__line__ ";save-as aifc -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-aifc))
- (snd-display #__line__ ";saved-as aifc -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";aifc[1000] = ~A?" (sample 1000 ab)))
- (if (or (not (string? (mus-sound-comment "test.snd")))
- (not (string=? (mus-sound-comment "test.snd") str)))
- (snd-display #__line__ ";output-comment: ~A ~A" (mus-sound-comment "test.snd") str))
- (if (or (not (string? (comment ab)))
- (not (string=? (comment ab) str)))
- (snd-display #__line__ ";output-comment (comment): ~A ~A" (comment ab) str))
- (close-sound ab))
+ (let ((diff (abs (- (v i) (v1 i)))))
+ (if (> diff maxdiff)
+ (begin
+ (set! maxdiff diff)
+ (set! maxpos i)))))
+ (if (> maxdiff allowed-diff)
+ (snd-display ";[line 2841] ~A: ~A at ~A (~A ~A)"
+ (mus-sample-type-name type)
+ maxdiff maxpos
+ (v maxpos) (v1 maxpos)))
+ (close-sound ind))))
+ (list mus-bshort mus-lshort mus-mulaw mus-alaw mus-byte
+ mus-lfloat mus-bint mus-lint mus-b24int mus-l24int
+ mus-ubshort mus-ulshort mus-ubyte mus-bfloat mus-bdouble
+ mus-ldouble)
+ (list (expt 2 -15) (expt 2 -15) 0.02 0.02 (expt 2 -7)
+ (expt 2 -23) (expt 2 -23) (expt 2 -23) (expt 2 -23) (expt 2 -23) ; assuming sndlib bits=24 here (if int)
+ (expt 2 -15) (expt 2 -15) (expt 2 -7) (expt 2 -23) (expt 2 -23)
+ (expt 2 -23))))
+
+ (let* ((ob (view-sound "oboe.snd"))
+ (samp (sample 1000 ob)))
+ (let ((old-comment (mus-sound-comment "oboe.snd")))
+ (let ((str (string-append "written "
+ (strftime "%a %d-%b-%Y %H:%M %Z"
+ (localtime (current-time))))))
+ (set! (comment ob) str)
+ (let ((tag (catch #t
+ (lambda ()
+ (save-sound-as "test.snd" ob :header-type mus-aifc :sample-type mus-bdouble))
+ (lambda args (car args)))))
+ (if (eq? tag 'cannot-save) (snd-display ";save-sound-as test.snd write trouble")))
+ (set! *filter-control-in-hz* #t)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-aifc))
+ (snd-display ";save-as aifc -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-aifc))
+ (snd-display ";saved-as aifc -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";aifc[1000] = ~A?" (sample 1000 ab)))
+ (if (not (equal? (mus-sound-comment "test.snd") str))
+ (snd-display ";output-comment: ~A ~A" (mus-sound-comment "test.snd") str))
+ (if (not (equal? (comment ab) str))
+ (snd-display ";output-comment (comment): ~A ~A" (comment ab) str))
+ (close-sound ab)))
(if (not (equal? old-comment (mus-sound-comment "oboe.snd")))
- (snd-display #__line__ ";set-comment overwrote current ~A ~A" old-comment (mus-sound-comment "oboe.snd")))
- (set! *filter-control-in-hz* #f)
- (save-sound-as "test.snd" ob :header-type mus-raw)
- (let ((ab (open-raw-sound "test.snd" 1 22050 mus-bshort)))
- (if (not (= (header-type ab) mus-raw))
- (snd-display #__line__ ";save-as raw -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-raw))
- (snd-display #__line__ ";saved-as raw -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";raw[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-nist :sample-type mus-bint)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-nist))
- (snd-display #__line__ ";save-as nist -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-nist))
- (snd-display #__line__ ";saved-as nist -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-bint))
- (snd-display #__line__ ";save-as int -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-bint))
- (snd-display #__line__ ";saved-as int -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";nist[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (set! (hook-functions output-comment-hook) ())
- (hook-push output-comment-hook
- (lambda (hook)
- (set! (hook 'result) (string-append (hook 'comment) " [written by me]"))))
- (save-sound-as :file "test.snd" :sound ob :header-type mus-riff :sample-type mus-lfloat)
- (set! (hook-functions output-comment-hook) ())
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-riff))
- (snd-display #__line__ ";save-as riff -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-riff))
- (snd-display #__line__ ";saved-as riff -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-lfloat))
- (snd-display #__line__ ";save-as float -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-lfloat))
- (snd-display #__line__ ";saved-as float -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";riff[1000] = ~A?" (sample 1000 ab)))
- (if (or (not (string? (comment ab)))
- (not (string=? (comment ab)
- (string-append "written "
- (strftime "%a %d-%b-%Y %H:%M %Z" (localtime (current-time)))
- " [written by me]"))))
- (snd-display #__line__ ";output-comment-hook: ~A~%(~A)" (comment ab) (mus-sound-comment "test.snd")))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-aiff :sample-type mus-b24int)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-aiff))
- (snd-display #__line__ ";save-as aiff -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-aiff))
- (snd-display #__line__ ";saved-as aiff -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-b24int))
- (snd-display #__line__ ";save-as 24-bit -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-b24int))
- (snd-display #__line__ ";saved-as 24-bit -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";aiff[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-ircam :sample-type mus-mulaw)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-ircam))
- (snd-display #__line__ ";save-as ircam -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-ircam))
- (snd-display #__line__ ";saved-as ircam -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-mulaw))
- (snd-display #__line__ ";save-as mulaw -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-mulaw))
- (snd-display #__line__ ";saved-as mulaw -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";ircam[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-alaw)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-next))
- (snd-display #__line__ ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-next))
- (snd-display #__line__ ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-alaw))
- (snd-display #__line__ ";save-as alaw -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-alaw))
- (snd-display #__line__ ";saved-as alaw -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";next (alaw)[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-ldouble)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-next))
- (snd-display #__line__ ";save-as dbl next -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (sample-type ab) mus-ldouble))
- (snd-display #__line__ ";save-as dbl -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";next (dbl)[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-bshort)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-next))
- (snd-display #__line__ ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-next))
- (snd-display #__line__ ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-bshort))
- (snd-display #__line__ ";save-as short -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-bshort))
- (snd-display #__line__ ";saved-as short -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";next (short)[1000] = ~A?" (sample 1000 ab)))
- (set! (hook-functions update-hook) ())
- (set! (y-bounds ab 0) (list -3.0 3.0))
- (set! (sample-type ab) mus-lshort)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd"))) ; these set!'s can change the index via update-sound
- (if (not (= (sample-type ab) mus-lshort)) (snd-display #__line__ ";set sample-type: ~A?" (mus-sample-type-name (sample-type ab))))
- (when with-gui
- (if (not (equal? (y-bounds ab 0) (list -3.0 3.0))) (snd-display #__line__ ";set sample type y-bounds: ~A?" (y-bounds ab 0))))
- (set! (y-bounds ab 0) (list 2.0))
- (when with-gui
- (if (not (equal? (y-bounds ab 0) (list -2.0 2.0))) (snd-display #__line__ ";set sample type y-bounds 1: ~A?" (y-bounds ab 0))))
- (set! (y-bounds ab 0) (list -2.0))
- (when with-gui
- (if (not (equal? (y-bounds ab 0) (list -2.0 2.0))) (snd-display #__line__ ";set sample type y-bounds -2: ~A?" (y-bounds ab 0))))
- (set! (header-type ab) mus-aifc)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (header-type ab) mus-aifc)) (snd-display #__line__ ";set header-type: ~A?" (mus-header-type-name (header-type ab))))
- (set! (channels ab) 3)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (channels ab) 3)) (snd-display #__line__ ";set chans: ~A?" (channels ab)))
- (set! (data-location ab) 1234)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (data-location ab) 1234)) (snd-display #__line__ ";set data-location: ~A?" (data-location ab)))
- (let ((old-size (data-size ab)))
- (set! (data-size ab) 1234)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (data-size ab) 1234)) (snd-display #__line__ ";set data-size: ~A?" (data-size ab)))
- (set! (data-size ab) old-size))
- (set! (srate ab) 12345)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (srate ab) 12345)) (snd-display #__line__ ";set srate: ~A?" (srate ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-bfloat)
- (let ((ab (open-sound "test.snd")))
- (if (not (= (header-type ab) mus-next))
- (snd-display #__line__ ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
- (if (not (= (mus-sound-header-type "test.snd") mus-next))
- (snd-display #__line__ ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
- (if (not (= (sample-type ab) mus-bfloat))
- (snd-display #__line__ ";save-as float -> ~A?" (mus-sample-type-name (sample-type ab))))
- (if (not (= (mus-sound-sample-type "test.snd") mus-bfloat))
- (snd-display #__line__ ";saved-as float -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
- (if (fneq (sample 1000 ab) samp) (snd-display #__line__ ";next (float)[1000] = ~A?" (sample 1000 ab)))
- (close-sound ab))
- (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-ldouble)
- (close-sound ob)
- (let ((ab (open-sound "test.snd")))
- (set! (sample-type) mus-lshort)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (sample-type) mus-lshort)) (snd-display #__line__ ";set sample-type: ~A?" (mus-sample-type-name (sample-type))))
- (set! (header-type) mus-aifc)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (header-type) mus-aifc)) (snd-display #__line__ ";set header-type: ~A?" (mus-header-type-name (header-type))))
- (set! (channels) 3)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (channels) 3)) (snd-display #__line__ ";set chans: ~A?" (channels)))
- (set! (data-location) 1234)
- (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (data-location) 1234)) (snd-display #__line__ ";set data-location: ~A?" (data-location)))
- (set! (srate) 12345)
+ (snd-display ";set-comment overwrote current ~A ~A" old-comment (mus-sound-comment "oboe.snd"))))
+ (set! *filter-control-in-hz* #f)
+ (save-sound-as "test.snd" ob :header-type mus-raw)
+ (let ((ab (open-raw-sound "test.snd" 1 22050 mus-bshort)))
+ (if (not (= (header-type ab) mus-raw))
+ (snd-display ";save-as raw -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-raw))
+ (snd-display ";saved-as raw -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";raw[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-nist :sample-type mus-bint)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-nist))
+ (snd-display ";save-as nist -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-nist))
+ (snd-display ";saved-as nist -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-bint))
+ (snd-display ";save-as int -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-bint))
+ (snd-display ";saved-as int -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";nist[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (set! (hook-functions output-comment-hook) ())
+ (hook-push output-comment-hook
+ (lambda (hook)
+ (set! (hook 'result) (string-append (hook 'comment) " [written by me]"))))
+ (save-sound-as :file "test.snd" :sound ob :header-type mus-riff :sample-type mus-lfloat)
+ (set! (hook-functions output-comment-hook) ())
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-riff))
+ (snd-display ";save-as riff -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-riff))
+ (snd-display ";saved-as riff -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-lfloat))
+ (snd-display ";save-as float -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-lfloat))
+ (snd-display ";saved-as float -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";riff[1000] = ~A?" (sample 1000 ab)))
+ (if (not (and (string? (comment ab))
+ (string=? (comment ab)
+ (string-append "written "
+ (strftime "%a %d-%b-%Y %H:%M %Z" (localtime (current-time)))
+ " [written by me]"))))
+ (snd-display ";output-comment-hook: ~A~%(~A)" (comment ab) (mus-sound-comment "test.snd")))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-aiff :sample-type mus-b24int)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-aiff))
+ (snd-display ";save-as aiff -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-aiff))
+ (snd-display ";saved-as aiff -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-b24int))
+ (snd-display ";save-as 24-bit -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-b24int))
+ (snd-display ";saved-as 24-bit -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";aiff[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-ircam :sample-type mus-mulaw)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-ircam))
+ (snd-display ";save-as ircam -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-ircam))
+ (snd-display ";saved-as ircam -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-mulaw))
+ (snd-display ";save-as mulaw -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-mulaw))
+ (snd-display ";saved-as mulaw -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";ircam[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-alaw)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-next))
+ (snd-display ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-next))
+ (snd-display ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-alaw))
+ (snd-display ";save-as alaw -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-alaw))
+ (snd-display ";saved-as alaw -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";next (alaw)[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-ldouble)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-next))
+ (snd-display ";save-as dbl next -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (sample-type ab) mus-ldouble))
+ (snd-display ";save-as dbl -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";next (dbl)[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-bshort)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-next))
+ (snd-display ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-next))
+ (snd-display ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-bshort))
+ (snd-display ";save-as short -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-bshort))
+ (snd-display ";saved-as short -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";next (short)[1000] = ~A?" (sample 1000 ab)))
+ (set! (hook-functions update-hook) ())
+ (set! (y-bounds ab 0) (list -3.0 3.0))
+ (set! (sample-type ab) mus-lshort)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd"))) ; these set!'s can change the index via update-sound
+ (if (not (= (sample-type ab) mus-lshort)) (snd-display ";set sample-type: ~A?" (mus-sample-type-name (sample-type ab))))
+ (when (and with-gui
+ (not (equal? (y-bounds ab 0) (list -3.0 3.0))))
+ (snd-display ";set sample type y-bounds: ~A?" (y-bounds ab 0)))
+ (set! (y-bounds ab 0) (list 2.0))
+ (when (and with-gui
+ (not (equal? (y-bounds ab 0) (list -2.0 2.0))))
+ (snd-display ";set sample type y-bounds 1: ~A?" (y-bounds ab 0)))
+ (set! (y-bounds ab 0) (list -2.0))
+ (when (and with-gui
+ (not (equal? (y-bounds ab 0) (list -2.0 2.0))))
+ (snd-display ";set sample type y-bounds -2: ~A?" (y-bounds ab 0)))
+ (set! (header-type ab) mus-aifc)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (header-type ab) mus-aifc)) (snd-display ";set header-type: ~A?" (mus-header-type-name (header-type ab))))
+ (set! (channels ab) 3)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (channels ab) 3)) (snd-display ";set chans: ~A?" (channels ab)))
+ (set! (data-location ab) 1234)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (data-location ab) 1234)) (snd-display ";set data-location: ~A?" (data-location ab)))
+ (let ((old-size (data-size ab)))
+ (set! (data-size ab) 1234)
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (srate) 12345)) (snd-display #__line__ ";set srate: ~A?" (srate)))
- (close-sound ab)))
-
- (let ((ind (open-sound "2a.snd")))
- (save-sound-as "test.snd" :sample-type mus-l24int :header-type mus-riff :channel 0)
- (let ((ind0 (open-sound "test.snd")))
- (if (not (= (channels ind0) 1))
- (snd-display #__line__ ";save-sound-as :channel 0 chans: ~A" (channels ind0)))
- (if (not (= (sample-type ind0) mus-l24int))
- (snd-display #__line__ ";save-sound-as :channel 0 sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
- (if (not (= (header-type ind0) mus-riff))
- (snd-display #__line__ ";save-sound-as :channel 0 header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
- (if (not (= (srate ind0) (srate ind)))
- (snd-display #__line__ ";save-sound-as :channel 0 srates: ~A ~A" (srate ind0) (srate ind)))
- (if (not (= (framples ind0) (framples ind 0)))
- (snd-display #__line__ ";save-sound-as :channel 0 framples: ~A ~A" (framples ind0) (framples ind 0)))
- (if (fneq (maxamp ind0 0) (maxamp ind 0))
- (snd-display #__line__ ";save-sound-as :channel 0 maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
- (close-sound ind0))
- (save-sound-as "test.snd" :sample-type mus-l24int :header-type mus-riff)
- (let ((ind0 (open-sound "test.snd")))
- (if (not (= (channels ind0) 2))
- (snd-display #__line__ ";save-sound-as chans: ~A" (channels ind0)))
- (if (not (= (sample-type ind0) mus-l24int))
- (snd-display #__line__ ";save-sound-as sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
- (if (not (= (header-type ind0) mus-riff))
- (snd-display #__line__ ";save-sound-as header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
- (if (not (= (srate ind0) (srate ind)))
- (snd-display #__line__ ";save-sound-as srates: ~A ~A" (srate ind0) (srate ind)))
- (if (not (= (framples ind0) (framples ind 0)))
- (snd-display #__line__ ";save-sound-as framples: ~A ~A" (framples ind0) (framples ind 0)))
- (if (fneq (maxamp ind0 0) (maxamp ind 0))
- (snd-display #__line__ ";save-sound-as maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
- (close-sound ind0))
- (save-sound-as "test.snd" :sample-type mus-b24int :header-type mus-aiff)
- (let ((ind0 (open-sound "test.snd")))
- (if (not (= (channels ind0) 2))
- (snd-display #__line__ ";save-sound-as chans: ~A" (channels ind0)))
- (if (not (= (sample-type ind0) mus-b24int))
- (snd-display #__line__ ";save-sound-as sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
- (if (not (= (header-type ind0) mus-aiff))
- (snd-display #__line__ ";save-sound-as header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
- (if (not (= (srate ind0) (srate ind)))
- (snd-display #__line__ ";save-sound-as srates: ~A ~A" (srate ind0) (srate ind)))
- (if (not (= (framples ind0) (framples ind 0)))
- (snd-display #__line__ ";save-sound-as framples: ~A ~A" (framples ind0) (framples ind 0)))
- (if (fneq (maxamp ind0 0) (maxamp ind 0))
- (snd-display #__line__ ";save-sound-as maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
- (close-sound ind0))
- (save-sound-as "test.snd" :sample-type mus-bfloat :header-type mus-aifc :channel 1 :srate 12345)
- (let ((ind0 (open-sound "test.snd")))
- (if (not (= (channels ind0) 1))
- (snd-display #__line__ ";save-sound-as :channel 1 chans: ~A" (channels ind0)))
- (if (not (= (sample-type ind0) mus-bfloat))
- (snd-display #__line__ ";save-sound-as :channel 1 sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
- (if (not (= (header-type ind0) mus-aifc))
- (snd-display #__line__ ";save-sound-as :channel 1 header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
- (if (not (= (srate ind0) 12345))
- (snd-display #__line__ ";save-sound-as :channel 1 srates: ~A ~A" (srate ind0) (srate ind)))
- (if (not (= (framples ind0) (framples ind 1)))
- (snd-display #__line__ ";save-sound-as :channel 1 framples: ~A ~A" (framples ind0) (framples ind 1)))
- (if (fneq (maxamp ind0 0) (maxamp ind 1))
- (snd-display #__line__ ";save-sound-as :channel 1 maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 1)))
- (close-sound ind0))
- (save-sound-as "test.snd" :channel 1 :comment "this is a test")
- (let ((ind0 (open-sound "test.snd")))
- (if (not (= (channels ind0) 1))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) chans: ~A" (channels ind0)))
- (if (not (= (sample-type ind0) (sample-type ind)))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
- (if (not (= (header-type ind0) (header-type ind)))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
- (if (not (= (srate ind0) (srate ind)))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) srates: ~A ~A" (srate ind0) (srate ind)))
- (if (not (= (framples ind0) (framples ind 1)))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) framples: ~A ~A" (framples ind0) (framples ind 1)))
- (if (fneq (maxamp ind0 0) (maxamp ind 1))
- (snd-display #__line__ ";save-sound-as :channel 1 (1) maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 1)))
- (if (not (string=? (comment ind0) "this is a test"))
- (snd-display #__line__ ";save-sound-as :channel 0 (1) comment: ~A" (comment ind0)))
- (close-sound ind0))
- (close-sound ind))
-
- (let ((fsnd (string-append sf-dir "t15.aiff")))
- (if (file-exists? fsnd)
- (let ((ind (open-sound fsnd)))
- (if (or (fneq (sample 132300 ind 0) .148)
- (fneq (sample 132300 ind 1) .126))
- (snd-display #__line__ ";aifc sowt trouble: ~A ~A" (sample 132300 ind 0) (sample 132300 ind 1)))
- (close-sound ind))))
- (let ((fsnd (string-append sf-dir "M1F1-float64C-AFsp.aif")))
- (if (file-exists? fsnd)
- (let ((ind (open-sound fsnd)))
- (if (or (fneq (sample 8000 ind 0) -0.024)
- (fneq (sample 8000 ind 1) 0.021))
- (snd-display #__line__ ";aifc fl64 trouble: ~A ~A" (sample 8000 ind 0) (sample 8000 ind 1)))
- (close-sound ind))))
-
- (for-each (lambda (n vals)
- (let ((val (catch #t (lambda ()
- (list (mus-sound-chans n)
- (mus-sound-srate n)
- (mus-sound-framples n)))
- (lambda args (car args)))))
- (if (and (not (equal? val vals))
- (not (eq? val 'mus-error)))
- (snd-display #__line__ ";~A: ~A ~A" n val vals))))
+ (if (not (= (data-size ab) 1234)) (snd-display ";set data-size: ~A?" (data-size ab)))
+ (set! (data-size ab) old-size))
+ (set! (srate ab) 12345)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (srate ab) 12345)) (snd-display ";set srate: ~A?" (srate ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-bfloat)
+ (let ((ab (open-sound "test.snd")))
+ (if (not (= (header-type ab) mus-next))
+ (snd-display ";save-as next -> ~A?" (mus-header-type-name (header-type ab))))
+ (if (not (= (mus-sound-header-type "test.snd") mus-next))
+ (snd-display ";saved-as next -> ~A?" (mus-header-type-name (mus-sound-header-type "test.snd"))))
+ (if (not (= (sample-type ab) mus-bfloat))
+ (snd-display ";save-as float -> ~A?" (mus-sample-type-name (sample-type ab))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-bfloat))
+ (snd-display ";saved-as float -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
+ (if (fneq (sample 1000 ab) samp) (snd-display ";next (float)[1000] = ~A?" (sample 1000 ab)))
+ (close-sound ab))
+ (save-sound-as "test.snd" ob :header-type mus-next :sample-type mus-ldouble)
+ (close-sound ob)
+ (let ((ab (open-sound "test.snd")))
+ (set! (sample-type) mus-lshort)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (sample-type) mus-lshort)) (snd-display ";set sample-type: ~A?" (mus-sample-type-name (sample-type))))
+ (set! (header-type) mus-aifc)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (header-type) mus-aifc)) (snd-display ";set header-type: ~A?" (mus-header-type-name (header-type))))
+ (set! (channels) 3)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (channels) 3)) (snd-display ";set chans: ~A?" (channels)))
+ (set! (data-location) 1234)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (data-location) 1234)) (snd-display ";set data-location: ~A?" (data-location)))
+ (set! (srate) 12345)
+ (if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
+ (if (not (= (srate) 12345)) (snd-display ";set srate: ~A?" (srate)))
+ (close-sound ab)))
+
+ (let ((ind (open-sound "2a.snd")))
+ (save-sound-as "test.snd" :sample-type mus-l24int :header-type mus-riff :channel 0)
+ (let ((ind0 (open-sound "test.snd")))
+ (if (not (= (channels ind0) 1))
+ (snd-display ";save-sound-as :channel 0 chans: ~A" (channels ind0)))
+ (if (not (= (sample-type ind0) mus-l24int))
+ (snd-display ";save-sound-as :channel 0 sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
+ (if (not (= (header-type ind0) mus-riff))
+ (snd-display ";save-sound-as :channel 0 header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
+ (if (not (= (srate ind0) (srate ind)))
+ (snd-display ";save-sound-as :channel 0 srates: ~A ~A" (srate ind0) (srate ind)))
+ (if (not (= (framples ind0) (framples ind 0)))
+ (snd-display ";save-sound-as :channel 0 framples: ~A ~A" (framples ind0) (framples ind 0)))
+ (if (fneq (maxamp ind0 0) (maxamp ind 0))
+ (snd-display ";save-sound-as :channel 0 maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
+ (close-sound ind0))
+ (save-sound-as "test.snd" :sample-type mus-l24int :header-type mus-riff)
+ (let ((ind0 (open-sound "test.snd")))
+ (if (not (= (channels ind0) 2))
+ (snd-display ";save-sound-as chans: ~A" (channels ind0)))
+ (if (not (= (sample-type ind0) mus-l24int))
+ (snd-display ";save-sound-as sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
+ (if (not (= (header-type ind0) mus-riff))
+ (snd-display ";save-sound-as header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
+ (if (not (= (srate ind0) (srate ind)))
+ (snd-display ";save-sound-as srates: ~A ~A" (srate ind0) (srate ind)))
+ (if (not (= (framples ind0) (framples ind 0)))
+ (snd-display ";save-sound-as framples: ~A ~A" (framples ind0) (framples ind 0)))
+ (if (fneq (maxamp ind0 0) (maxamp ind 0))
+ (snd-display ";save-sound-as maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
+ (close-sound ind0))
+ (save-sound-as "test.snd" :sample-type mus-b24int :header-type mus-aiff)
+ (let ((ind0 (open-sound "test.snd")))
+ (if (not (= (channels ind0) 2))
+ (snd-display ";save-sound-as chans: ~A" (channels ind0)))
+ (if (not (= (sample-type ind0) mus-b24int))
+ (snd-display ";save-sound-as sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
+ (if (not (= (header-type ind0) mus-aiff))
+ (snd-display ";save-sound-as header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
+ (if (not (= (srate ind0) (srate ind)))
+ (snd-display ";save-sound-as srates: ~A ~A" (srate ind0) (srate ind)))
+ (if (not (= (framples ind0) (framples ind 0)))
+ (snd-display ";save-sound-as framples: ~A ~A" (framples ind0) (framples ind 0)))
+ (if (fneq (maxamp ind0 0) (maxamp ind 0))
+ (snd-display ";save-sound-as maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 0)))
+ (close-sound ind0))
+ (save-sound-as "test.snd" :sample-type mus-bfloat :header-type mus-aifc :channel 1 :srate 12345)
+ (let ((ind0 (open-sound "test.snd")))
+ (if (not (= (channels ind0) 1))
+ (snd-display ";save-sound-as :channel 1 chans: ~A" (channels ind0)))
+ (if (not (= (sample-type ind0) mus-bfloat))
+ (snd-display ";save-sound-as :channel 1 sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
+ (if (not (= (header-type ind0) mus-aifc))
+ (snd-display ";save-sound-as :channel 1 header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
+ (if (not (= (srate ind0) 12345))
+ (snd-display ";save-sound-as :channel 1 srates: ~A ~A" (srate ind0) (srate ind)))
+ (if (not (= (framples ind0) (framples ind 1)))
+ (snd-display ";save-sound-as :channel 1 framples: ~A ~A" (framples ind0) (framples ind 1)))
+ (if (fneq (maxamp ind0 0) (maxamp ind 1))
+ (snd-display ";save-sound-as :channel 1 maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 1)))
+ (close-sound ind0))
+ (save-sound-as "test.snd" :channel 1 :comment "this is a test")
+ (let ((ind0 (open-sound "test.snd")))
+ (if (not (= (channels ind0) 1))
+ (snd-display ";save-sound-as :channel 1 (1) chans: ~A" (channels ind0)))
+ (if (not (= (sample-type ind0) (sample-type ind)))
+ (snd-display ";save-sound-as :channel 1 (1) sample-type: ~A ~A" (sample-type ind0) (mus-sample-type-name (sample-type ind0))))
+ (if (not (= (header-type ind0) (header-type ind)))
+ (snd-display ";save-sound-as :channel 1 (1) header-type: ~A ~A" (header-type ind0) (mus-header-type-name (header-type ind0))))
+ (if (not (= (srate ind0) (srate ind)))
+ (snd-display ";save-sound-as :channel 1 (1) srates: ~A ~A" (srate ind0) (srate ind)))
+ (if (not (= (framples ind0) (framples ind 1)))
+ (snd-display ";save-sound-as :channel 1 (1) framples: ~A ~A" (framples ind0) (framples ind 1)))
+ (if (fneq (maxamp ind0 0) (maxamp ind 1))
+ (snd-display ";save-sound-as :channel 1 (1) maxamps: ~A ~A" (maxamp ind0 0) (maxamp ind 1)))
+ (if (not (string=? (comment ind0) "this is a test"))
+ (snd-display ";save-sound-as :channel 0 (1) comment: ~A" (comment ind0)))
+ (close-sound ind0))
+ (close-sound ind))
+
+ (let ((fsnd (string-append sf-dir "t15.aiff")))
+ (if (file-exists? fsnd)
+ (let ((ind (open-sound fsnd)))
+ (if (or (fneq (sample 132300 ind 0) .148)
+ (fneq (sample 132300 ind 1) .126))
+ (snd-display ";aifc sowt trouble: ~A ~A" (sample 132300 ind 0) (sample 132300 ind 1)))
+ (close-sound ind))))
+ (let ((fsnd (string-append sf-dir "M1F1-float64C-AFsp.aif")))
+ (if (file-exists? fsnd)
+ (let ((ind (open-sound fsnd)))
+ (if (or (fneq (sample 8000 ind 0) -0.024)
+ (fneq (sample 8000 ind 1) 0.021))
+ (snd-display ";aifc fl64 trouble: ~A ~A" (sample 8000 ind 0) (sample 8000 ind 1)))
+ (close-sound ind))))
+
+ (for-each (lambda (n vals)
+ (let ((val (catch #t (lambda ()
+ (list (mus-sound-chans n)
+ (mus-sound-srate n)
+ (mus-sound-framples n)))
+ (lambda args (car args)))))
+ (if (not (or (equal? val vals)
+ (eq? val 'mus-error)))
+ (snd-display ";~A: ~A ~A" n val vals))))
+ (list (string-append sf-dir "bad_chans.snd")
+ (string-append sf-dir "bad_srate.snd")
+ (string-append sf-dir "bad_data_format.snd")
+ (string-append sf-dir "bad_chans.aifc")
+ (string-append sf-dir "bad_srate.aifc")
+ (string-append sf-dir "bad_length.aifc")
+ (string-append sf-dir "bad_chans.riff")
+ (string-append sf-dir "bad_srate.riff")
+ (string-append sf-dir "bad_chans.nist")
+ (string-append sf-dir "bad_srate.nist")
+ (string-append sf-dir "bad_length.nist"))
+ (list (list 0 22050 0)
+ (list 1 0 0)
+ (list 1 22050 4411)
+ (list 0 22050 0)
+ (list 1 0 0)
+ (list 1 22050 -10)
+ (list 0 22050 0)
+ (list 1 0 0)
+ (list 0 22050 0)
+ (list 1 0 0)
+ (list 1 22050 -10)))
+
+ (let ((ind (open-sound (string-append "/usr/include/sys/" home-dir "/cl/oboe.snd"))))
+ (if (not (and (sound? ind)
+ (string=? (short-file-name ind) "oboe.snd")))
+ (snd-display ";open-sound with slashes: ~A ~A" ind (and (sound? ind) (short-file-name ind))))
+ (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
+ (for-each (lambda (n)
+ (catch #t (lambda ()
+ (insert-sound n))
+ (lambda args (car args)))
+ (catch #t (lambda ()
+ (convolve-with n))
+ (lambda args (car args)))
+ (catch #t (lambda ()
+ (mix n))
+ (lambda args (car args)))
+ (catch #t (lambda ()
+ (let ((ind (open-sound n)))
+ (if (and (number? ind)
+ (sound? ind))
+ (close-sound ind))))
+ (lambda args (car args))))
(list (string-append sf-dir "bad_chans.snd")
(string-append sf-dir "bad_srate.snd")
- (string-append sf-dir "bad_data_format.snd")
(string-append sf-dir "bad_chans.aifc")
(string-append sf-dir "bad_srate.aifc")
(string-append sf-dir "bad_length.aifc")
(string-append sf-dir "bad_chans.riff")
(string-append sf-dir "bad_srate.riff")
(string-append sf-dir "bad_chans.nist")
+ (string-append sf-dir "bad_location.nist")
+ (string-append sf-dir "bad_field.nist")
(string-append sf-dir "bad_srate.nist")
- (string-append sf-dir "bad_length.nist"))
- (list (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 4411)
- (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 -10)
- (list 0 22050 0)
- (list 1 0 0)
- (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 -10)))
-
- (let ((ind (open-sound (string-append "/usr/include/sys/" home-dir "/cl/oboe.snd"))))
- (if (or (not (sound? ind))
- (not (string=? (short-file-name ind) "oboe.snd")))
- (snd-display #__line__ ";open-sound with slashes: ~A ~A" ind (and (sound? ind) (short-file-name ind))))
- (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
- (for-each (lambda (n)
- (catch #t (lambda ()
- (insert-sound n))
- (lambda args (car args)))
- (catch #t (lambda ()
- (convolve-with n))
- (lambda args (car args)))
- (catch #t (lambda ()
- (mix n))
- (lambda args (car args)))
- (catch #t (lambda ()
- (let ((ind (open-sound n)))
- (if (and (number? ind)
- (sound? ind))
- (close-sound ind))))
- (lambda args (car args))))
- (list (string-append sf-dir "bad_chans.snd")
- (string-append sf-dir "bad_srate.snd")
- (string-append sf-dir "bad_chans.aifc")
- (string-append sf-dir "bad_srate.aifc")
- (string-append sf-dir "bad_length.aifc")
- (string-append sf-dir "bad_chans.riff")
- (string-append sf-dir "bad_srate.riff")
- (string-append sf-dir "bad_chans.nist")
- (string-append sf-dir "bad_location.nist")
- (string-append sf-dir "bad_field.nist")
- (string-append sf-dir "bad_srate.nist")
- (string-append sf-dir "bad_length.nist")))
- (close-sound ind))
-
- (for-each close-sound (sounds))
+ (string-append sf-dir "bad_length.nist")))
+ (close-sound ind))
+
+ (for-each close-sound (sounds))
+
+ (if (selected-sound)
+ (snd-display ";selected-sound ~A ~A" (selected-sound) (sounds)))
+
+ (if (file-exists? (string-append (or sf-dir "") "a.sf2"))
+ (let ((fil (open-sound (string-append (or sf-dir "") "a.sf2"))))
+ (if fil
+ (let ((loops (and fil (soundfont-info))))
+ (if (or (null? loops)
+ (not (= (caddar loops) 65390))
+ (not (= (cadadr loops) 65490)))
+ (snd-display ";soundfont-info: ~A?" loops))
+ (close-sound fil)))))
+
+ (if (file-exists? "fmv5.snd") (delete-file "fmv5.snd"))
+ (set! *print-length* 12)
+
+ (for-each
+ (lambda (file)
+ (let ((tag (catch #t
+ (lambda () (open-sound (string-append sf-dir file)))
+ (lambda args args))))
+ (if (not (eq? (car tag) 'mus-error))
+ (snd-display ";open-sound ~A: ~A" file tag))))
+ (list "trunc.snd" "trunc.aiff" "trunc.wav" "trunc.sf" "trunc.voc" "trunc.nist" "bad.wav"
+ "trunc1.aiff" "badform.aiff"))
+
+ (hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) (list 1 22050 mus-bshort))))
+ (let ((ind (open-sound (string-append sf-dir "empty.snd"))))
+ (if (not (and (= (sample-type ind) mus-bshort)
+ (= (chans ind) 1)
+ (= (srate ind) 22050)
+ (= (data-location ind) 0)
+ (= (framples ind) 0)))
+ (snd-display ";open raw: ~A ~A ~A ~A ~A" (sample-type ind) (chans ind) (srate ind) (data-location ind) (framples ind)))
+ (set! (hook-functions open-raw-sound-hook) ())
+ (close-sound ind))
+
+ (let ((sd (make-float-vector (list 1 1) 0.0)))
+ (if (fneq (sd 0 0) 0.0) (snd-display ";vector2 ref: ~A" (sd 0 0)))
+ (set! (sd 0 0) 1.0)
+ (if (fneq (sd 0 0) 1.0) (snd-display ";vector2 set: ~A" (sd 0 0)))
+ (if (not (equal? sd (let ((sd1 (make-float-vector (list 1 1) 0.0))) (vector-set! sd1 0 0 1.0) sd1)))
+ (snd-display ";vector2 set not equal: ~A" sd)))
+
+ (let ((sd (make-float-vector (list 2 3) 0.0)))
+ (if (fneq (sd 0 0) 0.0) (snd-display ";vector2 ref (1): ~A" (sd 0 0)))
+ (set! (sd 1 0) 1.0)
+ (if (fneq (sd 1 0) 1.0) (snd-display ";vector2 set (1 0): ~A" (sd 1 0)))
+ (set! (sd 1 2) 2.0)
+ (if (fneq (sd 1 2) 2.0) (snd-display ";vector2 set (1 2): ~A" (sd 1 2)))
+ (if (not (equal? sd (let ((sd1 (make-float-vector (list 2 3) 0.0)))
+ (vector-set! sd1 1 0 1.0)
+ (vector-set! sd1 1 2 2.0)
+ sd1)))
+ (snd-display ";vector2 set (3) not equal: ~A" sd)))
+
+ ;; check clipping choices
+ (let ((ind (view-sound "oboe.snd")))
+ (set! *clipping* #f)
+ (scale-channel 10.0)
+ (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-ldouble)
+ (undo 1 ind 0)
+ (let ((ind1 (open-sound "test.snd")))
+ (if (fneq (maxamp ind1 0) (* 10 (maxamp ind 0)))
+ (snd-display ";clipping 0: ~A ~A" (maxamp ind1 0) (maxamp ind 0)))
+ (close-sound ind1))
+ (delete-file "test.snd")
+ (set! *clipping* #t)
+ (map-channel (lambda (y) (* y 10.0)) 0 #f ind 0)
+ (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-lshort)
+ (undo 1 ind 0)
+ (let ((ind1 (open-sound "test.snd")))
+ (if (fneq (maxamp ind1 0) 1.0)
+ (snd-display ";clipping 1: ~A ~A" (maxamp ind1 0) (maxamp ind 0)))
+ (close-sound ind1))
+ (delete-file "test.snd")
+ (set! *clipping* #f)
+ (let ((sub (- 1.001 (maxamp ind))))
+ (map-channel (lambda (y) (+ y sub)) 0 #f ind 0))
+ (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-lfloat)
+ (let ((ind1 (open-sound "test.snd"))
+ (baddy (scan-channel (lambda (y) (< y 0.0)))))
+ (if baddy
+ (snd-display ";clipping 2: ~A" baddy))
+ (close-sound ind1))
+ (delete-file "test.snd")
+ (set! *clipping* #t)
+ (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-ldouble)
+ (let ((ind1 (open-sound "test.snd"))
+ (baddy (scan-channel (lambda (y) (< y 0.0)))))
+ (if baddy
+ (snd-display ";clipping 3: ~A ~A" baddy (sample baddy)))
+ (close-sound ind1))
+ (delete-file "test.snd")
+ (set! *clipping* #f)
+ (close-sound ind))
+ (delete-file "fmv.snd")
+
+ (set! *clipping* #f)
+ (let ((snd (new-sound "test.snd" :sample-type mus-lshort)))
+ (pad-channel 0 10)
+ (set! (sample 1) 1.0)
+ (set! (sample 2) -1.0)
+ (set! (sample 3) 0.9999)
+ (set! (sample 4) 2.0)
+ (set! (sample 5) -2.0)
+ (set! (sample 6) 1.3)
+ (set! (sample 7) -1.3)
+ (set! (sample 8) 1.8)
+ (set! (sample 9) -1.8)
+ (save-sound snd)
+ (close-sound snd))
+ (let ((snd (open-sound "test.snd")))
+ (let ((data (channel->float-vector 0 10)))
+ (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 0.000 0.000 -0.700 0.700 -0.200 0.200)))
+ (snd-display ";unclipped 1: ~A" data)))
+ (close-sound snd))
+ (mus-sound-forget "test.snd")
+
+ (set! *clipping* #t)
+ (let ((snd (new-sound "test.snd" :sample-type mus-lshort)))
+ (pad-channel 0 10)
+ (set! (sample 1) 1.0)
+ (set! (sample 2) -1.0)
+ (set! (sample 3) 0.9999)
+ (set! (sample 4) 2.0)
+ (set! (sample 5) -2.0)
+ (set! (sample 6) 1.3)
+ (set! (sample 7) -1.3)
+ (set! (sample 8) 1.8)
+ (set! (sample 9) -1.8)
+ (save-sound snd)
+ (close-sound snd))
+ (let ((snd (open-sound "test.snd")))
+ (let ((data (channel->float-vector 0 10)))
+ (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
+ (snd-display ";clipped: ~A" data)))
+ (close-sound snd))
+ (set! *clipping* #f)
+
+ (let ((test-data (lambda (file beg dur data)
+ (catch #t
+ (lambda ()
+ (let* ((ind (open-sound file))
+ (ndata (channel->float-vector beg dur ind 0)))
+ (if (not (vequal data ndata))
+ (snd-display ";~A: ~A != ~A" file data ndata))
+ (close-sound ind)))
+ (lambda args args)))))
+ (test-data (string-append sf-dir "next-dbl.snd") 10 10 (float-vector 0.475 0.491 0.499 0.499 0.492 0.476 0.453 0.423 0.387 0.344))
+ (test-data (string-append sf-dir "oboe.ldbl") 1000 10 (float-vector 0.033 0.035 0.034 0.031 0.026 0.020 0.013 0.009 0.005 0.004))
- (if (selected-sound)
- (snd-display #__line__ ";selected-sound ~A ~A" (selected-sound) (sounds)))
+ (test-data (string-append sf-dir "next-flt.snd") 10 10 (float-vector 0.475 0.491 0.499 0.499 0.492 0.476 0.453 0.423 0.387 0.344))
+ (test-data (string-append sf-dir "clbonef.wav") 1000 10 (float-vector 0.111 0.101 0.070 0.032 -0.014 -0.060 -0.085 -0.108 -0.129 -0.152))
- (if (file-exists? (string-append (or sf-dir "") "a.sf2"))
- (let ((fil (open-sound (string-append (or sf-dir "") "a.sf2"))))
- (if fil
- (let ((loops (and fil (soundfont-info))))
- (if (or (null? loops)
- (not (= (caddar loops) 65390))
- (not (= (cadadr loops) 65490)))
- (snd-display #__line__ ";soundfont-info: ~A?" loops))
- (close-sound fil)))))
+ (test-data (string-append sf-dir "next-8.snd") 10 10 (float-vector 0.898 0.945 0.977 0.992 0.992 0.977 0.945 0.906 0.844 0.773))
+ (test-data (string-append sf-dir "o2_u8.wave") 1000 10 (float-vector -0.164 -0.219 -0.258 -0.242 -0.180 -0.102 -0.047 0.000 0.039 0.055))
- (if (file-exists? "fmv5.snd") (delete-file "fmv5.snd"))
- (set! *print-length* 12)
+ (test-data (string-append sf-dir "next-16.snd") 1000 10 (float-vector -0.026 -0.022 -0.024 -0.030 -0.041 -0.048 -0.050 -0.055 -0.048 -0.033))
+ (test-data (string-append sf-dir "o2.wave") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (for-each
- (lambda (file)
- (let ((tag (catch #t
- (lambda () (open-sound (string-append sf-dir file)))
- (lambda args args))))
- (if (not (eq? (car tag) 'mus-error))
- (snd-display #__line__ ";open-sound ~A: ~A" file tag))))
- (list "trunc.snd" "trunc.aiff" "trunc.wav" "trunc.sf" "trunc.voc" "trunc.nist" "bad.wav"
- "trunc1.aiff" "badform.aiff"))
-
- (hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) (list 1 22050 mus-bshort))))
- (let ((ind (open-sound (string-append sf-dir "empty.snd"))))
- (if (or (not (= (sample-type ind) mus-bshort))
- (not (= (chans ind) 1))
- (not (= (srate ind) 22050))
- (not (= (data-location ind) 0))
- (not (= (framples ind) 0)))
- (snd-display #__line__ ";open raw: ~A ~A ~A ~A ~A" (sample-type ind) (chans ind) (srate ind) (data-location ind) (framples ind)))
- (set! (hook-functions open-raw-sound-hook) ())
- (close-sound ind))
+ (test-data (string-append sf-dir "o2_18bit.aiff") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "o2_12bit.aiff") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (let ((sd (make-float-vector (list 1 1) 0.0)))
- (if (fneq (sd 0 0) 0.0) (snd-display #__line__ ";vector2 ref: ~A" (sd 0 0)))
- (set! (sd 0 0) 1.0)
- (if (fneq (sd 0 0) 1.0) (snd-display #__line__ ";vector2 set: ~A" (sd 0 0)))
- (if (not (equal? sd (let ((sd1 (make-float-vector (list 1 1) 0.0))) (vector-set! sd1 0 0 1.0) sd1)))
- (snd-display #__line__ ";vector2 set not equal: ~A" sd)))
-
- (let ((sd (make-float-vector (list 2 3) 0.0)))
- (if (fneq (sd 0 0) 0.0) (snd-display #__line__ ";vector2 ref (1): ~A" (sd 0 0)))
- (set! (sd 1 0) 1.0)
- (if (fneq (sd 1 0) 1.0) (snd-display #__line__ ";vector2 set (1 0): ~A" (sd 1 0)))
- (set! (sd 1 2) 2.0)
- (if (fneq (sd 1 2) 2.0) (snd-display #__line__ ";vector2 set (1 2): ~A" (sd 1 2)))
- (if (not (equal? sd (let ((sd1 (make-float-vector (list 2 3) 0.0)))
- (vector-set! sd1 1 0 1.0)
- (vector-set! sd1 1 2 2.0)
- sd1)))
- (snd-display #__line__ ";vector2 set (3) not equal: ~A" sd)))
-
- ;; check clipping choices
- (let ((ind (view-sound "oboe.snd")))
- (set! *clipping* #f)
- (scale-channel 10.0)
- (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-ldouble)
- (undo 1 ind 0)
- (let ((ind1 (open-sound "test.snd")))
- (if (fneq (maxamp ind1 0) (* 10 (maxamp ind 0)))
- (snd-display #__line__ ";clipping 0: ~A ~A" (maxamp ind1 0) (maxamp ind 0)))
- (close-sound ind1))
- (delete-file "test.snd")
- (set! *clipping* #t)
- (map-channel (lambda (y) (* y 10.0)) 0 #f ind 0)
- (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-lshort)
- (undo 1 ind 0)
- (let ((ind1 (open-sound "test.snd")))
- (if (fneq (maxamp ind1 0) 1.0)
- (snd-display #__line__ ";clipping 1: ~A ~A" (maxamp ind1 0) (maxamp ind 0)))
- (close-sound ind1))
- (delete-file "test.snd")
- (set! *clipping* #f)
- (let* ((mx (maxamp ind))
- (sub (- 1.001 mx)))
- (map-channel (lambda (y) (+ y sub)) 0 #f ind 0)
- (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-lfloat)
- (let ((ind1 (open-sound "test.snd"))
- (baddy (scan-channel (lambda (y) (< y 0.0)))))
- (if baddy
- (snd-display #__line__ ";clipping 2: ~A" baddy))
- (close-sound ind1))
- (delete-file "test.snd")
- (set! *clipping* #t)
- (save-sound-as "test.snd" ind :header-type mus-next :sample-type mus-ldouble)
- (let ((ind1 (open-sound "test.snd"))
- (baddy (scan-channel (lambda (y) (< y 0.0)))))
- (if baddy
- (snd-display #__line__ ";clipping 3: ~A ~A" baddy (sample baddy)))
- (close-sound ind1))
- (delete-file "test.snd")
- (set! *clipping* #f))
- (close-sound ind))
- (delete-file "fmv.snd")
+ (test-data (string-append sf-dir "next24.snd") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "mono24.wav") 1000 10 (float-vector 0.005 0.010 0.016 0.008 -0.007 -0.018 -0.025 -0.021 -0.005 0.001))
- (set! *clipping* #f)
- (let ((snd (new-sound "test.snd" :sample-type mus-lshort)))
- (pad-channel 0 10)
- (set! (sample 1) 1.0)
- (set! (sample 2) -1.0)
- (set! (sample 3) 0.9999)
- (set! (sample 4) 2.0)
- (set! (sample 5) -2.0)
- (set! (sample 6) 1.3)
- (set! (sample 7) -1.3)
- (set! (sample 8) 1.8)
- (set! (sample 9) -1.8)
- (save-sound snd)
- (close-sound snd))
- (let ((snd (open-sound "test.snd")))
- (let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 0.000 0.000 -0.700 0.700 -0.200 0.200)))
- (snd-display #__line__ ";unclipped 1: ~A" data)))
- (close-sound snd))
- (mus-sound-forget "test.snd")
+ (test-data (string-append sf-dir "o2_711u.wave") 1000 10 (float-vector -0.164 -0.219 -0.254 -0.242 -0.172 -0.103 -0.042 0.005 0.042 0.060))
+ (test-data (string-append sf-dir "alaw.wav") 1000 10 (float-vector -0.024 -0.048 -0.024 0.000 0.008 0.008 0.000 -0.040 -0.064 -0.024))
- (set! *clipping* #t)
- (let ((snd (new-sound "test.snd" :sample-type mus-lshort)))
- (pad-channel 0 10)
- (set! (sample 1) 1.0)
- (set! (sample 2) -1.0)
- (set! (sample 3) 0.9999)
- (set! (sample 4) 2.0)
- (set! (sample 5) -2.0)
- (set! (sample 6) 1.3)
- (set! (sample 7) -1.3)
- (set! (sample 8) 1.8)
- (set! (sample 9) -1.8)
- (save-sound snd)
- (close-sound snd))
- (let ((snd (open-sound "test.snd")))
- (let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
- (snd-display #__line__ ";clipped: ~A" data)))
- (close-sound snd))
- (set! *clipping* #f)
+ ;; it is not a bug if these don't match if MUS_SAMPLE_BITS is not 24
+ (test-data (string-append sf-dir "b32.pvf") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "b32.wave") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "b32.snd") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "32bit.sf") 1000 10 (float-vector 0.016 0.014 0.013 0.011 0.010 0.010 0.010 0.010 0.012 0.014))
- (let ((test-data (lambda (file beg dur data)
- (catch #t
- (lambda ()
- (let* ((ind (open-sound file))
- (ndata (channel->float-vector beg dur ind 0)))
- (if (not (vequal data ndata))
- (snd-display #__line__ ";~A: ~A != ~A" file data ndata))
- (close-sound ind)))
- (lambda args args)))))
- (test-data (string-append sf-dir "next-dbl.snd") 10 10 (float-vector 0.475 0.491 0.499 0.499 0.492 0.476 0.453 0.423 0.387 0.344))
- (test-data (string-append sf-dir "oboe.ldbl") 1000 10 (float-vector 0.033 0.035 0.034 0.031 0.026 0.020 0.013 0.009 0.005 0.004))
-
- (test-data (string-append sf-dir "next-flt.snd") 10 10 (float-vector 0.475 0.491 0.499 0.499 0.492 0.476 0.453 0.423 0.387 0.344))
- (test-data (string-append sf-dir "clbonef.wav") 1000 10 (float-vector 0.111 0.101 0.070 0.032 -0.014 -0.060 -0.085 -0.108 -0.129 -0.152))
-
- (test-data (string-append sf-dir "next-8.snd") 10 10 (float-vector 0.898 0.945 0.977 0.992 0.992 0.977 0.945 0.906 0.844 0.773))
- (test-data (string-append sf-dir "o2_u8.wave") 1000 10 (float-vector -0.164 -0.219 -0.258 -0.242 -0.180 -0.102 -0.047 0.000 0.039 0.055))
-
- (test-data (string-append sf-dir "next-16.snd") 1000 10 (float-vector -0.026 -0.022 -0.024 -0.030 -0.041 -0.048 -0.050 -0.055 -0.048 -0.033))
- (test-data (string-append sf-dir "o2.wave") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
-
- (test-data (string-append sf-dir "o2_18bit.aiff") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (test-data (string-append sf-dir "o2_12bit.aiff") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
-
- (test-data (string-append sf-dir "next24.snd") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (test-data (string-append sf-dir "mono24.wav") 1000 10 (float-vector 0.005 0.010 0.016 0.008 -0.007 -0.018 -0.025 -0.021 -0.005 0.001))
-
- (test-data (string-append sf-dir "o2_711u.wave") 1000 10 (float-vector -0.164 -0.219 -0.254 -0.242 -0.172 -0.103 -0.042 0.005 0.042 0.060))
- (test-data (string-append sf-dir "alaw.wav") 1000 10 (float-vector -0.024 -0.048 -0.024 0.000 0.008 0.008 0.000 -0.040 -0.064 -0.024))
-
- ;; it is not a bug if these don't match if MUS_SAMPLE_BITS is not 24
- (test-data (string-append sf-dir "b32.pvf") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (test-data (string-append sf-dir "b32.wave") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (test-data (string-append sf-dir "b32.snd") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
- (test-data (string-append sf-dir "32bit.sf") 1000 10 (float-vector 0.016 0.014 0.013 0.011 0.010 0.010 0.010 0.010 0.012 0.014))
-
- (test-data (string-append sf-dir "nist-shortpack.wav") 10000 10 (float-vector 0.021 0.018 0.014 0.009 0.004 -0.001 -0.004 -0.006 -0.007 -0.008))
- (test-data (string-append sf-dir "wood.sds") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
+ (test-data (string-append sf-dir "nist-shortpack.wav") 10000 10 (float-vector 0.021 0.018 0.014 0.009 0.004 -0.001 -0.004 -0.006 -0.007 -0.008))
+ (test-data (string-append sf-dir "wood.sds") 1000 10 (float-vector -0.160 -0.216 -0.254 -0.239 -0.175 -0.102 -0.042 0.005 0.041 0.059))
; (test-data (string-append sf-dir "oboe.g721") 1000 10 (float-vector -0.037 -0.040 -0.040 -0.041 -0.042 -0.038 -0.028 -0.015 -0.005 0.002))
; (test-data (string-append sf-dir "oboe.g723_40") 1000 10 (float-vector -0.037 -0.040 -0.041 -0.041 -0.041 -0.038 -0.028 -0.015 -0.005 0.003))
- (test-data (string-append sf-dir "mus10.snd") 10000 10 (float-vector 0.004 0.001 0.005 0.009 0.017 0.015 0.008 0.011 0.009 0.012))
- (test-data (string-append sf-dir "ieee-text-16.snd") 1000 10 (float-vector -0.052 -0.056 -0.069 -0.077 -0.065 -0.049 -0.054 -0.062 -0.066 -0.074))
- (test-data (string-append sf-dir "hcom-16.snd") 10000 10 (float-vector 0.000 0.000 0.000 0.008 0.000 -0.016 -0.016 -0.016 -0.008 0.000))
- (test-data (string-append sf-dir "ce-c3.w02") 1000 10 (float-vector 0.581 0.598 0.596 0.577 0.552 0.530 0.508 0.479 0.449 0.425))
- (test-data (string-append sf-dir "nasahal.avi") 20000 10 (float-vector 0.390 0.120 -0.399 -0.131 0.464 0.189 -0.458 -0.150 0.593 0.439))
- (test-data (string-append sf-dir "oki.wav") 100 10 (float-vector 0.396 0.564 0.677 0.779 0.761 0.540 0.209 -0.100 -0.301 -0.265))
-
- (test-data (string-append sf-dir "trumps22.adp") 5000 10 (float-vector 0.267 0.278 0.309 0.360 0.383 0.414 0.464 0.475 0.486 0.495))
- )
-
- (let ((errs (list "no error" "no frequency method" "no phase method" "null gen arg to method" "no length method"
- "no describe method" "no data method" "no scaler method"
- "memory allocation failed"
- "can't open file" "no sample input" "no sample output"
- "no such channel" "no file name provided" "no location method" "no channel method"
- "no such fft window" "unknown sample type" "header read failed"
- "unknown header type" "file descriptors not initialized" "not a sound file" "file closed" "write error"
- "header write failed" "can't open temp file" "interrupted" "bad envelope"
- "audio channels not available" "audio srate not available" "audio sample type not available"
- "no audio input available" "audio configuration not available"
- "audio write error" "audio size not available" "audio device not available"
- "can't close audio" "can't open audio" "audio read error"
- "can't write audio" "can't read audio" "no audio read permission"
- "can't close file" "arg out of range"
- "no channels method" "no hop method" "no width method" "no file-name method" "no ramp method" "no run method"
- "no increment method" "no offset method"
- "no xcoeff method" "no ycoeff method" "no xcoeffs method" "no ycoeffs method" "no reset" "bad size" "can't convert"
- "read error"
- "no feedforward method" "no feedback method" "no interp-type method" "no position method" "no order method" "no copy method"
- "can't translate"
- )))
- (let ((happy #t)
- (len (length errs)))
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i len)))
- (if (not (string=? (errs i) (mus-error-type->string i)))
- (begin
- (snd-display #__line__ ";mus-error-type->string ~D: ~A ~A" i (errs i) (mus-error-type->string i))
- (set! happy #f))))))
-
+ (test-data (string-append sf-dir "mus10.snd") 10000 10 (float-vector 0.004 0.001 0.005 0.009 0.017 0.015 0.008 0.011 0.009 0.012))
+ (test-data (string-append sf-dir "ieee-text-16.snd") 1000 10 (float-vector -0.052 -0.056 -0.069 -0.077 -0.065 -0.049 -0.054 -0.062 -0.066 -0.074))
+ (test-data (string-append sf-dir "hcom-16.snd") 10000 10 (float-vector 0.000 0.000 0.000 0.008 0.000 -0.016 -0.016 -0.016 -0.008 0.000))
+ (test-data (string-append sf-dir "ce-c3.w02") 1000 10 (float-vector 0.581 0.598 0.596 0.577 0.552 0.530 0.508 0.479 0.449 0.425))
+ (test-data (string-append sf-dir "nasahal.avi") 20000 10 (float-vector 0.390 0.120 -0.399 -0.131 0.464 0.189 -0.458 -0.150 0.593 0.439))
+ (test-data (string-append sf-dir "oki.wav") 100 10 (float-vector 0.396 0.564 0.677 0.779 0.761 0.540 0.209 -0.100 -0.301 -0.265))
+
+ (test-data (string-append sf-dir "trumps22.adp") 5000 10 (float-vector 0.267 0.278 0.309 0.360 0.383 0.414 0.464 0.475 0.486 0.495))
+ )
+
+ (let ((errs (list "no error" "no frequency method" "no phase method" "null gen arg to method" "no length method"
+ "no describe method" "no data method" "no scaler method"
+ "memory allocation failed"
+ "can't open file" "no sample input" "no sample output"
+ "no such channel" "no file name provided" "no location method" "no channel method"
+ "no such fft window" "unknown sample type" "header read failed"
+ "unknown header type" "file descriptors not initialized" "not a sound file" "file closed" "write error"
+ "header write failed" "can't open temp file" "interrupted" "bad envelope"
+ "audio channels not available" "audio srate not available" "audio sample type not available"
+ "no audio input available" "audio configuration not available"
+ "audio write error" "audio size not available" "audio device not available"
+ "can't close audio" "can't open audio" "audio read error"
+ "can't write audio" "can't read audio" "no audio read permission"
+ "can't close file" "arg out of range"
+ "no channels method" "no hop method" "no width method" "no file-name method" "no ramp method" "no run method"
+ "no increment method" "no offset method"
+ "no xcoeff method" "no ycoeff method" "no xcoeffs method" "no ycoeffs method" "no reset" "bad size" "can't convert"
+ "read error"
+ "no feedforward method" "no feedback method" "no interp-type method" "no position method" "no order method" "no copy method"
+ "can't translate"
+ )))
+ (let ((happy #t)
+ (len (length errs)))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i len)))
+ (if (not (string=? (errs i) (mus-error-type->string i)))
+ (begin
+ (snd-display ";mus-error-type->string ~D: ~A ~A" i (errs i) (mus-error-type->string i))
+ (set! happy #f))))))
+
; (let ((new-id (mus-make-error "hiho all messed up")))
; (if (not (string=? (mus-error-type->string new-id) "hiho all messed up"))
- ; (snd-display #__line__ ";mus-make-error :~A ~A" new-id (mus-error-type->string new-id))))
-
- (let ((cur-srate (mus-sound-srate "oboe.snd"))
- (cur-chans (mus-sound-chans "oboe.snd"))
- (cur-format (mus-sound-sample-type "oboe.snd"))
- (cur-type (mus-sound-header-type "oboe.snd"))
- (cur-loc (mus-sound-data-location "oboe.snd"))
- (cur-samps (mus-sound-samples "oboe.snd")))
- (set! (mus-sound-srate "oboe.snd") (* cur-srate 2))
- (if (not (= (* cur-srate 2) (mus-sound-srate "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-srate: ~A -> ~A" cur-srate (mus-sound-srate "oboe.snd")))
- (set! (mus-sound-samples "oboe.snd") (* cur-samps 2))
- (if (not (= (* cur-samps 2) (mus-sound-samples "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-samples: ~A -> ~A" cur-samps (mus-sound-samples "oboe.snd")))
- (set! (mus-sound-chans "oboe.snd") (* cur-chans 2))
- (if (not (= (* cur-chans 2) (mus-sound-chans "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-chans: ~A -> ~A" cur-chans (mus-sound-chans "oboe.snd")))
- (set! (mus-sound-data-location "oboe.snd") (* cur-loc 2))
- (if (not (= (* cur-loc 2) (mus-sound-data-location "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-data-location: ~A -> ~A" cur-loc (mus-sound-data-location "oboe.snd")))
- (set! (mus-sound-header-type "oboe.snd") mus-nist)
- (if (not (= mus-nist (mus-sound-header-type "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-header-type: ~A -> ~A" cur-type (mus-sound-header-type "oboe.snd")))
- (set! (mus-sound-sample-type "oboe.snd") mus-lintn)
- (if (not (= mus-lintn (mus-sound-sample-type "oboe.snd")))
- (snd-display #__line__ ";set mus-sound-sample-type: ~A -> ~A" cur-format (mus-sound-sample-type "oboe.snd")))
- (set! (mus-sound-srate "oboe.snd") cur-srate)
- (set! (mus-sound-samples "oboe.snd") cur-samps)
- (set! (mus-sound-chans "oboe.snd") cur-chans)
- (set! (mus-sound-data-location "oboe.snd") cur-loc)
- (set! (mus-sound-header-type "oboe.snd") cur-type)
- (set! (mus-sound-sample-type "oboe.snd") cur-format))
+ ; (snd-display ";mus-make-error :~A ~A" new-id (mus-error-type->string new-id))))
+
+ (let ((cur-srate (mus-sound-srate "oboe.snd"))
+ (cur-chans (mus-sound-chans "oboe.snd"))
+ (cur-format (mus-sound-sample-type "oboe.snd"))
+ (cur-type (mus-sound-header-type "oboe.snd"))
+ (cur-loc (mus-sound-data-location "oboe.snd"))
+ (cur-samps (mus-sound-samples "oboe.snd")))
+ (set! (mus-sound-srate "oboe.snd") (* cur-srate 2))
+ (if (not (= (* cur-srate 2) (mus-sound-srate "oboe.snd")))
+ (snd-display ";set mus-sound-srate: ~A -> ~A" cur-srate (mus-sound-srate "oboe.snd")))
+ (set! (mus-sound-samples "oboe.snd") (* cur-samps 2))
+ (if (not (= (* cur-samps 2) (mus-sound-samples "oboe.snd")))
+ (snd-display ";set mus-sound-samples: ~A -> ~A" cur-samps (mus-sound-samples "oboe.snd")))
+ (set! (mus-sound-chans "oboe.snd") (* cur-chans 2))
+ (if (not (= (* cur-chans 2) (mus-sound-chans "oboe.snd")))
+ (snd-display ";set mus-sound-chans: ~A -> ~A" cur-chans (mus-sound-chans "oboe.snd")))
+ (set! (mus-sound-data-location "oboe.snd") (* cur-loc 2))
+ (if (not (= (* cur-loc 2) (mus-sound-data-location "oboe.snd")))
+ (snd-display ";set mus-sound-data-location: ~A -> ~A" cur-loc (mus-sound-data-location "oboe.snd")))
+ (set! (mus-sound-header-type "oboe.snd") mus-nist)
+ (if (not (= mus-nist (mus-sound-header-type "oboe.snd")))
+ (snd-display ";set mus-sound-header-type: ~A -> ~A" cur-type (mus-sound-header-type "oboe.snd")))
+ (set! (mus-sound-sample-type "oboe.snd") mus-lintn)
+ (if (not (= mus-lintn (mus-sound-sample-type "oboe.snd")))
+ (snd-display ";set mus-sound-sample-type: ~A -> ~A" cur-format (mus-sound-sample-type "oboe.snd")))
+ (set! (mus-sound-srate "oboe.snd") cur-srate)
+ (set! (mus-sound-samples "oboe.snd") cur-samps)
+ (set! (mus-sound-chans "oboe.snd") cur-chans)
+ (set! (mus-sound-data-location "oboe.snd") cur-loc)
+ (set! (mus-sound-header-type "oboe.snd") cur-type)
+ (set! (mus-sound-sample-type "oboe.snd") cur-format))
+
+ (let ((ind (open-sound "oboe.snd")))
+ (save-sound-as "test.wave" ind :header-type mus-riff)
+ (save-sound-as "test.rf64" ind :header-type mus-rf64)
+ (save-sound-as "test.aifc" ind :header-type mus-aifc)
+ (close-sound ind)
- (let ((ind (open-sound "oboe.snd")))
- (save-sound-as "test.wave" ind :header-type mus-riff)
- (save-sound-as "test.rf64" ind :header-type mus-rf64)
- (save-sound-as "test.aifc" ind :header-type mus-aifc)
- (close-sound ind)
-
- (for-each
- (lambda (file)
- (let ((cur-srate (mus-sound-srate file))
- (cur-chans (mus-sound-chans file))
- (cur-format (mus-sound-sample-type file))
- (cur-type (mus-sound-header-type file))
- (cur-loc (mus-sound-data-location file))
- (cur-samps (mus-sound-samples file)))
- (set! (mus-sound-srate file) (* cur-srate 2))
- (if (not (= (* cur-srate 2) (mus-sound-srate file)))
- (snd-display #__line__ ";~A: set mus-sound-srate: ~A -> ~A" file cur-srate (mus-sound-srate file)))
- (set! (mus-sound-samples file) (* cur-samps 2))
- (if (not (= (* cur-samps 2) (mus-sound-samples file)))
- (snd-display #__line__ ";~A: set mus-sound-samples: ~A -> ~A" file cur-samps (mus-sound-samples file)))
- (set! (mus-sound-chans file) (* cur-chans 2))
- (if (not (= (* cur-chans 2) (mus-sound-chans file)))
- (snd-display #__line__ ";~A: set mus-sound-chans: ~A -> ~A" file cur-chans (mus-sound-chans file)))
- (set! (mus-sound-data-location file) (* cur-loc 2))
- (if (not (= (* cur-loc 2) (mus-sound-data-location file)))
- (snd-display #__line__ ";~A: set mus-sound-data-location: ~A -> ~A" file cur-loc (mus-sound-data-location file)))
- (set! (mus-sound-header-type file) mus-nist)
- (if (not (= mus-nist (mus-sound-header-type file)))
- (snd-display #__line__ ";~A: set mus-sound-header-type: ~A -> ~A" file cur-type (mus-sound-header-type file)))
- (set! (mus-sound-sample-type file) mus-lintn)
- (if (not (= mus-lintn (mus-sound-sample-type file)))
- (snd-display #__line__ ";~A: set mus-sound-sample-type: ~A -> ~A" file cur-format (mus-sound-sample-type file)))
- (set! (mus-sound-srate file) cur-srate)
- (set! (mus-sound-samples file) cur-samps)
- (set! (mus-sound-chans file) cur-chans)
- (set! (mus-sound-data-location file) cur-loc)
- (set! (mus-sound-header-type file) cur-type)
- (set! (mus-sound-sample-type file) cur-format)))
- (list "test.wave" "test.rf64" "test.aifc"))
-
- (for-each
- (lambda (file)
- (let ((ind (open-sound file)))
- (let ((cur-srate (srate ind))
- (cur-chans (chans ind))
- (cur-format (sample-type ind))
- (cur-type (header-type ind))
- (cur-loc (data-location ind))
- (cur-samps (framples ind)))
- (set! (srate ind) (* cur-srate 2))
- (if (not (= (* cur-srate 2) (srate ind)))
- (snd-display #__line__ ";~A: set srate: ~A -> ~A" file cur-srate (srate ind)))
- (set! (framples ind) (* cur-samps 2))
- (if (not (= (* cur-samps 2) (framples ind)))
- (snd-display #__line__ ";~A: set framples: ~A -> ~A" file cur-samps (framples ind)))
- (set! (chans ind) (* cur-chans 2)) ; this can change the index
- (let ((xind (find-sound file)))
- (if (not (equal? ind xind))
- (set! ind xind)))
- (if (not (= (* cur-chans 2) (chans ind)))
- (snd-display #__line__ ";~A: set chans: ~A -> ~A" file cur-chans (chans ind)))
- (set! (data-location ind) (* cur-loc 2))
- (if (not (= (* cur-loc 2) (data-location ind)))
- (snd-display #__line__ ";~A: set data-location: ~A -> ~A" file cur-loc (data-location ind)))
- (set! (header-type ind) mus-nist)
- (if (not (= mus-nist (header-type ind)))
- (snd-display #__line__ ";~A: set header-type: ~A -> ~A" file cur-type (header-type ind)))
- (set! (sample-type ind) mus-lintn)
- (if (not (= mus-lintn (sample-type ind)))
- (snd-display #__line__ ";~A: set sample-type: ~A -> ~A" file cur-format (sample-type ind)))
- (set! (srate ind) cur-srate)
- (set! (framples ind) cur-samps)
- (set! (chans ind) cur-chans)
- (set! (data-location ind) cur-loc)
- (set! (header-type ind) cur-type)
- (set! (sample-type ind) cur-format))
- (close-sound ind))
- (if (file-exists? file)
- (delete-file file)))
- (list "test.wave" "test.rf64" "test.aifc")))
-
- ;; (with-sound (big-file-name :srate 44100 :play #f)
- ;; (do ((i 0 (+ i 1))) ((= i 72000))
- ;; (fm-violin i .1 440 (+ .01 (* (/ i 72000.0) .9)))))
-
- (if with-big-file
- (let ((probable-framples (floor (* (floor *clm-srate*) 71999.1)))) ; silence as last .9 secs, so it probably wasn't written
- (if (not (= (mus-sound-samples big-file-name) 3175160310))
- (snd-display #__line__ ";bigger samples: ~A" (mus-sound-samples big-file-name)))
- (if (not (= (mus-sound-framples big-file-name) 3175160310))
- (snd-display #__line__ ";bigger framples: ~A" (mus-sound-framples big-file-name)))
- (if (not (= (mus-sound-framples big-file-name) probable-framples))
- (snd-display #__line__ ";bigger framples: ~A (probable: ~A)" (mus-sound-framples big-file-name) probable-framples))
- (if (not (= (mus-sound-length big-file-name) 6350320648))
- (snd-display #__line__ ";bigger bytes: ~A" (mus-sound-length big-file-name)))
- (if (fneq (mus-sound-duration big-file-name) 71999.1015)
- (snd-display #__line__ ";bigger dur: ~A" (mus-sound-duration big-file-name)))
- (let ((ind (open-sound big-file-name)))
- (if (not (= (framples ind) 3175160310)) (snd-display #__line__ ";bigger framples: ~A" (framples ind)))
- (set! big-file-framples (framples ind))
- (if (not (= (framples ind) probable-framples)) (snd-display #__line__ ";bigger framples: ~A (probable: ~A)" (framples ind) probable-framples))
- (if (not (= (framples ind 0 0) big-file-framples)) (snd-display #__line__ ";bigger edpos-framples: ~A" (framples ind)))
- (let ((m1 (add-mark (* (floor *clm-srate*) 50000) ind)))
- (if (not (= (mark-sample m1) (* (floor *clm-srate*) 50000))) (snd-display #__line__ ";bigger mark at: ~A" (mark-sample m1)))
- (set! (mark-sample m1) (* (floor *clm-srate*) 66000))
- (if (not (= (mark-sample m1) (* (floor *clm-srate*) 66000))) (snd-display #__line__ ";bigger mark to: ~A" (mark-sample m1))))
- (let ((mx (mix-sound "oboe.snd" (* (floor *clm-srate*) 60000))))
- (if (mix? mx)
- (begin
- (if (not (= (mix-position mx) (* (floor *clm-srate*) 60000))) (snd-display #__line__ ";bigger mix at: ~A" (mix-position mx)))
- (set! (mix-position mx) (* (floor *clm-srate*) 61000))
- (if (not (= (mix-position mx) (* (floor *clm-srate*) 61000))) (snd-display #__line__ ";bigger mix to: ~A" (mix-position mx))))
- (snd-display #__line__ ";no mix tag from mix-sound"))
- (undo 2))
- (let ((res (scan-channel (lambda (y) (> (abs y) 0.0)))))
- (if (or (not res)
- (> (cadr res) 100))
- (snd-display #__line__ ";bigger find not 0.0: ~A" res)))
- (let ((old-select *selection-creates-region*))
- (set! *selection-creates-region* #f)
- (select-all ind)
- (if (not (= (selection-framples) (framples ind))) (snd-display #__line__ ";bigger select all: ~A ~A" (selection-framples) (framples)))
- (set! (selection-position) (* (floor *clm-srate*) 50000))
- (if (not (= (selection-position) (* (floor *clm-srate*) 50000))) (snd-display #__line__ ";bigger select pos: ~A" (selection-position)))
- (set! (selection-position) 0)
- (set! (selection-framples) (* (floor *clm-srate*) 65000))
- (if (not (= (selection-framples) (* (floor *clm-srate*) 65000))) (snd-display #__line__ ";bigger select len: ~A" (selection-framples)))
- (set! *selection-creates-region* old-select))
- (set! (cursor ind) (* (floor *clm-srate*) 50000))
- (if (not (= (cursor ind) (* (floor *clm-srate*) 50000))) (snd-display #__line__ ";bigger cursor: ~A" (cursor ind)))
- (let ((m1 (add-mark (* 44123 51234) ind)))
- (if (not (= (mark-sample m1) (* 44123 51234))) (snd-display #__line__ ";bigger mark at: ~A" (mark-sample m1)))
- (let ((mid (find-mark (* 44123 51234))))
- (if (or (not (number? mid)) (not (= mid m1))) (snd-display #__line__ ";bigger mark seach: ~A ~A" mid m1))))
- (let ((mx (mix-sound "oboe.snd" (* 44123 61234))))
- (let ((mxd (find-mix (* 44123 61234))))
- (if (or (not (number? mxd)) (not (= mxd mx))) (snd-display #__line__ ";bigger find-mix ~A ~A" mxd mx))))
- (set! (cursor ind) (* 44123 51234))
- (if (not (= (cursor ind) (* 44123 51234))) (snd-display #__line__ ";bigger cursor 123: ~A" (cursor ind)))
- (close-sound ind))))
+ (for-each
+ (lambda (file)
+ (let ((cur-srate (mus-sound-srate file))
+ (cur-chans (mus-sound-chans file))
+ (cur-format (mus-sound-sample-type file))
+ (cur-type (mus-sound-header-type file))
+ (cur-loc (mus-sound-data-location file))
+ (cur-samps (mus-sound-samples file)))
+ (set! (mus-sound-srate file) (* cur-srate 2))
+ (if (not (= (* cur-srate 2) (mus-sound-srate file)))
+ (snd-display ";~A: set mus-sound-srate: ~A -> ~A" file cur-srate (mus-sound-srate file)))
+ (set! (mus-sound-samples file) (* cur-samps 2))
+ (if (not (= (* cur-samps 2) (mus-sound-samples file)))
+ (snd-display ";~A: set mus-sound-samples: ~A -> ~A" file cur-samps (mus-sound-samples file)))
+ (set! (mus-sound-chans file) (* cur-chans 2))
+ (if (not (= (* cur-chans 2) (mus-sound-chans file)))
+ (snd-display ";~A: set mus-sound-chans: ~A -> ~A" file cur-chans (mus-sound-chans file)))
+ (set! (mus-sound-data-location file) (* cur-loc 2))
+ (if (not (= (* cur-loc 2) (mus-sound-data-location file)))
+ (snd-display ";~A: set mus-sound-data-location: ~A -> ~A" file cur-loc (mus-sound-data-location file)))
+ (set! (mus-sound-header-type file) mus-nist)
+ (if (not (= mus-nist (mus-sound-header-type file)))
+ (snd-display ";~A: set mus-sound-header-type: ~A -> ~A" file cur-type (mus-sound-header-type file)))
+ (set! (mus-sound-sample-type file) mus-lintn)
+ (if (not (= mus-lintn (mus-sound-sample-type file)))
+ (snd-display ";~A: set mus-sound-sample-type: ~A -> ~A" file cur-format (mus-sound-sample-type file)))
+ (set! (mus-sound-srate file) cur-srate)
+ (set! (mus-sound-samples file) cur-samps)
+ (set! (mus-sound-chans file) cur-chans)
+ (set! (mus-sound-data-location file) cur-loc)
+ (set! (mus-sound-header-type file) cur-type)
+ (set! (mus-sound-sample-type file) cur-format)))
+ (list "test.wave" "test.rf64" "test.aifc"))
- (let ((ind (new-sound "tmp.snd" 1 22050 mus-l24int mus-riff :size 100000))
- (old-selection-creates-region *selection-creates-region*))
- (set! *selection-creates-region* #t)
- (let ((incr (/ 1.0 (framples)))
- (data (make-float-vector (framples))))
- (outa->fv data (- (* i incr) 0.5))
- (float-vector->channel data))
- (save-sound)
- (close-sound ind)
- (set! ind (open-sound "tmp.snd"))
- (let ((reg (select-all))
- (v1 (make-float-vector 100000)))
- (save-selection "tmp1.snd" 22050 mus-l24int mus-next)
- (let ((ind1 (open-sound "tmp1.snd")))
- (let ((incr (/ 1.0 (framples))))
- (outa->fv v1 (- (* i incr) 0.5))
- (let ((v0 (samples 0 100000 ind1 0)))
- (if (not (vequal v0 v1))
- (snd-display #__line__ ";l24 (next) selection not saved correctly? ~A" v0))))
- (close-sound ind1))
-
- (save-selection "tmp1.snd" 22050 mus-l24int mus-aifc)
- (let ((ind1 (open-sound "tmp1.snd")))
- (let ((v0 (samples 0 100000 ind1 0)))
- (if (not (vequal v0 v1))
- (snd-display #__line__ ";l24 (aifc) selection not saved correctly? ~A" v0)))
- (close-sound ind1))
-
- (save-region reg "tmp1.snd" mus-l24int mus-next)
- (let ((ind1 (open-sound "tmp1.snd")))
+ (for-each
+ (lambda (file)
+ (let ((ind (open-sound file)))
+ (let ((cur-srate (srate ind))
+ (cur-chans (chans ind))
+ (cur-format (sample-type ind))
+ (cur-type (header-type ind))
+ (cur-loc (data-location ind))
+ (cur-samps (framples ind)))
+ (set! (srate ind) (* cur-srate 2))
+ (if (not (= (* cur-srate 2) (srate ind)))
+ (snd-display ";~A: set srate: ~A -> ~A" file cur-srate (srate ind)))
+ (set! (framples ind) (* cur-samps 2))
+ (if (not (= (* cur-samps 2) (framples ind)))
+ (snd-display ";~A: set framples: ~A -> ~A" file cur-samps (framples ind)))
+ (set! (chans ind) (* cur-chans 2)) ; this can change the index
+ (let ((xind (find-sound file)))
+ (if (not (equal? ind xind))
+ (set! ind xind)))
+ (if (not (= (* cur-chans 2) (chans ind)))
+ (snd-display ";~A: set chans: ~A -> ~A" file cur-chans (chans ind)))
+ (set! (data-location ind) (* cur-loc 2))
+ (if (not (= (* cur-loc 2) (data-location ind)))
+ (snd-display ";~A: set data-location: ~A -> ~A" file cur-loc (data-location ind)))
+ (set! (header-type ind) mus-nist)
+ (if (not (= mus-nist (header-type ind)))
+ (snd-display ";~A: set header-type: ~A -> ~A" file cur-type (header-type ind)))
+ (set! (sample-type ind) mus-lintn)
+ (if (not (= mus-lintn (sample-type ind)))
+ (snd-display ";~A: set sample-type: ~A -> ~A" file cur-format (sample-type ind)))
+ (set! (srate ind) cur-srate)
+ (set! (framples ind) cur-samps)
+ (set! (chans ind) cur-chans)
+ (set! (data-location ind) cur-loc)
+ (set! (header-type ind) cur-type)
+ (set! (sample-type ind) cur-format))
+ (close-sound ind))
+ (if (file-exists? file)
+ (delete-file file)))
+ (list "test.wave" "test.rf64" "test.aifc")))
+
+ ;; (with-sound (big-file-name :srate 44100 :play #f)
+ ;; (do ((i 0 (+ i 1))) ((= i 72000))
+ ;; (fm-violin i .1 440 (+ .01 (* (/ i 72000.0) .9)))))
+
+ (when with-big-file
+ (let ((probable-framples (floor (* (floor *clm-srate*) 71999.1)))) ; silence as last .9 secs, so it probably wasn't written
+ (if (not (= (mus-sound-samples big-file-name) 3175160310))
+ (snd-display ";bigger samples: ~A" (mus-sound-samples big-file-name)))
+ (if (not (= (mus-sound-framples big-file-name) 3175160310))
+ (snd-display ";bigger framples: ~A" (mus-sound-framples big-file-name)))
+ (if (not (= (mus-sound-framples big-file-name) probable-framples))
+ (snd-display ";bigger framples: ~A (probable: ~A)" (mus-sound-framples big-file-name) probable-framples))
+ (if (not (= (mus-sound-length big-file-name) 6350320648))
+ (snd-display ";bigger bytes: ~A" (mus-sound-length big-file-name)))
+ (if (fneq (mus-sound-duration big-file-name) 71999.1015)
+ (snd-display ";bigger dur: ~A" (mus-sound-duration big-file-name)))
+ (let ((ind (open-sound big-file-name)))
+ (if (not (= (framples ind) 3175160310)) (snd-display ";bigger framples: ~A" (framples ind)))
+ (set! big-file-framples (framples ind))
+ (if (not (= (framples ind) probable-framples)) (snd-display ";bigger framples: ~A (probable: ~A)" (framples ind) probable-framples))
+ (if (not (= (framples ind 0 0) big-file-framples)) (snd-display ";bigger edpos-framples: ~A" (framples ind)))
+ (let ((m1 (add-mark (* (floor *clm-srate*) 50000) ind)))
+ (if (not (= (mark-sample m1) (* (floor *clm-srate*) 50000))) (snd-display ";bigger mark at: ~A" (mark-sample m1)))
+ (set! (mark-sample m1) (* (floor *clm-srate*) 66000))
+ (if (not (= (mark-sample m1) (* (floor *clm-srate*) 66000))) (snd-display ";bigger mark to: ~A" (mark-sample m1))))
+ (let ((mx (mix-sound "oboe.snd" (* (floor *clm-srate*) 60000))))
+ (if (mix? mx)
+ (begin
+ (if (not (= (mix-position mx) (* (floor *clm-srate*) 60000))) (snd-display ";bigger mix at: ~A" (mix-position mx)))
+ (set! (mix-position mx) (* (floor *clm-srate*) 61000))
+ (if (not (= (mix-position mx) (* (floor *clm-srate*) 61000))) (snd-display ";bigger mix to: ~A" (mix-position mx))))
+ (snd-display ";no mix tag from mix-sound"))
+ (undo 2))
+ (let ((res (scan-channel (lambda (y) (> (abs y) 0.0)))))
+ (if (or (not res)
+ (> (cadr res) 100))
+ (snd-display ";bigger find not 0.0: ~A" res)))
+ (let ((old-select *selection-creates-region*))
+ (set! *selection-creates-region* #f)
+ (select-all ind)
+ (if (not (= (selection-framples) (framples ind))) (snd-display ";bigger select all: ~A ~A" (selection-framples) (framples)))
+ (set! (selection-position) (* (floor *clm-srate*) 50000))
+ (if (not (= (selection-position) (* (floor *clm-srate*) 50000))) (snd-display ";bigger select pos: ~A" (selection-position)))
+ (set! (selection-position) 0)
+ (set! (selection-framples) (* (floor *clm-srate*) 65000))
+ (if (not (= (selection-framples) (* (floor *clm-srate*) 65000))) (snd-display ";bigger select len: ~A" (selection-framples)))
+ (set! *selection-creates-region* old-select))
+ (let ((size 2260597782) ;(* 44123 51234))
+ (msize 2701827782)) ;(* 44123 61234)
+ (set! (cursor ind) (* (floor *clm-srate*) 50000))
+ (if (not (= (cursor ind) (* (floor *clm-srate*) 50000))) (snd-display ";bigger cursor: ~A" (cursor ind)))
+ (let ((m1 (add-mark size ind)))
+ (if (not (= (mark-sample m1) size)) (snd-display ";bigger mark at: ~A" (mark-sample m1)))
+ (let ((mid (find-mark size)))
+ (if (not (and (number? mid) (= mid m1))) (snd-display ";bigger mark seach: ~A ~A" mid m1))))
+ (let ((mx (mix-sound "oboe.snd" msize)))
+ (let ((mxd (find-mix msize)))
+ (if (not (and (number? mxd) (= mxd mx))) (snd-display ";bigger find-mix ~A ~A" mxd mx))))
+ (set! (cursor ind) size)
+ (if (not (= (cursor ind) size)) (snd-display ";bigger cursor 123: ~A" (cursor ind))))
+ (close-sound ind))))
+
+ (let ((ind (new-sound "tmp.snd" 1 22050 mus-l24int mus-riff :size 100000))
+ (old-selection-creates-region *selection-creates-region*))
+ (set! *selection-creates-region* #t)
+ (let ((incr (/ 1.0 (framples)))
+ (data (make-float-vector (framples))))
+ (outa->fv data (- (* i incr) 0.5))
+ (float-vector->channel data))
+ (save-sound)
+ (close-sound ind)
+ (set! ind (open-sound "tmp.snd"))
+ (let ((reg (select-all))
+ (v1 (make-float-vector 100000)))
+ (save-selection "tmp1.snd" 22050 mus-l24int mus-next)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((incr (/ 1.0 (framples))))
+ (outa->fv v1 (- (* i incr) 0.5))
(let ((v0 (samples 0 100000 ind1 0)))
(if (not (vequal v0 v1))
- (snd-display #__line__ ";l24 (next) region not saved correctly? ~A" v0)))
- (close-sound ind1))
- (delete-file "tmp1.snd")
- (close-sound ind)
- (delete-file "tmp.snd"))
- (set! *selection-creates-region* old-selection-creates-region))
-
- (let ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 10 :comment #f)))
- (map-channel (lambda (y) 1.0))
- (env-channel '(0 0 .1 .1 .2 .2 .3 .3 .4 .4 .5 .5 .6 .6 .7 .7 .8 .8 .9 .9))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
- (snd-display #__line__ ";ramp env by .1: ~A" (channel->float-vector)))
- (close-sound ind))
- )
+ (snd-display ";l24 (next) selection not saved correctly? ~A" v0))))
+ (close-sound ind1))
+
+ (save-selection "tmp1.snd" 22050 mus-l24int mus-aifc)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((v0 (samples 0 100000 ind1 0)))
+ (if (not (vequal v0 v1))
+ (snd-display ";l24 (aifc) selection not saved correctly? ~A" v0)))
+ (close-sound ind1))
+
+ (save-region reg "tmp1.snd" mus-l24int mus-next)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((v0 (samples 0 100000 ind1 0)))
+ (if (not (vequal v0 v1))
+ (snd-display ";l24 (next) region not saved correctly? ~A" v0)))
+ (close-sound ind1))
+ (delete-file "tmp1.snd")
+ (close-sound ind)
+ (delete-file "tmp.snd"))
+ (set! *selection-creates-region* old-selection-creates-region))
+
+ (let ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 10 :comment #f)))
+ (map-channel (lambda (y) 1.0))
+ (env-channel '(0 0 .1 .1 .2 .2 .3 .3 .4 .4 .5 .5 .6 .6 .7 .7 .8 .8 .9 .9))
+ (if (not (vequal (channel->float-vector) (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
+ (snd-display ";ramp env by .1: ~A" (channel->float-vector)))
+ (close-sound ind))
+ )
- (set! (hook-functions open-raw-sound-hook) ())
- (hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) #t)))
- (set! (hook-functions bad-header-hook) ())
- (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
- (if (null? (hook-functions open-raw-sound-hook)) (snd-display #__line__ ";add hook open-raw-sound-hook failed??"))
- (if (null? (hook-functions bad-header-hook)) (snd-display #__line__ ";add hook bad-header-hook failed??"))
- (let* ((magic-words (list ".snd" "FORM" "AIFF" "AIFC" "COMM" "COMT" "INFO" "INST" "inst" "MARK" "SSND"
- "FVER" "NONE" "ULAW" "ulaw" "ima4" "raw " "sowt" "in32" "in24" "ni23" "fl32"
- "FL32" "fl64" "twos" "ALAW" "alaw" "APPL" "CLM " "RIFF" "RIFX" "WAVE" "fmt "
- "data" "fact" "clm " "NIST" "8SVX" "16SV" "Crea" "tive" "SOUN" "D SA" "MPLE"
- "BODY" "VHDR" "CHAN" "ANNO" "NAME" "2BIT" "HCOM" "FSSD" "%//\n" "%---" "ALaw"
- "Soun" "MAUD" "MHDR" "MDAT" "mdat" "MThd" "sfbk" "sdta" "shdr" "pdta"
- "LIST" "GF1P" "ATCH" "$SIG" "NAL_" "GOLD" " SAM" "SRFS" "Diam" "ondW" "CSRE"
- "SND " "SNIN" "SNDT" "DDSF" "FSMu" "UWFD" "LM89" "SY80" "SY85" "SCRS" "DSPL"
- "AVI " "strf" "movi" "PRAM" " paf" "fap " "DS16" "HEDR" "HDR8" "SDA_" "SDAB"
- "SD_B" "NOTE" "file" "=sam" "SU7M" "SU7R" "PVF1" "PVF2" "AUTH" "riff" "TWIN"
- "IMPS" "SMP1" "Maui" "SDIF"))
- (len (length magic-words))
- (ctr 0))
- (for-each
- (lambda (magic)
- (if (null? (hook-functions open-raw-sound-hook)) (snd-display #__line__ ";open-raw-sound-hook cleared??"))
- (if (null? (hook-functions bad-header-hook)) (snd-display #__line__ ";bad-header-hook cleared??"))
- (if (file-exists? "test.snd")
- (delete-file "test.snd"))
- (mus-sound-forget "test.snd")
- ;; try random garbage
- (with-output-to-file "test.snd"
- (lambda ()
- (display magic)
- (do ((i 0 (+ i 1)))
- ((= i 128))
- (write (random 1.0)))))
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.snd"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound garbage ~A: ~A -> ~A?" magic tag (file->string "test.snd"))
- (if (sound? tag) (close-sound tag)))))
- (delete-file "test.snd")
- (mus-sound-forget "test.snd")
- ;; try plausible garbage
- (with-output-to-file "test.snd"
- (lambda ()
- (display magic)
- (do ((i 0 (+ i 1)))
- ((= i 128))
- (write (random 128)))))
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.snd"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound plausible garbage ~A: ~A?" magic tag)
- (if (sound? tag) (close-sound tag)))))
- (delete-file "test.snd")
- (mus-sound-forget "test.snd")
- ;; write very plausible garbage
- (with-output-to-file "test.snd"
- (lambda ()
- (display magic)
- (do ((i 1 (+ i 1)))
- ((= i 12))
- (if (< (+ ctr i) len)
- (display (magic-words (+ ctr i)))
- (display (magic-words i))))))
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.snd"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound very plausible garbage ~A: ~A?" magic tag)
- (if (sound? tag) (close-sound tag)))))
- (set! ctr (+ ctr 1)))
- magic-words))
- (if (file-exists? "test.snd") (delete-file "test.snd"))
- (mus-sound-forget "test.snd")
+ (set! (hook-functions open-raw-sound-hook) ())
+ (hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) #t)))
+ (set! (hook-functions bad-header-hook) ())
+ (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
+ (if (null? (hook-functions open-raw-sound-hook)) (snd-display ";add hook open-raw-sound-hook failed??"))
+ (if (null? (hook-functions bad-header-hook)) (snd-display ";add hook bad-header-hook failed??"))
+ (let* ((magic-words (list ".snd" "FORM" "AIFF" "AIFC" "COMM" "COMT" "INFO" "INST" "inst" "MARK" "SSND"
+ "FVER" "NONE" "ULAW" "ulaw" "ima4" "raw " "sowt" "in32" "in24" "ni23" "fl32"
+ "FL32" "fl64" "twos" "ALAW" "alaw" "APPL" "CLM " "RIFF" "RIFX" "WAVE" "fmt "
+ "data" "fact" "clm " "NIST" "8SVX" "16SV" "Crea" "tive" "SOUN" "D SA" "MPLE"
+ "BODY" "VHDR" "CHAN" "ANNO" "NAME" "2BIT" "HCOM" "FSSD" "%//\n" "%---" "ALaw"
+ "Soun" "MAUD" "MHDR" "MDAT" "mdat" "MThd" "sfbk" "sdta" "shdr" "pdta"
+ "LIST" "GF1P" "ATCH" "$SIG" "NAL_" "GOLD" " SAM" "SRFS" "Diam" "ondW" "CSRE"
+ "SND " "SNIN" "SNDT" "DDSF" "FSMu" "UWFD" "LM89" "SY80" "SY85" "SCRS" "DSPL"
+ "AVI " "strf" "movi" "PRAM" " paf" "fap " "DS16" "HEDR" "HDR8" "SDA_" "SDAB"
+ "SD_B" "NOTE" "file" "=sam" "SU7M" "SU7R" "PVF1" "PVF2" "AUTH" "riff" "TWIN"
+ "IMPS" "SMP1" "Maui" "SDIF"))
+ (len (length magic-words))
+ (ctr 0))
+ (for-each
+ (lambda (magic)
+ (if (null? (hook-functions open-raw-sound-hook)) (snd-display ";open-raw-sound-hook cleared??"))
+ (if (null? (hook-functions bad-header-hook)) (snd-display ";bad-header-hook cleared??"))
+ (if (file-exists? "test.snd")
+ (delete-file "test.snd"))
+ (mus-sound-forget "test.snd")
+ ;; try random garbage
+ (with-output-to-file "test.snd"
+ (lambda ()
+ (display magic)
+ (do ((i 0 (+ i 1)))
+ ((= i 128))
+ (write (random 1.0)))))
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.snd"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
+ (begin
+ (snd-display ";open-sound garbage ~A: ~A -> ~A?" magic tag (file->string "test.snd"))
+ (if (sound? tag) (close-sound tag)))))
+ (delete-file "test.snd")
+ (mus-sound-forget "test.snd")
+ ;; try plausible garbage
+ (with-output-to-file "test.snd"
+ (lambda ()
+ (display magic)
+ (do ((i 0 (+ i 1)))
+ ((= i 128))
+ (write (random 128)))))
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.snd"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
+ (begin
+ (snd-display ";open-sound plausible garbage ~A: ~A?" magic tag)
+ (if (sound? tag) (close-sound tag)))))
+ (delete-file "test.snd")
+ (mus-sound-forget "test.snd")
+ ;; write very plausible garbage
+ (with-output-to-file "test.snd"
+ (lambda ()
+ (display magic)
+ (do ((i 1 (+ i 1)))
+ ((= i 12))
+ (if (< (+ ctr i) len)
+ (display (magic-words (+ ctr i)))
+ (display (magic-words i))))))
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.snd"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
+ (begin
+ (snd-display ";open-sound very plausible garbage ~A: ~A?" magic tag)
+ (if (sound? tag) (close-sound tag)))))
+ (set! ctr (+ ctr 1)))
+ magic-words))
+ (if (file-exists? "test.snd") (delete-file "test.snd"))
+ (mus-sound-forget "test.snd")
+
+
+ (with-output-to-file "test.snd"
+ (lambda ()
+ (display ".snd")
+ (for-each write-byte '(0 0 0 28 0 1 141 24 0 0 0 18 0 0 86 34 0 0 0 1 0 0 0 0 0 1))))
+ (if (not (= (mus-sound-sample-type "test.snd") mus-bshort))
+ (snd-display ";next 18: ~A" (mus-sound-sample-type "test.snd")))
+ (delete-file "test.snd")
+ (mus-sound-forget "test.snd")
+ (with-output-to-file "test.snd"
+ (lambda ()
+ (display ".snd")
+ (for-each write-byte '(0 0 0 4 0 1 141 24 0 0 0 18 0 0 86 34 0 0 0 1 0 0 0 0 0 1))))
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.snd"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
+ (begin
+ (snd-display ";open-sound next bad location ~A: ~A?" (data-location tag) tag)
+ (close-sound tag))))
+ (delete-file "test.snd")
+ (mus-sound-forget "test.snd")
+
+ (let ((make-aifc-file
+ (lambda (len auth-lo bits)
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 102))
+ (display "AIFCFVER")
+ (for-each write-byte '(0 0 0 4 162 128 81 64))
+ (display "COMM")
+ (for-each write-byte (list 0 0 0 38 0 1 0 0 0 len 0 bits 64 14 172 68 0 0 0 0 0 0))
+ ;; srate as 80-bit float (sheesh)
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "AUTH")
+ (for-each write-byte (list 0 0 0 auth-lo))
+ (display "bil")
+ (write-byte #o000)
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64)))))))
+ (if (file-exists? "test.aif") (delete-file "test.aif"))
+ (mus-sound-forget "test.aif")
+ ;;correct (make-aifc-file #o002 #o004 #o020)
+ (make-aifc-file #o102 #o004 #o020)
-
- (with-output-to-file "test.snd"
- (lambda ()
- (display ".snd")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o034) ; location
- (write-byte #o000) (write-byte #o001) (write-byte #o215) (write-byte #o030) ; nominal size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o022) ; format
- (write-byte #o000) (write-byte #o000) (write-byte #o126) (write-byte #o042) ; srate
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o001) ; chans
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; comment
- (write-byte #o000) (write-byte #o001) ; samp 1
- ))
- (if (not (= (mus-sound-sample-type "test.snd") mus-bshort))
- (snd-display #__line__ ";next 18: ~A" (mus-sound-sample-type "test.snd")))
- (delete-file "test.snd")
- (mus-sound-forget "test.snd")
- (with-output-to-file "test.snd"
+ (catch #t
(lambda ()
- (display ".snd")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; location
- (write-byte #o000) (write-byte #o001) (write-byte #o215) (write-byte #o030) ; nominal size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o022) ; format
- (write-byte #o000) (write-byte #o000) (write-byte #o126) (write-byte #o042) ; srate
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o001) ; chans
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; comment
- (write-byte #o000) (write-byte #o001) ; samp 1
- ))
+ (let ((ind (open-sound "test.aif")))
+ (if (not (= (framples ind) 2)) (snd-display ";bad framples in header: ~A" (framples ind)))
+ (close-sound ind)))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+ (make-aifc-file #o002 #o150 #o020)
(let ((tag (catch #t
- (lambda ()
- (open-sound "test.snd"))
- (lambda args (car args)))))
+ (lambda ()
+ (open-sound "test.aif"))
+ (lambda args (car args)))))
(if (and (number? tag)
(sound? tag))
(begin
- (snd-display #__line__ ";open-sound next bad location ~A: ~A?" (data-location tag) tag)
+ (snd-display ";open-sound aifc no ssnd chunk ~A: ~A?" (data-location tag) tag)
(close-sound tag))))
- (delete-file "test.snd")
- (mus-sound-forget "test.snd")
-
- (letrec ((make-aifc-file
- (lambda (len auth-lo bits)
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o146) ; len
- (display "AIFCFVER")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; version chunk size
- (write-byte #o242) (write-byte #o200) (write-byte #o121) (write-byte #o100) ; version
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte len) ; framples
- (write-byte #o000) (write-byte bits) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ;
- ;; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "AUTH")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte auth-lo) ; AUTH chunk size
- (display "bil")
- (write-byte #o000)
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- )))))
- (if (file-exists? "test.aif") (delete-file "test.aif"))
- (mus-sound-forget "test.aif")
- ;;correct (make-aifc-file #o002 #o004 #o020)
- (make-aifc-file #o102 #o004 #o020)
-
- (catch #t
- (lambda ()
- (let ((ind (open-sound "test.aif")))
- (if (not (= (framples ind) 2)) (snd-display #__line__ ";bad framples in header: ~A" (framples ind)))
- (close-sound ind)))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
- (make-aifc-file #o002 #o150 #o020)
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.aif"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound aifc no ssnd chunk ~A: ~A?" (data-location tag) tag)
- (close-sound tag))))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
- (make-aifc-file #o002 #o000 #o020)
-
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.aif"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound aifc 0-len auth chunk ~A: ~A?" (data-location tag) tag)
- (close-sound tag))))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
- (make-aifc-file #o002 #o150 #o120)
- (let ((tag (catch #t
- (lambda ()
- (open-sound "test.aif"))
- (lambda args (car args)))))
- (if (and (number? tag)
- (sound? tag))
- (begin
- (snd-display #__line__ ";open-sound bits 80 ~A: ~A?" (sample-type tag) tag)
- (close-sound tag))))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif"))
-
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o176) ; len
- (display "AIFCFVER")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; version chunk size
- (write-byte #o242) (write-byte #o200) (write-byte #o121) (write-byte #o100) ; version
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o002) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "AUTH")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "bil")
- (write-byte #o000)
- (display "ANNO")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "cat")
- (write-byte #o000)
- (display "NAME")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "dog")
- (write-byte #o000)
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- ))
- (catch #t
- (lambda ()
- (if (not (= (length (mus-sound-comment "test.aif")) 15))
- (snd-display #__line__ ";aifc 3 aux comments: ~A?" (mus-sound-comment "test.aif"))))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o142) ; len
- (display "AIFC")
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o002) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "COMT")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000)
- (display "bil")
- (write-byte #o000)
- ))
-
- (catch #t
- (lambda ()
- (if (not (string=? (substring (mus-sound-comment "test.aif") 0 3) "bil"))
- (snd-display #__line__ ";aifc trailing comt comment: ~A?" (mus-sound-comment "test.aif"))))
- (lambda args (snd-display #__line__ ";~S" args)))
- (if (not (= (mus-sound-framples "test.aif") 2))
- (snd-display #__line__ ";aifc trailing comt framples: ~A?" (mus-sound-framples "test.aif")))
- (catch #t
- (lambda ()
- (let ((ind (open-sound "test.aif")))
- (if (or (fneq (sample 0) 0.00198)
- (fneq (sample 1) 0.00195)
- (fneq (sample 2) 0.0)
- (fneq (sample 3) 0.0))
- (snd-display #__line__ ";aifc trailing comt samps: ~A ~A ~A ~A" (sample 0) (sample 1) (sample 2) (sample 3)))
- (close-sound ind)))
- (lambda args (snd-display #__line__ ";~S" args)))
(delete-file "test.aif")
(mus-sound-forget "test.aif")
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o142) ; len
- (display "AIFC")
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o100) (write-byte #o102) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "COMT")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000)
- (display "bil")
- (write-byte #o000)
- ))
- (if (or (not (string? (mus-sound-comment "test.aif")))
- (not (string=? (substring (mus-sound-comment "test.aif") 0 3) "bil")))
- (snd-display #__line__ ";aifc trailing comt comment: ~A?" (mus-sound-comment "test.aif")))
- (if (not (= (mus-sound-framples "test.aif") 2))
- (snd-display #__line__ ";aifc trailing comt (bogus) framples: ~A?" (mus-sound-framples "test.aif")))
- (catch #t
- (lambda ()
- (let ((ind (open-sound "test.aif")))
- (if (or (fneq (sample 0) 0.00198)
- (fneq (sample 1) 0.00195)
- (fneq (sample 2) 0.0)
- (fneq (sample 3) 0.0))
- (snd-display #__line__ ";aifc trailing comt samps (bogus frame setting): ~A ~A ~A ~A" (sample 0) (sample 1) (sample 2) (sample 3)))
- (close-sound ind)))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o142) ; len
- (display "AIFC")
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o100) (write-byte #o102) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- ))
-
+ (make-aifc-file #o002 #o000 #o020)
+
(let ((tag (catch #t
- (lambda ()
- (open-sound "test.aif"))
- (lambda args (car args)))))
+ (lambda ()
+ (open-sound "test.aif"))
+ (lambda args (car args)))))
(if (and (number? tag)
(sound? tag))
(begin
- (snd-display #__line__ ";open-sound aifc 2 ssnd chunks ~A: ~A?" (data-location tag) tag)
+ (snd-display ";open-sound aifc 0-len auth chunk ~A: ~A?" (data-location tag) tag)
(close-sound tag))))
(delete-file "test.aif")
(mus-sound-forget "test.aif")
-
- (with-output-to-file "test.aif"
- (lambda ()
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o040) ; len
- (display "AIFC")
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o000) (write-byte #o101) (write-byte #o000) (write-byte #o100) ; two samples
- ))
+ (make-aifc-file #o002 #o150 #o120)
(let ((tag (catch #t
- (lambda ()
- (open-sound "test.aif"))
- (lambda args (car args)))))
- (if (not (eq? tag 'mus-error))
+ (lambda ()
+ (open-sound "test.aif"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
(begin
- (snd-display #__line__ ";open-sound aifc no comm chunk ~A?" tag)
- (if (and (number? tag)
- (sound? tag))
- (close-sound tag)))))
+ (snd-display ";open-sound bits 80 ~A: ~A?" (sample-type tag) tag)
+ (close-sound tag))))
(delete-file "test.aif")
- (mus-sound-forget "test.aif")
-
- (with-output-to-file "test.aif"
- (lambda ()
+ (mus-sound-forget "test.aif"))
+
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 126))
+ (display "AIFCFVER")
+ (for-each write-byte '(0 0 0 4 162 128 81 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 0 2 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "AUTH")
+ (for-each write-byte '(0 0 0 4))
+ (display "bil")
+ (write-byte #o000)
+ (display "ANNO")
+ (for-each write-byte '(0 0 0 4))
+ (display "cat")
+ (write-byte #o000)
+ (display "NAME")
+ (for-each write-byte '(0 0 0 4))
+ (display "dog")
+ (write-byte #o000)
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))))
+ (catch #t
+ (lambda ()
+ (if (not (= (length (mus-sound-comment "test.aif")) 15))
+ (snd-display ";aifc 3 aux comments: ~A?" (mus-sound-comment "test.aif"))))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 98))
+ (display "AIFC")
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 0 2 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "COMT")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0))
+ (display "bil")
+ (write-byte #o000)))
+
+ (catch #t
+ (lambda ()
+ (if (not (string=? (substring (mus-sound-comment "test.aif") 0 3) "bil"))
+ (snd-display ";aifc trailing comt comment: ~A?" (mus-sound-comment "test.aif"))))
+ (lambda args (snd-display ";~S" args)))
+ (if (not (= (mus-sound-framples "test.aif") 2))
+ (snd-display ";aifc trailing comt framples: ~A?" (mus-sound-framples "test.aif")))
+ (catch #t
+ (lambda ()
+ (let ((ind (open-sound "test.aif")))
+ (if (or (fneq (sample 0) 0.00198)
+ (fneq (sample 1) 0.00195)
+ (fneq (sample 2) 0.0)
+ (fneq (sample 3) 0.0))
+ (snd-display ";aifc trailing comt samps: ~A ~A ~A ~A" (sample 0) (sample 1) (sample 2) (sample 3)))
+ (close-sound ind)))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 98))
+ (display "AIFC")
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 64 66 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "COMT")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0))
+ (display "bil")
+ (write-byte #o000)))
+ (if (not (and (string? (mus-sound-comment "test.aif"))
+ (string=? (substring (mus-sound-comment "test.aif") 0 3) "bil")))
+ (snd-display ";aifc trailing comt comment: ~A?" (mus-sound-comment "test.aif")))
+ (if (not (= (mus-sound-framples "test.aif") 2))
+ (snd-display ";aifc trailing comt (bogus) framples: ~A?" (mus-sound-framples "test.aif")))
+ (catch #t
+ (lambda ()
+ (let ((ind (open-sound "test.aif")))
+ (if (or (fneq (sample 0) 0.00198)
+ (fneq (sample 1) 0.00195)
+ (fneq (sample 2) 0.0)
+ (fneq (sample 3) 0.0))
+ (snd-display ";aifc trailing comt samps (bogus frame setting): ~A ~A ~A ~A" (sample 0) (sample 1) (sample 2) (sample 3)))
+ (close-sound ind)))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 98))
+ (display "AIFC")
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 64 66 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))))
+
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.aif"))
+ (lambda args (car args)))))
+ (if (and (number? tag)
+ (sound? tag))
+ (begin
+ (snd-display ";open-sound aifc 2 ssnd chunks ~A: ~A?" (data-location tag) tag)
+ (close-sound tag))))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+
+ (with-output-to-file "test.aif"
+ (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 32))
+ (display "AIFC")
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 0 65 0 64))))
+ (let ((tag (catch #t
+ (lambda ()
+ (open-sound "test.aif"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'mus-error))
+ (begin
+ (snd-display ";open-sound aifc no comm chunk ~A?" tag)
+ (if (and (number? tag)
+ (sound? tag))
+ (close-sound tag)))))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+
+ (with-output-to-file "test.aif"
+ (lambda ()
;write AIFC with trailing chunks to try to confuse file->sample
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o176) ; len
- (display "AIFCFVER")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; version chunk size
- (write-byte #o242) (write-byte #o200) (write-byte #o121) (write-byte #o100) ; version
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o002) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o170) (write-byte #o101) (write-byte #o100) (write-byte #o100) ; two samples
- (display "AUTH")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "bil")
- (write-byte #o000)
- (display "ANNO")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "cat")
- (write-byte #o000)
- (display "NAME")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; AUTH chunk size
- (display "dog")
- (write-byte #o000)
- ))
- (catch #t
- (lambda ()
- (let ((gen (make-file->sample "test.aif")))
- (if (fneq (gen 0) 0.93948) (snd-display #__line__ ";file->sample chunked 0: ~A" (gen 0)))
- (if (fneq (gen 1) 0.50195) (snd-display #__line__ ";file->sample chunked 1: ~A" (gen 1)))
- (if (fneq (gen 2) 0.0) (snd-display #__line__ ";file->sample chunked eof: ~A" (gen 2)))
- (if (fneq (gen 3) 0.0) (snd-display #__line__ ";file->sample chunked eof+1: ~A" (gen 3))))
- (let ((file (open-sound "test.aif")))
- (if (not (= (framples file) 2)) (snd-display #__line__ ";chunked framples: ~A" (framples file)))
- (if (fneq (sample 0) 0.93948) (snd-display #__line__ ";file chunked 0: ~A" (sample 0)))
- (if (fneq (sample 1) 0.50195) (snd-display #__line__ ";file chunked 1: ~A" (sample 1)))
- (if (fneq (sample 2) 0.0) (snd-display #__line__ ";file chunked eof: ~A" (sample 2)))
- (if (fneq (sample 3) 0.0) (snd-display #__line__ ";file chunked eof+1: ~A" (sample 3)))
- (close-sound file)))
- (lambda args (snd-display #__line__ ";~S" args)))
- (catch #t
- (lambda ()
- (if (not (= (mus-sound-framples "test.aif") 2)) (snd-display #__line__ ";chunked mus-sound-framples: ~A" (mus-sound-framples "test.aif"))))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
-
- (with-output-to-file "test.aif"
- (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 126))
+ (display "AIFCFVER")
+ (for-each write-byte '(0 0 0 4 162 128 81 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 0 2 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 120 65 64 64))
+ (display "AUTH")
+ (for-each write-byte '(0 0 0 4))
+ (display "bil")
+ (write-byte #o000)
+ (display "ANNO")
+ (for-each write-byte '(0 0 0 4))
+ (display "cat")
+ (write-byte #o000)
+ (display "NAME")
+ (for-each write-byte '(0 0 0 4))
+ (display "dog")
+ (write-byte #o000)))
+ (catch #t
+ (lambda ()
+ (let ((gen (make-file->sample "test.aif")))
+ (if (fneq (gen 0) 0.93948) (snd-display ";file->sample chunked 0: ~A" (gen 0)))
+ (if (fneq (gen 1) 0.50195) (snd-display ";file->sample chunked 1: ~A" (gen 1)))
+ (if (fneq (gen 2) 0.0) (snd-display ";file->sample chunked eof: ~A" (gen 2)))
+ (if (fneq (gen 3) 0.0) (snd-display ";file->sample chunked eof+1: ~A" (gen 3))))
+ (let ((file (open-sound "test.aif")))
+ (if (not (= (framples file) 2)) (snd-display ";chunked framples: ~A" (framples file)))
+ (if (fneq (sample 0) 0.93948) (snd-display ";file chunked 0: ~A" (sample 0)))
+ (if (fneq (sample 1) 0.50195) (snd-display ";file chunked 1: ~A" (sample 1)))
+ (if (fneq (sample 2) 0.0) (snd-display ";file chunked eof: ~A" (sample 2)))
+ (if (fneq (sample 3) 0.0) (snd-display ";file chunked eof+1: ~A" (sample 3)))
+ (close-sound file)))
+ (lambda args (snd-display ";~S" args)))
+ (catch #t
+ (lambda ()
+ (if (not (= (mus-sound-framples "test.aif") 2)) (snd-display ";chunked mus-sound-framples: ~A" (mus-sound-framples "test.aif"))))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+
+ (with-output-to-file "test.aif"
+ (lambda ()
;write AIFC with trailing chunks to try to confuse file->sample
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o176) ; len
- (display "AIFCFVER")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; version chunk size
- (write-byte #o242) (write-byte #o200) (write-byte #o121) (write-byte #o100) ; version
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o170) (write-byte #o101) (write-byte #o100) (write-byte #o100) ; two samples
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o001) ; 1 chan
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o002) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "APPL")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte (char->integer #\h))
- (display "CLM ;Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")
- (write-byte #o000)
- ))
- (catch #t
- (lambda ()
- (let ((gen (make-file->sample "test.aif")))
- (if (fneq (gen 0) 0.93948) (snd-display #__line__ ";file->sample chunked 0: ~A" (gen 0)))
- (if (fneq (gen 1) 0.50195) (snd-display #__line__ ";file->sample chunked 1: ~A" (gen 1)))
- (if (fneq (gen 2) 0.0) (snd-display #__line__ ";file->sample chunked eof: ~A" (gen 2)))
- (if (fneq (gen 3) 0.0) (snd-display #__line__ ";file->sample chunked eof+1: ~A" (gen 3))))
- (let ((file (open-sound "test.aif")))
- (if (not (= (framples file) 2)) (snd-display #__line__ ";chunked framples: ~A" (framples file)))
- (if (fneq (sample 0) 0.93948) (snd-display #__line__ ";file chunked 0: ~A" (sample 0)))
- (if (fneq (sample 1) 0.50195) (snd-display #__line__ ";file chunked 1: ~A" (sample 1)))
- (if (fneq (sample 2) 0.0) (snd-display #__line__ ";file chunked eof: ~A" (sample 2)))
- (if (fneq (sample 3) 0.0) (snd-display #__line__ ";file chunked eof+1: ~A" (sample 3)))
- (if (or (not (string? (comment)))
- (not (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
- (snd-display #__line__ ";chunked appl comment: ~A" (comment)))
- (close-sound file)))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
-
- (with-output-to-file "test.aif"
- (lambda ()
+ (display "FORM")
+ (for-each write-byte '(0 0 0 126))
+ (display "AIFCFVER")
+ (for-each write-byte '(0 0 0 4 162 128 81 64))
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 120 65 64 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 1 0 0 0 2 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "APPL")
+ (for-each write-byte (list 0 0 0 (char->integer #\h)))
+ (display "CLM ;Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")
+ (write-byte #o000)))
+ (catch #t
+ (lambda ()
+ (let ((gen (make-file->sample "test.aif")))
+ (if (fneq (gen 0) 0.93948) (snd-display ";file->sample chunked 0: ~A" (gen 0)))
+ (if (fneq (gen 1) 0.50195) (snd-display ";file->sample chunked 1: ~A" (gen 1)))
+ (if (fneq (gen 2) 0.0) (snd-display ";file->sample chunked eof: ~A" (gen 2)))
+ (if (fneq (gen 3) 0.0) (snd-display ";file->sample chunked eof+1: ~A" (gen 3))))
+ (let ((file (open-sound "test.aif")))
+ (if (not (= (framples file) 2)) (snd-display ";chunked framples: ~A" (framples file)))
+ (if (fneq (sample 0) 0.93948) (snd-display ";file chunked 0: ~A" (sample 0)))
+ (if (fneq (sample 1) 0.50195) (snd-display ";file chunked 1: ~A" (sample 1)))
+ (if (fneq (sample 2) 0.0) (snd-display ";file chunked eof: ~A" (sample 2)))
+ (if (fneq (sample 3) 0.0) (snd-display ";file chunked eof+1: ~A" (sample 3)))
+ (if (not (and (string? (comment))
+ (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
+ (snd-display ";chunked appl comment: ~A" (comment)))
+ (close-sound file)))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+
+ (with-output-to-file "test.aif"
+ (lambda ()
;write AIFC with trailing chunks to try to confuse file->sample
- (display "FORM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o176) ; len
- (display "AIFCFVER")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o004) ; version chunk size
- (write-byte #o242) (write-byte #o200) (write-byte #o121) (write-byte #o100) ; version
- (display "SSND")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o014) ; SSND chunk size
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; SSND data loc
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; block size?
- (write-byte #o170) (write-byte #o101) (write-byte #o100) (write-byte #o100) ; two samples (one frame)
- (display "COMM")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o046) ; COMM chunk size
- (write-byte #o000) (write-byte #o002) ; 2 chans
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o001) ; framples
- (write-byte #o000) (write-byte #o020) ; bits
- (write-byte #o100) (write-byte #o016) (write-byte #o254) (write-byte #o104) (write-byte #o000)
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte #o000) ; srate as 80-bit float (sheesh)
- (display "NONE") ; compression
- (write-byte #o016) ; pascal string len
- (display "not compressed")
- (write-byte #o000)
- (display "APPL")
- (write-byte #o000) (write-byte #o000) (write-byte #o000) (write-byte (char->integer #\h))
- (display "CLM ;Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")
- (write-byte #o000)
- ))
- (catch #t
- (lambda ()
- (let ((gen (make-file->sample "test.aif")))
- (if (fneq (gen 0 0) 0.93948) (snd-display #__line__ ";file->sample chunked 0 0: ~A" (gen 0 0)))
- (if (fneq (gen 0 1) 0.50195) (snd-display #__line__ ";file->sample chunked 0 1: ~A" (gen 0 1)))
- (if (fneq (gen 1 0) 0.0) (snd-display #__line__ ";file->sample chunked eof(stereo): ~A" (gen 1 0)))
- (if (fneq (gen 1 1) 0.0) (snd-display #__line__ ";file->sample chunked eof+1 (stereo): ~A" (gen 1 1))))
- (let ((file (open-sound "test.aif")))
- (if (not (= (framples file) 1)) (snd-display #__line__ ";chunked framples (1): ~A" (framples file)))
- (if (fneq (sample 0 file 0) 0.93948) (snd-display #__line__ ";file chunked 0 0: ~A" (sample 0 file 0)))
- (if (fneq (sample 0 file 1) 0.50195) (snd-display #__line__ ";file chunked 0 1: ~A" (sample 0 file 1)))
- (if (fneq (sample 1 file 0) 0.0) (snd-display #__line__ ";file chunked eof (stereo): ~A" (sample 1 file 0)))
- (if (fneq (sample 1 file 1) 0.0) (snd-display #__line__ ";file chunked eof+1 (stereo): ~A" (sample 1 file 1)))
- (if (or (not (string? (comment)))
- (not (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
- (snd-display #__line__ ";chunked appl comment (stereo): ~A" (comment)))
- (close-sound file)))
- (lambda args (snd-display #__line__ ";~S" args)))
- (delete-file "test.aif")
- (mus-sound-forget "test.aif")
-
- (let ((files (sound-files-in-directory cwd)))
- (define (difference a b)
- (let ((diffs ()))
- (for-each
- (lambda (f)
- (if (not (member f b)) (set! diffs (cons f diffs))))
- a)
- (for-each
- (lambda (f)
- (if (not (member f a)) (set! diffs (cons f diffs))))
- b)
- diffs))
- (if (null? files) (snd-display #__line__ ";no sound files in ~A?" cwd))
- (let ((files1 (sound-files-in-directory)))
- (if (not (equal? files files1)) (snd-display #__line__ ";different sound files in ~A and default?~% ~A~% ~A~%" cwd files files1))
- (let ((files2 (sound-files-in-directory ".")))
- (if (or (not (equal? files1 files2))
- (not (equal? files files2)))
- (snd-display #__line__ ";sound-files-in-directory dot: ~A~% ~A~% but ~A" (difference files2 files) files2 files)))))
-
- (set! (hook-functions bad-header-hook) ())
- (set! (hook-functions open-raw-sound-hook) ())
- (if (pair? (sounds)) (for-each close-sound (sounds)))
-
- (let ((ind (new-sound :size 0)))
- (if (not (= (framples ind) 0)) (snd-display #__line__ ";new-sound :size 0 -> ~A framples" (framples ind)))
- (if (fneq (sample 0) 0.0) (snd-display #__line__ ";new-sound :size 0 sample 0: ~A" (sample 0)))
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
- (let ((ind (new-sound :size 1)))
- (if (not (= (framples ind) 1)) (snd-display #__line__ ";new-sound :size 1 -> ~A framples" (framples ind)))
- (if (fneq (sample 0) 0.0) (snd-display #__line__ ";new-sound :size 1 sample 0: ~A" (sample 0)))
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
- (let ((tag (catch #t
- (lambda () (new-sound :size -1))
- (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range))
- (begin
- (snd-display #__line__ ";new-sound :size -1: ~A" tag)
- (if (pair? (sounds)) (for-each close-sound (sounds))))))
-
- (let ((ind (read-ascii (string-append sf-dir "caruso.asc"))))
- (if (not (sound? ind))
- (snd-display #__line__ ";read-ascii can't find ~A (~A)" (string-append sf-dir "caruso.asc") (map file-name (sounds)))
- (begin
- (if (fneq (maxamp ind 0) 0.723) (snd-display #__line__ ";read-ascii maxamp: ~A" (maxamp ind 0)))
- (if (not (= (framples ind 0) 50000)) (snd-display #__line__ ";read-ascii framples: ~A" (framples ind 0)))
- (if (not (= (srate ind) 44100)) (snd-display #__line__ ";read-ascii srate: ~A" (srate ind)))
- (set! (srate ind) 8000)
- (if (or (not (= (framples ind 0) 50000))
- (fneq (maxamp ind 0) .723))
- (snd-display #__line__ ";set srate clobbered new sound: ~A ~A (~A)" (framples ind 0) (maxamp ind 0) (srate ind)))
-
- (close-sound ind))))
-
- (let ((ind (open-sound "oboe.snd")))
- (save-sound-as "test space.snd")
- (close-sound ind)
- (set! ind (open-sound "test space.snd"))
- (if (not (string=? (short-file-name ind) "test space.snd"))
- (snd-display #__line__ ";file name with space: ~A" (short-file-name ind)))
- (let ((len (framples ind))
- (slen (mus-sound-framples "test space.snd")))
- (if (not (= len slen)) (snd-display #__line__ ";spaced filename framples: ~A ~A" len slen)))
- (add-mark 1234 ind 0)
- (save-marks ind) ; should write "test space.marks"
+ (display "FORM")
+ (for-each write-byte '(0 0 0 126))
+ (display "AIFCFVER")
+ (for-each write-byte '(0 0 0 4 162 128 81 64))
+ (display "SSND")
+ (for-each write-byte '(0 0 0 12 0 0 0 0 0 0 0 0 120 65 64 64))
+ (display "COMM")
+ (for-each write-byte '(0 0 0 38 0 2 0 0 0 1 0 16 64 14 172 68 0 0 0 0 0 0))
+ (display "NONE") ; compression
+ (write-byte #o016) ; pascal string len
+ (display "not compressed")
+ (write-byte #o000)
+ (display "APPL")
+ (for-each write-byte (list 0 0 0 (char->integer #\h)))
+ (display "CLM ;Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")
+ (write-byte #o000)))
+ (catch #t
+ (lambda ()
+ (let ((gen (make-file->sample "test.aif")))
+ (if (fneq (gen 0 0) 0.93948) (snd-display ";file->sample chunked 0 0: ~A" (gen 0 0)))
+ (if (fneq (gen 0 1) 0.50195) (snd-display ";file->sample chunked 0 1: ~A" (gen 0 1)))
+ (if (fneq (gen 1 0) 0.0) (snd-display ";file->sample chunked eof(stereo): ~A" (gen 1 0)))
+ (if (fneq (gen 1 1) 0.0) (snd-display ";file->sample chunked eof+1 (stereo): ~A" (gen 1 1))))
+ (let ((file (open-sound "test.aif")))
+ (if (not (= (framples file) 1)) (snd-display ";chunked framples (1): ~A" (framples file)))
+ (if (fneq (sample 0 file 0) 0.93948) (snd-display ";file chunked 0 0: ~A" (sample 0 file 0)))
+ (if (fneq (sample 0 file 1) 0.50195) (snd-display ";file chunked 0 1: ~A" (sample 0 file 1)))
+ (if (fneq (sample 1 file 0) 0.0) (snd-display ";file chunked eof (stereo): ~A" (sample 1 file 0)))
+ (if (fneq (sample 1 file 1) 0.0) (snd-display ";file chunked eof+1 (stereo): ~A" (sample 1 file 1)))
+ (if (not (and (string? (comment))
+ (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
+ (snd-display ";chunked appl comment (stereo): ~A" (comment)))
+ (close-sound file)))
+ (lambda args (snd-display ";~S" args)))
+ (delete-file "test.aif")
+ (mus-sound-forget "test.aif")
+
+ (let ((files (sound-files-in-directory cwd)))
+ (define (difference a b)
+ (let ((diffs ()))
+ (for-each
+ (lambda (f)
+ (if (not (member f b)) (set! diffs (cons f diffs))))
+ a)
+ (for-each
+ (lambda (f)
+ (if (not (member f a)) (set! diffs (cons f diffs))))
+ b)
+ diffs))
+ (if (null? files) (snd-display ";no sound files in ~A?" cwd))
+ (let ((files1 (sound-files-in-directory)))
+ (if (not (equal? files files1)) (snd-display ";different sound files in ~A and default?~% ~A~% ~A~%" cwd files files1))
+ (let ((files2 (sound-files-in-directory ".")))
+ (if (not (and (equal? files1 files2)
+ (equal? files files2)))
+ (snd-display ";sound-files-in-directory dot: ~A~% ~A~% but ~A" (difference files2 files) files2 files)))))
+
+ (set! (hook-functions bad-header-hook) ())
+ (set! (hook-functions open-raw-sound-hook) ())
+ (if (pair? (sounds)) (for-each close-sound (sounds)))
+
+ (let ((ind (new-sound :size 0)))
+ (if (not (= (framples ind) 0)) (snd-display ";new-sound :size 0 -> ~A framples" (framples ind)))
+ (if (fneq (sample 0) 0.0) (snd-display ";new-sound :size 0 sample 0: ~A" (sample 0)))
+ (let ((new-file-name (file-name ind)))
(close-sound ind)
- (set! ind (open-sound "test space.snd"))
- (load (string-append cwd "test space.marks"))
- (if (not (find-mark 1234 ind))
- (snd-display #__line__ ";space file name save marks: ~A" (marks ind)))
- (let ((rd (make-readin :file "test space.snd")))
- (if (not (string=? (mus-file-name rd) "test space.snd"))
- (snd-display #__line__ ";file name with space readin: ~A" (mus-file-name rd))))
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+ (let ((ind (new-sound :size 1)))
+ (if (not (= (framples ind) 1)) (snd-display ";new-sound :size 1 -> ~A framples" (framples ind)))
+ (if (fneq (sample 0) 0.0) (snd-display ";new-sound :size 1 sample 0: ~A" (sample 0)))
+ (let ((new-file-name (file-name ind)))
(close-sound ind)
- (if (file-exists? "test space.snd")
- (delete-file "test space.snd"))
- (if (file-exists? "test space.marks")
- (delete-file "test space.marks")))
-
- (if (directory? "oboe.snd") (snd-display #__line__ ";directory? oboe.snd!"))
- (if (not (directory? ".")) (snd-display #__line__ ";directory? . #f!"))
- (if (not (getenv "PATH")) (snd-display #__line__ ";getenv: no PATH?"))
- (if (not (number? (getpid))) (snd-display #__line__ ";getpid: ~A" (getpid)))
-
- (unless (provided? 'pure-s7)
- (let ((ip (current-input-port)))
- (let ((tag (catch #t (lambda () (set-current-input-port "hiho!")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";set-current-input-port tag: ~A" tag))
- (if (not (equal? ip (current-input-port))) (snd-display #__line__ ";set-current-input-port clobbered port? ~A ~A" ip (current-input-port)))))
-
- (let ((ip (current-output-port)))
- (let ((tag (catch #t (lambda () (set-current-output-port "hiho!")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";set-current-output-port tag: ~A" tag))
- (if (not (equal? ip (current-output-port))) (snd-display #__line__ ";set-current-output-port clobbered port? ~A ~A" ip (current-output-port)))))
-
- (let ((ip (current-error-port)))
- (let ((tag (catch #t (lambda () (set-current-error-port "hiho!")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";set-current-error-port tag: ~A" tag))
- (if (not (equal? ip (current-error-port))) (snd-display #__line__ ";set-current-error-port clobbered port? ~A ~A" ip (current-error-port))))))
-
- (if (not (provided? 'gmp))
- (let* ((LONG_MAX 2147483647)
- (LONG_MIN -2147483648)
- (LLONG_MAX most-positive-fixnum)
- (LLONG_MIN most-negative-fixnum)
- (ints (list 0 1 -1 10 -10 1234 -1234 LONG_MAX LONG_MIN 65536 -65536))
- (shorts (list 0 1 -1 10 -10 1234 -1234 32767 -32768 8191 -8191))
- (longs (list 0 1 -1 11 -11 LONG_MAX LONG_MIN LLONG_MAX LLONG_MIN 1000 -1000))
- (floats (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003))
- (doubles (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003)))
- (load "binary-io.scm")
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+ (let ((tag (catch #t
+ (lambda () (new-sound :size -1))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range))
+ (begin
+ (snd-display ";new-sound :size -1: ~A" tag)
+ (if (pair? (sounds)) (for-each close-sound (sounds))))))
+
+ (let ((ind (read-ascii (string-append sf-dir "caruso.asc"))))
+ (if (not (sound? ind))
+ (snd-display ";read-ascii can't find ~A (~A)" (string-append sf-dir "caruso.asc") (map file-name (sounds)))
+ (begin
+ (if (fneq (maxamp ind 0) 0.723) (snd-display ";read-ascii maxamp: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 50000)) (snd-display ";read-ascii framples: ~A" (framples ind 0)))
+ (if (not (= (srate ind) 44100)) (snd-display ";read-ascii srate: ~A" (srate ind)))
+ (set! (srate ind) 8000)
+ (if (or (not (= (framples ind 0) 50000))
+ (fneq (maxamp ind 0) .723))
+ (snd-display ";set srate clobbered new sound: ~A ~A (~A)" (framples ind 0) (maxamp ind 0) (srate ind)))
- (with-output-to-file "idf1.data"
- (lambda ()
-
- (write-lint32 123)
- (write-bint32 321)
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (write-lint32 (ints i))
- (write-bint32 (ints i)))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (write-lint16 (shorts i))
- (write-bint16 (shorts i)))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (write-lint64 (longs i))
- (write-bint64 (longs i)))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (write-lfloat32 (floats i))
- (write-bfloat32 (floats i)))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (write-lfloat64 (doubles i))
- (write-bfloat64 (doubles i)))
- ))
+ (close-sound ind))))
+
+ (let ((ind (open-sound "oboe.snd")))
+ (save-sound-as "test space.snd")
+ (close-sound ind)
+ (set! ind (open-sound "test space.snd"))
+ (if (not (string=? (short-file-name ind) "test space.snd"))
+ (snd-display ";file name with space: ~A" (short-file-name ind)))
+ (let ((len (framples ind))
+ (slen (mus-sound-framples "test space.snd")))
+ (if (not (= len slen)) (snd-display ";spaced filename framples: ~A ~A" len slen)))
+ (add-mark 1234 ind 0)
+ (save-marks ind) ; should write "test space.marks"
+ (close-sound ind)
+ (set! ind (open-sound "test space.snd"))
+ (load (string-append cwd "test space.marks"))
+ (if (not (find-mark 1234 ind))
+ (snd-display ";space file name save marks: ~A" (marks ind)))
+ (let ((rd (make-readin :file "test space.snd")))
+ (if (not (string=? (mus-file-name rd) "test space.snd"))
+ (snd-display ";file name with space readin: ~A" (mus-file-name rd))))
+ (close-sound ind)
+ (if (file-exists? "test space.snd")
+ (delete-file "test space.snd"))
+ (if (file-exists? "test space.marks")
+ (delete-file "test space.marks")))
+
+ (if (directory? "oboe.snd") (snd-display ";directory? oboe.snd!"))
+ (if (not (directory? ".")) (snd-display ";directory? . #f!"))
+ (if (not (getenv "PATH")) (snd-display ";getenv: no PATH?"))
+ (if (not (number? (getpid))) (snd-display ";getpid: ~A" (getpid)))
+
+ (unless (provided? 'gmp)
+ (let* ((LONG_MAX 2147483647)
+ (LONG_MIN -2147483648)
+ (LLONG_MAX most-positive-fixnum)
+ (LLONG_MIN most-negative-fixnum)
+ (ints (list 0 1 -1 10 -10 1234 -1234 LONG_MAX LONG_MIN 65536 -65536))
+ (shorts (list 0 1 -1 10 -10 1234 -1234 32767 -32768 8191 -8191))
+ (longs (list 0 1 -1 11 -11 LONG_MAX LONG_MIN LLONG_MAX LLONG_MIN 1000 -1000))
+ (floats (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003))
+ (doubles (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003)))
+ (load "binary-io.scm")
+
+ (with-output-to-file "idf1.data"
+ (lambda ()
- (with-input-from-file "idf1.data"
- (lambda ()
-
- (define (testf val1 val2 name)
- (if (not (= val1 val2))
- (if (and (not (eq? name 'lfloat32))
- (not (eq? name 'bfloat32)))
- (snd-display #__line__ ";testf ~A: ~A != ~A~%" name val1 val2)
- (if (> (abs (- val1 val2)) 1.0e-6)
- (snd-display #__line__ ";testf ~A: ~A != ~A (~A)~%" name val1 val2 (abs (- val1 val2)))))))
-
- (testf (read-lint32) 123 'lint32)
- (testf (read-bint32) 321 'bint32)
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (testf (read-lint32) (ints i) 'lint32)
- (testf (read-bint32) (ints i) 'bint32))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (testf (read-lint16) (shorts i) 'lint16)
- (testf (read-bint16) (shorts i) 'bint16))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (testf (read-lint64) (longs i) 'lint64)
- (testf (read-bint64) (longs i) 'bint64))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (testf (read-lfloat32) (floats i) 'lfloat32)
- (testf (read-bfloat32) (floats i) 'bfloat32))
-
- (do ((i 0 (+ i 1)))
- ((= i 11))
- (testf (read-lfloat64) (doubles i) 'lfloat64)
- (testf (read-bfloat64) (doubles i) 'bfloat64))
- ))
+ (write-lint32 123)
+ (write-bint32 321)
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (write-lint32 (ints i))
+ (write-bint32 (ints i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (write-lint16 (shorts i))
+ (write-bint16 (shorts i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (write-lint64 (longs i))
+ (write-bint64 (longs i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (write-lfloat32 (floats i))
+ (write-bfloat32 (floats i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (write-lfloat64 (doubles i))
+ (write-bfloat64 (doubles i)))
))
- ))
+
+ (with-input-from-file "idf1.data"
+ (lambda ()
+
+ (define (testf val1 val2 name)
+ (if (not (= val1 val2))
+ (if (not (memq name '(lfloat32 bfloat32)))
+ (snd-display ";testf ~A: ~A != ~A~%" name val1 val2)
+ (if (> (abs (- val1 val2)) 1.0e-6)
+ (snd-display ";testf ~A: ~A != ~A (~A)~%" name val1 val2 (abs (- val1 val2)))))))
+
+ (testf (read-lint32) 123 'lint32)
+ (testf (read-bint32) 321 'bint32)
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (testf (read-lint32) (ints i) 'lint32)
+ (testf (read-bint32) (ints i) 'bint32))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (testf (read-lint16) (shorts i) 'lint16)
+ (testf (read-bint16) (shorts i) 'bint16))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (testf (read-lint64) (longs i) 'lint64)
+ (testf (read-bint64) (longs i) 'bint64))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (testf (read-lfloat32) (floats i) 'lfloat32)
+ (testf (read-bfloat32) (floats i) 'bfloat32))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 11))
+ (testf (read-lfloat64) (doubles i) 'lfloat64)
+ (testf (read-bfloat64) (doubles i) 'bfloat64))
+ ))
+ )))
@@ -4492,7 +4169,6 @@
(define (snd_test_5)
(define a-ctr 0)
- (define g-init-val 0)
(define (append-sound filename)
(insert-sound filename (framples)))
@@ -4502,13 +4178,13 @@
(fr2 (test-func ind1 0 0))
(fr3 (test-func ind1 0 current-edit-position)))
(if (not (= fr1 fr2 fr3))
- (snd-display #__line__ ";initial ~A: ~A ~A ~A?" func-name fr1 fr2 fr3))
+ (snd-display ";initial ~A: ~A ~A ~A?" func-name fr1 fr2 fr3))
(change-thunk)
(let ((fr5 (test-func ind1 0))
(fr6 (test-func ind1 0 1))
(fr7 (test-func ind1 0 current-edit-position)))
(if (not (= fr5 fr6 fr7))
- (snd-display #__line__ ";~A (edpos 1): ~A ~A ~A?" func-name fr5 fr6 fr7))))
+ (snd-display ";~A (edpos 1): ~A ~A ~A?" func-name fr5 fr6 fr7))))
(revert-sound ind1))
(define (test-edpos-1 test-func func-name ind1)
@@ -4516,11 +4192,11 @@
(test-func ind1 0)
(let ((v1 (channel->float-vector 12000 10 ind1 0)))
(if (vequal v0 v1)
- (snd-display #__line__ ";~A (0) no change! ~A ~A" func-name v0 v1))
+ (snd-display ";~A (0) no change! ~A ~A" func-name v0 v1))
(test-func ind1 0)
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";~A (1) ~A ~A" func-name v1 v2)))))
+ (snd-display ";~A (1) ~A ~A" func-name v1 v2)))))
(revert-sound ind1))
(define (test-orig func0 func1 func-name ind1)
@@ -4528,11 +4204,11 @@
(func0 ind1)
(let ((v1 (channel->float-vector 12000 10 ind1 0)))
(if (vequal1 v0 v1)
- (snd-display #__line__ ";~A (orig: 0) no change! ~A ~A" func-name v0 v1))
+ (snd-display ";~A (orig: 0) no change! ~A ~A" func-name v0 v1))
(func1 ind1)
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
(if (not (vequal1 v0 v2))
- (snd-display #__line__ ";~A (orig: 1) ~A ~A" func-name v0 v2))))
+ (snd-display ";~A (orig: 1) ~A ~A" func-name v0 v2))))
(revert-sound ind1)))
(define* (make-bandpass-2 flo1 fhi1 flo2 fhi2 (len 30))
@@ -4541,50 +4217,27 @@
(float-vector-add! (mus-xcoeffs f1) (mus-xcoeffs f2))
f1))
-#|
- (define* (cosine-channel (beg 0) dur snd chn edpos)
- (let ((samps (or dur (framples snd chn))))
- (map-channel
- (let ((incr (/ pi samps))
- (angle (* -0.5 pi)))
- (lambda (y)
- (let ((val (* y (cos angle))))
- (set! angle (+ angle incr))
- val)))
- beg dur snd chn edpos)
- ))
-|#
- (define* (cosine-channel (beg 0) dur snd chn edpos)
- (let ((samps (or dur (framples snd chn))))
- (map-channel
- (let ((incr (/ pi samps))
- (angle (* -0.5 pi))
- (p (make-one-pole 1.0 -1.0)))
- (one-pole p (- angle incr))
- (lambda (y)
- (* y (cos (one-pole p incr)))))
- beg dur snd chn edpos)
- ))
+ (define-expansion (check-maxamp ind val name)
+ `(check-maxamp-1 ,(port-line-number) ,ind ,val ,name))
- (define (check-maxamp caller-line ind val name)
- (if (fneq (maxamp ind 0) val) (snd-display #__line__ ";maxamp amp-env ~A: ~A should be ~A" name (maxamp ind) val))
+ (define (check-maxamp-1 caller-line ind val name)
+ (if (fneq (maxamp ind 0) val) (snd-display ";maxamp amp-env ~A: ~A should be ~A" name (maxamp ind) val))
(let ((pos (scan-channel (lambda (y) (>= (abs y) (- val .0001)))))
(maxpos (maxamp-position ind 0)))
(if (not pos)
- (snd-display #__line__ ";actual maxamp ~A vals not right" name)
+ (snd-display ";actual maxamp ~A vals not right" name)
(if (not (= maxpos pos))
- (snd-display #__line__ ";~A: find and maxamp-position disagree: ~A (~A) ~A (~A)"
+ (snd-display ";~A: find and maxamp-position disagree: ~A (~A) ~A (~A)"
name pos (sample pos ind 0) maxpos (sample maxpos ind 0))))
(let ((mx 0.0)
- (data #f)
(mpos 0)
(len (framples ind)))
(let ((info (float-vector-peak-and-location (samples 0 len ind))))
(set! mpos (cadr info))
(set! mx (car info)))
(if (not (= mpos maxpos))
- (snd-display #__line__ ";(~D) scan and maxamp-position disagree: ~A ~A" caller-line mpos maxpos))
- (if (fneq mx val) (snd-display #__line__ ";(~D) actual ~A max: ~A (correct: ~A)" caller-line name mx val)))))
+ (snd-display ";(~D) scan and maxamp-position disagree: ~A ~A" caller-line mpos maxpos))
+ (if (fneq mx val) (snd-display ";(~D) actual ~A max: ~A (correct: ~A)" caller-line name mx val)))))
(define (check-env-vals name gen)
(let ((len (framples))
@@ -4597,7 +4250,7 @@
(y (next-sample reader)))
(if (fneq val y)
(begin
- (format #t "~%;check-env-vals ~A at ~D: ~A ~A" name i val y)
+ (format () "~%;check-env-vals ~A at ~D: ~A ~A" name i val y)
(quit)))))))))
(define (our-x->position ind x)
@@ -4617,7 +4270,7 @@
(define (region2float-vector r c len)
(region->float-vector r 0 len c))
- (if (playing) (snd-display #__line__ ";dac is running??"))
+ (if (playing) (snd-display ";dac is running??"))
(do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
(log-mem clmtest)
@@ -4628,7 +4281,7 @@
(lambda ()
(set! (y-axis-label ind 0 1) "hiho"))
(lambda args
- (snd-display #__line__ ";no fft axis: ~A" args)))
+ (snd-display ";no fft axis: ~A" args)))
(set! (fft-log-frequency ind 0) #t) ; segfault here originally
(update-transform-graph ind 0)
(close-sound ind))
@@ -4638,20 +4291,52 @@
(env-channel '(0 0 1 1 2 0))
(let ((data (channel->float-vector)))
(if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";pyr 10: ~A" data)))
+ (snd-display ";pyr 10: ~A" data)))
(undo)
(env-channel '((0 0) (1 1) (2 0)))
(let ((data (channel->float-vector)))
(if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";pyr 10: ~A" data)))
+ (snd-display ";pyr 10: ~A" data)))
(undo)
(env-channel (make-env '(0 0 1 1 2 0) :length 10))
(let ((data (channel->float-vector)))
(if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";pyr 10: ~A" data)))
+ (snd-display ";pyr 10: ~A" data)))
(undo)
(close-sound ind))
+ (define (string-=? a b) ;(format *stderr* "str: ~A ~A~%" a b)
+ (or (string=? a b)
+ (and (or (char-position #\- a)
+ (char-position #\- b))
+ (let ((alen (length a))
+ (blen (length b))
+ (j 0)
+ (happy #t))
+ (do ((b7 (- blen 7))
+ (a7 (- alen 7))
+ (i 0 (+ i 1)))
+ ((or (not happy)
+ (= i alen))
+ (and happy
+ (= j blen)))
+ (let ((ac (a i))
+ (bc (b j)))
+ (if (char=? ac bc)
+ (set! j (+ j 1))
+ (if (not (and (char=? ac #\-)
+ (<= i a7)
+ (string=? (substring a i (+ i 6)) "-0.000")))
+ (if (and (char=? bc #\-)
+ (<= j b7)
+ (string=? (substring b j (+ j 6)) "-0.000"))
+ (begin
+ (set! j (+ j 1))
+ (if (not (char=? ac (b j)))
+ (set! happy #f)
+ (set! j (+ j 1))))
+ (set! happy #f))))))))))
+
(for-each
(lambda (size)
(let ((ind (new-sound "test.snd" :size size))
@@ -4663,62 +4348,62 @@
(let ((data (channel->float-vector)))
(if (or (fneq (data 0) 0.0)
(fneq (data (- size 1)) 1.0))
- (snd-display #__line__ ";ramp-channel ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (snd-display ";ramp-channel ~A end points: ~A ~A" size (data 0) (data (- size 1))))
(do ((i 0 (+ i 1)))
((= i size))
(let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0)))
(segval (env e)))
(if (or (fneq segval val)
(fneq (data i) val))
- (snd-display #__line__ ";ramp-channel ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval)))))
+ (snd-display ";ramp-channel ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval)))))
(undo)
(xramp-channel 0.0 1.0 32.0)
(let ((e (make-env '(0 0 1 1) :length size :base 32.0)))
(let ((data (channel->float-vector)))
(if (or (fneq (data 0) 0.0)
(fneq (data (- size 1)) 1.0))
- (snd-display #__line__ ";xramp-channel 32 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (snd-display ";xramp-channel 32 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
(do ((i 0 (+ i 1)))
((= i size))
(let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 32.0))
(segval (env e)))
(if (or (fneq segval val)
(fneq (data i) val))
- (snd-display #__line__ ";xramp-channel 32 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
+ (snd-display ";xramp-channel 32 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
(undo)
(xramp-channel 0.0 1.0 0.4)
(let ((e (make-env '(0 0 1 1) :length size :base 0.4)))
(let ((data (channel->float-vector)))
(if (or (fneq (data 0) 0.0)
(fneq (data (- size 1)) 1.0))
- (snd-display #__line__ ";xramp-channel .4 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (snd-display ";xramp-channel .4 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
(do ((i 0 (+ i 1)))
((= i size))
(let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 0.4))
(segval (env e)))
(if (or (fneq segval val)
(fneq (data i) val))
- (snd-display #__line__ ";xramp-channel .4 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
+ (snd-display ";xramp-channel .4 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
(undo)
(xramp-channel 1.0 -1.0 8.0)
(let ((e (make-env '(0 1 1 -1) :length size :base 8.0)))
(let ((data (channel->float-vector)))
(if (or (fneq (data 0) 1.0)
(fneq (data (- size 1)) -1.0))
- (snd-display #__line__ ";xramp-channel 1 -1 8 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (snd-display ";xramp-channel 1 -1 8 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
(do ((i 0 (+ i 1)))
((= i size))
(let ((segval (env e)))
(if (fneq segval (data i))
- (snd-display #__line__ ";xramp-channel 1 -1 8 ~A of ~A: ramp: ~A, env: ~A" i size (data i) segval))))))
+ (snd-display ";xramp-channel 1 -1 8 ~A of ~A: ramp: ~A, env: ~A" i size (data i) segval))))))
(undo)
(close-sound ind)))
(list 10 100 1000))
;; basic edit tree cases
(let ((ind (new-sound "test.snd")))
- (if (not (= (redo) 0)) (snd-display #__line__ ";redo with no ops: ~A" (redo)))
- (if (not (= (undo) 0)) (snd-display #__line__ ";undo with no ops: ~A" (undo)))
+ (if (not (= (redo) 0)) (snd-display ";redo with no ops: ~A" (redo)))
+ (if (not (= (undo) 0)) (snd-display ";undo with no ops: ~A" (undo)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 0
@@ -4727,9 +4412,9 @@ EDITS: 0
(at 0, cp->sounds[0][0:0, 0.000]) [file: " cwd "test.snd[0]]
(at 1, end_mark)
")))
- (snd-display #__line__ ";new 0: ~A" (display-edits)))
+ (snd-display ";new 0: ~A" (display-edits)))
(insert-samples 10 10 (make-float-vector 10))
- (if (not (= (framples) 20)) (snd-display #__line__ ";new 1 framples: ~A" (framples)))
+ (if (not (= (framples) 20)) (snd-display ";new 1 framples: ~A" (framples)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 1
@@ -4743,10 +4428,10 @@ EDITS: 1
(at 10, cp->sounds[1][0:9, 1.000]) [buf: 10]
(at 20, end_mark)
")))
- (snd-display #__line__ ";new 1: ~A" (display-edits)))
+ (snd-display ";new 1: ~A" (display-edits)))
(undo)
(insert-samples 0 10 (make-float-vector 10))
- (if (not (= (framples) 11)) (snd-display #__line__ ";new 2 framples: ~A" (framples))) ; 11 because there was 1 sample when new-sound created
+ (if (not (= (framples) 11)) (snd-display ";new 2 framples: ~A" (framples))) ; 11 because there was 1 sample when new-sound created
(if (not (string-=? (display-edits) (string-append "
EDITS: 1
@@ -4759,11 +4444,11 @@ EDITS: 1
(at 10, cp->sounds[0][0:0, 0.000]) [file: " cwd "test.snd[0]]
(at 11, end_mark)
")))
- (snd-display #__line__ ";new 2: ~A" (display-edits)))
+ (snd-display ";new 2: ~A" (display-edits)))
(let ((eds (undo 2)))
- (if (not (= eds 2)) (snd-display #__line__ ";new 3 undo: ~A" eds)))
+ (if (not (= eds 2)) (snd-display ";new 3 undo: ~A" eds)))
(insert-samples 0 10 (make-float-vector 10))
- (if (not (= (framples) 11)) (snd-display #__line__ ";new 3 framples: ~A" (framples)))
+ (if (not (= (framples) 11)) (snd-display ";new 3 framples: ~A" (framples)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 1
@@ -4776,10 +4461,10 @@ EDITS: 1
(at 10, cp->sounds[0][0:0, 0.000]) [file: " cwd "test.snd[0]]
(at 11, end_mark)
")))
- (snd-display #__line__ ";new 3: ~A" (display-edits)))
+ (snd-display ";new 3: ~A" (display-edits)))
(undo)
(set! (sample 0) .5)
- (if (not (= (framples) 1)) (snd-display #__line__ ";new 4 framples: ~A" (framples)))
+ (if (not (= (framples) 1)) (snd-display ";new 4 framples: ~A" (framples)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 1
@@ -4791,11 +4476,11 @@ EDITS: 1
(at 0, cp->sounds[1][0:0, 1.000]) [buf: 1]
(at 1, end_mark)
")))
- (snd-display #__line__ ";new 4: ~A" (display-edits)))
+ (snd-display ";new 4: ~A" (display-edits)))
(undo)
(set! (samples 0 10) (make-float-vector 10))
- (if (not (= (framples) 10)) (snd-display #__line__ ";new 5 framples: ~A" (framples)))
+ (if (not (= (framples) 10)) (snd-display ";new 5 framples: ~A" (framples)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 1
@@ -4807,20 +4492,20 @@ EDITS: 1
(at 0, cp->sounds[1][0:9, 1.000]) [buf: 10]
(at 10, end_mark)
")))
- (snd-display #__line__ ";new 5: ~A" (display-edits)))
+ (snd-display ";new 5: ~A" (display-edits)))
(delete-samples 3 4)
- (if (not (= (framples) 6)) (snd-display #__line__ ";new 6 framples: ~A" (framples)))
+ (if (not (= (framples) 6)) (snd-display ";new 6 framples: ~A" (framples)))
(if (not (string-=? (safe-display-edits ind 0 2) "
(delete 3 4) ; delete-samples 3 4 [2:3]:
(at 0, cp->sounds[1][0:2, 1.000]) [buf: 10]
(at 3, cp->sounds[1][7:9, 1.000]) [buf: 10]
(at 6, end_mark)
"))
- (snd-display #__line__ ";new 6: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";new 6: ~A" (safe-display-edits ind 0 2)))
(set! (samples 1 4) (make-float-vector 4))
- (if (not (= (framples) 6)) (snd-display #__line__ ";new 7 framples: ~A" (framples)))
+ (if (not (= (framples) 6)) (snd-display ";new 7 framples: ~A" (framples)))
(if (not (string-=? (safe-display-edits ind 0 3) "
(set 1 4) ; set-samples [3:4]:
(at 0, cp->sounds[1][0:0, 1.000]) [buf: 10]
@@ -4828,13 +4513,13 @@ EDITS: 1
(at 5, cp->sounds[1][9:9, 1.000]) [buf: 10]
(at 6, end_mark)
"))
- (snd-display #__line__ ";new 7: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";new 7: ~A" (safe-display-edits ind 0 3)))
(undo 2)
(insert-samples 2 3 (make-float-vector 3))
(insert-samples 2 1 (make-float-vector 1))
(insert-samples 4 1 (make-float-vector 1))
(insert-samples 15 1 (make-float-vector 1))
- (if (not (= (framples) 16)) (snd-display #__line__ ";new 8 framples: ~A" (framples)))
+ (if (not (= (framples) 16)) (snd-display ";new 8 framples: ~A" (framples)))
(if (not (string-=? (display-edits) (string-append "
EDITS: 5
@@ -4878,7 +4563,7 @@ EDITS: 5
(at 15, cp->sounds[5][0:0, 1.000]) [buf: 1]
(at 16, end_mark)
")))
- (snd-display #__line__ ";new 8: ~A" (display-edits)))
+ (snd-display ";new 8: ~A" (display-edits)))
(delete-samples 2 1)
(if (not (string-=? (safe-display-edits ind 0 6) "
(delete 2 1) ; delete-samples 2 1 [6:7]:
@@ -4890,7 +4575,7 @@ EDITS: 5
(at 14, cp->sounds[5][0:0, 1.000]) [buf: 1]
(at 15, end_mark)
"))
- (snd-display #__line__ ";new 9: ~A" (safe-display-edits ind 0 6)))
+ (snd-display ";new 9: ~A" (safe-display-edits ind 0 6)))
(delete-samples 0 5)
(if (not (string-=? (safe-display-edits ind 0 7) "
(delete 0 5) ; delete-samples 0 5 [7:4]:
@@ -4899,7 +4584,7 @@ EDITS: 5
(at 9, cp->sounds[5][0:0, 1.000]) [buf: 1]
(at 10, end_mark)
"))
- (snd-display #__line__ ";new 10: ~A" (safe-display-edits ind 0 7)))
+ (snd-display ";new 10: ~A" (safe-display-edits ind 0 7)))
(delete-samples 6 4)
(if (not (string-=? (safe-display-edits ind 0 8) "
(delete 6 4) ; delete-samples 6 4 [8:3]:
@@ -4907,38 +4592,38 @@ EDITS: 5
(at 1, cp->sounds[1][2:6, 1.000]) [buf: 10]
(at 6, end_mark)
"))
- (snd-display #__line__ ";new 11: ~A" (safe-display-edits ind 0 8)))
+ (snd-display ";new 11: ~A" (safe-display-edits ind 0 8)))
(delete-samples 0 1)
(if (not (string-=? (safe-display-edits ind 0 9) "
(delete 0 1) ; delete-samples 0 1 [9:2]:
(at 0, cp->sounds[1][2:6, 1.000]) [buf: 10]
(at 5, end_mark)
"))
- (snd-display #__line__ ";new 12: ~A" (safe-display-edits ind 0 9)))
+ (snd-display ";new 12: ~A" (safe-display-edits ind 0 9)))
(delete-samples 0 5)
(if (not (string-=? (safe-display-edits ind 0 10) "
(delete 0 5) ; delete-samples 0 5 [10:1]:
(at 0, end_mark)
"))
- (snd-display #__line__ ";new 13: ~A" (safe-display-edits ind 0 10)))
+ (snd-display ";new 13: ~A" (safe-display-edits ind 0 10)))
(delete-samples 0 10)
(if (not (= (edit-position) 10))
- (snd-display #__line__ ";no-op delete deleted something! ~A" (display-edits)))
+ (snd-display ";no-op delete deleted something! ~A" (display-edits)))
(insert-samples 0 3 (make-float-vector 3))
(if (not (string-=? (safe-display-edits ind 0 11) "
(insert 0 3) ; insert-samples [11:2]:
(at 0, cp->sounds[6][0:2, 1.000]) [buf: 3]
(at 3, end_mark)
"))
- (snd-display #__line__ ";new 14: ~A" (safe-display-edits ind 0 11)))
+ (snd-display ";new 14: ~A" (safe-display-edits ind 0 11)))
(delete-samples 2 1)
(if (not (string-=? (safe-display-edits ind 0 12) "
(delete 2 1) ; delete-samples 2 1 [12:2]:
(at 0, cp->sounds[6][0:1, 1.000]) [buf: 3]
(at 2, end_mark)
"))
- (snd-display #__line__ ";new 15: ~A" (safe-display-edits ind 0 12)))
+ (snd-display ";new 15: ~A" (safe-display-edits ind 0 12)))
(set! (sample 0) .5)
(if (not (string-=? (safe-display-edits ind 0 13) "
(set 0 1) ; set-sample 0 0.5000 [13:3]:
@@ -4946,7 +4631,7 @@ EDITS: 5
(at 1, cp->sounds[6][1:1, 1.000]) [buf: 3]
(at 2, end_mark)
"))
- (snd-display #__line__ ";new 16: ~A" (safe-display-edits ind 0 13)))
+ (snd-display ";new 16: ~A" (safe-display-edits ind 0 13)))
(set! (sample 1) .5)
(if (not (string-=? (safe-display-edits ind 0 14) "
(set 1 1) ; set-sample 1 0.5000 [14:3]:
@@ -4954,14 +4639,14 @@ EDITS: 5
(at 1, cp->sounds[8][0:0, 1.000]) [buf: 1]
(at 2, end_mark)
"))
- (snd-display #__line__ ";new 17: ~A" (safe-display-edits ind 0 14)))
+ (snd-display ";new 17: ~A" (safe-display-edits ind 0 14)))
(map-channel (lambda (y) 1.0) 0 10)
(if (not (string-=? (safe-display-edits ind 0 15) "
(set 0 10) ; map-channel [15:2]:
(at 0, cp->sounds[9][0:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";new 18: ~A" (safe-display-edits ind 0 15)))
+ (snd-display ";new 18: ~A" (safe-display-edits ind 0 15)))
(insert-samples 0 10 (make-float-vector 10))
(if (not (string-=? (safe-display-edits ind 0 16) "
(insert 0 10) ; insert-samples [16:3]:
@@ -4969,7 +4654,7 @@ EDITS: 5
(at 10, cp->sounds[9][0:9, 1.000]) [buf: 10]
(at 20, end_mark)
"))
- (snd-display #__line__ ";new 19: ~A" (safe-display-edits ind 0 16)))
+ (snd-display ";new 19: ~A" (safe-display-edits ind 0 16)))
(set! (samples 2 3) (make-float-vector 3))
(if (not (string-=? (safe-display-edits ind 0 17) "
(set 2 3) ; set-samples [17:5]:
@@ -4979,7 +4664,7 @@ EDITS: 5
(at 10, cp->sounds[9][0:9, 1.000]) [buf: 10]
(at 20, end_mark)
"))
- (snd-display #__line__ ";new 20: ~A" (safe-display-edits ind 0 17)))
+ (snd-display ";new 20: ~A" (safe-display-edits ind 0 17)))
(set! (samples 0 12) (make-float-vector 12))
(if (not (string-=? (safe-display-edits ind 0 18) "
(set 0 12) ; set-samples [18:3]:
@@ -4987,7 +4672,7 @@ EDITS: 5
(at 12, cp->sounds[9][2:9, 1.000]) [buf: 10]
(at 20, end_mark)
"))
- (snd-display #__line__ ";new 21: ~A" (safe-display-edits ind 0 18)))
+ (snd-display ";new 21: ~A" (safe-display-edits ind 0 18)))
(set! (samples 30 10) (make-float-vector 10))
(if (not (string-=? (safe-display-edits ind 0 19) "
(set 20 21) ; set-samples [19:5]:
@@ -4997,7 +4682,7 @@ EDITS: 5
(at 30, cp->sounds[13][0:9, 1.000]) [buf: 10]
(at 40, end_mark)
"))
- (snd-display #__line__ ";new 21: ~A" (safe-display-edits ind 0 19)))
+ (snd-display ";new 21: ~A" (safe-display-edits ind 0 19)))
(close-sound ind))
;; scale/ramp
@@ -5009,7 +4694,7 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 0.500]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 0: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 0: ~A" (safe-display-edits ind 0 2)))
(undo)
(scale-channel 0.5 0 3)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5018,7 +4703,7 @@ EDITS: 5
(at 3, cp->sounds[1][3:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 1: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 1: ~A" (safe-display-edits ind 0 2)))
(undo)
(scale-channel 0.5 5 5)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5027,7 +4712,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 0.500]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 2: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 2: ~A" (safe-display-edits ind 0 2)))
(undo)
(scale-channel 0.5 2 4)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5037,14 +4722,14 @@ EDITS: 5
(at 6, cp->sounds[1][6:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 2a: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 2a: ~A" (safe-display-edits ind 0 2)))
(undo)
(scale-channel 0.5 10 10)
(if (not (= (edit-position) 1))
- (snd-display #__line__ ";scale beyond end edited? ~A" (display-edits)))
+ (snd-display ";scale beyond end edited? ~A" (display-edits)))
(scale-channel 0.5 100 10)
(if (not (= (edit-position) 1))
- (snd-display #__line__ ";scale way beyond end edited? ~A" (display-edits)))
+ (snd-display ";scale way beyond end edited? ~A" (display-edits)))
(scale-channel 0.5 5 10)
(if (not (string-=? (safe-display-edits ind 0 2) "
(scale 5 5) ; scale-channel 0.500 5 5 [2:3]:
@@ -5052,7 +4737,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 0.500]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 3: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 3: ~A" (safe-display-edits ind 0 2)))
(undo)
(set! (sample 4) .5)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5062,7 +4747,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 4: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";scl 4: ~A" (safe-display-edits ind 0 2)))
(scale-channel 0.5 0 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
(scale 0 4) ; scale-channel 0.500 0 4 [3:4]:
@@ -5071,7 +4756,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 5: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";scl 5: ~A" (safe-display-edits ind 0 3)))
(scale-channel 0.5 4 1)
(if (not (string-=? (safe-display-edits ind 0 4) "
(scale 4 1) ; scale-channel 0.500 4 1 [4:4]:
@@ -5080,7 +4765,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 6: ~A" (safe-display-edits ind 0 4)))
+ (snd-display ";scl 6: ~A" (safe-display-edits ind 0 4)))
(scale-channel 0.5 0 7)
(if (not (string-=? (safe-display-edits ind 0 5) "
(scale 0 7) ; scale-channel 0.500 0 7 [5:5]:
@@ -5090,7 +4775,7 @@ EDITS: 5
(at 7, cp->sounds[1][7:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 7: ~A" (safe-display-edits ind 0 5)))
+ (snd-display ";scl 7: ~A" (safe-display-edits ind 0 5)))
(scale-channel 0.5 1 4)
(if (not (string-=? (safe-display-edits ind 0 6) "
(scale 1 4) ; scale-channel 0.500 1 4 [6:6]:
@@ -5101,7 +4786,7 @@ EDITS: 5
(at 7, cp->sounds[1][7:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 8: ~A" (safe-display-edits ind 0 6)))
+ (snd-display ";scl 8: ~A" (safe-display-edits ind 0 6)))
(undo 4)
(scale-channel 0.5 1 8)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5113,7 +4798,7 @@ EDITS: 5
(at 9, cp->sounds[1][9:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";scl 9: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";scl 9: ~A" (safe-display-edits ind 0 3)))
(undo 2)
(ramp-channel 0.0 1.0)
@@ -5122,14 +4807,14 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]-0.000 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 0: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";ramp 0: ~A" (safe-display-edits ind 0 2)))
(scale-channel 0.5)
(if (not (string-=? (safe-display-edits ind 0 3) "
(scale 0 10) ; scale-channel 0.500 0 #f [3:2]:
(at 0, cp->sounds[1][0:9, 0.500, [1]-0.000 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 1: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 1: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 0 5)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5138,7 +4823,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 1.000, [1]0.556 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 2: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 2: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 2 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5148,7 +4833,7 @@ EDITS: 5
(at 6, cp->sounds[1][6:9, 1.000, [1]0.667 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 3: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 3: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 5 5)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5157,7 +4842,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 0.500, [1]0.556 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 4: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 4: ~A" (safe-display-edits ind 0 3)))
(undo 2)
(ramp-channel .2 .6 2 6)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5167,7 +4852,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 5: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";ramp 5: ~A" (safe-display-edits ind 0 2)))
(scale-channel 0.5 0 5)
(if (not (string-=? (safe-display-edits ind 0 3) "
(scale 0 5) ; scale-channel 0.500 0 5 [3:5]:
@@ -5177,7 +4862,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 6: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 6: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 2 6)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5187,7 +4872,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 7: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 7: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 5 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5199,7 +4884,7 @@ EDITS: 5
(at 9, cp->sounds[1][9:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 8: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 8: ~A" (safe-display-edits ind 0 3)))
(undo)
(set! (sample 4) .5)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5211,7 +4896,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 9: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 9: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 4 1)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5223,7 +4908,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 10: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 10: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-sample 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5234,7 +4919,7 @@ EDITS: 5
(at 7, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 9, end_mark)
"))
- (snd-display #__line__ ";ramp 11: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 11: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-samples 4 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5245,7 +4930,7 @@ EDITS: 5
(at 6, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 8, end_mark)
"))
- (snd-display #__line__ ";ramp 12: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 12: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-samples 4 3)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5256,7 +4941,7 @@ EDITS: 5
(at 5, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 7, end_mark)
"))
- (snd-display #__line__ ";ramp 13: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 13: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-samples 4 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5266,7 +4951,7 @@ EDITS: 5
(at 4, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 6, end_mark)
"))
- (snd-display #__line__ ";ramp 14: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 14: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-samples 4 5)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5276,7 +4961,7 @@ EDITS: 5
(at 4, cp->sounds[1][9:9, 1.000]) [buf: 10]
(at 5, end_mark)
"))
- (snd-display #__line__ ";ramp 15: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 15: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 4 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5288,7 +4973,7 @@ EDITS: 5
(at 8, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";ramp 16: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 16: ~A" (safe-display-edits ind 0 3)))
(undo)
(pad-channel 4 1)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5300,7 +4985,7 @@ EDITS: 5
(at 9, cp->sounds[1][8:9, 1.000]) [buf: 10]
(at 11, end_mark)
"))
- (snd-display #__line__ ";ramp 17: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";ramp 17: ~A" (safe-display-edits ind 0 3)))
(close-sound ind))
;; xramp
@@ -5312,7 +4997,7 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]0.000 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 1: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 1: ~A" (safe-display-edits ind 0 2)))
(undo)
(xramp-channel 0.0 1.0 0.325)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5320,7 +5005,7 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]0.000 -> 1.000, off: 1.481, scl: -1.481]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 2: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 2: ~A" (safe-display-edits ind 0 2)))
(undo)
(xramp-channel 0.0 1.0 0.0)
(if (not (string-=? (safe-display-edits ind 0 2) (string-append "
@@ -5328,7 +5013,7 @@ EDITS: 5
(at 0, cp->sounds[0][0:9, 0.000]) [file: " (getcwd) "/test.snd[0]]
(at 10, end_mark)
")))
- (snd-display #__line__ ";xramp 3: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 3: ~A" (safe-display-edits ind 0 2)))
(undo)
(xramp-channel 0.0 1.0 1.0)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5336,7 +5021,7 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]-0.000 -> 1.000]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 4: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 4: ~A" (safe-display-edits ind 0 2)))
(undo)
(xramp-channel 0.5 1.5 32.0)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5344,9 +5029,9 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]0.500 -> 1.500, off: 0.468, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 5: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 5: ~A" (safe-display-edits ind 0 2)))
(if (or (fneq (maxamp) 1.5) (fneq (sample 0) 0.5))
- (snd-display #__line__ ";xramp 5 vals: ~A ~A" (maxamp) (sample 0)))
+ (snd-display ";xramp 5 vals: ~A ~A" (maxamp) (sample 0)))
(undo)
(xramp-channel -0.5 1.5 32.0)
(if (not (string-=? (safe-display-edits ind 0 2) "
@@ -5354,9 +5039,9 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 1.000, [1]-0.500 -> 1.500, off: -0.565, scl: 0.065]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 6: ~A" (safe-display-edits ind 0 2)))
+ (snd-display ";xramp 6: ~A" (safe-display-edits ind 0 2)))
(if (or (fneq (maxamp) 1.5) (fneq (sample 0) -0.5))
- (snd-display #__line__ ";xramp 6 vals: ~A ~A" (maxamp) (sample 0)))
+ (snd-display ";xramp 6 vals: ~A ~A" (maxamp) (sample 0)))
(undo)
(xramp-channel 0.0 1.0 32.0)
(let ((vals (channel->float-vector))
@@ -5367,11 +5052,11 @@ EDITS: 5
(at 0, cp->sounds[1][0:9, 0.500, [1]0.000 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 7: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 7: ~A" (safe-display-edits ind 0 3)))
(set! ctr 0)
(let ((p (make-one-pole 1.0 -1.0)))
(let ((baddy (scan-channel (lambda (y) (fneq y (* 0.5 (float-vector-ref vals (floor (- (one-pole p 1.0) 1.0)))))))))
- (if baddy (snd-display #__line__ ";trouble in xramp 7: ~A" baddy))))
+ (if baddy (snd-display ";trouble in xramp 7: ~A" baddy))))
(undo)
(delete-sample 0)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5379,11 +5064,11 @@ EDITS: 5
(at 0, cp->sounds[1][1:9, 1.000, [1]0.015 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 9, end_mark)
"))
- (snd-display #__line__ ";xramp 8: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 8: ~A" (safe-display-edits ind 0 3)))
(set! ctr 1)
(let ((p (make-one-pole 1.0 -1.0)))
(let ((baddy (scan-channel (lambda (y) (fneq y (float-vector-ref vals (floor (one-pole p 1.0))))))))
- (if baddy (snd-display #__line__ ";trouble in xramp 8: ~A" baddy))))
+ (if baddy (snd-display ";trouble in xramp 8: ~A" baddy))))
(undo)
(delete-samples 0 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5391,12 +5076,12 @@ EDITS: 5
(at 0, cp->sounds[1][2:9, 1.000, [1]0.037 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 8, end_mark)
"))
- (snd-display #__line__ ";xramp 9: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 9: ~A" (safe-display-edits ind 0 3)))
(set! ctr 2)
(let ((p (make-one-pole 1.0 -1.0)))
(one-pole p 1.0)
(let ((baddy (scan-channel (lambda (y) (fneq y (float-vector-ref vals (floor (one-pole p 1.0))))))))
- (if baddy (snd-display #__line__ ";trouble in xramp 9: ~A" baddy))))
+ (if baddy (snd-display ";trouble in xramp 9: ~A" baddy))))
(undo)
(delete-sample 0)
(delete-sample 0)
@@ -5405,7 +5090,7 @@ EDITS: 5
(at 0, cp->sounds[1][2:9, 1.000, [1]0.037 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 8, end_mark)
"))
- (snd-display #__line__ ";xramp 10: ~A" (safe-display-edits ind 0 4)))
+ (snd-display ";xramp 10: ~A" (safe-display-edits ind 0 4)))
(undo 2)
(delete-sample 4)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5414,7 +5099,7 @@ EDITS: 5
(at 4, cp->sounds[1][5:9, 1.000, [1]0.189 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 9, end_mark)
"))
- (snd-display #__line__ ";xramp 11: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 11: ~A" (safe-display-edits ind 0 3)))
(undo)
(delete-samples 4 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5423,7 +5108,7 @@ EDITS: 5
(at 4, cp->sounds[1][6:9, 1.000, [1]0.293 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 8, end_mark)
"))
- (snd-display #__line__ ";xramp 12: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 12: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5 4 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5433,15 +5118,15 @@ EDITS: 5
(at 6, cp->sounds[1][6:9, 1.000, [1]0.293 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 13: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 13: ~A" (safe-display-edits ind 0 3)))
(set! ctr 0)
(let ((baddy (scan-channel (lambda (y)
- (if (or (and (> ctr 5) (fneq y (vals ctr)))
- (and (< ctr 4) (fneq y (vals ctr)))
- (and (or (= ctr 4) (= ctr 5)) (fneq y (* 0.5 (vals ctr)))))
- #t
- (begin (set! ctr (+ ctr 1)) #f))))))
- (if baddy (snd-display #__line__ ";trouble in xramp 8: ~A" baddy)))
+ (or (and (> ctr 5) (fneq y (vals ctr)))
+ (and (< ctr 4) (fneq y (vals ctr)))
+ (and (memv ctr '(4 5)) (fneq y (* 0.5 (vals ctr)))))
+ (set! ctr (+ ctr 1))
+ #f))))
+ (if baddy (snd-display ";trouble in xramp 8: ~A" baddy)))
(undo)
(scale-channel 0.5 0 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5450,7 +5135,7 @@ EDITS: 5
(at 2, cp->sounds[1][2:9, 1.000, [1]0.037 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 14: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 14: ~A" (safe-display-edits ind 0 3)))
(undo)
(pad-channel 4 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5460,7 +5145,7 @@ EDITS: 5
(at 6, cp->sounds[1][4:9, 1.000, [1]0.118 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 12, end_mark)
"))
- (snd-display #__line__ ";xramp 15: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 15: ~A" (safe-display-edits ind 0 3)))
(undo)
(set! (sample 4) 1.0)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5470,7 +5155,7 @@ EDITS: 5
(at 5, cp->sounds[1][5:9, 1.000, [1]0.189 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 16: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 16: ~A" (safe-display-edits ind 0 3)))
(undo)
(set! (samples 4 2) (make-float-vector 2))
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5480,7 +5165,7 @@ EDITS: 5
(at 6, cp->sounds[1][6:9, 1.000, [1]0.293 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 17: ~A" (safe-display-edits ind 0 3)))
+ (snd-display ";xramp 17: ~A" (safe-display-edits ind 0 3)))
(undo)
(scale-channel 0.5)
(set! (samples 4 2) (make-float-vector 2))
@@ -5491,7 +5176,7 @@ EDITS: 5
(at 6, cp->sounds[1][6:9, 0.500, [1]0.293 -> 1.000, off: -0.032, scl: 0.032]) [buf: 10]
(at 10, end_mark)
"))
- (snd-display #__line__ ";xramp 18: ~A" (safe-display-edits ind 0 4)))
+ (snd-display ";xramp 18: ~A" (safe-display-edits ind 0 4)))
)
(close-sound ind))
@@ -5515,8 +5200,8 @@ EDITS: 5
(at 90, cp->sounds[1][90:99, 0.500, [1]0.909 -> 1.000]) [buf: 100]
(at 100, end_mark)
"))
- (snd-display #__line__ ";multi-ramp 1: ~A" (safe-display-edits ind 0 12)))
- (if (fneq (maxamp) 0.5) (snd-display #__line__ ";multi ramp 1 maxamp: ~A" (maxamp)))
+ (snd-display ";multi-ramp 1: ~A" (safe-display-edits ind 0 12)))
+ (if (fneq (maxamp) 0.5) (snd-display ";multi ramp 1 maxamp: ~A" (maxamp)))
(undo)
(ramp-channel 0.1 1.0 10 90)
(if (not (string=? (safe-display-edits ind 0 12) "
@@ -5533,8 +5218,8 @@ EDITS: 5
(at 90, cp->sounds[1][90:99, 0.500, [1]0.909 -> 1.000]) [buf: 100]
(at 100, end_mark)
"))
- (snd-display #__line__ ";multi-ramp 2: ~A" (safe-display-edits ind 0 12)))
- (if (fneq (maxamp) 0.5) (snd-display #__line__ ";multi ramp 2 maxamp: ~A" (maxamp)))
+ (snd-display ";multi-ramp 2: ~A" (safe-display-edits ind 0 12)))
+ (if (fneq (maxamp) 0.5) (snd-display ";multi ramp 2 maxamp: ~A" (maxamp)))
(undo)
(ramp-channel 0.0 0.9 0 90)
(if (not (string=? (safe-display-edits ind 0 12) "
@@ -5551,10 +5236,10 @@ EDITS: 5
(at 90, cp->sounds[1][90:99, 0.500]) [buf: 100]
(at 100, end_mark)
"))
- (snd-display #__line__ ";multi-ramp 3: ~A" (safe-display-edits ind 0 12)))
- (if (fneq (maxamp) 0.5) (snd-display #__line__ ";multi ramp 3 maxamp: ~A" (maxamp)))
- (if (fneq (sample 89) 0.45) (snd-display #__line__ ";multi ramp 3 sample 89: ~A" (sample 89)))
- (if (fneq (sample 90) 0.5) (snd-display #__line__ ";multi ramp 3 sample 90: ~A" (sample 90)))
+ (snd-display ";multi-ramp 3: ~A" (safe-display-edits ind 0 12)))
+ (if (fneq (maxamp) 0.5) (snd-display ";multi ramp 3 maxamp: ~A" (maxamp)))
+ (if (fneq (sample 89) 0.45) (snd-display ";multi ramp 3 sample 89: ~A" (sample 89)))
+ (if (fneq (sample 90) 0.5) (snd-display ";multi ramp 3 sample 90: ~A" (sample 90)))
(undo)
(ramp-channel 0.1 0.9 10 80)
(if (not (string=? (safe-display-edits ind 0 12) "
@@ -5571,7 +5256,7 @@ EDITS: 5
(at 90, cp->sounds[1][90:99, 0.500]) [buf: 100]
(at 100, end_mark)
"))
- (snd-display #__line__ ";multi-ramp 4: ~A" (safe-display-edits ind 0 12)))
+ (snd-display ";multi-ramp 4: ~A" (safe-display-edits ind 0 12)))
(revert-sound)
(map-channel (lambda (y) 1.0) 0 100)
(ramp-channel 0.0 1.0)
@@ -5592,38 +5277,38 @@ EDITS: 5
(at 90, cp->sounds[1][90:99, 0.500, [1]0.909 -> 1.000]) [buf: 100]
(at 100, end_mark)
"))
- (snd-display #__line__ ";multi-ramp 5: ~A" (safe-display-edits ind 0 12)))
+ (snd-display ";multi-ramp 5: ~A" (safe-display-edits ind 0 12)))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
- (if (not (= (redo 1 ind 0) 0)) (snd-display #__line__ ";open redo with no ops: ~A" (redo)))
- (if (not (= (undo 1 ind 0) 0)) (snd-display #__line__ ";open undo with no ops: ~A" (undo)))
+ (if (not (= (redo 1 ind 0) 0)) (snd-display ";open redo with no ops: ~A" (redo)))
+ (if (not (= (undo 1 ind 0) 0)) (snd-display ";open undo with no ops: ~A" (undo)))
(set! (cursor) 1000)
(delete-sample 321)
- (if (not (= (cursor) 999)) (snd-display #__line__ ";delete-sample before cursor: ~A" (cursor)))
- (if (not (= (cursor ind 0 0) 1000)) (snd-display #__line__ ";delete-sample before cursor (0): ~A" (cursor ind 0 0)))
+ (if (not (= (cursor) 999)) (snd-display ";delete-sample before cursor: ~A" (cursor)))
+ (if (not (= (cursor ind 0 0) 1000)) (snd-display ";delete-sample before cursor (0): ~A" (cursor ind 0 0)))
(undo)
- (if (not (= (cursor) 1000)) (snd-display #__line__ ";delete-sample after cursor undo: ~A" (cursor)))
+ (if (not (= (cursor) 1000)) (snd-display ";delete-sample after cursor undo: ~A" (cursor)))
(undo -1)
- (if (not (= (cursor) 999)) (snd-display #__line__ ";delete-sample before cursor redo: ~A" (cursor)))
+ (if (not (= (cursor) 999)) (snd-display ";delete-sample before cursor redo: ~A" (cursor)))
(redo -1)
(delete-sample 1321)
- (if (not (= (cursor) 1000)) (snd-display #__line__ ";delete-sample after cursor: ~A" (cursor)))
+ (if (not (= (cursor) 1000)) (snd-display ";delete-sample after cursor: ~A" (cursor)))
(undo)
(delete-samples 0 100)
- (if (not (= (cursor) 900)) (snd-display #__line__ ";delete-samples before cursor: ~A" (cursor)))
+ (if (not (= (cursor) 900)) (snd-display ";delete-samples before cursor: ~A" (cursor)))
(undo)
(delete-samples 1100 100)
- (if (not (= (cursor) 1000)) (snd-display #__line__ ";delete-samples after cursor: ~A" (cursor)))
+ (if (not (= (cursor) 1000)) (snd-display ";delete-samples after cursor: ~A" (cursor)))
(undo)
(insert-samples 100 100 (make-float-vector 100))
- (if (not (= (cursor) 1100)) (snd-display #__line__ ";insert-samples before cursor: ~A" (cursor)))
+ (if (not (= (cursor) 1100)) (snd-display ";insert-samples before cursor: ~A" (cursor)))
(undo)
(insert-samples 1100 100 (make-float-vector 100))
- (if (not (= (cursor) 1000)) (snd-display #__line__ ";insert-samples after cursor: ~A" (cursor)))
+ (if (not (= (cursor) 1000)) (snd-display ";insert-samples after cursor: ~A" (cursor)))
(undo)
(set! (samples 0 100) (make-float-vector 100))
- (if (not (= (cursor) 1000)) (snd-display #__line__ ";set-samples cursor: ~A" (cursor)))
+ (if (not (= (cursor) 1000)) (snd-display ";set-samples cursor: ~A" (cursor)))
(set! (show-axes ind 0) show-x-axis-unlabelled)
(update-time-graph)
(set! (show-axes ind 0) show-all-axes-unlabelled)
@@ -5633,24 +5318,24 @@ EDITS: 5
(let ((ind (new-sound "test.snd" :size 100)))
(float-vector->channel (make-float-vector 3 1.0) 10 8)
(if (fneq (maxamp ind 0) 1.0)
- (snd-display #__line__ ";float-vector->channel size mismatch maxamp: ~A" (maxamp ind 0)))
+ (snd-display ";float-vector->channel size mismatch maxamp: ~A" (maxamp ind 0)))
(if (not (vequal (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";float-vector->channel size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
+ (snd-display ";float-vector->channel size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(revert-sound ind)
(set! (samples 10 5) (make-float-vector 3 1.0))
(if (fneq (maxamp ind 0) 1.0)
- (snd-display #__line__ ";set samples size mismatch maxamp: ~A" (maxamp ind 0)))
+ (snd-display ";set samples size mismatch maxamp: ~A" (maxamp ind 0)))
(if (not (vequal (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";set samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
+ (snd-display ";set samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(revert-sound ind)
(insert-samples 10 8 (make-float-vector 3 1.0) ind 0)
(if (fneq (maxamp ind 0) 1.0)
- (snd-display #__line__ ";insert samples size mismatch maxamp: ~A" (maxamp ind 0)))
+ (snd-display ";insert samples size mismatch maxamp: ~A" (maxamp ind 0)))
(if (not (vequal (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";insert samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
+ (snd-display ";insert samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(close-sound ind))
(let* ((index (open-sound "oboe.snd"))
@@ -5660,11 +5345,11 @@ EDITS: 5
(xz (x-zoom-slider))
(yz (y-zoom-slider)))
(if (not (string=? (snd-completion " open-so") " open-sound"))
- (snd-display #__line__ ";completion: ~A" (snd-completion " open-so")))
+ (snd-display ";completion: ~A" (snd-completion " open-so")))
; (if (not (string=? (snd-completion " open-sound") " open-sound"))
- ; (snd-display #__line__ ";completion: ~A" (snd-completion " open-so")))
+ ; (snd-display ";completion: ~A" (snd-completion " open-so")))
(if (not (string=? (snd-completion " zoom-focus-r") " zoom-focus-right"))
- (snd-display #__line__ ";completion: ~A" (snd-completion " zoom-focus-r")))
+ (snd-display ";completion: ~A" (snd-completion " zoom-focus-r")))
(play "oboe.snd" :wait #t)
(play "oboe.snd" :start 12000 :wait #t)
(play "oboe.snd" :start 12000 :end 15000 :wait #t)
@@ -5685,133 +5370,123 @@ EDITS: 5
(let ((k (disk-kspace "oboe.snd")))
(if (or (not (number? k))
(<= k 0))
- (snd-display #__line__ ";disk-kspace = ~A" (disk-kspace "oboe.snd")))
+ (snd-display ";disk-kspace = ~A" (disk-kspace "oboe.snd")))
(set! k (disk-kspace "/baddy/hiho"))
(if (not (= k -1))
- (snd-display #__line__ ";disk-kspace of bogus file = ~A" (disk-kspace "/baddy/hiho"))))
- (if (not (= (transform-framples) 0)) (snd-display #__line__ ";transform-framples ~A?" (transform-framples)))
+ (snd-display ";disk-kspace of bogus file = ~A" (disk-kspace "/baddy/hiho"))))
+ (if (not (= (transform-framples) 0)) (snd-display ";transform-framples ~A?" (transform-framples)))
(set! *transform-size* 512)
(set! (transform-graph?) #t)
(set! (time-graph?) #t)
- (if with-gui
- (catch #t
- (lambda ()
- (if (not (string=? (x-axis-label) "time"))
- (snd-display #__line__ ";def time x-axis-label: ~A" (x-axis-label)))
- (set! (x-axis-label index 0 time-graph) "no time")
- (if (not (string=? (x-axis-label) "no time"))
- (snd-display #__line__ ";time x-axis-label: ~A" (x-axis-label index 0 time-graph)))
-
- (update-transform-graph)
- (if (not (string=? (x-axis-label index 0 transform-graph) "frequency"))
- (snd-display #__line__ ";get fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
- (set! (x-axis-label index 0 transform-graph) "hiho")
- (update-transform-graph)
- (if (not (string=? (x-axis-label index 0 transform-graph) "hiho"))
- (snd-display #__line__ ";set fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
- (set! (x-axis-label index 0 transform-graph) "frequency") ; for later test
-
- (graph '(0 0 1 1 2 0) "lisp")
- (update-lisp-graph)
- (if (not (string=? (x-axis-label index 0 lisp-graph) "lisp"))
- (snd-display #__line__ ";def lisp x-axis-label: ~A" (x-axis-label index 0 lisp-graph)))
- (set! (x-axis-label index 0 lisp-graph) "no lisp")
- (if (not (string=? (x-axis-label index 0 lisp-graph) "no lisp"))
- (snd-display #__line__ ";lisp x-axis-label: ~A" (x-axis-label index 0 lisp-graph)))
-
- (set! (y-axis-label index 0 time-graph) "no amp")
- (if (not (string=? (y-axis-label) "no amp"))
- (snd-display #__line__ ";time y-axis-label: ~A" (y-axis-label index 0 time-graph)))
- (set! (y-axis-label index 0 lisp-graph) "no lamp")
- (if (not (string=? (y-axis-label index 0 lisp-graph) "no lamp"))
- (snd-display #__line__ ";lisp y-axis-label: ~A" (y-axis-label index 0 lisp-graph)))
- (set! (y-axis-label) #f)
- (set! (y-axis-label index 0) "no amp")
- (if (not (string=? (y-axis-label) "no amp"))
- (snd-display #__line__ ";time y-axis-label (time): ~A" (y-axis-label index 0 time-graph)))
- (set! (y-axis-label index) #f))
- (lambda args (snd-display #__line__ ";axis label error: ~A" args))))
-
- (if with-gui
- (begin
- (let ((cr (make-cairo (car (channel-widgets index 0)))))
- (graph-data (make-float-vector 4) index 0 copy-context #f #f graph-lines cr)
- (free-cairo cr)
- (update-lisp-graph))
- (graph (float-vector 0 0 1 1 2 0))
- (do ((i 0 (+ i 1)))
- ((= i 32))
- (graph (float-vector 0 1 2))
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3)))
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1))))
- (set! (x-bounds) (list 0.0 0.01))
- (let ((data (make-graph-data)))
- (if (float-vector? data)
- (let ((mid (round (* .5 (length data)))))
- (if (not (= (length data) (+ 1 (- (right-sample) (left-sample)))))
- (snd-display #__line__ ";make-graph-data bounds: ~A ~A -> ~A" (left-sample) (right-sample) (length data)))
- (if (fneq (data mid)
- (sample (+ (left-sample) mid)))
- (snd-display #__line__ ";make-graph-data[~D]: ~A ~A" mid (data mid) (sample (+ (left-sample) mid)))))))
- (let ((data (make-graph-data index 0 0 100 199)))
- (if (float-vector? data)
- (begin
- (if (not (= (length data) 100))
- (snd-display #__line__ ";make-graph-data 100:199: ~A" (length data)))
- (if (fneq (data 50) (sample 50))
- (snd-display #__line__ ";make-graph-data 50: ~A ~A" (data 50) (sample 50))))))
- (set! (x-bounds) (list 0.0 0.1))
+ (when with-gui
+ (catch #t
+ (lambda ()
+ (if (not (string=? (x-axis-label) "time"))
+ (snd-display ";def time x-axis-label: ~A" (x-axis-label)))
+ (set! (x-axis-label index 0 time-graph) "no time")
+ (if (not (string=? (x-axis-label) "no time"))
+ (snd-display ";time x-axis-label: ~A" (x-axis-label index 0 time-graph)))
+
(update-transform-graph)
- (catch 'no-such-axis
- (lambda ()
- (if (not (string=? (x-axis-label index 0 transform-graph) "frequency"))
- (snd-display #__line__ ";def fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
- (set! (x-axis-label index 0 transform-graph) "fourier")
- (if (not (string=? (x-axis-label index 0 transform-graph) "fourier"))
- (snd-display #__line__ ";fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
- (set! (x-axis-label) "hiho")
-
- (set! (y-axis-label index 0 transform-graph) "spectra")
- (let ((val (y-axis-label index 0 transform-graph)))
- (if (or (not (string? val))
- (not (string=? val "spectra")))
- (snd-display #__line__ ";fft y-axis-label: ~A" val)))
- (set! (y-axis-label) "hiho"))
- (lambda args (snd-display #__line__ ";transform axis not displayed?")))
- ))
-
+ (if (not (string=? (x-axis-label index 0 transform-graph) "frequency"))
+ (snd-display ";get fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
+ (set! (x-axis-label index 0 transform-graph) "hiho")
+ (update-transform-graph)
+ (if (not (string=? (x-axis-label index 0 transform-graph) "hiho"))
+ (snd-display ";set fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
+ (set! (x-axis-label index 0 transform-graph) "frequency") ; for later test
+
+ (graph '(0 0 1 1 2 0) "lisp")
+ (update-lisp-graph)
+ (if (not (string=? (x-axis-label index 0 lisp-graph) "lisp"))
+ (snd-display ";def lisp x-axis-label: ~A" (x-axis-label index 0 lisp-graph)))
+ (set! (x-axis-label index 0 lisp-graph) "no lisp")
+ (if (not (string=? (x-axis-label index 0 lisp-graph) "no lisp"))
+ (snd-display ";lisp x-axis-label: ~A" (x-axis-label index 0 lisp-graph)))
+
+ (set! (y-axis-label index 0 time-graph) "no amp")
+ (if (not (string=? (y-axis-label) "no amp"))
+ (snd-display ";time y-axis-label: ~A" (y-axis-label index 0 time-graph)))
+ (set! (y-axis-label index 0 lisp-graph) "no lamp")
+ (if (not (string=? (y-axis-label index 0 lisp-graph) "no lamp"))
+ (snd-display ";lisp y-axis-label: ~A" (y-axis-label index 0 lisp-graph)))
+ (set! (y-axis-label) #f)
+ (set! (y-axis-label index 0) "no amp")
+ (if (not (string=? (y-axis-label) "no amp"))
+ (snd-display ";time y-axis-label (time): ~A" (y-axis-label index 0 time-graph)))
+ (set! (y-axis-label index) #f))
+ (lambda args (snd-display ";axis label error: ~A" args)))
+
+ (let ((cr (make-cairo (car (channel-widgets index 0)))))
+ (graph-data (make-float-vector 4) index 0 copy-context #f #f graph-lines cr)
+ (free-cairo cr)
+ (update-lisp-graph))
+ (graph (float-vector 0 0 1 1 2 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 32))
+ (graph (float-vector 0 1 2))
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3)))
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1))))
+ (set! (x-bounds) (list 0.0 0.01))
+ (let ((data (make-graph-data)))
+ (if (float-vector? data)
+ (let ((mid (round (* .5 (length data)))))
+ (if (not (= (length data) (+ 1 (- (right-sample) (left-sample)))))
+ (snd-display ";make-graph-data bounds: ~A ~A -> ~A" (left-sample) (right-sample) (length data)))
+ (if (fneq (data mid)
+ (sample (+ (left-sample) mid)))
+ (snd-display ";make-graph-data[~D]: ~A ~A" mid (data mid) (sample (+ (left-sample) mid)))))))
+ (let ((data (make-graph-data index 0 0 100 199)))
+ (if (float-vector? data)
+ (begin
+ (if (not (= (length data) 100))
+ (snd-display ";make-graph-data 100:199: ~A" (length data)))
+ (if (fneq (data 50) (sample 50))
+ (snd-display ";make-graph-data 50: ~A ~A" (data 50) (sample 50))))))
+ (set! (x-bounds) (list 0.0 0.1))
+ (update-transform-graph)
+ (catch 'no-such-axis
+ (lambda ()
+ (if (not (string=? (x-axis-label index 0 transform-graph) "frequency"))
+ (snd-display ";def fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
+ (set! (x-axis-label index 0 transform-graph) "fourier")
+ (if (not (string=? (x-axis-label index 0 transform-graph) "fourier"))
+ (snd-display ";fft x-axis-label: ~A" (x-axis-label index 0 transform-graph)))
+ (set! (x-axis-label) "hiho")
+
+ (set! (y-axis-label index 0 transform-graph) "spectra")
+ (let ((val (y-axis-label index 0 transform-graph)))
+ (if (not (equal? val "spectra"))
+ (snd-display ";fft y-axis-label: ~A" val)))
+ (set! (y-axis-label) "hiho"))
+ (lambda args (snd-display ";transform axis not displayed?")))
+ )
+
(if (and (number? (transform-framples))
(= (transform-framples) 0))
- (snd-display #__line__ ";transform-graph? transform-framples ~A?" (transform-framples)))
+ (snd-display ";transform-graph? transform-framples ~A?" (transform-framples)))
(update-transform-graph)
(let ((tag (catch #t (lambda () (peaks "/baddy/hiho")) (lambda args (car args)))))
- (if (not (eq? tag 'cant-open-file)) (snd-display #__line__ ";peaks bad file: ~A" tag)))
+ (if (not (eq? tag 'cant-open-file)) (snd-display ";peaks bad file: ~A" tag)))
(peaks "tmp.peaks")
(let ((p (open-input-file "tmp.peaks")))
- (if (not p)
- (snd-display #__line__ ";peaks->tmp.peaks failed?")
- (let ((line (read-line p)))
- (if (or (not (string? line))
- (not (string=? "Snd: fft peaks" (substring line 0 14))))
- (snd-display #__line__ ";peaks 1: ~A?" line))
- (set! line (read-line p))
- (set! line (read-line p))
- (if (and (not (eof-object? line))
- (or (not (string? line))
- (and (not (string=? "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2" line))
- (not (string=? (string-append "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2" (string #\newline)) line)))))
- (snd-display #__line__ ";peaks 2: ~A?" line))
- (set! line (read-line p))
- (set! line (read-line p))
- (close-input-port p))))
+ (let ((line (read-line p)))
+ (if (not (string=? "Snd: fft peaks" (substring line 0 14)))
+ (snd-display ";peaks 1: ~A?" line))
+ (set! line (read-line p))
+ (set! line (read-line p))
+ (if (not (member line '(#<eof> "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2"
+ "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2\n")))
+ (snd-display ";peaks 2: ~A?" line))
+ (close-input-port p)))
(delete-file "tmp.peaks")
(peaks)
(if (and (provided? 'xm)
- (or (not ((dialog-widgets) 15))
- (not ((*motif* 'XtIsManaged) ((dialog-widgets) 15)))))
- (snd-display #__line__ ";peaks but no help?"))
+ (not (and ((dialog-widgets) 15)
+ ((*motif* 'XtIsManaged) ((dialog-widgets) 15)))))
+ (snd-display ";peaks but no help?"))
(dismiss-all-dialogs)
(let ((num-transforms 6)
(num-transform-graph-types 3))
@@ -5820,214 +5495,212 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((= i num-transforms))
(set! *transform-type* (integer->transform i))
- (if (not (transform? (integer->transform i))) (snd-display #__line__ ";transform? ~A?" i))
+ (if (not (transform? (integer->transform i))) (snd-display ";transform? ~A?" i))
(do ((j 0 (+ j 1)))
((= j num-transform-graph-types))
(set! (transform-graph-type index 0) j)
(update-transform-graph index 0))))
(set! *transform-type* fourier-transform)
- (if (not (transform? *transform-type*)) (snd-display #__line__ ";transform? ~A ~A?" *transform-type* fourier-transform))
- (if (not (transform? autocorrelation)) (snd-display #__line__ ";transform? autocorrelation"))
+ (if (not (transform? *transform-type*)) (snd-display ";transform? ~A ~A?" *transform-type* fourier-transform))
+ (if (not (transform? autocorrelation)) (snd-display ";transform? autocorrelation"))
- (if (read-only index) (snd-display #__line__ ";read-only open-sound: ~A?" (read-only index)))
+ (if (read-only index) (snd-display ";read-only open-sound: ~A?" (read-only index)))
(set! (read-only index) #t)
- (if (not (read-only index)) (snd-display #__line__ ";set-read-only: ~A?" (read-only index)))
+ (if (not (read-only index)) (snd-display ";set-read-only: ~A?" (read-only index)))
(bind-key #\a 0 (lambda () (set! a-ctr 3)))
(key (char->integer #\a) 0)
- (if (not (= a-ctr 3)) (snd-display #__line__ ";bind-key: ~A?" a-ctr))
+ (if (not (= a-ctr 3)) (snd-display ";bind-key: ~A?" a-ctr))
(let ((str (with-output-to-string (lambda () (display (procedure-source (key-binding (char->integer #\a) 0)))))))
(if (not (string=? str "(lambda () (set! a-ctr 3))"))
- (snd-display #__line__ ";key-binding: ~A?" str)))
+ (snd-display ";key-binding: ~A?" str)))
(unbind-key (char->integer #\a) 0)
(set! a-ctr 0)
(key (char->integer #\a) 0)
(do ((i 0 (+ i 1)))
((= i 5))
(let ((psf *eps-file*))
- (if (and psf (string? psf))
+ (if (string? psf)
(begin
(if (file-exists? psf) (delete-file psf))
(set! *graph-style* i)
(graph->ps)
- (if (not (file-exists? psf))
- (snd-display #__line__ ";graph->ps: ~A?" psf)
- (delete-file psf))))))
+ (if (file-exists? psf)
+ (delete-file psf)
+ (snd-display ";graph->ps: ~A?" psf))))))
(let ((err (catch 'cannot-print
(lambda ()
(graph->ps "/bad/bad.eps"))
(lambda args 12345))))
- (if (not (= err 12345)) (snd-display #__line__ ";graph->ps err: ~A?" err)))
+ (if (not (= err 12345)) (snd-display ";graph->ps err: ~A?" err)))
(when with-gui
(let ((n2 (or (open-sound "2.snd") (open-sound "4.aiff"))))
(set! (transform-graph? n2) #t)
(set! (channel-style n2) channels-superimposed)
- (if (not (= (channel-style n2) channels-superimposed)) (snd-display #__line__ ";channel-style->~D: ~A?" channels-superimposed (channel-style n2)))
+ (if (not (= (channel-style n2) channels-superimposed)) (snd-display ";channel-style->~D: ~A?" channels-superimposed (channel-style n2)))
(graph->ps "aaa.eps")
(set! (channel-style n2) channels-combined)
- (if (not (= (channel-style n2) channels-combined)) (snd-display #__line__ ";channel-style->~D: ~A?" channels-combined (channel-style n2)))
+ (if (not (= (channel-style n2) channels-combined)) (snd-display ";channel-style->~D: ~A?" channels-combined (channel-style n2)))
(graph->ps "aaa.eps")
(set! (channel-style n2) channels-separate)
- (if (not (= (channel-style n2) channels-separate)) (snd-display #__line__ ";channel-style->~D: ~A?" channels-separate (channel-style n2)))
+ (if (not (= (channel-style n2) channels-separate)) (snd-display ";channel-style->~D: ~A?" channels-separate (channel-style n2)))
(graph->ps "aaa.eps")
(close-sound n2)))
(if (= (channels index) 1)
(begin
(set! (channel-style index) channels-superimposed)
- (if (not (= (channel-style index) channels-separate)) (snd-display #__line__ ";channel-style[0]->~D: ~A?" channels-separate (channel-style index)))))
+ (if (not (= (channel-style index) channels-separate)) (snd-display ";channel-style[0]->~D: ~A?" channels-separate (channel-style index)))))
(set! (sync index) 32)
- (if (not (= (sync index) 32)) (snd-display #__line__ ";sync->32: ~A?" (sync index)))
- (if (< (sync-max) 32) (snd-display #__line__ ";sync-max 32: ~A" (sync-max)))
+ (if (not (= (sync index) 32)) (snd-display ";sync->32: ~A?" (sync index)))
+ (if (< (sync-max) 32) (snd-display ";sync-max 32: ~A" (sync-max)))
(set! (sync index) 0)
(set! (channel-sync index 0) 12)
- (if (not (= (channel-sync index 0) 12)) (snd-display #__line__ ";sync-chn->12: ~A?" (channel-sync index 0)))
+ (if (not (= (channel-sync index 0) 12)) (snd-display ";sync-chn->12: ~A?" (channel-sync index 0)))
(set! (channel-sync index 0) 0)
- (if (not (= a-ctr 0)) (snd-display #__line__ ";unbind-key: ~A?" a-ctr))
- (if (fneq xp 0.0) (snd-display #__line__ ";x-position-slider: ~A?" xp))
- (if (fneq yp 0.0) (snd-display #__line__ ";y-position-slider: ~A?" yp))
- (if (and (fneq xz 0.04338) (fneq xz 1.0)) (snd-display #__line__ ";x-zoom-slider: ~A?" xz))
- (if (fneq yz 1.0) (snd-display #__line__ ";y-zoom-slider: ~A?" yz))
- (if (and (or (fneq (car bnds) 0.0) (fneq (cadr bnds) 0.1))
- (or (fneq (car bnds) 0.0) (fneq (cadr bnds) 2.305))) ; open-hook from ~/.snd*
- (snd-display #__line__ ";x-bounds: ~A?" bnds))
- (if (not (equal? (find-sound "oboe.snd") index)) (snd-display #__line__ ";oboe: index ~D is not ~D?" (find-sound "oboe.snd") index))
- (if (not (sound? index)) (snd-display #__line__ ";oboe: ~D not ok?" index))
- (if (not (= (chans index) 1)) (snd-display #__line__ ";oboe: chans ~D?" (chans index)))
- (if (not (= (channels index) 1)) (snd-display #__line__ ";oboe: channels ~D?" (channels index)))
- (if (not (= (framples index) 50828)) (snd-display #__line__ ";oboe: framples ~D?" (framples index)))
- (if (not (= (srate index) 22050)) (snd-display #__line__ ";oboe: srate ~D?" (srate index)))
- (if (not (= (data-location index) 28)) (snd-display #__line__ ";oboe: location ~D?" (data-location index)))
- (if (not (= (data-size index) (* 50828 2))) (snd-display #__line__ ";oboe: size ~D?" (data-size index)))
- (if (not (= (sample-type index) mus-bshort)) (snd-display #__line__ ";oboe: format ~A?" (sample-type index)))
- (if (fneq (maxamp index) .14724) (snd-display #__line__ ";oboe: maxamp ~F?" (maxamp index)))
- (if (not (= (maxamp-position index) 24971)) (snd-display #__line__ ";oboe: maxamp-position ~A?" (maxamp-position index)))
- (if (> (length (comment index)) 0) (snd-display #__line__ ";oboe: comment ~A?" (comment index)))
- (if (not (= (length "asdf") 4)) (snd-display #__line__ ";string-length: ~A?" (length "asdf")))
- (if (not (string=? (short-file-name index) "oboe.snd")) (snd-display #__line__ ";oboe short name: ~S?" (short-file-name index)))
+ (if (not (= a-ctr 0)) (snd-display ";unbind-key: ~A?" a-ctr))
+ (if (fneq xp 0.0) (snd-display ";x-position-slider: ~A?" xp))
+ (if (fneq yp 0.0) (snd-display ";y-position-slider: ~A?" yp))
+ (if (and (fneq xz 0.04338) (fneq xz 1.0)) (snd-display ";x-zoom-slider: ~A?" xz))
+ (if (fneq yz 1.0) (snd-display ";y-zoom-slider: ~A?" yz))
+ (if (or (fneq (car bnds) 0.0) (and (fneq (cadr bnds) 0.1) (fneq (cadr bnds) 2.305)))
+ (snd-display ";x-bounds: ~A?" bnds))
+ (if (not (equal? (find-sound "oboe.snd") index)) (snd-display ";oboe: index ~D is not ~D?" (find-sound "oboe.snd") index))
+ (if (not (sound? index)) (snd-display ";oboe: ~D not ok?" index))
+ (if (not (= (chans index) 1)) (snd-display ";oboe: chans ~D?" (chans index)))
+ (if (not (= (channels index) 1)) (snd-display ";oboe: channels ~D?" (channels index)))
+ (if (not (= (framples index) 50828)) (snd-display ";oboe: framples ~D?" (framples index)))
+ (if (not (= (srate index) 22050)) (snd-display ";oboe: srate ~D?" (srate index)))
+ (if (not (= (data-location index) 28)) (snd-display ";oboe: location ~D?" (data-location index)))
+ (if (not (= (data-size index) 101656)) (snd-display ";oboe: size ~D?" (data-size index)))
+ (if (not (= (sample-type index) mus-bshort)) (snd-display ";oboe: format ~A?" (sample-type index)))
+ (if (fneq (maxamp index) .14724) (snd-display ";oboe: maxamp ~F?" (maxamp index)))
+ (if (not (= (maxamp-position index) 24971)) (snd-display ";oboe: maxamp-position ~A?" (maxamp-position index)))
+ (if (> (length (comment index)) 0) (snd-display ";oboe: comment ~A?" (comment index)))
+ (if (not (string=? (short-file-name index) "oboe.snd")) (snd-display ";oboe short name: ~S?" (short-file-name index)))
(let ((matches (count-matches (lambda (a) (> a .125)))))
- (if (not (= matches 1313)) (snd-display #__line__ ";count-matches: ~A?" matches)))
+ (if (not (= matches 1313)) (snd-display ";count-matches: ~A?" matches)))
(let ((spot (scan-channel (lambda (a) (> a .13)))))
- (if (or (not spot) (not (= spot 8862))) (snd-display #__line__ ";find: ~A?" spot)))
+ (if (not (eqv? spot 8862)) (snd-display ";find: ~A?" spot)))
(set! (right-sample) 3000)
(let ((samp (right-sample)))
- (if (> (abs (- samp 3000)) 1) (snd-display #__line__ ";right-sample: ~A?" samp)))
+ (if (> (abs (- samp 3000)) 1) (snd-display ";right-sample: ~A?" samp)))
(set! (left-sample) 1000)
(let ((samp (left-sample)))
- (if (> (abs (- samp 1000)) 1) (snd-display #__line__ ";left-sample: ~A?" samp)))
+ (if (> (abs (- samp 1000)) 1) (snd-display ";left-sample: ~A?" samp)))
(let ((eds (edits)))
(if (not (= (car eds) 0 (cadr eds)))
- (snd-display #__line__ ";edits: ~A?" eds))
+ (snd-display ";edits: ~A?" eds))
(if (not (= (edit-position) (car eds)))
- (snd-display #__line__ ";edit-position: ~A ~A?" (edit-position) eds)))
+ (snd-display ";edit-position: ~A ~A?" (edit-position) eds)))
(play index :channel 0 :wait #t)
(if (not *selection-creates-region*) (set! *selection-creates-region* #t))
(select-all index 0)
(let ((r0 (car (regions)))
(sel (selection)))
- (if (not (selection?)) (snd-display #__line__ ";selection?"))
- (if (not (selection? sel)) (snd-display #__line__ ";selection? sel"))
- (if (not (region? r0)) (snd-display #__line__ ";region?"))
- (if (not (= (selection-chans) 1)) (snd-display #__line__ ";selection-chans(1): ~A" (selection-chans)))
- (if (not (= (channels sel) 1)) (snd-display #__line__ ";generic selection-chans(1): ~A" (channels sel)))
- (if (not (= (selection-srate) (srate index))) (snd-display #__line__ ";selection-srate: ~A ~A" (selection-srate) (srate index)))
- (if (not (= (srate sel) (srate index))) (snd-display #__line__ ";generic selection-srate: ~A ~A" (srate sel) (srate index)))
- (if (fneq (region-maxamp r0) (maxamp index)) (snd-display #__line__ ";region-maxamp (1): ~A?" (region-maxamp r0)))
+ (if (not (selection?)) (snd-display ";selection?"))
+ (if (not (selection? sel)) (snd-display ";selection? sel"))
+ (if (not (region? r0)) (snd-display ";region?"))
+ (if (not (= (selection-chans) 1)) (snd-display ";selection-chans(1): ~A" (selection-chans)))
+ (if (not (= (channels sel) 1)) (snd-display ";generic selection-chans(1): ~A" (channels sel)))
+ (if (not (= (selection-srate) (srate index))) (snd-display ";selection-srate: ~A ~A" (selection-srate) (srate index)))
+ (if (not (= (srate sel) (srate index))) (snd-display ";generic selection-srate: ~A ~A" (srate sel) (srate index)))
+ (if (fneq (region-maxamp r0) (maxamp index)) (snd-display ";region-maxamp (1): ~A?" (region-maxamp r0)))
(if (not (= (region-maxamp-position r0) (maxamp-position index)))
- (snd-display #__line__ ";region-maxamp-position (1): ~A ~A?" (region-maxamp-position r0) (maxamp-position index)))
- (if (fneq (selection-maxamp index 0) (maxamp index)) (snd-display #__line__ ";selection-maxamp (1): ~A?" (selection-maxamp index 0)))
- (if (fneq (maxamp sel index 0) (maxamp index)) (snd-display #__line__ ";generic selection-maxamp (1): ~A?" (maxamp sel index 0)))
+ (snd-display ";region-maxamp-position (1): ~A ~A?" (region-maxamp-position r0) (maxamp-position index)))
+ (if (fneq (selection-maxamp index 0) (maxamp index)) (snd-display ";selection-maxamp (1): ~A?" (selection-maxamp index 0)))
+ (if (fneq (maxamp sel index 0) (maxamp index)) (snd-display ";generic selection-maxamp (1): ~A?" (maxamp sel index 0)))
(if (not (= (selection-maxamp-position index 0) (maxamp-position index)))
- (snd-display #__line__ ";selection-maxamp-position (1): ~A ~A?" (selection-maxamp-position index 0) (maxamp-position index)))
+ (snd-display ";selection-maxamp-position (1): ~A ~A?" (selection-maxamp-position index 0) (maxamp-position index)))
(save-region r0 "temp.dat")
(if (file-exists? "temp.dat")
(delete-file "temp.dat")
- (snd-display #__line__ ";save-region file disappeared?"))
+ (snd-display ";save-region file disappeared?"))
(play r0 :wait #t) ;needs to be #t here or it never gets run
- (if (not (= (length (regions)) 1)) (snd-display #__line__ ";regions: ~A?" (regions)))
- (if (not (selection-member? index)) (snd-display #__line__ ";selection-member?: ~A" (selection-member? index)))
- (if (not (= (region-srate r0) 22050)) (snd-display #__line__ ";region-srate: ~A?" (region-srate r0)))
- (if (not (= (region-chans r0) 1)) (snd-display #__line__ ";region-chans: ~A?" (region-chans r0)))
- (if (not (equal? (region-home r0) (list "oboe.snd" 0 50827))) (snd-display #__line__ ";region-home: ~A" (region-home r0)))
- (if (not (= (region-framples r0) 50828)) (snd-display #__line__ ";region-framples: ~A?" (region-framples r0)))
- (if (not (= (selection-framples) 50828)) (snd-display #__line__ ";selection-framples: ~A?" (selection-framples 0)))
- (if (not (= (framples sel) 50828)) (snd-display #__line__ ";generic selection-framples: ~A?" (framples sel)))
- (if (not (= (length sel) 50828)) (snd-display #__line__ ";generic length selection-framples: ~A?" (length sel)))
- (if (not (= (selection-position) 0)) (snd-display #__line__ ";selection-position: ~A?" (selection-position)))
- (if (not (= (region-position r0 0) 0)) (snd-display #__line__ ";region-position: ~A?" (region-position r0 0)))
- (if (fneq (region-maxamp r0) (maxamp index)) (snd-display #__line__ ";region-maxamp: ~A?" (region-maxamp r0)))
- (if (fneq (selection-maxamp index 0) (maxamp index)) (snd-display #__line__ ";selection-maxamp: ~A?" (selection-maxamp index 0)))
+ (if (not (= (length (regions)) 1)) (snd-display ";regions: ~A?" (regions)))
+ (if (not (selection-member? index)) (snd-display ";selection-member?: ~A" (selection-member? index)))
+ (if (not (= (region-srate r0) 22050)) (snd-display ";region-srate: ~A?" (region-srate r0)))
+ (if (not (= (region-chans r0) 1)) (snd-display ";region-chans: ~A?" (region-chans r0)))
+ (if (not (equal? (region-home r0) (list "oboe.snd" 0 50827))) (snd-display ";region-home: ~A" (region-home r0)))
+ (if (not (= (region-framples r0) 50828)) (snd-display ";region-framples: ~A?" (region-framples r0)))
+ (if (not (= (selection-framples) 50828)) (snd-display ";selection-framples: ~A?" (selection-framples 0)))
+ (if (not (= (framples sel) 50828)) (snd-display ";generic selection-framples: ~A?" (framples sel)))
+ (if (not (= (length sel) 50828)) (snd-display ";generic length selection-framples: ~A?" (length sel)))
+ (if (not (= (selection-position) 0)) (snd-display ";selection-position: ~A?" (selection-position)))
+ (if (not (= (region-position r0 0) 0)) (snd-display ";region-position: ~A?" (region-position r0 0)))
+ (if (fneq (region-maxamp r0) (maxamp index)) (snd-display ";region-maxamp: ~A?" (region-maxamp r0)))
+ (if (fneq (selection-maxamp index 0) (maxamp index)) (snd-display ";selection-maxamp: ~A?" (selection-maxamp index 0)))
(let ((samps1 (channel->float-vector 0 50827 index 0))
(samps2 (region->float-vector r0 0 50828 0))
(vr (make-sampler 0 index 0 1)))
- (if (not (sampler? vr)) (snd-display #__line__ ";~A not sampler?" vr))
- (if (not (= (sampler-position vr) 0)) (snd-display #__line__ ";initial sampler-position: ~A" (sampler-position vr)))
+ (if (not (sampler? vr)) (snd-display ";~A not sampler?" vr))
+ (if (not (= (sampler-position vr) 0)) (snd-display ";initial sampler-position: ~A" (sampler-position vr)))
(if (not (equal? (sampler-home vr) (list index 0)))
- (snd-display #__line__ ";sampler-home: ~A ~A?" (sampler-home vr) (list index 0)))
- (if (sampler-at-end? vr) (snd-display #__line__ ";~A init at end?" vr))
+ (snd-display ";sampler-home: ~A ~A?" (sampler-home vr) (list index 0)))
+ (if (sampler-at-end? vr) (snd-display ";~A init at end?" vr))
(let ((err (catch #t
(lambda ()
(region->float-vector r0 -1 1233))
(lambda args (car args)))))
- (if (not (eq? err 'no-such-sample)) (snd-display #__line__ ";region->float-vector -1: ~A" err)))
+ (if (not (eq? err 'no-such-sample)) (snd-display ";region->float-vector -1: ~A" err)))
(let ((err (catch #t
(lambda ()
(region->float-vector r0 12345678 1))
(lambda args (car args)))))
;; should this return 'no-such-sample?
- (if err (snd-display #__line__ ";region->float-vector 12345678: ~A" err)))
+ (if err (snd-display ";region->float-vector 12345678: ~A" err)))
(let ((reader-string (format #f "~A" vr)))
(if (not (string=? reader-string "#<sampler: oboe.snd[0: 0] from 0, at 0, forward>"))
- (snd-display #__line__ ";sampler actually got: [~S]" reader-string)))
+ (snd-display ";sampler actually got: [~S]" reader-string)))
(let ((evr vr))
- (if (not (equal? evr vr)) (snd-display #__line__ ";sampler equal? ~A ~A" vr evr)))
+ (if (not (equal? evr vr)) (snd-display ";sampler equal? ~A ~A" vr evr)))
(catch 'break
(lambda ()
(do ((i 0 (+ i 1)))
((= i 50827))
(if (not (= (if (odd? i) (next-sample vr) (read-sample vr)) (samps1 i) (samps2 i)))
(begin
- (snd-display #__line__ ";readers disagree at ~D" i)
+ (snd-display ";readers disagree at ~D" i)
(throw 'break)))))
(lambda args (car args)))
(free-sampler vr)))
(let ((var (catch #t (lambda () (make-sampler 0 index -1)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";make-sampler bad chan (-1): ~A" var)))
+ (snd-display ";make-sampler bad chan (-1): ~A" var)))
(let ((var (catch #t (lambda () (make-sampler 0 index 1)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";make-sampler bad chan (1): ~A, ~A" var index)))
+ (snd-display ";make-sampler bad chan (1): ~A, ~A" var index)))
(let ((fd (make-sampler 0)))
- (if (mix-sampler? fd) (snd-display #__line__ ";sampler: mix ~A" fd))
- (if (region-sampler? fd) (snd-display #__line__ ";sampler: region ~A" fd))
- (if (not (sampler? fd)) (snd-display #__line__ ";sampler: normal ~A" fd))
- (if (not (= (sampler-position fd) 0)) (snd-display #__line__ ";sampler: position: ~A" fd))
+ (if (mix-sampler? fd) (snd-display ";sampler: mix ~A" fd))
+ (if (region-sampler? fd) (snd-display ";sampler: region ~A" fd))
+ (if (not (sampler? fd)) (snd-display ";sampler: normal ~A" fd))
+ (if (not (= (sampler-position fd) 0)) (snd-display ";sampler: position: ~A" fd))
(free-sampler fd)
(let ((str (format #f "~A" fd)))
(if (not (string=? (substring str (- (length str) 16)) "at eof or freed>"))
- (snd-display #__line__ ";freed sampler: ~A [~A]?" str (substring str (- (length str) 16))))))
+ (snd-display ";freed sampler: ~A [~A]?" str (substring str (- (length str) 16))))))
(let* ((reg (car (regions)))
(chns (region-chans reg))
(var (catch #t (lambda () (make-region-sampler reg 0 (+ chns 1))) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";make-region-sampler bad chan (2): ~A ~A" var (regions)))
+ (snd-display ";make-region-sampler bad chan (2): ~A ~A" var (regions)))
(let ((tag (catch #t (lambda () (make-region-sampler reg 0 0 -2)) (lambda args args))))
(if (not (eq? (car tag) 'no-such-direction))
- (snd-display #__line__ ";make-region-sampler bad dir (-2): ~A" tag))))
+ (snd-display ";make-region-sampler bad dir (-2): ~A" tag))))
(revert-sound index)
(insert-sample 100 .5 index)
(let ((var (catch #t (lambda () (insert-sound "oboe.snd" 0 1)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";insert-sound bad chan (1): ~A" var)))
+ (snd-display ";insert-sound bad chan (1): ~A" var)))
(let ((var (catch #t (lambda () (insert-sample -12 1.0)) (lambda args args))))
(if (not (eq? (car var) 'no-such-sample))
- (snd-display #__line__ ";insert-sample bad pos: ~A" var)))
+ (snd-display ";insert-sample bad pos: ~A" var)))
(set! (show-axes index 0) show-no-axes)
(update-transform-graph index)
(update-time-graph index)
(if (or (fneq (sample 100) .5)
(not (= (framples index) 50829)))
- (snd-display #__line__ ";insert-sample: ~A ~A?" (sample 100) (framples index)))
+ (snd-display ";insert-sample: ~A ~A?" (sample 100) (framples index)))
(let ((v0 (make-vector 3))
(v1 (make-float-vector 3)))
(fill! v1 .75)
@@ -6037,114 +5710,114 @@ EDITS: 5
(if (or (fneq (sample 201) .25)
(fneq (sample 301) .75)
(not (= (framples index) 50835)))
- (snd-display #__line__ ";insert-samples: ~A ~A ~A?" (sample 201) (sample 301) (framples index))))
+ (snd-display ";insert-samples: ~A ~A ~A?" (sample 201) (sample 301) (framples index))))
(save-sound-as "hiho.snd" index 22050 mus-ldouble mus-next)
(let ((nindex (view-sound "hiho.snd")))
(if (fneq (sample 101 nindex) (sample 101 index))
- (snd-display #__line__ ";save-sound-as: ~A ~A?" (sample 101 nindex) (sample 101 index)))
- (if (not (read-only nindex)) (snd-display #__line__ ";read-only view-sound: ~A?" (read-only nindex)))
+ (snd-display ";save-sound-as: ~A ~A?" (sample 101 nindex) (sample 101 index)))
+ (if (not (read-only nindex)) (snd-display ";read-only view-sound: ~A?" (read-only nindex)))
(set! (speed-control-style nindex) speed-control-as-semitone)
(if (not (= (speed-control-style nindex) speed-control-as-semitone))
- (snd-display #__line__ ";speed-control-style set semi: ~A" (speed-control-style nindex)))
+ (snd-display ";speed-control-style set semi: ~A" (speed-control-style nindex)))
(set! (speed-control-tones nindex) -8)
(if (not (= (speed-control-tones nindex) 12))
- (snd-display #__line__ ";speed-control-tones -8: ~A" (speed-control-tones nindex)))
+ (snd-display ";speed-control-tones -8: ~A" (speed-control-tones nindex)))
(set! (speed-control-tones nindex) 18)
(if (not (= (speed-control-tones nindex) 18))
- (snd-display #__line__ ";speed-control-tones 18: ~A" (speed-control-tones nindex)))
+ (snd-display ";speed-control-tones 18: ~A" (speed-control-tones nindex)))
(graph->ps "aaa.eps")
(close-sound nindex))
(revert-sound index)
(set! (sample 50 index) .5)
- (if (fneq (sample 50) .5) (snd-display #__line__ ";set-sample: ~A?" (sample 50)))
+ (if (fneq (sample 50) .5) (snd-display ";set-sample: ~A?" (sample 50)))
(let ((v0 (make-vector 3 0.25)))
(set! (samples 60 3 index) v0)
(if (or (fneq (sample 60) .25) (fneq (sample 61) .25))
- (snd-display #__line__ ";set-samples: ~A ~A ~A?" (sample 60) (sample 61) (sample 62))))
+ (snd-display ";set-samples: ~A ~A ~A?" (sample 60) (sample 61) (sample 62))))
(set! (samples 10 3 index) (list 0.1 0.2 0.3))
(if (not (vequal (channel->float-vector 10 3 index) (float-vector 0.1 0.2 0.3)))
- (snd-display #__line__ ";set-samples via list: ~A" (channel->float-vector 10 3 index)))
+ (snd-display ";set-samples via list: ~A" (channel->float-vector 10 3 index)))
(revert-sound index)
(save-sound-as "temporary.snd" index)
(set! (samples 100000 20000 index) "temporary.snd")
(if (not (vequal (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
- (snd-display #__line__ ";set samples to self: ~A ~A" (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
+ (snd-display ";set samples to self: ~A ~A" (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
(revert-sound index)
(delete-sample 100 index)
(if (not (file-exists? "temporary.snd"))
- (snd-display #__line__ ";set-samples temp deleted?"))
+ (snd-display ";set-samples temp deleted?"))
(delete-file "temporary.snd")
- (if (not (= (framples index) 50827)) (snd-display #__line__ ";delete-sample: ~A?" (framples index)))
+ (if (not (= (framples index) 50827)) (snd-display ";delete-sample: ~A?" (framples index)))
(delete-samples 0 100 index)
- (if (not (= (framples index) 50727)) (snd-display #__line__ ";delete-samples: ~A?" (framples index)))
+ (if (not (= (framples index) 50727)) (snd-display ";delete-samples: ~A?" (framples index)))
(revert-sound index)
(let ((maxa (maxamp index)))
(scale-to .5 index)
(let ((newmaxa (maxamp index)))
- (if (fneq newmaxa .5) (snd-display #__line__ ";scale-to: ~A?" newmaxa))
+ (if (fneq newmaxa .5) (snd-display ";scale-to: ~A?" newmaxa))
(undo 1 index)
(scale-by 2.0 index)
(set! newmaxa (maxamp index))
- (if (fneq newmaxa (* 2.0 maxa)) (snd-display #__line__ ";scale-by: ~A?" newmaxa))
+ (if (fneq newmaxa (* 2.0 maxa)) (snd-display ";scale-by: ~A?" newmaxa))
(revert-sound index)
(scale-by -1 index)
(mix "oboe.snd")
- (if (fneq (maxamp index 0) 0.0) (snd-display #__line__ ";invert+mix->~A" (maxamp)))
+ (if (fneq (maxamp index 0) 0.0) (snd-display ";invert+mix->~A" (maxamp)))
(revert-sound index)
(select-all index)
- (if (not (= (length (regions)) 2)) (snd-display #__line__ ";regions(2): ~A?" (regions)))
+ (if (not (= (length (regions)) 2)) (snd-display ";regions(2): ~A?" (regions)))
(scale-selection-to .5)
(set! newmaxa (maxamp index))
- (if (fneq newmaxa .5) (snd-display #__line__ ";scale-selection-to: ~A?" newmaxa))
+ (if (fneq newmaxa .5) (snd-display ";scale-selection-to: ~A?" newmaxa))
(revert-sound index)
(select-all index)
(scale-selection-by 2.0)
(set! newmaxa (maxamp index))
- (if (fneq newmaxa (* 2.0 maxa)) (snd-display #__line__ ";scale-selection-by: ~A?" newmaxa))
+ (if (fneq newmaxa (* 2.0 maxa)) (snd-display ";scale-selection-by: ~A?" newmaxa))
(revert-sound index)
(with-temporary-selection (lambda () (scale-selection-by 2.0)) 0 (framples) index 0)
(set! newmaxa (maxamp index))
- (if (fneq newmaxa (* 2.0 maxa)) (snd-display #__line__ ";with-temporary-selection: ~A?" newmaxa))
+ (if (fneq newmaxa (* 2.0 maxa)) (snd-display ";with-temporary-selection: ~A?" newmaxa))
(revert-sound index)
(let ((samp999 (sample 999 index 0))
(samp1001 (sample 1001 index 0)))
(with-temporary-selection (lambda () (scale-selection-to 2.0)) 1000 1 index 0)
- (if (fneq (sample 1000 index 0) 2.0) (snd-display #__line__ ";with-temporary-selection 1000: ~A" (sample 1000 index 0)))
- (if (fneq (sample 999 index 0) samp999) (snd-display #__line__ ";with-temporary-selection 999: ~A from ~A" (sample 999 index 0) samp999))
- (if (fneq (sample 1001 index 0) samp1001) (snd-display #__line__ ";with-temporary-selection 1001: ~A from ~A" (sample 1001 index 0) samp1001)))
+ (if (fneq (sample 1000 index 0) 2.0) (snd-display ";with-temporary-selection 1000: ~A" (sample 1000 index 0)))
+ (if (fneq (sample 999 index 0) samp999) (snd-display ";with-temporary-selection 999: ~A from ~A" (sample 999 index 0) samp999))
+ (if (fneq (sample 1001 index 0) samp1001) (snd-display ";with-temporary-selection 1001: ~A from ~A" (sample 1001 index 0) samp1001)))
(revert-sound index)
(make-selection 100 199 index 0)
(let ((old-start (selection-position index 0))
(old-len (selection-framples index 0)))
(with-temporary-selection (lambda () (scale-selection-to 2.0)) 1000 1 index 0)
- (if (not (selection?)) (snd-display #__line__ ";with-temporary-selection restore?"))
- (if (not (selection-member? index 0)) (snd-display #__line__ ";with-temporary-selection not member?"))
- (if (not (= (selection-position index 0) old-start)) (snd-display #__line__ ";with-temporary-selection start: ~A" (selection-position index 0)))
- (if (not (= (selection-framples index 0) old-len)) (snd-display #__line__ ";with-temporary-selection len: ~A" (selection-framples index 0))))
+ (if (not (selection?)) (snd-display ";with-temporary-selection restore?"))
+ (if (not (selection-member? index 0)) (snd-display ";with-temporary-selection not member?"))
+ (if (not (= (selection-position index 0) old-start)) (snd-display ";with-temporary-selection start: ~A" (selection-position index 0)))
+ (if (not (= (selection-framples index 0) old-len)) (snd-display ";with-temporary-selection len: ~A" (selection-framples index 0))))
(unselect-all)
- (if (selection-member? index 0) (snd-display #__line__ ";unselect all ~D 0?" index))
+ (if (selection-member? index 0) (snd-display ";unselect all ~D 0?" index))
(revert-sound index)
(select-all index)
(let ((rread (make-region-sampler (car (regions)) 0))
- (sread (make-sampler 0 index))
- (rvect (region->float-vector (car (regions)) 0 100))
- (svect (samples 0 100 index)))
- (if (fneq (rvect 1) (region-sample (car (regions)) 1))
- (snd-display #__line__ ";region-sample: ~A ~A?" (region-sample (car (regions)) 1) (rvect 1)))
- (do ((i 0 (+ i 1)))
- ((= i 100))
- (let ((rval (next-sample rread))
- (sval (next-sample sread)))
- (if (fneq rval sval) (snd-display #__line__ ";sample-read: ~A ~A?" rval sval))
- (if (fneq rval (rvect i)) (snd-display #__line__ ";region-samples: ~A ~A?" rval (rvect i)))
- (if (fneq sval (svect i)) (snd-display #__line__ ";samples: ~A ~A?" sval (svect i)))))
+ (sread (make-sampler 0 index)))
+ (let ((rvect (region->float-vector (car (regions)) 0 100))
+ (svect (samples 0 100 index)))
+ (if (fneq (rvect 1) (region-sample (car (regions)) 1))
+ (snd-display ";region-sample: ~A ~A?" (region-sample (car (regions)) 1) (rvect 1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 100))
+ (let ((rval (next-sample rread))
+ (sval (next-sample sread)))
+ (if (fneq rval sval) (snd-display ";sample-read: ~A ~A?" rval sval))
+ (if (fneq rval (rvect i)) (snd-display ";region-samples: ~A ~A?" rval (rvect i)))
+ (if (fneq sval (svect i)) (snd-display ";samples: ~A ~A?" sval (svect i))))))
(free-sampler rread)
(let ((val0 (next-sample sread)))
- (if (sampler-at-end? sread) (snd-display #__line__ ";premature end?"))
+ (if (sampler-at-end? sread) (snd-display ";premature end?"))
(previous-sample sread)
(let ((val1 (previous-sample sread)))
- (if (fneq val0 val1) (snd-display #__line__ ";previous-sample: ~A ~A?" val0 val1))))
+ (if (fneq val0 val1) (snd-display ";previous-sample: ~A ~A?" val0 val1))))
(free-sampler sread))))
(revert-sound index)
(let ((s100 (sample 100))
@@ -6155,9 +5828,9 @@ EDITS: 5
(set! *cursor-size* 25)
(set! (cursor index) 50)
(if (not (= *cursor-style* cursor-line))
- (snd-display #__line__ ";cursor-style: ~A? " *cursor-style*))
+ (snd-display ";cursor-style: ~A? " *cursor-style*))
(if (not (= *cursor-size* 25))
- (snd-display #__line__ ";cursor-size: ~A? " *cursor-size*))
+ (snd-display ";cursor-size: ~A? " *cursor-size*))
(set! *cursor-style* cursor-cross)
(set! *cursor-size* 15)
(set! (cursor index 0) 30)
@@ -6175,120 +5848,120 @@ EDITS: 5
(draw-line (- x size) (- y size) (+ x size) (+ y size) snd chn cursor-context cr)
(draw-line (- x size) (+ y size) (+ x size) (- y size) snd chn cursor-context cr)
(free-cairo cr))))
- (if (not (procedure? (cursor-style index 0))) (snd-display #__line__ ";set cursor-style to proc: ~A" (cursor-style index 0)))))
+ (if (not (procedure? (cursor-style index 0))) (snd-display ";set cursor-style to proc: ~A" (cursor-style index 0)))))
(set! (cursor index) 50)
(insert-sound "fyow.snd" (cursor) 0 index 0)
(if (or (fneq (sample 40) s40) (not (fneq (sample 100) s100)) (fneq (sample 100) 0.001831))
- (snd-display #__line__ ";insert-sound: ~A?" (sample 100)))
- (if (not (= (framples) (+ len addlen))) (snd-display #__line__ ";insert-sound len: ~A?" (framples)))
+ (snd-display ";insert-sound: ~A?" (sample 100)))
+ (if (not (= (framples) (+ len addlen))) (snd-display ";insert-sound len: ~A?" (framples)))
(save-sound-as "not-temporary.snd")
(insert-samples 0 100 "not-temporary.snd")
(set! (cursor index 0 0) (- (framples index 0 0) 2))
(revert-sound)
(if (not (= (cursor index 0) (- (framples index 0) 2)))
- (snd-display #__line__ ";set edpos cursor: ~A ~A ~A" (cursor) (cursor index 0 0) (- (framples index 0 0) 2)))
- (if (not (file-exists? "not-temporary.snd"))
- (snd-display #__line__ ";insert-samples deleted its file?")
- (delete-file "not-temporary.snd"))
+ (snd-display ";set edpos cursor: ~A ~A ~A" (cursor) (cursor index 0 0) (- (framples index 0 0) 2)))
+ (if (file-exists? "not-temporary.snd")
+ (delete-file "not-temporary.snd")
+ (snd-display ";insert-samples deleted its file?"))
(let ((id (make-region 0 99)))
(insert-region id 60 index)
- (if (not (= (framples) (+ len 100))) (snd-display #__line__ ";insert-region len: ~A?" (framples)))
- (if (fneq (sample 100) s40) (snd-display #__line__ ";insert-region: ~A ~A?" (sample 100) s40))
+ (if (not (= (framples) (+ len 100))) (snd-display ";insert-region len: ~A?" (framples)))
+ (if (fneq (sample 100) s40) (snd-display ";insert-region: ~A ~A?" (sample 100) s40))
(let ((var (catch #t (lambda () (insert-region (integer->region (+ 1000 (apply max (map region->integer (regions))))) 0)) (lambda args args))))
(if (not (eq? (car var) 'no-such-region))
- (snd-display #__line__ ";insert-region bad id: ~A" var)))
+ (snd-display ";insert-region bad id: ~A" var)))
(save-region id "fmv.snd")
(if (not (= (mus-sound-header-type "fmv.snd") mus-next))
- (snd-display #__line__ ";save-region header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";save-region header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-out-format))
- (snd-display #__line__ ";save-region format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";save-region format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (= (mus-sound-srate "fmv.snd") (region-srate id)))
- (snd-display #__line__ ";save-region srate: ~A (~A)" (mus-sound-srate "fmv.snd") (region-srate id)))
+ (snd-display ";save-region srate: ~A (~A)" (mus-sound-srate "fmv.snd") (region-srate id)))
(if (not (= (mus-sound-chans "fmv.snd") (region-chans id)))
- (snd-display #__line__ ";save-region chans: ~A (~A)" (mus-sound-chans "fmv.snd") (region-chans id)))
+ (snd-display ";save-region chans: ~A (~A)" (mus-sound-chans "fmv.snd") (region-chans id)))
(if (not (= (mus-sound-framples "fmv.snd") (region-framples id)))
- (snd-display #__line__ ";save-region length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
+ (snd-display ";save-region length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
(if (not (= (region-position id 0) 0))
- (snd-display #__line__ ";save-region position: ~A" (region-position id 0)))
+ (snd-display ";save-region position: ~A" (region-position id 0)))
(delete-file "fmv.snd")
(save-region id "fmv.snd" mus-lshort mus-riff "this is a comment")
(if (not (= (mus-sound-header-type "fmv.snd") mus-riff))
- (snd-display #__line__ ";save-region riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";save-region riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-lshort))
- (snd-display #__line__ ";save-region lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";save-region lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (= (mus-sound-framples "fmv.snd") (region-framples id)))
- (snd-display #__line__ ";save-region length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
+ (snd-display ";save-region length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";save-region comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";save-region comment: ~A" (mus-sound-comment "fmv.snd")))
(delete-file "fmv.snd")
(save-region id :file "fmv.snd" :header-type mus-riff :sample-type mus-lshort :comment "this is a comment")
(if (not (= (mus-sound-header-type "fmv.snd") mus-riff))
- (snd-display #__line__ ";save-region opt riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";save-region opt riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-lshort))
- (snd-display #__line__ ";save-region opt lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";save-region opt lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (= (mus-sound-framples "fmv.snd") (region-framples id)))
- (snd-display #__line__ ";save-region opt length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
+ (snd-display ";save-region opt length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";save-region opt comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";save-region opt comment: ~A" (mus-sound-comment "fmv.snd")))
(delete-file "fmv.snd")
(save-region id :comment "this is a comment" :file "fmv.snd" :sample-type mus-lshort :header-type mus-riff)
(if (not (= (mus-sound-header-type "fmv.snd") mus-riff))
- (snd-display #__line__ ";save-region opt1 riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";save-region opt1 riff header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-lshort))
- (snd-display #__line__ ";save-region opt1 lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";save-region opt1 lshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (= (mus-sound-framples "fmv.snd") (region-framples id)))
- (snd-display #__line__ ";save-region opt1 length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
+ (snd-display ";save-region opt1 length: ~A (~A)" (mus-sound-framples "fmv.snd") (region-framples id)))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";save-region opt1 comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";save-region opt1 comment: ~A" (mus-sound-comment "fmv.snd")))
(delete-file "fmv.snd")
(save-region id "fmv.snd" :sample-type mus-bshort)
(if (not (= (mus-sound-header-type "fmv.snd") mus-next))
- (snd-display #__line__ ";save-region opt2 next header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";save-region opt2 next header: ~A?" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-bshort))
- (snd-display #__line__ ";save-region opt2 bshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";save-region opt2 bshort format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(delete-file "fmv.snd")
))
(close-sound index)
(let ((var (catch #t (lambda () (new-sound "hi.snd" :channels 0)) (lambda args args))))
- (if (or (not (pair? var))
- (not (eq? (car var) 'out-of-range)))
- (snd-display #__line__ ";new-sound bad chan: ~A" var)))
+ (if (not (and (pair? var)
+ (eq? (car var) 'out-of-range)))
+ (snd-display ";new-sound bad chan: ~A" var)))
(set! index (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "unequal lens"))
(insert-silence 0 1000 index 1)
- (if (or (not (= (framples index 0) 1))
- (not (= (framples index 1) 1001)))
- (snd-display #__line__ ";silence 1: ~A ~A" (framples index 0) (framples index 1)))
+ (if (not (and (= (framples index 0) 1)
+ (= (framples index 1) 1001)))
+ (snd-display ";silence 1: ~A ~A" (framples index 0) (framples index 1)))
(save-sound index)
- (if (or (not (= (framples index 0) 1001))
- (not (= (framples index 1) 1001)))
- (snd-display #__line__ ";saved silence 1: ~A ~A" (framples index 0) (framples index 1)))
+ (if (not (and (= (framples index 0) 1001)
+ (= (framples index 1) 1001)))
+ (snd-display ";saved silence 1: ~A ~A" (framples index 0) (framples index 1)))
(if (not (= (mus-sound-framples "fmv.snd") 1001))
- (snd-display #__line__ ";saved framers silence 1: ~A" (mus-sound-framples "fmv.snd")))
+ (snd-display ";saved framers silence 1: ~A" (mus-sound-framples "fmv.snd")))
(let ((v0 (channel->float-vector 0 1000 index 0))
(v1 (channel->float-vector 0 1000 index 1)))
(if (fneq (float-vector-peak v0) 0.0)
- (snd-display #__line__ ";auto-pad 0: ~A" (float-vector-peak v0)))
+ (snd-display ";auto-pad 0: ~A" (float-vector-peak v0)))
(if (fneq (float-vector-peak v1) 0.0)
- (snd-display #__line__ ";silence 0: ~A" (float-vector-peak v1))))
+ (snd-display ";silence 0: ~A" (float-vector-peak v1))))
(close-sound index)
(delete-file "fmv.snd")
(set! index (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "unequal lens"))
(pad-channel 0 1000 index 1)
- (if (or (not (= (framples index 0) 1))
- (not (= (framples index 1) 1001)))
- (snd-display #__line__ ";pad-channel 1: ~A ~A" (framples index 0) (framples index 1)))
+ (if (not (and (= (framples index 0) 1)
+ (= (framples index 1) 1001)))
+ (snd-display ";pad-channel 1: ~A ~A" (framples index 0) (framples index 1)))
(let ((v0 (channel->float-vector 0 1000 index 0))
(v1 (channel->float-vector 0 1000 index 1)))
(if (fneq (float-vector-peak v0) 0.0)
- (snd-display #__line__ ";pad 0: ~A" (float-vector-peak v0)))
+ (snd-display ";pad 0: ~A" (float-vector-peak v0)))
(if (fneq (float-vector-peak v1) 0.0)
- (snd-display #__line__ ";pad 1: ~A" (float-vector-peak v1))))
+ (snd-display ";pad 1: ~A" (float-vector-peak v1))))
(map-channel (lambda (n) 1.0) 0 2 index 0)
(map-channel (lambda (n) 1.0) 0 1002 index 1)
(pad-channel 0 1000 index 0 1)
(if (not (= (framples index 1) 1002))
- (snd-display #__line__ ";pad-channel ed 1: ~A ~A" (framples index 0) (framples index 1)))
+ (snd-display ";pad-channel ed 1: ~A ~A" (framples index 0) (framples index 1)))
(close-sound index)
(delete-file "fmv.snd")
@@ -6296,7 +5969,7 @@ EDITS: 5
(scale-to 1.0 ind 0)
(make-selection 1000 2000 ind 0)
(filter-selection-and-smooth .01 (float-vector .25 .5 .5 .5 .25))
- ; (if (fneq (sample 1500 ind 0) -0.0045776) (snd-display #__line__ ";filter-selection-and-smooth: ~A" (sample 1500 ind 0)))
+ ; (if (fneq (sample 1500 ind 0) -0.0045776) (snd-display ";filter-selection-and-smooth: ~A" (sample 1500 ind 0)))
(revert-sound ind)
(close-sound ind))
@@ -6309,7 +5982,7 @@ EDITS: 5
(smooth-selection)
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 127) .5) (fneq (sample 120) .4962) (fneq (sample 32) 0.07431) (fneq (sample 64) 0.25308))
- (snd-display #__line__ ";smooth-selection: ~A?" v0))
+ (snd-display ";smooth-selection: ~A?" v0))
(revert-sound index)
(fill! v0 0.0)
(set! (v0 10) .5)
@@ -6322,9 +5995,9 @@ EDITS: 5
(set! *sinc-width* old-wid))
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 20) .5) (fneq (sample 30) 0.0) (fneq (sample 17) -.1057) )
- (snd-display #__line__ ";src-selection: ~A?" v0))
+ (snd-display ";src-selection: ~A?" v0))
(unselect-all)
- (if (selection-member?) (snd-display #__line__ ";unselect-all but still a selection?"))
+ (if (selection-member?) (snd-display ";unselect-all but still a selection?"))
(unselect-all)
(revert-sound index)
(fill! v0 0.0)
@@ -6334,7 +6007,7 @@ EDITS: 5
(filter-selection '(0 0 .1 1 1 0) 40)
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 29) .1945) (fneq (sample 39) -.0137) (fneq (sample 24) -0.01986))
- (snd-display #__line__ ";filter-selection: ~A?" v0))
+ (snd-display ";filter-selection: ~A?" v0))
(revert-sound index)
(fill! v0 1.0)
(float-vector->channel v0 0 128 index 0)
@@ -6342,7 +6015,7 @@ EDITS: 5
(filter-selection (make-one-zero :a0 .5 :a1 0.0))
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 29) .5) (fneq (sample 39) .5) (fneq (sample 24) 0.5))
- (snd-display #__line__ ";filter-selection one-zero: ~A?" v0))
+ (snd-display ";filter-selection one-zero: ~A?" v0))
(revert-sound index)
(fill! v0 1.0)
(float-vector->channel v0 0 128 index 0)
@@ -6351,22 +6024,22 @@ EDITS: 5
(env-selection '(0 0 1 1 2 0) 1.0)
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 64) 1.0) (fneq (sample 20) .3125) (fneq (sample 119) 0.127))
- (snd-display #__line__ ";env-selection [len: ~A]: ~A ~A ~A ~A?" (selection-framples) (sample 64) (sample 20) (sample 119) v0))
+ (snd-display ";env-selection [len: ~A]: ~A ~A ~A ~A?" (selection-framples) (sample 64) (sample 20) (sample 119) v0))
(save-selection "fmv5.snd" 22050 mus-bint mus-next "") ;1.0->-1.0 if short
(revert-sound index)
(let ((tag (catch #t (lambda () (file->array "/baddy/hiho" 0 0 128 v0)) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-file)) (snd-display #__line__ ";file->array w/o file: ~A" tag)))
+ (if (not (eq? tag 'no-such-file)) (snd-display ";file->array w/o file: ~A" tag)))
(let ((tag (catch #t (lambda () (file->array "fmv5.snd" 123 0 128 v0)) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-channel)) (snd-display #__line__ ";file->array w/o channel: ~A" tag)))
+ (if (not (eq? tag 'no-such-channel)) (snd-display ";file->array w/o channel: ~A" tag)))
(file->array "fmv5.snd" 0 0 128 v0)
(if (or (fneq (v0 64) 1.0) (fneq (v0 20) .3125) (fneq (v0 119) 0.127))
- (snd-display #__line__ ";save-selection: ~A ~A ~A ~A?" (v0 64) (v0 20) (v0 119) v0))
+ (snd-display ";save-selection: ~A ~A ~A ~A?" (v0 64) (v0 20) (v0 119) v0))
(if (not (= (mus-sound-header-type "fmv5.snd") mus-next))
- (snd-display #__line__ ";save-selection type: ~A?" (mus-header-type-name (mus-sound-header-type "fmv5.snd"))))
+ (snd-display ";save-selection type: ~A?" (mus-header-type-name (mus-sound-header-type "fmv5.snd"))))
(if (not (= (mus-sound-sample-type "fmv5.snd") mus-bint))
- (snd-display #__line__ ";save-selection format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv5.snd"))))
+ (snd-display ";save-selection format: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv5.snd"))))
(if (not (= (mus-sound-srate "fmv5.snd") 22050))
- (snd-display #__line__ ";save-selection srate: ~A?" (mus-sound-srate "fmv5.snd")))
+ (snd-display ";save-selection srate: ~A?" (mus-sound-srate "fmv5.snd")))
(fill! v0 0.0)
(set! (v0 100) .5)
(set! (v0 2) -.5)
@@ -6376,37 +6049,37 @@ EDITS: 5
(save-selection "fmv4.snd" 44100 mus-lfloat mus-riff "this is a comment")
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 27) 0.5) (fneq (sample 125) -.5))
- (snd-display #__line__ ";reverse-selection: ~A?" v0))
+ (snd-display ";reverse-selection: ~A?" v0))
(file->array "fmv4.snd" 0 0 128 v0)
(if (or (fneq (sample 27) 0.5) (fneq (sample 125) -.5))
- (snd-display #__line__ ";save reverse-selection: ~A?" v0))
+ (snd-display ";save reverse-selection: ~A?" v0))
(if (not (= (mus-sound-header-type "fmv4.snd") mus-riff))
- (snd-display #__line__ ";save-selection type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
+ (snd-display ";save-selection type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
(if (not (= (mus-sound-sample-type "fmv4.snd") mus-lfloat))
- (snd-display #__line__ ";save-selection format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
+ (snd-display ";save-selection format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
(if (not (= (mus-sound-srate "fmv4.snd") 44100))
- (snd-display #__line__ ";save-selection srate 1: ~A?" (mus-sound-srate "fmv4.snd")))
+ (snd-display ";save-selection srate 1: ~A?" (mus-sound-srate "fmv4.snd")))
(if (not (string=? (mus-sound-comment "fmv4.snd") "this is a comment"))
- (snd-display #__line__ ";save-selection comment: ~A?" (mus-sound-comment "fmv4.snd")))
+ (snd-display ";save-selection comment: ~A?" (mus-sound-comment "fmv4.snd")))
(delete-file "fmv4.snd")
(save-selection :file "fmv4.snd" :header-type mus-riff :sample-type mus-lfloat :srate 44100 :comment "this is a comment")
(if (not (= (mus-sound-header-type "fmv4.snd") mus-riff))
- (snd-display #__line__ ";save-selection opt type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
+ (snd-display ";save-selection opt type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
(if (not (= (mus-sound-sample-type "fmv4.snd") mus-lfloat))
- (snd-display #__line__ ";save-selection opt format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
+ (snd-display ";save-selection opt format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
(if (not (= (mus-sound-srate "fmv4.snd") 44100))
- (snd-display #__line__ ";save-selection opt srate 1: ~A?" (mus-sound-srate "fmv4.snd")))
+ (snd-display ";save-selection opt srate 1: ~A?" (mus-sound-srate "fmv4.snd")))
(if (not (string=? (mus-sound-comment "fmv4.snd") "this is a comment"))
- (snd-display #__line__ ";save-selection opt comment: ~A?" (mus-sound-comment "fmv4.snd")))
+ (snd-display ";save-selection opt comment: ~A?" (mus-sound-comment "fmv4.snd")))
(delete-file "fmv4.snd")
(save-selection :file "fmv4.snd" :sample-type mus-bfloat :channel 0)
- (if (and (not (= (mus-sound-header-type "fmv4.snd") mus-next))
- (not (= (mus-sound-header-type "fmv4.snd") mus-ircam)))
- (snd-display #__line__ ";save-selection opt1 type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
+ (if (not (or (= (mus-sound-header-type "fmv4.snd") mus-next)
+ (= (mus-sound-header-type "fmv4.snd") mus-ircam)))
+ (snd-display ";save-selection opt1 type 1: ~A?" (mus-header-type-name (mus-sound-header-type "fmv4.snd"))))
(if (not (= (mus-sound-sample-type "fmv4.snd") mus-bfloat))
- (snd-display #__line__ ";save-selection opt1 format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
+ (snd-display ";save-selection opt1 format 1: ~A?" (mus-sample-type-name (mus-sound-sample-type "fmv4.snd"))))
(if (not (= (mus-sound-chans "fmv4.snd") 1))
- (snd-display #__line__ ";save-selection opt1 chans: ~A?" (mus-sound-chans "fmv4.snd")))
+ (snd-display ";save-selection opt1 chans: ~A?" (mus-sound-chans "fmv4.snd")))
(delete-file "fmv4.snd")
(revert-sound index)
(fill! v0 0.0)
@@ -6419,83 +6092,83 @@ EDITS: 5
(if *clipping* (set! *clipping* #f))
(convolve-selection-with "fmv5.snd" .5)
(set! v0 (channel->float-vector 0 128 index 0))
- (if (fneq (sample 66) -.5) (snd-display #__line__ ";convolve-selection-with: ~A ~A ~A?" (v0 66) (sample 66) v0))
+ (if (fneq (sample 66) -.5) (snd-display ";convolve-selection-with: ~A ~A ~A?" (v0 66) (sample 66) v0))
(close-sound index))
- (let* ((obind (open-sound "oboe.snd"))
- (vol (maxamp obind))
- (dur (framples)))
+ (let ((obind (open-sound "oboe.snd")))
(when with-gui
- (set! (amp-control obind) 2.0)
- (if (fffneq (amp-control obind) 2.0) (snd-display #__line__ ";set amp-control ~A" (amp-control obind)))
- (reset-controls obind)
- (if (ffneq (amp-control obind) 1.0) (snd-display #__line__ ";reset amp-control ~A" (amp-control obind)))
- (set! (amp-control-bounds obind) (list 0.0 4.0))
- (if (not (equal? (amp-control-bounds obind) (list 0.0 4.0))) (snd-display #__line__ ";amp-control-bounds: ~A" (amp-control-bounds)))
- (set! (amp-control obind) 2.0)
- (if (eq? (without-errors (apply-controls obind)) 'no-such-sound) (snd-display #__line__ ";apply-controls can't find oboe.snd?"))
- (let ((newamp (maxamp obind)))
- (if (> (abs (- (* 2.0 vol) newamp)) .05) (snd-display #__line__ ";apply amp: ~A -> ~A?" vol newamp))
+ (let ((vol (maxamp obind))
+ (dur (framples)))
+ (set! (amp-control obind) 2.0)
+ (if (fffneq (amp-control obind) 2.0) (snd-display ";set amp-control ~A" (amp-control obind)))
+ (reset-controls obind)
+ (if (ffneq (amp-control obind) 1.0) (snd-display ";reset amp-control ~A" (amp-control obind)))
+ (set! (amp-control-bounds obind) (list 0.0 4.0))
+ (if (not (equal? (amp-control-bounds obind) (list 0.0 4.0))) (snd-display ";amp-control-bounds: ~A" (amp-control-bounds)))
+ (set! (amp-control obind) 2.0)
+ (if (eq? (without-errors (apply-controls obind)) 'no-such-sound) (snd-display ";apply-controls can't find oboe.snd?"))
+ (let ((newamp (maxamp obind)))
+ (if (> (abs (- (* 2.0 vol) newamp)) .05) (snd-display ";apply amp: ~A -> ~A?" vol newamp)))
(set! (amp-control-bounds obind) (list 0.0 8.0))
(set! (speed-control-bounds obind) (list 1.0 5.0))
- (if (not (equal? (speed-control-bounds obind) (list 1.0 5.0))) (snd-display #__line__ ";speed-control-bounds: ~A" (speed-control-bounds)))
+ (if (not (equal? (speed-control-bounds obind) (list 1.0 5.0))) (snd-display ";speed-control-bounds: ~A" (speed-control-bounds)))
(set! (speed-control obind) 0.5)
(set! (speed-control-bounds obind) (list .05 20.0))
(add-mark 1234)
(apply-controls obind)
(let ((newdur (framples obind)))
(set! (speed-control obind) 1.0)
- (if (>= (- newdur (* 2.0 dur)) 256) (snd-display #__line__ ";apply speed: ~A -> ~A?" dur newdur))
+ (if (>= (- newdur (* 2.0 dur)) 256) (snd-display ";apply speed: ~A -> ~A?" dur newdur))
;; within 256 which is apply's buffer size (it always flushes full buffers)
(set! (contrast-control? obind) #t)
(set! (contrast-control-bounds obind) (list 0.5 2.5))
- (if (not (equal? (contrast-control-bounds obind) (list 0.5 2.5))) (snd-display #__line__ ";contrast-control-bounds: ~A" (contrast-control-bounds)))
+ (if (not (equal? (contrast-control-bounds obind) (list 0.5 2.5))) (snd-display ";contrast-control-bounds: ~A" (contrast-control-bounds)))
(set! (contrast-control obind) 1.0)
(apply-controls obind)
(set! (contrast-control-bounds obind) (list 0.0 10.0))
- (if (not (equal? (contrast-control-bounds obind) (list 0.0 10.0))) (snd-display #__line__ ";contrast-control-bounds (2): ~A" (contrast-control-bounds)))
+ (if (not (equal? (contrast-control-bounds obind) (list 0.0 10.0))) (snd-display ";contrast-control-bounds (2): ~A" (contrast-control-bounds)))
(let ((secamp (maxamp obind))
(secdur (framples obind)))
- (if (fneq secamp .989) (snd-display #__line__ ";apply contrast: ~A?" secamp))
- (if (not (= secdur newdur)) (snd-display #__line__ ";apply contrast length: ~A -> ~A?" newdur secdur)))
- (undo 3 obind)
- (set! (reverb-control? obind) #t)
- (set! (reverb-control-scale-bounds obind) (list 0.0 1.0))
- (if (not (equal? (reverb-control-scale-bounds obind) (list 0.0 1.0)))
- (snd-display #__line__ ";reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
- (set! (reverb-control-length-bounds obind) (list 0.0 2.0))
- (if (not (equal? (reverb-control-length-bounds obind) (list 0.0 2.0)))
- (snd-display #__line__ ";reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
- (set! (reverb-control-scale obind) .2)
- (let ((nowamp (maxamp obind)))
- (apply-controls obind)
- (let ((revamp (maxamp obind))
- (revdur (framples obind)))
- (if (ffneq revamp .214)
- (snd-display #__line__ ";apply reverb scale: ~A at ~A, scale: ~A previous max: ~A?"
- revamp (maxamp-position obind) (reverb-control-scale obind) nowamp))
- (if (>= (- revdur (+ 50828 (round (* *reverb-control-decay* 22050)))) 256)
- (snd-display #__line__ ";apply reverb length: ~A?" revdur))))
- (undo 1 obind)
- (set! (expand-control? obind) #t)
- (set! (expand-control-bounds obind) (list 1.0 3.0))
- (if (not (equal? (expand-control-bounds obind) (list 1.0 3.0))) (snd-display #__line__ ";expand-control-bounds: ~A" (expand-control-bounds)))
- (set! (expand-control obind) 1.5)
- (apply-controls obind)
- (let ((expamp (maxamp obind))
- (expdur (framples obind)))
- (if (> (abs (- expamp .152)) .05) (snd-display #__line__ ";apply expand-control scale: ~A?" expamp))
- (if (<= expdur (* 1.25 50828)) (snd-display #__line__ ";apply expand-control length: ~A?" expdur))
- (set! (expand-control-bounds obind) (list 0.001 20.0)))
- (undo 1 obind)
- (set! (filter-control? obind) #t)
- (set! (filter-control-order obind) 40)
- (set! (filter-control-envelope obind) '(0 0 1 .5 2 0))
- (apply-controls obind)
- (let ((fltamp (maxamp obind))
- (fltdur (framples obind)))
- (if (> (abs (- fltamp .02)) .005) (snd-display #__line__ ";apply filter scale: ~A?" fltamp))
- (if (> (- fltdur (+ 40 50828)) 256) (snd-display #__line__ ";apply filter length: ~A?" fltdur))
- (undo 1 obind)))))
+ (if (fneq secamp .989) (snd-display ";apply contrast: ~A?" secamp))
+ (if (not (= secdur newdur)) (snd-display ";apply contrast length: ~A -> ~A?" newdur secdur)))))
+ (undo 3 obind)
+ (set! (reverb-control? obind) #t)
+ (set! (reverb-control-scale-bounds obind) (list 0.0 1.0))
+ (if (not (equal? (reverb-control-scale-bounds obind) (list 0.0 1.0)))
+ (snd-display ";reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
+ (set! (reverb-control-length-bounds obind) (list 0.0 2.0))
+ (if (not (equal? (reverb-control-length-bounds obind) (list 0.0 2.0)))
+ (snd-display ";reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
+ (set! (reverb-control-scale obind) .2)
+ (let ((nowamp (maxamp obind)))
+ (apply-controls obind)
+ (let ((revamp (maxamp obind))
+ (revdur (framples obind)))
+ (if (ffneq revamp .214)
+ (snd-display ";apply reverb scale: ~A at ~A, scale: ~A previous max: ~A?"
+ revamp (maxamp-position obind) (reverb-control-scale obind) nowamp))
+ (if (>= (- revdur 50828 (round (* *reverb-control-decay* 22050))) 256)
+ (snd-display ";apply reverb length: ~A?" revdur))))
+ (undo 1 obind)
+ (set! (expand-control? obind) #t)
+ (set! (expand-control-bounds obind) (list 1.0 3.0))
+ (if (not (equal? (expand-control-bounds obind) (list 1.0 3.0))) (snd-display ";expand-control-bounds: ~A" (expand-control-bounds)))
+ (set! (expand-control obind) 1.5)
+ (apply-controls obind)
+ (let ((expamp (maxamp obind))
+ (expdur (framples obind)))
+ (if (> (abs (- expamp .152)) .05) (snd-display ";apply expand-control scale: ~A?" expamp))
+ (if (<= expdur (* 1.25 50828)) (snd-display ";apply expand-control length: ~A?" expdur))
+ (set! (expand-control-bounds obind) (list 0.001 20.0)))
+ (undo 1 obind)
+ (set! (filter-control? obind) #t)
+ (set! (filter-control-order obind) 40)
+ (set! (filter-control-envelope obind) '(0 0 1 .5 2 0))
+ (apply-controls obind)
+ (let ((fltamp (maxamp obind))
+ (fltdur (framples obind)))
+ (if (> (abs (- fltamp .02)) .005) (snd-display ";apply filter scale: ~A?" fltamp))
+ (if (> (- fltdur 50868) 256) (snd-display ";apply filter length: ~A?" fltdur))
+ (undo 1 obind)))
(revert-sound obind)
(make-selection 1000 1000)
@@ -6528,7 +6201,7 @@ EDITS: 5
(2003 0 2003 50827 1.0 0.0 0.0 0)
(50828 -2 0 0 0.0 0.0 0.0 0))))
(if (not (= (length tree) (length true-tree)))
- (snd-display #__line__ ";edit trees are not same length: ~A ~A?" (length tree) (length true-tree))
+ (snd-display ";edit trees are not same length: ~A ~A?" (length tree) (length true-tree))
(let ((len (length tree)))
(do ((i 0 (+ i 1)))
((= i len))
@@ -6539,7 +6212,7 @@ EDITS: 5
(not (= (caddr branch) (caddr true-branch)))
(not (= (cadddr branch) (cadddr true-branch)))
(fneq (branch 4) (true-branch 4)))
- (snd-display #__line__ ";edit trees disagree at ~D: ~A ~A" i branch true-branch)))))))
+ (snd-display ";edit trees disagree at ~D: ~A ~A" i branch true-branch)))))))
(insert-silence 1001 8)
(insert-silence 900 50)
(insert-silence 2005 1)
@@ -6563,7 +6236,7 @@ EDITS: 5
(2064 0 2003 50827 1.0 0.0 0.0 0)
(50889 -2 0 0 0.0 0.0 0.0 0))))
(if (not (= (length tree) (length true-tree)))
- (snd-display #__line__ ";silenced edit trees are not same length: ~A ~A?" (length tree) (length true-tree))
+ (snd-display ";silenced edit trees are not same length: ~A ~A?" (length tree) (length true-tree))
(let ((len (length tree)))
(do ((i 0 (+ i 1)))
((= i len))
@@ -6574,78 +6247,78 @@ EDITS: 5
(not (= (caddr branch) (caddr true-branch)))
(not (= (cadddr branch) (cadddr true-branch)))
(fneq (branch 4) (true-branch 4)))
- (snd-display #__line__ ";silenced edit trees disagree at ~D: ~A ~A" i branch true-branch)))))))
+ (snd-display ";silenced edit trees disagree at ~D: ~A ~A" i branch true-branch)))))))
(if (or (fneq (sample 998) -.03)
(fneq (sample 999) 0.0)
(fneq (sample 1000) 0.0)
(fneq (sample 1001) -.03))
- (snd-display #__line__ ";insert-silence [999 for 2]: ~A ~A ~A ~A?" (sample 998) (sample 999) (sample 1000) (sample 1001) ))
+ (snd-display ";insert-silence [999 for 2]: ~A ~A ~A ~A?" (sample 998) (sample 999) (sample 1000) (sample 1001) ))
(if (or (fneq (sample 2006) -.033)
(fneq (sample 2007) 0.0)
(fneq (sample 2008) -.033))
- (snd-display #__line__ ";insert-silence [2007 for 1]: ~A ~A ~A?" (sample 2006) (sample 2007) (sample 2008)))
+ (snd-display ";insert-silence [2007 for 1]: ~A ~A ~A?" (sample 2006) (sample 2007) (sample 2008)))
(revert-sound obind)
(add-mark 1200 obind 0)
(let ((mark-num (length (marks obind 0))))
(scale-by 2.0 obind 0)
(let ((mark-now (length (marks obind 0))))
(if (not (= mark-num mark-now))
- (snd-display #__line__ ";mark lost after scaling?"))
+ (snd-display ";mark lost after scaling?"))
(set! (selection-position) 0)
(set! (selection-framples) 100)
(scale-selection-to .5)
(set! mark-now (length (marks obind 0)))
(if (not (= mark-num mark-now))
- (snd-display #__line__ ";mark lost after selection scaling?")))
- (let ((m1 (add-mark 1000)))
- (set! (cursor obind 0) 100)
- (key (char->integer #\u) 4 obind)
- (key (char->integer #\1) 0 obind)
- (key (char->integer #\0) 0 obind)
- (key (char->integer #\0) 0 obind)
- (key (char->integer #\o) 4 obind)
- (if (not (= (mark-sample m1) 1100))
- (snd-display #__line__ ";mark after zeros: ~D (1100)? " (mark-sample m1)))
- (set! (cursor obind) 0)
- (key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 1100)) (snd-display #__line__ ";c-j to ~A" (cursor obind)))
- (add-mark 100)
- (set! (cursor obind) 0)
- (key (char->integer #\u) 4 obind)
- (key (char->integer #\2) 0 obind)
- (key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 1100)) (snd-display #__line__ ";c-u 2 c-j ~A" (cursor obind)))
- (key (char->integer #\-) 4 obind)
- (key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 100)) (snd-display #__line__ ";c-- c-j ~A" (cursor obind)))))
+ (snd-display ";mark lost after selection scaling?"))))
+ (let ((m1 (add-mark 1000)))
+ (set! (cursor obind 0) 100)
+ (key (char->integer #\u) 4 obind)
+ (key (char->integer #\1) 0 obind)
+ (key (char->integer #\0) 0 obind)
+ (key (char->integer #\0) 0 obind)
+ (key (char->integer #\o) 4 obind)
+ (if (not (= (mark-sample m1) 1100))
+ (snd-display ";mark after zeros: ~D (1100)? " (mark-sample m1))))
+ (set! (cursor obind) 0)
+ (key (char->integer #\j) 4 obind)
+ (if (not (= (cursor obind) 1100)) (snd-display ";c-j to ~A" (cursor obind)))
+ (add-mark 100)
+ (set! (cursor obind) 0)
+ (key (char->integer #\u) 4 obind)
+ (key (char->integer #\2) 0 obind)
+ (key (char->integer #\j) 4 obind)
+ (if (not (= (cursor obind) 1100)) (snd-display ";c-u 2 c-j ~A" (cursor obind)))
+ (key (char->integer #\-) 4 obind)
+ (key (char->integer #\j) 4 obind)
+ (if (not (= (cursor obind) 100)) (snd-display ";c-- c-j ~A" (cursor obind)))
(revert-sound obind)
(let ((frs (framples obind)))
(make-region 0 999 obind 0)
- (if (not (selection?)) (snd-display #__line__ ";make-region but no selection? ~A" (selection?)))
+ (if (not (selection?)) (snd-display ";make-region but no selection? ~A" (selection?)))
(delete-selection)
(if (not (= (framples obind) (- frs 1000)))
- (snd-display #__line__ ";delete-selection: ~A?" (framples obind)))
+ (snd-display ";delete-selection: ~A?" (framples obind)))
(let ((val (sample 0 obind 0)))
(undo)
(if (fneq (sample 1000) val)
- (snd-display #__line__ ";delete-selection val: ~A ~A" val (sample 1000)))
+ (snd-display ";delete-selection val: ~A ~A" val (sample 1000)))
(insert-selection)
(let ((var (catch #t (lambda () (insert-selection 0 obind 123)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";insert-selection bad chan: ~A" var)))
+ (snd-display ";insert-selection bad chan: ~A" var)))
(let ((var (catch #t (lambda () (mix-selection 0 obind 123)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";mix-selection bad chan: ~A" var)))
+ (snd-display ";mix-selection bad chan: ~A" var)))
(if (not (= (framples obind) (+ frs 1000)))
- (snd-display #__line__ ";insert-selection: ~A?" (framples obind)))
+ (snd-display ";insert-selection: ~A?" (framples obind)))
(if (fneq (sample 2000) val)
- (snd-display #__line__ ";insert-selection val: ~A ~A" val (sample 2000)))
+ (snd-display ";insert-selection val: ~A ~A" val (sample 2000)))
(set! val (sample 900))
(mix-selection)
(if (fneq (sample 900) (* 2 val))
- (snd-display #__line__ ";mix-selection val: ~A ~A" (* 2 val) (sample 900)))
+ (snd-display ";mix-selection val: ~A ~A" (* 2 val) (sample 900)))
(if (not (= (framples obind) (+ frs 1000)))
- (snd-display #__line__ ";mix-selection len: ~A?" (framples obind)))))
+ (snd-display ";mix-selection len: ~A?" (framples obind)))))
(close-sound obind))
(let* ((ind (open-sound "2.snd"))
@@ -6657,12 +6330,12 @@ EDITS: 5
(set! (speed-control ind) .5)
(apply-controls ind apply-to-sound) ; temp 1
(if (> (abs (- (framples) (* 2 len))) 256)
- (snd-display #__line__ ";apply srate .5: ~A ~A" (framples) (* 2 len)))
+ (snd-display ";apply srate .5: ~A ~A" (framples) (* 2 len)))
(make-selection 0 (framples))
(set! (speed-control ind) .5)
(apply-controls ind apply-to-selection) ; temp 2
(if (> (abs (- (framples) (* 4 len))) 256)
- (snd-display #__line__ ";apply srate .5 to selection: ~A ~A" (framples) (* 4 len)))
+ (snd-display ";apply srate .5 to selection: ~A ~A" (framples) (* 4 len)))
(env-sound '(0 0 1 1) 0 (framples) 32.0) ; temp 3
(let ((reg (select-all))) ; make multi-channel region
(insert-region reg 0) ; temp 4
@@ -6673,16 +6346,16 @@ EDITS: 5
(set! (selected-channel ind) 1)
(apply-controls ind apply-to-channel)
(if (> (abs (- (framples ind 1) (* 2 len))) 256)
- (snd-display #__line__ ";apply srate .5 to chan 1: ~A ~A" (framples ind 1) (* 2 len)))
+ (snd-display ";apply srate .5 to chan 1: ~A ~A" (framples ind 1) (* 2 len)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";apply srate .5 but chan 0: ~A ~A" (framples ind 0) len))
+ (snd-display ";apply srate .5 but chan 0: ~A ~A" (framples ind 0) len))
(set! (speed-control ind) .5)
(apply-controls ind apply-to-sound 1000)
(make-selection 2000 4000)
(set! (speed-control ind) .5)
(apply-controls ind apply-to-selection)
(set! (selected-channel ind) #f)
- (if (selected-channel ind) (snd-display #__line__ ";selected-channel #f: ~A" (selected-channel ind)))
+ (if (selected-channel ind) (snd-display ";selected-channel #f: ~A" (selected-channel ind)))
(close-sound ind))
(let* ((ind1 (open-sound "oboe.snd"))
@@ -6693,22 +6366,22 @@ EDITS: 5
(select-sound ind1)
(scale-sound-by 2.0)
(let ((nmx (maxamp ind1 0)))
- (if (fneq (* 2 mx1) nmx) (snd-display #__line__ ";scale-sound-by 2.0: ~A ~A?" mx1 nmx))
+ (if (fneq (* 2 mx1) nmx) (snd-display ";scale-sound-by 2.0: ~A ~A?" mx1 nmx))
(if (not (equal? (edit-fragment 1 ind1 0) (list "scale-channel 2.000 0 #f" "scale" 0 50828)))
- (snd-display #__line__ ";scale-sound-by: ~A?" (edit-fragment 1 ind1 0))))
+ (snd-display ";scale-sound-by: ~A?" (edit-fragment 1 ind1 0))))
(scale-sound-to 0.5)
(let ((nmx (maxamp ind1 0)))
- (if (fneq nmx 0.5) (snd-display #__line__ ";scale-sound-to 0.5: ~A?" nmx))
+ (if (fneq nmx 0.5) (snd-display ";scale-sound-to 0.5: ~A?" nmx))
(if (not (equal? (edit-fragment 2 ind1 0) (list "scale-channel 1.698 0 #f" "scale" 0 50828)))
- (snd-display #__line__ ";scale-sound-to: ~A?" (edit-fragment 2 ind1 0))))
+ (snd-display ";scale-sound-to: ~A?" (edit-fragment 2 ind1 0))))
(scale-sound-by 0.0 0 1000 ind1 0)
(let ((nmx (maxamp ind1 0)))
- (if (fneq 0.5 nmx) (snd-display #__line__ ";scale-sound-by 0.0: ~A ~A?" mx1 nmx))
+ (if (fneq 0.5 nmx) (snd-display ";scale-sound-by 0.0: ~A ~A?" mx1 nmx))
(if (not (equal? (edit-fragment 3 ind1 0) (list "scale-channel 0.000 0 1000" "scale" 0 1000)))
- (snd-display #__line__ ";scale-sound-by 0.0: ~A?" (edit-fragment 3 ind1 0))))
+ (snd-display ";scale-sound-by 0.0: ~A?" (edit-fragment 3 ind1 0))))
(let* ((v (channel->float-vector 0 1000 ind1 0))
(pk (float-vector-peak v)))
- (if (fneq pk 0.0) (snd-display #__line__ ";scale-sound-by 0.0 [0:1000]: ~A?" pk)))
+ (if (fneq pk 0.0) (snd-display ";scale-sound-by 0.0 [0:1000]: ~A?" pk)))
(revert-sound ind1)
(let ((oldv (channel->float-vector 12000 10 ind1 0)))
(scale-sound-by 2.0 12000 10 ind1 0)
@@ -6716,25 +6389,25 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (* 2.0 (oldv i)) (newv i))
- (snd-display #__line__ ";scale ~D: ~A ~A?" i (oldv i) (newv i)))))
+ (snd-display ";scale ~D: ~A ~A?" i (oldv i) (newv i)))))
(if (not (equal? (edit-fragment 1 ind1 0) (list "scale-channel 2.000 12000 10" "scale" 12000 10)))
- (snd-display #__line__ ";scale-sound-by 2.0 [12000:10]: ~A?" (edit-fragment 1 ind1 0))))
+ (snd-display ";scale-sound-by 2.0 [12000:10]: ~A?" (edit-fragment 1 ind1 0))))
(revert-sound ind1)
(select-sound ind2)
(scale-sound-by 2.0)
(let ((nmx (maxamp ind2 0)))
- (if (fneq (* 2 mx20) nmx) (snd-display #__line__ ";2:0 scale-sound-by 2.0: ~A ~A?" mx20 nmx)))
+ (if (fneq (* 2 mx20) nmx) (snd-display ";2:0 scale-sound-by 2.0: ~A ~A?" mx20 nmx)))
(let ((nmx (maxamp ind2 1)))
- (if (fneq (* 2 mx21) nmx) (snd-display #__line__ ";2:1 scale-sound-by 2.0: ~A ~A?" mx21 nmx)))
+ (if (fneq (* 2 mx21) nmx) (snd-display ";2:1 scale-sound-by 2.0: ~A ~A?" mx21 nmx)))
(scale-sound-to 0.5)
(let ((nmx (max (maxamp ind2 0) (maxamp ind2 1))))
- (if (fneq nmx 0.5) (snd-display #__line__ ";2 scale-sound-to 0.5: ~A (~A)?" nmx (maxamp ind2))))
+ (if (fneq nmx 0.5) (snd-display ";2 scale-sound-to 0.5: ~A (~A)?" nmx (maxamp ind2))))
(scale-sound-by 0.0 0 1000 ind2 1)
(if (not (equal? (edit-fragment 3 ind2 1) (list "scale-channel 0.000 0 1000" "scale" 0 1000)))
- (snd-display #__line__ ";2:1 scale-sound-by 0.0: ~A?" (edit-fragment 3 ind2 1)))
+ (snd-display ";2:1 scale-sound-by 0.0: ~A?" (edit-fragment 3 ind2 1)))
(let* ((v (channel->float-vector 0 1000 ind2 1))
(pk (float-vector-peak v)))
- (if (fneq pk 0.0) (snd-display #__line__ ";2:1 scale-sound-by 0.0 [0:1000]: ~A?" pk)))
+ (if (fneq pk 0.0) (snd-display ";2:1 scale-sound-by 0.0 [0:1000]: ~A?" pk)))
(revert-sound ind2)
(let ((oldv (channel->float-vector 12000 10 ind2 0)))
(scale-sound-by 2.0 12000 10 ind2 0)
@@ -6742,37 +6415,37 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (* 2.0 (oldv i)) (newv i))
- (snd-display #__line__ ";2 scale ~D: ~A ~A?" i (oldv i) (newv i))))))
+ (snd-display ";2 scale ~D: ~A ~A?" i (oldv i) (newv i))))))
(revert-sound ind2)
(set! (sync ind2) 3)
(set! (sync ind1) 3)
(scale-sound-by 2.0)
(let ((nmx (maxamp ind1 0)))
- (if (fneq mx1 nmx) (snd-display #__line__ ";sync scale-sound-by 2.0: ~A ~A?" mx1 nmx)))
+ (if (fneq mx1 nmx) (snd-display ";sync scale-sound-by 2.0: ~A ~A?" mx1 nmx)))
(let ((nmx (maxamp ind2 0)))
- (if (fneq (* 2 mx20) nmx) (snd-display #__line__ ";2:0 sync scale-sound-by 2.0: ~A ~A?" mx20 nmx)))
+ (if (fneq (* 2 mx20) nmx) (snd-display ";2:0 sync scale-sound-by 2.0: ~A ~A?" mx20 nmx)))
(let ((nmx (maxamp ind2 1)))
- (if (fneq (* 2 mx21) nmx) (snd-display #__line__ ";2:1 sync scale-sound-by 2.0: ~A ~A?" mx21 nmx)))
+ (if (fneq (* 2 mx21) nmx) (snd-display ";2:1 sync scale-sound-by 2.0: ~A ~A?" mx21 nmx)))
(scale-sound-to 1.0 20000 40000 ind2 1)
(let ((nmx (maxamp ind1 0)))
- (if (fneq mx1 nmx) (snd-display #__line__ ";sync scale-sound-to 1.0: ~A ~A?" mx1 nmx)))
+ (if (fneq mx1 nmx) (snd-display ";sync scale-sound-to 1.0: ~A ~A?" mx1 nmx)))
(let ((nmx (maxamp ind2 0)))
- (if (fneq (* 2 mx20) nmx) (snd-display #__line__ ";2:0 sync scale-sound-to 1.0: ~A ~A?" mx20 nmx)))
+ (if (fneq (* 2 mx20) nmx) (snd-display ";2:0 sync scale-sound-to 1.0: ~A ~A?" mx20 nmx)))
(let ((nmx (maxamp ind2 1)))
- (if (fneq nmx 1.0) (snd-display #__line__ ";2:1 sync scale-sound-to 1.0: ~A?" nmx)))
+ (if (fneq nmx 1.0) (snd-display ";2:1 sync scale-sound-to 1.0: ~A?" nmx)))
(close-sound ind1)
(close-sound ind2))
(let ((ind (open-sound "now.snd")))
(set! (amp-control ind) .5)
- (if (ffneq (amp-control ind) .5) (snd-display #__line__ ";amp-control (.5): ~A?" (amp-control ind)))
+ (if (ffneq (amp-control ind) .5) (snd-display ";amp-control (.5): ~A?" (amp-control ind)))
(set! (amp-control ind 0) .25)
- (if (ffneq (amp-control ind) .5) (snd-display #__line__ ";amp-control after local set (.5): ~A?" (amp-control ind)))
- (if (ffneq (amp-control ind 0) .25) (snd-display #__line__ ";amp-control 0 (.25): ~A?" (amp-control ind 0)))
+ (if (ffneq (amp-control ind) .5) (snd-display ";amp-control after local set (.5): ~A?" (amp-control ind)))
+ (if (ffneq (amp-control ind 0) .25) (snd-display ";amp-control 0 (.25): ~A?" (amp-control ind 0)))
(set! (amp-control ind) 1.0)
- (if (ffneq (amp-control ind) 1.0) (snd-display #__line__ ";amp-control (1.0): ~A?" (amp-control ind)))
- (if (ffneq (amp-control ind 0) .25) (snd-display #__line__ ";amp-control 0 after set (.25): ~A?" (amp-control ind 0)))
+ (if (ffneq (amp-control ind) 1.0) (snd-display ";amp-control (1.0): ~A?" (amp-control ind)))
+ (if (ffneq (amp-control ind 0) .25) (snd-display ";amp-control 0 after set (.25): ~A?" (amp-control ind 0)))
(set! (transform-graph? ind 0) #t)
(set! (transform-graph-type ind 0) graph-as-sonogram)
(update-transform-graph ind 0)
@@ -6781,21 +6454,21 @@ EDITS: 5
(if (or (not (list? val))
(fneq (car val) 1.0)
(not (= (caddr val) 256)))
- (snd-display #__line__ ";transform-framples: ~A (~A)" val (transform-size ind 0)))))
+ (snd-display ";transform-framples: ~A (~A)" val (transform-size ind 0)))))
(close-sound ind)
(set! ind (open-sound "4.aiff"))
- (if (ffneq (amp-control ind) 1.0) (snd-display #__line__ ";amp-control upon open (1.0): ~A?" (amp-control ind)))
- (if (ffneq (amp-control ind 2) 1.0) (snd-display #__line__ ";amp-control 2 upon open (1.0): ~A?" (amp-control ind 2)))
+ (if (ffneq (amp-control ind) 1.0) (snd-display ";amp-control upon open (1.0): ~A?" (amp-control ind)))
+ (if (ffneq (amp-control ind 2) 1.0) (snd-display ";amp-control 2 upon open (1.0): ~A?" (amp-control ind 2)))
(set! (amp-control ind) .5)
- (if (ffneq (amp-control ind 2) .5) (snd-display #__line__ ";amp-control 2 after global set (.5): ~A?" (amp-control ind 2)))
+ (if (ffneq (amp-control ind 2) .5) (snd-display ";amp-control 2 after global set (.5): ~A?" (amp-control ind 2)))
(set! (amp-control ind 2) .25)
- (if (ffneq (amp-control ind 2) .25) (snd-display #__line__ ";amp-control 2 (.25): ~A?" (amp-control ind 2)))
- (if (ffneq (amp-control ind 1) .5) (snd-display #__line__ ";amp-control 1 after local set (.5): ~A?" (amp-control ind 1)))
+ (if (ffneq (amp-control ind 2) .25) (snd-display ";amp-control 2 (.25): ~A?" (amp-control ind 2)))
+ (if (ffneq (amp-control ind 1) .5) (snd-display ";amp-control 1 after local set (.5): ~A?" (amp-control ind 1)))
(let ((after-ran #f))
(set! (hook-functions after-apply-controls-hook) ())
(hook-push after-apply-controls-hook (lambda (hook) (set! after-ran (hook 'snd))))
(apply-controls ind)
- (if (not (equal? ind after-ran)) (snd-display #__line__ ";after-apply-controls-hook: ~A?" after-ran))
+ (if (not (equal? ind after-ran)) (snd-display ";after-apply-controls-hook: ~A?" after-ran))
(set! (hook-functions after-apply-controls-hook) ()))
(revert-sound ind)
(set! (sync ind) 1)
@@ -6805,27 +6478,27 @@ EDITS: 5
(fneq (mx 1) .2)
(fneq (mx 2) .2)
(fneq (mx 3) .2))
- (snd-display #__line__ ";scale to with vector: ~A" mx)))
+ (snd-display ";scale to with vector: ~A" mx)))
(set! (filter-control-envelope ind) '(0 0 1 1))
(if (not (feql '(0.0 0.0 1.0 1.0) (filter-control-envelope ind)))
- (snd-display #__line__ ";set filter-control-envelope: ~A?" (filter-control-envelope ind)))
+ (snd-display ";set filter-control-envelope: ~A?" (filter-control-envelope ind)))
(set! (filter-control-order ind) 20)
(if (not (vequal (filter-control-coeffs ind)
(float-vector -0.007 0.010 -0.025 0.029 -0.050 0.055 -0.096 0.109 -0.268 0.241
0.241 -0.268 0.109 -0.096 0.055 -0.050 0.029 -0.025 0.010 -0.007)))
- (snd-display #__line__ ";highpass coeffs: ~A" (filter-control-coeffs ind)))
+ (snd-display ";highpass coeffs: ~A" (filter-control-coeffs ind)))
(set! (filter-control-envelope ind) '(0 1 1 0))
(if (not (vequal (filter-control-coeffs ind)
(float-vector 0.003 0.002 0.004 0.002 0.007 0.003 0.014 0.012 0.059 0.394
0.394 0.059 0.012 0.014 0.003 0.007 0.002 0.004 0.002 0.003)))
- (snd-display #__line__ ";lowpass coeffs: ~A" (filter-control-coeffs ind)))
+ (snd-display ";lowpass coeffs: ~A" (filter-control-coeffs ind)))
(close-sound ind))
(let* ((obind (open-sound "4.aiff"))
(amps (maxamp obind #t))
(times (maxamp-position obind #t)))
(if (not (equal? times (list 810071 810071 810071 810071)))
- (snd-display #__line__ ";4.aiff times: ~A" times))
+ (snd-display ";4.aiff times: ~A" times))
(if (< (window-width) 600)
(set! (window-width) 600))
(if (< (window-height) 600)
@@ -6835,13 +6508,13 @@ EDITS: 5
(update-time-graph)
(set! (amp-control obind) 0.1)
(select-channel 2)
- (if (eq? (without-errors (apply-controls obind 1)) 'no-such-sound) (snd-display #__line__ ";apply-controls can't find 4.aiff?"))
+ (if (eq? (without-errors (apply-controls obind 1)) 'no-such-sound) (snd-display ";apply-controls can't find 4.aiff?"))
(let ((newamps (maxamp obind #t)))
(if (or (fneq (car amps) (car newamps))
(fneq (cadr amps) (cadr newamps))
(> (abs (- (* 0.1 (caddr amps)) (caddr newamps))) .05)
(fneq (cadddr amps) (cadddr newamps)))
- (snd-display #__line__ ";apply amps:~% ~A ->~% ~A?" amps newamps))
+ (snd-display ";apply amps:~% ~A ->~% ~A?" amps newamps))
(undo 1 obind 2)
(set! (amp-control obind) 0.1)
(make-region 0 (framples obind) obind 1)
@@ -6851,85 +6524,84 @@ EDITS: 5
(> (abs (- (* 0.1 (cadr amps)) (cadr newamps))) .05)
(fneq (caddr amps) (caddr newamps))
(fneq (cadddr amps) (cadddr newamps)))
- (snd-display #__line__ ";apply selection amp:~% ~A ->~% ~A?" amps newamps))
- (if with-gui
- (let* ((axinfo (axis-info obind 0 time-graph))
- (losamp (car axinfo))
- (hisamp (cadr axinfo))
- (x0 (axinfo 2))
- (y0 (axinfo 3))
- (x1 (axinfo 4))
- (y1 (axinfo 5))
- (xpos (+ x0 (* .5 (- x1 x0))))
- (ypos (+ y0 (* .75 (- y1 y0)))))
- (define (cp-x x) (floor (+ (axinfo 10)
- (* (- x x0) (/ (- (axinfo 12) (axinfo 10))
- (- x1 x0))))))
- (define (cp-y y) (floor (+ (axinfo 13)
- (* (- y1 y) (/ (- (axinfo 11) (axinfo 13))
- (- y1 y0))))))
- (select-channel 0)
- (set! (cursor obind) 100)
- (let ((xy (cursor-position obind)))
- (if (fneq (position->x (car xy)) (/ (cursor obind) (srate obind)))
- (snd-display #__line__ ";cursor-position: ~A ~A ~A?" (car xy) (position->x (car xy)) (/ (cursor obind) (srate obind)))))
- (if (fneq (position->x (x->position xpos)) xpos)
- (snd-display #__line__ ";x<->position: ~A ~A?" (position->x (x->position xpos)) xpos))
- (if (> (abs (- (position->y (y->position ypos)) ypos)) .5)
- (snd-display #__line__ ";y<->position: ~A ~A?" (position->y (y->position ypos)) ypos))
- (if (not (= losamp (left-sample obind 0)))
- (snd-display #__line__ ";axis-info[0 losamp]: ~A ~A?" losamp (left-sample obind 0)))
- (if (not (= hisamp (right-sample obind 0)))
- (snd-display #__line__ ";axis-info[1 hisamp]: ~A ~A?" hisamp (right-sample obind 0)))
- (if (fneq (axinfo 6) 0.0)
- (snd-display #__line__ ";axis-info[6 xmin]: ~A?" (axinfo 6)))
- (if (fneq (axinfo 7) -1.0)
- (snd-display #__line__ ";axis-info[7 ymin]: ~A?" (axinfo 7)))
- (if (fneq (axinfo 9) 1.0)
- (snd-display #__line__ ";axis-info[9 ymax]: ~A?" (axinfo 9)))
- (if (> (abs (apply - (our-x->position obind x0))) 1)
- (snd-display #__line__ ";x0->position: ~A?" (our-x->position obind x0)))
- (if (> (abs (apply - (our-x->position obind x1))) 1)
- (snd-display #__line__ ";x1->position: ~A?" (our-x->position obind x1)))
- (if (> (abs (apply - (our-x->position obind (* 0.5 (+ x0 x1))))) 1)
- (snd-display #__line__ ";xmid->position: ~A?" (our-x->position obind (* 0.5 (+ x0 x1)))))
- (if (not full-test)
- (begin
- (if (> (abs (- (x->position xpos) (cp-x xpos))) 1)
- (snd-display #__line__ ";cp-x .5: ~A ~A?" (x->position xpos) (cp-x xpos)))
- (if (> (abs (- (y->position ypos) (cp-y ypos))) 1)
- (snd-display #__line__ ";cp-y .75: ~A ~A?" (y->position ypos) (cp-y ypos)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (let ((xpos (+ x0 (random (- x1 x0))))
- (ypos (+ y0 (random (- y1 y0)))))
- (if (> (abs (- (x->position xpos) (cp-x xpos))) 1)
- (snd-display #__line__ ";cp-x[~A] ~A: ~A ~A?" i xpos (x->position xpos) (cp-x xpos)))
- (if (> (abs (- (y->position ypos) (cp-y ypos))) 1)
- (snd-display #__line__ ";cp-y[~A] ~A: ~A ~A?" i ypos (y->position ypos) (cp-y ypos)))
- (if (fneq (position->x (cp-x xpos)) xpos)
- (snd-display #__line__ ";x->position cp-x ~A ~A" xpos (position->x (cp-x xpos))))
- (if (fffneq (position->y (cp-y ypos)) ypos)
- (snd-display #__line__ ";y->position cp-y ~A ~A" ypos (position->y (cp-y ypos))))))))
- (set! (left-sample obind 0) 1234)
- (if (not (= 1234 (car (axis-info obind 0))))
- (snd-display #__line__ ";axis-info[0 losamp at 1234]: ~A ~A?" (car (axis-info obind 0)) (left-sample obind 0)))
- (set! axinfo (axis-info obind 0))
- (set! x0 (axinfo 2))
- (set! x1 (axinfo 4))
- (if (> (abs (apply - (our-x->position obind x0))) 1)
- (snd-display #__line__ ";x0a->position: ~A?" (our-x->position obind x0)))
- (if (> (abs (apply - (our-x->position obind x1))) 1)
- (snd-display #__line__ ";x1a->position: ~A?" (our-x->position obind x1)))
- (if (> (abs (apply - (our-x->position obind (* 0.5 (+ x0 x1))))) 1)
- (snd-display #__line__ ";xmida->position: ~A?" (our-x->position obind (* 0.5 (+ x0 x1)))))
- (set! (y-bounds obind 0) (list -2.0 3.0))
- (if (fneq ((axis-info obind 0) 7) -2.0)
- (snd-display #__line__ ";axis-info[7 ymin -2.0]: ~A?" ((axis-info obind 0) 7)))
- (if (fneq ((axis-info obind 0) 9) 3.0)
- (snd-display #__line__ ";axis-info[9 ymax 3.0]: ~A?" ((axis-info obind 0) 9)))
-
- ))
+ (snd-display ";apply selection amp:~% ~A ->~% ~A?" amps newamps))
+ (when with-gui
+ (let* ((axinfo (axis-info obind 0 time-graph))
+ (losamp (car axinfo))
+ (hisamp (cadr axinfo))
+ (x0 (axinfo 2))
+ (y0 (axinfo 3))
+ (x1 (axinfo 4))
+ (y1 (axinfo 5))
+ (xpos (+ x0 (* .5 (- x1 x0))))
+ (ypos (+ y0 (* .75 (- y1 y0)))))
+ (define (cp-x x) (floor (+ (axinfo 10)
+ (* (- x x0) (/ (- (axinfo 12) (axinfo 10))
+ (- x1 x0))))))
+ (define (cp-y y) (floor (+ (axinfo 13)
+ (* (- y1 y) (/ (- (axinfo 11) (axinfo 13))
+ (- y1 y0))))))
+ (select-channel 0)
+ (set! (cursor obind) 100)
+ (let ((xy (cursor-position obind)))
+ (if (fneq (position->x (car xy)) (/ (cursor obind) (srate obind)))
+ (snd-display ";cursor-position: ~A ~A ~A?" (car xy) (position->x (car xy)) (/ (cursor obind) (srate obind)))))
+ (if (fneq (position->x (x->position xpos)) xpos)
+ (snd-display ";x<->position: ~A ~A?" (position->x (x->position xpos)) xpos))
+ (if (> (abs (- (position->y (y->position ypos)) ypos)) .5)
+ (snd-display ";y<->position: ~A ~A?" (position->y (y->position ypos)) ypos))
+ (if (not (= losamp (left-sample obind 0)))
+ (snd-display ";axis-info[0 losamp]: ~A ~A?" losamp (left-sample obind 0)))
+ (if (not (= hisamp (right-sample obind 0)))
+ (snd-display ";axis-info[1 hisamp]: ~A ~A?" hisamp (right-sample obind 0)))
+ (if (fneq (axinfo 6) 0.0)
+ (snd-display ";axis-info[6 xmin]: ~A?" (axinfo 6)))
+ (if (fneq (axinfo 7) -1.0)
+ (snd-display ";axis-info[7 ymin]: ~A?" (axinfo 7)))
+ (if (fneq (axinfo 9) 1.0)
+ (snd-display ";axis-info[9 ymax]: ~A?" (axinfo 9)))
+ (if (> (abs (apply - (our-x->position obind x0))) 1)
+ (snd-display ";x0->position: ~A?" (our-x->position obind x0)))
+ (if (> (abs (apply - (our-x->position obind x1))) 1)
+ (snd-display ";x1->position: ~A?" (our-x->position obind x1)))
+ (if (> (abs (apply - (our-x->position obind (* 0.5 (+ x0 x1))))) 1)
+ (snd-display ";xmid->position: ~A?" (our-x->position obind (* 0.5 (+ x0 x1)))))
+ (unless full-test
+ (if (> (abs (- (x->position xpos) (cp-x xpos))) 1)
+ (snd-display ";cp-x .5: ~A ~A?" (x->position xpos) (cp-x xpos)))
+ (if (> (abs (- (y->position ypos) (cp-y ypos))) 1)
+ (snd-display ";cp-y .75: ~A ~A?" (y->position ypos) (cp-y ypos)))
+ (do ((xrange (- x1 x0))
+ (yrange (- y1 y0))
+ (i 0 (+ i 1)))
+ ((= i 10))
+ (let ((xpos (+ x0 (random xrange)))
+ (ypos (+ y0 (random yrange))))
+ (if (> (abs (- (x->position xpos) (cp-x xpos))) 1)
+ (snd-display ";cp-x[~A] ~A: ~A ~A?" i xpos (x->position xpos) (cp-x xpos)))
+ (if (> (abs (- (y->position ypos) (cp-y ypos))) 1)
+ (snd-display ";cp-y[~A] ~A: ~A ~A?" i ypos (y->position ypos) (cp-y ypos)))
+ (if (fneq (position->x (cp-x xpos)) xpos)
+ (snd-display ";x->position cp-x ~A ~A" xpos (position->x (cp-x xpos))))
+ (if (fffneq (position->y (cp-y ypos)) ypos)
+ (snd-display ";y->position cp-y ~A ~A" ypos (position->y (cp-y ypos)))))))
+ (set! (left-sample obind 0) 1234)
+ (if (not (= 1234 (car (axis-info obind 0))))
+ (snd-display ";axis-info[0 losamp at 1234]: ~A ~A?" (car (axis-info obind 0)) (left-sample obind 0)))
+ (set! axinfo (axis-info obind 0))
+ (set! x0 (axinfo 2))
+ (set! x1 (axinfo 4))
+ (if (> (abs (apply - (our-x->position obind x0))) 1)
+ (snd-display ";x0a->position: ~A?" (our-x->position obind x0)))
+ (if (> (abs (apply - (our-x->position obind x1))) 1)
+ (snd-display ";x1a->position: ~A?" (our-x->position obind x1)))
+ (if (> (abs (apply - (our-x->position obind (* 0.5 (+ x0 x1))))) 1)
+ (snd-display ";xmida->position: ~A?" (our-x->position obind (* 0.5 (+ x0 x1)))))
+ (set! (y-bounds obind 0) (list -2.0 3.0))
+ (if (fneq ((axis-info obind 0) 7) -2.0)
+ (snd-display ";axis-info[7 ymin -2.0]: ~A?" ((axis-info obind 0) 7)))
+ (if (fneq ((axis-info obind 0) 9) 3.0)
+ (snd-display ";axis-info[9 ymax 3.0]: ~A?" ((axis-info obind 0) 9)))))
(close-sound obind)))
(let ((ind1 (open-sound "oboe.snd")))
@@ -6975,51 +6647,51 @@ EDITS: 5
(let ((var (catch #t (lambda () (src-sound '(0 0 1 1))) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";src-sound env at 0: ~A" var)))
+ (snd-display ";src-sound env at 0: ~A" var)))
(let ((var (catch #t (lambda () (src-sound '(0 1 1 -1))) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";src-sound env through 0: ~A" var)))
+ (snd-display ";src-sound env through 0: ~A" var)))
(scale-to 1.0 ind1)
- (let ((v0 (make-float-vector 10))
- (v1 (channel->float-vector 12000 10 ind1 0)))
- (set! (v0 0) 1.0)
- (array->file "fmv3.snd" v0 10 22050 1)
+ (let ((v1 (channel->float-vector 12000 10 ind1 0)))
+ (let ((v0 (make-float-vector 10)))
+ (set! (v0 0) 1.0)
+ (array->file "fmv3.snd" v0 10 22050 1))
(copy-file "oboe.snd" "fmv4.snd")
(convolve-with "fmv3.snd" 1.0 ind1)
(convolve-files "fmv4.snd" "fmv3.snd" 1.0 "fmv5.snd")
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
(if (not (vequal1 v1 v2))
- (snd-display #__line__ ";~A (orig: 0) ~A ~A" 'convolve-with v1 v2))
+ (snd-display ";~A (orig: 0) ~A ~A" 'convolve-with v1 v2))
(file->array "fmv5.snd" 0 12000 10 v2)
(if (not (vequal1 v1 v2))
- (snd-display #__line__ ";convolve-files: (orig: 0) ~A ~A" v1 v2)))
+ (snd-display ";convolve-files: (orig: 0) ~A ~A" v1 v2)))
(delete-file "fmv3.snd")
(delete-file "fmv5.snd"))
(convolve-files "2.snd" "oboe.snd" 0.5 "fmv5.snd")
(if (or (fneq (cadr (mus-sound-maxamp "fmv5.snd")) 0.25)
(fneq (cadddr (mus-sound-maxamp "fmv5.snd")) 0.5))
- (snd-display #__line__ ";convolve-files stereo: ~A" (mus-sound-maxamp "fmv5.snd")))
+ (snd-display ";convolve-files stereo: ~A" (mus-sound-maxamp "fmv5.snd")))
(delete-file "fmv5.snd")
(scale-to .25 ind1)
(set! (y-bounds ind1) ())
(if (not (equal? (y-bounds ind1) (list -.25 .25)))
- (snd-display #__line__ ";y-bounds (): ~A?" (y-bounds ind1)))
+ (snd-display ";y-bounds (): ~A?" (y-bounds ind1)))
(revert-sound ind1)
(scale-to 1.0 ind1)
- (let ((v0 (make-float-vector 10))
- (v1 (channel->float-vector 12000 10 ind1 0)))
- (set! (v0 5) 1.0)
- (array->file "fmv3.snd" v0 10 22050 1)
+ (let ((v1 (channel->float-vector 12000 10 ind1 0)))
+ (let ((v0 (make-float-vector 10)))
+ (set! (v0 5) 1.0)
+ (array->file "fmv3.snd" v0 10 22050 1))
(convolve-with "fmv3.snd" 1.0 ind1)
(convolve-files "fmv4.snd" "fmv3.snd" 1.0 "fmv5.snd")
(let ((v2 (channel->float-vector 12005 10 ind1 0)))
(if (not (vequal1 v1 v2))
- (snd-display #__line__ ";~A (orig: 2) ~A ~A" 'convolve-with v1 v2))
+ (snd-display ";~A (orig: 2) ~A ~A" 'convolve-with v1 v2))
(file->array "fmv5.snd" 0 12005 10 v2)
(if (not (vequal1 v1 v2))
- (snd-display #__line__ ";convolve-files: (orig: 2) ~A ~A" v1 v2)))
+ (snd-display ";convolve-files: (orig: 2) ~A ~A" v1 v2)))
(delete-file "fmv3.snd")
(delete-file "fmv4.snd")
(delete-file "fmv5.snd"))
@@ -7031,33 +6703,33 @@ EDITS: 5
(select-all ind1)
(set! *selection-creates-region* old-val)
(if (not (equal? old-regions (regions)))
- (snd-display #__line__ ";selection-create-region: ~A -> ~A?" old-regions (regions))))
+ (snd-display ";selection-create-region: ~A -> ~A?" old-regions (regions))))
(convolve-selection-with "pistol.snd" (maxamp))
(let ((data (channel->float-vector 12000 10 ind1 0)))
(convolve-with "pistol.snd" (maxamp ind1 0 0) ind1 0 0)
(let ((new-data (channel->float-vector 12000 10 ind1 0)))
(if (not (vequal1 data new-data))
- (snd-display #__line__ ";convolve-selection-with: ~A ~A?" data new-data))))
+ (snd-display ";convolve-selection-with: ~A ~A?" data new-data))))
(revert-sound ind1)
(make-selection 1000 2000 ind1)
(let ((ma (maxamp ind1)))
(convolve-selection-with "pistol.snd" ma)
- (if (fneq (maxamp ind1) ma) (snd-display #__line__ ";convolve-selection-with 1000: ~A ~A?" ma (maxamp ind1))))
+ (if (fneq (maxamp ind1) ma) (snd-display ";convolve-selection-with 1000: ~A ~A?" ma (maxamp ind1))))
(make-selection 1000 2000 ind1)
(let ((id (make-region)))
(if (not (region? id))
- (snd-display #__line__ ";make-region argless: ~A" id))
+ (snd-display ";make-region argless: ~A" id))
(if (not (= (region-framples id 0) (selection-framples)))
- (snd-display #__line__ ";region/selection-framples: ~A ~A (~A)?" (region-framples id 0) (selection-framples) (region-framples id)))
+ (snd-display ";region/selection-framples: ~A ~A (~A)?" (region-framples id 0) (selection-framples) (region-framples id)))
(if (fneq (region-sample id 0) (sample 1000 ind1))
- (snd-display #__line__ ";region-sample from make-region: ~A ~A?" (region-sample id 0) (sample 1000 ind1))))
+ (snd-display ";region-sample from make-region: ~A ~A?" (region-sample id 0) (sample 1000 ind1))))
(close-sound ind1))
(let* ((ind (open-sound "2.snd"))
(reg (make-region 0 100 ind #t)))
(if (not (equal? (region-home reg) (list "2.snd" 0 100)))
- (snd-display #__line__ ";make + region-home: ~A" (region-home reg)))
+ (snd-display ";make + region-home: ~A" (region-home reg)))
(if (not (= (region-chans reg) 2))
- (snd-display #__line__ ";make-region chan #t: ~A" (region-chans reg)))
+ (snd-display ";make-region chan #t: ~A" (region-chans reg)))
(close-sound ind))
(let ((ind1 (open-sound "2.snd")))
@@ -7068,36 +6740,36 @@ EDITS: 5
(v3 (channel->float-vector 12000 10 ind1 1)))
(if (or (vequal v0 v2)
(vequal v1 v3))
- (snd-display #__line__ ";swap-channels 0: no change! ~A ~A ~A ~A" v0 v2 v1 v3)))
+ (snd-display ";swap-channels 0: no change! ~A ~A ~A ~A" v0 v2 v1 v3)))
(swap-channels ind1)
(let ((v2 (channel->float-vector 12000 10 ind1 0))
(v3 (channel->float-vector 12000 10 ind1 1)))
- (if (or (not (vequal v0 v2))
- (not (vequal v1 v3)))
- (snd-display #__line__ ";swap-channels 1: ~A ~A ~A ~A" v0 v2 v1 v3)))
- ;; as long as we're here...
- (set! (sync ind1) 0)
- (set! (cursor ind1 0) 100)
- (set! (cursor ind1 1) 200)
- (if (or (not (= (cursor ind1 0) 100))
- (not (= (cursor ind1 1) 200)))
- (snd-display #__line__ ";cursor: ~A ~A?" (cursor ind1 0) (cursor ind1 1)))
- (set! (sync ind1) 1)
- (scale-by (list .5 .25) ind1)
- (scale-by (float-vector 2.0 4.0) ind1)
- (revert-sound ind1)
- (let ((amps (maxamp ind1 #t)))
- (swap-channels ind1 0 ind1)
- (let ((newamps (maxamp ind1 #t)))
- (if (or (fneq (car amps) (cadr newamps))
- (fneq (cadr amps) (car newamps)))
- (snd-display #__line__ ";swap-channels with cp def: ~A ~A" amps newamps)))
- (swap-channels ind1 1)
- (let ((newamps (maxamp ind1 #t)))
- (if (or (fneq (car amps) (car newamps))
- (fneq (cadr amps) (cadr newamps)))
- (snd-display #__line__ ";swap-channels with cp def 0: ~A ~A" amps newamps))))
- (close-sound ind1)))
+ (if (not (and (vequal v0 v2)
+ (vequal v1 v3)))
+ (snd-display ";swap-channels 1: ~A ~A ~A ~A" v0 v2 v1 v3))))
+ ;; as long as we're here...
+ (set! (sync ind1) 0)
+ (set! (cursor ind1 0) 100)
+ (set! (cursor ind1 1) 200)
+ (if (not (and (= (cursor ind1 0) 100)
+ (= (cursor ind1 1) 200)))
+ (snd-display ";cursor: ~A ~A?" (cursor ind1 0) (cursor ind1 1)))
+ (set! (sync ind1) 1)
+ (scale-by (list .5 .25) ind1)
+ (scale-by (float-vector 2.0 4.0) ind1)
+ (revert-sound ind1)
+ (let ((amps (maxamp ind1 #t)))
+ (swap-channels ind1 0 ind1)
+ (let ((newamps (maxamp ind1 #t)))
+ (if (or (fneq (car amps) (cadr newamps))
+ (fneq (cadr amps) (car newamps)))
+ (snd-display ";swap-channels with cp def: ~A ~A" amps newamps)))
+ (swap-channels ind1 1)
+ (let ((newamps (maxamp ind1 #t)))
+ (if (or (fneq (car amps) (car newamps))
+ (fneq (cadr amps) (cadr newamps)))
+ (snd-display ";swap-channels with cp def 0: ~A ~A" amps newamps))))
+ (close-sound ind1))
(let ((ind1 (open-sound "oboe.snd"))
(ind2 (open-sound "2.snd")))
@@ -7110,7 +6782,7 @@ EDITS: 5
(if (> (next-sample reader) .1)
(set! count (+ count 1)))))))
(if (not (= ups1 ups2))
- (snd-display #__line__ ";scan-chan: ~A ~A?" ups1 ups2))
+ (snd-display ";scan-chan: ~A ~A?" ups1 ups2))
(set! ups1 (count-matches (lambda (n) (> n .03)) 0 ind2 0))
(set! ups2 (count-matches (lambda (n) (> n .03)) 0 ind2 1))
(let ((ups3 (let ((count 0)
@@ -7128,62 +6800,62 @@ EDITS: 5
(if (> (next-sample reader) .03)
(set! count (+ count 1)))))))
(if (not (= ups1 ups3))
- (snd-display #__line__ ";2[0] scan-chan: ~A ~A?" ups1 ups3))
+ (snd-display ";2[0] scan-chan: ~A ~A?" ups1 ups3))
(if (not (= ups2 ups4))
- (snd-display #__line__ ";2[1] scan-chan: ~A ~A?" ups2 ups4))))
+ (snd-display ";2[1] scan-chan: ~A ~A?" ups2 ups4))))
(close-sound ind1)
(close-sound ind2))
- (let* ((ind1 (open-sound "oboe.snd"))
- (len (framples ind1))
- (ctr #f))
- (map-channel (lambda (n)
- (and (set! ctr (not ctr))
- (* n 2.0))))
- (if (> (framples ind1) (+ (/ len 2) 1))
- (snd-display #__line__ ";map-channel cut: ~A ~A?" len (framples ind1)))
- (revert-sound ind1)
- (set! ctr 0)
- (map-channel (lambda (n)
- (or (> (set! ctr (+ ctr 1)) 3) n)))
- (if (> ctr 4)
- (snd-display #__line__ ";map-channel no-edit count: ~A?" ctr))
- (revert-sound ind1)
- (let ((v1 (make-float-vector 2)))
- (map-channel (lambda (n)
- (set! (v1 0) n)
- (set! (v1 1) (* n 3))
- v1)))
- (if (> (abs (- (framples ind1) (* len 2))) 3)
- (snd-display #__line__ ";map-channel double: ~A ~A?" len (framples ind1)))
+ (let ((ind1 (open-sound "oboe.snd")))
+ (let ((len (framples ind1)))
+ (let ((ctr #f))
+ (map-channel (lambda (n)
+ (and (set! ctr (not ctr))
+ (* n 2.0))))
+ (if (> (framples ind1) (+ (/ len 2) 1))
+ (snd-display ";map-channel cut: ~A ~A?" len (framples ind1)))
+ (revert-sound ind1)
+ (set! ctr 0)
+ (map-channel (lambda (n)
+ (or (> (set! ctr (+ ctr 1)) 3) n)))
+ (if (> ctr 4)
+ (snd-display ";map-channel no-edit count: ~A?" ctr)))
+ (revert-sound ind1)
+ (let ((v1 (make-float-vector 2)))
+ (map-channel (lambda (n)
+ (set! (v1 0) n)
+ (set! (v1 1) (* n 3))
+ v1)))
+ (if (> (abs (- (framples ind1) (* len 2))) 3)
+ (snd-display ";map-channel double: ~A ~A?" len (framples ind1))))
(revert-sound ind1)
(let ((otime (maxamp-position ind1)))
(set! (sample 1234) .9)
(let ((ntime (maxamp-position ind1))
(nval (maxamp ind1))
(npos (edit-position ind1 0)))
- (if (not (= ntime 1234)) (snd-display #__line__ ";maxamp-position 1234: ~A" ntime))
+ (if (not (= ntime 1234)) (snd-display ";maxamp-position 1234: ~A" ntime))
(let ((ootime (maxamp-position ind1 0 0)))
- (if (not (= ootime otime)) (snd-display #__line__ ";maxamp-position edpos 0: ~A ~A" otime ootime)))
+ (if (not (= ootime otime)) (snd-display ";maxamp-position edpos 0: ~A ~A" otime ootime)))
(let ((nntime (maxamp-position ind1 0 npos)))
- (if (not (= nntime ntime)) (snd-display #__line__ ";maxamp-position edpos ~D: ~A ~A" npos ntime nntime)))
- (if (fneq nval .9) (snd-display #__line__ ";maxamp .9: ~A" nval)))
+ (if (not (= nntime ntime)) (snd-display ";maxamp-position edpos ~D: ~A ~A" npos ntime nntime)))
+ (if (fneq nval .9) (snd-display ";maxamp .9: ~A" nval)))
(set! (sample 1234) 0.0)
(env-channel '(0 0 1 1))
- (if (not (= (maxamp-position) 35062)) (snd-display #__line__ ";env-channel maxamp-position: ~A" (maxamp-position)))
+ (if (not (= (maxamp-position) 35062)) (snd-display ";env-channel maxamp-position: ~A" (maxamp-position)))
(let ((ootime (maxamp-position ind1 0 0)))
- (if (not (= ootime otime)) (snd-display #__line__ ";maxamp-position edpos 0(1): ~A ~A" otime ootime)))
+ (if (not (= ootime otime)) (snd-display ";maxamp-position edpos 0(1): ~A ~A" otime ootime)))
(let ((nntime (maxamp-position ind1 0 1)))
- (if (not (= nntime 1234)) (snd-display #__line__ ";maxamp-position edpos 1(1): ~A ~A" 1234 nntime)))
+ (if (not (= nntime 1234)) (snd-display ";maxamp-position edpos 1(1): ~A ~A" 1234 nntime)))
(let ((nntime (maxamp-position ind1 0 current-edit-position)))
- (if (not (= nntime 35062)) (snd-display #__line__ ";maxamp-position edpos current: ~A ~A" 35062 nntime))))
+ (if (not (= nntime 35062)) (snd-display ";maxamp-position edpos current: ~A ~A" 35062 nntime))))
(revert-sound ind1)
(make-selection 24000 25000)
(if (not (= (selection-maxamp-position) 971))
- (snd-display #__line__ ";selection maxamp position: ~A" (selection-maxamp-position)))
+ (snd-display ";selection maxamp position: ~A" (selection-maxamp-position)))
(let ((reg (make-region 24000 25000)))
(if (not (= (region-maxamp-position reg) 971))
- (snd-display #__line__ ";region maxamp position: ~A" (region-maxamp-position reg))))
+ (snd-display ";region maxamp position: ~A" (region-maxamp-position reg))))
(close-sound ind1))
(let ((ind1 (open-sound "oboe.snd")))
(test-edpos maxamp 'maxamp (lambda () (scale-by 2.0 ind1 0)) ind1)
@@ -7218,24 +6890,24 @@ EDITS: 5
(save-sound-as "fmv1.snd" ind1 :edit-position 1)
(let ((var (catch #t (lambda () (save-sound-as "fmv2.snd" ind1 :channel 1234)) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
- (snd-display #__line__ ";save-sound-as bad chan: ~A" var)))
+ (snd-display ";save-sound-as bad chan: ~A" var)))
(if (not (= (mus-sound-framples "fmv.snd") (framples ind1 0 0)))
- (snd-display #__line__ ";save-sound-as (edpos): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 0)))
+ (snd-display ";save-sound-as (edpos): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 0)))
(if (not (= (mus-sound-framples "fmv1.snd") (framples ind1 0 1)))
- (snd-display #__line__ ";save-sound-as (edpos 1): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 1)))
+ (snd-display ";save-sound-as (edpos 1): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 1)))
(if (= (mus-sound-framples "fmv.snd") (framples ind1 0 1))
- (snd-display #__line__ ";save-sound-as (edpos 1)(2): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 1)))
+ (snd-display ";save-sound-as (edpos 1)(2): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 1)))
(let ((ind2 (open-sound "fmv.snd"))
(ind3 (open-sound "fmv1.snd")))
(if (not (vequal (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
- (snd-display #__line__ ";save-sound-as (edpos 3): ~A ~A?" (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
+ (snd-display ";save-sound-as (edpos 3): ~A ~A?" (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
(if (not (vequal (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
- (snd-display #__line__ ";save-sound-as (edpos 4): ~A ~A?" (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
+ (snd-display ";save-sound-as (edpos 4): ~A ~A?" (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
(if (vequal (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0))
- (snd-display #__line__ ";save-sound-as (edpos 5): ~A ~A?" (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0)))
+ (snd-display ";save-sound-as (edpos 5): ~A ~A?" (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0)))
(select-sound ind3)
(set! (comment) "hiho")
- (if (not (string=? (comment) "hiho")) (snd-display #__line__ ";set! comment no index: ~A" (comment)))
+ (if (not (string=? (comment) "hiho")) (snd-display ";set! comment no index: ~A" (comment)))
(close-sound ind2)
(close-sound ind3))
(delete-file "fmv.snd")
@@ -7247,23 +6919,23 @@ EDITS: 5
(test-edpos-1 (lambda (snd pos) (filter-sound (make-fir-filter 6 (float-vector .1 .2 .3 .3 .2 .1)) 6 snd 0 pos)) 'filter-sound ind1)
(test-edpos-1 (lambda (snd pos) (convolve-with "pistol.snd" .5 snd 0 pos)) 'convolve-with ind1)
- (let ((ind (new-sound "fmv.snd"))
- (v (make-float-vector 2000))
- (e (make-env (list 0.0 0.0 1.0 (* 2000 0.2 pi)) :length 2001)))
- (fill-float-vector v (sin (env e)))
- (float-vector->channel v 0 2000 ind 0)
+ (let ((ind (new-sound "fmv.snd")))
+ (let ((v (make-float-vector 2000))
+ (e (make-env (list 0.0 0.0 1.0 (* 2000 0.2 pi)) :length 2001)))
+ (fill-float-vector v (sin (env e)))
+ (float-vector->channel v 0 2000 ind 0))
(filter-sound '(0 0 .09 0 .1 1 .11 0 1 0) 1024)
- (if (> (maxamp) .025) (snd-display #__line__ ";filter-sound maxamp 1: ~A" (maxamp)))
+ (if (> (maxamp) .025) (snd-display ";filter-sound maxamp 1: ~A" (maxamp)))
(undo)
(filter-sound '(0 0 .19 0 .2 1 .21 0 1 0) 1024)
- (if (< (maxamp) .9) (snd-display #__line__ ";filter-sound maxamp 2: ~A" (maxamp)))
+ (if (< (maxamp) .9) (snd-display ";filter-sound maxamp 2: ~A" (maxamp)))
(undo)
(filter-sound '(0 0 .29 0 .3 1 .31 0 1 0) 1024)
- (if (> (maxamp) .02) (snd-display #__line__ ";filter-sound maxamp 3: ~A" (maxamp)))
+ (if (> (maxamp) .02) (snd-display ";filter-sound maxamp 3: ~A" (maxamp)))
(set! *show-sonogram-cursor* #t)
(set! *with-tracking-cursor* #t)
- (if (not *with-tracking-cursor*) (snd-display #__line__ ";with-tracking-cursor set to #t: ~A" *with-tracking-cursor*))
+ (if (not *with-tracking-cursor*) (snd-display ";with-tracking-cursor set to #t: ~A" *with-tracking-cursor*))
(set! *transform-graph-type* graph-as-sonogram)
(play :wait #t)
@@ -7277,21 +6949,21 @@ EDITS: 5
(set! (cursor) 2000)
(let ((here (cursor)))
(play :start (cursor))
- (if (or (not (= here 2000))
- (not (= (cursor) 2000)))
- (snd-display #__line__ ";with-tracking-cursor set to :track-and-return: start: ~A, end: ~A" here (cursor))))
+ (if (not (and (= here 2000)
+ (= (cursor) 2000)))
+ (snd-display ";with-tracking-cursor set to :track-and-return: start: ~A, end: ~A" here (cursor))))
(set! (zoom-focus-style) zoom-focus-middle)
(when with-motif
(set! (x-zoom-slider) .5)
- (if (fneq (x-position-slider) 0.25) (snd-display #__line__ ";zoom focus middle .5: ~A" (x-position-slider)))
+ (if (fneq (x-position-slider) 0.25) (snd-display ";zoom focus middle .5: ~A" (x-position-slider)))
(set! (x-zoom-slider) .1)
- (if (fneq (x-position-slider) 0.45) (snd-display #__line__ ";zoom focus middle .1: ~A" (x-position-slider)))
+ (if (fneq (x-position-slider) 0.45) (snd-display ";zoom focus middle .1: ~A" (x-position-slider)))
(set! (x-zoom-slider) .9)
- (if (fneq (x-position-slider) 0.05) (snd-display #__line__ ";zoom focus middle .9: ~A" (x-position-slider)))
+ (if (fneq (x-position-slider) 0.05) (snd-display ";zoom focus middle .9: ~A" (x-position-slider)))
(set! (zoom-focus-style) zoom-focus-left)
(set! (x-zoom-slider) .1)
- (if (fneq (x-position-slider) 0.05) (snd-display #__line__ ";zoom focus left .1: ~A" (x-position-slider))))
+ (if (fneq (x-position-slider) 0.05) (snd-display ";zoom focus left .1: ~A" (x-position-slider))))
(close-sound ind))
@@ -7323,7 +6995,7 @@ EDITS: 5
(if (or (> mxdiff diff)
(> mndiff diff))
(begin
- (snd-display #__line__ ";~A: peak-env-equal? [bin ~D of ~D]: (~,4F to ~,4F), diff: ~,5F"
+ (snd-display ";~A: peak-env-equal? [bin ~D of ~D]: (~,4F to ~,4F), diff: ~,5F"
name
e-bin e-size
mn mx
@@ -7331,67 +7003,68 @@ EDITS: 5
(set! happy #f)))))))))
(if (null? e0)
- (snd-display #__line__ ";no amp env data")
- (let ((mx1 (float-vector-peak (car e0)))
- (mx2 (float-vector-peak (cadr e0))))
- (if (fneq mx (max mx1 mx2))
- (snd-display #__line__ ";amp env max: ~A ~A ~A" mx mx1 mx2))
- (peak-env-equal? "straight peak" ind e0 .0001)
- (scale-by 3.0)
- (let* ((e1 (channel-amp-envs ind 0 1))
- (mx3 (float-vector-peak (car e1)))
- (mx4 (float-vector-peak (cadr e1))))
- (if (or (fneq (* 3.0 mx1) mx3)
- (fneq (* 3.0 mx2) mx4))
- (snd-display #__line__ ";3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
- (peak-env-equal? "scaled peak" ind e1 .0001))
- (if (fneq (maxamp ind 0) (* 3 mx))
- (snd-display #__line__ ";maxamp after scale: ~A ~A" mx (maxamp ind 0)))
- (undo)
- (set! (selection-member? #t) #f)
- (set! (selection-member? ind 0) #t)
- (set! (selection-position ind 0) 20000)
- (set! (selection-framples ind 0) 12000)
- (scale-selection-by 3.0)
- (let* ((e1 (channel-amp-envs ind 0 1))
- (mx3 (float-vector-peak (car e1)))
- (mx4 (float-vector-peak (cadr e1))))
- (if (or (fneq (* 3.0 mx1) mx3)
- (fneq (* 3.0 mx2) mx4))
- (snd-display #__line__ ";selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
- (if (fneq (maxamp ind 0) (* 3 mx))
- (snd-display #__line__ ";maxamp after selection scale: ~A ~A" mx (maxamp ind 0)))
- (peak-env-equal? "selection peak" ind e1 .0001))
- (map-channel abs)
- (let* ((e1 (channel-amp-envs ind 0 2))
- (mx3 (float-vector-peak (car e1)))
- (mx4 (float-vector-peak (cadr e1))))
- (if (fneq (* 3.0 mx2) mx4)
- (snd-display #__line__ ";abs selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
- (if (fneq (maxamp ind 0) (* 3 mx))
- (snd-display #__line__ ";maxamp after abs selection scale: ~A ~A" mx (maxamp ind 0)))
- (if (ffneq mx3 0.03)
- (snd-display #__line__ ";abs max: ~A ~A" mx3 mx4))
- (peak-env-equal? "map-channel peak" ind e1 .0001))
- (delete-samples 10000 5000)
- (let* ((e1 (channel-amp-envs ind 0))
- (mx3 (float-vector-peak (car e1)))
- (mx4 (float-vector-peak (cadr e1))))
- (if (fneq (* 3.0 mx2) mx4)
- (snd-display #__line__ ";abs selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
+ (snd-display ";no amp env data")
+ (let ()
+ (let ((mx1 (float-vector-peak (car e0)))
+ (mx2 (float-vector-peak (cadr e0))))
+ (if (fneq mx (max mx1 mx2))
+ (snd-display ";amp env max: ~A ~A ~A" mx mx1 mx2))
+ (peak-env-equal? "straight peak" ind e0 .0001)
+ (scale-by 3.0)
+ (let* ((e1 (channel-amp-envs ind 0 1))
+ (mx3 (float-vector-peak (car e1)))
+ (mx4 (float-vector-peak (cadr e1))))
+ (if (or (fneq (* 3.0 mx1) mx3)
+ (fneq (* 3.0 mx2) mx4))
+ (snd-display ";3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
+ (peak-env-equal? "scaled peak" ind e1 .0001))
(if (fneq (maxamp ind 0) (* 3 mx))
- (snd-display #__line__ ";maxamp after abs selection scale: ~A ~A" mx (maxamp ind 0)))
- (if (ffneq mx3 0.03)
- (snd-display #__line__ ";abs max: ~A ~A" mx3 mx4))
- (peak-env-equal? "delete peak" ind e1 .0001))
- (scale-selection-by -.333)
- (let* ((e1 (channel-amp-envs ind 0 4))
- (mx3 (float-vector-peak (car e1))))
- (if (fneq (maxamp ind 0) mx)
- (snd-display #__line__ ";maxamp after minus abs selection scale: ~A ~A" mx (maxamp ind 0)))
- (if (fneq (maxamp ind 0) mx3)
- (snd-display #__line__ ";mx3 maxamp after minus abs selection scale: ~A ~A" mx mx3))
- (peak-env-equal? "scale-selection peak" ind e1 .0001))
+ (snd-display ";maxamp after scale: ~A ~A" mx (maxamp ind 0)))
+ (undo)
+ (set! (selection-member? #t) #f)
+ (set! (selection-member? ind 0) #t)
+ (set! (selection-position ind 0) 20000)
+ (set! (selection-framples ind 0) 12000)
+ (scale-selection-by 3.0)
+ (let* ((e1 (channel-amp-envs ind 0 1))
+ (mx3 (float-vector-peak (car e1)))
+ (mx4 (float-vector-peak (cadr e1))))
+ (if (or (fneq (* 3.0 mx1) mx3)
+ (fneq (* 3.0 mx2) mx4))
+ (snd-display ";selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
+ (if (fneq (maxamp ind 0) (* 3 mx))
+ (snd-display ";maxamp after selection scale: ~A ~A" mx (maxamp ind 0)))
+ (peak-env-equal? "selection peak" ind e1 .0001))
+ (map-channel abs)
+ (let* ((e1 (channel-amp-envs ind 0 2))
+ (mx3 (float-vector-peak (car e1)))
+ (mx4 (float-vector-peak (cadr e1))))
+ (if (fneq (* 3.0 mx2) mx4)
+ (snd-display ";abs selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
+ (if (fneq (maxamp ind 0) (* 3 mx))
+ (snd-display ";maxamp after abs selection scale: ~A ~A" mx (maxamp ind 0)))
+ (if (ffneq mx3 0.03)
+ (snd-display ";abs max: ~A ~A" mx3 mx4))
+ (peak-env-equal? "map-channel peak" ind e1 .0001))
+ (delete-samples 10000 5000)
+ (let* ((e1 (channel-amp-envs ind 0))
+ (mx3 (float-vector-peak (car e1)))
+ (mx4 (float-vector-peak (cadr e1))))
+ (if (fneq (* 3.0 mx2) mx4)
+ (snd-display ";abs selection 3.0 amp env max: ~A ~A ~A ~A" mx1 mx2 mx3 mx4))
+ (if (fneq (maxamp ind 0) (* 3 mx))
+ (snd-display ";maxamp after abs selection scale: ~A ~A" mx (maxamp ind 0)))
+ (if (ffneq mx3 0.03)
+ (snd-display ";abs max: ~A ~A" mx3 mx4))
+ (peak-env-equal? "delete peak" ind e1 .0001))
+ (scale-selection-by -.333)
+ (let* ((e1 (channel-amp-envs ind 0 4))
+ (mx3 (float-vector-peak (car e1))))
+ (if (fneq (maxamp ind 0) mx)
+ (snd-display ";maxamp after minus abs selection scale: ~A ~A" mx (maxamp ind 0)))
+ (if (fneq (maxamp ind 0) mx3)
+ (snd-display ";mx3 maxamp after minus abs selection scale: ~A ~A" mx mx3))
+ (peak-env-equal? "scale-selection peak" ind e1 .0001)))
(revert-sound ind)
(ramp-channel 0.0 1.0)
@@ -7486,14 +7159,13 @@ EDITS: 5
(let* ((peaks (channel-amp-envs ind 0))
(mx (cadr peaks))
(mn (car peaks)))
- (call-with-current-continuation
+ (call-with-exit
(lambda (break)
- (if (not (continuation? break)) (snd-display #__line__ ";not a continuation: ~A" break))
(let ((ln (- (length mn) 4)))
(do ((i 0 (+ i 1)))
((= i ln))
- (if (< (mn i) 0.5) (begin (snd-display #__line__ ";peak min: ~A ~A" (mn i) i) (break #f)))
- (if (< (mx i) 0.5) (begin (snd-display #__line__ ";peak max: ~A ~A" (mx i) i) (break #f))))))))
+ (if (< (mn i) 0.5) (begin (snd-display ";peak min: ~A ~A" (mn i) i) (break #f)))
+ (if (< (mx i) 0.5) (begin (snd-display ";peak max: ~A ~A" (mx i) i) (break #f))))))))
(undo 2)
(map-channel (lambda (y) -1.0) 0 50001)
(ramp-channel 0.5 1.0 1000 4000)
@@ -7505,16 +7177,16 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((or (not happy)
(= i ln)))
- (if (> (mn i) -0.5) (begin (snd-display #__line__ ";1 peak min: ~A ~A" (mn i) i) (set! happy #f)))
- (if (> (mx i) -0.5) (begin (snd-display #__line__ ";1 peak max: ~A ~A" (mx i) i) (set! happy #f)))))
+ (if (> (mn i) -0.5) (begin (snd-display ";1 peak min: ~A ~A" (mn i) i) (set! happy #f)))
+ (if (> (mx i) -0.5) (begin (snd-display ";1 peak max: ~A ~A" (mx i) i) (set! happy #f)))))
(close-sound ind))
(let ((index (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "channel tests")))
(define (test-channel-func func val-func init-val)
(let ((len (framples index))
(chns (chans index))
- (val #f))
- (set! g-init-val init-val)
+ (val #f)
+ (g-init-val init-val))
(do ((k 0 (+ k 1)))
((= k 2))
(set! val (val-func len))
@@ -7523,7 +7195,7 @@ EDITS: 5
((= i chns))
(map-channel (lambda (n) 0.0) 0 len index i)
(if (scan-channel (lambda (n) (> (abs n) .001)) 0 len index i)
- (snd-display #__line__ ";init scan: ~A?" (scan-channel (lambda (n) (> (abs n) 0.001))))))
+ (snd-display ";init scan: ~A?" (scan-channel (lambda (n) (> (abs n) 0.001))))))
;; now it's cleared
(do ((i 0 (+ i 1)))
((= i chns))
@@ -7534,9 +7206,9 @@ EDITS: 5
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
(if (not (vequal vi val))
- (snd-display #__line__ ";chan func: ~A ~A" vi val))
+ (snd-display ";chan func: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) .001)) 0 len index j)
- (snd-display #__line__ ";chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
+ (snd-display ";chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
(map-channel (lambda (n) 0.0) 0 len index i))
(do ((i 0 (+ i 1)))
((= i chns))
@@ -7549,9 +7221,9 @@ EDITS: 5
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
(if (not (vequal vi val))
- (snd-display #__line__ ";ed chan func: ~A ~A" vi val))
+ (snd-display ";ed chan func: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j)
- (snd-display #__line__ ";ed chan func leaks? ~A ~A ~A: ~A" i j ed (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
+ (snd-display ";ed chan func leaks? ~A ~A ~A: ~A" i j ed (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
(map-channel (lambda (n) 0.0) 0 len index i)))
(let* ((beg (floor (/ len 3)))
(dur beg)
@@ -7571,9 +7243,9 @@ EDITS: 5
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
(if (not (vequal vi val))
- (snd-display #__line__ ";chan func n: ~A ~A" vi val))
+ (snd-display ";chan func n: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j)
- (snd-display #__line__ ";dur chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
+ (snd-display ";dur chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
(map-channel (lambda (n) 0.0) 0 len index i))))))
(insert-silence 0 10 index 0)
@@ -7712,20 +7384,20 @@ EDITS: 5
(for-each forget-region (regions))
(load (string-append cwd "s61.scm"))
(if (not (equal? old-reglen (map region-framples (regions))))
- (snd-display #__line__ ";region-framples after save: ~A ~A" old-reglen (map region-framples (regions))))
+ (snd-display ";region-framples after save: ~A ~A" old-reglen (map region-framples (regions))))
(catch #t
(lambda ()
(for-each (lambda (n data)
(if (not (vequal data (region->float-vector n 0 10)))
- (snd-display #__line__ ";region after save ~A: ~A ~A" n data (region->float-vector n 0 10))))
+ (snd-display ";region after save ~A: ~A ~A" n data (region->float-vector n 0 10))))
(regions)
regdata))
- (lambda args (snd-display #__line__ ";region->float-vector: ~A" args)))
+ (lambda args (snd-display ";region->float-vector: ~A" args)))
(set! index (find-sound "fmv.snd"))
(if (not (equal? (maxamp index #t) old-max))
- (snd-display #__line__ ";maxes: ~A ~A" (maxamp index #t) old-max))
+ (snd-display ";maxes: ~A ~A" (maxamp index #t) old-max))
(if (not (equal? (edits index) (list 275 0)))
- (snd-display #__line__ ";saved channel edits: ~A" (edits index)))
+ (snd-display ";saved channel edits: ~A" (edits index)))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -7763,29 +7435,29 @@ EDITS: 5
((= i 10))
(set! (v i) (src s)))
(if (not (vequal v (channel->float-vector 0 10 index 0)))
- (snd-display #__line__ ";src-channel: ~A ~A" v (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel: ~A ~A" v (channel->float-vector 0 10 index 0)))
(if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 1)))
- (snd-display #__line__ ";src-channel leaks: ~A" (channel->float-vector 0 10 index 1))))
+ (snd-display ";src-channel leaks: ~A" (channel->float-vector 0 10 index 1))))
(let ((tag (catch #t (lambda () (src-channel 120000.0)) (lambda args args))))
- (if (not (eq? (car tag) 'mus-error)) (snd-display #__line__ ";src-channel crazy srate: ~A" tag)))
+ (if (not (eq? (car tag) 'mus-error)) (snd-display ";src-channel crazy srate: ~A" tag)))
(let ((tag (catch #t (lambda () (filter-sound (make-snd->sample))) (lambda args args))))
- (if (not (eq? (car tag) 'mus-error)) (snd-display #__line__ ";filter-sound + un-run gen: ~A" tag)))
+ (if (not (eq? (car tag) 'mus-error)) (snd-display ";filter-sound + un-run gen: ~A" tag)))
(revert-sound index)
(float-vector->channel v 0 10 index 1)
(float-vector->channel v 10 10 index 1)
(src-channel (make-env :envelope '(1 1 2 2) :length 21) 0 20 index 1)
(if (not (vequal (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.048 0.068 -0.059 0.022 0.030 -0.100 0.273 0.606)))
- (snd-display #__line__ ";src-channel env: ~A" (channel->float-vector 0 10 index 1)))
+ (snd-display ";src-channel env: ~A" (channel->float-vector 0 10 index 1)))
(if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 0)))
- (snd-display #__line__ ";src-channel env leaks: ~A" (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel env leaks: ~A" (channel->float-vector 0 10 index 0)))
(revert-sound index)
(float-vector->channel v 0 10 index 1)
(float-vector->channel v 10 10 index 1)
(src-channel '(1 1 2 2) 0 20 index 1) ; end is off above -- should be 19 I think
(if (not (vequal (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.051 0.069 -0.056 0.015 0.042 -0.117 0.320 0.568)))
- (snd-display #__line__ ";src-channel lst: ~A" (channel->float-vector 0 10 index 1)))
+ (snd-display ";src-channel lst: ~A" (channel->float-vector 0 10 index 1)))
(if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 0)))
- (snd-display #__line__ ";src-channel lst leaks: ~A" (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel lst leaks: ~A" (channel->float-vector 0 10 index 0)))
(set! *sinc-width* sw)
(close-sound index))
@@ -7811,72 +7483,72 @@ EDITS: 5
(set! sum (+ sum (float-vector-ref v1 i))))
(if (or (> sum .01) ; depends on sinc-width I think
(> mx .002))
- (snd-display #__line__ ";src-channel ~A: diff: ~A ~A~%" sr sum mx))))))
+ (snd-display ";src-channel ~A: diff: ~A ~A~%" sr sum mx))))))
(list 0.5 0.75 1.0 1.5 2.0))
(close-sound ind))
- (if (< *max-regions* 8) (set! *max-regions* 8))
+ (set! *max-regions* (max *max-regions* 8))
(let* ((ind (open-sound "oboe.snd"))
(rid0 (make-region 2000 2020 ind 0))
(rid0-data (region2float-vector rid0 0 20)))
(scale-sound-by 2.0)
(play rid0 :wait #t)
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display #__line__ ";deferred region after scaling:~% ~A~% ~A" rid0-data nv)))
+ (if (not (vequal rid0-data nv)) (snd-display ";deferred region after scaling:~% ~A~% ~A" rid0-data nv)))
(let ((nv (region-to-float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display #__line__ ";deferred region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
+ (if (not (vequal rid0-data nv)) (snd-display ";deferred region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
(undo)
(scale-by 4.0)
(play rid0 :wait #t)
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display #__line__ ";file region after scaling:~% ~A~% ~A" rid0-data nv)))
+ (if (not (vequal rid0-data nv)) (snd-display ";file region after scaling:~% ~A~% ~A" rid0-data nv)))
(let ((nv (region-to-float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display #__line__ ";file region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
+ (if (not (vequal rid0-data nv)) (snd-display ";file region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
(let* ((rid1 (make-region 2000 2020 ind 0))
(rid1-data (region2float-vector rid1 0 20)))
(scale-to .5)
(let ((nv (region2float-vector rid1 0 20)))
- (if (not (vequal rid1-data nv)) (snd-display #__line__ ";deferred region after scale-to:~% ~A~% ~A" rid1-data nv)))
+ (if (not (vequal rid1-data nv)) (snd-display ";deferred region after scale-to:~% ~A~% ~A" rid1-data nv)))
(close-sound ind)
(play rid0 :wait #t)
(play rid1 :wait #t)
(let ((nv (region2float-vector rid1 0 20)))
- (if (not (vequal rid1-data nv)) (snd-display #__line__ ";deferred region after close:~% ~A~% ~A" rid1-data nv)))
+ (if (not (vequal rid1-data nv)) (snd-display ";deferred region after close:~% ~A~% ~A" rid1-data nv)))
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display #__line__ ";file region after close:~% ~A~% ~A" rid0-data nv))))
+ (if (not (vequal rid0-data nv)) (snd-display ";file region after close:~% ~A~% ~A" rid0-data nv))))
(for-each
- (lambda (s1 l1 s2 l2)
+ (lambda (s1 L1 s2 L2)
(set! ind (open-sound "2.snd"))
(set! (selection-member? #t) #f)
(set! (selection-member? ind 0) #t)
(set! (selection-position ind 0) s1)
- (set! (selection-framples ind 0) l1)
+ (set! (selection-framples ind 0) L1)
(set! (selection-member? ind 1) #t)
(set! (selection-position ind 1) s2)
- (set! (selection-framples ind 1) l2)
+ (set! (selection-framples ind 1) L2)
(let* ((rid2 (make-region))
- (rid20-data (region2float-vector rid2 0 l1))
- (rid21-data (region2float-vector rid2 1 l2)))
- (if (not (= (region-chans rid2) 2)) (snd-display #__line__ ";region-chans of sync'd sound: ~A?" (region-chans rid2)))
+ (rid20-data (region2float-vector rid2 0 L1))
+ (rid21-data (region2float-vector rid2 1 L2)))
+ (if (not (= (region-chans rid2) 2)) (snd-display ";region-chans of sync'd sound: ~A?" (region-chans rid2)))
(swap-channels ind 0 ind 1)
- (let ((nv (region2float-vector rid2 0 l1)))
- (if (not (vequal rid20-data nv)) (snd-display #__line__ ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
- (let ((nv (region-to-float-vector rid2 0 l1)))
- (if (not (vequal rid20-data nv)) (snd-display #__line__ ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
- (let ((nv (region2float-vector rid2 1 l2)))
- (if (not (vequal rid21-data nv)) (snd-display #__line__ ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
- (let ((nv (region-to-float-vector rid2 1 l2)))
- (if (not (vequal rid21-data nv)) (snd-display #__line__ ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
+ (let ((nv (region2float-vector rid2 0 L1)))
+ (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
+ (let ((nv (region-to-float-vector rid2 0 L1)))
+ (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
+ (let ((nv (region2float-vector rid2 1 L2)))
+ (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
+ (let ((nv (region-to-float-vector rid2 1 L2)))
+ (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
(close-sound ind)
- (let ((nv (region2float-vector rid2 0 l1)))
- (if (not (vequal rid20-data nv)) (snd-display #__line__ ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
- (let ((nv (region-to-float-vector rid2 0 l1)))
- (if (not (vequal rid20-data nv)) (snd-display #__line__ ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
- (let ((nv (region2float-vector rid2 1 l2)))
- (if (not (vequal rid21-data nv)) (snd-display #__line__ ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
- (let ((nv (region-to-float-vector rid2 1 l2)))
- (if (not (vequal rid21-data nv)) (snd-display #__line__ ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
+ (let ((nv (region2float-vector rid2 0 L1)))
+ (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
+ (let ((nv (region-to-float-vector rid2 0 L1)))
+ (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
+ (let ((nv (region2float-vector rid2 1 L2)))
+ (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
+ (let ((nv (region-to-float-vector rid2 1 L2)))
+ (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
))
(list 2000 2000 2000 0 2000 0 2000)
(list 20 10 20 20 20 10 20)
@@ -7890,50 +7562,43 @@ EDITS: 5
(lambda ()
(save-sound ind))
(lambda args args))))
- (if (sound? val) (snd-display #__line__ ";save-sound read-only: ~A" val))
- (if (not (equal? (edits ind) (list 1 0))) (snd-display #__line__ ";read-only ignored? ~A" (edits ind))))
+ (if (sound? val) (snd-display ";save-sound read-only: ~A" val))
+ (if (not (equal? (edits ind) (list 1 0))) (snd-display ";read-only ignored? ~A" (edits ind))))
(set! (read-only ind) #f)
(revert-sound ind)
(let ((tag (catch #t
(lambda () (save-sound ind))
(lambda args args))))
- (if (not (sound? tag)) (snd-display #__line__ ";save-sound read-write: ~A" tag)))
- (key (char->integer #\j) 4)
- (key (char->integer #\-) 4)
- (key (char->integer #\j) 4)
- (key (char->integer #\j) 4)
- (key (char->integer #\x) 4)
+ (if (not (sound? tag)) (snd-display ";save-sound read-write: ~A" tag)))
+ (for-each (lambda (arg) (key arg 4)) (vector (char->integer #\j) (char->integer #\-) (char->integer #\j)
+ (char->integer #\j) (char->integer #\x)))
(key (char->integer #\c) 0)
(catch #t (lambda () (add-mark 123)) (lambda args #f))
- (key (char->integer #\u) 4)
- (key (char->integer #\6) 4)
- (key (char->integer #\j) 4)
- (key (char->integer #\u) 4)
- (key (char->integer #\6) 4)
- (key (char->integer #\x) 4)
+ (for-each (lambda (arg) (key arg 4)) (vector (char->integer #\u) (char->integer #\6) (char->integer #\j)
+ (char->integer #\u) (char->integer #\6) (char->integer #\x)))
(key (char->integer #\c) 0)
(close-sound ind))
- (let ((ns (new-sound))
- (v (make-float-vector 1000)))
+ (let ((ns (new-sound)))
(unselect-all)
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .001)))
- ((= i 1000))
- (set! (v i) x))
- (float-vector->channel v 0 1000 ns 0)
+ (let ((v (make-float-vector 1000)))
+ (do ((i 0 (+ i 1))
+ (x 0.0 (+ x .001)))
+ ((= i 1000))
+ (set! (v i) x))
+ (float-vector->channel v 0 1000 ns 0))
(set! (selection-member? ns 0) #t)
(set! (selection-position ns 0) 200)
(set! (selection-framples ns 0) 300)
(delete-selection-and-smooth)
(if (not (= (framples ns 0) 700))
- (snd-display #__line__ ";delete-selection-and-smooth framples: ~A" (framples ns 0)))
+ (snd-display ";delete-selection-and-smooth framples: ~A" (framples ns 0)))
(if (fneq (sample 167 ns 0) 0.167)
- (snd-display #__line__ ";delete-selection-and-smooth 167: ~A" (sample 167 ns 0)))
+ (snd-display ";delete-selection-and-smooth 167: ~A" (sample 167 ns 0)))
(if (fneq (sample 234 ns 0) 0.534)
- (snd-display #__line__ ";delete-selection-and-smooth 234: ~A" (sample 234 ns 0)))
+ (snd-display ";delete-selection-and-smooth 234: ~A" (sample 234 ns 0)))
(if (fneq (sample 210 ns 0) 0.406)
- (snd-display #__line__ ";delete-selection-and-smooth 210: ~A" (sample 210 ns 0)))
+ (snd-display ";delete-selection-and-smooth 210: ~A" (sample 210 ns 0)))
(let* ((v1 (channel->float-vector))
(maxdiff 0.0)
(mindiff 10.0)
@@ -7942,30 +7607,30 @@ EDITS: 5
((= i 700))
(let ((diff (- (v1 i) ls)))
(set! ls (v1 i))
- (if (> diff maxdiff) (set! maxdiff diff))
- (if (< diff mindiff) (set! mindiff diff))))
+ (set! maxdiff (max maxdiff diff))
+ (set! mindiff (min mindiff diff))))
(if (< mindiff .0009)
- (snd-display #__line__ ";delete-selection-and-smooth min diff: ~A" mindiff))
+ (snd-display ";delete-selection-and-smooth min diff: ~A" mindiff))
(if (> maxdiff .007)
- (snd-display #__line__ ";delete-selection-and-smooth max diff: ~A" maxdiff)))
+ (snd-display ";delete-selection-and-smooth max diff: ~A" maxdiff)))
(close-sound ns))
- (let ((ns (new-sound))
- (v (make-float-vector 1000)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .001)))
- ((= i 1000))
- (set! (v i) x))
- (float-vector->channel v 0 1000 ns 0)
+ (let ((ns (new-sound)))
+ (let ((v (make-float-vector 1000)))
+ (do ((i 0 (+ i 1))
+ (x 0.0 (+ x .001)))
+ ((= i 1000))
+ (set! (v i) x))
+ (float-vector->channel v 0 1000 ns 0))
(delete-samples-and-smooth 200 300 ns 0)
(if (not (= (framples ns 0) 700))
- (snd-display #__line__ ";delete-samples-and-smooth framples: ~A" (framples ns 0)))
+ (snd-display ";delete-samples-and-smooth framples: ~A" (framples ns 0)))
(if (fneq (sample 167 ns 0) 0.167)
- (snd-display #__line__ ";delete-samples-and-smooth 167: ~A" (sample 167 ns 0)))
+ (snd-display ";delete-samples-and-smooth 167: ~A" (sample 167 ns 0)))
(if (fneq (sample 234 ns 0) 0.534)
- (snd-display #__line__ ";delete-samples-and-smooth 234: ~A" (sample 234 ns 0)))
+ (snd-display ";delete-samples-and-smooth 234: ~A" (sample 234 ns 0)))
(if (fneq (sample 210 ns 0) 0.406)
- (snd-display #__line__ ";delete-samples-and-smooth 210: ~A" (sample 210 ns 0)))
+ (snd-display ";delete-samples-and-smooth 210: ~A" (sample 210 ns 0)))
(let* ((v1 (channel->float-vector))
(maxdiff 0.0)
(mindiff 10.0)
@@ -7974,12 +7639,12 @@ EDITS: 5
((= i 700))
(let ((diff (- (v1 i) ls)))
(set! ls (v1 i))
- (if (> diff maxdiff) (set! maxdiff diff))
- (if (< diff mindiff) (set! mindiff diff))))
+ (set! maxdiff (max maxdiff diff))
+ (set! mindiff (min mindiff diff))))
(if (< mindiff .0009)
- (snd-display #__line__ ";delete-samples-and-smooth min diff: ~A" mindiff))
+ (snd-display ";delete-samples-and-smooth min diff: ~A" mindiff))
(if (> maxdiff .007)
- (snd-display #__line__ ";delete-samples-and-smooth max diff: ~A" maxdiff)))
+ (snd-display ";delete-samples-and-smooth max diff: ~A" maxdiff)))
(close-sound ns))
(let ((old-beg *initial-beg*)
@@ -7992,9 +7657,9 @@ EDITS: 5
(let ((ls (left-sample ns 0))
(rs (right-sample ns 0))
(fr (framples ns 0)))
- (when with-gui
- (if (not (equal? (list fr ls rs) '(220501 0 220501)))
- (snd-display #__line__ ";show-full-duration 1: ~A" (list fr ls rs))))
+ (when (and with-gui
+ (not (equal? (list fr ls rs) '(220501 0 220501))))
+ (snd-display ";show-full-duration 1: ~A" (list fr ls rs)))
(close-sound ns)))
(set! *show-full-duration* #t)
(set! *initial-beg* 0.0)
@@ -8003,9 +7668,9 @@ EDITS: 5
(let ((ls (left-sample ns 0))
(rs (right-sample ns 0))
(fr (framples ns 0)))
- (when with-gui
- (if (not (equal? (list fr ls rs) '(220501 0 220501)))
- (snd-display #__line__ ";show-full-duration 2: ~A" (list fr ls rs))))
+ (when (and with-gui
+ (not (equal? (list fr ls rs) '(220501 0 220501))))
+ (snd-display ";show-full-duration 2: ~A" (list fr ls rs)))
(close-sound ns)))
(set! *show-full-duration* #f)
(set! *initial-beg* 0.0)
@@ -8015,7 +7680,7 @@ EDITS: 5
(rs (right-sample ns 0))
(fr (framples ns 0)))
(if (not (equal? (list fr ls rs) '(220501 0 4410)))
- (snd-display #__line__ ";show-full-duration 3: ~A" (list fr ls rs)))
+ (snd-display ";show-full-duration 3: ~A" (list fr ls rs)))
(close-sound ns)))
(set! *initial-beg* 2.0)
(set! *initial-dur* 1.0)
@@ -8024,7 +7689,7 @@ EDITS: 5
(rs (right-sample ns 0))
(fr (framples ns 0)))
(if (not (equal? (list fr ls rs) '(220501 44100 66150)))
- (snd-display #__line__ ";show-full-duration 4: ~A" (list fr ls rs)))
+ (snd-display ";show-full-duration 4: ~A" (list fr ls rs)))
(close-sound ns)))
(set! *initial-beg* old-beg)
(set! *initial-dur* old-dur)
@@ -8035,22 +7700,22 @@ EDITS: 5
(let ((ns (open-sound "1a.snd")))
(if (or (fneq (car (y-bounds ns 0)) -1.0)
(fneq (cadr (y-bounds ns 0)) 1.0))
- (snd-display #__line__ ";show-full-range 1a: ~A" (y-bounds ns 0)))
+ (snd-display ";show-full-range 1a: ~A" (y-bounds ns 0)))
(close-sound ns))
(with-sound ("test.snd" :clipped #f :to-snd #f)
(fm-violin 0 1 440 3.5))
(let ((ns (open-sound "test.snd")))
- (when with-gui
- (if (or (fneq (car (y-bounds ns 0)) -3.5)
- (fneq (cadr (y-bounds ns 0)) 3.5))
- (snd-display #__line__ ";show-full-range 3.5 test: ~A" (y-bounds ns 0))))
+ (when (and with-gui
+ (or (fneq (car (y-bounds ns 0)) -3.5)
+ (fneq (cadr (y-bounds ns 0)) 3.5)))
+ (snd-display ";show-full-range 3.5 test: ~A" (y-bounds ns 0)))
(with-sound ("test.snd" :clipped #f :to-snd #f)
(fm-violin 0 1 440 1.5))
(update-sound ns)
- (when with-gui
- (if (or (fneq (car (y-bounds ns 0)) -1.5)
- (fneq (cadr (y-bounds ns 0)) 1.5))
- (snd-display #__line__ ";show-full-range 1.5 test: ~A" (y-bounds ns 0))))
+ (when (and with-gui
+ (or (fneq (car (y-bounds ns 0)) -1.5)
+ (fneq (cadr (y-bounds ns 0)) 1.5)))
+ (snd-display ";show-full-range 1.5 test: ~A" (y-bounds ns 0)))
(close-sound ns))
(set! *show-full-range* #f)
@@ -8058,14 +7723,14 @@ EDITS: 5
(set! *sync-style* sync-none)
(let ((ns (open-sound "2.snd")))
(if (not (= (sync ns) 0))
- (snd-display #__line__ ";sync-none open: ~A" (sync ns)))
+ (snd-display ";sync-none open: ~A" (sync ns)))
(set! (sync ns) 1)
(set! *sync-style* sync-by-sound)
(let ((ns1 (open-sound "1a.snd")))
(if (or ;(= (sync ns1) 0) ; this default changed 12.9
(= (sync ns1) 1)
(not (= (sync ns) 1)))
- (snd-display #__line__ ";sync-by-sound open: ~A" (list (sync ns) (sync ns1))))
+ (snd-display ";sync-by-sound open: ~A" (list (sync ns) (sync ns1))))
(close-sound ns1))
(close-sound ns))
(set! *sync-style* old-sync))
@@ -8075,8 +7740,8 @@ EDITS: 5
(let ((tag (catch #t
(lambda () (save-sound ind))
(lambda args args))))
- (if (integer? tag) (snd-display #__line__ ";save-viewed-sound: ~A" tag))
- (if (not (equal? (edits ind) (list 1 0))) (snd-display #__line__ ";view read-only ignored? ~A" (edits ind))))
+ (if (integer? tag) (snd-display ";save-viewed-sound: ~A" tag))
+ (if (not (equal? (edits ind) (list 1 0))) (snd-display ";view read-only ignored? ~A" (edits ind))))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
@@ -8096,7 +7761,7 @@ EDITS: 5
(map-channel (lambda (y) 1.0))
(env-sound '(0 0 1 1 2 0))
(let ((reader (make-sampler (- (framples) 1) ind 0 -1)))
- (if (not (= (sampler-position reader) (- (framples) 1))) (snd-display #__line__ ";sampler-position: ~A" (sampler-position reader)))
+ (if (not (= (sampler-position reader) (- (framples) 1))) (snd-display ";sampler-position: ~A" (sampler-position reader)))
(map-channel (lambda (y) (read-sample reader))))
(let ((e (make-env '(0 0 1 1 2 0) :length (+ 1 dur)))
(len (framples)))
@@ -8104,7 +7769,7 @@ EDITS: 5
(v1 (samples 0 len ind 0)))
(outa->fv v0 (env e))
(if (not (vequal v0 v1))
- (snd-display #__line__ "~%;trouble in reverse read ~A ~A" v0 v1))))
+ (snd-display "~%;trouble in reverse read ~A ~A" v0 v1))))
(revert-sound))
(list 150 1500 150000))
(close-sound ind))
@@ -8129,7 +7794,7 @@ EDITS: 5
(and (> i 700) (<= i 900)
(fneq new 0.0)))
(begin
- (format #t "~%;trouble in reverse read 2 at ~D ~A ~A" i old new)
+ (format () "~%;trouble in reverse read 2 at ~D ~A ~A" i old new)
(quit)))))))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
@@ -8141,16 +7806,12 @@ EDITS: 5
(if (= i 5)
(scale-channel 0.5 1000 12345))
(env-sound '(0 0 1 1 2.5 0 3 1 4 0))
- (if (= i 1)
- (delete-samples 50 100)
- (if (= i 2)
- (insert-samples 300 100 (make-float-vector 100 0.5))
- (if (= i 3)
- (scale-channel 0.0 1000 1000)
- (if (= i 4)
- (float-vector->channel (make-float-vector 100 .5) 500 100)
- (if (= i 6)
- (env-sound '(0 1 1 0) 10000 2000))))))
+ (case i
+ ((1) (delete-samples 50 100))
+ ((2) (insert-samples 300 100 (make-float-vector 100 0.5)))
+ ((3) (scale-channel 0.0 1000 1000))
+ ((4) (float-vector->channel (make-float-vector 100 0.5) 500 100))
+ ((6) (env-sound '(0 1 1 0) 10000 2000)))
(let ((reader (make-sampler (- (framples) 1) ind 0 -1)))
(map-channel (lambda (y) (read-sample reader))))
(let ((reader (make-sampler (- (framples) 1) ind 0 -1)))
@@ -8159,7 +7820,7 @@ EDITS: 5
(let ((v0 (samples 0 len ind 0 (- (edit-position ind 0) 2)))
(v1 (samples 0 len ind 0)))
(if (not (vequal v0 v1))
- (snd-display #__line__ "~%;trouble in reverse read ~A ~A" v0 v1))))
+ (snd-display "~%;trouble in reverse read ~A ~A" v0 v1))))
(set! (edit-position ind 0) edpos)))
(close-sound ind))
(let ((reader #f)
@@ -8181,102 +7842,102 @@ EDITS: 5
(let ((samp (sample 1000)))
(set! (cursor ind 0) 1000)
(if (fneq (sample) samp)
- (snd-display #__line__ ";sample no args: ~A ~A" (sample) samp)))
+ (snd-display ";sample no args: ~A ~A" (sample) samp)))
(set! val (my-scan-channel (lambda (y) (> y .1))))
(if (not (equal? val (list #t 4423)))
- (snd-display #__line__ ";my-scan-chan: ~A" val))
+ (snd-display ";my-scan-chan: ~A" val))
(set! val (scan-again))
(if (not (equal? val (list #t 4463)))
- (snd-display #__line__ ";scan-again: ~A" val))
+ (snd-display ";scan-again: ~A" val))
(set! (cursor) 1000)
(set! (sample) .5)
(if (fneq (sample 1000) .5)
- (snd-display #__line__ ";set sample no arg: ~A ~A" (sample 1000) (sample 0)))
+ (snd-display ";set sample no arg: ~A ~A" (sample 1000) (sample 0)))
(close-sound ind)))
;; edit-menu.scm tests
- (if (defined? 'selection->new)
- (let ((ind (view-sound "oboe.snd")))
- (make-selection 1000 1999 ind 0)
- (let ((newsnd (selection->new)))
- (if (not (sound? newsnd)) (snd-display #__line__ ";selection->new -> ~A" newsnd))
- (if (not (= (framples newsnd 0) 1000)) (snd-display #__line__ ";selection->new framples: ~A" (framples newsnd 0)))
- (if (not (equal? (edits ind 0) (list 0 0))) (snd-display #__line__ ";selection->new edited original? ~A" (edits ind 0)))
- (let ((newfile (file-name newsnd)))
- (close-sound newsnd)
- (delete-file newfile)
- (mus-sound-forget newfile)))
- (make-selection 1000 1999 ind 0)
- (let ((newsnd (cut-selection->new)))
- (if (not (sound? newsnd)) (snd-display #__line__ ";cut-selection->new -> ~A" newsnd))
- (if (not (= (framples newsnd 0) 1000)) (snd-display #__line__ ";cut-selection->new framples: ~A" (framples newsnd 0)))
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display #__line__ ";cut-selection->new did not edit original? ~A" (edits ind 0)))
- (if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
- (snd-display #__line__ ";cut-selection->new cut: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
- (undo 1 ind 0)
- (let ((newfile (file-name newsnd)))
- (close-sound newsnd)
- (delete-file newfile)
- (mus-sound-forget newfile)))
- (make-selection 1000 1999 ind 0)
- (append-selection)
- (if (not (= (framples ind 0) (+ (framples ind 0 0) 1000)))
- (snd-display #__line__ ";append-selection: ~A ~A" (framples ind 0) (framples ind 0 0)))
- (append-sound "oboe.snd")
- (if (not (= (framples ind 0) (+ (* 2 (framples ind 0 0)) 1000)))
- (snd-display #__line__ ";append-sound: ~A ~A" (framples ind 0) (framples ind 0 0)))
- (revert-sound ind)
- (let ((m1 (add-mark 1000))
- (m2 (add-mark 12000)))
- (trim-front)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display #__line__ ";time-front did not edit original? ~A" (edits ind 0)))
- (if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
- (snd-display #__line__ ";trim-front: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
- (if (not (= (mark-sample m2) 11000)) (snd-display #__line__ ";trim-front m2: ~A" (mark-sample m2)))
- (undo 1 ind 0)
- (trim-back)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display #__line__ ";time-back did not edit original? ~A" (edits ind 0)))
- (if (not (= (framples ind 0) 12001)) (snd-display #__line__ ";trim-back: ~A" (framples ind 0)))
- (if (not (= (mark-sample m1) 1000)) (snd-display #__line__ ";trim-back m1: ~A" (mark-sample m1)))
- (undo 1 ind 0)
- (add-mark 22000)
- (crop)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display #__line__ ";crop did not edit original? ~A" (edits ind 0)))
- (if (not (= (framples ind 0) 21001)) (snd-display #__line__ ";crop: ~A" (framples ind 0)))
- (undo 1 ind 0)
- (close-sound ind))))
+ (when (defined? 'selection->new)
+ (let ((ind (view-sound "oboe.snd")))
+ (make-selection 1000 1999 ind 0)
+ (let ((newsnd (selection->new)))
+ (if (not (sound? newsnd)) (snd-display ";selection->new -> ~A" newsnd))
+ (if (not (= (framples newsnd 0) 1000)) (snd-display ";selection->new framples: ~A" (framples newsnd 0)))
+ (if (not (equal? (edits ind 0) (list 0 0))) (snd-display ";selection->new edited original? ~A" (edits ind 0)))
+ (let ((newfile (file-name newsnd)))
+ (close-sound newsnd)
+ (delete-file newfile)
+ (mus-sound-forget newfile)))
+ (make-selection 1000 1999 ind 0)
+ (let ((newsnd (cut-selection->new)))
+ (if (not (sound? newsnd)) (snd-display ";cut-selection->new -> ~A" newsnd))
+ (if (not (= (framples newsnd 0) 1000)) (snd-display ";cut-selection->new framples: ~A" (framples newsnd 0)))
+ (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";cut-selection->new did not edit original? ~A" (edits ind 0)))
+ (if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
+ (snd-display ";cut-selection->new cut: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
+ (undo 1 ind 0)
+ (let ((newfile (file-name newsnd)))
+ (close-sound newsnd)
+ (delete-file newfile)
+ (mus-sound-forget newfile)))
+ (make-selection 1000 1999 ind 0)
+ (append-selection)
+ (if (not (= (framples ind 0) (+ (framples ind 0 0) 1000)))
+ (snd-display ";append-selection: ~A ~A" (framples ind 0) (framples ind 0 0)))
+ (append-sound "oboe.snd")
+ (if (not (= (framples ind 0) (+ (* 2 (framples ind 0 0)) 1000)))
+ (snd-display ";append-sound: ~A ~A" (framples ind 0) (framples ind 0 0)))
+ (revert-sound ind)
+ (let ((m1 (add-mark 1000))
+ (m2 (add-mark 12000)))
+ (trim-front)
+ (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";time-front did not edit original? ~A" (edits ind 0)))
+ (if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
+ (snd-display ";trim-front: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
+ (if (not (= (mark-sample m2) 11000)) (snd-display ";trim-front m2: ~A" (mark-sample m2)))
+ (undo 1 ind 0)
+ (trim-back)
+ (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";time-back did not edit original? ~A" (edits ind 0)))
+ (if (not (= (framples ind 0) 12001)) (snd-display ";trim-back: ~A" (framples ind 0)))
+ (if (not (= (mark-sample m1) 1000)) (snd-display ";trim-back m1: ~A" (mark-sample m1))))
+ (undo 1 ind 0)
+ (add-mark 22000)
+ (crop)
+ (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";crop did not edit original? ~A" (edits ind 0)))
+ (if (not (= (framples ind 0) 21001)) (snd-display ";crop: ~A" (framples ind 0)))
+ (undo 1 ind 0)
+ (close-sound ind)))
(let ((ind (new-sound "test.snd")))
(map-channel (lambda (y) 1.0) 0 1001)
(env-channel (make-env '(0 1 1 1) :scaler .5 :length 1001))
- (check-maxamp #__line__ ind .5 "simple scaler")
+ (check-maxamp ind .5 "simple scaler")
(check-env-vals "simple scaler" (make-env '(0 1 1 1) :scaler .5 :length 1001))
(if (= (edit-position) 2)
(undo)
- (snd-display #__line__ ";env+scl was no-op"))
+ (snd-display ";env+scl was no-op"))
(env-channel (make-env '(0 1 1 1) :offset .5 :length 1001))
- (check-maxamp #__line__ ind 1.5 "simple offset")
+ (check-maxamp ind 1.5 "simple offset")
(check-env-vals "simple offset" (make-env '(0 1 1 1) :offset .5 :length 1001))
(if (= (edit-position) 2)
(undo)
- (snd-display #__line__ ";env+offset was no-op"))
+ (snd-display ";env+offset was no-op"))
(env-channel (make-env '(0 0 1 1 2 0) :offset .5 :scaler 2.0 :length 1001))
- (check-maxamp #__line__ ind 2.5 "off+scl")
+ (check-maxamp ind 2.5 "off+scl")
(check-env-vals "off+scl" (make-env '(0 0 1 1 2 0) :offset .5 :scaler 2.0 :length 1001))
(undo)
(env-channel (make-env '(0 -0.5 1 0 2 -1) :offset .5 :scaler 2.0 :length 1001))
- (check-maxamp #__line__ ind 1.5 "off+scl #2")
+ (check-maxamp ind 1.5 "off+scl #2")
(let ((mx -12.0))
(scan-channel (lambda (y) (not (set! mx (max mx y)))))
- (if (fneq mx 0.5) (snd-display #__line__ ";non abs max: ~A (correct: 0.5)" mx)))
+ (if (fneq mx 0.5) (snd-display ";non abs max: ~A (correct: 0.5)" mx)))
(check-env-vals "off+scl #2" (make-env '(0 -0.5 1 0 2 -1) :offset .5 :scaler 2.0 :length 1001))
(undo)
(env-sound '(0 .5 1 .75 2 .25) 0 (framples) 32.0)
- (check-maxamp #__line__ ind 0.75 "xramp")
+ (check-maxamp ind 0.75 "xramp")
(check-env-vals "xramp" (make-env '(0 .5 1 .75 2 .25) :base 32.0 :length 1001))
(undo)
(env-channel-with-base '(0 .5 1 .75 2 .25) 32.0)
- (check-maxamp #__line__ ind 0.75 "xramp1")
+ (check-maxamp ind 0.75 "xramp1")
(check-env-vals "xramp1" (make-env '(0 .5 1 .75 2 .25) :base 32.0 :length 1001))
(close-sound ind))
@@ -8287,7 +7948,7 @@ EDITS: 5
((= i 20))
(set! (data i) (hilbert-transform hlb (if (= i 0) 1.0 0.0))))
(if (not (vequal data (float-vector 0.0 -0.010 0.0 -0.046 0.0 -0.152 0.0 -0.614 0.0 0.614 0.0 0.152 0.0 0.046 0.0 0.010 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";hilbert-transform 8 impulse response: ~A" data)))
+ (snd-display ";hilbert-transform 8 impulse response: ~A" data)))
(let ((hlb (make-hilbert-transform 7))
(data (make-float-vector 20)))
@@ -8295,54 +7956,48 @@ EDITS: 5
((= i 20))
(set! (data i) (hilbert-transform hlb (if (= i 0) 1.0 0.0))))
(if (not (vequal data (float-vector -0.007 0.0 -0.032 0.0 -0.136 0.0 -0.608 0.0 0.608 0.0 0.136 0.0 0.032 0.0 0.007 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";hilbert-transform 7 impulse response: ~A" data)))
+ (snd-display ";hilbert-transform 7 impulse response: ~A" data)))
(let ((ind (new-sound "test.snd")))
(pad-channel 0 1000)
(set! (sample 100) 1.0)
(let ((h (make-hilbert-transform 100)))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (map-channel (lambda (y) (hilbert-transform h y))))
;; now ideally we'd be back to an impulse
(if (> (abs (- (sample 500) .98)) .01)
- (snd-display #__line__ ";hilbert impulse: ~A" (sample 500)))
+ (snd-display ";hilbert impulse: ~A" (sample 500)))
(set! (sample 500) 0.0)
(if (> (maxamp ind 0) .02)
- (snd-display #__line__ ";hilbert sidelobes: ~A" (maxamp ind 0)))
+ (snd-display ";hilbert sidelobes: ~A" (maxamp ind 0)))
(scale-channel 0.0)
(set! (sample 100) 1.0)
(set! h (make-hilbert-transform 101))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
- (map-channel (lambda (y) (hilbert-transform h y)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (map-channel (lambda (y) (hilbert-transform h y))))
(if (> (abs (- (sample 504) .98)) .01)
- (snd-display #__line__ ";hilbert 101 impulse: ~A: ~A" (sample 504) (channel->float-vector 498 10)))
+ (snd-display ";hilbert 101 impulse: ~A: ~A" (sample 504) (channel->float-vector 498 10)))
(set! (sample 504) 0.0)
(if (> (maxamp ind 0) .02)
- (snd-display #__line__ ";hilbert 101 sidelobes: ~A" (maxamp ind 0)))
+ (snd-display ";hilbert 101 sidelobes: ~A" (maxamp ind 0)))
(revert-sound))
(pad-channel 0 1000)
(set! (sample 100) 1.0)
(let ((lo (make-lowpass (* .1 pi) 20))
(hi (make-highpass (* .1 pi) 20)))
- (map-channel (lambda (y) (+ (lowpass lo y) (highpass hi y))))
- (if (fneq (sample 120) 1.0)
- (snd-display #__line__ ";lowpass+highpass impulse: ~A" (sample 120)))
- (set! (sample 120) 0.0)
- (if (fneq (maxamp ind 0) 0.0)
- (snd-display #__line__ ";lowpass+highpass sidelobes: ~A" (maxamp ind 0))))
+ (map-channel (lambda (y) (+ (lowpass lo y) (highpass hi y)))))
+ (if (fneq (sample 120) 1.0)
+ (snd-display ";lowpass+highpass impulse: ~A" (sample 120)))
+ (set! (sample 120) 0.0)
+ (if (fneq (maxamp ind 0) 0.0)
+ (snd-display ";lowpass+highpass sidelobes: ~A" (maxamp ind 0)))
(undo 2)
(let ((lo (make-bandpass (* .1 pi) (* .2 pi) 20))
(hi (make-bandstop (* .1 pi) (* .2 pi) 20)))
- (map-channel (lambda (y) (+ (bandpass lo y) (bandstop hi y))))
- (if (fneq (sample 120) 1.0)
- (snd-display #__line__ ";bandpass+bandstop impulse: ~A" (sample 120)))
- (set! (sample 120) 0.0)
- (if (fneq (maxamp ind 0) 0.0)
- (snd-display #__line__ ";bandpass+bandstop sidelobes: ~A" (maxamp ind 0))))
+ (map-channel (lambda (y) (+ (bandpass lo y) (bandstop hi y)))))
+ (if (fneq (sample 120) 1.0)
+ (snd-display ";bandpass+bandstop impulse: ~A" (sample 120)))
+ (set! (sample 120) 0.0)
+ (if (fneq (maxamp ind 0) 0.0)
+ (snd-display ";bandpass+bandstop sidelobes: ~A" (maxamp ind 0)))
(close-sound ind))
(let ((ind (new-sound "test.snd")))
@@ -8357,7 +8012,7 @@ EDITS: 5
(let ((data1 (channel->float-vector)))
(float-vector-subtract! data data1)
(if (> (float-vector-peak data) .00001)
- (snd-display #__line__ ";fir-filter 2: ~A" (float-vector-peak data))))
+ (snd-display ";fir-filter 2: ~A" (float-vector-peak data))))
(undo))))
(close-sound ind))
@@ -8378,7 +8033,7 @@ EDITS: 5
(f2)
(let ((v2 (channel->float-vector 0 100 ind 0)))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
+ (snd-display ";env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))
(if try-scale
(begin
@@ -8390,7 +8045,7 @@ EDITS: 5
(scale-by 2.0)
(let ((v2 (channel->float-vector 0 100 ind 0)))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";scaled (2) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
+ (snd-display ";scaled (2) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))
(f1)
(scale-by .5)
@@ -8400,7 +8055,7 @@ EDITS: 5
(f2)
(let ((v2 (channel->float-vector 0 100 ind 0)))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";scaled (.5) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
+ (snd-display ";scaled (.5) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))))))
(list (list "ramp-xramp" #t
@@ -8456,27 +8111,27 @@ EDITS: 5
(as-one-edit
(lambda ()
(set! (sample 10) 1.0)))
- (if (fneq (sample 10) 1.0) (snd-display #__line__ ";as-one-edit 1: ~A" (sample 10)))
+ (if (fneq (sample 10) 1.0) (snd-display ";as-one-edit 1: ~A" (sample 10)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";as-one-edit 1 edpos: ~A" (edit-position ind 0))
+ (snd-display ";as-one-edit 1 edpos: ~A" (edit-position ind 0))
(begin
(if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 1 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 1 edlist: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
- (snd-display #__line__ ";as-one-edit 1 original edlist: ~A" (edit-fragment 0 ind 0)))))
+ (snd-display ";as-one-edit 1 original edlist: ~A" (edit-fragment 0 ind 0)))))
(revert-sound ind)
(as-one-edit
(lambda ()
(set! (sample 10) 1.0)
(map-channel (lambda (y) (* y 2.0)) 0 20 ind 0 #f "map-channel as-one-edit")
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";as-one-edit 2 edpos internal: ~A" (edit-position ind 0))))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";as-one-edit 2 edpos internal: ~A" (edit-position ind 0))))
"as-one-edit test-2")
- (if (fneq (sample 10) 2.0) (snd-display #__line__ ";as-one-edit 2: ~A" (sample 10)))
+ (if (fneq (sample 10) 2.0) (snd-display ";as-one-edit 2: ~A" (sample 10)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";as-one-edit 2 edpos: ~A" (edit-position ind 0))
+ (snd-display ";as-one-edit 2 edpos: ~A" (edit-position ind 0))
(if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
- (snd-display #__line__ ";as-one-edit 2 original edlist: ~A" (edit-fragment 0 ind 0))))
+ (snd-display ";as-one-edit 2 original edlist: ~A" (edit-fragment 0 ind 0))))
(revert-sound ind)
(let ((ind2 (open-sound "2a.snd")))
@@ -8487,16 +8142,16 @@ EDITS: 5
(as-one-edit
(lambda ()
(set! (sample 10 ind 0) 1.0)))
- (if (fneq (sample 10 ind 0) 1.0) (snd-display #__line__ ";as-one-edit 3: ~A" (sample 10 ind 0)))
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";as-one-edit 3 edpos: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind2 0) 1)) (snd-display #__line__ ";as-one-edit 3 2 edpos: ~A" (edit-position ind2 0)))
- (if (not (= (edit-position ind2 1) 1)) (snd-display #__line__ ";as-one-edit 3 2 1 edpos: ~A" (edit-position ind2 1)))
+ (if (fneq (sample 10 ind 0) 1.0) (snd-display ";as-one-edit 3: ~A" (sample 10 ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 3 edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind2 0) 1)) (snd-display ";as-one-edit 3 2 edpos: ~A" (edit-position ind2 0)))
+ (if (not (= (edit-position ind2 1) 1)) (snd-display ";as-one-edit 3 2 1 edpos: ~A" (edit-position ind2 1)))
(if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 3 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 3 edlist: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 1 1.0000" "set" 1 1)))
- (snd-display #__line__ ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
+ (snd-display ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
(if (not (equal? (edit-fragment 1 ind2 1) (list "set-sample 2 0.5000" "set" 2 1)))
- (snd-display #__line__ ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
+ (snd-display ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
(revert-sound ind)
@@ -8504,15 +8159,15 @@ EDITS: 5
(lambda ()
(set! (sample 10 ind 0) 1.0)
(map-channel (lambda (y) (* y 2.0)) 0 20 ind 0 #f "map-channel as-one-edit 2")
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";as-one-edit 4 edpos internal: ~A" (edit-position ind 0))))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";as-one-edit 4 edpos internal: ~A" (edit-position ind 0))))
"as-one-edit test-4")
- (if (fneq (sample 10) 2.0) (snd-display #__line__ ";as-one-edit 4: ~A" (sample 10 ind 0)))
+ (if (fneq (sample 10) 2.0) (snd-display ";as-one-edit 4: ~A" (sample 10 ind 0)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";as-one-edit 4 edpos: ~A" (edit-position ind 0)))
+ (snd-display ";as-one-edit 4 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 1 1.0000" "set" 1 1)))
- (snd-display #__line__ ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
+ (snd-display ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
(if (not (equal? (edit-fragment 1 ind2 1) (list "set-sample 2 0.5000" "set" 2 1)))
- (snd-display #__line__ ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
+ (snd-display ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
(revert-sound ind)
(set! (sample 3 ind 0) 1.0)
@@ -8522,22 +8177,22 @@ EDITS: 5
(set! (sample 10 ind 0) 1.0)
(set! (sample 10 ind2 0) 0.5)
(set! (sample 10 ind2 1) 0.4)))
- (if (fneq (sample 3 ind 0) 1.0) (snd-display #__line__ ";as-one-edit 5 (3): ~A" (sample 3 ind 0)))
- (if (fneq (sample 10 ind 0) 1.0) (snd-display #__line__ ";as-one-edit 5 (10): ~A" (sample 10 ind 0)))
- (if (fneq (sample 10 ind2 0) 0.5) (snd-display #__line__ ";as-one-edit 5 (2 10): ~A" (sample 10 ind2 0)))
- (if (fneq (sample 10 ind2 1) 0.4) (snd-display #__line__ ";as-one-edit 5 (2 1 10): ~A" (sample 10 ind2 1)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";as-one-edit 5 edpos: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind2 0) 2)) (snd-display #__line__ ";as-one-edit 5 2 edpos: ~A" (edit-position ind2 0)))
- (if (not (= (edit-position ind2 1) 2)) (snd-display #__line__ ";as-one-edit 5 2 1 edpos: ~A" (edit-position ind2 1)))
+ (if (fneq (sample 3 ind 0) 1.0) (snd-display ";as-one-edit 5 (3): ~A" (sample 3 ind 0)))
+ (if (fneq (sample 10 ind 0) 1.0) (snd-display ";as-one-edit 5 (10): ~A" (sample 10 ind 0)))
+ (if (fneq (sample 10 ind2 0) 0.5) (snd-display ";as-one-edit 5 (2 10): ~A" (sample 10 ind2 0)))
+ (if (fneq (sample 10 ind2 1) 0.4) (snd-display ";as-one-edit 5 (2 1 10): ~A" (sample 10 ind2 1)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";as-one-edit 5 edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind2 0) 2)) (snd-display ";as-one-edit 5 2 edpos: ~A" (edit-position ind2 0)))
+ (if (not (= (edit-position ind2 1) 2)) (snd-display ";as-one-edit 5 2 1 edpos: ~A" (edit-position ind2 1)))
(if (not (equal? (edit-fragment 2 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 3 1.0000" "set" 3 1)))
- (snd-display #__line__ ";as-one-edit 5 edlist 1: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 5 edlist 1: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
- (snd-display #__line__ ";as-one-edit 5 original edlist: ~A" (edit-fragment 0 ind 0)))
+ (snd-display ";as-one-edit 5 original edlist: ~A" (edit-fragment 0 ind 0)))
(if (not (equal? (edit-fragment 2 ind2 0) (list "set-sample 10 0.5000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
+ (snd-display ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
(as-one-edit
(lambda ()
@@ -8546,18 +8201,18 @@ EDITS: 5
"as-one-edit test-6")
- (if (fneq (sample 3 ind 0) 2.0) (snd-display #__line__ ";as-one-edit 6 (3): ~A" (sample 3 ind 0)))
- (if (fneq (sample 10 ind 0) 2.0) (snd-display #__line__ ";as-one-edit 6 (10): ~A" (sample 10 ind 0)))
- (if (fneq (sample 10 ind2 0) 0.5) (snd-display #__line__ ";as-one-edit 6 (2 10): ~A" (sample 10 ind2 0)))
- (if (fneq (sample 10 ind2 1) 0.8) (snd-display #__line__ ";as-one-edit 6 (2 1 10): ~A" (sample 10 ind2 1)))
- (if (not (= (edit-position ind 0) 3)) (snd-display #__line__ ";as-one-edit 6 edpos: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind2 0) 2)) (snd-display #__line__ ";as-one-edit 6 2 edpos: ~A" (edit-position ind2 0)))
- (if (not (= (edit-position ind2 1) 3)) (snd-display #__line__ ";as-one-edit 6 2 1 edpos: ~A" (edit-position ind2 1)))
+ (if (fneq (sample 3 ind 0) 2.0) (snd-display ";as-one-edit 6 (3): ~A" (sample 3 ind 0)))
+ (if (fneq (sample 10 ind 0) 2.0) (snd-display ";as-one-edit 6 (10): ~A" (sample 10 ind 0)))
+ (if (fneq (sample 10 ind2 0) 0.5) (snd-display ";as-one-edit 6 (2 10): ~A" (sample 10 ind2 0)))
+ (if (fneq (sample 10 ind2 1) 0.8) (snd-display ";as-one-edit 6 (2 1 10): ~A" (sample 10 ind2 1)))
+ (if (not (= (edit-position ind 0) 3)) (snd-display ";as-one-edit 6 edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind2 0) 2)) (snd-display ";as-one-edit 6 2 edpos: ~A" (edit-position ind2 0)))
+ (if (not (= (edit-position ind2 1) 3)) (snd-display ";as-one-edit 6 2 1 edpos: ~A" (edit-position ind2 1)))
(if (not (equal? (edit-fragment 2 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 2 ind2 0) (list "set-sample 10 0.5000" "set" 10 1)))
- (snd-display #__line__ ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
+ (snd-display ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
(close-sound ind2))
;; nested cases
@@ -8574,15 +8229,15 @@ EDITS: 5
(if (or (fneq (sample 100) .9)
(fneq (sample 200) .8)
(fneq (sample 300) .6))
- (snd-display #__line__ ";nested as-one-edit 7: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
+ (snd-display ";nested as-one-edit 7: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";nested as-one-edit 7 edpos: ~A" (edit-position ind 0)))
+ (snd-display ";nested as-one-edit 7 edpos: ~A" (edit-position ind 0)))
(if (squelch-update ind 0)
(begin
- (snd-display #__line__ ";nested as-one-edit 7 squelch is on")
+ (snd-display ";nested as-one-edit 7 squelch is on")
(set! (squelch-update) #f)))
(if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 300 0.6000" "set" 100 204)))
- (snd-display #__line__ ";as-one-edit 7 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 7 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
(as-one-edit
@@ -8597,11 +8252,11 @@ EDITS: 5
(if (or (fneq (sample 100) .9)
(fneq (sample 200) .8)
(fneq (sample 300) .6))
- (snd-display #__line__ ";nested as-one-edit 8: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
+ (snd-display ";nested as-one-edit 8: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";nested as-one-edit 8 edpos: ~A" (edit-position ind 0)))
+ (snd-display ";nested as-one-edit 8 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-8" "set" 100 204)))
- (snd-display #__line__ ";as-one-edit 8 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 8 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
(as-one-edit
@@ -8617,11 +8272,11 @@ EDITS: 5
(if (or (fneq (sample 100) .9)
(fneq (sample 200) .8)
(fneq (sample 300) .6))
- (snd-display #__line__ ";nested as-one-edit 9: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
+ (snd-display ";nested as-one-edit 9: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";nested as-one-edit 9 edpos: ~A" (edit-position ind 0)))
+ (snd-display ";nested as-one-edit 9 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-9" "set" 100 204)))
- (snd-display #__line__ ";as-one-edit 9 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 9 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
(as-one-edit
@@ -8642,28 +8297,28 @@ EDITS: 5
(fneq (sample 200) .8)
(fneq (sample 300) .6)
(fneq (sample 400) .3))
- (snd-display #__line__ ";nested as-one-edit 10: ~A ~A ~A ~A" (sample 100) (sample 200) (sample 300) (sample 400)))
+ (snd-display ";nested as-one-edit 10: ~A ~A ~A ~A" (sample 100) (sample 200) (sample 300) (sample 400)))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";nested as-one-edit 10 edpos: ~A" (edit-position ind 0)))
+ (snd-display ";nested as-one-edit 10 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-10" "set" 100 305)))
- (snd-display #__line__ ";as-one-edit 10 edlist: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 10 edlist: ~A" (edit-fragment 1 ind 0)))
;; try implicit as-one-edits nested
(revert-sound ind)
(env-channel-with-base '(0 0 1 1 2 .5 3 .25 4 0) 0.0 0 #f ind 0)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";as-one-edit 11 edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 11 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0)
(list "env-channel-with-base '(0.000 0.000 1.000 1.000 2.000 0.500 3.000 0.250 4.000 0.000) 0.0000 0 #f" "scale" 0 50830)))
- (snd-display #__line__ ";as-one-edit 11: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 11: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
(as-one-edit
(lambda ()
(env-channel-with-base '(0 0 1 1 2 .5 3 .25 4 0) 0.0 0 #f ind 0))
"as-one-edit 12")
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";as-one-edit 12 edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 12 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit 12" "scale" 0 50830)))
- (snd-display #__line__ ";as-one-edit 12: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit 12: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
(let ((m1 #f)
@@ -8679,8 +8334,8 @@ EDITS: 5
(set! (sample 123 ind 0) .3)
(set! m2 (add-mark 1235 ind 0)))
"as-one-edit inner 1")
- (if (not (mark? m1)) (snd-display #__line__ ";as-one-edit stepped on m1: ~A" m1))
- (if (not (mark? m2)) (snd-display #__line__ ";as-one-edit stepped on m2: ~A" m2))
+ (if (not (mark? m1)) (snd-display ";as-one-edit stepped on m1: ~A" m1))
+ (if (not (mark? m2)) (snd-display ";as-one-edit stepped on m2: ~A" m2))
(as-one-edit
(lambda ()
(set! m3 (add-mark 1238 ind 0))
@@ -8689,15 +8344,15 @@ EDITS: 5
(set! (sample 1239 ind 0) .9)
(set! m4 (add-mark 1237 ind 0)))
"outer as-one-edit")
- (if (not (mark? m1)) (snd-display #__line__ ";second as-one-edit stepped on m1: ~A" m1))
- (if (not (mark? m2)) (snd-display #__line__ ";second as-one-edit stepped on m2: ~A" m2))
- (if (not (mark? m3)) (snd-display #__line__ ";second as-one-edit stepped on m3: ~A" m3))
- (if (not (mark? m4)) (snd-display #__line__ ";second as-one-edit stepped on m4: ~A" m4))
- (if (not (= (mark-sample m1) 1234)) (snd-display #__line__ ";as-one-edit m1 sample: ~A (1234)" (mark-sample m1)))
- (if (not (= (mark-sample m2) 1235)) (snd-display #__line__ ";as-one-edit m2 sample: ~A (1235)" (mark-sample m2)))
- (if (not (= (mark-sample m3) 1238)) (snd-display #__line__ ";as-one-edit m3 sample: ~A (1238)" (mark-sample m3)))
- (if (not (= (mark-sample m4) 1237)) (snd-display #__line__ ";as-one-edit m4 sample: ~A (1237)" (mark-sample m4)))
- (if (not (string=? (display-edits ind 0) (string-append "
+ (if (not (mark? m1)) (snd-display ";second as-one-edit stepped on m1: ~A" m1))
+ (if (not (mark? m2)) (snd-display ";second as-one-edit stepped on m2: ~A" m2))
+ (if (not (mark? m3)) (snd-display ";second as-one-edit stepped on m3: ~A" m3))
+ (if (not (mark? m4)) (snd-display ";second as-one-edit stepped on m4: ~A" m4))
+ (if (not (= (mark-sample m1) 1234)) (snd-display ";as-one-edit m1 sample: ~A (1234)" (mark-sample m1)))
+ (if (not (= (mark-sample m2) 1235)) (snd-display ";as-one-edit m2 sample: ~A (1235)" (mark-sample m2)))
+ (if (not (= (mark-sample m3) 1238)) (snd-display ";as-one-edit m3 sample: ~A (1238)" (mark-sample m3)))
+ (if (not (= (mark-sample m4) 1237)) (snd-display ";as-one-edit m4 sample: ~A (1237)" (mark-sample m4))))
+ (if (not (string=? (display-edits ind 0) (string-append "
EDITS: 1
(begin) [0:2]:
@@ -8715,37 +8370,36 @@ EDITS: 1
(at 1240, cp->sounds[0][1240:50827, 1.000]) [file: " cwd "oboe.snd[0]]
(at 50828, end_mark)
")))
- (snd-display #__line__ ";as-one-edit edits: ~A" (display-edits ind 0)))
-
- (revert-sound ind))
+ (snd-display ";as-one-edit edits: ~A" (display-edits ind 0)))
+ (revert-sound ind)
- (let ((m1 #f)
- (m2 #f)
- (m3 #f)
+ (let ((m3 #f)
(m4 #f))
- (as-one-edit
- (lambda ()
- (set! m1 (mix-float-vector (float-vector .1 .2 .3) 1234 ind 0))
- (set! (sample 1236 ind 0) .6)
- (as-one-edit
- (lambda ()
- (set! (sample 123 ind 0) .3)
- (set! m2 (mix-float-vector (float-vector .1 .2 .3) 1235 ind 0)))
- "as-one-edit inner 1")
- (if (not (mix? m1)) (snd-display #__line__ ";as-one-edit stepped on m1: ~A" m1))
- (if (not (mix? m2)) (snd-display #__line__ ";as-one-edit stepped on m2: ~A" m2))
- (as-one-edit
- (lambda ()
- (set! m3 (mix-float-vector (float-vector .1 .2 .3) 1238 ind 0))
- (set! (sample 1238 ind 0) .8))
- "as-one-edit inner 2")
- (set! (sample 1239 ind 0) .9)
- (set! m4 (mix-float-vector (float-vector .1 .2 .3) 1237 ind 0)))
- "outer as-one-edit")
- (if (not (mix? m1)) (snd-display #__line__ ";second as-one-edit stepped on mx1: ~A" m1))
- (if (not (mix? m2)) (snd-display #__line__ ";second as-one-edit stepped on mx2: ~A" m2))
- (if (not (mix? m3)) (snd-display #__line__ ";second as-one-edit stepped on mx3: ~A" m3))
- (if (not (mix? m4)) (snd-display #__line__ ";second as-one-edit stepped on mx4: ~A" m4))
+ (let ((m2 #f))
+ (let ((m1 #f))
+ (as-one-edit
+ (lambda ()
+ (set! m1 (mix-float-vector (float-vector .1 .2 .3) 1234 ind 0))
+ (set! (sample 1236 ind 0) .6)
+ (as-one-edit
+ (lambda ()
+ (set! (sample 123 ind 0) .3)
+ (set! m2 (mix-float-vector (float-vector .1 .2 .3) 1235 ind 0)))
+ "as-one-edit inner 1")
+ (if (not (mix? m1)) (snd-display ";as-one-edit stepped on m1: ~A" m1))
+ (if (not (mix? m2)) (snd-display ";as-one-edit stepped on m2: ~A" m2))
+ (as-one-edit
+ (lambda ()
+ (set! m3 (mix-float-vector (float-vector .1 .2 .3) 1238 ind 0))
+ (set! (sample 1238 ind 0) .8))
+ "as-one-edit inner 2")
+ (set! (sample 1239 ind 0) .9)
+ (set! m4 (mix-float-vector (float-vector .1 .2 .3) 1237 ind 0)))
+ "outer as-one-edit")
+ (if (not (mix? m1)) (snd-display ";second as-one-edit stepped on mx1: ~A" m1)))
+ (if (not (mix? m2)) (snd-display ";second as-one-edit stepped on mx2: ~A" m2)))
+ (if (not (mix? m3)) (snd-display ";second as-one-edit stepped on mx3: ~A" m3))
+ (if (not (mix? m4)) (snd-display ";second as-one-edit stepped on mx4: ~A" m4))
(revert-sound ind))
(let ((ind2 #f))
@@ -8755,13 +8409,13 @@ EDITS: 1
(set! (sample 100 ind 0) .5)
(set! (sample 200 ind2 0) .6))
"as-one-edit+open")
- (if (not (sound? ind2)) (snd-display #__line__ ";as-one-edit didn't open sound? ~A ~A" ind2 (sounds)))
- (if (not (= (edit-position ind2 0) 1)) (snd-display #__line__ ";edpos as-one-edit opened sound: ~A" (edit-position ind2 0)))
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";edpos as-one-edit original sound: ~A" (edit-position ind 0)))
+ (if (not (sound? ind2)) (snd-display ";as-one-edit didn't open sound? ~A ~A" ind2 (sounds)))
+ (if (not (= (edit-position ind2 0) 1)) (snd-display ";edpos as-one-edit opened sound: ~A" (edit-position ind2 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";edpos as-one-edit original sound: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit+open" "set" 100 1)))
- (snd-display #__line__ ";as-one-edit open sound edlist orig: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";as-one-edit open sound edlist orig: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 200 0.6000" "set" 200 1)))
- (snd-display #__line__ ";as-one-edit open sound edlist new: ~A" (edit-fragment 1 ind2 0)))
+ (snd-display ";as-one-edit open sound edlist new: ~A" (edit-fragment 1 ind2 0)))
(as-one-edit
(lambda ()
@@ -8770,9 +8424,9 @@ EDITS: 1
"as-one-edit+close")
(if (sound? ind2)
(begin
- (snd-display #__line__ ";as-one-edit didn't close sound? ~A ~A" ind2 (sounds))
+ (snd-display ";as-one-edit didn't close sound? ~A ~A" ind2 (sounds))
(close-sound ind2)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";edpos as-one-edit close original sound: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";edpos as-one-edit close original sound: ~A" (edit-position ind 0)))
(if (not (string=? (display-edits ind 0) (string-append "
EDITS: 2
@@ -8794,7 +8448,7 @@ EDITS: 2
(at 201, cp->sounds[0][201:50827, 1.000]) [file: " cwd "oboe.snd[0]]
(at 50828, end_mark)
")))
- (snd-display #__line__ ";as-one-edit open+close: ~A" (display-edits ind 0))))
+ (snd-display ";as-one-edit open+close: ~A" (display-edits ind 0))))
(close-sound ind))
@@ -8811,8 +8465,8 @@ EDITS: 2
"inner edit")
(set! (sample 300 ind2 0) .6))
"outer edit")
- (if (sound? ind1) (snd-display #__line__ ";as-one-edit close inner: ~A ~A" ind1 (sounds)))
- (if (not (sound? ind2)) (snd-display #__line__ ";as-one-edit open inner: ~A ~A" ind2 (sounds)))
+ (if (sound? ind1) (snd-display ";as-one-edit close inner: ~A ~A" ind1 (sounds)))
+ (if (not (sound? ind2)) (snd-display ";as-one-edit open inner: ~A ~A" ind2 (sounds)))
(revert-sound ind2)
(as-one-edit
@@ -8827,60 +8481,59 @@ EDITS: 2
(close-sound ind1)
(close-sound ind2))
- (let* ((ind (open-sound "oboe.snd"))
- (mx (maxamp ind 0)))
+ (let ((ind (open-sound "oboe.snd")))
(let ((tag (catch #t
(lambda () (as-one-edit (lambda (oops) #f)))
(lambda args (car args)))))
(if (not (eq? tag 'bad-arity))
- (snd-display #__line__ ";as-one-edit arg? ~A" tag)))
+ (snd-display ";as-one-edit arg? ~A" tag)))
(let ((tag (catch #t
(lambda () (as-one-edit (lambda* (oops) #f)))
(lambda args (car args)))))
(if (not (eq? tag 'bad-arity))
- (snd-display #__line__ ";as-one-edit arg? ~A" tag)))
+ (snd-display ";as-one-edit arg? ~A" tag)))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "more tests" 10)))
;; offset-channel
(offset-channel .1)
(if (not (vequal (channel->float-vector 0 10) (make-float-vector 10 .1)))
- (snd-display #__line__ ";offset-channel (.1): ~A" (channel->float-vector 0 10)))
+ (snd-display ";offset-channel (.1): ~A" (channel->float-vector 0 10)))
(offset-channel -.2 5 5)
(if (not (vequal (channel->float-vector 0 10) (float-vector .1 .1 .1 .1 .1 -.1 -.1 -.1 -.1 -.1)))
- (snd-display #__line__ ";offset-channel (-.1): ~A" (channel->float-vector 0 10)))
+ (snd-display ";offset-channel (-.1): ~A" (channel->float-vector 0 10)))
(undo)
(offset-channel .9 0 10 ind 0)
(if (not (vequal (channel->float-vector 0 10) (make-float-vector 10 1.0)))
- (snd-display #__line__ ";offset-channel (1): ~A" (channel->float-vector 0 10)))
+ (snd-display ";offset-channel (1): ~A" (channel->float-vector 0 10)))
;; sine-env and sine-ramp...
(revert-sound ind)
(map-channel (lambda (y) 1.0))
(sine-ramp 0.0 1.0)
(if (not (vequal (channel->float-vector) (float-vector 0.000 0.024 0.095 0.206 0.345 0.500 0.655 0.794 0.905 0.976)))
- (snd-display #__line__ ";sine-ramp 0 1: ~A" (channel->float-vector)))
+ (snd-display ";sine-ramp 0 1: ~A" (channel->float-vector)))
(revert-sound ind)
(offset-channel 1.0)
(sine-ramp 1.0 0.0)
(if (not (vequal (channel->float-vector) (float-vector 1.000 0.976 0.905 0.794 0.655 0.500 0.345 0.206 0.095 0.024)))
- (snd-display #__line__ ";sine-ramp 1 0: ~A" (channel->float-vector)))
+ (snd-display ";sine-ramp 1 0: ~A" (channel->float-vector)))
(close-sound ind)
(set! ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "sine-env tests" 100))
(map-channel (lambda (y) 1.0))
(sine-env-channel '(0 0 1 1 2 -.5 3 1))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";as-one-edit sine-env-channel: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";as-one-edit sine-env-channel: ~A" (edit-position ind 0)))
(revert-sound ind)
(offset-channel -1.0)
(sine-env-channel '(0 0 1 1 2 1 3 0) 40 20)
- (if (or (not (vequal (channel->float-vector 40 20) (float-vector -0.000 -0.050 -0.188 -0.389 -0.611 -0.812 -0.950 -1.000 -1.000 -1.000
- -1.000 -1.000 -1.000 -1.000 -1.000 -0.950 -0.812 -0.611 -0.389 -0.188)))
- (not (vequal (channel->float-vector 30 10) (make-float-vector 10 -1.0))))
- (snd-display #__line__ ";off+sine-env: ~A ~A" (channel->float-vector 40 20) (channel->float-vector 30 10)))
+ (if (not (and (vequal (channel->float-vector 40 20) (float-vector -0.000 -0.050 -0.188 -0.389 -0.611 -0.812 -0.950 -1.000 -1.000 -1.000
+ -1.000 -1.000 -1.000 -1.000 -1.000 -0.950 -0.812 -0.611 -0.389 -0.188))
+ (vequal (channel->float-vector 30 10) (make-float-vector 10 -1.0))))
+ (snd-display ";off+sine-env: ~A ~A" (channel->float-vector 40 20) (channel->float-vector 30 10)))
(revert-sound ind)
(scale-by 0.0)
(dither-channel)
(let ((mx (maxamp)))
- (if (or (< mx .00003) (> mx .0001))
- (snd-display #__line__ ";dithering: ~A" mx)))
+ (if (not (<= 3e-05 mx 0.0001))
+ (snd-display ";dithering: ~A" mx)))
(revert-sound ind)
(map-channel (ring-mod 10 (list 0 0 1 (hz->radians 100))))
(osc-formants .99 (float-vector 400.0 800.0 1200.0) (float-vector 400.0 800.0 1200.0) (float-vector 4.0 2.0 3.0))
@@ -8893,9 +8546,9 @@ EDITS: 2
(map-channel (notch-filter .8 32))
(let ((ind1 (open-sound "now.snd")))
(select-sound ind1)
- (if (fneq (maxamp) .309) (snd-display #__line__ ";squelch-vowels init: ~A" (maxamp)))
+ (if (fneq (maxamp) .309) (snd-display ";squelch-vowels init: ~A" (maxamp)))
(squelch-vowels)
- (if (fneq (maxamp) .047) (snd-display #__line__ ";squelch-vowels maxamp: ~A" (maxamp)))
+ (if (fneq (maxamp) .047) (snd-display ";squelch-vowels maxamp: ~A" (maxamp)))
(select-sound ind)
(map-channel (cross-synthesis ind1 .5 128 6.0))
(revert-sound ind1)
@@ -8916,7 +8569,7 @@ EDITS: 2
(blackman4-env-channel '(0 0 1 1))
(let ((new-vals (channel->float-vector)))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";blackman4-env-channel/ramp: ~A ~A" vals new-vals))
+ (snd-display ";blackman4-env-channel/ramp: ~A ~A" vals new-vals))
(undo)
(blackman4-ramp 0.0 1.0 0 50)
(set! vals (channel->float-vector))
@@ -8924,11 +8577,11 @@ EDITS: 2
(blackman4-env-channel '(0 0 1 1 2 1))
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";blackman4-env-channel/ramp 1: ~A ~A" vals new-vals))
+ (snd-display ";blackman4-env-channel/ramp 1: ~A ~A" vals new-vals))
(undo)
(blackman4-env-channel '(0 0 1 1 2 -.5 3 0))
(if (not (vequal (channel->float-vector 60 10) (float-vector -0.109 -0.217 -0.313 -0.392 -0.451 -0.488 -0.499 -0.499 -0.499 -0.499)))
- (snd-display #__line__ ";blackman4 to -.5: ~A" (channel->float-vector 60 10)))
+ (snd-display ";blackman4 to -.5: ~A" (channel->float-vector 60 10)))
(undo)
(ramp-squared 0.0 1.0)
@@ -8937,7 +8590,7 @@ EDITS: 2
(env-squared-channel '(0 0 1 1))
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-squared/ramp: ~A ~A" vals new-vals))
+ (snd-display ";env-squared/ramp: ~A ~A" vals new-vals))
(undo)
(ramp-squared 0.0 1.0 #t 0 50)
(set! vals (channel->float-vector))
@@ -8945,15 +8598,15 @@ EDITS: 2
(env-squared-channel '(0 0 1 1 2 1))
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-squared/ramp 1: ~A ~A" vals new-vals))
+ (snd-display ";env-squared/ramp 1: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0))
(if (not (vequal (channel->float-vector 60 10) (float-vector -0.450 -0.466 -0.478 -0.488 -0.494 -0.499 -0.500 -0.500 -0.498 -0.496)))
- (snd-display #__line__ ";env-squared to -.5: ~A" (channel->float-vector 60 10)))
+ (snd-display ";env-squared to -.5: ~A" (channel->float-vector 60 10)))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0) #f)
(if (not (vequal (channel->float-vector 60 10) (float-vector -0.004 -0.080 -0.158 -0.240 -0.324 -0.410 -0.500 -0.500 -0.498 -0.496)))
- (snd-display #__line__ ";env-squared unsymmetric to -.5: ~A" (channel->float-vector 60 10)))
+ (snd-display ";env-squared unsymmetric to -.5: ~A" (channel->float-vector 60 10)))
(undo)
(ramp-squared 0.0 1.0)
@@ -8962,7 +8615,7 @@ EDITS: 2
(env-expt-channel '(0 0 1 1) 2)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt2/ramp: ~A ~A" vals new-vals))
+ (snd-display ";env-expt2/ramp: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0))
(set! vals (channel->float-vector))
@@ -8970,7 +8623,7 @@ EDITS: 2
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 2.0)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt2/env-squared: ~A ~A" vals new-vals))
+ (snd-display ";env-expt2/env-squared: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0) #f)
(set! vals (channel->float-vector))
@@ -8978,7 +8631,7 @@ EDITS: 2
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 2.0 #f)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt2/env-squared unsymmetric: ~A ~A" vals new-vals))
+ (snd-display ";env-expt2/env-squared unsymmetric: ~A ~A" vals new-vals))
(undo)
(ramp-expt 0.0 1.0 32.0)
@@ -8987,7 +8640,7 @@ EDITS: 2
(env-expt-channel '(0 0 1 1) 32.0)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt/ramp 32: ~A ~A" vals new-vals))
+ (snd-display ";env-expt/ramp 32: ~A ~A" vals new-vals))
(undo)
(ramp-expt 0.0 1.0 32.0 #f 0 50)
(set! vals (channel->float-vector))
@@ -8995,7 +8648,7 @@ EDITS: 2
(env-expt-channel '(0 0 1 1 2 1) 32.0)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt/ramp 1 32: ~A ~A" vals new-vals))
+ (snd-display ";env-expt/ramp 1 32: ~A ~A" vals new-vals))
(undo)
(ramp-expt 0.0 1.0 .1)
(set! vals (channel->float-vector))
@@ -9003,16 +8656,16 @@ EDITS: 2
(env-expt-channel '(0 0 1 1) .1)
(set! new-vals (channel->float-vector))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";env-expt/ramp .1: ~A ~A" vals new-vals))
+ (snd-display ";env-expt/ramp .1: ~A ~A" vals new-vals))
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 12.0)
(if (not (vequal (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 0.537 0.208 -0.022 -0.182 -0.291 -0.365)))
- (snd-display #__line__ ";env-expt to -.5 12.0: ~A" (channel->float-vector 30 10)))
+ (snd-display ";env-expt to -.5 12.0: ~A" (channel->float-vector 30 10)))
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 12.0 #f)
(if (not (vequal (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
- (snd-display #__line__ ";env-expt to -.5 12.0 unsymmetric: ~A" (channel->float-vector 30 10)))
+ (snd-display ";env-expt to -.5 12.0 unsymmetric: ~A" (channel->float-vector 30 10)))
(undo)
(close-sound ind))))
@@ -9029,7 +8682,7 @@ EDITS: 2
(ny (sin (+ (* val 0.5 pi) (* 1.0 (sin (* val 2.0 pi)))))))
(if (fneq y ny)
(begin
- (snd-display #__line__ ";contrast-channel: ~A ~A ~A" val y ny)
+ (snd-display ";contrast-channel: ~A ~A ~A" val y ny)
(set! happy #f))))))
(close-sound ind))
@@ -9037,27 +8690,24 @@ EDITS: 2
(ind1 (open-sound "pistol.snd")))
(let ((clip (channel-clipped? ind0 0)))
- (if clip (snd-display #__line__ ";channel-clipped? oboe.snd -> ~A" clip)))
+ (if clip (snd-display ";channel-clipped? oboe.snd -> ~A" clip)))
(scale-to 1.5 ind0 0)
(let ((clip (channel-clipped? ind0 0)))
- (if (not (member clip (list 4502 4503))) (snd-display #__line__ ";channel-clipped after scale: ~A" clip)))
+ (if (not (member clip '(4502 4503))) (snd-display ";channel-clipped after scale: ~A" clip)))
(revert-sound ind0)
- (ramp-channel 0.0 1.0 0 #f ind1 0)
- (ramp-channel 0.0 1.0 0 #f ind1 0)
- (ramp-channel 0.0 1.0 0 #f ind1 0)
- (ramp-channel 0.0 1.0 0 #f ind1 0)
+ (do ((i 0 (+ i 1))) ((= i 4)) (ramp-channel 0.0 1.0 0 #f ind1 0))
(make-selection 1000 2000 ind1 0)
(set! (sync ind0) 1)
(set! (selected-sound) ind0)
(env-selection '(0 0 1 1))
- (if (or (not (= (edit-position ind0 0) 0))
- (not (= (edit-position ind1 0) 5)))
- (snd-display #__line__ ";selection override of sync field: ~A ~A" (edit-position ind0 0) (edit-position ind1 0)))
+ (if (not (and (= (edit-position ind0 0) 0)
+ (= (edit-position ind1 0) 5)))
+ (snd-display ";selection override of sync field: ~A ~A" (edit-position ind0 0) (edit-position ind1 0)))
(env-sound '(0 0 1 1 2 0))
- (if (or (not (= (edit-position ind0 0) 1))
- (not (= (edit-position ind1 0) 5)))
- (snd-display #__line__ ";sync field over selection: ~A ~A" (edit-position ind0 0) (edit-position ind1 0)))
+ (if (not (and (= (edit-position ind0 0) 1)
+ (= (edit-position ind1 0) 5)))
+ (snd-display ";sync field over selection: ~A ~A" (edit-position ind0 0) (edit-position ind1 0)))
(close-sound ind1)
(revert-sound ind0)
@@ -9066,87 +8716,87 @@ EDITS: 2
(let ((s1 (open-sound "oboe.snd")))
(let ((s2 (copy s1)))
(if (not (sound? s2))
- (snd-display #__line__ ";copy sound oboe -> ~A" s2)
+ (snd-display ";copy sound oboe -> ~A" s2)
(begin
- (if (not (= (srate s1) (srate s2))) (snd-display #__line__ ";copy sounds srates: ~A ~A" (srate s1) (srate s2)))
- (if (not (= (framples s1) (framples s2))) (snd-display #__line__ ";copy sounds framples: ~A ~A" (framples s1) (framples s2)))
- (if (not (= (chans s1) (chans s2) 1)) (snd-display #__line__ ";copy sounds chans: ~A ~A" (chans s1) (chans s2)))
+ (if (not (= (srate s1) (srate s2))) (snd-display ";copy sounds srates: ~A ~A" (srate s1) (srate s2)))
+ (if (not (= (framples s1) (framples s2))) (snd-display ";copy sounds framples: ~A ~A" (framples s1) (framples s2)))
+ (if (not (= (chans s1) (chans s2) 1)) (snd-display ";copy sounds chans: ~A ~A" (chans s1) (chans s2)))
(let ((d1 (channel->float-vector 0 #f s1))
(d2 (channel->float-vector 0 #f s2)))
(if (not (vequal d1 d2))
- (snd-display #__line__ ";copied sound not equal? ~A?" (float-vector-peak (float-vector-subtract! d0 d1)))))
+ (snd-display ";copied sound not equal? ~A?" (float-vector-peak (float-vector-subtract! d0 d1)))))
(close-sound s2))))
(fill! s1 0.0)
- (if (fneq (maxamp s1) 0.0) (snd-display #__line__ ";fill 1 with 0: ~A" (maxamp s1)))
+ (if (fneq (maxamp s1) 0.0) (snd-display ";fill 1 with 0: ~A" (maxamp s1)))
(fill! s1 0.3)
- (if (fneq (maxamp s1) 0.3) (snd-display #__line__ ";fill 1 with 0.3: ~A" (maxamp s1)))
+ (if (fneq (maxamp s1) 0.3) (snd-display ";fill 1 with 0.3: ~A" (maxamp s1)))
(close-sound s1))
(let ((s1 (open-sound "2a.snd")))
(let ((s2 (copy s1)))
(if (not (sound? s2))
- (snd-display #__line__ ";copy sound 2a -> ~A" s2)
+ (snd-display ";copy sound 2a -> ~A" s2)
(begin
- (if (not (= (srate s1) (srate s2))) (snd-display #__line__ ";copy sounds srates 2: ~A ~A" (srate s1) (srate s2)))
- (if (not (= (framples s1) (framples s2))) (snd-display #__line__ ";copy sounds framples 2: ~A ~A" (framples s1) (framples s2)))
- (if (not (= (chans s1) (chans s2) 2)) (snd-display #__line__ ";copy sounds chans 2: ~A ~A" (chans s1) (chans s2)))
+ (if (not (= (srate s1) (srate s2))) (snd-display ";copy sounds srates 2: ~A ~A" (srate s1) (srate s2)))
+ (if (not (= (framples s1) (framples s2))) (snd-display ";copy sounds framples 2: ~A ~A" (framples s1) (framples s2)))
+ (if (not (= (chans s1) (chans s2) 2)) (snd-display ";copy sounds chans 2: ~A ~A" (chans s1) (chans s2)))
(let ((d10 (channel->float-vector 0 #f s1 0))
(d11 (channel->float-vector 0 #f s1 1))
(d20 (channel->float-vector 0 #f s2 0))
(d21 (channel->float-vector 0 #f s2 1)))
(if (not (vequal d10 d20))
- (snd-display #__line__ ";copied sound 2 (0) not equal? ~A?" (float-vector-peak (float-vector-subtract! d10 d20))))
+ (snd-display ";copied sound 2 (0) not equal? ~A?" (float-vector-peak (float-vector-subtract! d10 d20))))
(if (not (vequal d11 d21))
- (snd-display #__line__ ";copied sound 2 (1) not equal? ~A?" (float-vector-peak (float-vector-subtract! d11 d21)))))
+ (snd-display ";copied sound 2 (1) not equal? ~A?" (float-vector-peak (float-vector-subtract! d11 d21)))))
(close-sound s2))))
(fill! s1 0.0)
- (if (fneq (maxamp s1) 0.0) (snd-display #__line__ ";fill 2 with 0: ~A" (maxamp s1)))
+ (if (fneq (maxamp s1) 0.0) (snd-display ";fill 2 with 0: ~A" (maxamp s1)))
(fill! s1 0.3)
- (if (fneq (maxamp s1) 0.3) (snd-display #__line__ ";fill 2 with 0.3: ~A" (maxamp s1)))
+ (if (fneq (maxamp s1) 0.3) (snd-display ";fill 2 with 0.3: ~A" (maxamp s1)))
(close-sound s1))
(for-each close-sound (sounds))
(unselect-all)
(let ((snd (open-sound "oboe.snd")))
(make-selection 1000 2000 snd 0)
- (if (not (selection?)) (snd-display #__line__ ";make-selection for copy failed?"))
+ (if (not (selection?)) (snd-display ";make-selection for copy failed?"))
(copy (selection))
- (let* ((r1 (channel->float-vector 1000 1000 snd 0))
- (snds (sounds))
- (sel (if (equal? (car snds) snd) (cadr snds) (car snds)))
- (r2 (channel->float-vector 0 1000 sel 0)))
- (if (equal? sel snd)
- (snd-display #__line__ ";very weird: ~A equal? ~A from ~A (~A ~A ~A)" sel snd snds (car snds) (cadr snds) (equal? (car snds) snd)))
- (if (not (vequal r1 r2))
- (snd-display #__line__ ";copied selection not equal? ~A?" (float-vector-peak (float-vector-subtract! r1 r2))))
- (close-sound sel)
+ (let ((r1 (channel->float-vector 1000 1000 snd 0)))
+ (let* ((snds (sounds))
+ (sel (if (equal? (car snds) snd) (cadr snds) (car snds)))
+ (r2 (channel->float-vector 0 1000 sel 0)))
+ (if (equal? sel snd)
+ (snd-display ";very weird: ~A equal? ~A from ~A (~A ~A ~A)" sel snd snds (car snds) (cadr snds) (equal? (car snds) snd)))
+ (if (not (vequal r1 r2))
+ (snd-display ";copied selection not equal? ~A?" (float-vector-peak (float-vector-subtract! r1 r2))))
+ (close-sound sel))
(if (not (selection?))
- (snd-display #__line__ ";copy selection unselected? ~A" (sounds))
+ (snd-display ";copy selection unselected? ~A" (sounds))
(begin
(fill! (selection) 0.0)
(let ((r1 (channel->float-vector 1000 1000 snd 0)))
(if (> (float-vector-peak r1) 0.0)
- (snd-display #__line__ ";fill! selection not 0.0? ~A" (float-vector-peak r1))))
+ (snd-display ";fill! selection not 0.0? ~A" (float-vector-peak r1))))
(revert-sound snd)
(if (not (selection?))
- (snd-display #__line__ ";revert-sound selection unselected?")
+ (snd-display ";revert-sound selection unselected?")
(begin
(fill! (selection) 0.3)
(let ((r1 (channel->float-vector 1000 1000 snd 0)))
- (if (or (not (= (float-vector-max r1) 0.3))
- (not (= (float-vector-min r1) 0.3)))
- (snd-display #__line__ ";fill! selection not 0.3? ~A ~A" (float-vector-min r1) (float-vector-max r1)))))))))
+ (if (not (and (morally-equal? (float-vector-max r1) 0.3)
+ (morally-equal? (float-vector-min r1) 0.3)))
+ (snd-display ";fill! selection not 0.3? ~A ~A" (float-vector-min r1) (float-vector-max r1)))))))))
(for-each close-sound (sounds)))
(let ((snd (open-sound "oboe.snd")))
(make-selection 1000 2000 snd 0)
(if (not (selection?))
- (snd-display #__line__ ";make-selection failed?")
+ (snd-display ";make-selection failed?")
(let ((sel-max (maxamp (selection)))
(sel-len (length (selection))))
(let ((mx (car (selection->mix))))
(if (not (mix? mx))
- (snd-display #__line__ ";selection->mix: ~A" mx)
+ (snd-display ";selection->mix: ~A" mx)
(let ((mx-rd (make-mix-sampler mx 0))
(snd-rd (make-sampler 1000 snd 0))
(orig-rd (make-sampler 1000 snd 0 1 0)))
@@ -9161,9 +8811,9 @@ EDITS: 2
(fneq snd-val orig-val))
(begin
(set! happy #f)
- (snd-display #__line__ ";selection->mix at ~A: ~A ~A ~A" (+ i 1000) mx-val snd-val orig-val))))))
- (if (not (= (length mx) sel-len 1001)) (snd-display #__line__ ";selection->mix mix length: ~A (~A)" (length mx) sel-len))
- (if (fneq (maxamp mx) sel-max) (snd-display #__line__ ";selection->mix maxamps: ~A ~A" (maxamp mx) sel-max)))))))
+ (snd-display ";selection->mix at ~A: ~A ~A ~A" (+ i 1000) mx-val snd-val orig-val))))))
+ (if (not (= (length mx) sel-len 1001)) (snd-display ";selection->mix mix length: ~A (~A)" (length mx) sel-len))
+ (if (fneq (maxamp mx) sel-max) (snd-display ";selection->mix maxamps: ~A ~A" (maxamp mx) sel-max)))))))
(for-each close-sound (sounds)))
(let ((snd (open-sound "2.snd")))
@@ -9171,18 +8821,18 @@ EDITS: 2
;; make-selection claims it follows the sync field
(make-selection 2000 3000 snd)
(if (not (selection?))
- (snd-display #__line__ ";make-selection (2) failed?")
+ (snd-display ";make-selection (2) failed?")
(let ((sel-max (maxamp (selection)))
(sel-len (length (selection)))
(sel-chns (channels (selection))))
- (if (not (= sel-chns 2)) (snd-display #__line__ ";make-selection stereo syncd chans: ~A" sel-chns))
- (if (not (= sel-len 1001)) (snd-display #__line__ ";make-selection stereo length: ~A" sel-len))
+ (if (not (= sel-chns 2)) (snd-display ";make-selection stereo syncd chans: ~A" sel-chns))
+ (if (not (= sel-len 1001)) (snd-display ";make-selection stereo length: ~A" sel-len))
(let* ((mx-list (selection->mix))
(mx0 (car mx-list))
(mx1 (cadr mx-list)))
- (if (or (not (mix? mx0))
- (not (mix? mx1)))
- (snd-display #__line__ ";selection->mix stereo: ~A ~A" mx0 mx1)
+ (if (not (and (mix? mx0)
+ (mix? mx1)))
+ (snd-display ";selection->mix stereo: ~A ~A" mx0 mx1)
(let ((mx0-rd (make-mix-sampler mx0 0))
(mx1-rd (make-mix-sampler mx1 0))
(snd0-rd (make-sampler 2000 snd 0))
@@ -9203,17 +8853,17 @@ EDITS: 2
(fneq snd0-val orig0-val))
(begin
(set! happy #f)
- (snd-display #__line__ ";selection->mix stereo 0 at ~A: ~A ~A ~A" (+ i 2000) mx0-val snd0-val orig0-val)))
+ (snd-display ";selection->mix stereo 0 at ~A: ~A ~A ~A" (+ i 2000) mx0-val snd0-val orig0-val)))
(if (or (fneq mx1-val snd1-val)
(fneq snd1-val orig1-val))
(begin
(set! happy #f)
- (snd-display #__line__ ";selection->mix stereo 1 at ~A: ~A ~A ~A" (+ i 2000) mx1-val snd1-val orig1-val))))))))
+ (snd-display ";selection->mix stereo 1 at ~A: ~A ~A ~A" (+ i 2000) mx1-val snd1-val orig1-val))))))))
(if (not (= (length mx0) (length mx1) sel-len 1001))
- (snd-display #__line__ ";selection->mix stereo mix length: ~A ~A (~A)" (length mx0) (length mx1) sel-len))
+ (snd-display ";selection->mix stereo mix length: ~A ~A (~A)" (length mx0) (length mx1) sel-len))
(if (fneq (max (maxamp mx0) (maxamp mx1)) sel-max)
- (snd-display #__line__ ";selection->mix stereo maxamps: ~A ~A ~A" (maxamp mx0) (maxamp mx1) sel-max)))))
+ (snd-display ";selection->mix stereo maxamps: ~A ~A ~A" (maxamp mx0) (maxamp mx1) sel-max)))))
(for-each close-sound (sounds)))
(let ((ind (new-sound :size 10)))
@@ -9222,12 +8872,12 @@ EDITS: 2
(set! (sample i ind 0) (* .1 i)))
(let ((rd (make-sampler 3 ind 0)))
(let ((val (read-sample-with-direction rd 1)))
- (if (fneq val .3) (snd-display #__line__ ";read-sample-with-direction 3: ~A" val))
+ (if (fneq val .3) (snd-display ";read-sample-with-direction 3: ~A" val))
(read-sample-with-direction rd -1)
(set! val (read-sample-with-direction rd -1))
- (if (fneq val .2) (snd-display #__line__ ";read-sample-with-direction 2: ~A" val))
+ (if (fneq val .2) (snd-display ";read-sample-with-direction 2: ~A" val))
(set! val (read-sample-with-direction rd -1))
- (if (fneq val .1) (snd-display #__line__ ";read-sample-with-direction 1: ~A" val))
+ (if (fneq val .1) (snd-display ";read-sample-with-direction 1: ~A" val))
(close-sound ind))))
(clear-save-state-files))
@@ -9239,118 +8889,107 @@ EDITS: 2
(do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
(log-mem clmtest)
(let ((v0 (make-float-vector 10))
- (v1 (make-float-vector 10))
- (vlst (make-float-vector 3)))
- (if (not (float-vector? v0)) (snd-display #__line__ ";v0 isn't a float-vector?!?"))
- (if (eqv? v0 10) (snd-display #__line__ ";v0 is 10!?"))
- (if (float-vector? 10) (snd-display #__line__ ";10 is a float-vector?"))
- (if (not (= (length v0) 10)) (snd-display #__line__ ";v0 length = ~D?" (length v0)))
+ (v1 (make-float-vector 10)))
+ (if (not (= (length v0) 10)) (snd-display ";v0 length = ~D?" (length v0)))
(fill! v0 1.0)
(fill! v1 0.5)
- (if (equal? v0 v1) (snd-display #__line__ ";float-vector equal? ~A ~A" v0 v1))
- (if (eq? v0 v1) (snd-display #__line__ ";float-vector eq? ~A ~A" v0 v1))
- (if (fneq (float-vector-max v0) 1.0) (snd-display #__line__ ";float-vector max ~A" (float-vector-max v0)))
- (if (fneq (float-vector-min v0) 1.0) (snd-display #__line__ ";float-vector min ~A" (float-vector-max v0)))
- (let ((v2 v1)
- (v3 (make-float-vector 10))
+ (if (equal? v0 v1) (snd-display ";float-vector equal? ~A ~A" v0 v1))
+ (if (eq? v0 v1) (snd-display ";float-vector eq? ~A ~A" v0 v1))
+ (if (fneq (float-vector-max v0) 1.0) (snd-display ";float-vector max ~A" (float-vector-max v0)))
+ (if (fneq (float-vector-min v0) 1.0) (snd-display ";float-vector min ~A" (float-vector-max v0)))
+ (let ((v3 (make-float-vector 10))
(v4 (make-float-vector 3)))
- (if (not (eq? v1 v2)) (snd-display #__line__ ";float-vector not eq? ~A ~A" v1 v2))
(fill! v3 0.5)
- (if (not (equal? v3 v1)) (snd-display #__line__ ";float-vector not equal? ~A ~A" v3 v1))
- (if (equal? v4 v1) (snd-display #__line__ ";len diff float-vector equal? ~A ~A" v4 v1))
+ (if (not (equal? v3 v1)) (snd-display ";float-vector not equal? ~A ~A" v3 v1))
+ (if (equal? v4 v1) (snd-display ";len diff float-vector equal? ~A ~A" v4 v1))
(set! (v3 0) 1.0)
- (if (fneq (v3 0) 1.0) (snd-display #__line__ ";set! float-vector-ref: ~A" (v3 0))))
- (set! (vlst 1) .1)
- (if (not (feql (map values vlst) (list 0.0 0.1 0.0))) (snd-display #__line__ ";vector->list: ~A?" (map values vlst)))
+ (if (fneq (v3 0) 1.0) (snd-display ";set! float-vector-ref: ~A" (v3 0))))
+ (let ((vlst (make-float-vector 3)))
+ (set! (vlst 1) .1)
+ (if (not (feql (map values vlst) (list 0.0 0.1 0.0))) (snd-display ";vector->list: ~A?" (map values vlst))))
(let ((v2 (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 4))
(set! (v2 i) i))
(float-vector-move! v2 3 2 #t)
(if (or (fneq (v2 3) 2.0) (fneq (v2 2) 1.0))
- (snd-display #__line__ ";float-vector-move! back: ~A?" v2)))
+ (snd-display ";float-vector-move! back: ~A?" v2)))
(if (not (string=? (float-vector->string (float-vector 1.0 2.0)) "(float-vector 1.000 2.000)"))
- (snd-display #__line__ ";float-vector->string: ~A" (float-vector->string (float-vector 1.0 2.0))))
+ (snd-display ";float-vector->string: ~A" (float-vector->string (float-vector 1.0 2.0))))
- (if (not (vequal (float-vector 4 3 2 1) (reverse! (float-vector 1 2 3 4)))) (snd-display #__line__ ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3 4))))
- (if (not (vequal (float-vector 3 2 1) (reverse! (float-vector 1 2 3)))) (snd-display #__line__ ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3))))
- (if (not (vequal (float-vector 2 1) (reverse! (float-vector 1 2)))) (snd-display #__line__ ";float-vector-reverse: ~A" (reverse! (float-vector 1 2))))
- (if (not (vequal (float-vector 1) (reverse! (float-vector 1)))) (snd-display #__line__ ";float-vector-reverse: ~A" (reverse! (float-vector 1))))
- (if (not (vequal (float-vector 3 2 1) (reverse (float-vector 1 2 3)))) (snd-display #__line__ ";reverse(float-vector): ~A" (reverse (float-vector 1 2 3))))
+ (if (not (vequal (float-vector 4 3 2 1) (reverse! (float-vector 1 2 3 4)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3 4))))
+ (if (not (vequal (float-vector 3 2 1) (reverse! (float-vector 1 2 3)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3))))
+ (if (not (vequal (float-vector 2 1) (reverse! (float-vector 1 2)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2))))
+ (if (not (vequal (float-vector 1) (reverse! (float-vector 1)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1))))
+ (if (not (vequal (float-vector 3 2 1) (reverse (float-vector 1 2 3)))) (snd-display ";reverse(float-vector): ~A" (reverse (float-vector 1 2 3))))
(let ((v (float-vector 3 2 1)))
(let ((rv (reverse v)))
(if (not (vequal rv (float-vector 1 2 3)))
- (snd-display #__line__ ";reverse(float-vector) -> ~A ~A" v rv))))
+ (snd-display ";reverse(float-vector) -> ~A ~A" v rv))))
(let ((v0 (make-float-vector 3)))
(let ((var (catch #t (lambda () (v0 10)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-ref high index: ~A" var)))
- (let ((var (catch #t (lambda () (v0 -1)) (lambda args args))))
- (if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-ref low index: ~A" var)))
+ (snd-display ";float-vector-ref high index: ~A" var)))
(let ((var (catch #t (lambda () (set! (v0 10) 1.0)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-set! high index: ~A" var)))
- (let ((var (catch #t (lambda () (set! (v0 -1) 1.0)) (lambda args args))))
- (if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-set! low index: ~A" var)))
+ (snd-display ";float-vector-set! high index: ~A" var)))
(let ((var (catch #t (lambda () (float-vector-move! v0 10 0 #t)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-move! high index: ~A" var)))
+ (snd-display ";float-vector-move! high index: ~A" var)))
(let ((var (catch #t (lambda () (float-vector-move! v0 0 10 #t)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-move! high 2 index: ~A" var)))
+ (snd-display ";float-vector-move! high 2 index: ~A" var)))
(let ((var (catch #t (lambda () (float-vector-move! v0 -10 0 #f)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-move! back high index: ~A" var)))
+ (snd-display ";float-vector-move! back high index: ~A" var)))
(let ((var (catch #t (lambda () (float-vector-move! v0 0 -10 #f)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";float-vector-move! back high 2 index: ~A" var))))
+ (snd-display ";float-vector-move! back high 2 index: ~A" var))))
(let ((v (float-vector 0.0 1.0 -2.0 -3.0)))
(if (not (vequal (float-vector-abs! v) (float-vector 0.0 1.0 2.0 3.0)))
- (snd-display #__line__ ";float-vector-abs! ~A" v)))
+ (snd-display ";float-vector-abs! ~A" v)))
;; float-vector-add! + shared-vector:
(let ((fv (float-vector 1 2 3 4 5)))
(let ((sv (make-shared-vector fv '(4) 1)))
(float-vector-add! sv fv)
(if (not (vequal fv (float-vector 1.0 3.0 6.0 10.0 15.0)))
- (snd-display #__line__ ";float-vector+shared-vector: ~A" fv))))
+ (snd-display ";float-vector+shared-vector: ~A" fv))))
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v0 i) 1.0) (snd-display #__line__ ";fill v0[~D] = ~F?" i (v0 i)))
- (if (fneq (v1 i) 0.5) (snd-display #__line__ ";preset v1[~D] = ~F?" i (v1 i))))
+ (if (fneq (v0 i) 1.0) (snd-display ";fill v0[~D] = ~F?" i (v0 i)))
+ (if (fneq (v1 i) 0.5) (snd-display ";preset v1[~D] = ~F?" i (v1 i))))
(float-vector-add! v0 v1)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v0 i) 1.5) (snd-display #__line__ ";add v0[~D] = ~F?" i (v0 i))))
+ (if (fneq (v0 i) 1.5) (snd-display ";add v0[~D] = ~F?" i (v0 i))))
(float-vector-subtract! v0 v1)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v0 i) 1.0) (snd-display #__line__ ";subtract v0[~D] = ~F?" i (v0 i))))
+ (if (fneq (v0 i) 1.0) (snd-display ";subtract v0[~D] = ~F?" i (v0 i))))
(let ((v2 (copy v0)))
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v2 i) 1.0) (snd-display #__line__ ";copy v0[~D] = ~F?" i (v2 i))))
+ (if (fneq (v2 i) 1.0) (snd-display ";copy v0[~D] = ~F?" i (v2 i))))
(float-vector-scale! v2 5.0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v2 i) 5.0) (snd-display #__line__ ";scale v2[~D] = ~F?" i (v2 i))))
+ (if (fneq (v2 i) 5.0) (snd-display ";scale v2[~D] = ~F?" i (v2 i))))
(float-vector-offset! v0 -1.0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v0 i) 0.0) (snd-display #__line__ ";offset v0[~D] = ~F?" i (v0 i))))
+ (if (fneq (v0 i) 0.0) (snd-display ";offset v0[~D] = ~F?" i (v0 i))))
(float-vector-multiply! v2 v1)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v2 i) 2.5) (snd-display #__line__ ";multiply v2[~D] = ~F?" i (v2 i))))
- (if (fneq (float-vector-peak v2) 2.5) (snd-display #__line__ ";v2's peak is ~F?" (float-vector-peak v2)))
+ (if (fneq (v2 i) 2.5) (snd-display ";multiply v2[~D] = ~F?" i (v2 i))))
+ (if (fneq (float-vector-peak v2) 2.5) (snd-display ";v2's peak is ~F?" (float-vector-peak v2)))
(set! (v2 5) 123.0)
- (if (fneq (float-vector-peak v2) 123.0) (snd-display #__line__ ";v2's set peak is ~F?" (float-vector-peak v2)))
+ (if (fneq (float-vector-peak v2) 123.0) (snd-display ";v2's set peak is ~F?" (float-vector-peak v2)))
(let ((vn (make-float-vector 32))
(vb (make-float-vector 64))
(vs (make-float-vector 3))
@@ -9359,24 +8998,24 @@ EDITS: 2
((= i 32))
(set! (vn i) i))
(let ((vnew (float-vector-subseq vn 3)))
- (if (fneq (vnew 0) 3.0) (snd-display #__line__ ";float-vector-subseq[3:] ~A?" (vnew 0)))
- (if (not (= (length vnew) 29)) (snd-display #__line__ ";float-vector-subseq[3:] length: ~A?" (length vnew))))
+ (if (fneq (vnew 0) 3.0) (snd-display ";float-vector-subseq[3:] ~A?" (vnew 0)))
+ (if (not (= (length vnew) 29)) (snd-display ";float-vector-subseq[3:] length: ~A?" (length vnew))))
(let ((vnew (float-vector-subseq vn 3 8)))
- (if (fneq (vnew 0) 3.0) (snd-display #__line__ ";float-vector-subseq[3:8] ~A?" (vnew 0)))
- (if (not (= (length vnew) 6)) (snd-display #__line__ ";float-vector-subseq[3:8] length: ~A?" (length vnew))))
+ (if (fneq (vnew 0) 3.0) (snd-display ";float-vector-subseq[3:8] ~A?" (vnew 0)))
+ (if (not (= (length vnew) 6)) (snd-display ";float-vector-subseq[3:8] length: ~A?" (length vnew))))
(float-vector-subseq vn 3 3 vs)
(if (or (fneq (vs 0) 3.0)
(fneq (vs 1) 0.0)
(fneq (vs 2) 0.0))
- (snd-display #__line__ ";float-vector-subseq[3:3->vs] ~A?" vs))
+ (snd-display ";float-vector-subseq[3:3->vs] ~A?" vs))
(float-vector-subseq vn 0 32 vs)
- (if (not (= (length vs) 3)) (snd-display #__line__ ";float-vector-subseq[0:32->vs] length: ~A?" (length vs)))
+ (if (not (= (length vs) 3)) (snd-display ";float-vector-subseq[0:32->vs] length: ~A?" (length vs)))
(float-vector-subseq vn 2 3 vss)
- (if (fneq (vss 0) 2.0) (snd-display #__line__ ";float-vector-subseq[2:3->vss] ~A?" (vss 0)))
+ (if (fneq (vss 0) 2.0) (snd-display ";float-vector-subseq[2:3->vss] ~A?" (vss 0)))
(set! (vb 8) 123.0)
(float-vector-subseq vn 1 8 vb)
- (if (fneq (vb 0) 1.0) (snd-display #__line__ ";float-vector-subseq[1:8->vb] ~A?" (vb 0)))
- (if (fneq (vb 8) 123.0) (snd-display #__line__ ";float-vector-subseq[1:8->vb][8] ~A?" (vb 8))))
+ (if (fneq (vb 0) 1.0) (snd-display ";float-vector-subseq[1:8->vb] ~A?" (vb 0)))
+ (if (fneq (vb 8) 123.0) (snd-display ";float-vector-subseq[1:8->vb][8] ~A?" (vb 8))))
(let ((v (make-float-vector 20))
(mn 1.0)
@@ -9385,40 +9024,40 @@ EDITS: 2
((= i 20))
(let ((val (mus-random 1.0)))
(set! (v i) val)
- (if (< val mn) (set! mn val))
- (if (> val mx) (set! mx val))))
- (if (fneq (float-vector-min v) mn) (snd-display #__line__ ";float-vector-min ran: ~A ~A" (float-vector-min v) mn))
- (if (fneq (float-vector-max v) mx) (snd-display #__line__ ";float-vector-max ran: ~A ~A" (float-vector-max v) mx))
- (if (fneq (float-vector-peak v) (max (abs mn) (abs mx))) (snd-display #__line__ ";float-vector-peak ran: ~A ~A ~A" (float-vector-peak v) mn mx)))
+ (set! mn (min mn val))
+ (set! mx (max mx val))))
+ (if (fneq (float-vector-min v) mn) (snd-display ";float-vector-min ran: ~A ~A" (float-vector-min v) mn))
+ (if (fneq (float-vector-max v) mx) (snd-display ";float-vector-max ran: ~A ~A" (float-vector-max v) mx))
+ (if (fneq (float-vector-peak v) (max (abs mn) (abs mx))) (snd-display ";float-vector-peak ran: ~A ~A ~A" (float-vector-peak v) mn mx)))
(let ((v1 (make-float-vector 3 .1))
(v2 (make-float-vector 4 .2)))
(let ((val (float-vector+ (copy v1) v2)))
- (if (not (vequal val (float-vector .3 .3 .3))) (snd-display #__line__ ";float-vector+ .1 .2: ~A" val)))
+ (if (not (vequal val (float-vector .3 .3 .3))) (snd-display ";float-vector+ .1 .2: ~A" val)))
(set! (v1 1) .3)
(let ((val (float-vector+ (copy v1) v2)))
- (if (not (vequal val (float-vector .3 .5 .3))) (snd-display #__line__ ";float-vector+ .1 .2 (1): ~A" val)))
+ (if (not (vequal val (float-vector .3 .5 .3))) (snd-display ";float-vector+ .1 .2 (1): ~A" val)))
(let ((val (float-vector+ (copy v1) 2.0)))
- (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display #__line__ ";float-vector+ .1 2.0: ~A" val)))
+ (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0: ~A" val)))
(let ((val (float-vector+ 2.0 (copy v1))))
- (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display #__line__ ";float-vector+ .1 2.0 (1): ~A" val)))
+ (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0 (1): ~A" val)))
(let ((val (float-vector* 2.0 (copy v1))))
- (if (not (vequal val (float-vector .2 .6 .2))) (snd-display #__line__ ";float-vector* 2.0: ~A" val)))
+ (if (not (vequal val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0: ~A" val)))
(let ((val (float-vector* (copy v1) 2.0)))
- (if (not (vequal val (float-vector .2 .6 .2))) (snd-display #__line__ ";float-vector* 2.0 (1): ~A" val)))
+ (if (not (vequal val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0 (1): ~A" val)))
(let ((val (float-vector* (copy v1) v2)))
- (if (not (vequal val (float-vector .02 .06 .02))) (snd-display #__line__ ";float-vector* v1 v2: ~A" val))))
+ (if (not (vequal val (float-vector .02 .06 .02))) (snd-display ";float-vector* v1 v2: ~A" val))))
(fill! v0 1.0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (v0 i) 1.0) (snd-display #__line__ ";map v0[~D] = ~F?" i (v0 i)))))
+ (if (fneq (v0 i) 1.0) (snd-display ";map v0[~D] = ~F?" i (v0 i)))))
(if (fneq ((float-vector 1.0 2.0 3.0) 1) 2.0)
- (snd-display #__line__ ";(float-vector...) = ~A?" ((float-vector 1.0 2.0 3.0) 1)))
+ (snd-display ";(float-vector...) = ~A?" ((float-vector 1.0 2.0 3.0) 1)))
(let ((v1 (float-vector 1 2 3 4)))
(if (fneq (v1 1) 2.0)
- (snd-display #__line__ ";(v1 1) = ~A?" (v1 1))))
+ (snd-display ";(v1 1) = ~A?" (v1 1))))
(when with-gui
(let ((ind (open-sound "oboe.snd")))
@@ -9430,24 +9069,24 @@ EDITS: 2
;; try some special cases
(apply-controls)
(if (not (= (edit-position ind) 0))
- (snd-display #__line__ ";apply-controls with no:change: ~A: ~A" (edits ind) (edit-tree ind)))
+ (snd-display ";apply-controls with no:change: ~A: ~A" (edits ind) (edit-tree ind)))
(set! (speed-control ind) -1.0)
(apply-controls)
(if (not (= (edit-position ind) 1))
- (snd-display #__line__ ";apply-controls with srate -1.0: ~A ~A ~A" (edit-position ind) (edits ind) (edit-tree ind)))
+ (snd-display ";apply-controls with srate -1.0: ~A ~A ~A" (edit-position ind) (edits ind) (edit-tree ind)))
(if (> (abs (- (framples ind 0) (framples ind 0 0))) 2)
- (snd-display #__line__ ";apply-controls srate -1.0 lengths: ~A ~A" (framples ind 0) (framples ind 0 0)))
+ (snd-display ";apply-controls srate -1.0 lengths: ~A ~A" (framples ind 0) (framples ind 0 0)))
(if (or (fneq (maxamp) .147)
(< (abs (sample 9327)) .01))
- (snd-display #__line__ ";apply-controls srate -1.0 samples: ~A ~A" (maxamp) (sample 9327)))
- (if (fneq (speed-control ind) 1.0) (snd-display #__line__ ";apply-controls -1.0 -> ~A?" (speed-control ind)))
+ (snd-display ";apply-controls srate -1.0 samples: ~A ~A" (maxamp) (sample 9327)))
+ (if (fneq (speed-control ind) 1.0) (snd-display ";apply-controls -1.0 -> ~A?" (speed-control ind)))
(hook-push after-apply-controls-hook (lambda (hook)
(let ((tag (catch #t
apply-controls
(lambda args args))))
(if (not (eq? (car tag) 'cannot-apply-controls))
- (snd-display #__line__ ";after-apply-controls-hook: recursive attempt apply-controls: ~A" tag)))))
+ (snd-display ";after-apply-controls-hook: recursive attempt apply-controls: ~A" tag)))))
(apply-controls)
(set! (hook-functions after-apply-controls-hook) ())
(revert-sound)
@@ -9458,43 +9097,43 @@ EDITS: 2
(lambda () (float-vector-subseq hi 1 0))
(lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";float-vector-subseq 1 0: ~A" tag))))
+ (snd-display ";float-vector-subseq 1 0: ~A" tag))))
(let ((v0 (make-float-vector 5 .1))
(v1 (make-float-vector 6 .2)))
(float-vector-add! v0 v1 2)
(if (not (vequal v0 (float-vector .1 .1 .3 .3 .3)))
- (snd-display #__line__ ";float-vector-add + offset: ~A" v0)))
+ (snd-display ";float-vector-add + offset: ~A" v0)))
;; check s7 stuff with float-vectors
(let ((v (float-vector 1.0 2.0 3.0)))
(if (not (string=? (format #f "~{~A~^-~}" v) "1.0-2.0-3.0"))
- (snd-display #__line__ ";float-vector in format {}: ~S" (format #f "~{~A~^-~}" v)))
+ (snd-display ";float-vector in format {}: ~S" (format #f "~{~A~^-~}" v)))
(if (not (= (length v) 3))
- (snd-display #__line__ ";float-vector s7 len: ~A" (length v)))
+ (snd-display ";float-vector s7 len: ~A" (length v)))
(if (not (equal? v (copy v)))
- (snd-display #__line__ ";float-vector s7 copy is not equal? ~A ~A" v (copy v)))
+ (snd-display ";float-vector s7 copy is not equal? ~A ~A" v (copy v)))
(let ((val (map floor v)))
(if (not (equal? val '(1 2 3)))
- (snd-display #__line__ ";float-vector s7 map: ~A" val)))
+ (snd-display ";float-vector s7 map: ~A" val)))
(let ((val 0))
(for-each
(lambda (x)
(set! val (+ val (floor x))))
v)
(if (not (eqv? val 6))
- (snd-display #__line__ ";float-vector s7 for-each: ~A" val)))
+ (snd-display ";float-vector s7 for-each: ~A" val)))
(set! v (reverse v))
(if (not (vvequal v (float-vector 3.0 2.0 1.0)))
- (snd-display #__line__ ";float-vector s7 reverse: ~A" v))
+ (snd-display ";float-vector s7 reverse: ~A" v))
(fill! v 12.0)
(if (not (vvequal v (float-vector 12.0 12.0 12.0)))
- (snd-display #__line__ ";float-vector s7 fill: ~A" (fill! v 12.0)))
+ (snd-display ";float-vector s7 fill: ~A" (fill! v 12.0)))
)
(let ((sum 0))
(for-each (lambda (n) (set! sum (+ sum n))) (float-vector 1 2 3))
- (if (not (= sum 6.0))
- (snd-display #__line__ ";object for-each (float-vector): ~A" sum)))
+ (if (not (morally-equal? sum 6.0))
+ (snd-display ";object for-each (float-vector): ~A" sum)))
(let ((x (float-vector 0.0))
(osc (make-oscil :frequency 440))
@@ -9504,9 +9143,9 @@ EDITS: 2
(float-vector-set! x 0 (* (env e1) (oscil osc (float-vector-ref x 0))))))
(if (fneq (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .1) .0909)
- (snd-display #__line__ ";float-vector-equal? 0.0909: ~A" (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .1)))
+ (snd-display ";float-vector-equal? 0.0909: ~A" (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .1)))
(if (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .01)
- (snd-display #__line__ ";float-vector-equal? #f: ~A" (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .01)))
+ (snd-display ";float-vector-equal? #f: ~A" (float-vector-equal? (float-vector 1.0) (float-vector 1.1) .01)))
)))
@@ -9519,126 +9158,128 @@ EDITS: 2
(define colormap-error-max 0.0)
(define cfneq (lambda (a b) (> (abs (- a b)) colormap-error-max)))
(define old-colormap-size *colormap-size*)
+ (define beige (*rgb* 'beige))
- (if (or (provided? 'snd-gtk)
- (provided? 'snd-motif))
- (letrec ((test-color
- (lambda (lst)
- (if (pair? lst)
- (let* ((name ((car lst) 0))
- (getfnc ((car lst) 1))
- (setfnc (lambda (val) (set! (getfnc) val)))
- (initval ((car lst) 2)))
- (if (not (color? initval)) (snd-display #__line__ ";~A not color?" initval))
- ;; we'll get warnings here if the cell chosen didn't exactly match the one requested -- not a bug
- ;; (if (not (equal? (getfnc) initval))
- ;; (snd-display #__line__ ";~A is not ~A (~A)?" name initval (getfnc)))
- (setfnc beige)
- (if (not (equal? (getfnc) beige))
- (snd-display #__line__ ";set-~A is not beige (~A)?" name (getfnc)))
- (setfnc initval)
- (test-color (cdr lst)))))))
-
- (let* ((c1 (catch 'no-such-color
- (lambda () (make-color 0 0 1))
- (lambda args #f)))
- (c2 c1)
- (c3 (catch 'no-such-color
- (lambda () (make-color 0 0 1))
- (lambda args #f))))
- (if (not (equal? c1 c2)) (snd-display #__line__ ";color not equal? ~A ~A?" c1 c2))
- (if (not (eq? c1 c2)) (snd-display #__line__ ";color not eq? ~A ~A?" c1 c2))
- ;(if (not (equal? c1 c3)) (snd-display #__line__ ";diff color not equal? ~A ~A?" c1 c3))
- (if (eq? c1 c3) (snd-display #__line__ ";diff color eq? ~A ~A?" c1 c3))
- (if (and (not (equal? (color->list c1) (list 0.0 0.0 1.0)))
- (not (equal? (color->list c1) (list 0.0 0.0 1.0 1.0))))
- (snd-display #__line__ ";color->list: ~A ~A?" c1 (color->list c1))))
-
- (if (not (provided? 'snd-motif))
- (let* ((c1 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.5))
- (lambda args #f)))
- (c2 c1)
- (c3 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.5))
- (lambda args #f))))
- (if (not (equal? c1 c2)) (snd-display #__line__ ";alpha color not equal? ~A ~A?" c1 c2))
- (if (not (eq? c1 c2)) (snd-display #__line__ ";alpha color not eq? ~A ~A?" c1 c2))
- ;(if (not (equal? c1 c3)) (snd-display #__line__ ";alpha diff color not equal? ~A ~A?" c1 c3))
- (if (eq? c1 c3) (snd-display #__line__ ";alpha diff color eq? ~A ~A?" c1 c3))
- (let ((c4 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.0))
- (lambda args #f))))
- (if (equal? c1 c4) (snd-display #__line__ ";alpha color equal? ~A ~A?" c1 c2)))))
-
- (do ((i 0 (+ i 1)))
- ((not (colormap? (integer->colormap i))))
- (let ((val (colormap-ref (integer->colormap i) 0))
- (true-val ((list '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 1.0 1.0)
- '(0.0 0.0 7.01915007248035e-4) '(0.0 0.0 0.0) '(0.0 0.0 0.0)
- '(0.0 0.0 0.49999) '(1.0 0.0 0.0) '(1.0 0.0 0.0) '(0.0 0.0 1.0)
- '(1.0 0.0 1.0) '(0.0 0.500007629510948 0.4) '(1.0 0.0 0.0)
- '(1.0 0.0 0.0) '(0.0 0.0 1.0))
- i)))
- (if (not (feql val true-val))
- (snd-display #__line__ ";colormap-ref ~A: ~A (~A)" i val true-val))))
- (catch #t ; might be undefined var as well as no-such-color
- (lambda ()
- (test-color
- (list
- (list 'basic-color basic-color ivory2)
- (list 'cursor-color cursor-color red)
- (list 'data-color data-color black)
- (list 'enved-waveform-color enved-waveform-color blue)
- (list 'filter-control-waveform-color filter-control-waveform-color blue)
- (list 'graph-color graph-color white)
- (list 'highlight-color highlight-color ivory1)
- (list 'listener-color listener-color alice-blue)
- (list 'listener-text-color listener-text-color black)
- (list 'mark-color mark-color red)
- (list 'mix-color mix-color dark-gray)
- (list 'position-color position-color ivory3)
- (list 'sash-color sash-color light-green)
- (list 'selected-data-color selected-data-color black)
- (list 'selected-graph-color selected-graph-color white)
- (list 'selection-color selection-color lightsteelblue1)
- (list 'text-focus-color text-focus-color white)
- (list 'zoom-color zoom-color ivory4)
- ))
-
- (let ((ind (open-sound "oboe.snd")))
- (set! *selected-data-color* light-green)
- (set! *data-color* blue)
- (set! *selected-graph-color* black)
- (let ((red (make-color-with-catch 1.0 0.0 0.0)))
- (set! (foreground-color ind 0 cursor-context) red)
- (let ((col (foreground-color ind 0 cursor-context)))
- (if (not (feql (color->list col) (color->list red)))
- (snd-display #__line__ ";set foreground cursor color: ~A ~A" (color->list col) (color->list red))))
- (set! (foreground-color) blue)
- (let ((col (foreground-color)))
- (if (not (feql (color->list col) (color->list blue)))
- (snd-display #__line__ ";set foreground-color: ~A ~A" (color->list col) (color->list blue))))
- (set! (foreground-color ind) red)
- (let ((col (foreground-color ind)))
- (if (not (feql (color->list col) (color->list red)))
- (snd-display #__line__ ";set foreground-color with ind (red): ~A ~A" (color->list col) (color->list red))))
- (set! (foreground-color ind) black)
- (let ((col (foreground-color ind)))
- (if (not (feql (color->list col) (color->list black)))
- (snd-display #__line__ ";set foreground-color with ind (black): ~A ~A" (color->list col) (color->list black)))))
- (set! *selected-graph-color* (make-color-with-catch 0.96 0.96 0.86))
- (set! *data-color* black)
- (set! *selected-data-color* blue)
- (set! *graph-color* white)
- (close-sound ind)))
- (lambda args args))
-
- (if (not (= (length jet-colormap) *colormap-size*))
- (snd-display #__line__ ";jet-colormap length: ~A ~A" (length jet-colormap) *colormap-size*))
-
- (for-each
- (lambda (n err)
+ (when (or (provided? 'snd-gtk)
+ (provided? 'snd-motif))
+ (letrec ((test-color
+ (lambda (lst)
+ (if (pair? lst)
+ (let* ((name ((car lst) 0))
+ (getfnc ((car lst) 1))
+ (setfnc (lambda (val) (set! (getfnc) val)))
+ (initval ((car lst) 2)))
+ (if (not (color? initval)) (snd-display ";~A not color?" initval))
+ ;; we'll get warnings here if the cell chosen didn't exactly match the one requested -- not a bug
+ ;; (if (not (equal? (getfnc) initval))
+ ;; (snd-display ";~A is not ~A (~A)?" name initval (getfnc)))
+ (setfnc beige)
+ (if (not (equal? (getfnc) beige))
+ (snd-display ";set-~A is not beige (~A)?" name (getfnc)))
+ (setfnc initval)
+ (test-color (cdr lst)))))))
+
+ (let* ((c1 (catch 'no-such-color
+ (lambda () (make-color 0 0 1))
+ (lambda args #f)))
+ (c2 c1)
+ (c3 (catch 'no-such-color
+ (lambda () (make-color 0 0 1))
+ (lambda args #f))))
+ (if (not (equal? c1 c2)) (snd-display ";color not equal? ~A ~A?" c1 c2))
+ (if (not (eq? c1 c2)) (snd-display ";color not eq? ~A ~A?" c1 c2))
+ ;(if (not (equal? c1 c3)) (snd-display ";diff color not equal? ~A ~A?" c1 c3))
+ (if (eq? c1 c3) (snd-display ";diff color eq? ~A ~A?" c1 c3))
+ (if (not (or (equal? (color->list c1) (list 0.0 0.0 1.0))
+ (equal? (color->list c1) (list 0.0 0.0 1.0 1.0))))
+ (snd-display ";color->list: ~A ~A?" c1 (color->list c1))))
+
+ (if (not (provided? 'snd-motif))
+ (let* ((c1 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.5))
+ (lambda args #f)))
+ (c2 c1)
+ (c3 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.5))
+ (lambda args #f))))
+ (if (not (equal? c1 c2)) (snd-display ";alpha color not equal? ~A ~A?" c1 c2))
+ (if (not (eq? c1 c2)) (snd-display ";alpha color not eq? ~A ~A?" c1 c2))
+ ;(if (not (equal? c1 c3)) (snd-display ";alpha diff color not equal? ~A ~A?" c1 c3))
+ (if (eq? c1 c3) (snd-display ";alpha diff color eq? ~A ~A?" c1 c3))
+ (let ((c4 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.0))
+ (lambda args #f))))
+ (if (equal? c1 c4) (snd-display ";alpha color equal? ~A ~A?" c1 c2)))))
+
+ (do ((i 0 (+ i 1)))
+ ((not (colormap? (integer->colormap i))))
+ (let ((val (colormap-ref (integer->colormap i) 0))
+ (true-val ((list '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 1.0 1.0)
+ '(0.0 0.0 7.01915007248035e-4) '(0.0 0.0 0.0) '(0.0 0.0 0.0)
+ '(0.0 0.0 0.49999) '(1.0 0.0 0.0) '(1.0 0.0 0.0) '(0.0 0.0 1.0)
+ '(1.0 0.0 1.0) '(0.0 0.500007629510948 0.4) '(1.0 0.0 0.0)
+ '(1.0 0.0 0.0) '(0.0 0.0 1.0))
+ i)))
+ (if (not (feql val true-val))
+ (snd-display ";colormap-ref ~A: ~A (~A)" i val true-val))))
+ (catch #t ; might be undefined var as well as no-such-color
+ (lambda ()
+ (test-color
+ (list
+ (list 'basic-color basic-color ivory2)
+ (list 'cursor-color cursor-color red)
+ (list 'data-color data-color black)
+ (list 'enved-waveform-color enved-waveform-color blue)
+ (list 'filter-control-waveform-color filter-control-waveform-color blue)
+ (list 'graph-color graph-color white)
+ (list 'highlight-color highlight-color ivory1)
+ (list 'listener-color listener-color alice-blue)
+ (list 'listener-text-color listener-text-color black)
+ (list 'mark-color mark-color red)
+ (list 'mix-color mix-color dark-gray)
+ (list 'position-color position-color ivory3)
+ (list 'sash-color sash-color light-green)
+ (list 'selected-data-color selected-data-color black)
+ (list 'selected-graph-color selected-graph-color white)
+ (list 'selection-color selection-color lightsteelblue1)
+ (list 'text-focus-color text-focus-color white)
+ (list 'zoom-color zoom-color ivory4)
+ ))
+
+ (let ((ind (open-sound "oboe.snd")))
+ (set! *selected-data-color* light-green)
+ (set! *data-color* blue)
+ (set! *selected-graph-color* black)
+ (let ((red (make-color-with-catch 1.0 0.0 0.0)))
+ (set! (foreground-color ind 0 cursor-context) red)
+ (let ((col (foreground-color ind 0 cursor-context)))
+ (if (not (feql (color->list col) (color->list red)))
+ (snd-display ";set foreground cursor color: ~A ~A" (color->list col) (color->list red))))
+ (set! (foreground-color) blue)
+ (let ((col (foreground-color)))
+ (if (not (feql (color->list col) (color->list blue)))
+ (snd-display ";set foreground-color: ~A ~A" (color->list col) (color->list blue))))
+ (set! (foreground-color ind) red)
+ (let ((col (foreground-color ind)))
+ (if (not (feql (color->list col) (color->list red)))
+ (snd-display ";set foreground-color with ind (red): ~A ~A" (color->list col) (color->list red))))
+ (set! (foreground-color ind) black)
+ (let ((col (foreground-color ind)))
+ (if (not (feql (color->list col) (color->list black)))
+ (snd-display ";set foreground-color with ind (black): ~A ~A" (color->list col) (color->list black)))))
+ (set! *selected-graph-color* (make-color-with-catch 0.96 0.96 0.86))
+ (set! *data-color* black)
+ (set! *selected-data-color* blue)
+ (set! *graph-color* white)
+ (close-sound ind)))
+ (lambda args args))
+
+ (if (not (= (length jet-colormap) *colormap-size*))
+ (snd-display ";jet-colormap length: ~A ~A" (length jet-colormap) *colormap-size*))
+
+ (for-each
+ (lambda (n err)
+ (let ((inv (- 1.0 (/ 1.0 n))))
(set! *colormap-size* n)
(set! colormap-error-max err)
@@ -9663,14 +9304,14 @@ EDITS: 2
(r2 (rgb1 0))
(g2 (rgb1 1))
(b2 (rgb1 2)))
- (if (and (< x (- 1.0 (/ 1.0 n)))
+ (if (and (< x inv)
(or (cfneq r r1)
(cfneq g g1)
(cfneq b b1)
(cfneq r2 r1)
(cfneq g2 g1)
(cfneq b2 b1)))
- (snd-display #__line__ ";bone ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (snd-display ";bone ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9684,8 +9325,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";copper ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";copper ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9697,8 +9338,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";winter ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";winter ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9710,8 +9351,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";autumn ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";autumn ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9723,8 +9364,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";cool ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";cool ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9744,64 +9385,54 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";hot ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";hot ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
- (r (if (< x 3/8)
- 0.0
- (if (< x 5/8)
- (- (* 4 x) 3/2)
- (if (< x 7/8)
- 1.0
- (+ (* -4 x) 9/2)))))
- (g (if (< x 1/8)
- 0.0
- (if (< x 3/8)
- (- (* 4 x) 1/2)
- (if (< x 5/8)
- 1.0
- (if (< x 7/8)
- (+ (* -4 x) 7/2)
- 0.0)))))
- (b (if (< x 1/8)
- (+ (* 4 x) 1/2)
- (if (< x 3/8)
- 1.0
- (if (< x 5/8)
- (+ (* -4 x) 5/2)
- 0.0))))
+ (r (cond ((< x 3/8) 0.0)
+ ((< x 5/8) (- (* 4 x) 3/2))
+ ((< x 7/8) 1.0)
+ (else (+ (* -4 x) 9/2))))
+ (g (cond ((< x 1/8) 0.0)
+ ((< x 3/8) (- (* 4 x) 1/2))
+ ((< x 5/8) 1.0)
+ ((< x 7/8) (+ (* -4 x) 7/2))
+ (else 0.0)))
+ (b (cond ((< x 1/8) (+ (* 4 x) 1/2))
+ ((< x 3/8) 1.0)
+ ((< x 5/8) (+ (* -4 x) 5/2))
+ (else 0.0)))
(rgb (colormap-ref jet-colormap x))
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";jet ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";jet ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
- (if (colormap? pink-colormap)
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 3/8)
- (* 14/9 x)
- (+ (* 2/3 x) 1/3)))
- (g (if (< x 3/8)
- (* 2/3 x)
- (if (< x 3/4)
- (- (* 14/9 x) 1/3)
- (+ (* 2/3 x) 1/3))))
- (b (if (< x 3/4)
- (* 2/3 x)
- (- (* 2 x) 1)))
- (rgb (colormap-ref pink-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";pink ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
+ (when (colormap? pink-colormap)
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 3/8)
+ (* 14/9 x)
+ (+ (* 2/3 x) 1/3)))
+ (g (if (< x 3/8)
+ (* 2/3 x)
+ (if (< x 3/4)
+ (- (* 14/9 x) 1/3)
+ (+ (* 2/3 x) 1/3))))
+ (b (if (< x 3/4)
+ (* 2/3 x)
+ (- (* 2 x) 1)))
+ (rgb (colormap-ref pink-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";pink ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
@@ -9812,8 +9443,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";spring ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";spring ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9825,8 +9456,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";gray ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";gray ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9838,8 +9469,8 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";black-and-white ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";black-and-white ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -9851,182 +9482,174 @@ EDITS: 2
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";summer ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";summer ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
- (r (if (< x 2/5)
- 1.0
- (if (< x 3/5)
- (+ (* -5 x) 3)
- (if (< x 4/5)
- 0.0
- (- (* 10/3 x) 8/3)))))
- (g (if (< x 2/5)
- (* 5/2 x)
- (if (< x 3/5)
- 1.0
- (if (< x 4/5)
- (+ (* -5 x) 4)
- 0.0))))
- (b (if (< x 3/5)
- 0.0
- (if (< x 4/5)
- (- (* 5 x) 3)
- 1.0)))
+ (r (cond ((< x 2/5) 1.0)
+ ((< x 3/5) (+ (* -5 x) 3))
+ ((< x 4/5) 0.0)
+ (else (- (* 10/3 x) 8/3))))
+ (g (cond ((< x 2/5) (* 5/2 x))
+ ((< x 3/5) 1.0)
+ ((< x 4/5) (+ (* -5 x) 4))
+ (else 0.0)))
+ (b (cond ((< x 3/5) 0.0)
+ ((< x 4/5) (- (* 5 x) 3))
+ (else 1.0)))
(rgb (colormap-ref rainbow-colormap x))
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
- (if (and (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";rainbow ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";rainbow ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
(rgb (colormap-ref prism-colormap x)))
- (if (and (< x (- 1.0 (/ 1.0 n)))
- (not (feql rgb '(1 0 0)))
- (not (feql rgb '(1 0.5 0)))
- (not (feql rgb '(1 1 0)))
- (not (feql rgb '(0 1 0)))
- (not (feql rgb '(0 0 1)))
- (not (feql rgb '(.6667 0 1))))
- (snd-display #__line__ ";prism ~A" rgb))))
+ (if (not (or (>= x inv)
+ (feql rgb '(1 0 0))
+ (feql rgb '(1 0.5 0))
+ (feql rgb '(1 1 0))
+ (feql rgb '(0 1 0))
+ (feql rgb '(0 0 1))
+ (feql rgb '(0.6667000000000001 0 1))))
+ (snd-display ";prism ~A" rgb))))
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
(rgb (colormap-ref flag-colormap x)))
- (if (and (< x (- 1.0 (/ 1.0 n)))
- (not (feql rgb '(1 0 0)))
- (not (feql rgb '(1 1 1)))
- (not (feql rgb '(0 0 1)))
- (not (feql rgb '(0 0 0))))
- (snd-display #__line__ ";flag: ~A" rgb))))
- )
- (list 512 64)
- (list 0.005 0.04))
-
- (let ((ind (add-colormap "white" (lambda (size) (list (make-float-vector size 1.0) (make-float-vector size 1.0) (make-float-vector size 1.0))))))
- (if (not (colormap? ind))
- (snd-display #__line__ ";add-colormap ~A: ~A" ind (colormap? ind)))
- (if (not (feql (colormap-ref ind 0.5) '(1.0 1.0 1.0)))
- (snd-display #__line__ ";white colormap: ~A" (colormap-ref ind 0.5)))
- (let ((tag (catch #t (lambda () (set! *colormap* ind)) (lambda args args))))
- (if (or (eq? tag 'no-such-colormap)
- (not (equal? *colormap* ind))
- (not (= (colormap->integer *colormap*) (colormap->integer ind))))
- (snd-display #__line__ ";colormap white: ~A ~A ~A" tag ind *colormap*)))
- (if (not (string=? (colormap-name ind) "white"))
- (snd-display #__line__ ";white colormap name: ~A" (colormap-name ind))))
-
- (let ((tag (catch #t (lambda () (delete-colormap (integer->colormap 1234))) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display #__line__ ";delete-colormap 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap 1234) 0.5)) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display #__line__ ";colormap-ref 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap -1) 0.5)) (lambda args (car args)))))
- (if (and (not (eq? tag 'no-such-colormap))
- (not (eq? tag 'wrong-type-arg)))
- (snd-display #__line__ ";colormap-ref -1: ~A" tag)))
- (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap 1234))) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display #__line__ "; set colormap 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap -1))) (lambda args (car args)))))
- (if (and (not (eq? tag 'no-such-colormap))
- (not (eq? tag 'wrong-type-arg)))
- (snd-display #__line__ "; set colormap -1: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref copper-colormap 2.0)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";colormap-ref 2.0: ~A" tag)))
-
- (set! *colormap-size* old-colormap-size)
- (if (not (= *colormap-size* old-colormap-size))
- (snd-display #__line__ ";set colormap-size: ~A ~A" *colormap-size* old-colormap-size))
-
- (if (not (string=? (colormap-name black-and-white-colormap) "black-and-white"))
- (snd-display #__line__ ";black-and-white: ~A" (colormap-name black-and-white-colormap)))
- (if (not (string=? (colormap-name gray-colormap) "gray"))
- (snd-display #__line__ ";gray: ~A" (colormap-name gray-colormap)))
- (if (not (string=? (colormap-name rainbow-colormap) "rainbow"))
- (snd-display #__line__ ";rainbow: ~A" (colormap-name rainbow-colormap)))
-
- (let ()
- (add-colormap "purple"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ 256.0 size))
- (er (list 0 60 60 116 128 252 192 252 256 60))
- (eg (list 0 0 64 0 128 252 192 252 256 0))
- (eb (list 0 80 128 252 192 0 256 80)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i size))
- (set! (r i) (/ (envelope-interp x er) 256.0))
- (set! (g i) (/ (envelope-interp x eg) 256.0))
- (set! (b i) (/ (envelope-interp x eb) 256.0)))
- (list r g b))))
- (add-colormap "sin"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ (* 2 pi) size)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i size))
- (set! (r i) (abs (sin (* 1.5 x))))
- (set! (g i) (abs (sin (* 3.5 x))))
- (set! (b i) (abs (sin (* 2.5 x)))))
- (list r g b))))
- (add-colormap "another-sin"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ (* 2 pi) size)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i size))
- (set! (r i) (abs (sin (* 2.5 x))))
- (set! (g i) (abs (sin (* 3.5 x))))
- (set! (b i) (abs (sin (* 4.5 x)))))
- (list r g b))))
-
- (delete-colormap pink-colormap)
- (if (colormap? pink-colormap)
- (snd-display #__line__ ";delete-colormap ~A: ~A" pink-colormap (colormap? pink-colormap)))
- (let ((tag (catch #t (lambda () (set! *colormap* pink-colormap)) (lambda args args))))
- (if (or (not (eq? (car tag) 'no-such-colormap))
- (equal? *colormap* pink-colormap))
- (snd-display #__line__ ";delete pink colormap: ~A ~A ~A" tag pink-colormap *colormap*)))
-
- (for-each
- (lambda (n)
- (set! *colormap-size* n)
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 4/5) (* 5/4 x) 1.0))
- (g (* 4/5 x))
- (b (* 1/2 x))
- (rgb (colormap-ref copper-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (> n 2) (< x (- 1.0 (/ 1.0 n))) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display #__line__ ";copper size reset ~A: ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- n x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
- (list 1024 256 2 512))
- (set! *colormap-size* 512))
+ (if (not (or (>= x inv)
+ (feql rgb '(1 0 0))
+ (feql rgb '(1 1 1))
+ (feql rgb '(0 0 1))
+ (feql rgb '(0 0 0))))
+ (snd-display ";flag: ~A" rgb))))
+ ))
+ (list 512 64)
+ (list 0.005 0.04))
+
+ (let ((ind (add-colormap "white" (lambda (size) (list (make-float-vector size 1.0) (make-float-vector size 1.0) (make-float-vector size 1.0))))))
+ (if (not (colormap? ind))
+ (snd-display ";add-colormap ~A: ~A" ind (colormap? ind)))
+ (if (not (feql (colormap-ref ind 0.5) '(1.0 1.0 1.0)))
+ (snd-display ";white colormap: ~A" (colormap-ref ind 0.5)))
+ (let ((tag (catch #t (lambda () (set! *colormap* ind)) (lambda args args))))
+ (if (or (eq? tag 'no-such-colormap)
+ (not (equal? *colormap* ind))
+ (not (= (colormap->integer *colormap*) (colormap->integer ind))))
+ (snd-display ";colormap white: ~A ~A ~A" tag ind *colormap*)))
+ (if (not (string=? (colormap-name ind) "white"))
+ (snd-display ";white colormap name: ~A" (colormap-name ind))))
+
+ (let ((tag (catch #t (lambda () (delete-colormap (integer->colormap 1234))) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display ";delete-colormap 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap 1234) 0.5)) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display ";colormap-ref 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap -1) 0.5)) (lambda args (car args)))))
+ (if (not (memq tag '(no-such-colormap wrong-type-arg)))
+ (snd-display ";colormap-ref -1: ~A" tag)))
+ (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap 1234))) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display "; set colormap 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap -1))) (lambda args (car args)))))
+ (if (not (memq tag '(no-such-colormap wrong-type-arg)))
+ (snd-display "; set colormap -1: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref copper-colormap 2.0)) (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range))
+ (snd-display ";colormap-ref 2.0: ~A" tag)))
+
+ (set! *colormap-size* old-colormap-size)
+ (if (not (= *colormap-size* old-colormap-size))
+ (snd-display ";set colormap-size: ~A ~A" *colormap-size* old-colormap-size))
+
+ (if (not (string=? (colormap-name black-and-white-colormap) "black-and-white"))
+ (snd-display ";black-and-white: ~A" (colormap-name black-and-white-colormap)))
+ (if (not (string=? (colormap-name gray-colormap) "gray"))
+ (snd-display ";gray: ~A" (colormap-name gray-colormap)))
+ (if (not (string=? (colormap-name rainbow-colormap) "rainbow"))
+ (snd-display ";rainbow: ~A" (colormap-name rainbow-colormap)))
+
+ (let ()
+ (add-colormap "purple"
+ (lambda (size)
+ (let ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ 256.0 size))
+ (er (list 0 60 60 116 128 252 192 252 256 60))
+ (eg (list 0 0 64 0 128 252 192 252 256 0))
+ (eb (list 0 80 128 252 192 0 256 80)))
+ (do ((i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i size))
+ (set! (r i) (/ (envelope-interp x er) 256.0))
+ (set! (g i) (/ (envelope-interp x eg) 256.0))
+ (set! (b i) (/ (envelope-interp x eb) 256.0)))
+ (list r g b))))
+ (add-colormap "sin"
+ (lambda (size)
+ (let ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ (* 2 pi) size)))
+ (do ((i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i size))
+ (set! (r i) (abs (sin (* 1.5 x))))
+ (set! (g i) (abs (sin (* 3.5 x))))
+ (set! (b i) (abs (sin (* 2.5 x)))))
+ (list r g b))))
+ (add-colormap "another-sin"
+ (lambda (size)
+ (let ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ (* 2 pi) size)))
+ (do ((i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i size))
+ (set! (r i) (abs (sin (* 2.5 x))))
+ (set! (g i) (abs (sin (* 3.5 x))))
+ (set! (b i) (abs (sin (* 4.5 x)))))
+ (list r g b))))
+
+ (delete-colormap pink-colormap)
+ (if (colormap? pink-colormap)
+ (snd-display ";delete-colormap ~A: ~A" pink-colormap (colormap? pink-colormap)))
+ (let ((tag (catch #t (lambda () (set! *colormap* pink-colormap)) (lambda args args))))
+ (if (or (not (eq? (car tag) 'no-such-colormap))
+ (equal? *colormap* pink-colormap))
+ (snd-display ";delete pink colormap: ~A ~A ~A" tag pink-colormap *colormap*)))
- (set! (hook-functions graph-hook) ())
- )))
+ (for-each
+ (lambda (n)
+ (set! *colormap-size* n)
+ (do ((n2 (> n 2))
+ (n/n (- 1.0 (/ 1.0 n)))
+ (i 0 (+ i 1)))
+ ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 4/5) (* 5/4 x) 1.0))
+ (g (* 4/5 x))
+ (b (* 1/2 x))
+ (rgb (colormap-ref copper-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and n2 (< x n/n) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";copper size reset ~A: ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ n x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
+ (list 1024 256 2 512))
+ (set! *colormap-size* 512))
+
+ (set! (hook-functions graph-hook) ())
+ )))
@@ -10035,257 +9658,256 @@ EDITS: 2
(require snd-moog.scm snd-poly.scm snd-bird.scm snd-v.scm snd-numerics.scm snd-generators.scm)
(if (defined? 'gsl-roots) (require snd-analog-filter.scm))
-(defgenerator sa1 freq (coscar #f) (sincar #f) (dly #f) (hlb #f))
-
-(define (copy-test o)
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";copy ~A != ~A~%" o p))
- (mus-apply o 1.0)
- (if (equal? o p)
- (snd-display #__line__ ";copy/run ~A == ~A~%" o p))
- (set! p (mus-copy o))
- (if (not (equal? o p))
- (snd-display #__line__ ";mus-copy ~A != ~A~%" o p))))
-
-(define (osc-opt)
- (let ((g1 (make-oscil 1000))
- (g2 (make-oscil 1000))
- (g3 (make-oscil 1000))
- (g4 (make-oscil 1000))
- (g5 (make-oscil 1000))
- (g6 (make-oscil 1000))
- (x1 1.0)
- (x2 (hz->radians 100.0))
- (x4 (hz->radians 5.0)))
- (do ((i 0 (+ i 1)))
- ((= i 50))
- (let ((o1 (oscil g1 x2))
- (o2 (* 1.0 (oscil g2 x2)))
- (o3 (oscil g3 (* x4 20.0)))
- (o4 (oscil g4 (* 20.0 x4)))
- (o5 (oscil g5 (* x1 x2)))
- (o6 (* 1.0 (oscil g6 (* 20.0 x4)))))
- (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
- (snd-display #__line__ "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F" i o1 o2 o3 o4 o5 o6))))))
-
-(define (nrxysin-opt)
- (let ((g1 (make-nrxysin 1000 :n 10 :r .9))
- (g2 (make-nrxysin 1000 :n 10 :r .9))
- (g3 (make-nrxysin 1000 :n 10 :r .9))
- (g4 (make-nrxysin 1000 :n 10 :r .9))
- (g5 (make-nrxysin 1000 :n 10 :r .9))
- (g6 (make-nrxysin 1000 :n 10 :r .9))
- (x1 1.0)
- (x2 (hz->radians 100.0))
- (x4 (hz->radians 5.0)))
- (do ((i 0 (+ i 1)))
- ((= i 50))
- (let ((o1 (nrxysin g1 x2))
- (o2 (* 1.0 (nrxysin g2 x2)))
- (o3 (nrxysin g3 (* x4 20.0)))
- (o4 (nrxysin g4 (* 20.0 x4)))
- (o5 (nrxysin g5 (* x1 x2)))
- (o6 (* 1.0 (nrxysin g6 (* 20.0 x4)))))
- (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
- (format #t "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F~%" i o1 o2 o3 o4 o5 o6))))))
-
-(define (polywave-opt)
- (let ((g1 (make-polywave 1000 '(1 .5 2 .5)))
- (g2 (make-polywave 1000 '(1 .5 2 .5)))
- (g3 (make-polywave 1000 '(1 .5 2 .5)))
- (g4 (make-polywave 1000 '(1 .5 2 .5)))
- (g5 (make-polywave 1000 '(1 .5 2 .5)))
- (g6 (make-polywave 1000 '(1 .5 2 .5)))
- (x1 1.0)
- (x2 (hz->radians 100.0))
- (x4 (hz->radians 5.0)))
- (do ((i 0 (+ i 1)))
- ((= i 50))
- (let ((o1 (polywave g1 x2))
- (o2 (* 1.0 (polywave g2 x2)))
- (o3 (polywave g3 (* x4 20.0)))
- (o4 (polywave g4 (* 20.0 x4)))
- (o5 (polywave g5 (* x1 x2)))
- (o6 (* 1.0 (polywave g6 (* 20.0 x4)))))
- (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
- (format #t "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F~%" i o1 o2 o3 o4 o5 o6))))))
-
-(define (test-simple-polywave n offset kind)
- (let ((p (make-polywave 400.0
- (let ((h (if offset (list offset 0) (list))))
- (do ((i 1 (+ i 1)))
- ((> i n))
- (set! h (cons (* i .1) (cons i h))))
- (reverse h))
- kind))
- (vp (make-float-vector 200))
- (vo (make-float-vector 200))
- (ob (make-oscil-bank
- (apply float-vector (let ((frqs (if offset (list 0.0) (list))))
- (do ((i 1 (+ i 1)))
- ((> i n))
- (set! frqs (cons (hz->radians (* i 400.0)) frqs)))
- (reverse frqs)))
- (let ((phases (make-float-vector (+ n (if offset 1 0))
- (if (= kind mus-chebyshev-second-kind) 0.0 (/ pi 2)))))
- (if (and offset (= kind mus-chebyshev-second-kind))
- (set! (phases 0) (/ pi 2)))
- phases)
- (apply float-vector (let ((amps (if offset (list offset) (list))))
- (do ((i 1 (+ i 1)))
- ((> i n))
- (set! amps (cons (* i .1) amps)))
- (reverse amps)))
- #t)))
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (float-vector-set! vp i (polywave p)))
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (float-vector-set! vo i (oscil-bank ob)))
- (if (not (mus-arrays-equal? vp vo))
- (format *stderr* ";simple polywave ~A ~A ~A: ~A~% ~A~% ~A~%~A ~A~%"
- n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
- (float-vector-peak (float-vector-subtract! (copy vp) vo))
- vp vo
- p ob))
-
- (let ((temp 0.0))
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (set! temp (polywave p))
- (vector-set! vp i temp)
- (set! (vo i) (oscil-bank ob)))
- (if (not (mus-arrays-equal? vp vo))
- (format *stderr* ";simple polywave (temps) ~A ~A ~A: ~A~% ~A~% ~A~%~A ~A~%"
- n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
- (float-vector-peak (float-vector-subtract! (copy vp) vo))
- vp vo
- p ob)))
+;;; -------- scissor-tailed flycatcher
+;;;
+;;; mix a scissor-tailed flycatcher call into the current sound
+;;; see bird.scm for lots more birds
- (let ((t1 (with-sound ("test.snd")
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (outa i (polywave p)))))
- (t2 (with-sound ("tst.snd")
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (outa i (oscil-bank ob))))))
- (set! vp (channel->float-vector 0 200 (find-sound t1) 0))
- (set! vo (channel->float-vector 0 200 (find-sound t2) 0))
-
- (if (not (mus-arrays-equal? vp vo))
- (format *stderr* ";simple polywave (with-sound) n: ~A, offset: ~A, type: ~A (len: ~D ~D): dist: ~A~% ~A~% ~A~%~A ~A~%"
- n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
- (length vp) (length vo)
- (float-vector-peak (float-vector-subtract! (copy vp) vo))
- vp vo
- p ob))
- (close-sound (find-sound t1))
- (close-sound (find-sound t2)))))
-
-(define (test-simple-nsin n)
- (let ((p (make-nsin 400.0 n))
- (vp (make-float-vector 200))
- (vo (make-float-vector 200)))
- (let ((ob (make-oscil-bank
- (apply float-vector (let ((frqs ()))
+
+(define scissor
+ (let ((documentation "(scissor beg) is the scissor-tailed flycatcher"))
+ (lambda (begin-time) ; test 23 also
+ (let ((scissorf '(0 0 40 1 60 1 100 0)))
+ (bigbird begin-time 0.05 1800 1800 .2
+ scissorf
+ '(0 0 25 1 75 1 100 0)
+ '(1 .5 2 1 3 .5 4 .1 5 .01))))))
+
+(define (snd_test_8)
+
+ (define (copy-test o)
+ (let ((p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";copy ~A != ~A~%" o p))
+ (mus-apply o 1.0)
+ (if (equal? o p)
+ (snd-display ";copy/run ~A == ~A~%" o p))
+ (set! p (mus-copy o))
+ (if (not (equal? o p))
+ (snd-display ";mus-copy ~A != ~A~%" o p))))
+
+ (define (osc-opt)
+ (let ((g1 (make-oscil 1000))
+ (g2 (make-oscil 1000))
+ (g3 (make-oscil 1000))
+ (g4 (make-oscil 1000))
+ (g5 (make-oscil 1000))
+ (g6 (make-oscil 1000))
+ (x1 1.0)
+ (x2 (hz->radians 100.0))
+ (x4 (hz->radians 5.0)))
+ (do ((x1x2 (* x1 x2))
+ (x420 (* 20 x4))
+ (i 0 (+ i 1)))
+ ((= i 50))
+ (let ((o1 (oscil g1 x2))
+ (o2 (* 1.0 (oscil g2 x2)))
+ (o3 (oscil g3 x420))
+ (o4 (oscil g4 x420))
+ (o5 (oscil g5 x1x2))
+ (o6 (* 1.0 (oscil g6 x420))))
+ (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
+ (snd-display "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F" i o1 o2 o3 o4 o5 o6))))))
+
+ (define (nrxysin-opt)
+ (let ((g1 (make-nrxysin 1000 :n 10 :r .9))
+ (g2 (make-nrxysin 1000 :n 10 :r .9))
+ (g3 (make-nrxysin 1000 :n 10 :r .9))
+ (g4 (make-nrxysin 1000 :n 10 :r .9))
+ (g5 (make-nrxysin 1000 :n 10 :r .9))
+ (g6 (make-nrxysin 1000 :n 10 :r .9))
+ (x1 1.0)
+ (x2 (hz->radians 100.0))
+ (x4 (hz->radians 5.0)))
+ (do ((x1x2 (* x1 x2))
+ (x420 (* 20 x4))
+ (i 0 (+ i 1)))
+ ((= i 50))
+ (let ((o1 (nrxysin g1 x2))
+ (o2 (* 1.0 (nrxysin g2 x2)))
+ (o3 (nrxysin g3 x420))
+ (o4 (nrxysin g4 x420))
+ (o5 (nrxysin g5 x1x2))
+ (o6 (nrxysin g6 x420)))
+ (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
+ (format () "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F~%" i o1 o2 o3 o4 o5 o6))))))
+
+ (define (polywave-opt)
+ (let ((g1 (make-polywave 1000 '(1 .5 2 .5)))
+ (g2 (make-polywave 1000 '(1 .5 2 .5)))
+ (g3 (make-polywave 1000 '(1 .5 2 .5)))
+ (g4 (make-polywave 1000 '(1 .5 2 .5)))
+ (g5 (make-polywave 1000 '(1 .5 2 .5)))
+ (g6 (make-polywave 1000 '(1 .5 2 .5)))
+ (x1 1.0)
+ (x2 (hz->radians 100.0))
+ (x4 (hz->radians 5.0)))
+ (do ((x1x2 (* x1 x2))
+ (x420 (* 20 x4))
+ (i 0 (+ i 1)))
+ ((= i 50))
+ (let ((o1 (polywave g1 x2))
+ (o2 (* 1.0 (polywave g2 x2)))
+ (o3 (polywave g3 x420))
+ (o4 (polywave g4 x420))
+ (o5 (polywave g5 x1x2))
+ (o6 (* 1.0 (polywave g6 x420))))
+ (if (> (abs (- (+ o2 o3 o4 o5 o6) (* 5 o1))) 1e-6)
+ (format () "~A: ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F ~1,4F~%" i o1 o2 o3 o4 o5 o6))))))
+
+ (define (test-simple-polywave n offset kind)
+ (let ((p (make-polywave 400.0
+ (let ((h (if offset (list offset 0) (list))))
+ (do ((i 1 (+ i 1)))
+ ((> i n))
+ (set! h (cons (* i .1) (cons i h))))
+ (reverse h))
+ kind))
+ (vp (make-float-vector 200))
+ (vo (make-float-vector 200))
+ (ob (make-oscil-bank
+ (apply float-vector (let ((frqs (if offset (list 0.0) (list))))
(do ((i 1 (+ i 1)))
((> i n))
(set! frqs (cons (hz->radians (* i 400.0)) frqs)))
(reverse frqs)))
- (make-float-vector n 0.0)
- (make-float-vector n (mus-scaler p))
- #t)))
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (float-vector-set! vp i (nsin p)))
- (do ((i 0 (+ i 1)))
- ((= i 200))
- (float-vector-set! vo i (oscil-bank ob)))
- (if (not (mus-arrays-equal? vp vo))
- (format *stderr* ";simple nsin ~A: ~A~% ~A~% ~A~%~A ~A~%"
- n
- (float-vector-peak (float-vector-subtract! (copy vp) vo))
- vp vo
- p ob)))))
-
-(define (test-simple-ncos n)
- (let ((p (make-ncos 400.0 n))
- (vp (make-float-vector 200))
- (vo (make-float-vector 200)))
- (let ((ob (make-oscil-bank
- (apply float-vector (let ((frqs ()))
+ (let ((phases (make-float-vector (+ n (if offset 1 0))
+ (if (= kind mus-chebyshev-second-kind) 0.0 (/ pi 2)))))
+ (if (and offset (= kind mus-chebyshev-second-kind))
+ (set! (phases 0) (/ pi 2)))
+ phases)
+ (apply float-vector (let ((amps (if offset (list offset) (list))))
(do ((i 1 (+ i 1)))
((> i n))
- (set! frqs (cons (hz->radians (* i 400.0)) frqs)))
- (reverse frqs)))
- (make-float-vector n (/ pi 2.0))
- (make-float-vector n (mus-scaler p))
+ (set! amps (cons (* i .1) amps)))
+ (reverse amps)))
#t)))
(do ((i 0 (+ i 1)))
((= i 200))
- (float-vector-set! vp i (ncos p)))
+ (float-vector-set! vp i (polywave p)))
(do ((i 0 (+ i 1)))
((= i 200))
(float-vector-set! vo i (oscil-bank ob)))
(if (not (mus-arrays-equal? vp vo))
- (format *stderr* ";simple ncos ~A: ~A~% ~A~% ~A~%~A ~A~%"
- n
+ (format *stderr* ";simple polywave ~A ~A ~A: ~A~% ~A~% ~A~%~A ~A~%"
+ n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
(float-vector-peak (float-vector-subtract! (copy vp) vo))
vp vo
- p ob)))))
-
-(define (snd-test-jc-reverb decay-dur low-pass volume amp-env)
- (let ((allpass1 (make-all-pass -0.700 0.700 1051))
- (allpass2 (make-all-pass -0.700 0.700 337))
- (allpass3 (make-all-pass -0.700 0.700 113))
- (comb1 (make-comb 0.742 4799))
- (comb2 (make-comb 0.733 4999))
- (comb3 (make-comb 0.715 5399))
- (comb4 (make-comb 0.697 5801))
- (dur (+ decay-dur (/ (framples) (srate))))
- (outdel (make-delay (seconds->samples .013))))
- (let ((combs (make-comb-bank (vector comb1 comb2 comb3 comb4)))
- (allpasses (make-all-pass-bank (vector allpass1 allpass2 allpass3))))
- (if (or amp-env low-pass)
- (let ((flt (and low-pass (make-fir-filter 3 (float-vector 0.25 0.5 0.25))))
- (envA (make-env :envelope (or amp-env '(0 1 1 1)) :scaler volume :duration dur)))
- (if low-pass
- (map-channel
- (lambda (inval)
- (+ inval (delay outdel (* (env envA) (fir-filter flt (comb-bank combs (all-pass-bank allpasses inval)))))))
- 0 (round (* dur (srate))))
- (map-channel
- (lambda (inval)
- (+ inval (delay outdel (* (env envA) (comb-bank combs (all-pass-bank allpasses inval))))))
- 0 (round (* dur (srate))))))
- (map-channel
- (lambda (inval)
- (+ inval (delay outdel (* volume (comb-bank combs (all-pass-bank allpasses inval))))))
- 0 (round (* dur (srate))))))))
-
-
-
-
-;;; -------- scissor-tailed flycatcher
-;;;
-;;; mix a scissor-tailed flycatcher call into the current sound
-;;; see bird.scm for lots more birds
-
-
-(define scissor
- (let ((documentation "(scissor beg) is the scissor-tailed flycatcher"))
- (lambda (begin-time) ; test 23 also
- (let ((scissorf '(0 0 40 1 60 1 100 0)))
- (bigbird begin-time 0.05 1800 1800 .2
- scissorf
- '(0 0 25 1 75 1 100 0)
- '(1 .5 2 1 3 .5 4 .1 5 .01))))))
-
-
-(define (snd_test_8)
+ p ob))
+
+ (let ((temp 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (set! temp (polywave p))
+ (vector-set! vp i temp)
+ (set! (vo i) (oscil-bank ob)))
+ (if (not (mus-arrays-equal? vp vo))
+ (format *stderr* ";simple polywave (temps) ~A ~A ~A: ~A~% ~A~% ~A~%~A ~A~%"
+ n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
+ (float-vector-peak (float-vector-subtract! (copy vp) vo))
+ vp vo
+ p ob)))
+
+ (let ((t1 (with-sound ("test.snd")
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (outa i (polywave p)))))
+ (t2 (with-sound ("tst.snd")
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (outa i (oscil-bank ob))))))
+ (set! vp (channel->float-vector 0 200 (find-sound t1) 0))
+ (set! vo (channel->float-vector 0 200 (find-sound t2) 0))
+
+ (if (not (mus-arrays-equal? vp vo))
+ (format *stderr* ";simple polywave (with-sound) n: ~A, offset: ~A, type: ~A (len: ~D ~D): dist: ~A~% ~A~% ~A~%~A ~A~%"
+ n offset (if (= kind mus-chebyshev-first-kind) 'first 'second)
+ (length vp) (length vo)
+ (float-vector-peak (float-vector-subtract! (copy vp) vo))
+ vp vo
+ p ob))
+ (close-sound (find-sound t1))
+ (close-sound (find-sound t2)))))
+
+ (define (test-simple-nsin n)
+ (let ((p (make-nsin 400.0 n))
+ (vp (make-float-vector 200))
+ (vo (make-float-vector 200)))
+ (let ((ob (make-oscil-bank
+ (apply float-vector (let ((frqs ()))
+ (do ((i 1 (+ i 1)))
+ ((> i n))
+ (set! frqs (cons (hz->radians (* i 400.0)) frqs)))
+ (reverse frqs)))
+ (make-float-vector n 0.0)
+ (make-float-vector n (mus-scaler p))
+ #t)))
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (float-vector-set! vp i (nsin p)))
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (float-vector-set! vo i (oscil-bank ob)))
+ (if (not (mus-arrays-equal? vp vo))
+ (format *stderr* ";simple nsin ~A: ~A~% ~A~% ~A~%~A ~A~%"
+ n
+ (float-vector-peak (float-vector-subtract! (copy vp) vo))
+ vp vo
+ p ob)))))
+
+ (define (test-simple-ncos n)
+ (let ((p (make-ncos 400.0 n))
+ (vp (make-float-vector 200))
+ (vo (make-float-vector 200)))
+ (let ((ob (make-oscil-bank
+ (apply float-vector (let ((frqs ()))
+ (do ((i 1 (+ i 1)))
+ ((> i n))
+ (set! frqs (cons (hz->radians (* i 400.0)) frqs)))
+ (reverse frqs)))
+ (make-float-vector n (/ pi 2.0))
+ (make-float-vector n (mus-scaler p))
+ #t)))
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (float-vector-set! vp i (ncos p)))
+ (do ((i 0 (+ i 1)))
+ ((= i 200))
+ (float-vector-set! vo i (oscil-bank ob)))
+ (if (not (mus-arrays-equal? vp vo))
+ (format *stderr* ";simple ncos ~A: ~A~% ~A~% ~A~%~A ~A~%"
+ n
+ (float-vector-peak (float-vector-subtract! (copy vp) vo))
+ vp vo
+ p ob)))))
+
+ (define (snd-test-jc-reverb decay-dur low-pass volume amp-env)
+ (let ((allpass1 (make-all-pass -0.700 0.700 1051))
+ (allpass2 (make-all-pass -0.700 0.700 337))
+ (allpass3 (make-all-pass -0.700 0.700 113))
+ (comb1 (make-comb 0.742 4799))
+ (comb2 (make-comb 0.733 4999))
+ (comb3 (make-comb 0.715 5399))
+ (comb4 (make-comb 0.697 5801))
+ (dur (+ decay-dur (/ (framples) (srate))))
+ (outdel (make-delay (seconds->samples .013))))
+ (let ((combs (make-comb-bank (vector comb1 comb2 comb3 comb4)))
+ (allpasses (make-all-pass-bank (vector allpass1 allpass2 allpass3))))
+ (if (or amp-env low-pass)
+ (let ((flt (and low-pass (make-fir-filter 3 (float-vector 0.25 0.5 0.25))))
+ (envA (make-env :envelope (or amp-env '(0 1 1 1)) :scaler volume :duration dur)))
+ (map-channel
+ (if low-pass
+ (lambda (inval)
+ (+ inval (delay outdel (* (env envA) (fir-filter flt (comb-bank combs (all-pass-bank allpasses inval)))))))
+ (lambda (inval)
+ (+ inval (delay outdel (* (env envA) (comb-bank combs (all-pass-bank allpasses inval)))))))
+ 0 (round (* dur (srate)))))
+ (map-channel
+ (lambda (inval)
+ (+ inval (delay outdel (* volume (comb-bank combs (all-pass-bank allpasses inval))))))
+ 0 (round (* dur (srate))))))))
+
;; ----------------
(define (bumpy)
@@ -10298,8 +9920,8 @@ EDITS: 2
(let ((val (if (or (<= x start) ; don't divide by zero
(>= x end))
0.0
- (* (exp (/ -1.0 (- x start)))
- (exp (/ -1.0 (- end x)))))))
+ (exp (+ (/ -1.0 (- x start))
+ (/ -1.0 (- end x)))))))
(set! x (+ x xi))
(* scl val))))))
@@ -10315,24 +9937,23 @@ EDITS: 2
((= i 12))
(let ((val (sin (/ (* 2 pi i) 12.0))))
(set! (x1 (+ i (- (/ size 4) 6))) val)))
- (let ((gen1 (make-table-lookup 440.0 :wave x1))
- (gen2 (make-table-lookup 440.0 :wave x2))
- (recompute-samps 30) ;just a quick guess
- (data (make-float-vector dur)))
- (do ((i 0 (+ i 1))
- (k 0.0)
- (kincr (/ 1.0 recompute-samps)))
- ((= i dur))
- (if (>= k 1.0)
- (begin
- (set! k 0.0)
- (compute-uniform-circular-string size x0 x1 x2 mass xspring damp))
- (set! k (+ k kincr)))
- (let ((g1 (table-lookup gen1))
- (g2 (table-lookup gen2)))
- (set! (data i) (+ g2 (* k (- g1 g2))))))
- (let ((curamp (float-vector-peak data)))
- (float-vector-scale! data (/ amp curamp)))
+ (let ((data (make-float-vector dur)))
+ (let ((recompute-samps 30) ;just a quick guess
+ (gen1 (make-table-lookup 440.0 :wave x1))
+ (gen2 (make-table-lookup 440.0 :wave x2)))
+ (do ((i 0 (+ i 1))
+ (k 0.0)
+ (kincr (/ 1.0 recompute-samps)))
+ ((= i dur))
+ (if (>= k 1.0)
+ (begin
+ (set! k 0.0)
+ (compute-uniform-circular-string size x0 x1 x2 mass xspring damp))
+ (set! k (+ k kincr)))
+ (let ((g1 (table-lookup gen1))
+ (g2 (table-lookup gen2)))
+ (set! (data i) (+ g2 (* k (- g1 g2)))))))
+ (float-vector-scale! data (/ amp (float-vector-peak data)))
(float-vector->channel data 0 dur)))))
;; (test-scanned-synthesis .1 10000 1.0 0.1 0.0)
@@ -10384,12 +10005,14 @@ EDITS: 2
(lambda (n w)
(let ((mat (make-float-vector (list n n) 0.0))
(cw (cos (* 2 pi w))))
- (do ((i 0 (+ i 1)))
+ (do ((n-1 (- n 1))
+ (n/2 (* 0.5 (- n 1)))
+ (i 0 (+ i 1)))
((= i n))
- (let ((n2 (- (* 0.5 (- n 1)) i)))
+ (let ((n2 (- n/2 i)))
(set! (mat i i) (* cw n2 n2))
- (if (< i (- n 1))
- (set! (mat i (+ i 1)) (* 0.5 (+ i 1) (- n 1 i))))
+ (if (< i n-1)
+ (set! (mat i (+ i 1)) (* 0.5 (+ i 1) (- n-1 i))))
(if (> i 0)
(set! (mat i (- i 1)) (* 0.5 i (- n i))))))
(let* ((vc (vector-ref (cadr (gsl-eigenvectors mat)) 0)) ; cadr->vector of fv-vectors
@@ -10405,7 +10028,7 @@ EDITS: 2
;; ----------------
(define (test-lpc)
- (define (make-sine n)
+ (define* (make-sine (n 16))
(let ((data (make-float-vector n 0.0))
(incr (/ (* 2.0 pi) n)))
(do ((i 0 (+ i 1))
@@ -10424,38 +10047,38 @@ EDITS: 2
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7) 8 (lpc-coeffs (float-vector 0 1 2 3 4 5 6 7) 8 4) 4 2)))
(if (not (vequal vals (float-vector 7.906 8.557)))
- (snd-display #__line__ ";predict ramp: ~A" vals)))
+ (snd-display ";predict ramp: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7) 8 (lpc-coeffs (float-vector 0 1 2 3 4 5 6 7) 8 7) 7 2)))
(if (not (vequal vals (float-vector 7.971 8.816)))
- (snd-display #__line__ ";predict ramp 1: ~A" vals)))
+ (snd-display ";predict ramp 1: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15
(lpc-coeffs (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15 7) 7 5)))
(if (not (vequal vals (float-vector 14.999 15.995 16.980 17.940 18.851)))
- (snd-display #__line__ ";predict ramp 2: ~A" vals)))
+ (snd-display ";predict ramp 2: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15
(lpc-coeffs (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15 14) 14 5)))
(if (not (vequal vals (float-vector 15.000 16.000 16.998 17.991 18.971)))
- (snd-display #__line__ ";predict ramp 3: ~A" vals)))
- (let ((vals (lpc-predict (make-sine 16) 16 (lpc-coeffs (make-sine 16) 16 8) 8 2)))
+ (snd-display ";predict ramp 3: ~A" vals)))
+ (let ((vals (lpc-predict (make-sine) 16 (lpc-coeffs (make-sine) 16 8) 8 2)))
(if (not (vequal vals (float-vector 0.000 0.383)))
- (snd-display #__line__ ";predict sine: ~A" vals)))
- (let ((vals (lpc-predict (make-sine 16) 16 (lpc-coeffs (make-sine 16) 16 8) 8 8)))
+ (snd-display ";predict sine: ~A" vals)))
+ (let ((vals (lpc-predict (make-sine) 16 (lpc-coeffs (make-sine) 16 8) 8 8)))
(if (not (vequal vals (float-vector 0.000 0.383 0.707 0.924 1.000 0.924 0.707 0.383)))
- (snd-display #__line__ ";predict sine 1: ~A" vals)))
+ (snd-display ";predict sine 1: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 8) 8 8)))
(if (not (vequal vals (float-vector 0.000 0.379 0.686 0.880 0.970 1.001 1.022 1.053)))
- (snd-display #__line__ ";predict sines: ~A" vals)))
+ (snd-display ";predict sines: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 16) 16 8)))
- (if (and (not (vequal vals (float-vector 0.000 0.379 0.684 0.876 0.961 0.987 1.006 1.046)))
- (not (vequal vals (float-vector 0.000 0.379 0.685 0.876 0.961 0.985 0.998 1.029))))
- (snd-display #__line__ ";predict sines 1: ~A" vals)))
+ (if (not (or (vequal vals (float-vector 0.000 0.379 0.684 0.876 0.961 0.987 1.006 1.046))
+ (vequal vals (float-vector 0.000 0.379 0.685 0.876 0.961 0.985 0.998 1.029))))
+ (snd-display ";predict sines 1: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 30) 30 4)))
- (if (and (not (vequal vals (float-vector 0.000 0.379 0.685 0.878)))
- (not (vequal vals (float-vector 0.000 0.379 0.684 0.875)))) ; double float-vectors
- (snd-display #__line__ ";predict sines 2: ~A" vals)))
+ (if (not (or (vequal vals (float-vector 0.000 0.379 0.685 0.878))
+ (vequal vals (float-vector 0.000 0.379 0.684 0.875)))) ; double float-vectors
+ (snd-display ";predict sines 2: ~A" vals)))
(let ((vals (lpc-predict (make-sines 64) 64 (lpc-coeffs (make-sines 64) 64 32) 32 8)))
(if (not (vequal vals (float-vector 0.000 0.195 0.379 0.545 0.684 0.795 0.875 0.927)))
- (snd-display #__line__ ";predict sines 3: ~A" vals))))
+ (snd-display ";predict sines 3: ~A" vals))))
;; ----------------
(define (test-unclip-channel)
@@ -10473,16 +10096,16 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 20)) (snd-display #__line__ ";unclip-channel 0 oboe clips: ~A" clips))
- (if (not (= lmax 1)) (snd-display #__line__ ";unclip-channel 0 oboe max len: ~A" lmax))
- (if (fneq umax .999) (snd-display #__line__ ";unclip-channel 0 oboe maxamp: ~A" umax)))
+ (if (not (= clips 20)) (snd-display ";unclip-channel 0 oboe clips: ~A" clips))
+ (if (not (= lmax 1)) (snd-display ";unclip-channel 0 oboe max len: ~A" lmax))
+ (if (fneq umax .999) (snd-display ";unclip-channel 0 oboe maxamp: ~A" umax)))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(e (make-env '(0 0 1 .8 1.5 1.0 2.0 1.0 2.5 .8 3.5 0) :length 101))
(o (make-oscil 1000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* 1.05 (env e) (oscil o))))
(float-vector->channel data 0 100 ind 0)
(float-vector->channel data 0 100 ind 1))
@@ -10491,16 +10114,16 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 1 sine clips: ~A" clips))
- (if (not (= lmax 2)) (snd-display #__line__ ";unclip-channel 1 sine max len: ~A" lmax))
- (if (fneq umax .999) (snd-display #__line__ ";unclip-channel 1 sine maxamp: ~A" umax)))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 1 sine clips: ~A" clips))
+ (if (not (= lmax 2)) (snd-display ";unclip-channel 1 sine max len: ~A" lmax))
+ (if (fneq umax .999) (snd-display ";unclip-channel 1 sine maxamp: ~A" umax)))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(e (make-env '(0 0 1 .8 1.75 1.0 2.0 1.0 2.25 .8 3.5 0) :length 101))
(o (make-oscil 1000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* 1.1 (env e) (oscil o))))
(float-vector->channel data 0 100 ind 0)
(float-vector->channel data 0 100 ind 1))
@@ -10509,9 +10132,9 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 2 sine clips: ~A" clips))
- (if (not (= lmax 3)) (snd-display #__line__ ";unclip-channel 2 sine max len: ~A" lmax))
- (if (fneq umax .999) (snd-display #__line__ ";unclip-channel 2 sine maxamp: ~A" umax)))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 2 sine clips: ~A" clips))
+ (if (not (= lmax 3)) (snd-display ";unclip-channel 2 sine max len: ~A" lmax))
+ (if (fneq umax .999) (snd-display ";unclip-channel 2 sine maxamp: ~A" umax)))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
@@ -10519,7 +10142,7 @@ EDITS: 2
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* 1.2 (env e) (+ (* .75 (oscil o1)) (* .25 (oscil o2))))))
(float-vector->channel data 0 100 ind 0)
(float-vector->channel data 0 100 ind 1))
@@ -10528,9 +10151,9 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 3 sine clips: ~A" clips))
- (if (not (= lmax 1)) (snd-display #__line__ ";unclip-channel 3 sine max len: ~A" lmax))
- (if (fneq umax .999) (snd-display #__line__ ";unclip-channel 3 sine maxamp: ~A" umax)))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 3 sine clips: ~A" clips))
+ (if (not (= lmax 1)) (snd-display ";unclip-channel 3 sine max len: ~A" lmax))
+ (if (fneq umax .999) (snd-display ";unclip-channel 3 sine maxamp: ~A" umax)))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
@@ -10538,7 +10161,7 @@ EDITS: 2
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* 1.5 (env e) (+ (* .75 (oscil o1)) (* .25 (oscil o2))))))
(float-vector->channel data 0 100 ind 0)
(float-vector->channel data 0 100 ind 1))
@@ -10547,15 +10170,15 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 4 sine clips: ~A" clips))
- (if (not (= lmax 4)) (snd-display #__line__ ";unclip-channel 4 sine max len: ~A" lmax))
- (if (fneq umax .999) (snd-display #__line__ ";unclip-channel 4 sine maxamp: ~A" umax)))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 4 sine clips: ~A" clips))
+ (if (not (= lmax 4)) (snd-display ";unclip-channel 4 sine max len: ~A" lmax))
+ (if (fneq umax .999) (snd-display ";unclip-channel 4 sine maxamp: ~A" umax)))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* .25 (oscil o1))))
(let ((true-max (float-vector-peak data)))
(set! (data 50) (+ (data 50) 1.25))
@@ -10566,15 +10189,15 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 5 click clips: ~A" clips))
- (if (not (= lmax 1)) (snd-display #__line__ ";unclip-channel 5 click max len: ~A" lmax))
- (if (fneq umax true-max) (snd-display #__line__ ";unclip-channel 5 click maxamp: ~A ~A" umax true-max)))))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 5 click clips: ~A" clips))
+ (if (not (= lmax 1)) (snd-display ";unclip-channel 5 click max len: ~A" lmax))
+ (if (fneq umax true-max) (snd-display ";unclip-channel 5 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* .25 (oscil o1))))
(let ((true-max (float-vector-peak data)))
(do ((i 49 (+ i 1)))
@@ -10587,15 +10210,15 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 6 click clips: ~A" clips))
- (if (not (= lmax 2)) (snd-display #__line__ ";unclip-channel 6 click max len: ~A" lmax))
- (if (fneq umax true-max) (snd-display #__line__ ";unclip-channel 6 click maxamp: ~A ~A" umax true-max)))))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 6 click clips: ~A" clips))
+ (if (not (= lmax 2)) (snd-display ";unclip-channel 6 click max len: ~A" lmax))
+ (if (fneq umax true-max) (snd-display ";unclip-channel 6 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* .25 (oscil o1))))
(let ((true-max (float-vector-peak data)))
(do ((i 45 (+ i 1)))
@@ -10608,16 +10231,16 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 7 click clips: ~A" clips))
- (if (not (= lmax 10)) (snd-display #__line__ ";unclip-channel 7 click max len: ~A" lmax))
- (if (fneq umax true-max) (snd-display #__line__ ";unclip-channel 7 click maxamp: ~A ~A" umax true-max)))))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 7 click clips: ~A" clips))
+ (if (not (= lmax 10)) (snd-display ";unclip-channel 7 click max len: ~A" lmax))
+ (if (fneq umax true-max) (snd-display ";unclip-channel 7 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
(let ((data (make-float-vector 100 0.0))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
- ((= i 100) data)
+ ((= i 100))
(set! (data i) (* .25 (+ (oscil o1) (oscil o2)))))
(let ((true-max (float-vector-peak data)))
(do ((i 45 (+ i 1)))
@@ -10630,16 +10253,16 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 1)) (snd-display #__line__ ";unclip-channel 8 click clips: ~A" clips))
- (if (not (= lmax 10)) (snd-display #__line__ ";unclip-channel 8 click max len: ~A" lmax))
- (if (fneq umax true-max) (snd-display #__line__ ";unclip-channel 8 click maxamp: ~A ~A" umax true-max)))))
+ (if (not (= clips 1)) (snd-display ";unclip-channel 8 click clips: ~A" clips))
+ (if (not (= lmax 10)) (snd-display ";unclip-channel 8 click max len: ~A" lmax))
+ (if (fneq umax true-max) (snd-display ";unclip-channel 8 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
(let ((data (make-float-vector 200 0.0))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
- ((= i 200) data)
+ ((= i 200))
(set! (data i) (* .25 (+ (oscil o1) (oscil o2)))))
(let ((true-max (float-vector-peak data)))
(do ((i 45 (+ i 1)))
@@ -10655,9 +10278,9 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 2)) (snd-display #__line__ ";unclip-channel 9 collision clips: ~A" clips))
- (if (not (= lmax 10)) (snd-display #__line__ ";unclip-channel 9 collision max len: ~A" lmax))
- (if (fneq umax true-max) (snd-display #__line__ ";unclip-channel 9 collision maxamp: ~A ~A" umax true-max)))))
+ (if (not (= clips 2)) (snd-display ";unclip-channel 9 collision clips: ~A" clips))
+ (if (not (= lmax 10)) (snd-display ";unclip-channel 9 collision max len: ~A" lmax))
+ (if (fneq umax true-max) (snd-display ";unclip-channel 9 collision maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
(mix "oboe.snd" 0 0 ind 0 #f)
@@ -10668,9 +10291,9 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 20)) (snd-display #__line__ ";unclip-channel 10 oboe clips: ~A" clips))
- (if (not (= lmax 1)) (snd-display #__line__ ";unclip-channel 10 oboe max len: ~A" lmax))
- (if (fneq umax 0.999) (snd-display #__line__ ";unclip-channel 10 oboe maxamp: ~A" umax)))
+ (if (not (= clips 20)) (snd-display ";unclip-channel 10 oboe clips: ~A" clips))
+ (if (not (= lmax 1)) (snd-display ";unclip-channel 10 oboe max len: ~A" lmax))
+ (if (fneq umax 0.999) (snd-display ";unclip-channel 10 oboe maxamp: ~A" umax)))
(revert-sound ind)
(mix "oboe.snd" 0 0 ind 0 #f)
@@ -10681,9 +10304,9 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 217)) (snd-display #__line__ ";unclip-channel 11 oboe clips: ~A" clips))
- (if (not (= lmax 2)) (snd-display #__line__ ";unclip-channel 11 oboe max len: ~A" lmax))
- (if (fneq umax 0.999) (snd-display #__line__ ";unclip-channel 11 oboe maxamp: ~A" umax)))
+ (if (not (= clips 217)) (snd-display ";unclip-channel 11 oboe clips: ~A" clips))
+ (if (not (= lmax 2)) (snd-display ";unclip-channel 11 oboe max len: ~A" lmax))
+ (if (fneq umax 0.999) (snd-display ";unclip-channel 11 oboe maxamp: ~A" umax)))
(revert-sound ind)
(mix "oboe.snd" 0 0 ind 0 #f)
@@ -10695,18 +10318,16 @@ EDITS: 2
(umax (vals 1))
(clips (vals 3))
(lmax (vals 5)))
- (if (not (= clips 28)) (snd-display #__line__ ";unclip-channel 12 oboe clips: ~A" clips))
- (if (not (= lmax 3)) (snd-display #__line__ ";unclip-channel 12 oboe max len: ~A" lmax))
- (if (fneq umax 0.999) (snd-display #__line__ ";unclip-channel 12 oboe maxamp: ~A" umax)))
+ (if (not (= clips 28)) (snd-display ";unclip-channel 12 oboe clips: ~A" clips))
+ (if (not (= lmax 3)) (snd-display ";unclip-channel 12 oboe max len: ~A" lmax))
+ (if (fneq umax 0.999) (snd-display ";unclip-channel 12 oboe maxamp: ~A" umax)))
(close-sound ind)))
;; ----------------
(define (analog-filter-tests)
- (define v (make-float-vector 1000))
-
- (define (sweep->bins flt bins)
+ (define* (sweep->bins flt (bins 10))
(let ((ind (open-sound "sweep.snd")))
(if (mus-generator? flt)
(clm-channel flt)
@@ -10722,11 +10343,12 @@ EDITS: 2
(list mx resp))))
(define (filter-response-max f1)
- (set! (v 0) (f1 1.0))
- (do ((i 1 (+ i 1)))
- ((= i 1000))
- (set! (v i) (filter f1 0.0)))
- (float-vector-peak v))
+ (let ((v (make-float-vector 1000)))
+ (set! (v 0) (f1 1.0))
+ (do ((i 1 (+ i 1)))
+ ((= i 1000))
+ (set! (v i) (filter f1 0.0)))
+ (float-vector-peak v)))
(define (filter-equal? f1 f2) ; equalp in clm2xen is too restrictive
(and (= (mus-order f1) (mus-order f2))
@@ -10745,32 +10367,32 @@ EDITS: 2
((>= i 12))
(let ((vals (butterworth-prototype i)))
(if (not (vequal (cadr vals) (poles k)))
- (snd-display #__line__ ";butterworth prototype poles ~A: ~A (~A)" i (cadr vals) (poles k)))
+ (snd-display ";butterworth prototype poles ~A: ~A (~A)" i (cadr vals) (poles k)))
(let ((zeros (make-float-vector (* (+ k 1) 3))))
(do ((j 2 (+ j 3)))
((>= j (* (+ k 1) 3)))
(set! (zeros j) 1.0))
(if (not (vequal (car vals) zeros))
- (snd-display #__line__ ";butterworth prototype zeros ~A: ~A (~A)" i (car vals) zeros)))))
- (do ((cutoff .1 (+ cutoff .1))
- (m 0 (+ 1 m)))
- ((= m 3))
- (do ((i 2 (+ i 2))
- (k 1 (+ k 1)))
- ((= i 16))
- (let ((local (make-butterworth-lowpass i cutoff))
- (dsp (make-butter-lp k (* *clm-srate* cutoff))))
- (if (not (filter-equal? local dsp))
- (snd-display #__line__ ";butterworth lowpass ~A ~A ~A" cutoff local dsp)))
- (let ((local (make-butterworth-highpass i cutoff))
- (dsp (make-butter-hp k (* *clm-srate* cutoff))))
- (if (not (filter-equal? local dsp))
- (snd-display #__line__ ";butterworth highpass ~A ~A ~A" cutoff local dsp)))))
-
+ (snd-display ";butterworth prototype zeros ~A: ~A (~A)" i (car vals) zeros))))))
+ (do ((cutoff .1 (+ cutoff .1))
+ (m 0 (+ 1 m)))
+ ((= m 3))
+ (do ((clm-cutoff (* *clm-srate* cutoff))
+ (i 2 (+ i 2))
+ (k 1 (+ k 1)))
+ ((= i 16))
+ (let ((local (make-butterworth-lowpass i cutoff))
+ (dsp (make-butter-lp k clm-cutoff)))
+ (if (not (filter-equal? local dsp))
+ (snd-display ";butterworth lowpass ~A ~A ~A" cutoff local dsp)))
+ (let ((local (make-butterworth-highpass i cutoff))
+ (dsp (make-butter-hp k clm-cutoff)))
+ (if (not (filter-equal? local dsp))
+ (snd-display ";butterworth highpass ~A ~A ~A" cutoff local dsp))))
+
(let ((ind (open-sound "oboe.snd")))
(map-channel (make-eliminate-hum 550))
- (let ((peaker (make-peaking-2 500 1000 1.0)))
- (map-channel peaker))
+ (map-channel (make-peaking-2 500 1000 1.0))
(map-channel (chordalize))
(close-sound ind))
@@ -10786,21 +10408,21 @@ EDITS: 2
(close-sound ind))
(let* ((f1 (make-butterworth-lowpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth lp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth lp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.359 0.014 0.001 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";butterworth lp 8 .1 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth lp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-lowpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth lp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth lp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.358 0.010 0.000 0.000 0.000)))
- (snd-display #__line__ ";butterworth lp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth lp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-lowpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth lp 10 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.361 0.001)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.360 0.002))))
- (snd-display #__line__ ";butterworth lp 10 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth lp 10 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.361 0.001))
+ (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.360 0.002))))
+ (snd-display ";butterworth lp 10 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 12))
@@ -10809,41 +10431,41 @@ EDITS: 2
(let* ((f1 (make-butterworth-lowpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";butter low max ~A ~A: ~A" i j mx)))))
+ (snd-display ";butter low max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-butterworth-highpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth hp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth hp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.348 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
- (snd-display #__line__ ";butterworth hp 8 .1 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth hp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-highpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth hp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth hp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.011 0.348 0.500 0.500 0.500 0.500 0.500)))
- (snd-display #__line__ ";butterworth hp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth hp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-highpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";butterworth hp 10 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";butterworth hp 10 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.005 0.343 0.501 0.501)))
- (snd-display #__line__ ";butterworth hp 10 .4 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth hp 10 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-bandpass 4 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bp 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.028 0.350 0.481 0.479 0.346 0.132 0.038 0.009 0.002 0.000)))
- (snd-display #__line__ ";butterworth bp 4 .1 .2 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth bp 4 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-bandpass 12 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bp 12 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.006 0.317 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.012 0.319 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.323 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";butterworth bp 12 .1 .2 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 12 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.006 0.317 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.012 0.319 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.000 0.323 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))))
+ (snd-display ";butterworth bp 12 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-bandpass 8 .3 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.003 0.034 0.344 0.499 0.499 0.353 0.002)))
- (snd-display #__line__ ";butterworth bp 8 .3 .4 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth bp 8 .3 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 12))
@@ -10852,25 +10474,25 @@ EDITS: 2
(let* ((f1 (make-butterworth-highpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";butter high max ~A ~A: ~A" i j mx)))))
+ (snd-display ";butter high max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-butterworth-bandstop 4 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bs 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.347 0.339 0.481 0.499 0.500 0.500 0.500 0.500)))
- (snd-display #__line__ ";butterworth bs 4 .1 .2 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth bs 4 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-bandstop 12 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bs 12 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.503 0.503 0.364 0.334 0.500 0.500 0.500 0.500 0.500 0.500)))
- (not (vequal1 (cadr vals) (float-vector 0.502 0.503 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))))
- (snd-display #__line__ ";butterworth bs 12 .1 .2 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 12 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.503 0.503 0.364 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
+ (vequal1 (cadr vals) (float-vector 0.502 0.503 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
+ (vequal1 (cadr vals) (float-vector 0.500 0.500 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))))
+ (snd-display ";butterworth bs 12 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-butterworth-bandstop 8 .3 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";butterworth bs 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.498 0.354 0.332 0.500 0.500)))
- (snd-display #__line__ ";butterworth bs 8 .3 .4 spect: ~A" (cadr vals))))
+ (snd-display ";butterworth bs 8 .3 .4 spect: ~A" (cadr vals))))
;; ---------------- Chebyshev ----------------
@@ -10902,34 +10524,34 @@ EDITS: 2
((>= i 12))
(let ((vals (chebyshev-prototype i .01)))
(if (not (vequal1 (cadr vals) (poles-01 k)))
- (snd-display #__line__ ";chebyshev prototype .01 poles ~A: ~A (~A)" i (cadr vals) (poles-01 k))))
+ (snd-display ";chebyshev prototype .01 poles ~A: ~A (~A)" i (cadr vals) (poles-01 k))))
(let ((vals (chebyshev-prototype i .1)))
(if (not (vequal1 (cadr vals) (poles-1 k)))
- (snd-display #__line__ ";chebyshev prototype .1 poles ~A: ~A (~A)" i (cadr vals) (poles-1 k))))
+ (snd-display ";chebyshev prototype .1 poles ~A: ~A (~A)" i (cadr vals) (poles-1 k))))
(let ((vals (chebyshev-prototype i)))
(if (not (vequal1 (cadr vals) (poles-10 k)))
- (snd-display #__line__ ";chebyshev prototype 1 poles ~A: ~A (~A)" i (cadr vals) (poles-10 k)))
+ (snd-display ";chebyshev prototype 1 poles ~A: ~A (~A)" i (cadr vals) (poles-10 k)))
(if (not (vequal (car vals) (zeros k)))
- (snd-display #__line__ ";chebyshev prototype .01 zeros ~A: ~A (~A)" i (car vals) (zeros k))))))
+ (snd-display ";chebyshev prototype .01 zeros ~A: ~A (~A)" i (car vals) (zeros k))))))
(let* ((f1 (make-chebyshev-lowpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";chebyshev lp 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";chebyshev lp 8 .1 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";chebyshev lp 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";chebyshev lp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-lowpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";chebyshev lp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";chebyshev lp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.509 0.500 0.508 0.508 0.507 0.413 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";chebyshev lp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev lp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-lowpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";chebyshev lp 10 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";chebyshev lp 10 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.465 0.493 0.509 0.508 0.477 0.507 0.508 0.507 0.431 0.000)))
- (snd-display #__line__ ";chebyshev lp 10 .4 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev lp 10 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
@@ -10938,59 +10560,59 @@ EDITS: 2
(let* ((f1 (make-chebyshev-lowpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";cheby low max ~A ~A: ~A" i j mx)))))
+ (snd-display ";cheby low max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-chebyshev-lowpass 8 .1 .01))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .49) (snd-display #__line__ ";chebyshev lp 8 .1 .01 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .49) (snd-display ";chebyshev lp 8 .1 .01 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";chebyshev lp 8 .1 .01 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev lp 8 .1 .01 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-lowpass 12 .25 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .49) (snd-display #__line__ ";chebyshev lp 12 .1 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .49) (snd-display ";chebyshev lp 12 .1 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.488 0.488 0.488 0.488 0.487 0.403 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";chebyshev lp 12 .25 .1 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev lp 12 .25 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-lowpass 10 .4 .001))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .49) (snd-display #__line__ ";chebyshev lp 10 .001 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .49) (snd-display ";chebyshev lp 10 .001 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.488 0.000)))
- (snd-display #__line__ ";chebyshev lp 10 .4 .001 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev lp 10 .4 .001 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .55) (snd-display #__line__ ";chebyshev hp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .55) (snd-display ";chebyshev hp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.341 0.551 0.509 0.466 0.501 0.509 0.505 0.481 0.461)))
- (snd-display #__line__ ";chebyshev hp 8 .1 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev hp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .55) (snd-display #__line__ ";chebyshev hp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .55) (snd-display ";chebyshev hp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.299 0.554 0.509 0.509 0.500 0.509)))
- (snd-display #__line__ ";chebyshev hp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev hp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.297 0.786 0.677)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.301 0.788 0.660)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.322 0.861 0.724)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.262 0.571 0.509))))
- (snd-display #__line__ ";chebyshev hp 10 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.297 0.786 0.677))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.301 0.788 0.660))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.322 0.861 0.724))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.262 0.571 0.509))))
+ (snd-display ";chebyshev hp 10 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 8 .1 .01))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .49) (snd-display #__line__ ";chebyshev hp 8 .1 .01 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .49) (snd-display ";chebyshev hp 8 .1 .01 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.498 0.498 0.492 0.491 0.492 0.492 0.492 0.491 0.491)))
- (snd-display #__line__ ";chebyshev hp 8 .1 .01 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev hp 8 .1 .01 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 12 .25 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";chebyshev hp 12 .1 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";chebyshev hp 12 .1 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.453 0.516 0.489 0.489 0.488 0.488)))
- (snd-display #__line__ ";chebyshev hp 12 .25 .1 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev hp 12 .25 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-highpass 10 .4 .001))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .5) (snd-display #__line__ ";chebyshev hp 10 .001 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.501 0.504 0.504)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.505 0.504)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.501 0.497))))
- (snd-display #__line__ ";chebyshev hp 10 .4 .001 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .5) (snd-display ";chebyshev hp 10 .001 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.501 0.504 0.504))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.505 0.504))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.501 0.497))))
+ (snd-display ";chebyshev hp 10 .4 .001 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
@@ -10999,73 +10621,73 @@ EDITS: 2
(let* ((f1 (make-chebyshev-highpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";cheby high max ~A ~A: ~A" i j mx)))))
+ (snd-display ";cheby high max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-chebyshev-bandpass 4 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bp 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.009 0.449 0.509 0.505 0.442 0.065 0.013 0.003 0.000 0.000)))
- (snd-display #__line__ ";chebyshev bp 4 .1 .2 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bp 4 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandpass 6 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bp 6 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 6 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.376 0.505 0.498 0.412 0.011 0.001 0.000 0.000 0.000)))
- (snd-display #__line__ ";chebyshev bp 6 .1 .2 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bp 6 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandpass 8 .3 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.002 0.363 0.517 0.513 0.433 0.000)))
- (snd-display #__line__ ";chebyshev bp 8 .3 .4 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bp 8 .3 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandpass 8 .2 .2 .01))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bp 10 .2 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 10 .2 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.015 0.483 0.482 0.021 0.001 0.000 0.000 0.000)))
- (snd-display #__line__ ";chebyshev bp 10 .2 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bp 10 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandstop 4 .1 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bs 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bs 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.509 0.505 0.447 0.033 0.006 0.006 0.033 0.445 0.512 0.509)))
- (snd-display #__line__ ";chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandstop 8 .1 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .51)) .05) (snd-display #__line__ ";chebyshev bs 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.001 0.345 0.551 0.507)))
- (not (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.001 0.344 0.549 0.508)))
- (not (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.001 0.345 0.552 0.508)))
- (not (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.001 0.343 0.548 0.508))))
- (snd-display #__line__ ";chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .51)) .05) (snd-display ";chebyshev bs 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.001 0.345 0.551 0.507))
+ (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.001 0.344 0.549 0.508))
+ (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.001 0.345 0.552 0.508))
+ (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.001 0.343 0.548 0.508))))
+ (snd-display ";chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-chebyshev-bandstop 8 .1 .4 .01))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";chebyshev bs 8 .01 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bs 8 .01 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.006 0.494 0.495 0.492)))
- (snd-display #__line__ ";chebyshev bs 8 .1 .4 .01 spect: ~A" (cadr vals))))
+ (snd-display ";chebyshev bs 8 .1 .4 .01 spect: ~A" (cadr vals))))
;; ---------------- inverse-chebyshev ----------------
(let* ((f1 (make-inverse-chebyshev-lowpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev lp 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))))
- (snd-display #__line__ ";inverse-chebyshev lp 8 .1 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))
+ (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))))
+ (snd-display ";inverse-chebyshev lp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-lowpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev lp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.496 0.001 0.001 0.001 0.001 0.001)))
- (snd-display #__line__ ";inverse-chebyshev lp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev lp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-lowpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev lp 10 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.001 0.001)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.002 0.002))))
- (snd-display #__line__ ";inverse-chebyshev lp 10 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 10 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.001 0.001))
+ (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.002 0.002))))
+ (snd-display ";inverse-chebyshev lp 10 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-lowpass 10 .4 120))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev lp 10 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 10 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.501 0.501 0.501 0.501 0.501 0.500 0.345 0.007 0.000 0.000)))
- (snd-display #__line__ ";inverse-chebyshev lp 10 .4 120 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev lp 10 .4 120 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
@@ -11074,30 +10696,30 @@ EDITS: 2
(let* ((f1 (make-inverse-chebyshev-lowpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";inv cheby low max ~A ~A: ~A" i j mx)))))
+ (snd-display ";inv cheby low max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-inverse-chebyshev-highpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev hp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.440 0.505 0.505 0.503 0.502 0.501 0.501 0.501)))
- (snd-display #__line__ ";inverse-chebyshev hp 8 .1 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev hp 8 .1 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-highpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev hp 12 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 12 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.001 0.001 0.001 0.505 0.506 0.503 0.501 0.501)))
- (snd-display #__line__ ";inverse-chebyshev hp 12 .25 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev hp 12 .25 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-highpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev hp 10 .4 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.503 0.503)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.505 0.503)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.509 0.504))))
- (snd-display #__line__ ";inverse-chebyshev hp 10 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 10 .4 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.503 0.503))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.505 0.503))
+ (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.509 0.504))))
+ (snd-display ";inverse-chebyshev hp 10 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-highpass 10 .1 120))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .51) (snd-display #__line__ ";inverse-chebyshev hp 10 .1 120 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 10 .1 120 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.007 0.328 0.502 0.502 0.502 0.501 0.501 0.501)))
- (snd-display #__line__ ";inverse-chebyshev hp 10 .1 120 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev hp 10 .1 120 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
@@ -11106,244 +10728,216 @@ EDITS: 2
(let* ((f1 (make-inverse-chebyshev-highpass i j))
(mx (filter-response-max f1)))
(if (> mx 1.0)
- (snd-display #__line__ ";inv cheby high max ~A ~A: ~A" i j mx)))))
+ (snd-display ";inv cheby high max ~A ~A: ~A" i j mx)))))
(let* ((f1 (make-inverse-chebyshev-bandpass 10 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bp 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.498 0.485 0.001 0.001 0.000 0.001 0.000 0.001)))
- (snd-display #__line__ ";inverse-chebyshev bp 10 .1 .2 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev bp 10 .1 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandpass 10 .1 .2 30))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bp 6 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.026 0.025 0.509 0.505 0.020 0.016 0.012 0.016 0.011 0.016)))
- (not (vequal1 (cadr vals) (float-vector 0.030 0.042 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016)))
- (not (vequal1 (cadr vals) (float-vector 0.022 0.017 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))))
- (snd-display #__line__ ";inverse-chebyshev bp 10 .1 .2 30 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 6 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.026 0.025 0.509 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
+ (vequal1 (cadr vals) (float-vector 0.030 0.042 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
+ (vequal1 (cadr vals) (float-vector 0.022 0.017 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))))
+ (snd-display ";inverse-chebyshev bp 10 .1 .2 30 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandpass 8 .1 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bp 8 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 8 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.440 0.506 0.505 0.503 0.502 0.434 0.001 0.001)))
- (snd-display #__line__ ";inverse-chebyshev bp 8 .1 .4 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev bp 8 .1 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandpass 8 .3 .4 40))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bp 10 .2 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 10 .2 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.002 0.005 0.007 0.007 0.005 0.005 0.503 0.505 0.006 0.005)))
- (snd-display #__line__ ";inverse-chebyshev bp 10 .2 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev bp 10 .2 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandstop 4 .1 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bs 4 max: ~A" (car vals)))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 4 max: ~A" (car vals)))
(if (not (vequal1 (cadr vals) (float-vector 0.500 0.054 0.001 0.001 0.000 0.000 0.000 0.001 0.055 0.503)))
- (snd-display #__line__ ";inverse-chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
+ (snd-display ";inverse-chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandstop 8 .1 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bs 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506)))
- (not (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.511)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))))
- (snd-display #__line__ ";inverse-chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))
+ (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.511))
+ (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))))
+ (snd-display ";inverse-chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
(let* ((f1 (make-inverse-chebyshev-bandstop 8 .1 .4 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";inverse-chebyshev bs 8 90 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.505 0.325 0.000 0.000 0.000 0.000 0.000 0.000 0.270 0.506)))
- (not (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.269 0.509)))
- (not (vequal1 (cadr vals) (float-vector 0.501 0.327 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.506))))
- (snd-display #__line__ ";inverse-chebyshev bs 8 .1 .4 90 spect: ~A" (cadr vals))))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 8 90 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.505 0.325 0.000 0.000 0.000 0.000 0.000 0.000 0.270 0.506))
+ (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.269 0.509))
+ (vequal1 (cadr vals) (float-vector 0.501 0.327 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.506))))
+ (snd-display ";inverse-chebyshev bs 8 .1 .4 90 spect: ~A" (cadr vals))))
;; ---------------- bessel ----------------
;; checked poly coeff tables, but the prototype has scaling built in
- (if (provided? 'gsl)
- (begin
- (let* ((f1 (make-bessel-lowpass 4 .1))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel lp 4 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.417 0.209 0.062 0.018 0.005 0.001 0.000 0.000 0.000)))
- (snd-display #__line__ ";bessel lp 4 .1 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-bessel-lowpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel lp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.499 0.365 0.116 0.010 0.001 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";bessel lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-lowpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel lp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.477 0.410 0.309 0.185 0.063 0.006 0.000 0.000 0.000)))
- (snd-display #__line__ ";bessel lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-lowpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel lp 10 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.001)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.002))))
- (snd-display #__line__ ";bessel lp 10 .4 spect: ~A" (cadr vals))))
-
- (do ((i 2 (+ i 2)))
- ((= i 12))
- (do ((j .1 (+ j .1)))
- ((>= j .45))
- (let* ((f1 (make-bessel-lowpass i j))
- (mx (filter-response-max f1)))
- (if (> mx 1.0)
- (snd-display #__line__ ";bess low max ~A ~A: ~A" i j mx)))))
-
- (let* ((f1 (make-bessel-highpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel hp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.115 0.290 0.386 0.435 0.465 0.483 0.493 0.498 0.500)))
- (snd-display #__line__ ";bessel hp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-highpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (fneq (car vals) .5) (snd-display #__line__ ";bessel hp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.006 0.063 0.181 0.309 0.410 0.477 0.500)))
- (snd-display #__line__ ";bessel hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-highpass 10 .4))
- (vals (sweep->bins f1 10)))
- (if (ffneq (car vals) .5) (snd-display #__line__ ";bessel hp 10 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.004 0.084 0.343 0.499)))
- (snd-display #__line__ ";bessel hp 10 .4 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-bessel-bandpass 4 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .245)) .05) (snd-display #__line__ ";bessel bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.023 0.176 0.245 0.244 0.179 0.085 0.031 0.008 0.001 0.000)))
- (snd-display #__line__ ";bessel bp 4 .1 .2 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-bessel-bandstop 12 .1 .2))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .05) (snd-display #__line__ ";bessel bs 12 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.498 0.325 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500)))
- (not (vequal1 (cadr vals) (float-vector 0.499 0.324 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))))
- (snd-display #__line__ ";bessel bs 12 .1 .2 spect: ~A" (cadr vals))))
-
- ;; ---------------- elliptic ----------------
-
- (let* ((f1 (make-elliptic-lowpass 8 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.500 0.515 0.379 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.509 0.385 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.499 0.498 0.373 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";elliptic lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 12 .25))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 12 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.412 0.003 0.001 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.561 0.004 0.000 0.000 0.000)))
- (not (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.493 0.299 0.006 0.001 0.000 0.000))))
- (snd-display #__line__ ";elliptic lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 4 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.447 0.453 0.462 0.477 0.494 0.500 0.497 0.496 0.445 0.003)))
- (snd-display #__line__ ";elliptic lp 4 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .1 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 8 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";elliptic lp 8 .1 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .1 .1 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 8 .1 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";elliptic lp 8 .1 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .25 .01 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic lp 8 .25 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.495 0.001 0.000 0.000 0.000)))
- (snd-display #__line__ ";elliptic lp 8 .25 .1 90 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-elliptic-highpass 4 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.004 0.438 0.516 0.499 0.502 0.495 0.478 0.463 0.453 0.447)))
- (snd-display #__line__ ";elliptic hp 4 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 12 .25))
- (vals (sweep->bins f1 10)))
- ;(if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 12 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.026 0.934 0.518 0.495 0.503 0.477)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.033 1.185 0.519 0.495 0.503 0.477)))
- (not (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.018 0.788 0.520 0.495 0.503 0.477))))
- (snd-display #__line__ ";elliptic hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 12 .25 .01 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 12 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.499 0.517 0.503 0.501 0.500 0.500)))
- (snd-display #__line__ ";elliptic hp 12 .25 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 4 .4))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.002 0.023 0.447 0.515 0.502)))
- (snd-display #__line__ ";elliptic hp 4 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .1 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 8 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.553 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
- (snd-display #__line__ ";elliptic hp 8 .1 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .1 .1 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 8 .1 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.554 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
- (snd-display #__line__ ";elliptic hp 8 .1 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .25 .01 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic hp 8 .25 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.516 0.517 0.507 0.503 0.501 0.500)))
- (snd-display #__line__ ";elliptic hp 8 .25 .1 90 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-elliptic-bandpass 4 .1 .2 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.036 0.546 0.550 0.510 0.501 0.032 0.024 0.009 0.021 0.024)))
- (snd-display #__line__ ";elliptic bp 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandpass 6 .1 .2 .1 90))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic bp 6 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.002 0.511 0.532 0.503 0.492 0.003 0.001 0.001 0.001 0.001)))
- (snd-display #__line__ ";elliptic bp 6 .1 .2 90 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-elliptic-bandstop 4 .1 .3 .1))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic bs 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.499 0.502 0.498 0.037 0.050 0.540 0.544 0.527 0.526 0.521)))
- (snd-display #__line__ ";elliptic bs 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandstop 8 .1 .3 .1 120))
- (vals (sweep->bins f1 10)))
- (if (> (abs (- (car vals) .5)) .1) (snd-display #__line__ ";elliptic bs 8 max: ~A" (car vals)))
- (if (and (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.476 0.000 0.000 0.495 0.526 0.505 0.501 0.501)))
- (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.495 0.526 0.505 0.501 0.501))))
- (snd-display #__line__ ";elliptic bs 8 .1 .2 spect: ~A" (cadr vals))))
- ))))
-
- (define (test-polyoid n)
- (let* ((res (with-sound (:channels 2 :clipped #f)
- (let ((freqs (make-float-vector n))
- (phases (make-float-vector n)) ; for oscil-bank
- (cur-phases (make-float-vector (* 3 n))) ; for polyoid
- (amp (/ 1.0 n)))
- (do ((i 0 (+ i 1))
- (j 0 (+ j 3)))
- ((= i n))
- (set! (cur-phases j) (+ i 1))
- (set! (cur-phases (+ j 1)) (/ 1.0 n))
- (set! (cur-phases (+ j 2)) (random (* 2 pi)))
-
- (set! (freqs i) (hz->radians (+ i 1.0)))
- (set! (phases i) (cur-phases (+ j 2))))
-
- (let ((gen (make-polyoid 1.0 cur-phases))
- (obank (make-oscil-bank freqs phases (make-float-vector n 1.0) #t)))
- (do ((i 0 (+ i 1)))
- ((= i 88200))
- (outa i (* amp (oscil-bank obank))))
- (do ((i 0 (+ i 1)))
- ((= i 88200))
- (outb i (polyoid gen 0.0)))))))
- (snd (find-sound res)))
- (channel-distance snd 0 snd 1)))
+ (when (provided? 'gsl)
+ (let* ((f1 (make-bessel-lowpass 4 .1))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel lp 4 .1 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.500 0.417 0.209 0.062 0.018 0.005 0.001 0.000 0.000 0.000)))
+ (snd-display ";bessel lp 4 .1 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-bessel-lowpass 8 .1))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel lp 8 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.499 0.365 0.116 0.010 0.001 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";bessel lp 8 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-bessel-lowpass 12 .25))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel lp 12 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.500 0.477 0.410 0.309 0.185 0.063 0.006 0.000 0.000 0.000)))
+ (snd-display ";bessel lp 12 .25 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-bessel-lowpass 10 .4))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel lp 10 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.001))
+ (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.002))))
+ (snd-display ";bessel lp 10 .4 spect: ~A" (cadr vals))))
+
+ (do ((i 2 (+ i 2)))
+ ((= i 12))
+ (do ((j .1 (+ j .1)))
+ ((>= j .45))
+ (let* ((f1 (make-bessel-lowpass i j))
+ (mx (filter-response-max f1)))
+ (if (> mx 1.0)
+ (snd-display ";bess low max ~A ~A: ~A" i j mx)))))
+
+ (let* ((f1 (make-bessel-highpass 8 .1))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel hp 8 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.001 0.115 0.290 0.386 0.435 0.465 0.483 0.493 0.498 0.500)))
+ (snd-display ";bessel hp 8 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-bessel-highpass 12 .25))
+ (vals (sweep->bins f1)))
+ (if (fneq (car vals) .5) (snd-display ";bessel hp 12 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.006 0.063 0.181 0.309 0.410 0.477 0.500)))
+ (snd-display ";bessel hp 12 .25 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-bessel-highpass 10 .4))
+ (vals (sweep->bins f1)))
+ (if (ffneq (car vals) .5) (snd-display ";bessel hp 10 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.004 0.084 0.343 0.499)))
+ (snd-display ";bessel hp 10 .4 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-bessel-bandpass 4 .1 .2))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .245)) .05) (snd-display ";bessel bp 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.023 0.176 0.245 0.244 0.179 0.085 0.031 0.008 0.001 0.000)))
+ (snd-display ";bessel bp 4 .1 .2 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-bessel-bandstop 12 .1 .2))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .05) (snd-display ";bessel bs 12 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.498 0.325 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))
+ (vequal1 (cadr vals) (float-vector 0.499 0.324 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))))
+ (snd-display ";bessel bs 12 .1 .2 spect: ~A" (cadr vals))))
+
+ ;; ---------------- elliptic ----------------
+
+ (let* ((f1 (make-elliptic-lowpass 8 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.515 0.379 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.500 0.509 0.385 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.499 0.498 0.373 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";elliptic lp 8 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-lowpass 12 .25))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 12 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.412 0.003 0.001 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.561 0.004 0.000 0.000 0.000))
+ (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.493 0.299 0.006 0.001 0.000 0.000))))
+ (snd-display ";elliptic lp 12 .25 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-lowpass 4 .4))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.447 0.453 0.462 0.477 0.494 0.500 0.497 0.496 0.445 0.003)))
+ (snd-display ";elliptic lp 4 .4 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-lowpass 8 .1 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .1 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";elliptic lp 8 .1 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-lowpass 8 .1 .1 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .1 90 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";elliptic lp 8 .1 .1 90 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-lowpass 8 .25 .01 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .25 90 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.495 0.001 0.000 0.000 0.000)))
+ (snd-display ";elliptic lp 8 .25 .1 90 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-elliptic-highpass 4 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.004 0.438 0.516 0.499 0.502 0.495 0.478 0.463 0.453 0.447)))
+ (snd-display ";elliptic hp 4 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 12 .25))
+ (vals (sweep->bins f1)))
+ ;(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 12 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.026 0.934 0.518 0.495 0.503 0.477))
+ (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.033 1.185 0.519 0.495 0.503 0.477))
+ (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.018 0.788 0.520 0.495 0.503 0.477))))
+ (snd-display ";elliptic hp 12 .25 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 12 .25 .01 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 12 90 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.499 0.517 0.503 0.501 0.500 0.500)))
+ (snd-display ";elliptic hp 12 .25 90 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 4 .4))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.002 0.023 0.447 0.515 0.502)))
+ (snd-display ";elliptic hp 4 .4 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 8 .1 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .1 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.553 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
+ (snd-display ";elliptic hp 8 .1 .1 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 8 .1 .1 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .1 90 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.554 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
+ (snd-display ";elliptic hp 8 .1 .1 90 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-highpass 8 .25 .01 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .25 90 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.516 0.517 0.507 0.503 0.501 0.500)))
+ (snd-display ";elliptic hp 8 .25 .1 90 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-elliptic-bandpass 4 .1 .2 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bp 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.036 0.546 0.550 0.510 0.501 0.032 0.024 0.009 0.021 0.024)))
+ (snd-display ";elliptic bp 4 .1 .2 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-bandpass 6 .1 .2 .1 90))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bp 6 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.002 0.511 0.532 0.503 0.492 0.003 0.001 0.001 0.001 0.001)))
+ (snd-display ";elliptic bp 6 .1 .2 90 spect: ~A" (cadr vals))))
+
+ (let* ((f1 (make-elliptic-bandstop 4 .1 .3 .1))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bs 4 max: ~A" (car vals)))
+ (if (not (vequal1 (cadr vals) (float-vector 0.499 0.502 0.498 0.037 0.050 0.540 0.544 0.527 0.526 0.521)))
+ (snd-display ";elliptic bs 4 .1 .2 spect: ~A" (cadr vals))))
+ (let* ((f1 (make-elliptic-bandstop 8 .1 .3 .1 120))
+ (vals (sweep->bins f1)))
+ (if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bs 8 max: ~A" (car vals)))
+ (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.499 0.476 0.000 0.000 0.495 0.526 0.505 0.501 0.501))
+ (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.495 0.526 0.505 0.501 0.501))))
+ (snd-display ";elliptic bs 8 .1 .2 spect: ~A" (cadr vals))))
+ )))
;; ----------------
(define (poly-roots-tests)
@@ -11357,124 +10951,124 @@ EDITS: 2
;; degree=0
(let ((val (poly-roots (float-vector 0.0))))
- (if (pair? val) (snd-display #__line__ ";poly-roots 0.0: ~A" val)))
+ (if (pair? val) (snd-display ";poly-roots 0.0: ~A" val)))
(let ((val (poly-roots (float-vector 12.3))))
- (if (pair? val) (snd-display #__line__ ";poly-roots 12.3: ~A" val)))
+ (if (pair? val) (snd-display ";poly-roots 12.3: ~A" val)))
;; degree 0 + x=0
(let ((val (poly-roots (float-vector 0.0 1.0))))
- (if (not (ceql val (list 0.0))) (snd-display #__line__ ";poly-roots 0.0 1.0: ~A" val)))
+ (if (not (ceql val (list 0.0))) (snd-display ";poly-roots 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 0.0 0.0 0.0 121.0))))
- (if (not (ceql val (list 0.0 0.0 0.0))) (snd-display #__line__ ";poly-roots 0.0 0.0 0.0 121.0: ~A" val)))
+ (if (not (ceql val (list 0.0 0.0 0.0))) (snd-display ";poly-roots 0.0 0.0 0.0 121.0: ~A" val)))
;; degree=1
(let ((val (poly-roots (float-vector -1.0 1.0))))
- (if (not (ceql val (list 1.0))) (snd-display #__line__ ";poly-roots -1.0 1.0: ~A" val)))
+ (if (not (ceql val (list 1.0))) (snd-display ";poly-roots -1.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -2.0 4.0))))
- (if (not (ceql val (list 0.5))) (snd-display #__line__ ";poly-roots -2.0 4.0: ~A" val)))
+ (if (not (ceql val (list 0.5))) (snd-display ";poly-roots -2.0 4.0: ~A" val)))
(let ((val (poly-as-vector-roots (vector 0.0-i 1))))
- (if (not (ceql val (list -0.0+1.0i))) (snd-display #__line__ ";poly-roots: -i 1: ~A" val)))
+ (if (not (ceql val (list -0.0+1.0i))) (snd-display ";poly-roots: -i 1: ~A" val)))
;; linear x^n
(let ((val (poly-roots (float-vector -1.0 0.0 0.0 0.0 1.0))))
- (if (and (not (ceql val (list 0.0-1.0i -1.0 0.0+1.0i 1.0)))
- (not (ceql val (list 1.0 -1.0 0.0+1.0i -0.0-1.0i))))
- (snd-display #__line__ ";poly-roots -1.0 0.0 0.0 0.0 1.0: ~A" val)))
+ (if (not (or (ceql val (list 0.0-1.0i -1.0 0.0+1.0i 1.0))
+ (ceql val (list 1.0 -1.0 0.0+1.0i -0.0-1.0i))))
+ (snd-display ";poly-roots -1.0 0.0 0.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -16.0 0.0 0.0 0.0 1.0))))
- (if (and (not (ceql val (list 0.0-2.0i -2.0 0.0+2.0i 2.0)))
- (not (ceql val (list 2.0 -2.0 0.0+2.0i -0.0-2.0i))))
- (snd-display #__line__ ";poly-roots -16.0 0.0 0.0 0.0 1.0: ~A" val)))
+ (if (not (or (ceql val (list 0.0-2.0i -2.0 0.0+2.0i 2.0))
+ (ceql val (list 2.0 -2.0 0.0+2.0i -0.0-2.0i))))
+ (snd-display ";poly-roots -16.0 0.0 0.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -32.0 0 0 0 0 0 0.5))))
- (if (not (ceql val (list 1.0-1.7320i -1.0-1.7320i -2.0 -1.0+1.7320i 1.0+1.7320i 2.0))) (snd-display #__line__ ";poly-roots 32 0 0 0 0 0 0.5: ~A" val)))
+ (if (not (ceql val (list 1.0-1.7320i -1.0-1.7320i -2.0 -1.0+1.7320i 1.0+1.7320i 2.0))) (snd-display ";poly-roots 32 0 0 0 0 0 0.5: ~A" val)))
;; linear + x=0
(let ((val (poly-roots (float-vector 0.0 -2.0 4.0))))
- (if (not (ceql val (list 0.0 0.5))) (snd-display #__line__ ";poly-roots 0.0 -2.0 4.0: ~A" val)))
+ (if (not (ceql val (list 0.0 0.5))) (snd-display ";poly-roots 0.0 -2.0 4.0: ~A" val)))
;; degree=2
(let ((val (poly-roots (float-vector -1.0 0.0 1.0))))
- (if (not (ceql val (list 1.0 -1.0))) (snd-display #__line__ ";poly-roots -1.0 0.0 1.0: ~A" val)))
+ (if (not (ceql val (list 1.0 -1.0))) (snd-display ";poly-roots -1.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 15.0 -8.0 1.0))))
- (if (not (ceql val (list 5.0 3.0))) (snd-display #__line__ ";poly-roots 15.0 -8.0 1.0: ~A" val)))
+ (if (not (ceql val (list 5.0 3.0))) (snd-display ";poly-roots 15.0 -8.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 1 -2 1))))
- (if (not (ceql val (list 1.0 1.0))) (snd-display #__line__ ";poly-roots 1 -2 1: ~A" val)))
+ (if (not (ceql val (list 1.0 1.0))) (snd-display ";poly-roots 1 -2 1: ~A" val)))
(let ((val (poly-as-vector-roots (vector -1 0.0+2i 1))))
- (if (not (ceql val (list 0.0-1.0i 0.0-1.0i))) (snd-display #__line__ ";poly-roots -1 2i 1: ~A" val)))
+ (if (not (ceql val (list 0.0-1.0i 0.0-1.0i))) (snd-display ";poly-roots -1 2i 1: ~A" val)))
(let ((val (poly-roots (float-vector 1 1 5))))
- (if (not (ceql val (list -0.1+0.43589i -0.1-0.43589i))) (snd-display #__line__ ";poly-roots 1 1 5: ~A" val)))
+ (if (not (ceql val (list -0.1+0.43589i -0.1-0.43589i))) (snd-display ";poly-roots 1 1 5: ~A" val)))
;; 2 + x=0
(let ((val (poly-roots (float-vector 0.0 0.0 -1.0 0.0 1.0))))
- (if (not (ceql val (list 0.0 0.0 1.0 -1.0))) (snd-display #__line__ ";poly-roots 0.0 0.0 -1.0 0.0 1.0: ~A" val)))
+ (if (not (ceql val (list 0.0 0.0 1.0 -1.0))) (snd-display ";poly-roots 0.0 0.0 -1.0 0.0 1.0: ~A" val)))
;; quadratic in x^(n/2)
(let ((vals (poly-roots (float-vector 1.0 0.0 -2.0 0.0 1.0))))
- (if (and (not (ceql vals (list -1.0 1.0 -1.0 1.0)))
- (not (ceql vals (list 1.0 1.0 -1.0 -1.0))))
- (snd-display #__line__ ";poly-roots 1 0 -2 0 1: ~A" vals)))
+ (if (not (or (ceql vals (list -1.0 1.0 -1.0 1.0))
+ (ceql vals (list 1.0 1.0 -1.0 -1.0))))
+ (snd-display ";poly-roots 1 0 -2 0 1: ~A" vals)))
(let ((vals (poly-roots (float-vector 64.0 0.0 0.0 -16.0 0.0 0.0 1.0))))
(if (not (ceql vals (list -1.0-1.73205i -1.0+1.73205i 2.0 -1.0-1.73205i -1.0+1.73205i 2.0)))
- (snd-display #__line__ ";poly-roots 64 0 0 -16 0 0 1: ~A" vals)))
+ (snd-display ";poly-roots 64 0 0 -16 0 0 1: ~A" vals)))
;; degree=3
(let ((val (poly-roots (float-vector -15.0 23.0 -9.0 1.0))))
- (if (not (ceql val (list 5.0 1.0 3.0))) (snd-display #__line__ ";poly-roots 5 1 3: ~A" val)))
+ (if (not (ceql val (list 5.0 1.0 3.0))) (snd-display ";poly-roots 5 1 3: ~A" val)))
(let ((val (poly-roots (float-vector -126 -15 0 1))))
- (if (not (ceql val (list 6.0 -3.0+3.46410i -3.0-3.46410i))) (snd-display #__line__ ";poly-roots -126 -15 0 1: ~A" val)))
+ (if (not (ceql val (list 6.0 -3.0+3.46410i -3.0-3.46410i))) (snd-display ";poly-roots -126 -15 0 1: ~A" val)))
(let ((val (poly-roots (float-vector -1 3 -3 1))))
- (if (not (ceql val (list 1.0 1.0 1.0))) (snd-display #__line__ ";poly-roots -1 3 -3 1: ~A" val)))
+ (if (not (ceql val (list 1.0 1.0 1.0))) (snd-display ";poly-roots -1 3 -3 1: ~A" val)))
(let ((val (poly-roots (float-vector 1 -1 -1 1))))
- (if (and (not (ceql val (list 1.0 -1.0 1.0)))
- (not (ceql val (list -1.0 1.0 1.0))))
- (snd-display #__line__ ";poly-roots 1 -1 1: ~A" val)))
+ (if (not (or (ceql val (list 1.0 -1.0 1.0))
+ (ceql val (list -1.0 1.0 1.0))))
+ (snd-display ";poly-roots 1 -1 1: ~A" val)))
(let ((val (poly-roots (float-vector 2 -2 -2 2))))
- (if (and (not (ceql val (list 1.0 -1.0 1.0)))
- (not (ceql val (list -1.0 1.0 1.0))))
- (snd-display #__line__ ";poly-roots 2 -2 -2 2: ~A" val)))
+ (if (not (or (ceql val (list 1.0 -1.0 1.0))
+ (ceql val (list -1.0 1.0 1.0))))
+ (snd-display ";poly-roots 2 -2 -2 2: ~A" val)))
;; degree=4
; (let ((vals (poly-roots (float-vector -15 8 14 -8 1))))
- ; (if (not (ceql vals (list 5.0 3.0 1.0 -1.0))) (snd-display #__line__ ";poly-roots -15 8 14 -8 1: ~A" vals)))
+ ; (if (not (ceql vals (list 5.0 3.0 1.0 -1.0))) (snd-display ";poly-roots -15 8 14 -8 1: ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0))) (snd-display #__line__ ";poly-roots 4(1): ~A" vals)))
+ ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0))) (snd-display ";poly-roots 4(1): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector .2 1) (float-vector -3 1)) (poly* (float-vector .8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 9.0 3.0 -0.2 -0.8))) (snd-display #__line__ ";poly-roots 4(2): ~A" vals)))
+ ; (if (not (ceql vals (list 9.0 3.0 -0.2 -0.8))) (snd-display ";poly-roots 4(2): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector .02 1) (float-vector -32 1)) (poly* (float-vector .8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 32.0 9.0 -0.02 -0.8))) (snd-display #__line__ ";poly-roots 4(3): ~A" vals)))
+ ; (if (not (ceql vals (list 32.0 9.0 -0.02 -0.8))) (snd-display ";poly-roots 4(3): ~A" vals)))
;; degree>4
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector -1 1) (float-vector -2 1))))))))
; (if (not (ceql vals (list 3.0 2.0 -1.0 -2.0 1.0)))
- ; (snd-display #__line__ ";poly-roots n(1): ~A from ~A ~A ~A"
+ ; (snd-display ";poly-roots n(1): ~A from ~A ~A ~A"
; vals
; (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector -1 1) (float-vector -2 1)))))
; *mus-float-equal-fudge-factor*
; poly-roots-epsilon)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 8 1) (float-vector -9 1))))))))
- ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0 -1.0))) (snd-display #__line__ ";poly-roots n(2): ~A" vals)))
+ ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0 -1.0))) (snd-display ";poly-roots n(2): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector 9 1) (float-vector -3 1)) (poly* (float-vector -10 1) (float-vector -2 1))))))))
- ; (if (not (ceql vals (list 10.0 3.0 -1.0 -9.0 2.0 1.0))) (snd-display #__line__ ";poly-roots n(3): ~A" vals)))
+ ; (if (not (ceql vals (list 10.0 3.0 -1.0 -9.0 2.0 1.0))) (snd-display ";poly-roots n(3): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector -4 0 1) (float-vector -3 1)) (poly* (float-vector -10 1) (float-vector -9 0 1))))))))
- ; (if (not (ceql vals (list 10.0 3.0 -2.0 -3.0 -1.0 3.0 2.0 1.0))) (snd-display #__line__ ";poly-roots n(4): ~A" vals)))
+ ; (if (not (ceql vals (list 10.0 3.0 -2.0 -3.0 -1.0 3.0 2.0 1.0))) (snd-display ";poly-roots n(4): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector -4 0 1) (float-vector -16 0 1)) (poly* (float-vector -25 0 1) (float-vector -9 0 1))))))))
- ; (if (not (ceql vals (list 5.0 -3.0 -4.0 -5.0 4.0 -2.0 3.0 -1.0 2.0 1.0))) (snd-display #__line__ ";poly-roots n(5): ~A" vals)))
+ ; (if (not (ceql vals (list 5.0 -3.0 -4.0 -5.0 4.0 -2.0 3.0 -1.0 2.0 1.0))) (snd-display ";poly-roots n(5): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 1 1) (float-vector -2 1))))))))
- ; (if (not (ceql vals (list 3.0 -1.0 -1.0 -2.0 2.0))) (snd-display #__line__ ";poly-roots n(6): ~A" vals)))
+ ; (if (not (ceql vals (list 3.0 -1.0 -1.0 -2.0 2.0))) (snd-display ";poly-roots n(6): ~A" vals)))
(let ((vals (poly-roots (float-vector -64 0 0 0 0 0 1))))
(if (not (ceql vals (list 0.999999999999999-1.73205080756888i -1.0-1.73205080756888i -2.0 -1.0+1.73205080756888i 1.0+1.73205080756888i 2.0)))
- (snd-display #__line__ ";poly-roots 64 6: ~A" vals)))
+ (snd-display ";poly-roots 64 6: ~A" vals)))
(let ((vals (poly-roots (float-vector 64 0 0 -16 0 0 1))))
(if (not (ceql vals (list -1.0-1.73205080756888i -1.0+1.73205080756888i 2.0 -1.0-1.73205080756888i -1.0+1.73205080756888i 2.0)))
- (snd-display #__line__ ";poly-roots 64 16 6: ~A" vals)))
+ (snd-display ";poly-roots 64 16 6: ~A" vals)))
(do ((i 0 (+ i 1))) ((= i 10)) (poly-roots (float-vector (random 1.0) (random 1.0) (random 1.0))))
(do ((i 0 (+ i 1))) ((= i 10)) (poly-roots (float-vector (mus-random 1.0) (mus-random 1.0) (mus-random 1.0))))
(let ((vals1 (convolution (float-vector 1 2 3 0 0 0 0 0) (float-vector 1 2 3 0 0 0 0 0) 8))
(vals2 (poly* (float-vector 1 2 3 0) (float-vector 1 2 3 0))))
(if (not (vequal vals1 vals2))
- (snd-display #__line__ ";poly* convolve: ~A ~A" vals1 vals2)))
+ (snd-display ";poly* convolve: ~A ~A" vals1 vals2)))
(do ((i 0 (+ i 1))) ((= i 10))
@@ -11494,16 +11088,6 @@ EDITS: 2
(complex (mus-random 1.0) (mus-random 1.0))
(complex (mus-random 1.0) (mus-random 1.0)))))
- ; (do ((i 0 (+ i 1))) ((= i 10))
- ; (poly-roots (float-vector (mus-random 1.0) (mus-random 1.0) (mus-random 1.0) (mus-random 1.0) (mus-random 1.0))))
- ;
- ; (do ((i 0 (+ i 1))) ((= i 10))
- ; (poly-as-vector-roots (vector (complex (mus-random 1.0) (mus-random 1.0))
- ; (complex (mus-random 1.0) (mus-random 1.0))
- ; (complex (mus-random 1.0) (mus-random 1.0))
- ; (complex (mus-random 1.0) (mus-random 1.0))
- ; (complex (mus-random 1.0) (mus-random 1.0)))))
-
(do ((i 3 (+ i 1))) ((= i 20))
(let ((v (make-float-vector i 0.0)))
(set! (v 0) (mus-random 1.0))
@@ -11518,26 +11102,26 @@ EDITS: 2
(poly-roots v)))
(let ((vals (poly-roots (float-vector 1 -1 -1 1))))
- (if (and (not (ceql vals (list 1.0 -1.0 1.0)))
- (not (ceql vals (list -1.0 1.0 1.0))))
- (snd-display #__line__ ";poly-roots 1-1-11: ~A" vals)))
+ (if (not (or (ceql vals (list 1.0 -1.0 1.0))
+ (ceql vals (list -1.0 1.0 1.0))))
+ (snd-display ";poly-roots 1-1-11: ~A" vals)))
(let ((vals (poly-roots (float-vector 2 -1 -2 1))))
- (if (not (ceql vals (list 2.0 -1.0 1.0))) (snd-display #__line__ ";poly-roots 2-1-21: ~A" vals)))
+ (if (not (ceql vals (list 2.0 -1.0 1.0))) (snd-display ";poly-roots 2-1-21: ~A" vals)))
(let ((vals (poly-roots (float-vector -1 1 1 1))))
(if (not (ceql vals (list 0.543689012692076 -0.771844506346038+1.11514250803994i -0.771844506346038-1.11514250803994i)))
- (snd-display #__line__ ";poly-roots -1111: ~A" vals)))
+ (snd-display ";poly-roots -1111: ~A" vals)))
(let ((vals (poly-roots (float-vector -1 3 -3 1))))
- (if (not (ceql vals (list 1.0 1.0 1.0))) (snd-display #__line__ ";poly-roots -13-31: ~A" vals)))
+ (if (not (ceql vals (list 1.0 1.0 1.0))) (snd-display ";poly-roots -13-31: ~A" vals)))
; (let ((vals (poly-roots (float-vector 1 -4 6 -4 1))))
- ; (if (not (ceql vals (list 1.0 1.0 1.0 1.0))) (snd-display #__line__ ";poly-roots 1-46-41: ~A" vals)))
+ ; (if (not (ceql vals (list 1.0 1.0 1.0 1.0))) (snd-display ";poly-roots 1-46-41: ~A" vals)))
(let ((vals (poly-roots (float-vector 0.5 0 0 1.0))))
- (if (and (not (ceql vals (list 0.396850262992049-0.687364818499302i -0.7937005259841 0.39685026299205+0.687364818499301i)))
- (not (ceql vals (list 0.39685026299205+0.687364818499301i 0.39685026299205-0.687364818499301i -0.7937005259841)))
- (not (ceql vals (list -7.9370052598409979172089E-1 3.968502629920498958E-1+6.873648184993013E-1i 3.96850262992049E-1-6.873648184993E-1i))))
- (snd-display #__line__ ";poly-roots 0..5 3: ~A" vals)))
+ (if (not (or (ceql vals (list 0.396850262992049-0.687364818499302i -0.7937005259841 0.39685026299205+0.687364818499301i))
+ (ceql vals (list 0.39685026299205+0.687364818499301i 0.39685026299205-0.687364818499301i -0.7937005259841))
+ (ceql vals (list -7.9370052598409979172089E-1 3.968502629920498958E-1+6.873648184993013E-1i 3.96850262992049E-1-6.873648184993E-1i))))
+ (snd-display ";poly-roots 0..5 3: ~A" vals)))
(let ((vals (poly-roots (poly* (poly* (poly* (float-vector -1 1) (float-vector 1 1)) (poly* (float-vector -2 1) (float-vector 2 1))) (poly* (float-vector -3 1) (float-vector 3 1))))))
(if (not (ceql vals (list -3.0 3.0 -1.0 1.0 -2.0 2.0)))
- (snd-display #__line__ ";cube in 2: ~A" vals)))
+ (snd-display ";cube in 2: ~A" vals)))
))
;; -----------------
@@ -11558,7 +11142,7 @@ EDITS: 2
;fm-complex-component add -0.016 from J4(1.0) = 0.002 and I-2(4.0) = 6.422
;fm-cascade-component add 0.512 from J0(1.5) = 0.512 and J0(1.0) = 1.000
"))
- (snd-display #__line__ ";fm-components are unexpected:~%~S" str)))))
+ (snd-display ";fm-components are unexpected:~%~S" str)))))
;; ----------------
(define fltit
@@ -11594,13 +11178,17 @@ EDITS: 2
;; ----------------
- (define* (make-ssb-am-1 freq (order 40))
- (if (even? order) (set! order (+ 1 order)))
- (make-sa1 :freq (abs freq)
- :coscar (make-oscil freq (* .5 pi))
- :sincar (make-oscil freq)
- :dly (make-delay order)
- :hlb (make-hilbert-transform order)))
+
+ (define make-ssb-am-1
+ (let ()
+ (defgenerator sa1 freq (coscar #f) (sincar #f) (dly #f) (hlb #f))
+ (lambda* (freq (order 40))
+ (if (even? order) (set! order (+ 1 order)))
+ (make-sa1 :freq (abs freq)
+ :coscar (make-oscil freq (* .5 pi))
+ :sincar (make-oscil freq)
+ :dly (make-delay order)
+ :hlb (make-hilbert-transform order)))))
;; ----------------
(define* (ssb-am-1 gen y (fm-1 0.0))
@@ -11637,14 +11225,14 @@ EDITS: 2
(define* (print-and-check gen name desc (desc1 "") (desc2 ""))
(if (not (string=? (mus-name gen) name))
- (snd-display #__line__ ";mus-name ~A: ~A?" name (mus-name gen)))
- (if (and (not (string=? (mus-describe gen) desc))
- (not (string=? (mus-describe gen) desc1))
- (not (string=? (mus-describe gen) desc2)))
- (snd-display #__line__ ";mus-describe ~A: ~A?" (mus-name gen) (mus-describe gen)))
+ (snd-display ";mus-name ~A: ~A?" name (mus-name gen)))
+ (if (not (or (string=? (mus-describe gen) desc)
+ (string=? (mus-describe gen) desc1)
+ (string=? (mus-describe gen) desc2)))
+ (snd-display ";mus-describe ~A: ~A?" (mus-name gen) (mus-describe gen)))
(let ((egen gen))
(if (not (equal? egen gen))
- (snd-display #__line__ ";equal? ~A: ~A?" gen egen))))
+ (snd-display ";equal? ~A: ~A?" gen egen))))
;; ----------------
(define (test-gen-equal g0 g1 g2)
@@ -11652,52 +11240,53 @@ EDITS: 2
(let ((g3 g0))
(if (not (eq? g0 g3))
- (snd-display #__line__ ";let ~A not eq?~% ~A~% ~A" (mus-name g0) g0 g3))
+ (snd-display ";let ~A not eq?~% ~A~% ~A" (mus-name g0) g0 g3))
(if (eq? g0 g1)
- (snd-display #__line__ ";arg ~A eq?~% ~A~% ~A" (mus-name g0) g0 g1))
+ (snd-display ";arg ~A eq?~% ~A~% ~A" (mus-name g0) g0 g1))
(if (not (equal? g0 g1))
- (snd-display #__line__ ";~A not equal?~% ~A~% ~A" (mus-name g0) g0 g1))
+ (snd-display ";~A not equal?~% ~A~% ~A" (mus-name g0) g0 g1))
(if (equal? g0 g2)
- (snd-display #__line__ ";~A equal?~% ~A~% ~A" (mus-name g0) g0 g2))
+ (snd-display ";~A equal?~% ~A~% ~A" (mus-name g0) g0 g2))
(g0)
(g3)
(g3)
(if (not (eq? g0 g3))
- (snd-display #__line__ ";run let ~A not eq?~% ~A~% ~A" (mus-name g0) g0 g3))
+ (snd-display ";run let ~A not eq?~% ~A~% ~A" (mus-name g0) g0 g3))
(if (eq? g0 g1)
- (snd-display #__line__ ";arg ~A eq?~% ~A~% ~A" (mus-name g0) g0 g1))
+ (snd-display ";arg ~A eq?~% ~A~% ~A" (mus-name g0) g0 g1))
(if (equal? g0 g1)
- (snd-display #__line__ ";run ~A equal?~% ~A~% ~A" (mus-name g0) g0 g1))
+ (snd-display ";run ~A equal?~% ~A~% ~A" (mus-name g0) g0 g1))
(if (equal? g0 g2)
- (snd-display #__line__ ";run ~A equal?~% ~A~% ~A" (mus-name g0) g0 g2))
+ (snd-display ";run ~A equal?~% ~A~% ~A" (mus-name g0) g0 g2))
(let ((data (catch #t (lambda () (mus-data g0)) (lambda args #f))))
(when (float-vector? data)
(let ((g4 (copy g0)))
(let ((data4 (catch #t (lambda () (mus-data g4)) (lambda args #f))))
(if (not (float-vector? data4))
- (snd-display #__line__ ";~A copy -> mus-data ~A?" (mus-name g0) data4))))))))
+ (snd-display ";~A copy -> mus-data ~A?" (mus-name g0) data4))))))))
;; ----------------
(define (fm-test gen)
- (if (not (mus-generator? gen)) (snd-display #__line__ ";~A not a gen?" gen))
+ (if (not (mus-generator? gen)) (snd-display ";~A not a gen?" gen))
(set! (mus-frequency gen) 0.0)
(set! (mus-phase gen) 0.0)
(gen 0.0)
- (if (fneq (mus-phase gen) 0.0) (snd-display #__line__ ";~A phase(0): ~A" gen (mus-phase gen)))
+ (if (fneq (mus-phase gen) 0.0) (snd-display ";~A phase(0): ~A" gen (mus-phase gen)))
(gen 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";~A phase(1): ~A" gen (mus-phase gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";~A phase(1): ~A" gen (mus-phase gen)))
(gen 0.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";~A phase(1, 0): ~A" gen (mus-phase gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";~A phase(1, 0): ~A" gen (mus-phase gen)))
(set! (mus-frequency gen) (radians->hz 2.0))
- (if (fneq (mus-increment gen) 2.0) (snd-display #__line__ ";~A increment: ~A" gen (mus-increment gen)))
+ (if (fneq (mus-increment gen) 2.0) (snd-display ";~A increment: ~A" gen (mus-increment gen)))
(set! (mus-increment gen) 2.0)
- (if (fneq (mus-frequency gen) (radians->hz 2.0)) (snd-display #__line__ ";~A set increment: ~A ~A" gen (mus-increment gen) (hz->radians (mus-frequency gen))))
+ (if (fneq (mus-frequency gen) (radians->hz 2.0)) (snd-display ";~A set increment: ~A ~A" gen (mus-increment gen) (hz->radians (mus-frequency gen))))
(gen 0.0)
- (if (fneq (mus-phase gen) 3.0) (snd-display #__line__ ";~A phase(1, 2): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 3.0) (snd-display ";~A phase(1, 2): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
(gen 1.0)
- (if (fneq (mus-phase gen) 6.0) (snd-display #__line__ ";~A phase(3, 2, 1): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 6.0) (snd-display ";~A phase(3, 2, 1): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
(do ((i 0 (+ i 1))) ((= i 10)) (gen 10.0))
- (if (fneq (mus-phase gen) (+ 26 (- 100 (* 2 pi 20)))) (snd-display #__line__ ";~A phase (over): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
+ (if (fneq (mus-phase gen) (+ 26 (- 100 (* 40 pi)))) ;(+ 26 (- 100 (* 2 pi 20)))
+ (snd-display ";~A phase (over): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
(set! (mus-frequency gen) 0.0)
(set! (mus-phase gen) 0.0)
(gen 1234567812345678)
@@ -11707,7 +11296,7 @@ EDITS: 2
(gen -2.0)
(if (and (fneq (mus-phase gen) -2.0)
(fneq (mus-phase gen) (- (* 2 pi) 2.0)))
- (snd-display #__line__ ";phase: ~A freq: ~A" (mus-phase gen) (mus-frequency gen))))
+ (snd-display ";phase: ~A freq: ~A" (mus-phase gen) (mus-frequency gen))))
;; ----------------
(define* (agc (ramp-speed .001) (window-size 512))
@@ -11732,11 +11321,10 @@ EDITS: 2
(max-bad 0.0))
(do ((i 0 (+ i 1)))
((= i 12))
- (let* ((nval (acos (vector-ref args i)))
- (diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad) (set! max-bad diff))))
+ (set! max-bad (max max-bad (abs (- (acos (vector-ref args i))
+ (vector-ref vals i))))))
(if (> max-bad 1.0e-15)
- (snd-display #__line__ ";acos: ~A" max-bad)))
+ (snd-display ";acos: ~A" max-bad)))
(let ((vals (vector 0.0000000000000000000 0.14130376948564857735 0.44356825438511518913 0.62236250371477866781 0.75643291085695958624
0.86701472649056510395 0.96242365011920689500 1.3169578969248167086 1.7627471740390860505 1.8115262724608531070
@@ -11747,9 +11335,9 @@ EDITS: 2
((= i 15))
(let* ((nval (acosh (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad) (set! max-bad diff))))
+ (set! max-bad (max max-bad diff))))
(if (> max-bad 1.0e-15)
- (snd-display #__line__ ";acosh: ~A" max-bad)))
+ (snd-display ";acosh: ~A" max-bad)))
(let ((vals (vector -0.10016742116155979635 0.00000000000000000000 0.10016742116155979635 0.20135792079033079146 0.30469265401539750797
0.41151684606748801938 0.52359877559829887308 0.64350110879328438680 0.77539749661075306374 0.92729521800161223243
@@ -11758,11 +11346,10 @@ EDITS: 2
(max-bad 0.0))
(do ((i 0 (+ i 1)))
((= i 12))
- (let* ((nval (asin (vector-ref args i)))
- (diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad) (set! max-bad diff))))
+ (set! max-bad (max max-bad (abs (- (asin (vector-ref args i))
+ (vector-ref vals i))))))
(if (> max-bad 1.0e-15)
- (snd-display #__line__ ";asin: ~A" max-bad)))
+ (snd-display ";asin: ~A" max-bad)))
(let ((vals (vector -2.3124383412727526203 -0.88137358701954302523 0.00000000000000000000 0.099834078899207563327 0.19869011034924140647
0.29567304756342243910 0.39003531977071527608 0.48121182505960344750 0.56882489873224753010 0.65266656608235578681
@@ -11774,9 +11361,9 @@ EDITS: 2
((= i 20))
(let* ((nval (asinh (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad) (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> max-bad 1.0e-14)
- (snd-display #__line__ ";asinh(~A): ~A ~A -> ~A" (vector-ref args i) nval (vector-ref vals i) max-bad)))))
+ (snd-display ";asinh(~A): ~A ~A -> ~A" (vector-ref args i) nval (vector-ref vals i) max-bad)))))
(let ((vals (vector 0.00000000000000000000 0.24497866312686415417 0.32175055439664219340 0.46364760900080611621 0.78539816339744830962
1.1071487177940905030 1.2490457723982544258 1.3258176636680324651 1.3734007669450158609 1.4711276743037345919 1.5208379310729538578))
@@ -11785,11 +11372,10 @@ EDITS: 2
(max-bad 0.0))
(do ((i 0 (+ i 1)))
((= i 11))
- (let* ((nval (atan (vector-ref args i)))
- (diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad) (set! max-bad diff))))
+ (set! max-bad (max max-bad (abs (- (atan (vector-ref args i))
+ (vector-ref vals i))))))
(if (> max-bad 1.0e-15)
- (snd-display #__line__ ";atan: ~A" max-bad)))
+ (snd-display ";atan: ~A" max-bad)))
(let ((vals (vector -0.54930614433405484570 0.00000000000000000000 0.0010000003333335333335 0.10033534773107558064 0.20273255405408219099
0.30951960420311171547 0.42364893019360180686 0.54930614433405484570 0.69314718055994530942 0.86730052769405319443
@@ -11800,10 +11386,9 @@ EDITS: 2
((= i 15))
(let* ((nval (atanh (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-10) ; one is > e-11
- (snd-display #__line__ ";atanh(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";atanh(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector 0.1000000000000000E+01 0.1010025027795146E+01 0.1040401782229341E+01 0.1092045364317340E+01 0.1166514922869803E+01
0.1266065877752008E+01 0.1393725584134064E+01 0.1553395099731217E+01 0.1749980639738909E+01 0.1989559356618051E+01
@@ -11817,10 +11402,9 @@ EDITS: 2
((= i 20))
(let* ((nval (bes-i0 (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-4)
- (snd-display #__line__ ";bes-i0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-i0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector -0.1775967713143383E+00 -0.3971498098638474E+00 -0.2600519549019334E+00 0.2238907791412357E+00 0.7651976865579666E+00
0.1000000000000000E+01 0.7651976865579666E+00 0.2238907791412357E+00 -0.2600519549019334E+00 -0.3971498098638474E+00
@@ -11833,10 +11417,9 @@ EDITS: 2
((= i 21))
(let* ((nval (bes-j0 (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-15)
- (snd-display #__line__ ";bes-j0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-j0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector 0.3275791375914652E+00 0.6604332802354914E-01 -0.3390589585259365E+00 -0.5767248077568734E+00 -0.4400505857449335E+00
0.0000000000000000E+00 0.4400505857449335E+00 0.5767248077568734E+00 0.3390589585259365E+00 -0.6604332802354914E-01
@@ -11849,10 +11432,9 @@ EDITS: 2
((= i 21))
(let* ((nval (bes-j1 (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-15)
- (snd-display #__line__ ";bes-j1(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-j1(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector 0.1149034849319005E+00 0.3528340286156377E+00 0.4656511627775222E-01 0.2546303136851206E+00 -0.5971280079425882E-01
0.2497577302112344E-03 0.7039629755871685E-02 0.2611405461201701E+00 -0.2340615281867936E+00 -0.8140024769656964E-01
@@ -11866,10 +11448,9 @@ EDITS: 2
((= i 20))
(let* ((nval (bes-jn (vector-ref ns i) (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-15)
- (snd-display #__line__ ";bes-jn(~A ~A): ~A ~A -> ~A" (vector-ref ns i) (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-jn(~A ~A): ~A ~A -> ~A" (vector-ref ns i) (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector -0.1534238651350367E+01 0.8825696421567696E-01 0.5103756726497451E+00 0.3768500100127904E+00 -0.1694073932506499E-01
-0.3085176252490338E+00 -0.2881946839815792E+00 -0.2594974396720926E-01 0.2235214893875662E+00 0.2499366982850247E+00
@@ -11880,10 +11461,9 @@ EDITS: 2
((= i 16))
(let* ((nval (bes-y0 (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-15)
- (snd-display #__line__ ";bes-y0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-y0(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector -0.6458951094702027E+01 -0.7812128213002887E+00 -0.1070324315409375E+00 0.3246744247918000E+00 0.3979257105571000E+00
0.1478631433912268E+00 -0.1750103443003983E+00 -0.3026672370241849E+00 -0.1580604617312475E+00 0.1043145751967159E+00
@@ -11894,10 +11474,9 @@ EDITS: 2
((= i 16))
(let* ((nval (bes-y1 (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (> diff 1.0e-14)
- (snd-display #__line__ ";bes-y1(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-y1(~A): ~A ~A -> ~A" (vector-ref args i) (vector-ref vals i) nval diff)))))
(let ((vals (vector -0.1650682606816254E+01 -0.6174081041906827E+00 0.3676628826055245E+00 -0.5868082442208615E-02 0.9579316872759649E-01
-0.2604058666258122E+03 -0.9935989128481975E+01 -0.4536948224911019E+00 0.1354030476893623E+00 -0.7854841391308165E-01
@@ -11914,11 +11493,10 @@ EDITS: 2
((= i 19))
(let* ((nval (bes-yn (vector-ref ns i) (vector-ref args i)))
(diff (abs (- nval (vector-ref vals i)))))
- (if (> diff max-bad)
- (set! max-bad diff))
+ (set! max-bad (max max-bad diff))
(if (and (> diff 1.0e-6)
(not (= i 15))) ; see above
- (snd-display #__line__ ";bes-yn(~A ~A): ~A ~A -> ~A" (vector-ref ns i) (vector-ref args i) (vector-ref vals i) nval diff)))))
+ (snd-display ";bes-yn(~A ~A): ~A ~A -> ~A" (vector-ref ns i) (vector-ref args i) (vector-ref vals i) nval diff)))))
;; one (20 1.0) is off by a lot but the val is 1e22
;; numerics stuff
@@ -11929,9 +11507,8 @@ EDITS: 2
((= i 11))
(let ((nval (binomial-direct (vector-ref ns i) (vector-ref ks i)))
(mval (n-choose-k (vector-ref ns i) (vector-ref ks i))))
- (if (or (not (= nval (vector-ref vals i)))
- (not (= mval (vector-ref vals i))))
- (snd-display #__line__ ";binomial(~A ~A): ~A ~A ~A" (vector-ref ns i) (vector-ref ks i) nval mval (vector-ref vals i))))))
+ (if (not (= nval mval (vector-ref vals i)))
+ (snd-display ";binomial(~A ~A): ~A ~A ~A" (vector-ref ns i) (vector-ref ks i) nval mval (vector-ref vals i))))))
(let ((ls (vector 1 1 1 1 1 2 2 2 3 3 3 3 4 5 6 7 8 9 10))
(ms (vector 0 0 0 0 1 0 1 2 0 1 2 3 2 2 3 3 4 4 5))
@@ -11941,10 +11518,10 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 19))
(let ((val (plgndr (vector-ref ls i) (vector-ref ms i) (vector-ref xs i))))
- (if (or (not (real? val))
- (not (real? (vector-ref vals i)))
- (> (abs (- val (vector-ref vals i))) 0.1))
- (snd-display #__line__ ";plgndr(~A ~A ~A) = ~A (~A)" (vector-ref ls i) (vector-ref ms i) (vector-ref xs i) val (vector-ref vals i))))))
+ (if (not (and (real? val)
+ (real? (vector-ref vals i))
+ (<= (abs (- val (vector-ref vals i))) 0.1)))
+ (snd-display ";plgndr(~A ~A ~A) = ~A (~A)" (vector-ref ls i) (vector-ref ms i) (vector-ref xs i) val (vector-ref vals i))))))
(let ((vals (vector 1.0000000000 0.8000000000 0.2800000000 -0.3520000000 -0.8432000000 -0.9971200000
-0.7521920000 -0.2063872000 0.4219724800 0.8815431680 0.9884965888 0.7000513741 0.1315856097))
@@ -11955,7 +11532,7 @@ EDITS: 2
((= i 13))
(let ((val (chebyshev (vector-ref ns i) (vector-ref xs i))))
(if (fneq val (vector-ref vals i))
- (snd-display #__line__ ";chebyshev ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
+ (snd-display ";chebyshev ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -11964,7 +11541,7 @@ EDITS: 2
(val1 (gegenbauer order x 1.0))
(val2 (chebyshev order x 2)))
(if (fneq val1 val2)
- (snd-display #__line__ ";gegenbauer/chebyshev (alpha=1) ~A ~A: ~A ~A" order x val1 val2)))))
+ (snd-display ";gegenbauer/chebyshev (alpha=1) ~A ~A: ~A ~A" order x val1 val2)))))
(let ((as (vector 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.0 1.0 2.0 3.0
4.0 5.0 6.0 7.0 8.0 9.0 10.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0
@@ -12001,7 +11578,7 @@ EDITS: 2
((= i 38))
(let ((val (gegenbauer (vector-ref ns i) (vector-ref xs i) (vector-ref as i))))
(if (fneq val (vector-ref vals i))
- (snd-display #__line__ ";gegenbauer ~A ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) (vector-ref as i) val (vector-ref vals i)))))
+ (snd-display ";gegenbauer ~A ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) (vector-ref as i) val (vector-ref vals i)))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -12010,7 +11587,7 @@ EDITS: 2
(val1 (gegenbauer 3 x alpha))
(val2 (g3 x alpha)))
(if (fneq val1 val2)
- (snd-display #__line__ ";gegenbauer 3 ~A ~A: ~A ~A" x alpha val1 val2))))
+ (snd-display ";gegenbauer 3 ~A ~A: ~A ~A" x alpha val1 val2))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -12019,7 +11596,7 @@ EDITS: 2
(val1 (gegenbauer 5 x alpha))
(val2 (g5 x alpha)))
(if (fneq val1 val2)
- (snd-display #__line__ ";gegenbauer 5 ~A ~A: ~A ~A" x alpha val1 val2))))
+ (snd-display ";gegenbauer 5 ~A ~A: ~A ~A" x alpha val1 val2))))
)
(let ((vals (vector 1.0000000000 0.0000000000 -0.5000000000 -0.6666666667 -0.6250000000 -0.4666666667
@@ -12031,7 +11608,7 @@ EDITS: 2
((= i 17))
(let ((val (laguerre (vector-ref ns i) (vector-ref xs i))))
(if (fneq val (vector-ref vals i))
- (snd-display #__line__ ";laguerre ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
+ (snd-display ";laguerre ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
)
(let ((vals (vector 1.0 10.0 98.0 940.0 8812.0 80600.0
@@ -12043,7 +11620,7 @@ EDITS: 2
((= i 13))
(let ((val (hermite (vector-ref ns i) (vector-ref xs i))))
(if (fneq val (vector-ref vals i))
- (snd-display #__line__ ";hermite ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
+ (snd-display ";hermite ~A ~A -> ~A ~A" (vector-ref ns i) (vector-ref xs i) val (vector-ref vals i)))))
)
(do ((i 0 (+ i 1)))
@@ -12054,25 +11631,19 @@ EDITS: 2
0.5))
(pv (plgndr i 0 0.5)))
(if (fneq lv pv)
- (snd-display #__line__ ";lv: ~A, pv: ~A (~A)" lv pv i))))
+ (snd-display ";lv: ~A, pv: ~A (~A)" lv pv i))))
(let ((pow-x (lambda (pow x)
;; A&S p798
- (if (= pow 0)
- (legendre-polynomial (vector 1) x)
- (if (= pow 1)
- (legendre-polynomial (vector 0 1) x)
- (if (= pow 2)
- (* (/ 1.0 3.0) (legendre-polynomial (vector 1 0 2) x))
- (if (= pow 3)
- (* (/ 1.0 5.0) (legendre-polynomial (vector 0 3 0 2) x))
- (if (= pow 4)
- (* (/ 1.0 35.0) (legendre-polynomial (vector 7 0 20 0 8) x))
- (if (= pow 5)
- (* (/ 1.0 63.0) (legendre-polynomial (vector 0 27 0 28 0 8) x))
- (if (= pow 6)
- (* (/ 1.0 231.0) (legendre-polynomial (vector 33 0 110 0 72 0 16) x))
- 'oops))))))))))
+ (case pow
+ ((0) (legendre-polynomial (vector 1) x))
+ ((1) (legendre-polynomial (vector 0 1) x))
+ ((2) (* (/ 1.0 3.0) (legendre-polynomial (vector 1 0 2) x)))
+ ((3) (* (/ 1.0 5.0) (legendre-polynomial (vector 0 3 0 2) x)))
+ ((4) (* (/ 1.0 35.0) (legendre-polynomial (vector 7 0 20 0 8) x)))
+ ((5) (* (/ 1.0 63.0) (legendre-polynomial (vector 0 27 0 28 0 8) x)))
+ ((6) (* (/ 1.0 231.0) (legendre-polynomial (vector 33 0 110 0 72 0 16) x)))
+ (else 'oops)))))
(for-each
(lambda (x)
(for-each
@@ -12080,19 +11651,19 @@ EDITS: 2
(let ((lv (pow-x pow x))
(sv (expt x pow)))
(if (fneq lv sv)
- (snd-display #__line__ ";~A ^ ~A = ~A ~A?" x pow lv sv))))
+ (snd-display ";~A ^ ~A = ~A ~A?" x pow lv sv))))
(list 0 1 2 3 4 5 6)))
(list 2.0 0.5 0.1 -0.5 3.0 0.8)))
- (let ((snd (with-sound (:scaled-to 0.5)
+ (let* ((snd (with-sound (:scaled-to 0.5)
(do ((i 0 (+ i 1))
(x 0.0 (+ x .02)))
((= i 100))
- (outa i (legendre 20 (cos x)))))))
- (let ((index (find-sound snd)))
- (if (fneq (sample 0 index 0) 0.5) (snd-display #__line__ ";legendre(cos(x)) 0: ~A" (sample 0 index 0)))
- (if (fneq (sample 50 index 0) 0.062572978) (snd-display #__line__ ";legendre(cos(x)) 50: ~A" (sample 50 index 0)))
- (close-sound index)))
+ (outa i (legendre 20 (cos x))))))
+ (index (find-sound snd)))
+ (if (fneq (sample 0 index 0) 0.5) (snd-display ";legendre(cos(x)) 0: ~A" (sample 0 index 0)))
+ (if (fneq (sample 50 index 0) 0.062572978) (snd-display ";legendre(cos(x)) 50: ~A" (sample 50 index 0)))
+ (close-sound index))
(let (;(h0 (lambda (x) 1.0))
@@ -12118,23 +11689,23 @@ EDITS: 2
(v55 (hermite 5 x))
(v6 (h6 x))
(v66 (hermite 6 x)))
- (if (fneq v1 v11) (snd-display #__line__ ";hermite 1 ~A: ~A ~A" x v1 v11)
- (if (fneq v2 v22) (snd-display #__line__ ";hermite 2 ~A: ~A ~A" x v2 v22)
- (if (fneq v3 v33) (snd-display #__line__ ";hermite 3 ~A: ~A ~A" x v3 v33)
- (if (fneq v4 v44) (snd-display #__line__ ";hermite 4 ~A: ~A ~A" x v4 v44)
- (if (fneq v5 v55) (snd-display #__line__ ";hermite 5 ~A: ~A ~A" x v5 v55)
- (if (fneq v6 v66) (snd-display #__line__ ";hermite 6 ~A: ~A ~A" x v6 v66)))))))))))
+ (cond ((fneq v1 v11) (snd-display ";hermite 1 ~A: ~A ~A" x v1 v11))
+ ((fneq v2 v22) (snd-display ";hermite 2 ~A: ~A ~A" x v2 v22))
+ ((fneq v3 v33) (snd-display ";hermite 3 ~A: ~A ~A" x v3 v33))
+ ((fneq v4 v44) (snd-display ";hermite 4 ~A: ~A ~A" x v4 v44))
+ ((fneq v5 v55) (snd-display ";hermite 5 ~A: ~A ~A" x v5 v55))
+ ((fneq v6 v66) (snd-display ";hermite 6 ~A: ~A ~A" x v6 v66)))))))
(let ((lg1 (lambda (x) (- 1 x)))
(lg2 (lambda (x) (+ 1 (* 0.5 x x) (* -2 x))))
- (lag1 (lambda (x a) (+ 1 a (- x))))
+ (lag1 (lambda (x a) (- (+ 1 a) x)))
(lag2 (lambda (x a) (* 0.5 (+ (* x x)
(* -2 x (+ a 2))
(* (+ a 1) (+ a 2))))))
- (lag3 (lambda (x a) (* (/ -1.0 6.0) (+ (* x x x)
- (* -3 x x (+ a 3))
- (* 3 x (+ a 2) (+ a 3))
- (* -1 (+ a 1) (+ a 2) (+ a 3)))))))
+ (lag3 (lambda (x a) (* (/ -1.0 6.0) (- (+ (* x x x)
+ (* -3 x x (+ a 3))
+ (* 3 x (+ a 2) (+ a 3)))
+ (* (+ a 1) (+ a 2) (+ a 3)))))))
(let ((x (random 10.0))
(a (random 1.0)))
(let ((v1 (laguerre 1 x))
@@ -12147,11 +11718,11 @@ EDITS: 2
(va22 (laguerre 2 x a))
(va3 (lag3 x a))
(va33 (laguerre 3 x a)))
- (if (fneq v1 v11) (snd-display #__line__ ";laguerre 1 ~A: ~A ~A" x v1 v11)
- (if (fneq v2 v22) (snd-display #__line__ ";laguerre 2 ~A: ~A ~A" x v2 v22)
- (if (fneq va1 va11) (snd-display #__line__ ";laguerre 1a ~A ~A: ~A ~A" x a va1 va11)
- (if (fneq va2 va22) (snd-display #__line__ ";laguerre 2a ~A ~A: ~A ~A" x a va2 va22)
- (if (fneq va3 va33) (snd-display #__line__ ";laguerre 3a ~A ~A: ~A ~A" x a va3 va33)))))))))
+ (cond ((fneq v1 v11) (snd-display ";laguerre 1 ~A: ~A ~A" x v1 v11))
+ ((fneq v2 v22) (snd-display ";laguerre 2 ~A: ~A ~A" x v2 v22))
+ ((fneq va1 va11) (snd-display ";laguerre 1a ~A ~A: ~A ~A" x a va1 va11))
+ ((fneq va2 va22) (snd-display ";laguerre 2a ~A ~A: ~A ~A" x a va2 va22))
+ ((fneq va3 va33) (snd-display ";laguerre 3a ~A ~A: ~A ~A" x a va3 va33))))))
)
;; ----------------
@@ -12162,142 +11733,139 @@ EDITS: 2
(log-mem clmtest)
(numerical-reality-checks)
- (if (mus-generator? 321) (snd-display #__line__ ";123 is a gen?"))
- (if (mus-generator? (list 321)) (snd-display #__line__ ";(123) is a gen?"))
- (if (mus-generator? (list 'hi 321)) (snd-display #__line__ ";(hi 123) is a gen?"))
+ (if (mus-generator? 321) (snd-display ";123 is a gen?"))
+ (if (mus-generator? (list 321)) (snd-display ";(123) is a gen?"))
+ (if (mus-generator? (list 'hi 321)) (snd-display ";(hi 123) is a gen?"))
(set! *clm-srate* 22050)
(let ((samps (seconds->samples 1.0))
(secs (samples->seconds 22050)))
- (if (not (= samps 22050)) (snd-display #__line__ ";seconds->samples: ~A" samps))
- (if (fneq secs 1.0) (snd-display #__line__ ";samples->seconds: ~A" secs)))
+ (if (not (= samps 22050)) (snd-display ";seconds->samples: ~A" samps))
+ (if (fneq secs 1.0) (snd-display ";samples->seconds: ~A" secs)))
(set! *clm-file-buffer-size* default-file-buffer-size)
(let ((var (catch #t (lambda () (set! *clm-file-buffer-size* #f)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";mus-file-buffer-size bad size: ~A" var)))
+ (snd-display ";mus-file-buffer-size bad size: ~A" var)))
(set! *clm-file-buffer-size* 128)
- (if (not (= *clm-file-buffer-size* 128)) (snd-display #__line__ ";mus-file-buffer-size: ~D?" *clm-file-buffer-size*))
+ (if (not (= *clm-file-buffer-size* 128)) (snd-display ";mus-file-buffer-size: ~D?" *clm-file-buffer-size*))
(set! *clm-file-buffer-size* default-file-buffer-size)
- (if (and (not (= *mus-array-print-length* 8))
- (not (= *mus-array-print-length* 12))
- (not (= *mus-array-print-length* 32)))
- (snd-display #__line__ ";mus-array-print-length: ~D?" *mus-array-print-length*))
+ (if (not (member *mus-array-print-length* '(8 12 32) =))
+ (snd-display ";mus-array-print-length: ~D?" *mus-array-print-length*))
(set! *mus-array-print-length* 32)
- (if (not (= *mus-array-print-length* 32)) (snd-display #__line__ ";set mus-array-print-length: ~D?" *mus-array-print-length*))
+ (if (not (= *mus-array-print-length* 32)) (snd-display ";set mus-array-print-length: ~D?" *mus-array-print-length*))
(set! *mus-array-print-length* 8)
(let ((fudge *mus-float-equal-fudge-factor*))
(if (> (abs (- *mus-float-equal-fudge-factor* 0.0000001)) 0.00000001)
- (snd-display #__line__ ";mus-float-equal-fudge-factor: ~A?" *mus-float-equal-fudge-factor*))
+ (snd-display ";mus-float-equal-fudge-factor: ~A?" *mus-float-equal-fudge-factor*))
(set! *mus-float-equal-fudge-factor* .1)
(if (fneq *mus-float-equal-fudge-factor* .1)
- (snd-display #__line__ ";set mus-float-equal-fudge-factor: ~A?" *mus-float-equal-fudge-factor*))
+ (snd-display ";set mus-float-equal-fudge-factor: ~A?" *mus-float-equal-fudge-factor*))
(set! *mus-float-equal-fudge-factor* fudge))
- (if (fneq *clm-srate* 22050.0) (snd-display #__line__ ";mus-srate: ~F?" *clm-srate*))
- (if (fneq (hz->radians 1.0) 2.84951704088598e-4) (snd-display #__line__ ";hz->radians: ~F?" (hz->radians 1.0)))
- (if (fneq (radians->hz 2.84951704088598e-4) 1.0) (snd-display #__line__ ";radians->hz: ~F?" (radians->hz 2.84951704088598e-4)))
- (if (fneq (radians->degrees 1.0) 57.2957801818848) (snd-display #__line__ ";radians->degrees: ~F?" (radians->degrees 1.0)))
- (if (fneq (degrees->radians 57.2957801818848) 1.0) (snd-display #__line__ ";degrees->radians: ~F?" (degrees->radians 57.2957801818848)))
- (if (fneq (linear->db .25) -12.0411996841431) (snd-display #__line__ ";linear->db: ~F?" (linear->db .25)))
- (if (fneq (db->linear -12.0411996841431) .25) (snd-display #__line__ ";db->linear: ~F?" (db->linear -12.0411996841431)))
-
- (if (fneq (odd-weight 0.0) 0.0) (snd-display #__line__ ";odd-weight 0.0: ~F?" (odd-weight 0.0)))
- (if (fneq (odd-weight 2.0) 0.0) (snd-display #__line__ ";odd-weight 2.0: ~F?" (odd-weight 2.0)))
- (if (fneq (odd-weight 1.0) 1.0) (snd-display #__line__ ";odd-weight 1.0: ~F?" (odd-weight 1.0)))
- (if (fneq (odd-weight 1.5) 0.5) (snd-display #__line__ ";odd-weight 1.5: ~F?" (odd-weight 1.5)))
- (if (fneq (odd-weight 2.5) 0.5) (snd-display #__line__ ";odd-weight 2.5: ~F?" (odd-weight 2.5)))
- (if (fneq (odd-weight 2.1) 0.1) (snd-display #__line__ ";odd-weight 2.1: ~F?" (odd-weight 2.1)))
- (if (fneq (odd-weight 2.9) 0.9) (snd-display #__line__ ";odd-weight 2.9: ~F?" (odd-weight 2.9)))
- (if (fneq (odd-weight 1.1) 0.9) (snd-display #__line__ ";odd-weight 1.1: ~F?" (odd-weight 1.1)))
- (if (fneq (odd-weight 1.9) 0.1) (snd-display #__line__ ";odd-weight 1.9: ~F?" (odd-weight 1.9)))
-
- (if (fneq (even-weight 0.0) 1.0) (snd-display #__line__ ";even-weight 0.0: ~F?" (even-weight 0.0)))
- (if (fneq (even-weight 2.0) 1.0) (snd-display #__line__ ";even-weight 2.0: ~F?" (even-weight 2.0)))
- (if (fneq (even-weight 1.0) 0.0) (snd-display #__line__ ";even-weight 1.0: ~F?" (even-weight 1.0)))
- (if (fneq (even-weight 1.5) 0.5) (snd-display #__line__ ";even-weight 1.5: ~F?" (even-weight 1.5)))
- (if (fneq (even-weight 2.5) 0.5) (snd-display #__line__ ";even-weight 2.5: ~F?" (even-weight 2.5)))
- (if (fneq (even-weight 2.1) 0.9) (snd-display #__line__ ";even-weight 2.1: ~F?" (even-weight 2.1)))
- (if (fneq (even-weight 2.9) 0.1) (snd-display #__line__ ";even-weight 2.9: ~F?" (even-weight 2.9)))
- (if (fneq (even-weight 1.1) 0.1) (snd-display #__line__ ";even-weight 1.1: ~F?" (even-weight 1.1)))
- (if (fneq (even-weight 1.9) 0.9) (snd-display #__line__ ";even-weight 1.9: ~F?" (even-weight 1.9)))
-
- (if (fneq (odd-multiple 0.0 2.0) 2.0) (snd-display #__line__ ";odd-multiple 0.0: ~F?" (odd-multiple 0.0 2.0)))
- (if (fneq (odd-multiple 2.0 2.0) 6.0) (snd-display #__line__ ";odd-multiple 2.0: ~F?" (odd-multiple 2.0 2.0)))
- (if (fneq (odd-multiple 1.0 2.0) 2.0) (snd-display #__line__ ";odd-multiple 1.0: ~F?" (odd-multiple 1.0 2.0)))
- (if (fneq (odd-multiple 1.5 2.0) 2.0) (snd-display #__line__ ";odd-multiple 1.5: ~F?" (odd-multiple 1.5 2.0)))
- (if (fneq (odd-multiple 2.5 2.0) 6.0) (snd-display #__line__ ";odd-multiple 2.5: ~F?" (odd-multiple 2.5 2.0)))
- (if (fneq (odd-multiple 2.1 2.0) 6.0) (snd-display #__line__ ";odd-multiple 2.1: ~F?" (odd-multiple 2.1 2.0)))
- (if (fneq (odd-multiple 2.9 2.0) 6.0) (snd-display #__line__ ";odd-multiple 2.9: ~F?" (odd-multiple 2.9 2.0)))
- (if (fneq (odd-multiple 1.1 2.0) 2.0) (snd-display #__line__ ";odd-multiple 1.1: ~F?" (odd-multiple 1.1 2.0)))
- (if (fneq (odd-multiple 1.9 2.0) 2.0) (snd-display #__line__ ";odd-multiple 1.9: ~F?" (odd-multiple 1.9 2.0)))
-
- (if (fneq (even-multiple 0.0 2.0) 0.0) (snd-display #__line__ ";even-multiple 0.0: ~F?" (even-multiple 0.0 2.0)))
- (if (fneq (even-multiple 2.0 2.0) 4.0) (snd-display #__line__ ";even-multiple 2.0: ~F?" (even-multiple 2.0 2.0)))
- (if (fneq (even-multiple 1.0 2.0) 4.0) (snd-display #__line__ ";even-multiple 1.0: ~F?" (even-multiple 1.0 2.0)))
- (if (fneq (even-multiple 1.5 2.0) 4.0) (snd-display #__line__ ";even-multiple 1.5: ~F?" (even-multiple 1.5 2.0)))
- (if (fneq (even-multiple 2.5 2.0) 4.0) (snd-display #__line__ ";even-multiple 2.5: ~F?" (even-multiple 2.5 2.0)))
- (if (fneq (even-multiple 2.1 2.0) 4.0) (snd-display #__line__ ";even-multiple 2.1: ~F?" (even-multiple 2.1 2.0)))
- (if (fneq (even-multiple 2.9 2.0) 4.0) (snd-display #__line__ ";even-multiple 2.9: ~F?" (even-multiple 2.9 2.0)))
- (if (fneq (even-multiple 1.1 2.0) 4.0) (snd-display #__line__ ";even-multiple 1.1: ~F?" (even-multiple 1.1 2.0)))
- (if (fneq (even-multiple 1.9 2.0) 4.0) (snd-display #__line__ ";even-multiple 1.9: ~F?" (even-multiple 1.9 2.0)))
-
- (if (fneq (ring-modulate .4 .5) .2) (snd-display #__line__ ";ring-modulate: ~F?" (ring-modulate .4 .5)))
- (if (fneq (amplitude-modulate 1.0 .5 .4) .7) (snd-display #__line__ ";amplitude-modulate: ~F?" (amplitude-modulate 1.0 .5 .4)))
+ (if (fneq *clm-srate* 22050.0) (snd-display ";mus-srate: ~F?" *clm-srate*))
+ (if (fneq (hz->radians 1.0) 2.84951704088598e-4) (snd-display ";hz->radians: ~F?" (hz->radians 1.0)))
+ (if (fneq (radians->hz 2.84951704088598e-4) 1.0) (snd-display ";radians->hz: ~F?" (radians->hz 2.84951704088598e-4)))
+ (if (fneq (radians->degrees 1.0) 57.2957801818848) (snd-display ";radians->degrees: ~F?" (radians->degrees 1.0)))
+ (if (fneq (degrees->radians 57.2957801818848) 1.0) (snd-display ";degrees->radians: ~F?" (degrees->radians 57.2957801818848)))
+ (if (fneq (linear->db .25) -12.0411996841431) (snd-display ";linear->db: ~F?" (linear->db .25)))
+ (if (fneq (db->linear -12.0411996841431) .25) (snd-display ";db->linear: ~F?" (db->linear -12.0411996841431)))
+
+ (if (fneq (odd-weight 0.0) 0.0) (snd-display ";odd-weight 0.0: ~F?" (odd-weight 0.0)))
+ (if (fneq (odd-weight 2.0) 0.0) (snd-display ";odd-weight 2.0: ~F?" (odd-weight 2.0)))
+ (if (fneq (odd-weight 1.0) 1.0) (snd-display ";odd-weight 1.0: ~F?" (odd-weight 1.0)))
+ (if (fneq (odd-weight 1.5) 0.5) (snd-display ";odd-weight 1.5: ~F?" (odd-weight 1.5)))
+ (if (fneq (odd-weight 2.5) 0.5) (snd-display ";odd-weight 2.5: ~F?" (odd-weight 2.5)))
+ (if (fneq (odd-weight 2.1) 0.1) (snd-display ";odd-weight 2.1: ~F?" (odd-weight 2.1)))
+ (if (fneq (odd-weight 2.9) 0.9) (snd-display ";odd-weight 2.9: ~F?" (odd-weight 2.9)))
+ (if (fneq (odd-weight 1.1) 0.9) (snd-display ";odd-weight 1.1: ~F?" (odd-weight 1.1)))
+ (if (fneq (odd-weight 1.9) 0.1) (snd-display ";odd-weight 1.9: ~F?" (odd-weight 1.9)))
+
+ (if (fneq (even-weight 0.0) 1.0) (snd-display ";even-weight 0.0: ~F?" (even-weight 0.0)))
+ (if (fneq (even-weight 2.0) 1.0) (snd-display ";even-weight 2.0: ~F?" (even-weight 2.0)))
+ (if (fneq (even-weight 1.0) 0.0) (snd-display ";even-weight 1.0: ~F?" (even-weight 1.0)))
+ (if (fneq (even-weight 1.5) 0.5) (snd-display ";even-weight 1.5: ~F?" (even-weight 1.5)))
+ (if (fneq (even-weight 2.5) 0.5) (snd-display ";even-weight 2.5: ~F?" (even-weight 2.5)))
+ (if (fneq (even-weight 2.1) 0.9) (snd-display ";even-weight 2.1: ~F?" (even-weight 2.1)))
+ (if (fneq (even-weight 2.9) 0.1) (snd-display ";even-weight 2.9: ~F?" (even-weight 2.9)))
+ (if (fneq (even-weight 1.1) 0.1) (snd-display ";even-weight 1.1: ~F?" (even-weight 1.1)))
+ (if (fneq (even-weight 1.9) 0.9) (snd-display ";even-weight 1.9: ~F?" (even-weight 1.9)))
+
+ (if (fneq (odd-multiple 0.0 2.0) 2.0) (snd-display ";odd-multiple 0.0: ~F?" (odd-multiple 0.0 2.0)))
+ (if (fneq (odd-multiple 2.0 2.0) 6.0) (snd-display ";odd-multiple 2.0: ~F?" (odd-multiple 2.0 2.0)))
+ (if (fneq (odd-multiple 1.0 2.0) 2.0) (snd-display ";odd-multiple 1.0: ~F?" (odd-multiple 1.0 2.0)))
+ (if (fneq (odd-multiple 1.5 2.0) 2.0) (snd-display ";odd-multiple 1.5: ~F?" (odd-multiple 1.5 2.0)))
+ (if (fneq (odd-multiple 2.5 2.0) 6.0) (snd-display ";odd-multiple 2.5: ~F?" (odd-multiple 2.5 2.0)))
+ (if (fneq (odd-multiple 2.1 2.0) 6.0) (snd-display ";odd-multiple 2.1: ~F?" (odd-multiple 2.1 2.0)))
+ (if (fneq (odd-multiple 2.9 2.0) 6.0) (snd-display ";odd-multiple 2.9: ~F?" (odd-multiple 2.9 2.0)))
+ (if (fneq (odd-multiple 1.1 2.0) 2.0) (snd-display ";odd-multiple 1.1: ~F?" (odd-multiple 1.1 2.0)))
+ (if (fneq (odd-multiple 1.9 2.0) 2.0) (snd-display ";odd-multiple 1.9: ~F?" (odd-multiple 1.9 2.0)))
+
+ (if (fneq (even-multiple 0.0 2.0) 0.0) (snd-display ";even-multiple 0.0: ~F?" (even-multiple 0.0 2.0)))
+ (if (fneq (even-multiple 2.0 2.0) 4.0) (snd-display ";even-multiple 2.0: ~F?" (even-multiple 2.0 2.0)))
+ (if (fneq (even-multiple 1.0 2.0) 4.0) (snd-display ";even-multiple 1.0: ~F?" (even-multiple 1.0 2.0)))
+ (if (fneq (even-multiple 1.5 2.0) 4.0) (snd-display ";even-multiple 1.5: ~F?" (even-multiple 1.5 2.0)))
+ (if (fneq (even-multiple 2.5 2.0) 4.0) (snd-display ";even-multiple 2.5: ~F?" (even-multiple 2.5 2.0)))
+ (if (fneq (even-multiple 2.1 2.0) 4.0) (snd-display ";even-multiple 2.1: ~F?" (even-multiple 2.1 2.0)))
+ (if (fneq (even-multiple 2.9 2.0) 4.0) (snd-display ";even-multiple 2.9: ~F?" (even-multiple 2.9 2.0)))
+ (if (fneq (even-multiple 1.1 2.0) 4.0) (snd-display ";even-multiple 1.1: ~F?" (even-multiple 1.1 2.0)))
+ (if (fneq (even-multiple 1.9 2.0) 4.0) (snd-display ";even-multiple 1.9: ~F?" (even-multiple 1.9 2.0)))
+
+ (if (fneq (ring-modulate .4 .5) .2) (snd-display ";ring-modulate: ~F?" (ring-modulate .4 .5)))
+ (if (fneq (amplitude-modulate 1.0 .5 .4) .7) (snd-display ";amplitude-modulate: ~F?" (amplitude-modulate 1.0 .5 .4)))
(if (fneq (contrast-enhancement 0.1 0.75) (sin (+ (* 0.1 (/ pi 2)) (* .75 (sin (* 0.1 2.0 pi))))))
- (snd-display #__line__ ";contrast-enhancement: ~F (0.562925306221587)" (contrast-enhancement 0.1 0.75)))
- (if (fneq (contrast-enhancement 1.0) 1.0) (snd-display #__line__ ";contrast-enhancement opt: ~A" (contrast-enhancement 1.0)))
- (let ((lv0 (partials->polynomial (float-vector 1 1 2 1) mus-chebyshev-first-kind))
- (lv1 (partials->polynomial '(1 1 2 1) mus-chebyshev-second-kind))
- (lv2 (partials->polynomial '(1 1 2 1 3 1 5 1) mus-chebyshev-first-kind))
- (lv3 (partials->polynomial '(1 1 2 1 3 1 5 1) mus-chebyshev-second-kind))
- (lv4 (partials->polynomial '(1 1 2 .5 3 .1 6 .01) mus-chebyshev-first-kind))
- (lv5 (partials->polynomial (list 1 1 2 .5 3 .1 6 .01) mus-chebyshev-second-kind))
- (lv6 (partials->polynomial (float-vector 1 9 2 3 3 5 4 7 5 1))) ; MLB
- (lv7 (partials->polynomial '(7 1)))
- (lv7a (partials->polynomial '(7 1) mus-chebyshev-first-kind))
- (lv8 (partials->polynomial '(7 1) mus-chebyshev-second-kind))
- )
- (if (not (fveql lv0 '(-1.000 1.000 2.000) 0)) (snd-display #__line__ ";partials->polynomial(1): ~A?" lv0))
- (if (not (fveql lv1 '(1.000 2.000 0.0) 0)) (snd-display #__line__ ";partials->polynomial(2): ~A?" lv1))
- (if (not (fveql lv2 '(-1.000 3.000 2.000 -16.000 0.000 16.000) 0)) (snd-display #__line__ ";partials->polynomial(3): ~A?" lv2))
- (if (not (fveql lv3 '(1.000 2.000 -8.000 0.000 16.000 0.000) 0)) (snd-display #__line__ ";partials->polynomial(4): ~A?" lv3))
- (if (not (fveql lv4 '(-0.510 0.700 1.180 0.400 -0.480 0.000 0.320) 0)) (snd-display #__line__ ";partials->polynomial(5): ~A?" lv4))
- (if (not (fveql lv5 '(0.900 1.060 0.400 -0.320 0.000 0.320 0.000) 0)) (snd-display #__line__ ";partials->polynomial(6): ~A?" lv5))
- (if (not (vequal lv6 (float-vector 4.000 -1.000 -50.000 0.000 56.000 16.000))) (snd-display #__line__ ";partials->polynomial(7): ~A?" lv6))
- (if (not (vequal lv7 (float-vector 0.000 -7.000 0.000 56.000 0.000 -112.000 0.000 64.000))) (snd-display #__line__ ";partials->polynomial(8): ~A?" lv7))
- (if (not (vequal lv8 (float-vector -1.000 0.000 24.000 0.000 -80.000 0.000 64.000 0.000))) (snd-display #__line__ ";partials->polynomial(9): ~A?" lv8))
- (if (not (vequal lv7 lv7a)) (snd-display #__line__ ";partials->polynomial kind=1? ~A ~A" lv7 lv7a))
-
- (if (not (vequal (normalize-partials (list 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
- (snd-display #__line__ ";normalize-partials 1: ~A" (normalize-partials (list 1 1 2 1))))
- (if (not (vequal (normalize-partials (float-vector 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
- (snd-display #__line__ ";normalize-partials 2: ~A" (normalize-partials (float-vector 1 1 2 1))))
- (if (not (vequal (normalize-partials (float-vector 1 1 2 -1)) (float-vector 1.000 0.500 2.000 -0.500)))
- (snd-display #__line__ ";normalize-partials 3: ~A" (normalize-partials (float-vector 1 1 2 -1))))
- (if (not (vequal (normalize-partials (float-vector 1 -.1 2 -.1)) (float-vector 1.000 -0.500 2.000 -0.500)))
- (snd-display #__line__ ";normalize-partials 4: ~A" (normalize-partials (float-vector 1 -.1 2 -.1))))
- (if (not (vequal (normalize-partials (float-vector 0 2 1 1 4 1)) (float-vector 0.000 0.500 1.000 0.250 4.000 0.250)))
- (snd-display #__line__ ";normalize-partials 4: ~A" (normalize-partials (float-vector 0 2 1 1 4 1))))
-
+ (snd-display ";contrast-enhancement: ~F (0.562925306221587)" (contrast-enhancement 0.1 0.75)))
+ (if (fneq (contrast-enhancement 1.0) 1.0) (snd-display ";contrast-enhancement opt: ~A" (contrast-enhancement 1.0)))
+ (let ((lv0 (partials->polynomial (float-vector 1 1 2 1) mus-chebyshev-first-kind)))
+ (if (not (fveql lv0 '(-1.000 1.000 2.000) 0)) (snd-display ";partials->polynomial(1): ~A?" lv0)))
+ (let ((lv1 (partials->polynomial '(1 1 2 1) mus-chebyshev-second-kind)))
+ (if (not (fveql lv1 '(1.000 2.000 0.0) 0)) (snd-display ";partials->polynomial(2): ~A?" lv1)))
+ (let ((lv2 (partials->polynomial '(1 1 2 1 3 1 5 1) mus-chebyshev-first-kind)))
+ (if (not (fveql lv2 '(-1.000 3.000 2.000 -16.000 0.000 16.000) 0)) (snd-display ";partials->polynomial(3): ~A?" lv2)))
+ (let ((lv3 (partials->polynomial '(1 1 2 1 3 1 5 1) mus-chebyshev-second-kind)))
+ (if (not (fveql lv3 '(1.000 2.000 -8.000 0.000 16.000 0.000) 0)) (snd-display ";partials->polynomial(4): ~A?" lv3)))
+ (let ((lv4 (partials->polynomial '(1 1 2 .5 3 .1 6 .01) mus-chebyshev-first-kind)))
+ (if (not (fveql lv4 '(-0.510 0.700 1.180 0.400 -0.480 0.000 0.320) 0)) (snd-display ";partials->polynomial(5): ~A?" lv4)))
+ (let ((lv5 (partials->polynomial (list 1 1 2 .5 3 .1 6 .01) mus-chebyshev-second-kind)))
+ (if (not (fveql lv5 '(0.900 1.060 0.400 -0.320 0.000 0.320 0.000) 0)) (snd-display ";partials->polynomial(6): ~A?" lv5)))
+ (let ((lv6 (partials->polynomial (float-vector 1 9 2 3 3 5 4 7 5 1))))
+ (if (not (vequal lv6 (float-vector 4.000 -1.000 -50.000 0.000 56.000 16.000))) (snd-display ";partials->polynomial(7): ~A?" lv6)))
+ (let ((lv7 (partials->polynomial '(7 1))))
+ (if (not (vequal lv7 (float-vector 0.000 -7.000 0.000 56.000 0.000 -112.000 0.000 64.000))) (snd-display ";partials->polynomial(8): ~A?" lv7))
+ (let ((lv7a (partials->polynomial '(7 1) mus-chebyshev-first-kind)))
+ (if (not (vequal lv7 lv7a)) (snd-display ";partials->polynomial kind=1? ~A ~A" lv7 lv7a)))
(if (fneq (polynomial lv7 1.0) (cosh (* 7 (acosh 1.0))))
- (snd-display #__line__ ";ccosh cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cosh (* 7 (acosh 1.0)))))
+ (snd-display ";ccosh cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cosh (* 7 (acosh 1.0)))))
(if (fneq (polynomial lv7 1.0) (cos (* 7 (acos 1.0))))
- (snd-display #__line__ ";cos cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cos (* 7 (acos 1.0)))))
- (if (fneq (polynomial lv8 0.5) (/ (sin (* 7 (acos 0.5))) (sin (acos 0.5))))
- (snd-display #__line__ ";acos cheb 7 1.0: ~A ~A" (polynomial lv8 0.5) (/ (sin (* 7 (acos 0.5))) (sin (acos 0.5)))))
- ;; G&R 8.943 p 984 uses n+1 where we use n in Un? (our numbering keeps harmonics aligned between Tn and Un)
-
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (let ((val (mus-random 1.0)))
- (if (fneq (polynomial lv7 val) (cosh (* 7 (acosh val))))
- (snd-display #__line__ ";ccosh cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cosh (* 7 (acosh val)))))
- (if (fneq (polynomial lv7 val) (cos (* 7 (acos val))))
- (snd-display #__line__ ";cos cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cos (* 7 (acos val)))))
- (if (fneq (polynomial lv8 val) (/ (sin (* 7 (acos val))) (sin (acos val))))
- (snd-display #__line__ ";acos cheb 7 ~A: ~A ~A" val (polynomial lv8 val) (/ (sin (* 7 (acos val))) (sin (acos val)))))))
- )
+ (snd-display ";cos cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cos (* 7 (acos 1.0)))))
+ (let ((lv8 (partials->polynomial '(7 1) mus-chebyshev-second-kind)))
+ (do ((sa (sin (acos 0.5)))
+ (ca (acos 0.5))
+ (i 0 (+ i 1)))
+ ((= i 10))
+ (let* ((val (mus-random 1.0))
+ (aval (acos val)))
+ (if (fneq (polynomial lv7 val) (cosh (* 7 (acosh val))))
+ (snd-display ";ccosh cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cosh (* 7 (acosh val)))))
+ (if (fneq (polynomial lv7 val) (cos (* 7 aval)))
+ (snd-display ";cos cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cos (* 7 aval))))
+ (if (fneq (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))
+ (snd-display ";acos cheb 7 ~A: ~A ~A" val (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))))
+ (if (not (vequal lv8 (float-vector -1.000 0.000 24.000 0.000 -80.000 0.000 64.000 0.000))) (snd-display ";partials->polynomial(9): ~A?" lv8))
+ (if (fneq (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa))
+ (snd-display ";acos cheb 7 1.0: ~A ~A" (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa))))))
+ ;; G&R 8.943 p 984 uses n+1 where we use n in Un? (our numbering keeps harmonics aligned between Tn and Un)
+
+ (if (not (vequal (normalize-partials (list 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
+ (snd-display ";normalize-partials 1: ~A" (normalize-partials (list 1 1 2 1))))
+ (if (not (vequal (normalize-partials (float-vector 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
+ (snd-display ";normalize-partials 2: ~A" (normalize-partials (float-vector 1 1 2 1))))
+ (if (not (vequal (normalize-partials (float-vector 1 1 2 -1)) (float-vector 1.000 0.500 2.000 -0.500)))
+ (snd-display ";normalize-partials 3: ~A" (normalize-partials (float-vector 1 1 2 -1))))
+ (if (not (vequal (normalize-partials (float-vector 1 -.1 2 -.1)) (float-vector 1.000 -0.500 2.000 -0.500)))
+ (snd-display ";normalize-partials 4: ~A" (normalize-partials (float-vector 1 -.1 2 -.1))))
+ (if (not (vequal (normalize-partials (float-vector 0 2 1 1 4 1)) (float-vector 0.000 0.500 1.000 0.250 4.000 0.250)))
+ (snd-display ";normalize-partials 4: ~A" (normalize-partials (float-vector 0 2 1 1 4 1))))
;; check phase-quadrature cancellations
(let ((cos-coeffs (partials->polynomial '(1 1 2 1) mus-chebyshev-first-kind))
@@ -12316,10 +11884,10 @@ EDITS: 2
(lower2 (+ 1.0 (cos a))))
(if (or (fneq upper upper2)
(fneq lower lower2))
- (snd-display #__line__ ";~A ~A, ~A ~A" upper upper2 lower lower2)))))
+ (snd-display ";~A ~A, ~A ~A" upper upper2 lower lower2)))))
(let ((tag (catch #t (lambda () (harmonicizer 550.0 (list .5 .3 .2) 10)) (lambda args (car args)))))
- (if (not (eq? tag 'no-data)) (snd-display #__line__ ";odd length arg to partials->polynomial: ~A" tag)))
+ (if (not (eq? tag 'no-data)) (snd-display ";odd length arg to partials->polynomial: ~A" tag)))
(let ((rdat (make-float-vector 16))
(idat (make-float-vector 16))
@@ -12331,7 +11899,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 8)) ;should all be 1.0 (impulse in)
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";spectra not equal 1: ~A ~A" v0 v1))))
+ (snd-display ";spectra not equal 1: ~A ~A" v0 v1))))
(float-vector-scale! idat 0.0)
(float-vector-scale! rdat 0.0)
(set! (rdat 0) 1.0)
@@ -12340,11 +11908,11 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 8)) ;should all be 1.0 (impulse in)
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";spectra not equal 0: ~A ~A" v0 v1))))
+ (snd-display ";spectra not equal 0: ~A ~A" v0 v1))))
(let ((var (catch #t (lambda () (spectrum rdat idat #f -1)) (lambda args args))))
(if (or (float-vector? var)
(not (eq? (car var) 'out-of-range)))
- (snd-display #__line__ ";spectrum bad type: ~A" var))))
+ (snd-display ";spectrum bad type: ~A" var))))
(let ((rdat (make-float-vector 16))
(idat (make-float-vector 16))
@@ -12354,19 +11922,20 @@ EDITS: 2
(set! (xdat 3) 1.0)
(fft rdat idat 1)
(mus-fft xdat ydat 16 1)
- (if (fneq (rdat 0) (xdat 0)) (snd-display #__line__ ";ffts: ~A ~A?" rdat xdat))
+ (if (fneq (rdat 0) (xdat 0)) (snd-display ";ffts: ~A ~A?" rdat xdat))
(fft rdat idat -1)
(mus-fft xdat ydat 17 -1) ; mistake is deliberate
(do ((i 0 (+ i 1)))
((= i 16))
- (if (or (and (= i 3) (or (fneq (rdat i) 16.0) (fneq (xdat i) 16.0)))
- (and (not (= i 3)) (or (fneq (rdat i) 0.0) (fneq (xdat i) 0.0))))
- (snd-display #__line__ ";fft real[~D]: ~A ~A?" i (rdat i) (xdat i)))
+ (if (if (= i 3)
+ (or (fneq (rdat i) 16.0) (fneq (xdat i) 16.0))
+ (or (fneq (rdat i) 0.0) (fneq (xdat i) 0.0)))
+ (snd-display ";fft real[~D]: ~A ~A?" i (rdat i) (xdat i)))
(if (or (fneq (idat i) 0.0) (fneq (ydat i) 0.0))
- (snd-display #__line__ ";fft imag[~D]: ~A ~A?" i (idat i) (ydat i))))
+ (snd-display ";fft imag[~D]: ~A ~A?" i (idat i) (ydat i))))
(let ((var (catch #t (lambda () (mus-fft xdat ydat -1 0)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";mus-fft bad len: ~A" var))))
+ (snd-display ";mus-fft bad len: ~A" var))))
(let ((rdat (make-float-vector 20))
(idat (make-float-vector 19)))
@@ -12380,29 +11949,29 @@ EDITS: 2
(fill! v0 1.0)
(fill! v1 0.5)
(float-vector-multiply! v0 v1)
- (if (fneq (v0 0) 0.5) (snd-display #__line__ ";multiple-arrays: ~F?" (v0 0)))
+ (if (fneq (v0 0) 0.5) (snd-display ";multiple-arrays: ~F?" (v0 0)))
(let ((sum (dot-product v0 v1)))
- (if (fneq sum 2.5) (snd-display #__line__ ";dot-product: ~F?" sum)))
+ (if (fneq sum 2.5) (snd-display ";dot-product: ~F?" sum)))
(let ((sum (dot-product v0 v1 10)))
- (if (fneq sum 2.5) (snd-display #__line__ ";dot-product (10): ~F?" sum)))
+ (if (fneq sum 2.5) (snd-display ";dot-product (10): ~F?" sum)))
(let ((sum (dot-product v0 v1 3)))
- (if (fneq sum 0.75) (snd-display #__line__ ";dot-product (3): ~F?" sum)))
+ (if (fneq sum 0.75) (snd-display ";dot-product (3): ~F?" sum)))
(fill! v0 0.0)
- (if (fneq (v0 3) 0.0) (snd-display #__line__ ";fill!: ~A?" v0))
+ (if (fneq (v0 3) 0.0) (snd-display ";fill!: ~A?" v0))
(fill! v0 1.0)
(fill! v1 0.5)
(let ((v2 (rectangular->polar v0 v1)))
- (if (fneq (v2 0) 1.118) (snd-display #__line__ ";rectangular->polar: ~A?" v2)))
+ (if (fneq (v2 0) 1.118) (snd-display ";rectangular->polar: ~A?" v2)))
(set! (v0 0) 1.0)
(set! (v1 0) 1.0)
(rectangular->polar v0 v1)
(if (or (fneq (v0 0) (sqrt 2.0))
(fneq (v1 0) (- (atan 1.0 1.0)))) ;(tan (atan 1.0 1.0)) -> 1.0
- (snd-display #__line__ ";rectangular->polar (~A ~A): ~A ~A?" (sqrt 2.0) (- (atan 1.0 1.0)) (v0 0) (v1 0)))
+ (snd-display ";rectangular->polar (~A ~A): ~A ~A?" (sqrt 2.0) (- (atan 1.0 1.0)) (v0 0) (v1 0)))
(polar->rectangular v0 v1)
(if (or (fneq (v0 0) 1.0)
(fneq (v1 0) 1.0))
- (snd-display #__line__ ";polar->rectangular (1 1): ~A ~A?" (v0 0) (v1 0)))
+ (snd-display ";polar->rectangular (1 1): ~A ~A?" (v0 0) (v1 0)))
(let ((ind (open-sound "oboe.snd"))
(rl (channel->float-vector 1200 512))
@@ -12416,7 +11985,7 @@ EDITS: 2
((= i 512))
(if (or (fneq (rl i) (rl-copy i))
(fneq (im i) (im-copy i)))
- (snd-display #__line__ ";polar->rectangular[~D]: ~A ~A ~A ~A"
+ (snd-display ";polar->rectangular[~D]: ~A ~A ~A ~A"
i
(rl i) (rl-copy i)
(im i) (im-copy i)))))
@@ -12427,7 +11996,7 @@ EDITS: 2
(do ((i 0 (+ i 1))) ((= i 8)) (set! (v0 i) i) (set! (v1 i) (/ (+ i 1))))
(rectangular->magnitudes v0 v1)
(if (not (vequal v0 (float-vector 1.000 1.118 2.028 3.010 4.005 5.003 6.002 7.001)))
- (snd-display #__line__ ";rectangular->magnitudes v0: ~A" v0)))
+ (snd-display ";rectangular->magnitudes v0: ~A" v0)))
(let ((v0 (make-float-vector 8))
(v1 (make-float-vector 8))
@@ -12444,51 +12013,51 @@ EDITS: 2
(rectangular->magnitudes v0 v1)
(rectangular->polar v2 v3)
(if (not (vequal v0 v2))
- (snd-display #__line__ ";rectangular->magnitudes|polar: ~A ~A" v0 v2)))
-
- (if (defined? 'edot-product) ; needs complex numbers in C
- (let* ((vals (make-float-vector 1 1.0))
- (v1 (edot-product 0.0 vals)))
- (if (fneq v1 1.0) ; exp 0.0 * 1.0
- (snd-display #__line__ ";edot a 1.0: ~A" v1))
- (set! (vals 0) 0.0)
- (set! v1 (edot-product 0.0 vals))
- (if (fneq v1 0.0) ; exp 0.0 * 0.0
- (snd-display #__line__ ";edot b 0.0: ~A" v1))
- (set! vals (make-vector 1 1.0))
- (set! v1 (edot-product 0.0 vals))
- (if (fneq v1 1.0) ; exp 0.0 * 1.0
- (snd-display #__line__ ";edot c 1.0: ~A" v1))
- (set! (vals 0) 0.0+i)
- (set! v1 (edot-product 0.0 vals))
- (if (cneq v1 0.0+i)
- (snd-display #__line__ ";edot i: ~A" v1))
- (set! vals (make-float-vector 4 1.0))
- (set! v1 (edot-product (* 0.25 2 pi) vals))
- (let ((v2 (+ (exp (* 0 2 pi))
- (exp (* 0.25 2 pi))
- (exp (* 0.5 2 pi))
- (exp (* 0.75 2 pi)))))
- (if (fneq v1 v2) (snd-display #__line__ ";edot 4: ~A ~A" v1 v2)))
- (set! vals (make-vector 4 0.0))
- (do ((i 0 (+ i 1)))
- ((= i 4))
- (set! (vals i) (+ i 1.0)))
- (set! v1 (edot-product (* 0.25 2 pi 0.0-i) vals))
- (let ((v2 (+ (* (exp (* 0 2 pi 0.0-i)))
- (* 2 (exp (* 0.25 2 pi 0.0-i)))
- (* 3 (exp (* 0.5 2 pi 0.0-i)))
- (* 4 (exp (* 0.75 2 pi 0.0-i))))))
- (if (cneq v1 v2) (snd-display #__line__ ";edot 4 -i: ~A ~A" v1 v2)))
- (do ((i 0 (+ i 1)))
- ((= i 4))
- (set! (vals i) (+ i 1.0+i)))
- (set! v1 (edot-product (* 0.25 2 pi 0.0-i) vals))
- (let ((v2 (+ (* 1+i (exp (* 0 2 pi 0.0-i)))
- (* 2+i (exp (* 0.25 2 pi 0.0-i)))
- (* 3+i (exp (* 0.5 2 pi 0.0-i)))
- (* 4+i (exp (* 0.75 2 pi 0.0-i))))))
- (if (cneq v1 v2) (snd-display #__line__ ";edot 4 -i * i: ~A ~A" v1 v2)))))
+ (snd-display ";rectangular->magnitudes|polar: ~A ~A" v0 v2)))
+
+ (when (defined? 'edot-product) ; needs complex numbers in C
+ (let* ((vals (make-float-vector 1 1.0))
+ (v1 (edot-product 0.0 vals)))
+ (if (fneq v1 1.0) ; exp 0.0 * 1.0
+ (snd-display ";edot a 1.0: ~A" v1))
+ (set! (vals 0) 0.0)
+ (set! v1 (edot-product 0.0 vals))
+ (if (fneq v1 0.0) ; exp 0.0 * 0.0
+ (snd-display ";edot b 0.0: ~A" v1))
+ (set! vals (make-vector 1 1.0))
+ (set! v1 (edot-product 0.0 vals))
+ (if (fneq v1 1.0) ; exp 0.0 * 1.0
+ (snd-display ";edot c 1.0: ~A" v1))
+ (set! (vals 0) 0.0+i)
+ (set! v1 (edot-product 0.0 vals))
+ (if (cneq v1 0.0+i)
+ (snd-display ";edot i: ~A" v1))
+ (set! vals (make-float-vector 4 1.0))
+ (set! v1 (edot-product (* 0.25 2 pi) vals))
+ (let ((v2 (+ 1 ;(exp (* 0 2 pi))
+ (exp (* 0.25 2 pi))
+ (exp (* 0.5 2 pi))
+ (exp (* 0.75 2 pi)))))
+ (if (fneq v1 v2) (snd-display ";edot 4: ~A ~A" v1 v2)))
+ (set! vals (make-vector 4 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (set! (vals i) (+ i 1.0)))
+ (set! v1 (edot-product (* 0.25 2 pi 0.0-i) vals))
+ (let ((v2 (+ 1 ;(* (exp (* 0 2 pi 0.0-i)))
+ (* 2 (exp (* 0.25 2 pi 0.0-i)))
+ (* 3 (exp (* 0.5 2 pi 0.0-i)))
+ (* 4 (exp (* 0.75 2 pi 0.0-i))))))
+ (if (cneq v1 v2) (snd-display ";edot 4 -i: ~A ~A" v1 v2)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (set! (vals i) (+ i 1.0+i)))
+ (set! v1 (edot-product (* 0.25 2 pi 0.0-i) vals))
+ (let ((v2 (+ 1+i ;(* 1+i (exp (* 0 2 pi 0.0-i)))
+ (* 2+i (exp (* 0.25 2 pi 0.0-i)))
+ (* 3+i (exp (* 0.5 2 pi 0.0-i)))
+ (* 4+i (exp (* 0.75 2 pi 0.0-i))))))
+ (if (cneq v1 v2) (snd-display ";edot 4 -i * i: ~A ~A" v1 v2)))))
(let ((v0 (make-float-vector 3)))
(set! (v0 0) 1.0)
@@ -12497,15 +12066,15 @@ EDITS: 2
(if (or (fneq (polynomial v0 0.0) 1.0)
(fneq (polynomial v0 1.0) 1.6)
(fneq (polynomial v0 2.0) 2.4))
- (snd-display #__line__ ";polynomial: ~A ~A ~A?"
+ (snd-display ";polynomial: ~A ~A ~A?"
(polynomial v0 0.0)
(polynomial v0 1.0)
(polynomial v0 2.0))))
(if (fneq (polynomial (float-vector 0.0 2.0) 0.5) 1.0)
- (snd-display #__line__ ";polynomial 2.0 * 0.5: ~A" (polynomial (float-vector 2.0) 0.5)))
+ (snd-display ";polynomial 2.0 * 0.5: ~A" (polynomial (float-vector 2.0) 0.5)))
(let ((var (catch #t (lambda () (polynomial #f 1.0)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";polynomial empty coeffs: ~A" var)))
+ (snd-display ";polynomial empty coeffs: ~A" var)))
(do ((i 0 (+ i 1)))
((= i 100))
@@ -12515,98 +12084,93 @@ EDITS: 2
(val2 (modulo arg1 arg2)))
(if (and (> (abs (- val1 val2)) 1e-8)
(> (abs (- (abs (- val1 val2)) (abs arg2))) 1e-8))
- (snd-display #__line__ ";poly ~A ~A: ~A ~A -> ~A~%" arg1 arg2 val1 val2 (abs (- val1 val2)))))))
+ (snd-display ";poly ~A ~A: ~A ~A -> ~A~%" arg1 arg2 val1 val2 (abs (- val1 val2)))))))
(let ((err 0.0)
(coeffs (float-vector 1.0 0.0 -.4999999963 0.0 .0416666418 0.0 -.0013888397 0.0 .0000247609 0.0 -.0000002605))
(pi2 (* pi 0.5)))
- (letrec ((new-cos
- (lambda (x)
- (let ((xx (abs x)))
- (if (<= xx pi2)
- (polynomial coeffs xx)
- (let ((nxx (modulo xx (* 2 pi))))
- (if (<= nxx pi2)
- (polynomial coeffs nxx)
- (if (<= nxx pi)
- (- (polynomial coeffs (- pi nxx)))
- (if (< nxx (* 1.5 pi))
- (- (polynomial coeffs (- nxx pi)))
- (polynomial coeffs (- (* 2 pi) nxx)))))))))))
+ (let ((new-cos
+ (lambda (x)
+ (let ((xx (abs x)))
+ (if (<= xx pi2)
+ (polynomial coeffs xx)
+ (let ((nxx (modulo xx (* 2 pi))))
+ (cond ((<= nxx pi2) (polynomial coeffs nxx))
+ ((<= nxx pi) (- (polynomial coeffs (- pi nxx))))
+ ((< nxx (* 1.5 pi)) (- (polynomial coeffs (- nxx pi))))
+ (else (polynomial coeffs (- (* 2 pi) nxx))))))))))
(do ((i 0 (+ i 1))
(x -10.0 (+ x .01)))
((= i 2000))
- (let ((diff (abs (- (cos x) (new-cos x)))))
- (if (> diff err)
- (set! err diff))))
- (if (> err 1.1e-7) (snd-display #__line__ ";new-cos poly err: ~A" err))))
+ (set! err (max err (abs (- (cos x) (new-cos x))))))
+ (if (> err 1.1e-7) (snd-display ";new-cos poly err: ~A" err))))
(let ((val (poly+ (float-vector .1 .2 .3) (float-vector 0.0 1.0 2.0 3.0 4.0))))
- (if (not (vequal val (float-vector 0.100 1.200 2.300 3.000 4.000))) (snd-display #__line__ ";poly+ 1: ~A" val)))
+ (if (not (vequal val (float-vector 0.100 1.200 2.300 3.000 4.000))) (snd-display ";poly+ 1: ~A" val)))
(let ((val (poly+ (float-vector .1 .2 .3) .5)))
- (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display #__line__ ";poly+ 2: ~A" val)))
+ (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 2: ~A" val)))
(let ((val (poly+ .5 (float-vector .1 .2 .3))))
- (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display #__line__ ";poly+ 3: ~A" val)))
+ (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 3: ~A" val)))
(let ((val (poly* (float-vector 1 1) (float-vector -1 1))))
- (if (not (vequal val (float-vector -1.000 0.000 1.000 0.000))) (snd-display #__line__ ";poly* 1: ~A" val)))
+ (if (not (vequal val (float-vector -1.000 0.000 1.000 0.000))) (snd-display ";poly* 1: ~A" val)))
(let ((val (poly* (float-vector -5 1) (float-vector 3 7 2))))
- (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display #__line__ ";poly* 2: ~A" val)))
+ (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 2: ~A" val)))
(let ((val (poly* (float-vector -30 -4 2) (float-vector 0.5 1))))
- (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display #__line__ ";poly* 3: ~A" val)))
+ (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 3: ~A" val)))
(let ((val (poly* (float-vector -30 -4 2) 0.5)))
- (if (not (vequal val (float-vector -15.000 -2.000 1.000))) (snd-display #__line__ ";poly* 4: ~A" val)))
+ (if (not (vequal val (float-vector -15.000 -2.000 1.000))) (snd-display ";poly* 4: ~A" val)))
(let ((val (poly* 2.0 (float-vector -30 -4 2))))
- (if (not (vequal val (float-vector -60.000 -8.000 4.000))) (snd-display #__line__ ";poly* 5: ~A" val)))
+ (if (not (vequal val (float-vector -60.000 -8.000 4.000))) (snd-display ";poly* 5: ~A" val)))
(let ((val (poly/ (float-vector -1.0 -0.0 1.0) (float-vector 1.0 1.0))))
- (if (or (not (vequal (car val) (float-vector -1.000 1.000 0.000)))
- (not (vequal (cadr val) (float-vector 0.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 1: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -1.000 1.000 0.000))
+ (vequal (cadr val) (float-vector 0.000 0.000 0.000))))
+ (snd-display ";poly/ 1: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector -5 1))))
- (if (or (not (vequal (car val) (float-vector 3.000 7.000 2.000 0.000)))
- (not (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 2: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector 3.000 7.000 2.000 0.000))
+ (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (snd-display ";poly/ 2: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector 3 1))))
- (if (or (not (vequal (car val) (float-vector -5.000 -9.000 2.000 0.000)))
- (not (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 3: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -5.000 -9.000 2.000 0.000))
+ (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (snd-display ";poly/ 3: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector .5 1))))
- (if (or (not (vequal (car val) (float-vector -30.000 -4.000 2.000 0.000)))
- (not (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 4: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -30.000 -4.000 2.000 0.000))
+ (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (snd-display ";poly/ 4: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector 3 7 2))))
- (if (or (not (vequal (car val) (float-vector -5.000 1.000 0.000 0.000)))
- (not (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 5: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -5.000 1.000 0.000 0.000))
+ (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (snd-display ";poly/ 5: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) 2.0)))
(if (not (vequal (car val) (float-vector -7.500 -16.000 -1.500 1.000)))
- (snd-display #__line__ ";poly/ 6: ~A" val)))
+ (snd-display ";poly/ 6: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 0.0 0.0 1.0) (float-vector 1.0 0.0 1.0))))
- (if (or (not (vequal (car val) (float-vector -1.0 0.0 1.0 0.0 0.0)))
- (not (vequal (cadr val) (make-float-vector 5))))
- (snd-display #__line__ ";poly/ 7: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -1.0 0.0 1.0 0.0 0.0))
+ (vequal (cadr val) (make-float-vector 5))))
+ (snd-display ";poly/ 7: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0) (float-vector 1.0 0.0 0.0 0.0 1.0))))
- (if (or (not (vequal (car val) (float-vector -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0)))
- (not (vequal (cadr val) (make-float-vector 9))))
- (snd-display #__line__ ";poly/ 8: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0))
+ (vequal (cadr val) (make-float-vector 9))))
+ (snd-display ";poly/ 8: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 1.0) (float-vector -1.0 0.0 1.0))))
- (if (or (not (vequal (car val) (float-vector 1.0 0.0 0.0)))
- (not (vequal (cadr val) (make-float-vector 3))))
- (snd-display #__line__ ";poly/ 9: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector 1.0 0.0 0.0))
+ (vequal (cadr val) (make-float-vector 3))))
+ (snd-display ";poly/ 9: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 1.0) (float-vector 2.0 1.0))))
- (if (or (not (vequal (car val) (float-vector -2.000 1.000 0.000)))
- (not (vequal (cadr val) (float-vector 3.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 10: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector -2.000 1.000 0.000))
+ (vequal (cadr val) (float-vector 3.000 0.000 0.000))))
+ (snd-display ";poly/ 10: ~A" val)))
(let ((val (poly/ (float-vector 2 1) (float-vector -1.0 0.0 1.0))))
- (if (or (not (vequal (car val) (float-vector 0.0)))
- (not (vequal (cadr val) (float-vector -1.000 0.000 1.000))))
- (snd-display #__line__ ";poly/ 11: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector 0.0))
+ (vequal (cadr val) (float-vector -1.000 0.000 1.000))))
+ (snd-display ";poly/ 11: ~A" val)))
(let ((val (poly/ (float-vector 1 2 3 0 1) (float-vector 0 0 0 1))))
- (if (or (not (vequal (car val) (float-vector 0.000 1.000 0.000 0.000 0.000)))
- (not (vequal (cadr val) (float-vector 1.000 2.000 3.000 0.000 0.000))))
- (snd-display #__line__ ";poly/ 12: ~A" val)))
+ (if (not (and (vequal (car val) (float-vector 0.000 1.000 0.000 0.000 0.000))
+ (vequal (cadr val) (float-vector 1.000 2.000 3.000 0.000 0.000))))
+ (snd-display ";poly/ 12: ~A" val)))
(let ((ind (open-sound "1a.snd")))
(let ((v1 (channel->float-vector 0 100 ind 0))
@@ -12615,162 +12179,160 @@ EDITS: 2
(res (make-float-vector 100)))
(set! (res 0) 1.0)
(if (not (vequal vals res))
- (snd-display #__line__ ";poly1 1a: ~A" vals))))
+ (snd-display ";poly1 1a: ~A" vals))))
(close-sound ind))
(let ((val (poly-derivative (float-vector 0.5 1.0 2.0 4.0))))
- (if (not (vequal val (float-vector 1.000 4.000 12.000))) (snd-display #__line__ ";poly-derivative: ~A" val)))
+ (if (not (vequal val (float-vector 1.000 4.000 12.000))) (snd-display ";poly-derivative: ~A" val)))
(let ((val (poly-reduce (float-vector 1 2 3))))
- (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display #__line__ ";poly-reduce 1: ~A" val)))
+ (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 1: ~A" val)))
(let ((val (poly-reduce (float-vector 1 2 3 0 0 0))))
- (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display #__line__ ";poly-reduce 2: ~A" val)))
+ (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 2: ~A" val)))
(let ((val (poly-reduce (float-vector 0 0 0 0 1 0))))
- (if (not (vequal val (float-vector 0.000 0.000 0.000 0.000 1.000))) (snd-display #__line__ ";poly-reduce 3: ~A" val)))
+ (if (not (vequal val (float-vector 0.000 0.000 0.000 0.000 1.000))) (snd-display ";poly-reduce 3: ~A" val)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector 2 1))))
- (if (not (vequal vals (float-vector 2.000 1.000))) (snd-display #__line__ ";poly-gcd 1: ~A" vals)))
+ (if (not (vequal vals (float-vector 2.000 1.000))) (snd-display ";poly-gcd 1: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector 3 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display #__line__ ";poly-gcd 2: ~A" vals)))
+ (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 2: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector -3 1))))
- (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display #__line__ ";poly-gcd 2: ~A" vals)))
+ (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 2: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 8 1) (poly* (float-vector 2 1) (float-vector -3 1)))) (float-vector -3 1))))
- (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display #__line__ ";poly-gcd 3: ~A" vals)))
+ (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 3: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 8 1) (poly* (float-vector 2 1) (float-vector -3 1)))) (poly-reduce (poly* (float-vector 8 1) (float-vector -3 1))))))
- (if (not (vequal vals (float-vector -24.000 5.000 1.000))) (snd-display #__line__ ";poly-gcd 4: ~A" vals)))
+ (if (not (vequal vals (float-vector -24.000 5.000 1.000))) (snd-display ";poly-gcd 4: ~A" vals)))
(let ((vals (poly-gcd (float-vector -1 0 1) (float-vector 2 -2 -1 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display #__line__ ";poly-gcd 5: ~A" vals)))
+ (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 5: ~A" vals)))
(let ((vals (poly-gcd (float-vector 2 -2 -1 1) (float-vector -1 0 1))))
- (if (not (vequal vals (float-vector 1.000 -1.000))) (snd-display #__line__ ";poly-gcd 6: ~A" vals)))
+ (if (not (vequal vals (float-vector 1.000 -1.000))) (snd-display ";poly-gcd 6: ~A" vals)))
(let ((vals (poly-gcd (float-vector 2 -2 -1 1) (float-vector -2.5 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display #__line__ ";poly-gcd 7: ~A" vals)))
+ (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 7: ~A" vals)))
(poly-roots-tests)
(let ((val (poly-as-vector-resultant (vector -1 0 1) (vector 1 -2 1))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-resultant 0: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-resultant 0: ~A" val)))
(let ((val (poly-as-vector-resultant (vector -1 0 2) (vector 1 -2 1))))
- (if (fneq val 1.0) (snd-display #__line__ ";poly-resultant 1: ~A" val)))
+ (if (fneq val 1.0) (snd-display ";poly-resultant 1: ~A" val)))
(let ((val (poly-as-vector-resultant (vector -1 0 1) (vector 1 1))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-resultant 2: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-resultant 2: ~A" val)))
(let ((val (poly-as-vector-resultant (vector -1 0 1) (vector 2 1))))
- (if (fneq val 3.0) (snd-display #__line__ ";poly-resultant 3: ~A" val)))
+ (if (fneq val 3.0) (snd-display ";poly-resultant 3: ~A" val)))
(let ((val (poly-resultant (float-vector -1 0 1) (float-vector 1 -2 1))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-resultant 0: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-resultant 0: ~A" val)))
(let ((val (poly-as-vector-discriminant (vector -1 0 1))))
- (if (fneq val -4.0) (snd-display #__line__ ";poly-discriminant 0: ~A" val)))
+ (if (fneq val -4.0) (snd-display ";poly-discriminant 0: ~A" val)))
(let ((val (poly-as-vector-discriminant (vector 1 -2 1))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-discriminant 1: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-discriminant 1: ~A" val)))
(let ((val (poly-discriminant (poly-reduce (poly* (poly* (float-vector -1 1) (float-vector -1 1)) (float-vector 3 1))))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-discriminant 2: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-discriminant 2: ~A" val)))
(let ((val (poly-discriminant (poly-reduce (poly* (poly* (poly* (float-vector -1 1) (float-vector -1 1)) (float-vector 3 1)) (float-vector 2 1))))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-discriminant 3: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-discriminant 3: ~A" val)))
(let ((val (poly-discriminant (poly-reduce (poly* (poly* (poly* (float-vector 1 1) (float-vector -1 1)) (float-vector 3 1)) (float-vector 2 1))))))
- (if (fneq val 2304.0) (snd-display #__line__ ";poly-discriminant 4: ~A" val)))
+ (if (fneq val 2304.0) (snd-display ";poly-discriminant 4: ~A" val)))
(let ((val (poly-discriminant (poly-reduce (poly* (poly* (poly* (float-vector 1 1) (float-vector -1 1)) (float-vector 3 1)) (float-vector 3 1))))))
- (if (fneq val 0.0) (snd-display #__line__ ";poly-discriminant 5: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";poly-discriminant 5: ~A" val)))
(let ((v0 (make-float-vector 10)))
(do ((i 0 (+ i 1))) ((= i 10))
(set! (v0 i) i))
- (if (fneq (array-interp v0 3.5) 3.5) (snd-display #__line__ ";array-interp: ~F?" (array-interp v0 3.5)))
- (if (fneq (array-interp v0 13.5) 3.5) (snd-display #__line__ ";array-interp(13.5): ~F?" (array-interp v0 13.5)))
- (if (fneq (array-interp v0 -6.5) 3.5) (snd-display #__line__ ";array-interp(-6.5): ~F?" (array-interp v0 -6.5)))
- (if (fneq (array-interp v0 103.6) 3.6) (snd-display #__line__ ";array-interp(103.5): ~F?" (array-interp v0 103.6)))
- (if (fneq (array-interp v0 -106.6) 3.4) (snd-display #__line__ ";array-interp(-106.6): ~F?" (array-interp v0 -106.6)))
- (if (fneq (array-interp v0 -0.5) 4.5) (snd-display #__line__ ";array-interp(-0.5): ~F?" (array-interp v0 -0.5)))
+ (if (fneq (array-interp v0 3.5) 3.5) (snd-display ";array-interp: ~F?" (array-interp v0 3.5)))
+ (if (fneq (array-interp v0 13.5) 3.5) (snd-display ";array-interp(13.5): ~F?" (array-interp v0 13.5)))
+ (if (fneq (array-interp v0 -6.5) 3.5) (snd-display ";array-interp(-6.5): ~F?" (array-interp v0 -6.5)))
+ (if (fneq (array-interp v0 103.6) 3.6) (snd-display ";array-interp(103.5): ~F?" (array-interp v0 103.6)))
+ (if (fneq (array-interp v0 -106.6) 3.4) (snd-display ";array-interp(-106.6): ~F?" (array-interp v0 -106.6)))
+ (if (fneq (array-interp v0 -0.5) 4.5) (snd-display ";array-interp(-0.5): ~F?" (array-interp v0 -0.5)))
;; interpolating between 9 and 0 here (confusing...)
- (if (fneq (array-interp v0 -0.9) 8.1) (snd-display #__line__ ";array-interp(-0.9): ~F?" (array-interp v0 -0.9)))
- (if (fneq (array-interp v0 -0.1) 0.9) (snd-display #__line__ ";array-interp(-0.1): ~F?" (array-interp v0 -0.1)))
- (if (fneq (array-interp v0 9.1) 8.1) (snd-display #__line__ ";array-interp(9.1): ~F?" (array-interp v0 9.1)))
- (if (fneq (array-interp v0 9.9) 0.9) (snd-display #__line__ ";array-interp(9.9): ~F?" (array-interp v0 9.9)))
- (if (fneq (array-interp v0 10.1) 0.1) (snd-display #__line__ ";array-interp(10.1): ~F?" (array-interp v0 10.1)))
+ (if (fneq (array-interp v0 -0.9) 8.1) (snd-display ";array-interp(-0.9): ~F?" (array-interp v0 -0.9)))
+ (if (fneq (array-interp v0 -0.1) 0.9) (snd-display ";array-interp(-0.1): ~F?" (array-interp v0 -0.1)))
+ (if (fneq (array-interp v0 9.1) 8.1) (snd-display ";array-interp(9.1): ~F?" (array-interp v0 9.1)))
+ (if (fneq (array-interp v0 9.9) 0.9) (snd-display ";array-interp(9.9): ~F?" (array-interp v0 9.9)))
+ (if (fneq (array-interp v0 10.1) 0.1) (snd-display ";array-interp(10.1): ~F?" (array-interp v0 10.1)))
(let ((var (catch #t (lambda () (array-interp v0 1 -10)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";array-interp bad index: ~A" var))))
+ (snd-display ";array-interp bad index: ~A" var))))
(let ((ind (open-sound "oboe.snd")))
(let ((diff (array-interp-sound-diff ind 0)))
- (if (> diff .00001) (snd-display #__line__ ";array-interp-sound-diff: ~A" diff)))
+ (if (> diff .00001) (snd-display ";array-interp-sound-diff: ~A" diff)))
(close-sound ind))
(let ((v0 (make-float-vector 10)))
(do ((i 0 (+ i 1))) ((= i 10))
(set! (v0 i) i))
(let ((val (mus-interpolate mus-interp-linear 1.5 v0)))
- (if (fneq val 1.5) (snd-display #__line__ ";mus-interpolate linear: ~A" val))
+ (if (fneq val 1.5) (snd-display ";mus-interpolate linear: ~A" val))
(set! val (mus-interpolate mus-interp-all-pass 1.5 v0))
- (if (fneq val 1.5) (snd-display #__line__ ";mus-interpolate all-pass: ~A" val))
+ (if (fneq val 1.5) (snd-display ";mus-interpolate all-pass: ~A" val))
(set! val (mus-interpolate mus-interp-none 1.5 v0))
- (if (fneq val 1.0) (snd-display #__line__ ";mus-interpolate none: ~A" val))
+ (if (fneq val 1.0) (snd-display ";mus-interpolate none: ~A" val))
(set! val (mus-interpolate mus-interp-hermite 1.5 v0))
- (if (fneq val 1.5) (snd-display #__line__ ";mus-interpolate hermite: ~A" val))
+ (if (fneq val 1.5) (snd-display ";mus-interpolate hermite: ~A" val))
(set! val (mus-interpolate mus-interp-bezier 1.5 v0))
- (if (fneq val 1.5) (snd-display #__line__ ";mus-interpolate bezier: ~A" val))
+ (if (fneq val 1.5) (snd-display ";mus-interpolate bezier: ~A" val))
(set! val (mus-interpolate mus-interp-lagrange 1.5 v0))
- (if (fneq val 1.5) (snd-display #__line__ ";mus-interpolate lagrange: ~A" val))
+ (if (fneq val 1.5) (snd-display ";mus-interpolate lagrange: ~A" val))
(do ((i 0 (+ i 1))) ((= i 10)) (set! (v0 i) (sin (* pi (/ i 5)))))
(set! val (mus-interpolate mus-interp-linear 1.5 v0))
- (if (fneq val 0.7694) (snd-display #__line__ ";mus-interpolate linear sin: ~A" val))
+ (if (fneq val 0.7694) (snd-display ";mus-interpolate linear sin: ~A" val))
(set! val (mus-interpolate mus-interp-all-pass 1.5 v0))
- (if (fneq val 0.7694) (snd-display #__line__ ";mus-interpolate all-pass sin: ~A" val))
+ (if (fneq val 0.7694) (snd-display ";mus-interpolate all-pass sin: ~A" val))
(set! val (mus-interpolate mus-interp-none 1.5 v0))
- (if (fneq val 0.5877) (snd-display #__line__ ";mus-interpolate none sin: ~A" val))
+ (if (fneq val 0.5877) (snd-display ";mus-interpolate none sin: ~A" val))
(set! val (mus-interpolate mus-interp-hermite 1.5 v0))
- (if (fneq val 0.8061) (snd-display #__line__ ";mus-interpolate hermite sin: ~A" val))
+ (if (fneq val 0.8061) (snd-display ";mus-interpolate hermite sin: ~A" val))
(set! val (mus-interpolate mus-interp-bezier 1.5 v0))
- (if (fneq val 0.6959) (snd-display #__line__ ";mus-interpolate bezier sin: ~A" val))
+ (if (fneq val 0.6959) (snd-display ";mus-interpolate bezier sin: ~A" val))
(set! val (mus-interpolate mus-interp-lagrange 1.5 v0))
- (if (fneq val 0.7975) (snd-display #__line__ ";mus-interpolate lagrange sin: ~A" val))))
+ (if (fneq val 0.7975) (snd-display ";mus-interpolate lagrange sin: ~A" val))))
(let ((tag (catch #t (lambda () (mus-interpolate 1234 1.0 (make-float-vector 3))) (lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";mus-interpolate 1234: ~A" tag)))
+ (snd-display ";mus-interpolate 1234: ~A" tag)))
(let ((tag (catch #t (lambda () (mus-interpolate mus-interp-linear 1.0 (make-float-vector 3) -1)) (lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";mus-interpolate size -1: ~A" tag)))
+ (snd-display ";mus-interpolate size -1: ~A" tag)))
- (let ((gen (make-delay 3))
- (gen2 (make-delay 3))
- (gen1 (make-delay 4 :initial-contents '(1.0 0.5 0.25 0.0)))
- (gen3 (make-delay 4 :initial-contents (float-vector 1.0 0.5 0.25 0.0)))
- (v0 (make-float-vector 10))
- (v1 (make-float-vector 10)))
- (print-and-check gen
- "delay"
- "delay line[3, step]: [0 0 0]")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (delay gen i)))
- (let ((k 0)) (fill-float-vector v1 (let ((val (if (delay? gen2) (delay gen2 k) -1.0))) (set! k (+ k 1)) val)))
- (if (not (vequal v1 v0)) (snd-display #__line__ ";map delay: ~A ~A" v0 v1))
- (if (not (delay? gen)) (snd-display #__line__ ";~A not delay?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";delay length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.0) (fneq (v0 4) 1.0) (fneq (v0 8) 5.0))
- (snd-display #__line__ ";delay output: ~A" v0))
+ (let ((gen1 (make-delay 4 :initial-contents '(1.0 0.5 0.25 0.0)))
+ (gen3 (make-delay 4 :initial-contents (float-vector 1.0 0.5 0.25 0.0))))
+ (let ((gen (make-delay 3)))
+ (print-and-check gen
+ "delay"
+ "delay line[3, step]: [0 0 0]")
+ (let ((v0 (make-float-vector 10))
+ (v1 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (delay gen i)))
+ (let ((gen2 (make-delay 3)))
+ (let ((k 0)) (fill-float-vector v1 (let ((val (if (delay? gen2) (delay gen2 k) -1.0))) (set! k (+ k 1)) val))))
+ (if (not (vequal v1 v0)) (snd-display ";map delay: ~A ~A" v0 v1))
+ (if (not (delay? gen)) (snd-display ";~A not delay?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";delay length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.0) (fneq (v0 4) 1.0) (fneq (v0 8) 5.0))
+ (snd-display ";delay output: ~A" v0))))
(if (or (fneq (delay gen1) 1.0)
(fneq (delay gen1) 0.5)
(fneq (delay gen1) 0.25)
- (fneq (delay gen1) 0.0)
(fneq (delay gen1) 0.0))
- (snd-display #__line__ ";delay with list initial-contents confused"))
+ (snd-display ";delay with list initial-contents confused"))
(if (or (fneq (delay gen3) 1.0)
(fneq (delay gen3) 0.5)
(fneq (delay gen3) 0.25)
- (fneq (delay gen3) 0.0)
(fneq (delay gen3) 0.0))
- (snd-display #__line__ ";delay with float-vector initial-contents confused"))
- (let ((var (catch #t (lambda () (make-delay :size #f)) (lambda args args))))
- (if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-delay bad size #f: ~A" var)))
- (let ((var (catch #t (lambda () (make-delay 3 :initial-element (make-oscil))) (lambda args args))))
- (if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-delay bad initial element: ~A" var)))
- (let ((var (catch #t (lambda () (make-delay -3)) (lambda args args))))
- (if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-delay bad size: ~A" var))))
+ (snd-display ";delay with float-vector initial-contents confused")))
+ (let ((var (catch #t (lambda () (make-delay :size #f)) (lambda args args))))
+ (if (not (eq? (car var) 'wrong-type-arg))
+ (snd-display ";make-delay bad size #f: ~A" var)))
+ (let ((var (catch #t (lambda () (make-delay 3 :initial-element (make-oscil))) (lambda args args))))
+ (if (not (eq? (car var) 'wrong-type-arg))
+ (snd-display ";make-delay bad initial element: ~A" var)))
+ (let ((var (catch #t (lambda () (make-delay -3)) (lambda args args))))
+ (if (not (eq? (car var) 'out-of-range))
+ (snd-display ";make-delay bad size: ~A" var)))
(test-gen-equal (let ((d1 (make-delay 3))) (delay d1 1.0) d1)
(let ((d2 (make-delay 3))) (delay d2 1.0) d2)
@@ -12787,18 +12349,18 @@ EDITS: 2
(let ((data (copy (mus-data gen))))
(float-vector-set! (mus-data gen) 0 0.3)
(if (fneq ((mus-data gen) 0) 0.3)
- (snd-display #__line__ ";delay data 0: ~A" ((mus-data gen) 0)))
+ (snd-display ";delay data 0: ~A" ((mus-data gen) 0)))
(set! (data 0) .75)
- (set! (mus-data gen) data)
- (if (fneq ((mus-data gen) 0) 0.75)
- (snd-display #__line__ ";delay set data 0: ~A" ((mus-data gen) 0)))
- (delay gen 0.0)
- (delay gen 0.0)
- (let ((val (delay gen 0.0)))
- (if (fneq val 0.75)
- (snd-display #__line__ ";set delay data: ~A ~A" val (mus-data gen)))))
+ (set! (mus-data gen) data))
+ (if (fneq ((mus-data gen) 0) 0.75)
+ (snd-display ";delay set data 0: ~A" ((mus-data gen) 0)))
+ (delay gen 0.0)
+ (delay gen 0.0)
+ (let ((val (delay gen 0.0)))
+ (if (fneq val 0.75)
+ (snd-display ";set delay data: ~A ~A" val (mus-data gen))))
(if (mus-data (make-oscil))
- (snd-display #__line__ ";mus-data osc: ~A" (mus-data (make-oscil)))))
+ (snd-display ";mus-data osc: ~A" (mus-data (make-oscil)))))
(let ((del (make-delay 5 :max-size 8)))
(delay del 1.0)
@@ -12808,17 +12370,17 @@ EDITS: 2
((= i 5))
(set! (v0 i) (delay del 0.0 0.4)))
(if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000)))
- (snd-display #__line__ ";zdelay: ~A" v0))
- (delay del 1.0)
- (delay del 0.0 0.4)
- (if (not (string=? (mus-describe del) "delay line[5,8, linear]: [0 0 1 0 0]"))
- (snd-display #__line__ ";describe zdelay: ~A" (mus-describe del)))))
+ (snd-display ";zdelay: ~A" v0)))
+ (delay del 1.0)
+ (delay del 0.0 0.4)
+ (if (not (string=? (mus-describe del) "delay line[5,8, linear]: [0 0 1 0 0]"))
+ (snd-display ";describe zdelay: ~A" (mus-describe del))))
(let ((tag (catch #t (lambda ()
(let ((gen (make-oscil)))
(tap gen)))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";tap of oscil: ~A" tag)))
+ (snd-display ";tap of oscil: ~A" tag)))
(let ((dly (make-delay 3))
(flt (make-one-zero .5 .4))
@@ -12828,7 +12390,7 @@ EDITS: 2
(set! inval 0.0)
res))
(if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
- (snd-display #__line__ ";tap with low pass: ~A" v)))
+ (snd-display ";tap with low pass: ~A" v)))
(let ((dly (make-delay 3))
(v (make-float-vector 20))
@@ -12837,18 +12399,18 @@ EDITS: 2
(set! inval 0.0)
res))
(if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0)))
- (snd-display #__line__ ";simple tap: ~A" v)))
+ (snd-display ";simple tap: ~A" v)))
(let ((dly (make-delay 6))
(v (make-float-vector 20))
(inval 1.0))
- (if (not (tap? dly)) (snd-display #__line__ ";tap?: ~A" (tap? dly)))
+ (if (not (tap? dly)) (snd-display ";tap?: ~A" (tap? dly)))
(fill-float-vector v (let ((res (delay dly (+ inval (tap dly -2.0)))))
(set! inval 0.0)
res))
(set! *print-length* (max 20 *print-length*))
(if (not (vequal v (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0)))
- (snd-display #__line__ ";tap back 2: ~A" v)))
+ (snd-display ";tap back 2: ~A" v)))
(let ((dly (make-delay 3))
(flt (make-one-zero .5 .4))
@@ -12860,31 +12422,29 @@ EDITS: 2
(set! inval 0.0)
res)))
(if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
- (snd-display #__line__ ";tap with low pass: ~A" v)))
+ (snd-display ";tap with low pass: ~A" v)))
(let ((dly (make-delay 3 :initial-element 32.0)))
- (if (not (float-vector? (mus-data dly)))
- (snd-display #__line__ ";delay data not float-vector?")
- (if (not (= (length (mus-data dly)) 3))
- (snd-display #__line__ ";delay data len not 3: ~A (~A)" (length (mus-data dly)) (mus-data dly))
- (if (fneq ((mus-data dly) 1) 32.0) (snd-display #__line__ ";delay [1] 32: ~A" ((mus-data dly) 1)))))
+ (cond ((not (float-vector? (mus-data dly))) (snd-display ";delay data not float-vector?"))
+ ((not (= (length (mus-data dly)) 3)) (snd-display ";delay data len not 3: ~A (~A)" (length (mus-data dly)) (mus-data dly)))
+ ((fneq ((mus-data dly) 1) 32.0) (snd-display ";delay [1] 32: ~A" ((mus-data dly) 1))))
(let ((tag (catch #t (lambda () (set! (mus-length dly) -1)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";len to -1 -> ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";len to -1 -> ~A" tag)))
(let ((tag (catch #t (lambda () (set! (mus-length dly) 0)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";len to 0 -> ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";len to 0 -> ~A" tag)))
(let ((tag (catch #t (lambda () (set! (mus-length dly) 100)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";len to 100 -> ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";len to 100 -> ~A" tag)))
(let ((tag (catch #t (lambda () (set! ((mus-data dly) 100) .1)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";data 100 to .1 -> ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";data 100 to .1 -> ~A" tag)))
(let ((data (make-float-vector 32 1.0)))
- (set! (mus-data dly) data)
- (if (not (float-vector? (mus-data dly))) (snd-display #__line__ ";set delay data not float-vector?"))
- (if (fneq ((mus-data dly) 1) 1.0) (snd-display #__line__ ";set delay [1] 1: ~A" ((mus-data dly) 1)))
- (if (not (= (length (mus-data dly)) 32)) (snd-display #__line__ ";set delay data len(32): ~A" (length (mus-data dly))))
- (let ((tag (catch #t (lambda () (set! (mus-length dly) 100)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";set len to 100 -> ~A" tag)))
- (let ((tag (catch #t (lambda () (set! ((mus-data dly) 100) .1)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";set data 100 to .1 -> ~A" tag)))))
+ (set! (mus-data dly) data))
+ (if (not (float-vector? (mus-data dly))) (snd-display ";set delay data not float-vector?"))
+ (if (fneq ((mus-data dly) 1) 1.0) (snd-display ";set delay [1] 1: ~A" ((mus-data dly) 1)))
+ (if (not (= (length (mus-data dly)) 32)) (snd-display ";set delay data len(32): ~A" (length (mus-data dly))))
+ (let ((tag (catch #t (lambda () (set! (mus-length dly) 100)) (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";set len to 100 -> ~A" tag)))
+ (let ((tag (catch #t (lambda () (set! ((mus-data dly) 100) .1)) (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";set data 100 to .1 -> ~A" tag))))
(let ((d1 (make-delay 4))
(d2 (make-delay 4 :max-size 5 :type mus-interp-linear))
@@ -12900,13 +12460,13 @@ EDITS: 2
(v5 (make-float-vector 20))
(v6 (make-float-vector 20))
(v7 (make-float-vector 20)))
- (if (not (= (mus-interp-type d1) mus-interp-none)) (snd-display #__line__ ";d1 interp type: ~A" (mus-interp-type d1)))
- (if (not (= (mus-interp-type d2) mus-interp-linear)) (snd-display #__line__ ";d2 interp type: ~A" (mus-interp-type d2)))
- (if (not (= (mus-interp-type d3) mus-interp-all-pass)) (snd-display #__line__ ";d3 interp type: ~A" (mus-interp-type d3)))
- (if (not (= (mus-interp-type d4) mus-interp-none)) (snd-display #__line__ ";d4 interp type: ~A" (mus-interp-type d4)))
- (if (not (= (mus-interp-type d5) mus-interp-lagrange)) (snd-display #__line__ ";d5 interp type: ~A" (mus-interp-type d5)))
- (if (not (= (mus-interp-type d6) mus-interp-hermite)) (snd-display #__line__ ";d6 interp type: ~A" (mus-interp-type d6)))
- (if (not (= (mus-interp-type d7) mus-interp-linear)) (snd-display #__line__ ";d7 interp type: ~A" (mus-interp-type d7)))
+ (if (not (= (mus-interp-type d1) mus-interp-none)) (snd-display ";d1 interp type: ~A" (mus-interp-type d1)))
+ (if (not (= (mus-interp-type d2) mus-interp-linear)) (snd-display ";d2 interp type: ~A" (mus-interp-type d2)))
+ (if (not (= (mus-interp-type d3) mus-interp-all-pass)) (snd-display ";d3 interp type: ~A" (mus-interp-type d3)))
+ (if (not (= (mus-interp-type d4) mus-interp-none)) (snd-display ";d4 interp type: ~A" (mus-interp-type d4)))
+ (if (not (= (mus-interp-type d5) mus-interp-lagrange)) (snd-display ";d5 interp type: ~A" (mus-interp-type d5)))
+ (if (not (= (mus-interp-type d6) mus-interp-hermite)) (snd-display ";d6 interp type: ~A" (mus-interp-type d6)))
+ (if (not (= (mus-interp-type d7) mus-interp-linear)) (snd-display ";d7 interp type: ~A" (mus-interp-type d7)))
(set! (v1 0) (delay d1 1.0))
(set! (v2 0) (delay d2 1.0))
(set! (v3 0) (delay d3 1.0))
@@ -12914,13 +12474,7 @@ EDITS: 2
(set! (v5 0) (delay d5 1.0))
(set! (v6 0) (delay d6 1.0))
(set! (v7 0) (delay d7 1.0))
- (delay-tick d1 0.0)
- (delay-tick d2 0.0)
- (delay-tick d3 0.0)
- (delay-tick d4 0.0)
- (delay-tick d5 0.0)
- (delay-tick d6 0.0)
- (delay-tick d7 0.0)
+ (for-each (lambda (arg) (delay-tick arg 0.0)) (vector d1 d2 d3 d4 d5 d6 d7))
(do ((i 1 (+ i 1))
(j -0.2 (- j 0.2)))
((= i 20))
@@ -12932,22 +12486,22 @@ EDITS: 2
(set! (v6 i) (tap d6 j))
(set! (v7 i) (tap d7 j)))
(set! *print-length* (max 20 *print-length*))
- (if (and (not (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0)))
- (not (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
- (snd-display #__line__ ";delay interp none (1): ~A" v1))
+ (if (not (or (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
+ (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
+ (snd-display ";delay interp none (1): ~A" v1))
(if (not (vequal v2 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";delay interp linear (2): ~A" v2))
+ (snd-display ";delay interp linear (2): ~A" v2))
(if (not (vequal v3 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.600 0.160 0.168 -0.168 0.334 0.199 0.520 0.696 -0.696 0.557 -0.334 0.134 -0.027)))
- (snd-display #__line__ ";delay interp all-pass (3): ~A" v3))
- (if (and (not (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0)))
- (not (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
- (snd-display #__line__ ";delay interp none (4): ~A" v4))
+ (snd-display ";delay interp all-pass (3): ~A" v3))
+ (if (not (or (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
+ (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
+ (snd-display ";delay interp none (4): ~A" v4))
(if (not (vequal v5 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.120 0.280 0.480 0.720 1.000 0.960 0.840 0.640 0.360 0.000 -0.080 -0.120 -0.120 -0.080)))
- (snd-display #__line__ ";delay interp lagrange (5): ~A" v5))
+ (snd-display ";delay interp lagrange (5): ~A" v5))
(if (not (vequal v6 (float-vector 0.0 -0.016 -0.048 -0.072 -0.064 0.0 0.168 0.424 0.696 0.912 1.0 0.912 0.696 0.424 0.168 0.0 -0.064 -0.072 -0.048 -0.016)))
- (snd-display #__line__ ";delay interp hermite (6): ~A" v6))
+ (snd-display ";delay interp hermite (6): ~A" v6))
(if (not (vequal v7 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";delay interp linear (7): ~A" v7)))
+ (snd-display ";delay interp linear (7): ~A" v7)))
(let ((dly1 (make-delay :size 2 :max-size 3))
(data (make-float-vector 5))
@@ -12957,7 +12511,7 @@ EDITS: 2
(set! (data i) (delay dly1 impulse 0.4)) ; longer line
(set! impulse 0.0))
(if (not (vequal data (float-vector 0.0 0.0 0.6 0.4 0.0)))
- (snd-display #__line__ ";delay size 2, max 3, off 0.4: ~A" data))
+ (snd-display ";delay size 2, max 3, off 0.4: ~A" data))
(set! dly1 (make-delay :size 2 :max-size 3))
(set! impulse 1.0)
@@ -12966,7 +12520,7 @@ EDITS: 2
(set! (data i) (delay dly1 impulse -0.4)) ; shorter line
(set! impulse 0.0))
(if (not (vequal data (float-vector 0.0 0.4 0.6 0.0 0.0)))
- (snd-display #__line__ ";delay size 2, max 3, off -0.4: ~A" data))
+ (snd-display ";delay size 2, max 3, off -0.4: ~A" data))
(set! dly1 (make-delay :size 1 :max-size 2))
(set! impulse 1.0)
@@ -12975,7 +12529,7 @@ EDITS: 2
(set! (data i) (delay dly1 impulse 0.4))
(set! impulse 0.0))
(if (not (vequal data (float-vector 0.0 0.6 0.4 0.0 0.0)))
- (snd-display #__line__ ";delay size 1, max 2, off 0.4: ~A" data))
+ (snd-display ";delay size 1, max 2, off 0.4: ~A" data))
(set! dly1 (make-delay :size 0 :max-size 1))
(set! impulse 1.0)
@@ -12984,11 +12538,11 @@ EDITS: 2
(set! (data i) (delay dly1 impulse 0.4))
(set! impulse 0.0))
(if (not (vequal data (float-vector 0.6 0.4 0.0 0.0 0.0)))
- (snd-display #__line__ ";delay size 0, max 1, off 0.4: ~A" data))
+ (snd-display ";delay size 0, max 1, off 0.4: ~A" data))
(set! dly1 (make-delay :size 0 :max-size 1))
(let ((val (delay dly1 0.0)))
- (if (fneq val 0.0) (snd-display #__line__ ";initial delay 0 size val: ~A" val)))
+ (if (fneq val 0.0) (snd-display ";initial delay 0 size val: ~A" val)))
(set! dly1 (make-delay :size 0 :max-size 1))
(set! impulse 1.0)
@@ -12997,7 +12551,7 @@ EDITS: 2
(set! (data i) (delay dly1 impulse -0.4)) ; shorter than 0? should this be an error?
(set! impulse 0.0))
(if (not (vequal data (float-vector 1.4 -0.4 0.0 0.0 0.0))) ; hmmm -- they're asking for undefined values here
- (snd-display #__line__ ";delay size 0, max 1, off -0.4: ~A" data))
+ (snd-display ";delay size 0, max 1, off -0.4: ~A" data))
(set! dly1 (make-delay 0))
(set! impulse 1.0)
@@ -13006,10 +12560,10 @@ EDITS: 2
(set! (data i) (delay dly1 impulse))
(set! impulse 0.0))
(if (not (vequal data (float-vector 1 0 0 0 0)))
- (snd-display #__line__ ";delay size 0: ~A" data))
+ (snd-display ";delay size 0: ~A" data))
(let ((x (delay dly1 0.5)))
(if (fneq x 0.5)
- (snd-display #__line__ ";delay size 0 0.5: ~A" x)))
+ (snd-display ";delay size 0 0.5: ~A" x)))
)
(let ((gen (make-delay :size 0 :max-size 100))
@@ -13018,51 +12572,51 @@ EDITS: 2
((= i 10))
(set! (v i) (delay gen 0.5 i)))
(if (not (vequal v (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";delay 0 -> 100: ~A" v))
+ (snd-display ";delay 0 -> 100: ~A" v))
(do ((i 9 (- i 1)))
((< i 0))
(set! (v i) (delay gen 0.5 i)))
(if (not (vequal v (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
- (snd-display #__line__ ";delay 100 -> 0: ~A" v))
+ (snd-display ";delay 100 -> 0: ~A" v))
(mus-reset gen)
(if (not (vequal (mus-data gen) (make-float-vector 100 0.0)))
- (snd-display #__line__ ";after reset mus-data delay peak: ~A" (float-vector-peak (mus-data gen))))
+ (snd-display ";after reset mus-data delay peak: ~A" (float-vector-peak (mus-data gen))))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (delay gen (if (odd? i) 1.0 0.0) (* i .1))))
(if (not (vequal v (float-vector 0.000 0.900 0.000 0.700 0.000 0.500 0.000 0.300 0.000 0.100)))
- (snd-display #__line__ ";delay 0 -> 100 .1: ~A (~A)" v gen))
+ (snd-display ";delay 0 -> 100 .1: ~A (~A)" v gen))
(mus-reset gen)
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (delay gen (if (odd? i) 1.0 0.0) (+ 1.0 (* i .1)))))
(if (not (vequal v (float-vector 0.000 0.000 0.800 0.300 0.600 0.500 0.400 0.700 0.200 0.900)))
- (snd-display #__line__ ";delay 0 -> 100 1.1: ~A" v)))
+ (snd-display ";delay 0 -> 100 1.1: ~A" v)))
(let ((gen (make-all-pass .4 .6 3))
- (v0 (make-float-vector 10))
- (gen1 (make-all-pass .4 .6 3))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"all-pass"
"all-pass feedback: 0.400, feedforward: 0.600, line[3, step]:[0 0 0]")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (all-pass gen 1.0)))
- (fill-float-vector v1 (if (all-pass? gen1) (all-pass gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display #__line__ ";map all-pass: ~A ~A" v0 v1))
- (if (not (all-pass? gen)) (snd-display #__line__ ";~A not all-pass?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";all-pass length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 3)) (snd-display #__line__ ";all-pass order: ~D?" (mus-order gen)))
- (if (fneq (mus-feedback gen) .4) (snd-display #__line__ ";all-pass feedback: ~F?" (mus-feedback gen)))
- (if (fneq (mus-feedforward gen) .6) (snd-display #__line__ ";all-pass feedforward: ~F?" (mus-feedforward gen)))
+ (let ((gen1 (make-all-pass .4 .6 3))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (all-pass? gen1) (all-pass gen1 1.0) -1.0))
+ (if (not (vequal v1 v0)) (snd-display ";map all-pass: ~A ~A" v0 v1)))
+ (if (not (all-pass? gen)) (snd-display ";~A not all-pass?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";all-pass length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 3)) (snd-display ";all-pass order: ~D?" (mus-order gen)))
+ (if (fneq (mus-feedback gen) .4) (snd-display ";all-pass feedback: ~F?" (mus-feedback gen)))
+ (if (fneq (mus-feedforward gen) .6) (snd-display ";all-pass feedforward: ~F?" (mus-feedforward gen)))
(if (or (fneq (v0 1) 0.6) (fneq (v0 4) 1.84) (fneq (v0 8) 2.336))
- (snd-display #__line__ ";all-pass output: ~A" v0))
+ (snd-display ";all-pass output: ~A" v0))
(set! (mus-feedback gen) 0.5)
- (if (fneq (mus-feedback gen) .5) (snd-display #__line__ ";all-pass set-feedback: ~F?" (mus-feedback gen)))
+ (if (fneq (mus-feedback gen) .5) (snd-display ";all-pass set-feedback: ~F?" (mus-feedback gen)))
(set! (mus-feedforward gen) 0.5)
- (if (fneq (mus-feedforward gen) .5) (snd-display #__line__ ";all-pass set-feedforward: ~F?" (mus-feedforward gen))))
+ (if (fneq (mus-feedforward gen) .5) (snd-display ";all-pass set-feedforward: ~F?" (mus-feedforward gen))))
(test-gen-equal (let ((d1 (make-all-pass 0.7 0.5 3))) (all-pass d1 1.0) d1)
(let ((d2 (make-all-pass 0.7 0.5 3))) (all-pass d2 1.0) d2)
@@ -13078,50 +12632,50 @@ EDITS: 2
(make-all-pass 0.7 0.5 3 :initial-contents '(1.0 1.0 1.0)))
(let ((err (catch #t (lambda () (make-all-pass :feedback .2 :feedforward .1 :size -1)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-all-pass bad size error message: ~A" err)))
+ (snd-display ";make-all-pass bad size error message: ~A" err)))
(let ((gen (make-moving-average 4))
- (v0 (make-float-vector 10))
- (gen1 (make-moving-average 4))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"moving-average"
"moving-average 0.000, line[4]:[0 0 0 0]")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (moving-average gen 1.0)))
- (fill-float-vector v1 (if (moving-average? gen1) (moving-average gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display #__line__ ";map average: ~A ~A" v0 v1))
- (if (not (moving-average? gen)) (snd-display #__line__ ";~A not average?" gen))
- (if (not (= (mus-length gen) 4)) (snd-display #__line__ ";average length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 4)) (snd-display #__line__ ";average order: ~D?" (mus-order gen)))
+ (let ((gen1 (make-moving-average 4))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (moving-average? gen1) (moving-average gen1 1.0) -1.0))
+ (if (not (vequal v1 v0)) (snd-display ";map average: ~A ~A" v0 v1)))
+ (if (not (moving-average? gen)) (snd-display ";~A not average?" gen))
+ (if (not (= (mus-length gen) 4)) (snd-display ";average length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 4)) (snd-display ";average order: ~D?" (mus-order gen)))
(if (or (fneq (v0 1) 0.5) (fneq (v0 4) 1.0) (fneq (v0 8) 1.0))
- (snd-display #__line__ ";average output: ~A" v0)))
+ (snd-display ";average output: ~A" v0)))
(let* ((gen (make-moving-average 8))
(val (moving-average gen)))
- (if (fneq val 0.0) (snd-display #__line__ ";empty average: ~A" val))
+ (if (fneq val 0.0) (snd-display ";empty average: ~A" val))
(set! val (moving-average gen 1.0))
- (if (fneq val 0.125) (snd-display #__line__ ";average 1: ~A" val))
+ (if (fneq val 0.125) (snd-display ";average 1: ~A" val))
(set! val (moving-average gen 1.0))
- (if (fneq val 0.25) (snd-display #__line__ ";average 2: ~A" val))
+ (if (fneq val 0.25) (snd-display ";average 2: ~A" val))
(set! val (moving-average gen 0.5))
- (if (fneq val 0.3125) (snd-display #__line__ ";average 2: ~A" val))
+ (if (fneq val 0.3125) (snd-display ";average 2: ~A" val))
(do ((i 0 (+ i 1))) ((= i 5)) (set! val (moving-average gen 0.0)))
- (if (fneq val 0.3125) (snd-display #__line__ ";average 6: ~A" val))
+ (if (fneq val 0.3125) (snd-display ";average 6: ~A" val))
(set! val (moving-average gen 0.0))
- (if (fneq val 0.1875) (snd-display #__line__ ";average 7: ~A" val))
+ (if (fneq val 0.1875) (snd-display ";average 7: ~A" val))
(set! val (moving-average gen 0.0))
- (if (fneq val 0.0625) (snd-display #__line__ ";average 8: ~A" val))
+ (if (fneq val 0.0625) (snd-display ";average 8: ~A" val))
(set! val (moving-average gen 0.0))
- (if (fneq val 0.0) (snd-display #__line__ ";average 9: ~A" val))
+ (if (fneq val 0.0) (snd-display ";average 9: ~A" val))
)
(let* ((gen (make-moving-average 10 :initial-element .5))
(val (moving-average gen 0.5)))
- (if (fneq val 0.5) (snd-display #__line__ ";average initial-element: ~A" val)))
+ (if (fneq val 0.5) (snd-display ";average initial-element: ~A" val)))
(let* ((gen (make-moving-average 3 :initial-contents '(1.0 1.0 1.0)))
(val (moving-average gen 1.0)))
- (if (fneq val 1.0) (snd-display #__line__ ";average initial-contents: ~A" val)))
+ (if (fneq val 1.0) (snd-display ";average initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-average 3 :initial-contents '(0.7 0.5 3)))) (moving-average d1 1.0) d1)
(let ((d2 (make-moving-average 3 :initial-contents (float-vector 0.7 0.5 3)))) (moving-average d2 1.0) d2)
@@ -13137,14 +12691,13 @@ EDITS: 2
(make-moving-average 3 :initial-contents '(1.0 1.0 1.0)))
(let ((err (catch #t (lambda () (make-moving-average :size -1)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-average bad size error message: ~A" err)))
+ (snd-display ";make-average bad size error message: ~A" err)))
(let ((err (catch #t (lambda () (make-moving-average :size 0)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-average size==0 error message: ~A" err)))
+ (snd-display ";make-average size==0 error message: ~A" err)))
(let ((gen (make-moving-max 4))
(v0 (make-float-vector 10))
- (gen1 (make-moving-max 4))
(v1 (make-float-vector 10)))
(print-and-check gen
"moving-max"
@@ -13152,38 +12705,39 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (moving-max gen 1.0)))
- (fill-float-vector v1 (if (moving-max? gen1) (moving-max gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display #__line__ ";map max: ~A ~A" v0 v1))
- (if (not (moving-max? gen)) (snd-display #__line__ ";~A not max?" gen))
- (if (not (= (mus-length gen) 4)) (snd-display #__line__ ";max length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 4)) (snd-display #__line__ ";max order: ~D?" (mus-order gen)))
+ (let ((gen1 (make-moving-max 4)))
+ (fill-float-vector v1 (if (moving-max? gen1) (moving-max gen1 1.0) -1.0)))
+ (if (not (vequal v1 v0)) (snd-display ";map max: ~A ~A" v0 v1))
+ (if (not (moving-max? gen)) (snd-display ";~A not max?" gen))
+ (if (not (= (mus-length gen) 4)) (snd-display ";max length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 4)) (snd-display ";max order: ~D?" (mus-order gen)))
(if (or (fneq (v0 1) 1.0) (fneq (v0 4) 1.0) (fneq (v0 8) 1.0))
- (snd-display #__line__ ";max output: ~A" v0)))
+ (snd-display ";max output: ~A" v0)))
(let* ((gen (make-moving-max 8))
(val (moving-max gen)))
- (if (fneq val 0.0) (snd-display #__line__ ";empty max: ~A" val))
+ (if (fneq val 0.0) (snd-display ";empty max: ~A" val))
(set! val (moving-max gen 1.0))
- (if (fneq val 1.0) (snd-display #__line__ ";max 1: ~A" val))
+ (if (fneq val 1.0) (snd-display ";max 1: ~A" val))
(set! val (moving-max gen -0.5))
- (if (fneq val 1.0) (snd-display #__line__ ";max 2: ~A" val))
+ (if (fneq val 1.0) (snd-display ";max 2: ~A" val))
(set! val (moving-max gen -1.5))
- (if (fneq val 1.5) (snd-display #__line__ ";max 2: ~A" val))
+ (if (fneq val 1.5) (snd-display ";max 2: ~A" val))
(do ((i 0 (+ i 1))) ((= i 5)) (set! val (moving-max gen 0.0)))
- (if (fneq val 1.5) (snd-display #__line__ ";max 6: ~A" val))
+ (if (fneq val 1.5) (snd-display ";max 6: ~A" val))
(set! val (moving-max gen 0.0))
- (if (fneq val 1.5) (snd-display #__line__ ";max 7: ~A" val))
+ (if (fneq val 1.5) (snd-display ";max 7: ~A" val))
(set! val (moving-max gen 0.0))
- (if (fneq val 1.5) (snd-display #__line__ ";max 8: ~A" val))
+ (if (fneq val 1.5) (snd-display ";max 8: ~A" val))
(set! val (moving-max gen 0.0))
- (if (fneq val 0.0) (snd-display #__line__ ";max 9: ~A" val))
+ (if (fneq val 0.0) (snd-display ";max 9: ~A" val))
)
(let* ((gen (make-moving-max 10 :initial-element .5))
(val (moving-max gen 0.5)))
- (if (fneq val 0.5) (snd-display #__line__ ";max initial-element: ~A" val)))
+ (if (fneq val 0.5) (snd-display ";max initial-element: ~A" val)))
(let* ((gen (make-moving-max 3 :initial-contents '(1.0 1.0 1.0)))
(val (moving-max gen 1.0)))
- (if (fneq val 1.0) (snd-display #__line__ ";max initial-contents: ~A" val)))
+ (if (fneq val 1.0) (snd-display ";max initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-max 3 :initial-contents '(0.7 0.5 3)))) (moving-max d1 1.0) d1)
(let ((d2 (make-moving-max 3 :initial-contents (float-vector 0.7 0.5 3)))) (moving-max d2 1.0) d2)
@@ -13199,14 +12753,13 @@ EDITS: 2
(make-moving-max 3 :initial-contents '(1.0 1.0 1.0)))
(let ((err (catch #t (lambda () (make-moving-max :size -1)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-max bad size error message: ~A" err)))
+ (snd-display ";make-max bad size error message: ~A" err)))
(let ((err (catch #t (lambda () (make-moving-max :size 0)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-max size==0 error message: ~A" err)))
+ (snd-display ";make-max size==0 error message: ~A" err)))
(let ((gen (make-moving-norm 4))
(v0 (make-float-vector 10))
- (gen1 (make-moving-norm 4))
(v1 (make-float-vector 10)))
(print-and-check gen
"moving-norm"
@@ -13214,36 +12767,37 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (moving-norm gen 1.0)))
- (fill-float-vector v1 (if (moving-norm? gen1) (moving-norm gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display #__line__ ";map norm: ~A ~A" v0 v1))
- (if (not (moving-norm? gen)) (snd-display #__line__ ";~A not norm?" gen))
- (if (not (= (mus-length gen) 4)) (snd-display #__line__ ";norm length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 4)) (snd-display #__line__ ";norm order: ~D?" (mus-order gen))))
+ (let ((gen1 (make-moving-norm 4)))
+ (fill-float-vector v1 (if (moving-norm? gen1) (moving-norm gen1 1.0) -1.0)))
+ (if (not (vequal v1 v0)) (snd-display ";map norm: ~A ~A" v0 v1))
+ (if (not (moving-norm? gen)) (snd-display ";~A not norm?" gen))
+ (if (not (= (mus-length gen) 4)) (snd-display ";norm length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 4)) (snd-display ";norm order: ~D?" (mus-order gen))))
(let* ((gen (make-moving-norm 8))
(val (moving-norm gen)))
- (if (fneq val 1.1236) (snd-display #__line__ ";empty norm: ~A" val))
+ (if (fneq val 1.1236) (snd-display ";empty norm: ~A" val))
(set! val (moving-norm gen 1.0))
- (if (fneq val 1.1084) (snd-display #__line__ ";norm 1: ~A" val))
+ (if (fneq val 1.1084) (snd-display ";norm 1: ~A" val))
(set! val (moving-norm gen -0.5))
- (if (fneq val 1.0952) (snd-display #__line__ ";norm 2: ~A" val))
+ (if (fneq val 1.0952) (snd-display ";norm 2: ~A" val))
(set! val (moving-norm gen -1.5))
- (if (fneq val 1.0222) (snd-display #__line__ ";norm 2: ~A" val))
+ (if (fneq val 1.0222) (snd-display ";norm 2: ~A" val))
(do ((i 0 (+ i 1))) ((= i 5)) (set! val (moving-norm gen 0.0)))
- (if (fneq val 0.8261) (snd-display #__line__ ";norm 6: ~A" val))
+ (if (fneq val 0.8261) (snd-display ";norm 6: ~A" val))
(set! val (moving-norm gen 0.0))
- (if (fneq val 0.8047) (snd-display #__line__ ";norm 7: ~A" val))
+ (if (fneq val 0.8047) (snd-display ";norm 7: ~A" val))
(set! val (moving-norm gen 0.0))
- (if (fneq val 0.7866) (snd-display #__line__ ";norm 8: ~A" val))
+ (if (fneq val 0.7866) (snd-display ";norm 8: ~A" val))
(set! val (moving-norm gen 0.0))
- (if (fneq val 0.8841) (snd-display #__line__ ";norm 9: ~A" val))
+ (if (fneq val 0.8841) (snd-display ";norm 9: ~A" val))
)
(let* ((gen (make-moving-norm 10 :initial-element .5))
(val (moving-norm gen 0.5)))
- (if (fneq val 1.0476) (snd-display #__line__ ";norm initial-element: ~A" val)))
+ (if (fneq val 1.0476) (snd-display ";norm initial-element: ~A" val)))
(let* ((gen (make-moving-norm 3 :initial-contents '(1.0 1.0 1.0)))
(val (moving-norm gen 1.0)))
- (if (fneq val 1.0) (snd-display #__line__ ";norm initial-contents: ~A" val)))
+ (if (fneq val 1.0) (snd-display ";norm initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-norm 3))) (moving-norm d1 1.0) d1)
(let ((d2 (make-moving-norm 3))) (moving-norm d2 1.0) d2)
@@ -13253,15 +12807,14 @@ EDITS: 2
(make-moving-norm 4 :scaler 1.0))
(let ((err (catch #t (lambda () (make-moving-norm :size -1)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-norm bad size error message: ~A" err)))
+ (snd-display ";make-norm bad size error message: ~A" err)))
(let ((err (catch #t (lambda () (make-moving-norm :size 0)) (lambda args args))))
(if (not (eq? (car err) 'out-of-range))
- (snd-display #__line__ ";make-norm size==0 error message: ~A" err)))
+ (snd-display ";make-norm size==0 error message: ~A" err)))
(let ((gen (make-comb .4 3))
(v0 (make-float-vector 10))
- (gen1 (make-comb .4 3))
(v1 (make-float-vector 10)))
(print-and-check gen
"comb"
@@ -13269,14 +12822,15 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (comb gen 1.0)))
- (fill-float-vector v1 (if (comb? gen1) (comb gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map comb: ~A ~A" v0 v1))
- (if (not (comb? gen)) (snd-display #__line__ ";~A not comb?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";comb length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 3)) (snd-display #__line__ ";comb order: ~D?" (mus-order gen)))
- (if (fneq (mus-feedback gen) .4) (snd-display #__line__ ";comb feedback: ~F?" (mus-feedback gen)))
+ (let ((gen1 (make-comb .4 3)))
+ (fill-float-vector v1 (if (comb? gen1) (comb gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map comb: ~A ~A" v0 v1))
+ (if (not (comb? gen)) (snd-display ";~A not comb?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";comb length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 3)) (snd-display ";comb order: ~D?" (mus-order gen)))
+ (if (fneq (mus-feedback gen) .4) (snd-display ";comb feedback: ~F?" (mus-feedback gen)))
(if (or (fneq (v0 1) 0.0) (fneq (v0 4) 1.0) (fneq (v0 8) 1.4))
- (snd-display #__line__ ";comb output: ~A" v0)))
+ (snd-display ";comb output: ~A" v0)))
(test-gen-equal (let ((d1 (make-comb 0.7 3))) (comb d1 1.0) d1)
(let ((d2 (make-comb 0.7 3))) (comb d2 1.0) d2)
@@ -13299,32 +12853,32 @@ EDITS: 2
((= i 5))
(set! (v0 i) (comb del 0.0 0.4)))
(if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
- (snd-display #__line__ ";zcomb: ~A" v0))
- (comb del 1.0)
- (comb del 0.0 0.4)
- (if (not (string=? (mus-describe del) "comb scaler: 0.000, line[5,8, linear]: [0 0 1 0 0]"))
- (snd-display #__line__ ";describe zcomb: ~A" (mus-describe del))))
+ (snd-display ";zcomb: ~A" v0)))
+ (comb del 1.0)
+ (comb del 0.0 0.4)
+ (if (not (string=? (mus-describe del) "comb scaler: 0.000, line[5,8, linear]: [0 0 1 0 0]"))
+ (snd-display ";describe zcomb: ~A" (mus-describe del)))
(set! (mus-feedback del) 1.0)
(if (fneq (mus-feedback del) 1.0)
- (snd-display #__line__ ";comb feedback set: ~A" (mus-feedback del))))
+ (snd-display ";comb feedback set: ~A" (mus-feedback del))))
- (let ((gen (make-filtered-comb .4 5 :filter (make-one-zero .3 .7)))
- (v0 (make-float-vector 20)))
+ (let ((gen (make-filtered-comb .4 5 :filter (make-one-zero .3 .7))))
(print-and-check gen
"filtered-comb"
"filtered-comb scaler: 0.400, line[5, step]: [0 0 0 0 0], filter: [one-zero a0: 0.300, a1: 0.700, x1: 0.000]")
- (let ((val 1.0))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (set! (v0 i) (filtered-comb gen val))
- (set! val 0.0)))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.120 0.280 0.000 0.000 0.000 0.014 0.067 0.078 0.000 0.000)))
- (snd-display #__line__ ";filtered-comb: ~A" v0))
- (if (not (filtered-comb? gen)) (snd-display #__line__ ";~A not filtered-comb?" gen))
- (if (not (= (mus-length gen) 5)) (snd-display #__line__ ";filtered-comb length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 5)) (snd-display #__line__ ";filtered-comb order: ~D?" (mus-order gen)))
- (if (fneq (mus-feedback gen) .4) (snd-display #__line__ ";filtered-comb feedback: ~F?" (mus-feedback gen))))
+ (let ((v0 (make-float-vector 20)))
+ (let ((val 1.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (set! (v0 i) (filtered-comb gen val))
+ (set! val 0.0)))
+ (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.120 0.280 0.000 0.000 0.000 0.014 0.067 0.078 0.000 0.000)))
+ (snd-display ";filtered-comb: ~A" v0)))
+ (if (not (filtered-comb? gen)) (snd-display ";~A not filtered-comb?" gen))
+ (if (not (= (mus-length gen) 5)) (snd-display ";filtered-comb length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 5)) (snd-display ";filtered-comb order: ~D?" (mus-order gen)))
+ (if (fneq (mus-feedback gen) .4) (snd-display ";filtered-comb feedback: ~F?" (mus-feedback gen))))
(let ((gen (make-filtered-comb .9 5 :filter (make-one-zero .5 .5)))
(v0 (make-float-vector 20)))
@@ -13337,7 +12891,7 @@ EDITS: 2
(set! (v0 i) (filtered-comb gen val))
(set! val 0.0)))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.450 0.450 0.000 0.000 0.000 0.202 0.405 0.202 0.000 0.000)))
- (snd-display #__line__ ";filtered-comb .5 .5: ~A" v0)))
+ (snd-display ";filtered-comb .5 .5: ~A" v0)))
(let ((gen (make-filtered-comb .9 5 :filter (make-fir-filter 5 (float-vector .1 .2 .3 .2 .1))))
(v0 (make-float-vector 20)))
@@ -13350,7 +12904,7 @@ EDITS: 2
(set! (v0 i) (filtered-comb gen val))
(set! val 0.0)))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.090 0.180 0.270 0.180 0.090 0.008 0.032 0.081 0.130 0.154)))
- (snd-display #__line__ ";filtered-comb fir: ~A" v0)))
+ (snd-display ";filtered-comb fir: ~A" v0)))
(test-gen-equal (let ((d1 (make-filtered-comb 0.7 3 :filter (make-one-pole .3 .7)))) (filtered-comb d1 1.0) d1)
(let ((d2 (make-filtered-comb 0.7 3 :filter (make-one-pole .3 .7)))) (filtered-comb d2 1.0) d2)
@@ -13373,38 +12927,38 @@ EDITS: 2
((= i 5))
(set! (v0 i) (filtered-comb del 0.0 0.4)))
(if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
- (snd-display #__line__ ";zfiltered-comb: ~A" v0))
- (filtered-comb del 1.0)
- (filtered-comb del 0.0 0.4)
- (if (not (string=? (mus-describe del)
- "filtered-comb scaler: 0.000, line[5,8, linear]: [0 0 1 0 0], filter: [one-zero a0: 0.500, a1: 0.500, x1: 0.000]"))
- (snd-display #__line__ ";describe zfiltered-comb: ~A" (mus-describe del))))
+ (snd-display ";zfiltered-comb: ~A" v0)))
+ (filtered-comb del 1.0)
+ (filtered-comb del 0.0 0.4)
+ (if (not (string=? (mus-describe del)
+ "filtered-comb scaler: 0.000, line[5,8, linear]: [0 0 1 0 0], filter: [one-zero a0: 0.500, a1: 0.500, x1: 0.000]"))
+ (snd-display ";describe zfiltered-comb: ~A" (mus-describe del)))
(set! (mus-feedback del) 1.0)
(if (fneq (mus-feedback del) 1.0)
- (snd-display #__line__ ";filtered-comb feedback set: ~A" (mus-feedback del))))
+ (snd-display ";filtered-comb feedback set: ~A" (mus-feedback del))))
(let ((gen (make-notch .4 3))
- (v0 (make-float-vector 10))
- (gen1 (make-notch .4 3))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"notch"
"notch scaler: 0.400, line[3, step]: [0 0 0]")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (notch gen 1.0)))
- (fill-float-vector v1 (if (notch? gen1) (notch gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map notch: ~A ~A" v0 v1))
- (if (not (notch? gen)) (snd-display #__line__ ";~A not notch?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";notch length: ~D?" (mus-length gen)))
- (if (not (= (mus-order gen) 3)) (snd-display #__line__ ";notch order: ~D?" (mus-order gen)))
- (if (fneq (mus-feedforward gen) .4) (snd-display #__line__ ";notch feedforward: ~F?" (mus-feedforward gen)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-notch .4 3)))
+ (fill-float-vector v1 (if (notch? gen1) (notch gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map notch: ~A ~A" v0 v1)))
+ (if (not (notch? gen)) (snd-display ";~A not notch?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";notch length: ~D?" (mus-length gen)))
+ (if (not (= (mus-order gen) 3)) (snd-display ";notch order: ~D?" (mus-order gen)))
+ (if (fneq (mus-feedforward gen) .4) (snd-display ";notch feedforward: ~F?" (mus-feedforward gen)))
(if (or (fneq (v0 1) 0.4) (fneq (v0 4) 1.4) (fneq (v0 8) 1.4))
- (snd-display #__line__ ";notch output: ~A" v0))
+ (snd-display ";notch output: ~A" v0))
(set! (mus-feedforward gen) 1.0)
(if (fneq (mus-feedforward gen) 1.0)
- (snd-display #__line__ ";notch feedforward set: ~A" (mus-feedforward gen))))
+ (snd-display ";notch feedforward set: ~A" (mus-feedforward gen))))
(test-gen-equal (let ((d1 (make-notch 0.7 3))) (notch d1 1.0) d1)
(let ((d2 (make-notch 0.7 3))) (notch d2 1.0) d2)
@@ -13429,7 +12983,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
- (snd-display #__line__ ";comb (5 .5): ~A" v0)))
+ (snd-display ";comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5))
(v0 (make-float-vector 11))
@@ -13439,7 +12993,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
- (snd-display #__line__ ";all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5))
(v0 (make-float-vector 11))
@@ -13449,7 +13003,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";notch (5 .5): ~A" v0)))
+ (snd-display ";notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5))
(v0 (make-float-vector 11))
@@ -13459,7 +13013,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";all-pass (5 .5 0): ~A" v0)))
;; make sure zall-pass is the same as zcomb/znotch given the appropriate feedback/forward and "pm" settings
@@ -13471,7 +13025,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
- (snd-display #__line__ ";1comb (5 .5): ~A" v0)))
+ (snd-display ";1comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
(v0 (make-float-vector 11))
@@ -13481,7 +13035,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
- (snd-display #__line__ ";1all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";1all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
(v0 (make-float-vector 11))
@@ -13491,7 +13045,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";1notch (5 .5): ~A" v0)))
+ (snd-display ";1notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
(v0 (make-float-vector 11))
@@ -13501,7 +13055,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";1all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";1all-pass (5 .5 0): ~A" v0)))
;; now actually use the size difference
@@ -13514,7 +13068,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1 phase))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
- (snd-display #__line__ ";2comb (5 .5): ~A" v0)))
+ (snd-display ";2comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13525,7 +13079,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
- (snd-display #__line__ ";2all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";2all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13536,7 +13090,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";2notch (5 .5): ~A" v0)))
+ (snd-display ";2notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13547,7 +13101,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";2all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";2all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-comb 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13558,7 +13112,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
- (snd-display #__line__ ";3comb (5 .5): ~A" v0)))
+ (snd-display ";3comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13569,7 +13123,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
- (snd-display #__line__ ";3all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";3all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13580,7 +13134,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";3notch (5 .5): ~A" v0)))
+ (snd-display ";3notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13591,7 +13145,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";3all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";3all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-comb 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13602,7 +13156,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
- (snd-display #__line__ ";4comb (5 .5): ~A" v0)))
+ (snd-display ";4comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13613,7 +13167,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
- (snd-display #__line__ ";4all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";4all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13624,7 +13178,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";4notch (5 .5): ~A" v0)))
+ (snd-display ";4notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
(v0 (make-float-vector 20))
@@ -13635,7 +13189,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";4all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";4all-pass (5 .5 0): ~A" v0)))
;; now run off either end of the delay line "by accident"
@@ -13648,7 +13202,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
- (snd-display #__line__ ";5comb (5 .5): ~A" v0)))
+ (snd-display ";5comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13659,7 +13213,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
- (snd-display #__line__ ";5all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";5all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13670,7 +13224,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";5notch (5 .5): ~A" v0)))
+ (snd-display ";5notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13681,7 +13235,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";5all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";5all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-comb 0.5 5 :max-size 10))
@@ -13693,7 +13247,7 @@ EDITS: 2
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
- (snd-display #__line__ ";6comb (5 .5): ~A" v0)))
+ (snd-display ";6comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13704,7 +13258,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
- (snd-display #__line__ ";6all-pass (5 0 .5): ~A" v0)))
+ (snd-display ";6all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13715,7 +13269,7 @@ EDITS: 2
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";6notch (5 .5): ~A" v0)))
+ (snd-display ";6notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 10))
(v0 (make-float-vector 20))
@@ -13726,7 +13280,7 @@ EDITS: 2
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";6all-pass (5 .5 0): ~A" v0)))
+ (snd-display ";6all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .5 .5)))
(v0 (make-float-vector 21))
@@ -13737,7 +13291,7 @@ EDITS: 2
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.250 0.250
0.000 0.000 0.000 0.062 0.125 0.062 0.000 0.000 0.016)))
- (snd-display #__line__ ";filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .25 .75)))
(v0 (make-float-vector 21))
@@ -13748,7 +13302,7 @@ EDITS: 2
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
- (snd-display #__line__ ";1filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";1filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .25 .75)))
(v0 (make-float-vector 21))
@@ -13760,7 +13314,7 @@ EDITS: 2
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
- (snd-display #__line__ ";1mus-filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";1mus-filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .25 .75)))
(v0 (make-float-vector 21))
@@ -13771,7 +13325,7 @@ EDITS: 2
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
- (snd-display #__line__ ";1run-filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";1run-filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :max-size 20 :filter (make-one-zero .5 .5)))
(v0 (make-float-vector 20))
@@ -13782,7 +13336,7 @@ EDITS: 2
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.080 0.220 0.300 0.140 0.040 0.000 0.000)))
- (snd-display #__line__ ";2filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";2filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :max-size 20 :filter (make-one-zero .5 .5)))
(v0 (make-float-vector 20))
@@ -13793,7 +13347,7 @@ EDITS: 2
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.080 0.200 0.040 0.020 0.068 0.042 0.019 0.026 0.015 0.011 0.009 0.006 0.004)))
- (snd-display #__line__ ";3filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";3filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :max-size 20 :filter (make-one-zero .5 .5)))
(v0 (make-float-vector 20))
@@ -13804,175 +13358,175 @@ EDITS: 2
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
(if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.214 0.251 0.043 0.002 0.000 0.045 0.106 0.081 0.023 0.003)))
- (snd-display #__line__ ";4filtered-comb (5 .5): ~A" v0)))
+ (snd-display ";4filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-one-pole .4 .7))
- (v0 (make-float-vector 10))
- (gen1 (make-one-pole .4 .7))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"one-pole"
"one-pole a0: 0.400, b1: 0.700, y1: 0.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (one-pole gen 1.0)))
- (fill-float-vector v1 (if (one-pole? gen) (one-pole gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map one-pole: ~A ~A" v0 v1))
- (if (not (one-pole? gen)) (snd-display #__line__ ";~A not one-pole?" gen))
- (if (not (= (mus-order gen) 1)) (snd-display #__line__ ";one-pole order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";one-pole a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-ycoeff gen 1) .7) (snd-display #__line__ ";one-pole b1: ~F?" (mus-ycoeff gen 1)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-one-pole .4 .7)))
+ (fill-float-vector v1 (if (one-pole? gen) (one-pole gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map one-pole: ~A ~A" v0 v1)))
+ (if (not (one-pole? gen)) (snd-display ";~A not one-pole?" gen))
+ (if (not (= (mus-order gen) 1)) (snd-display ";one-pole order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";one-pole a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-ycoeff gen 1) .7) (snd-display ";one-pole b1: ~F?" (mus-ycoeff gen 1)))
(if (or (fneq (v0 1) 0.120) (fneq (v0 4) 0.275) (fneq (v0 8) 0.245))
- (snd-display #__line__ ";one-pole output: ~A" v0))
- (if (fneq (mus-ycoeff gen 1) .7) (snd-display #__line__ ";1p ycoeff 1 .7: ~A" gen))
+ (snd-display ";one-pole output: ~A" v0))
+ (if (fneq (mus-ycoeff gen 1) .7) (snd-display ";1p ycoeff 1 .7: ~A" gen))
(set! (mus-ycoeff gen 1) .1)
- (if (fneq (mus-ycoeff gen 1) .1) (snd-display #__line__ ";1p set ycoeff 1 .1: ~A" gen))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";1p xcoeff 0 .4: ~A" gen))
+ (if (fneq (mus-ycoeff gen 1) .1) (snd-display ";1p set ycoeff 1 .1: ~A" gen))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";1p xcoeff 0 .4: ~A" gen))
(set! (mus-xcoeff gen 0) .3)
- (if (fneq (mus-xcoeff gen 0) .3) (snd-display #__line__ ";1p set xcoeff 0 .3: ~A" gen)))
+ (if (fneq (mus-xcoeff gen 0) .3) (snd-display ";1p set xcoeff 0 .3: ~A" gen)))
(let ((gen (make-one-zero .4 .7))
- (v0 (make-float-vector 10))
- (gen1 (make-one-zero .4 .7))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"one-zero"
"one-zero a0: 0.400, a1: 0.700, x1: 0.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (one-zero gen 1.0)))
- (fill-float-vector v1 (if (one-zero? gen) (one-zero gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map one-zero: ~A ~A" v0 v1))
- (if (not (one-zero? gen)) (snd-display #__line__ ";~A not one-zero?" gen))
- (if (not (= (mus-order gen) 1)) (snd-display #__line__ ";one-zero order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";one-zero a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-xcoeff gen 1) .7) (snd-display #__line__ ";one-zero a1: ~F?" (mus-xcoeff gen 1)))
- (if (fneq (v0 1) 1.1) (snd-display #__line__ ";one-zero output: ~A" v0))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";1z xcoeff 0 .4: ~A" gen))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-one-zero .4 .7)))
+ (fill-float-vector v1 (if (one-zero? gen) (one-zero gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map one-zero: ~A ~A" v0 v1)))
+ (if (not (one-zero? gen)) (snd-display ";~A not one-zero?" gen))
+ (if (not (= (mus-order gen) 1)) (snd-display ";one-zero order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";one-zero a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-xcoeff gen 1) .7) (snd-display ";one-zero a1: ~F?" (mus-xcoeff gen 1)))
+ (if (fneq (v0 1) 1.1) (snd-display ";one-zero output: ~A" v0))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";1z xcoeff 0 .4: ~A" gen))
(set! (mus-xcoeff gen 0) .1)
- (if (fneq (mus-xcoeff gen 0) .1) (snd-display #__line__ ";1z set xcoeff 0 .1: ~A" gen)))
+ (if (fneq (mus-xcoeff gen 0) .1) (snd-display ";1z set xcoeff 0 .1: ~A" gen)))
(let ((gen (make-two-zero .4 .7 .3))
- (v0 (make-float-vector 10))
- (gen1 (make-two-zero .4 .7 .3))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"two-zero"
"two-zero a0: 0.400, a1: 0.700, a2: 0.300, x1: 0.000, x2: 0.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (two-zero gen 1.0)))
- (fill-float-vector v1 (if (two-zero? gen1) (two-zero gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map two-zero: ~A ~A" v0 v1))
- (if (not (two-zero? gen)) (snd-display #__line__ ";~A not two-zero?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";two-zero order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";two-zero a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-xcoeff gen 1) .7) (snd-display #__line__ ";two-zero a1: ~F?" (mus-xcoeff gen 1)))
- (if (fneq (mus-xcoeff gen 2) .3) (snd-display #__line__ ";two-zero a2: ~F?" (mus-xcoeff gen 2)))
- (if (or (fneq (v0 1) 1.1) (fneq (v0 8) 1.4)) (snd-display #__line__ ";two-zero output: ~A" v0))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";2z xcoeff 0 .4: ~A" gen))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-two-zero .4 .7 .3)))
+ (fill-float-vector v1 (if (two-zero? gen1) (two-zero gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map two-zero: ~A ~A" v0 v1)))
+ (if (not (two-zero? gen)) (snd-display ";~A not two-zero?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";two-zero order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";two-zero a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-xcoeff gen 1) .7) (snd-display ";two-zero a1: ~F?" (mus-xcoeff gen 1)))
+ (if (fneq (mus-xcoeff gen 2) .3) (snd-display ";two-zero a2: ~F?" (mus-xcoeff gen 2)))
+ (if (or (fneq (v0 1) 1.1) (fneq (v0 8) 1.4)) (snd-display ";two-zero output: ~A" v0))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";2z xcoeff 0 .4: ~A" gen))
(set! (mus-xcoeff gen 0) .1)
- (if (fneq (mus-xcoeff gen 0) .1) (snd-display #__line__ ";2z set xcoeff 0 .1: ~A" gen))
+ (if (fneq (mus-xcoeff gen 0) .1) (snd-display ";2z set xcoeff 0 .1: ~A" gen))
(set! (mus-xcoeff gen 0) 1.0)
(let ((r (mus-scaler gen)))
(set! (mus-frequency gen) 500.0)
- (if (ffneq (mus-frequency gen) 500.0) (snd-display #__line__ ";set mus-frequency two-zero: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) r) (snd-display #__line__ ";set mus-frequency two-zero hit r: ~A" (mus-scaler gen)))
- (set! (mus-scaler gen) .99)
- (if (fneq (mus-scaler gen) .99) (snd-display #__line__ ";set mus-scaler two-zero: ~A" (mus-scaler gen)))
- (if (ffneq (mus-frequency gen) 500.0) (snd-display #__line__ ";set mus-scaler hit freq two-zero: ~A" (mus-frequency gen)))
- (let ((g3 (make-two-zero :radius .99 :frequency 500.0)))
- (if (or (fneq (mus-xcoeff gen 0) (mus-xcoeff g3 0))
- (fneq (mus-xcoeff gen 1) (mus-xcoeff g3 1))
- (fneq (mus-xcoeff gen 2) (mus-xcoeff g3 2)))
- (snd-display #__line__ ";two-zero setters: ~A ~A" gen g3)))))
+ (if (ffneq (mus-frequency gen) 500.0) (snd-display ";set mus-frequency two-zero: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) r) (snd-display ";set mus-frequency two-zero hit r: ~A" (mus-scaler gen))))
+ (set! (mus-scaler gen) .99)
+ (if (fneq (mus-scaler gen) .99) (snd-display ";set mus-scaler two-zero: ~A" (mus-scaler gen)))
+ (if (ffneq (mus-frequency gen) 500.0) (snd-display ";set mus-scaler hit freq two-zero: ~A" (mus-frequency gen)))
+ (let ((g3 (make-two-zero :radius .99 :frequency 500.0)))
+ (if (or (fneq (mus-xcoeff gen 0) (mus-xcoeff g3 0))
+ (fneq (mus-xcoeff gen 1) (mus-xcoeff g3 1))
+ (fneq (mus-xcoeff gen 2) (mus-xcoeff g3 2)))
+ (snd-display ";two-zero setters: ~A ~A" gen g3))))
(let ((gen (make-two-zero .4 .7 .3)))
(let ((val (gen 1.0)))
- (if (fneq val .4) (snd-display #__line__ ";2zero->0.4: ~A" val))
+ (if (fneq val .4) (snd-display ";2zero->0.4: ~A" val))
(set! val (gen 0.5))
- (if (fneq val .9) (snd-display #__line__ ";2zero->0.9: ~A" val))
+ (if (fneq val .9) (snd-display ";2zero->0.9: ~A" val))
(set! val (gen 1.0))
- (if (fneq val 1.05) (snd-display #__line__ ";2zero->1.05: ~A" val))))
+ (if (fneq val 1.05) (snd-display ";2zero->1.05: ~A" val))))
(let ((gen (make-two-pole .4 .7 .3))
- (v0 (make-float-vector 10))
- (gen1 (make-two-pole .4 .7 .3))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"two-pole"
"two-pole a0: 0.400, b1: 0.700, b2: 0.300, y1: 0.000, y2: 0.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (two-pole gen 1.0)))
- (fill-float-vector v1 (if (two-pole? gen1) (two-pole gen1 1.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map two-pole: ~A ~A" v0 v1))
- (if (not (two-pole? gen)) (snd-display #__line__ ";~A not two-pole?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";two-pole order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";two-pole a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-ycoeff gen 1) .7) (snd-display #__line__ ";two-pole b1: ~F?" (mus-ycoeff gen 1)))
- (if (fneq (mus-ycoeff gen 2) .3) (snd-display #__line__ ";two-pole b2: ~F?" (mus-ycoeff gen 2)))
- (if (or (fneq (v0 1) 0.12) (fneq (v0 8) 0.201)) (snd-display #__line__ ";two-pole output: ~A" v0))
- (if (fneq (mus-ycoeff gen 1) .7) (snd-display #__line__ ";2p ycoeff 1 .7: ~A" gen))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-two-pole .4 .7 .3)))
+ (fill-float-vector v1 (if (two-pole? gen1) (two-pole gen1 1.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map two-pole: ~A ~A" v0 v1)))
+ (if (not (two-pole? gen)) (snd-display ";~A not two-pole?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";two-pole order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";two-pole a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-ycoeff gen 1) .7) (snd-display ";two-pole b1: ~F?" (mus-ycoeff gen 1)))
+ (if (fneq (mus-ycoeff gen 2) .3) (snd-display ";two-pole b2: ~F?" (mus-ycoeff gen 2)))
+ (if (or (fneq (v0 1) 0.12) (fneq (v0 8) 0.201)) (snd-display ";two-pole output: ~A" v0))
+ (if (fneq (mus-ycoeff gen 1) .7) (snd-display ";2p ycoeff 1 .7: ~A" gen))
(set! (mus-ycoeff gen 1) .1)
- (if (fneq (mus-ycoeff gen 1) .1) (snd-display #__line__ ";2p set ycoeff 1 .1: ~A" gen))
- (if (fneq (mus-xcoeff gen 0) .4) (snd-display #__line__ ";2p xcoeff 0 .4: ~A" gen))
+ (if (fneq (mus-ycoeff gen 1) .1) (snd-display ";2p set ycoeff 1 .1: ~A" gen))
+ (if (fneq (mus-xcoeff gen 0) .4) (snd-display ";2p xcoeff 0 .4: ~A" gen))
(set! (mus-xcoeff gen 0) .3)
- (if (fneq (mus-xcoeff gen 0) .3) (snd-display #__line__ ";2p set xcoeff 0 .3: ~A" gen))
+ (if (fneq (mus-xcoeff gen 0) .3) (snd-display ";2p set xcoeff 0 .3: ~A" gen))
(set! (mus-xcoeff gen 0) 1.0)
(let ((r (mus-scaler gen)))
(set! (mus-frequency gen) 500.0)
- (if (ffneq (mus-frequency gen) 500.0) (snd-display #__line__ ";set mus-frequency two-pole: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) r) (snd-display #__line__ ";set mus-frequency two-pole hit r: ~A" (mus-scaler gen)))
- (set! (mus-scaler gen) .99)
- (if (fneq (mus-scaler gen) .99) (snd-display #__line__ ";set mus-scaler two-pole: ~A" (mus-scaler gen)))
- (if (ffneq (mus-frequency gen) 500.0) (snd-display #__line__ ";set mus-scaler hit freq two-pole: ~A" (mus-frequency gen)))
- (let ((g3 (make-two-pole :radius .99 :frequency 500.0)))
- (if (or (fneq (mus-xcoeff gen 0) (mus-xcoeff g3 0))
- (fneq (mus-ycoeff gen 1) (mus-ycoeff g3 1))
- (fneq (mus-ycoeff gen 2) (mus-ycoeff g3 2)))
- (snd-display #__line__ ";two-pole setters: ~A ~A" gen g3)))))
+ (if (ffneq (mus-frequency gen) 500.0) (snd-display ";set mus-frequency two-pole: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) r) (snd-display ";set mus-frequency two-pole hit r: ~A" (mus-scaler gen))))
+ (set! (mus-scaler gen) .99)
+ (if (fneq (mus-scaler gen) .99) (snd-display ";set mus-scaler two-pole: ~A" (mus-scaler gen)))
+ (if (ffneq (mus-frequency gen) 500.0) (snd-display ";set mus-scaler hit freq two-pole: ~A" (mus-frequency gen)))
+ (let ((g3 (make-two-pole :radius .99 :frequency 500.0)))
+ (if (or (fneq (mus-xcoeff gen 0) (mus-xcoeff g3 0))
+ (fneq (mus-ycoeff gen 1) (mus-ycoeff g3 1))
+ (fneq (mus-ycoeff gen 2) (mus-ycoeff g3 2)))
+ (snd-display ";two-pole setters: ~A ~A" gen g3))))
(let ((gen (make-two-pole .4 .7 .3)))
(let ((val (gen 1.0)))
- (if (fneq val .4) (snd-display #__line__ ";a0->out 2pole: ~A" val))
+ (if (fneq val .4) (snd-display ";a0->out 2pole: ~A" val))
(set! val (gen 0.5))
- (if (fneq val -.08) (snd-display #__line__ ";a0->out 2pole (-0.08): ~A" val))
+ (if (fneq val -.08) (snd-display ";a0->out 2pole (-0.08): ~A" val))
(set! val (gen 1.0))
- (if (fneq val 0.336) (snd-display #__line__ ";a0->out 2pole (0.336): ~A" val))))
+ (if (fneq val 0.336) (snd-display ";a0->out 2pole (0.336): ~A" val))))
(let ((gen (make-oscil 440.0))
- (gen1 (make-oscil 440.0))
- (gen2 (make-oscil 440.0))
(v0 (make-float-vector 10))
- (v1 (make-float-vector 10))
- (v2 (make-float-vector 10)))
+ (v1 (make-float-vector 10)))
(print-and-check gen
"oscil"
"oscil freq: 440.000Hz, phase: 0.000")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (oscil gen 0.0))
- (set! (v1 i) (mus-apply gen1 0.0 0.0)))
- (fill-float-vector v2 (if (oscil? gen2) (oscil gen2 0.0) -1.0))
- (if (not (vequal v0 v2)) (snd-display #__line__ ";map oscil: ~A ~A" v0 v2))
- (if (not (oscil? gen)) (snd-display #__line__ ";~A not oscil?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";oscil phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";oscil frequency: ~F?" (mus-frequency gen)))
- (if (not (= (mus-length gen) 1)) (snd-display #__line__ ";oscil cosines: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.125) (fneq (v0 8) 0.843)) (snd-display #__line__ ";oscil output: ~A" v0))
+ (let ((gen1 (make-oscil 440.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (oscil gen 0.0))
+ (set! (v1 i) (mus-apply gen1 0.0 0.0))))
+ (let ((v2 (make-float-vector 10)))
+ (let ((gen2 (make-oscil 440.0)))
+ (fill-float-vector v2 (if (oscil? gen2) (oscil gen2 0.0) -1.0)))
+ (if (not (vequal v0 v2)) (snd-display ";map oscil: ~A ~A" v0 v2)))
+ (if (not (oscil? gen)) (snd-display ";~A not oscil?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";oscil phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";oscil frequency: ~F?" (mus-frequency gen)))
+ (if (not (= (mus-length gen) 1)) (snd-display ";oscil cosines: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.125) (fneq (v0 8) 0.843)) (snd-display ";oscil output: ~A" v0))
(set! (mus-phase gen) 0.0)
- (if (fneq (mus-phase gen) 0.0) (snd-display #__line__ ";oscil set-phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-phase gen) 0.0) (snd-display ";oscil set-phase: ~F?" (mus-phase gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";oscil set-frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";oscil set-frequency: ~F?" (mus-frequency gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";mus-apply oscil at ~D: ~A ~A?" i (v0 i) (v1 i))))
+ (snd-display ";mus-apply oscil at ~D: ~A ~A?" i (v0 i) (v1 i))))
(if (fneq (mus-apply) 0.0)
- (snd-display #__line__ ";(mus-apply): ~A" (mus-apply))))
+ (snd-display ";(mus-apply): ~A" (mus-apply))))
;; we can't (or don't anyway) guarantee optimized arg order evaluation so:
(let ((o (make-oscil 1000.0))
@@ -14004,8 +13558,8 @@ EDITS: 2
(hi)
(let ((v1 (hi)))
- (if (and (not (mus-arrays-equal? v v1))
- (not (mus-arrays-equal? v2 v1)))
+ (if (not (or (mus-arrays-equal? v v1)
+ (mus-arrays-equal? v2 v1)))
(format *stderr* ":orig: ~A~%; v1: ~A~%; v2: ~A~%" v v1 v2))))))
(test-fm-components)
(osc-opt)
@@ -14025,7 +13579,7 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (+ (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";oscil +-: ~A" mx)))
+ (snd-display ";oscil +-: ~A" mx)))
(let ((gen1 (make-oscil 100.0 (* pi 0.5)))
(gen2 (make-oscil -100.0 (* pi 0.5)))
@@ -14034,25 +13588,25 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (- (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";cosil +-: ~A" mx)))
+ (snd-display ";cosil +-: ~A" mx)))
(let ((frqs (float-vector 0.0 0.0))
(amps (float-vector 0.0 0.0))
(phs (float-vector 0.0 0.0)))
(let ((ob (make-oscil-bank frqs phs amps)))
- (if (not (oscil-bank? ob)) (snd-display #__line__ ";oscil-bank? ~A" ob))
- (if (not (equal? (mus-data ob) phs)) (snd-display #__line__ ";oscil-bank data: ~A ~A" (mus-data ob) phs))
+ (if (not (oscil-bank? ob)) (snd-display ";oscil-bank? ~A" ob))
+ (if (not (equal? (mus-data ob) phs)) (snd-display ";oscil-bank data: ~A ~A" (mus-data ob) phs))
(let ((x (oscil-bank ob)))
- (if (not (= x 0.0)) (snd-display #__line__ ";oscil-bank 0.0: ~A~%" x)))
+ (if (not (= x 0.0)) (snd-display ";oscil-bank 0.0: ~A~%" x)))
(set! (amps 0) 0.5)
(set! (amps 1) 0.2)
(let ((x (oscil-bank ob)))
- (if (not (= x 0.0)) (snd-display #__line__ ";oscil-bank 0.0 (amps): ~A~%" x)))
+ (if (not (= x 0.0)) (snd-display ";oscil-bank 0.0 (amps): ~A~%" x)))
(set! (frqs 0) .1)
(set! (frqs 1) .2)
(oscil-bank ob)
(let ((x (oscil-bank ob)))
- (if (not (morally-equal? x 0.08965057448242633)) (snd-display #__line__ ";oscil-bank 0.09: ~A~%" x)))))
+ (if (not (morally-equal? x 0.08965057448242633)) (snd-display ";oscil-bank 0.09: ~A~%" x)))))
(fm-test (make-oscil))
(fm-test (make-nrxysin))
@@ -14073,7 +13627,7 @@ EDITS: 2
(let ((oval (oscil gen .1))
(mval (mus-run gen1 .1)))
(if (fneq oval mval)
- (snd-display #__line__ ";mus-run ~A but oscil ~A?" mval oval)))))
+ (snd-display ";mus-run ~A but oscil ~A?" mval oval)))))
(let ((gen (make-oscil 440.0))
(gen1 (make-oscil 440.0))
@@ -14087,11 +13641,11 @@ EDITS: 2
(set! (v0 i) (oscil gen (* fm-index (oscil gen1 0.0))))
(set! (v1 i) (mus-apply gen2 (* fm-index (mus-apply gen3 0.0 0.0)) 0.0)))
(if (or (fneq (v0 1) 0.125) (fneq (v0 6) 0.830) (fneq (v0 8) 0.987))
- (snd-display #__line__ ";oscil fm output: ~A" v0))
+ (snd-display ";oscil fm output: ~A" v0))
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";mus-apply fm oscil at ~D: ~A ~A?" i (v0 i) (v1 i)))))
+ (snd-display ";mus-apply fm oscil at ~D: ~A ~A?" i (v0 i) (v1 i)))))
(test-gen-equal (make-oscil 440.0) (make-oscil 440.0) (make-oscil 100.0))
(test-gen-equal (make-oscil 440.0) (make-oscil 440.0) (make-oscil 440.0 1.0))
@@ -14104,7 +13658,7 @@ EDITS: 2
((= i 10))
(set! (v0 i) (gen 0.0 (* pm-index (gen1 0.0)))))
(if (or (fneq (v0 1) 0.367) (fneq (v0 6) 0.854) (fneq (v0 8) 0.437))
- (snd-display #__line__ ";oscil pm output: ~A" v0)))
+ (snd-display ";oscil pm output: ~A" v0)))
(let ((gen (make-oscil 440.0)))
(do ((i 0 (+ i 1)))
@@ -14112,7 +13666,7 @@ EDITS: 2
(let ((val1 (sin (mus-phase gen)))
(val2 (gen 0.0)))
(if (fneq val1 val2)
- (snd-display #__line__ ";oscil: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";oscil: ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-oscil 440.0 :initial-phase (* pi 0.5)))
(incr (/ (* 2 pi 440.0) 22050.0)))
@@ -14122,7 +13676,7 @@ EDITS: 2
(let ((val1 (cos a))
(val2 (gen 0.0)))
(if (fneq val1 val2)
- (snd-display #__line__ ";oscil (cos): ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";oscil (cos): ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-oscil 0.0))
(gen1 (make-oscil 40.0))
@@ -14133,7 +13687,7 @@ EDITS: 2
(let ((val1 (sin (sin a)))
(val2 (oscil gen 0.0 (oscil gen1 0.0))))
(if (fneq val1 val2)
- (snd-display #__line__ ";oscil pm: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";oscil pm: ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-oscil 0.0))
(gen1 (make-oscil 40.0))
@@ -14147,7 +13701,7 @@ EDITS: 2
(val2 (oscil gen (oscil gen1 0.0))))
(set! a1 (+ a1 fm))
(if (fneq val1 val2)
- (snd-display #__line__ ";oscil fm: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";oscil fm: ~A: ~A ~A" i val1 val2)))))
(let ()
(define (oscil-1-1)
@@ -14165,7 +13719,7 @@ EDITS: 2
(set! (v1 i) (oscil osc)))
(if (not (equal? v1 v2))
- (snd-display #__line__ ";oscil-1 shadowing test1: ~A ~A" v1 v2)))))
+ (snd-display ";oscil-1 shadowing test1: ~A ~A" v1 v2)))))
(define (oscil-1-2)
(define (ho-1 osc v i)
@@ -14183,7 +13737,7 @@ EDITS: 2
((= i 10))
(ho-1 o1 v1 i))
(if (not (equal? v1 v2))
- (snd-display #__line__ ";oscil-1 shadowing test2: ~A ~A" v1 v2))))
+ (snd-display ";oscil-1 shadowing test2: ~A ~A" v1 v2))))
(define (oscil-1-3)
(define (ho)
@@ -14203,7 +13757,7 @@ EDITS: 2
((= i 10))
(set! (v1 i) (o1)))
(if (not (equal? v1 v2))
- (snd-display #__line__ ";oscil-1 shadowing test3: ~A ~A" v1 v2))))
+ (snd-display ";oscil-1 shadowing test3: ~A ~A" v1 v2))))
(oscil-1-1)
(oscil-1-2)
@@ -14212,25 +13766,27 @@ EDITS: 2
(let ((var (catch #t (lambda () (mus-location (make-oscil))) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";mus-location bad gen: ~A" var)))
+ (snd-display ";mus-location bad gen: ~A" var)))
(let ((var (catch #t (lambda () (set! (mus-location (make-oscil)) 0)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";set mus-location bad gen: ~A" var)))
+ (snd-display ";set mus-location bad gen: ~A" var)))
(let ((var (catch #t (lambda () (set! (mus-scaler (make-oscil)) 0)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";set mus-scaler bad gen: ~A" var)))
+ (snd-display ";set mus-scaler bad gen: ~A" var)))
(let ((var (catch #t (lambda () (mus-frequency (make-one-pole))) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";mus-frequency bad gen: ~A" var)))
+ (snd-display ";mus-frequency bad gen: ~A" var)))
(let ((var (catch #t (lambda () (set! (mus-frequency (make-one-pole)) 0)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";set mus-frequency bad gen: ~A" var)))
- (let ((var (catch #t (lambda () (make-delay (* 1024 1024 40))) (lambda args args))))
+ (snd-display ";set mus-frequency bad gen: ~A" var)))
+ (let ((var (catch #t (lambda () (make-delay 41943040)) ;(* 1024 1024 40)
+ (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-delay huge line: ~A" var)))
- (let ((var (catch #t (lambda () (make-delay 32 :max-size (* 1024 1024 40))) (lambda args args))))
+ (snd-display ";make-delay huge line: ~A" var)))
+ (let ((var (catch #t (lambda () (make-delay 32 :max-size 41943040)) ;(* 1024 1024 40))
+ (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-delay huge line: ~A" var)))
+ (snd-display ";make-delay huge line: ~A" var)))
(let ((size 1000))
@@ -14254,7 +13810,7 @@ EDITS: 2
(let ((v1 (with-sound ((make-float-vector size) :srate 441000) (test-pm 0 size 20 1 1 1)))
(v2 (with-sound ((make-float-vector size) :srate 441000) (test-fm 0 size 20 1 1 1))))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";fm/pm peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
+ (snd-display ";fm/pm peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -14263,30 +13819,30 @@ EDITS: 2
(let ((v1 (with-sound ((make-float-vector size) :srate 441000) (test-pm 0 size 20 1 ratio index)))
(v2 (with-sound ((make-float-vector size) :srate 441000) (test-fm 0 size 20 1 ratio index))))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";fm/pm peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
+ (snd-display ";fm/pm peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
(let ((gen (make-ncos 440.0 10))
- (v0 (make-float-vector 10))
- (gen1 (make-ncos 440.0 10))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"ncos"
"ncos freq: 440.000Hz, phase: 0.000, n: 10")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (ncos gen 0.0)))
- (fill-float-vector v1 (if (ncos? gen1) (ncos gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map ncos: ~A ~A" v0 v1))
- (if (not (ncos? gen)) (snd-display #__line__ ";~A not ncos?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";ncos phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";ncos frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) .1) (snd-display #__line__ ";ncos scaler: ~F?" (mus-scaler gen)))
- (if (not (= (mus-length gen) 10)) (snd-display #__line__ ";ncos n: ~D?" (mus-length gen)))
- (if (not (= (mus-length gen) 10)) (snd-display #__line__ ";ncos length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.722) (fneq (v0 8) -0.143)) (snd-display #__line__ ";ncos output: ~A" v0))
- (set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";ncos set-scaler: ~F?" (mus-scaler gen)))
- (set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display #__line__ ";set ncos n: ~D?" (mus-length gen)))
- (if (fneq (mus-scaler gen) .2) (snd-display #__line__ ";set n->scaler: ~A" (mus-scaler gen))))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-ncos 440.0 10)))
+ (fill-float-vector v1 (if (ncos? gen1) (ncos gen1 0.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map ncos: ~A ~A" v0 v1)))
+ (if (not (ncos? gen)) (snd-display ";~A not ncos?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";ncos phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";ncos frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) .1) (snd-display ";ncos scaler: ~F?" (mus-scaler gen)))
+ (if (not (= (mus-length gen) 10)) (snd-display ";ncos n: ~D?" (mus-length gen)))
+ (if (not (= (mus-length gen) 10)) (snd-display ";ncos length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.722) (fneq (v0 8) -0.143)) (snd-display ";ncos output: ~A" v0))
+ (set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display ";ncos set-scaler: ~F?" (mus-scaler gen)))
+ (set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display ";set ncos n: ~D?" (mus-length gen)))
+ (if (fneq (mus-scaler gen) .2) (snd-display ";set n->scaler: ~A" (mus-scaler gen))))
(test-gen-equal (make-ncos 440.0 3) (make-ncos 440.0 3) (make-ncos 440.0 5))
(test-gen-equal (make-ncos 440.0 3) (make-ncos 440.0 3) (make-ncos 400.0 3))
@@ -14304,7 +13860,7 @@ EDITS: 2
0.5)))))
(val2 (gen 0.0)))
(if (> (abs (- val1 val2)) .002)
- (snd-display #__line__ ";ncos: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";ncos: ~A: ~A ~A" i val1 val2)))))
(let ((gen1 (make-ncos 100.0 10))
(gen2 (make-ncos -100.0 10))
@@ -14313,7 +13869,7 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (- (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";ncos +-: ~A" mx)))
+ (snd-display ";ncos +-: ~A" mx)))
(test-simple-ncos 1)
(test-simple-ncos 3)
@@ -14321,27 +13877,27 @@ EDITS: 2
(let ((gen (make-nsin 440.0 10))
- (v0 (make-float-vector 10))
- (gen1 (make-nsin 440.0 10))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"nsin"
"nsin freq: 440.000Hz, phase: 0.000, n: 10")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (nsin gen 0.0)))
- (fill-float-vector v1 (if (nsin? gen1) (nsin gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map nsin: ~A ~A" v0 v1))
- (if (not (nsin? gen)) (snd-display #__line__ ";~A not nsin?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";nsin phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";nsin frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) .1315) (snd-display #__line__ ";nsin scaler: ~F?" (mus-scaler gen)))
- (if (not (= (mus-length gen) 10)) (snd-display #__line__ ";nsin n: ~D?" (mus-length gen)))
- (if (not (= (mus-length gen) 10)) (snd-display #__line__ ";nsin length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.784) (fneq (v0 8) 0.181)) (snd-display #__line__ ";nsin output: ~A" v0))
- (set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";nsin set-scaler: ~F?" (mus-scaler gen)))
- (set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display #__line__ ";set nsin n: ~D?" (mus-length gen)))
- (if (fneq (mus-scaler gen) .2525) (snd-display #__line__ ";set sines->scaler: ~A" (mus-scaler gen))))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-nsin 440.0 10)))
+ (fill-float-vector v1 (if (nsin? gen1) (nsin gen1 0.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map nsin: ~A ~A" v0 v1)))
+ (if (not (nsin? gen)) (snd-display ";~A not nsin?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";nsin phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";nsin frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) .1315) (snd-display ";nsin scaler: ~F?" (mus-scaler gen)))
+ (if (not (= (mus-length gen) 10)) (snd-display ";nsin n: ~D?" (mus-length gen)))
+ (if (not (= (mus-length gen) 10)) (snd-display ";nsin length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.784) (fneq (v0 8) 0.181)) (snd-display ";nsin output: ~A" v0))
+ (set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display ";nsin set-scaler: ~F?" (mus-scaler gen)))
+ (set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display ";set nsin n: ~D?" (mus-length gen)))
+ (if (fneq (mus-scaler gen) .2525) (snd-display ";set sines->scaler: ~A" (mus-scaler gen))))
(test-gen-equal (make-nsin 440.0 3) (make-nsin 440.0 3) (make-nsin 440.0 5))
(test-gen-equal (make-nsin 440.0 3) (make-nsin 440.0 3) (make-nsin 400.0 3))
@@ -14353,33 +13909,33 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (+ (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";nsin +-: ~A" mx)))
+ (snd-display ";nsin +-: ~A" mx)))
(test-simple-nsin 1)
(test-simple-nsin 3)
(test-simple-nsin 10)
- (let ((gen (make-nrxysin 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-nrxysin 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-nrxysin 440.0)))
(print-and-check gen
"nrxysin"
"nrxysin frequency: 440.000, ratio: 1.000, phase: 0.000, n: 1, r: 0.500")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (nrxysin gen 0.0)))
- (fill-float-vector v1 (if (nrxysin? gen1) (nrxysin gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map nrxysin: ~A ~A" v0 v1))
- (if (not (nrxysin? gen)) (snd-display #__line__ ";~A not nrxysin?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";nrxysin phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";nrxysin frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";mus-scaler (a) nrxysin: ~A" (mus-scaler gen)))
+ (let ((v0 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (nrxysin gen 0.0)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-nrxysin 440.0)))
+ (fill-float-vector v1 (if (nrxysin? gen1) (nrxysin gen1 0.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map nrxysin: ~A ~A" v0 v1))))
+ (if (not (nrxysin? gen)) (snd-display ";~A not nrxysin?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";nrxysin phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";nrxysin frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";mus-scaler (a) nrxysin: ~A" (mus-scaler gen)))
(set! (mus-scaler gen) 0.75)
- (if (fneq (mus-scaler gen) 0.75) (snd-display #__line__ ";mus-scaler (set a) nrxysin: ~A" (mus-scaler gen)))
- (if (not (= (mus-length gen) 1)) (snd-display #__line__ ";mus-length nrxysin: ~A" (mus-length gen)))
- (if (fneq (mus-offset gen) 1.0) (snd-display #__line__ ";mus-offset nrxysin: ~A" (mus-offset gen))))
+ (if (fneq (mus-scaler gen) 0.75) (snd-display ";mus-scaler (set a) nrxysin: ~A" (mus-scaler gen)))
+ (if (not (= (mus-length gen) 1)) (snd-display ";mus-length nrxysin: ~A" (mus-length gen)))
+ (if (fneq (mus-offset gen) 1.0) (snd-display ";mus-offset nrxysin: ~A" (mus-offset gen))))
(test-gen-equal (make-nrxysin 440.0) (make-nrxysin 440.0) (make-nrxysin 100.0))
(test-gen-equal (make-nrxysin 440.0) (make-nrxysin 440.0) (make-nrxysin 440.0 1.5))
@@ -14392,29 +13948,29 @@ EDITS: 2
((= i 10))
(outa i (nrxysin gen)))))
(if (not (vequal v1 (float-vector 0.000 0.671 0.637 0.186 0.017 0.169 0.202 0.048 0.007 0.105)))
- (snd-display #__line__ ";ws nrxysin output: ~A" v1)))
+ (snd-display ";ws nrxysin output: ~A" v1)))
- (let ((gen (make-nrxycos 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-nrxycos 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-nrxycos 440.0)))
(print-and-check gen
"nrxycos"
"nrxycos frequency: 440.000, ratio: 1.000, phase: 0.000, n: 1, r: 0.500")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (nrxycos gen 0.0)))
- (fill-float-vector v1 (if (nrxycos? gen1) (nrxycos gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map nrxycos: ~A ~A" v0 v1))
- (if (not (nrxycos? gen)) (snd-display #__line__ ";~A not nrxycos?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";nrxycos phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";nrxycos frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";mus-scaler (a) nrxycos: ~A" (mus-scaler gen)))
+ (let ((v0 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (nrxycos gen 0.0)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-nrxycos 440.0)))
+ (fill-float-vector v1 (if (nrxycos? gen1) (nrxycos gen1 0.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map nrxycos: ~A ~A" v0 v1))))
+ (if (not (nrxycos? gen)) (snd-display ";~A not nrxycos?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";nrxycos phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";nrxycos frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";mus-scaler (a) nrxycos: ~A" (mus-scaler gen)))
(set! (mus-scaler gen) 0.75)
- (if (fneq (mus-scaler gen) 0.75) (snd-display #__line__ ";mus-scaler (set a) nrxycos: ~A" (mus-scaler gen)))
- (if (not (= (mus-length gen) 1)) (snd-display #__line__ ";mus-length nrxycos: ~A" (mus-length gen)))
- (if (fneq (mus-offset gen) 1.0) (snd-display #__line__ ";mus-offset nrxycos: ~A" (mus-offset gen))))
+ (if (fneq (mus-scaler gen) 0.75) (snd-display ";mus-scaler (set a) nrxycos: ~A" (mus-scaler gen)))
+ (if (not (= (mus-length gen) 1)) (snd-display ";mus-length nrxycos: ~A" (mus-length gen)))
+ (if (fneq (mus-offset gen) 1.0) (snd-display ";mus-offset nrxycos: ~A" (mus-offset gen))))
(test-gen-equal (make-nrxycos 440.0) (make-nrxycos 440.0) (make-nrxycos 100.0))
(test-gen-equal (make-nrxycos 440.0) (make-nrxycos 440.0) (make-nrxycos 440.0 1.5))
@@ -14426,32 +13982,32 @@ EDITS: 2
((= i 10))
(outa i (nrxycos gen)))))))
(if (not (vequal v1 (float-vector 1.000 0.602 -0.067 -0.242 -0.007 0.071 -0.087 -0.128 -0.007 0.012)))
- (snd-display #__line__ ";ws nrxycos output: ~A" v1)))
+ (snd-display ";ws nrxycos output: ~A" v1)))
(let ((gen (make-asymmetric-fm 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-asymmetric-fm 440.0))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"asymmetric-fm"
"asymmetric-fm freq: 440.000Hz, phase: 0.000, ratio: 1.000, r: 1.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (asymmetric-fm gen 0.0)))
- (fill-float-vector v1 (if (asymmetric-fm? gen1) (asymmetric-fm gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map asymmetric-fm: ~A ~A" v0 v1))
- (if (not (asymmetric-fm? gen)) (snd-display #__line__ ";~A not asymmetric-fm?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";asymmetric-fm phase: ~F?" (mus-phase gen)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-asymmetric-fm 440.0)))
+ (fill-float-vector v1 (if (asymmetric-fm? gen1) (asymmetric-fm gen1 0.0) -1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map asymmetric-fm: ~A ~A" v0 v1)))
+ (if (not (asymmetric-fm? gen)) (snd-display ";~A not asymmetric-fm?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";asymmetric-fm phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";set! asymmetric-fm phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";asymmetric-fm frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";set! asymmetric-fm phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";asymmetric-fm frequency: ~F?" (mus-frequency gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";set! asymmetric-fm frequency: ~F?" (mus-frequency gen)))
- (if (or (fneq (v0 2) 0.969) (fneq (v0 8) .538)) (snd-display #__line__ ";asymmetric-fm output: ~A" v0))
- (if (fneq (mus-scaler gen) 1.0) (snd-display #__line__ ";mus-scaler (r) asymmetric-fm: ~A" (mus-scaler gen)))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";set! asymmetric-fm frequency: ~F?" (mus-frequency gen)))
+ (if (or (fneq (v0 2) 0.969) (fneq (v0 8) .538)) (snd-display ";asymmetric-fm output: ~A" v0))
+ (if (fneq (mus-scaler gen) 1.0) (snd-display ";mus-scaler (r) asymmetric-fm: ~A" (mus-scaler gen)))
(set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";mus-scaler (set r) asymmetric-fm: ~A" (mus-scaler gen)))
- (if (fneq (mus-offset gen) 1.0) (snd-display #__line__ ";mus-offset asymmetric-fm: ~A" (mus-offset gen))))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";mus-scaler (set r) asymmetric-fm: ~A" (mus-scaler gen)))
+ (if (fneq (mus-offset gen) 1.0) (snd-display ";mus-offset asymmetric-fm: ~A" (mus-offset gen))))
(test-gen-equal (make-asymmetric-fm 440.0) (make-asymmetric-fm 440.0) (make-asymmetric-fm 100.0))
(test-gen-equal (make-asymmetric-fm 440.0) (make-asymmetric-fm 440.0) (make-asymmetric-fm 440.0 1.0))
@@ -14466,7 +14022,7 @@ EDITS: 2
(os (oscil gen2 0.0)))
(if (fneq ss os)
(begin
- (snd-display #__line__ ";asymmetric-fm 1: ~A: os: ~A ss: ~A" i os ss)
+ (snd-display ";asymmetric-fm 1: ~A: os: ~A ss: ~A" i os ss)
(set! happy #f))))))
(for-each
@@ -14479,7 +14035,7 @@ EDITS: 2
((= i 1000))
(outa i (asymmetric-fm gen index))))))))
(if (> (abs (- peak 1.0)) .1)
- (snd-display #__line__ ";asymmetric-fm peak: ~A, index: ~A, r: ~A" peak index r))))
+ (snd-display ";asymmetric-fm peak: ~A, index: ~A, r: ~A" peak index r))))
(list -10.0 -1.5 -0.5 0.5 1.0 1.5 10.0)))
(list 1.0 3.0 10.0))
@@ -14501,7 +14057,7 @@ EDITS: 2
(= i 512)))
(if (> (abs (- (spectr1 i) (spectr2 i))) .02)
(begin
- (snd-display #__line__ ";asymmetric-fm 2: ~A: ~A ~A" i (spectr1 i) (spectr2 i))
+ (snd-display ";asymmetric-fm 2: ~A: ~A ~A" i (spectr1 i) (spectr2 i))
(set! happy #f))))))
(let ((gen (make-asymmetric-fm 40.0 0.0 1.0 0.1))
@@ -14522,7 +14078,7 @@ EDITS: 2
(cos (+ a (* index sr (sin mth)))))))
(if (or (fneq val1 val2)
(fneq val1 val3))
- (snd-display #__line__ ";asyfm by hand: ~A: ~A ~A ~A" i val1 val2 val3)))))))
+ (snd-display ";asyfm by hand: ~A: ~A ~A ~A" i val1 val2 val3)))))))
(let ((float-vector0 (make-float-vector 2048))
(float-vector1 (make-float-vector 2048))
@@ -14533,16 +14089,18 @@ EDITS: 2
(set! (float-vector0 i) (asymmetric-fm gen3 2.0))
(set! (float-vector1 i) (asymmetric-fm gen4 2.0)))
(let ((spectr1 (snd-spectrum float-vector0 rectangular-window 2048 #t))
- (spectr2 (snd-spectrum float-vector1 rectangular-window 2048 #t))
(s1-loc 0)
(s2-loc 0))
- (do ((i 1 (+ i 1)))
+ (do ((spectr2 (snd-spectrum float-vector1 rectangular-window 2048 #t))
+ (i 1 (+ i 1)))
((= i 256))
- (if (< (abs (- 1.0 (spectr1 i))) .01) (set! s1-loc i))
- (if (< (abs (- 1.0 (spectr2 i))) .01) (set! s2-loc i)))
- (if (> s2-loc s1-loc) (snd-display #__line__ ";asymmetric-fm peaks: ~A ~A" s1-loc s2-loc))
- (let ((center (* (/ 22050 2048) .5 (+ s1-loc s2-loc))))
- (if (> (abs (- 1000 center)) 60) (snd-display #__line__ ";asymmetric-fm center: ~A" center)))
+ (if (within-.01? (spectr1 i)) ;(< (abs (- 1.0 (spectr1 i))) .01)
+ (set! s1-loc i))
+ (if (within-.01? (spectr2 i)) ;(< (abs (- 1.0 (spectr2 i))) .01)
+ (set! s2-loc i)))
+ (if (> s2-loc s1-loc) (snd-display ";asymmetric-fm peaks: ~A ~A" s1-loc s2-loc))
+ (let ((center (* 11025/1024 0.5 (+ s1-loc s2-loc)))) ;(* (/ 22050 2048) .5 (+ s1-loc s2-loc))
+ (if (> (abs (- 1000 center)) 60) (snd-display ";asymmetric-fm center: ~A" center)))
(set! (mus-scaler gen3) 0.5)
(do ((i 0 (+ i 1)))
((= i 2048))
@@ -14550,19 +14108,20 @@ EDITS: 2
(set! spectr1 (snd-spectrum float-vector0 rectangular-window 2048 #t))
(do ((i 1 (+ i 1)))
((= i 256))
- (if (< (abs (- 1.0 (spectr1 i))) .01) (set! s1-loc i)))
- (if (not (= s2-loc s1-loc)) (snd-display #__line__ ";asymmetric-fm set r peaks: ~A ~A" s1-loc s2-loc))
+ (if (within-.01? (spectr1 i)) ;(< (abs (- 1.0 (spectr1 i))) .01)
+ (set! s1-loc i)))
+ (if (not (= s2-loc s1-loc)) (snd-display ";asymmetric-fm set r peaks: ~A ~A" s1-loc s2-loc))
(do ((i 0 (+ i 1)))
((= i 2048))
(set! (float-vector0 i) (asymmetric-fm gen3 2.0)))
(snd-spectrum float-vector0 rectangular-window 2048 #t 0.0 #t)
(do ((i 1 (+ i 1)))
((= i 256))
- (if (< (abs (- 1.0 (float-vector0 i))) .01) (set! s1-loc i)))
- (if (not (= s2-loc s1-loc)) (snd-display #__line__ "asymmetric-fm set r in place peaks: ~A ~A" s1-loc s2-loc))))
+ (if (within-.01? (float-vector0 i)) ;(< (abs (- 1.0 (float-vector0 i))) .01)
+ (set! s1-loc i)))
+ (if (not (= s2-loc s1-loc)) (snd-display "asymmetric-fm set r in place peaks: ~A ~A" s1-loc s2-loc))))
- (let ((gen (make-asyfm :frequency 2000 :ratio .1)))
- (asyfm-I gen 0.0))
+ (asyfm-I (make-asyfm :frequency 2000 :ratio .1) 0.0)
(do ((i 2 (+ i 1)))
((= i 40))
@@ -14775,9 +14334,7 @@ EDITS: 2
(let ((gen (make-fir-filter 3 (float-vector .5 .25 .125)))
- (v0 (make-float-vector 10))
- (gen1 (make-fir-filter 3 (float-vector .5 .25 .125)))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"fir-filter"
"fir-filter order: 3, xs: [0.5 0.25 0.125]"
@@ -14786,22 +14343,24 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 10))
(set! (v0 i) (fir-filter gen 0.0)))
- (let ((inp 1.0))
- (fill-float-vector v1 (let ((val (if (fir-filter? gen1) (fir-filter gen1 inp) -1.0)))
- (set! inp 0.0)
- val)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map fir-filter: ~A ~A" v0 v1))
- (if (not (fir-filter? gen)) (snd-display #__line__ ";~A not fir-filter?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";fir-filter length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.25) (fneq (v0 2) .125)) (snd-display #__line__ ";fir-filter output: ~A" v0))
+ (let ((v1 (make-float-vector 10)))
+ (let ((inp 1.0)
+ (gen1 (make-fir-filter 3 (float-vector .5 .25 .125))))
+ (fill-float-vector v1 (let ((val (if (fir-filter? gen1) (fir-filter gen1 inp) -1.0)))
+ (set! inp 0.0)
+ val)))
+ (if (not (vequal v0 v1)) (snd-display ";map fir-filter: ~A ~A" v0 v1)))
+ (if (not (fir-filter? gen)) (snd-display ";~A not fir-filter?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";fir-filter length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.25) (fneq (v0 2) .125)) (snd-display ";fir-filter output: ~A" v0))
(let ((data (mus-xcoeffs gen)))
- (if (fneq (data 1) .25) (snd-display #__line__ ";fir-filter xcoeffs: ~A?" data)))
+ (if (fneq (data 1) .25) (snd-display ";fir-filter xcoeffs: ~A?" data)))
(let ((tag (catch #t (lambda () (mus-xcoeff gen 123)) (lambda args (car args)))))
(if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";xcoeff 123: ~A" tag)))
+ (snd-display ";xcoeff 123: ~A" tag)))
(let ((tag (catch #t (lambda () (mus-ycoeff gen 123)) (lambda args (car args)))))
(if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";fir ycoeff 123: ~A" tag))))
+ (snd-display ";fir ycoeff 123: ~A" tag))))
(test-gen-equal (let ((f1 (make-fir-filter 3 (float-vector .5 .25 .125)) )) (fir-filter f1 1.0) f1)
(let ((f2 (make-fir-filter 3 (float-vector .5 .25 .125)) )) (fir-filter f2 1.0) f2)
@@ -14829,17 +14388,17 @@ EDITS: 2
(fneq (data 10) 0.0)
(fneq (data 18) 0.166)
(fneq (data 89) 0.923))
- (snd-display #__line__ ";filter xcoeffs: ~A?" data))))
-
- (letrec ((make-f-filter (lambda (coeffs)
- (list coeffs (make-float-vector (length coeffs)))))
- (f-filter (lambda (flt x)
- (let* ((coeffs (car flt))
- (xs (cadr flt))
- (xlen (length xs)))
- (float-vector-move! xs (- xlen 1) (- xlen 2) #t)
- (set! (xs 0) x)
- (dot-product coeffs xs xlen)))))
+ (snd-display ";filter xcoeffs: ~A?" data))))
+
+ (let ((make-f-filter (lambda (coeffs)
+ (list coeffs (make-float-vector (length coeffs)))))
+ (f-filter (lambda (flt x)
+ (let* ((coeffs (car flt))
+ (xs (cadr flt))
+ (xlen (length xs)))
+ (float-vector-move! xs (- xlen 1) (- xlen 2) #t)
+ (set! (xs 0) x)
+ (dot-product coeffs xs xlen)))))
(let ((fir1 (make-fir-filter 3 (float-vector 1.0 0.4 0.1)))
(fir2 (make-f-filter (float-vector 1.0 0.4 0.1)))
(x 1.0)
@@ -14851,36 +14410,34 @@ EDITS: 2
(set! x 0.0)
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";f-filter ~A -> ~A ~A" i val1 val2)
+ (snd-display ";f-filter ~A -> ~A ~A" i val1 val2)
(set! happy #f)))))))
(let ((gen (make-spencer-filter)))
(if (not (fir-filter? gen))
- (snd-display #__line__ ";make-spencer-filter returns ~A?" gen)
+ (snd-display ";make-spencer-filter returns ~A?" gen)
(begin
- (if (not (= (mus-order gen) 15)) (snd-display #__line__ ";make-spencer-filter order ~A?" (mus-order gen)))
+ (if (not (= (mus-order gen) 15)) (snd-display ";make-spencer-filter order ~A?" (mus-order gen)))
(if (not (vequal (mus-xcoeffs gen) (float-vector -0.009 -0.019 -0.016 0.009 0.066 0.144 0.209 0.231 0.209 0.144 0.066 0.009 -0.016 -0.019 -0.009)))
- (snd-display #__line__ ";make-spencer-filter coeffs: ~A" (mus-xcoeffs gen))))))
+ (snd-display ";make-spencer-filter coeffs: ~A" (mus-xcoeffs gen))))))
(let ((flt (make-savitzky-golay-filter 5 2)))
(if (not (vequal (mus-xcoeffs flt) (float-vector -0.086 0.343 0.486 0.343 -0.086)))
- (snd-display #__line__ ";sg 5 2: ~A" (mus-xcoeffs flt))))
+ (snd-display ";sg 5 2: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 11 2)))
(if (not (vequal (mus-xcoeffs flt) (float-vector -0.084 0.021 0.103 0.161 0.196 0.207 0.196 0.161 0.103 0.021 -0.084)))
- (snd-display #__line__ ";sg 11 2: ~A" (mus-xcoeffs flt))))
+ (snd-display ";sg 11 2: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 11 4)))
(if (not (vequal (mus-xcoeffs flt) (float-vector 0.042 -0.105 -0.023 0.140 0.280 0.333 0.280 0.140 -0.023 -0.105 0.042)))
- (snd-display #__line__ ";sg 11 4: ~A" (mus-xcoeffs flt))))
+ (snd-display ";sg 11 4: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 25 2)))
(if (not (vequal (mus-xcoeffs flt) (float-vector -0.049 -0.027 -0.006 0.012 0.028 0.043 0.055 0.066 0.075 0.082 0.086
0.089 0.090 0.089 0.086 0.082 0.075 0.066 0.055 0.043
0.028 0.012 -0.006 -0.027 -0.049)))
- (snd-display #__line__ ";sg 25 2: ~A" (mus-xcoeffs flt))))
+ (snd-display ";sg 25 2: ~A" (mus-xcoeffs flt))))
(let ((gen (make-iir-filter 3 (float-vector .5 .25 .125)))
- (v0 (make-float-vector 10))
- (gen1 (make-iir-filter 3 (float-vector .5 .25 .125)))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"iir-filter"
"iir-filter order: 3, ys: [0.5 0.25 0.125]"
@@ -14889,22 +14446,24 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 10))
(set! (v0 i) (iir-filter gen 0.0)))
- (let ((inp 1.0))
- (fill-float-vector v1 (let ((val (if (iir-filter? gen1) (iir-filter gen1 inp) -1.0)))
- (set! inp 0.0)
- val)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map iir-filter: ~A ~A" v0 v1))
- (if (not (iir-filter? gen)) (snd-display #__line__ ";~A not iir-filter?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";iir-filter length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) -0.25) (fneq (v0 2) -.062)) (snd-display #__line__ ";iir-filter output: ~A" v0))
+ (let ((v1 (make-float-vector 10)))
+ (let ((inp 1.0)
+ (gen1 (make-iir-filter 3 (float-vector .5 .25 .125))))
+ (fill-float-vector v1 (let ((val (if (iir-filter? gen1) (iir-filter gen1 inp) -1.0)))
+ (set! inp 0.0)
+ val)))
+ (if (not (vequal v0 v1)) (snd-display ";map iir-filter: ~A ~A" v0 v1)))
+ (if (not (iir-filter? gen)) (snd-display ";~A not iir-filter?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";iir-filter length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) -0.25) (fneq (v0 2) -.062)) (snd-display ";iir-filter output: ~A" v0))
(let ((data (mus-ycoeffs gen)))
- (if (fneq (data 1) .25) (snd-display #__line__ ";iir-filter ycoeffs: ~A?" data)))
+ (if (fneq (data 1) .25) (snd-display ";iir-filter ycoeffs: ~A?" data)))
(let ((tag (catch #t (lambda () (mus-ycoeff gen 123)) (lambda args (car args)))))
(if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";ycoeff 123: ~A" tag)))
+ (snd-display ";ycoeff 123: ~A" tag)))
(let ((tag (catch #t (lambda () (mus-xcoeff gen 123)) (lambda args (car args)))))
(if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";iir xcoeff 123: ~A" tag))))
+ (snd-display ";iir xcoeff 123: ~A" tag))))
(test-gen-equal (let ((f1 (make-iir-filter 3 (float-vector .5 .25 .125)))) (iir-filter f1 1.0) f1)
(let ((f2 (make-iir-filter 3 (float-vector .5 .25 .125)) )) (iir-filter f2 1.0) f2)
@@ -14913,52 +14472,51 @@ EDITS: 2
(let ((f2 (make-iir-filter 3 (float-vector .5 .25 .125)) )) (iir-filter f2 1.0) f2)
(let ((f3 (make-iir-filter 2 (float-vector .5 .25)))) (iir-filter f3 1.0) f3))
- (let ((gen (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125)))
- (v0 (make-float-vector 10))
- (gen1 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125)))
- (v1 (make-float-vector 10))
- (gen2 (make-biquad .1 .2 .3 .4 .5)))
+ (let ((gen (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125))))
(print-and-check gen
"filter"
- "filter order: 3, xs: [0.5 0.25 0.125], ys: [0.5 0.25 0.125]"
- )
- (set! (v0 0) (filter gen 1.0))
- (do ((i 1 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (filter gen 0.0)))
- (let ((inp 1.0))
- (fill-float-vector v1 (let ((val (if (filter? gen1) (filter gen1 inp) -1.0)))
- (set! inp 0.0)
- val)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map filter: ~A ~A" v0 v1))
- (if (not (filter? gen)) (snd-display #__line__ ";~A not filter?" gen))
- (if (not (= (mus-length gen) 3)) (snd-display #__line__ ";filter length: ~D?" (mus-length gen)))
- (if (or (fneq (v0 1) 0.125) (fneq (v0 2) .031)) (snd-display #__line__ ";filter output: ~A" v0))
- (if (not (filter? gen2)) (snd-display #__line__ ";make-biquad: ~A" gen2))
+ "filter order: 3, xs: [0.5 0.25 0.125], ys: [0.5 0.25 0.125]")
+ (let ((v0 (make-float-vector 10))
+ (gen2 (make-biquad .1 .2 .3 .4 .5)))
+ (set! (v0 0) (filter gen 1.0))
+ (do ((i 1 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (filter gen 0.0)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125))))
+ (let ((inp 1.0))
+ (fill-float-vector v1 (let ((val (if (filter? gen1) (filter gen1 inp) -1.0)))
+ (set! inp 0.0)
+ val))))
+ (if (not (vequal v0 v1)) (snd-display ";map filter: ~A ~A" v0 v1)))
+ (if (not (filter? gen)) (snd-display ";~A not filter?" gen))
+ (if (not (= (mus-length gen) 3)) (snd-display ";filter length: ~D?" (mus-length gen)))
+ (if (or (fneq (v0 1) 0.125) (fneq (v0 2) .031)) (snd-display ";filter output: ~A" v0))
+ (if (not (filter? gen2)) (snd-display ";make-biquad: ~A" gen2)))
(let ((xs (mus-xcoeffs gen))
(ys (mus-ycoeffs gen)))
- (if (or (not (equal? xs (float-vector .5 .25 .125)))
- (not (equal? xs ys)))
- (snd-display #__line__ ";mus-xcoeffs: ~A ~A?" xs ys))))
+ (if (not (and (equal? xs (float-vector .5 .25 .125))
+ (equal? xs ys)))
+ (snd-display ";mus-xcoeffs: ~A ~A?" xs ys))))
(let ((var (catch #t (lambda () (make-filter :order 2 :xcoeffs (float-vector 1.0 0.5) :ycoeffs (float-vector 2.0 1.0 0.5))) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-filter bad coeffs: ~A" var)))
+ (snd-display ";make-filter bad coeffs: ~A" var)))
(let ((var (catch #t (lambda () (make-filter :order 0 :xcoeffs (float-vector 1.0 0.5))) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-filter bad order: ~A" var)))
+ (snd-display ";make-filter bad order: ~A" var)))
(let ((var (catch #t (lambda () (make-fir-filter :order 22 :xcoeffs (float-vector 1.0 0.5))) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-fir-filter bad coeffs: ~A" var)))
+ (snd-display ";make-fir-filter bad coeffs: ~A" var)))
(let ((var (catch #t (lambda () (make-iir-filter :order 22 :ycoeffs (float-vector 1.0 0.5))) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-iir-filter bad coeffs: ~A" var)))
+ (snd-display ";make-iir-filter bad coeffs: ~A" var)))
(let ((var (catch #t (lambda () (make-fir-filter -1)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-fir-filter bad order: ~A" var)))
+ (snd-display ";make-fir-filter bad order: ~A" var)))
(let ((var (make-filter :order 2 :ycoeffs (float-vector 1.0 0.5))))
(if (not (iir-filter? var))
- (snd-display #__line__ ";make-filter with only y: ~A" var)))
+ (snd-display ";make-filter with only y: ~A" var)))
(test-gen-equal (let ((f1 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125)))) (filter f1 1.0) f1)
(let ((f2 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125)))) (filter f2 1.0) f2)
@@ -14968,86 +14526,86 @@ EDITS: 2
(let ((f3 (make-filter 3 (float-vector .5 .5 .125) (float-vector .5 .25 .0625)))) (filter f3 1.0) f3))
(let ((fr (make-fir-filter 6 (float-vector 0 1 2 3 4 5))))
- (if (not (= (mus-length fr) 6)) (snd-display #__line__ ";filter-length: ~A" (mus-length fr))))
+ (if (not (= (mus-length fr) 6)) (snd-display ";filter-length: ~A" (mus-length fr))))
(let ((val (cascade->canonical (list (float-vector 1.0 0.0 0.0) (float-vector 1.0 0.5 0.25)))))
(if (not (vequal val (float-vector 1.000 0.500 0.250 0.000 0.000)))
- (snd-display #__line__ ";cas2can 0: ~A" val)))
+ (snd-display ";cas2can 0: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1.0 1.0 0.0) (float-vector 1.0 0.5 0.25)))))
(if (not (vequal val (float-vector 1.000 1.500 0.750 0.250 0.000)))
- (snd-display #__line__ ";cas2can 1: ~A" val)))
+ (snd-display ";cas2can 1: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1 0.8 0) (float-vector 1 1.4 0.65) (float-vector 1 0 0)))))
(if (not (vequal val (float-vector 1.000 2.200 1.770 0.520 0.000 0.000 0.000)))
- (snd-display #__line__ ";cascade->canonical: ~A" val)))
+ (snd-display ";cascade->canonical: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1 -0.9 0) (float-vector 1 1 0.74) (float-vector 1 -1.6 0.8)))))
(if (not (vequal val (float-vector 1.000 -1.500 0.480 -0.330 0.938 -0.533 0.000)))
- (snd-display #__line__ ";cascade->canonical 1: ~A" val)))
+ (snd-display ";cascade->canonical 1: ~A" val)))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
(pad-channel 0 10000)
(freq-sweep .45)
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.962 0.998 0.998 0.998 0.998 0.999 0.999 0.998 0.997 1.000)))
- (not (vequal sp (float-vector 0.963 0.999 0.999 0.999 0.999 0.999 1.000 1.000 0.998 0.997))))
- (snd-display #__line__ ";initial rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.962 0.998 0.998 0.998 0.998 0.999 0.999 0.998 0.997 1.000))
+ (vequal sp (float-vector 0.963 0.999 0.999 0.999 0.999 0.999 1.000 1.000 0.998 0.997))))
+ (snd-display ";initial rough spectrum: ~A" sp)))
- (let ((b (make-butter-high-pass 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
- (snd-display #__line__ ";butter high: ~A" v))
+ (let ((b (make-butter-high-pass 440.0)))
+ (let ((v (make-float-vector 10))
+ (d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0)))
+ (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
+ (snd-display ";butter high: ~A" v)))
(set! b (make-butter-high-pass 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000)))
- (not (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
- (snd-display #__line__ ";hp rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
+ (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
+ (snd-display ";hp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-low-pass 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
- (snd-display #__line__ ";butter low: ~A" v))
+ (let ((b (make-butter-low-pass 440.0)))
+ (let ((v (make-float-vector 10))
+ (d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0)))
+ (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
+ (snd-display ";butter low: ~A" v)))
(set! b (make-butter-low-pass 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";lp rough spectrum: ~A" sp)))
+ (snd-display ";lp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-band-pass 440.0 50.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.011 0.009 0.008 0.007 0.005)))
- (snd-display #__line__ ";butter bandpass: ~A" v))
+ (let ((b (make-butter-band-pass 440.0 50.0)))
+ (let ((v (make-float-vector 10))
+ (d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0)))
+ (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.011 0.009 0.008 0.007 0.005)))
+ (snd-display ";butter bandpass: ~A" v)))
(set! b (make-butter-band-pass 1000.0 500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 0.888 1.000 0.144 0.056 0.027 0.014 0.008 0.004 0.002 0.000)))
- (snd-display #__line__ ";bp rough spectrum: ~A" sp)))
+ (snd-display ";bp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-band-reject 440.0 50.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.993 -0.014 -0.013 -0.013 -0.012 -0.011 -0.009 -0.008 -0.007 -0.005)))
- (snd-display #__line__ ";butter bandstop: ~A" v))
+ (let ((b (make-butter-band-reject 440.0 50.0)))
+ (let ((v (make-float-vector 10))
+ (d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0)))
+ (if (not (vequal v (float-vector 0.993 -0.014 -0.013 -0.013 -0.012 -0.011 -0.009 -0.008 -0.007 -0.005)))
+ (snd-display ";butter bandstop: ~A" v)))
(set! b (make-butter-band-reject 1000.0 500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.662 0.687 0.953 0.980 0.989 0.994 0.997 0.997 0.997 1.000)))
- (not (vequal sp (float-vector 0.664 0.689 0.955 0.982 0.992 0.996 0.999 1.000 0.999 0.998))))
- (snd-display #__line__ ";bs rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.662 0.687 0.953 0.980 0.989 0.994 0.997 0.997 0.997 1.000))
+ (vequal sp (float-vector 0.664 0.689 0.955 0.982 0.992 0.996 0.999 1.000 0.999 0.998))))
+ (snd-display ";bs rough spectrum: ~A" sp)))
(undo))
(if (defined? 'gsl-roots) (analog-filter-tests))
@@ -15057,9 +14615,9 @@ EDITS: 2
(let ((v (spectrum->coeffs 10 (float-vector 0 1.0 0 0 0 0 0 0 1.0 0)))
(v1 (make-fir-coeffs 10 (float-vector 0 1.0 0 0 0 0 0 0 1.0 0))))
(if (not (vequal v (float-vector -0.190 -0.118 0.000 0.118 0.190 0.190 0.118 0.000 -0.118 -0.190)))
- (snd-display #__line__ ";spectrum->coeffs: ~A" v))
+ (snd-display ";spectrum->coeffs: ~A" v))
(if (not (vequal v v1))
- (snd-display #__line__ ";spectrum->coeffs v make-fir-coeffs: ~A ~A" v v1)))
+ (snd-display ";spectrum->coeffs v make-fir-coeffs: ~A ~A" v v1)))
(let ((notched-spectr (make-float-vector 20)))
(set! (notched-spectr 2) 1.0)
@@ -15067,15 +14625,15 @@ EDITS: 2
(v1 (make-fir-coeffs 20 notched-spectr)))
(if (not (vequal v (float-vector 0.095 0.059 -0.000 -0.059 -0.095 -0.095 -0.059 0.000 0.059 0.095
0.095 0.059 0.000 -0.059 -0.095 -0.095 -0.059 -0.000 0.059 0.095)))
- (snd-display #__line__ ";spectrum->coeffs (notch): ~A" v))
+ (snd-display ";spectrum->coeffs (notch): ~A" v))
(if (not (vequal v v1))
- (snd-display #__line__ ";spectrum->coeffs v(2) make-fir-coeffs: ~A ~A" v v1))
+ (snd-display ";spectrum->coeffs v(2) make-fir-coeffs: ~A ~A" v v1))
(let ((flt (make-fir-filter 20 v)))
- (map-channel (lambda (y) (fir-filter flt y)))))
- (let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.007 0.493 1.000 0.068 0.030 0.019 0.014 0.011 0.009 0.009)))
- (snd-display #__line__ ";sp->coeff rough spectrum: ~A" sp)))
- (undo))
+ (map-channel (lambda (y) (fir-filter flt y))))))
+ (let ((sp (rough-spectrum ind)))
+ (if (not (vequal sp (float-vector 0.007 0.493 1.000 0.068 0.030 0.019 0.014 0.011 0.009 0.009)))
+ (snd-display ";sp->coeff rough spectrum: ~A" sp)))
+ (undo)
(let ((rspect (make-float-vector 20)))
(do ((i 0 (+ i 1)))
@@ -15084,228 +14642,227 @@ EDITS: 2
(let ((v (spectrum->coeffs 20 rspect))
(v1 (make-fir-coeffs 20 rspect)))
(if (not (vequal v v1))
- (snd-display #__line__ ";spectrum->coeffs v(3) make-fir-coeffs: ~A ~A" v v1))))
-
- (let ((b (make-highpass (hz->radians 1000.0) 10))
- (v (make-float-vector 20))
- (d (make-delay 1)))
- (delay d (fir-filter b 1.0))
- (fill-float-vector v (delay d (fir-filter b 0.0)))
- (if (not (vequal v (float-vector -0.001 -0.002 -0.005 -0.011 -0.021 -0.034 -0.049 -0.065 -0.078 -0.087
- 0.909 -0.087 -0.078 -0.065 -0.049 -0.034 -0.021 -0.011 -0.005 -0.002)))
- (snd-display #__line__ ";dsp.scm high: ~A" v))
+ (snd-display ";spectrum->coeffs v(3) make-fir-coeffs: ~A ~A" v v1))))
+
+ (let ((b (make-highpass (hz->radians 1000.0) 10)))
+ (let ((v (make-float-vector 20)))
+ (let ((d (make-delay 1)))
+ (delay d (fir-filter b 1.0))
+ (fill-float-vector v (delay d (fir-filter b 0.0))))
+ (if (not (vequal v (float-vector -0.001 -0.002 -0.005 -0.011 -0.021 -0.034 -0.049 -0.065 -0.078 -0.087
+ 0.909 -0.087 -0.078 -0.065 -0.049 -0.034 -0.021 -0.011 -0.005 -0.002)))
+ (snd-display ";dsp.scm high: ~A" v)))
(set! b (make-highpass (hz->radians 1000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.053 0.774 0.998 0.997 0.997 0.996 0.996 0.996 0.997 1.000)))
- (not (vequal sp (float-vector 0.053 0.776 1.000 0.998 0.998 0.998 0.998 0.998 0.998 1.000))))
- (snd-display #__line__ ";dsp hp rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.053 0.774 0.998 0.997 0.997 0.996 0.996 0.996 0.997 1.000))
+ (vequal sp (float-vector 0.053 0.776 1.000 0.998 0.998 0.998 0.998 0.998 0.998 1.000))))
+ (snd-display ";dsp hp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-lowpass (hz->radians 1000.0) 10))
- (v (make-float-vector 20))
- (d (make-delay 1)))
- (delay d (fir-filter b 1.0))
- (fill-float-vector v (delay d (fir-filter b 0.0)))
- (if (not (vequal v (float-vector 0.001 0.002 0.005 0.011 0.021 0.034 0.049 0.065 0.078 0.087 0.091 0.087 0.078 0.065
- 0.049 0.034 0.021 0.011 0.005 0.002)))
- (snd-display #__line__ ";dsp.scm low: ~A" v))
+ (let ((b (make-lowpass (hz->radians 1000.0) 10)))
+ (let ((v (make-float-vector 20)))
+ (let ((d (make-delay 1)))
+ (delay d (fir-filter b 1.0))
+ (fill-float-vector v (delay d (fir-filter b 0.0))))
+ (if (not (vequal v (float-vector 0.001 0.002 0.005 0.011 0.021 0.034 0.049 0.065 0.078 0.087 0.091 0.087 0.078 0.065
+ 0.049 0.034 0.021 0.011 0.005 0.002)))
+ (snd-display ";dsp.scm low: ~A" v)))
(set! b (make-lowpass (hz->radians 1000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 1.000 0.054 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";dsp lp rough spectrum: ~A" sp)))
+ (snd-display ";dsp lp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-bandpass (hz->radians 1500.0) (hz->radians 2000.0) 10))
- (v (make-float-vector 20))
- (d (make-delay 1)))
- (delay d (fir-filter b 1.0))
- (fill-float-vector v (delay d (fir-filter b 0.0)))
- (if (not (vequal v (float-vector 0.001 -0.001 -0.005 -0.011 -0.017 -0.019 -0.013 0.003 0.022 0.039 0.045
- 0.039 0.022 0.003 -0.013 -0.019 -0.017 -0.011 -0.005 -0.001)))
- (snd-display #__line__ ";dsp.scm bp: ~A" v))
+ (let ((b (make-bandpass (hz->radians 1500.0) (hz->radians 2000.0) 10)))
+ (let ((v (make-float-vector 20)))
+ (let ((d (make-delay 1)))
+ (delay d (fir-filter b 1.0))
+ (fill-float-vector v (delay d (fir-filter b 0.0))))
+ (if (not (vequal v (float-vector 0.001 -0.001 -0.005 -0.011 -0.017 -0.019 -0.013 0.003 0.022 0.039 0.045
+ 0.039 0.022 0.003 -0.013 -0.019 -0.017 -0.011 -0.005 -0.001)))
+ (snd-display ";dsp.scm bp: ~A" v)))
(set! b (make-bandpass (hz->radians 1500.0) (hz->radians 2000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 0.010 1.000 0.154 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";dsp bp rough spectrum: ~A" sp)))
+ (snd-display ";dsp bp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-bandstop (hz->radians 1500.0) (hz->radians 2000.0) 10))
- (v (make-float-vector 20))
- (d (make-delay 1)))
- (delay d (fir-filter b 1.0))
- (fill-float-vector v (delay d (fir-filter b 0.0)))
- (if (not (vequal v (float-vector -0.001 0.001 0.005 0.011 0.017 0.019 0.013 -0.003 -0.022 -0.039 0.955
- -0.039 -0.022 -0.003 0.013 0.019 0.017 0.011 0.005 0.001)))
- (snd-display #__line__ ";dsp.scm bs: ~A" v))
+ (let ((b (make-bandstop (hz->radians 1500.0) (hz->radians 2000.0) 10)))
+ (let ((v (make-float-vector 20)))
+ (let ((d (make-delay 1)))
+ (delay d (fir-filter b 1.0))
+ (fill-float-vector v (delay d (fir-filter b 0.0))))
+ (if (not (vequal v (float-vector -0.001 0.001 0.005 0.011 0.017 0.019 0.013 -0.003 -0.022 -0.039 0.955
+ -0.039 -0.022 -0.003 0.013 0.019 0.017 0.011 0.005 0.001)))
+ (snd-display ";dsp.scm bs: ~A" v)))
(set! b (make-bandstop (hz->radians 1500.0) (hz->radians 2000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.904 0.425 0.821 0.998 0.997 0.996 0.996 0.996 0.997 1.000)))
- (not (vequal sp (float-vector 0.906 0.425 0.822 1.000 0.999 0.998 0.998 0.998 0.998 1.000))))
- (snd-display #__line__ ";dsp bs rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.904 0.425 0.821 0.998 0.997 0.996 0.996 0.996 0.997 1.000))
+ (vequal sp (float-vector 0.906 0.425 0.822 1.000 0.999 0.998 0.998 0.998 0.998 1.000))))
+ (snd-display ";dsp bs rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-differentiator 10))
- (v (make-float-vector 20))
- (d (make-delay 1)))
- (delay d (fir-filter b 1.0))
- (fill-float-vector v (delay d (fir-filter b 0.0)))
- (if (not (vequal v (float-vector -0.008 0.011 -0.021 0.039 -0.066 0.108 -0.171 0.270 -0.456 0.977
- 0.000 -0.977 0.456 -0.270 0.171 -0.108 0.066 -0.039 0.021 -0.011)))
- (snd-display #__line__ ";dsp.scm df: ~A" v))
+ (let ((b (make-differentiator 10)))
+ (let ((v (make-float-vector 20)))
+ (let ((d (make-delay 1)))
+ (delay d (fir-filter b 1.0))
+ (fill-float-vector v (delay d (fir-filter b 0.0))))
+ (if (not (vequal v (float-vector -0.008 0.011 -0.021 0.039 -0.066 0.108 -0.171 0.270 -0.456 0.977
+ 0.000 -0.977 0.456 -0.270 0.171 -0.108 0.066 -0.039 0.021 -0.011)))
+ (snd-display ";dsp.scm df: ~A" v)))
(set! b (make-differentiator 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 0.004 0.027 0.075 0.147 0.242 0.362 0.506 0.674 0.864 1.000)))
- (snd-display #__line__ ";dsp df rough spectrum: ~A" sp)))
+ (snd-display ";dsp df rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-iir-high-pass-2 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
- (snd-display #__line__ ";iir-2 high: ~A" v))
+ (let ((b (make-iir-high-pass-2 440.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
+ (snd-display ";iir-2 high: ~A" v)))
(set! b (make-iir-high-pass-2 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000)))
- (not (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
- (snd-display #__line__ ";iir-2 hp rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
+ (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
+ (snd-display ";iir-2 hp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-iir-low-pass-2 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
- (snd-display #__line__ ";iir-2 low: ~A" v))
+ (let ((b (make-iir-low-pass-2 440.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
+ (snd-display ";iir-2 low: ~A" v)))
(set! b (make-iir-low-pass-2 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";iir-2 lp rough spectrum: ~A" sp)))
+ (snd-display ";iir-2 lp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-iir-band-pass-2 440.0 490.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.010 0.009 0.008 0.006 0.004)))
- (snd-display #__line__ ";iir bp-2 bandpass: ~A" v))
+ (let ((b (make-iir-band-pass-2 440.0 490.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.010 0.009 0.008 0.006 0.004)))
+ (snd-display ";iir bp-2 bandpass: ~A" v)))
(set! b (make-iir-band-pass-2 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
(if (not (vequal sp (float-vector 0.239 1.000 0.117 0.041 0.019 0.010 0.005 0.003 0.001 0.000)))
- (snd-display #__line__ ";iir bp-2 rough spectrum: ~A" sp)))
+ (snd-display ";iir bp-2 rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-iir-band-stop-2 440.0 500.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.992 -0.017 -0.016 -0.015 -0.014 -0.012 -0.011 -0.009 -0.007 -0.005)))
- (snd-display #__line__ ";iir-2 bandstop: ~A" v))
+ (let ((b (make-iir-band-stop-2 440.0 500.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.992 -0.017 -0.016 -0.015 -0.014 -0.012 -0.011 -0.009 -0.007 -0.005)))
+ (snd-display ";iir-2 bandstop: ~A" v)))
(set! b (make-iir-band-stop-2 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.836 0.525 0.943 0.979 0.989 0.994 0.997 0.997 0.997 1.000)))
- (not (vequal sp (float-vector 0.838 0.527 0.945 0.981 0.991 0.996 0.999 1.000 0.999 0.998))))
- (snd-display #__line__ ";iir bs-2 rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.836 0.525 0.943 0.979 0.989 0.994 0.997 0.997 0.997 1.000))
+ (vequal sp (float-vector 0.838 0.527 0.945 0.981 0.991 0.996 0.999 1.000 0.999 0.998))))
+ (snd-display ";iir bs-2 rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-hp 4 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (and (not (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.036 0.014 0.047 0.0685 0.0775)))
- (not (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.015 0.049 0.070 0.081)))
- (not (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.014 0.049 0.069 0.079))))
- (snd-display #__line__ ";butter hp: ~A" v))
+ (let ((b (make-butter-hp 4 440.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (or (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.036 0.014 0.047 0.0685 0.0775))
+ (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.015 0.049 0.070 0.081))
+ (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.014 0.049 0.069 0.079))))
+ (snd-display ";butter hp: ~A" v)))
(set! b (make-butter-hp 4 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 0.0505 0.982 1.000 1.000 0.998 0.998 0.999 0.998 0.996 0.999)))
- (not (vequal sp (float-vector 0.051 0.982 1.000 1.000 0.998 0.998 0.998 0.999 0.997 0.995)))
- (not (vequal sp (float-vector 0.051 0.991 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995)))
- (not (vequal sp (float-vector 0.045 0.970 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995)))
- (not (vequal sp (float-vector 0.052 0.971 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))))
- (snd-display #__line__ ";bhp rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 0.0505 0.982 1.000 1.000 0.998 0.998 0.999 0.998 0.996 0.999))
+ (vequal sp (float-vector 0.051 0.982 1.000 1.000 0.998 0.998 0.998 0.999 0.997 0.995))
+ (vequal sp (float-vector 0.051 0.991 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
+ (vequal sp (float-vector 0.045 0.970 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
+ (vequal sp (float-vector 0.052 0.971 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))))
+ (snd-display ";bhp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-lp 4 440.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))) ;; ???
- (snd-display #__line__ ";butter lp: ~A" v))
+ (let ((b (make-butter-lp 4 440.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))) ;; ???
+ (snd-display ";butter lp: ~A" v)))
(set! b (make-butter-lp 4 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (and (not (vequal sp (float-vector 1.000 0.035 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal sp (float-vector 1.000 0.038 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";blp rough spectrum: ~A" sp)))
+ (if (not (or (vequal sp (float-vector 1.000 0.035 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal sp (float-vector 1.000 0.038 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";blp rough spectrum: ~A" sp)))
(undo))
- (let ((b (make-butter-bp 4 440.0 500.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";butter bp: ~A" v))
+ (let ((b (make-butter-bp 4 440.0 500.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";butter bp: ~A" v)))
(set! b (make-butter-bp 4 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(undo))
- (let ((b (make-butter-bs 4 440.0 500.0))
- (v (make-float-vector 10))
- (d (make-delay 1)))
- (delay d (filter b 1.0))
- (fill-float-vector v (delay d (filter b 0.0)))
- (if (and (not (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.026 -0.0225 -0.015 -0.0085)))
- (not (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.022 -0.017 -0.011)))
- (not (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.021 -0.014 -0.011))))
- (snd-display #__line__ ";butter bs: ~A" v))
+ (let ((b (make-butter-bs 4 440.0 500.0)))
+ (let ((v (make-float-vector 10)))
+ (let ((d (make-delay 1)))
+ (delay d (filter b 1.0))
+ (fill-float-vector v (delay d (filter b 0.0))))
+ (if (not (or (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.026 -0.0225 -0.015 -0.0085))
+ (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.022 -0.017 -0.011))
+ (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.021 -0.014 -0.011))))
+ (snd-display ";butter bs: ~A" v)))
(set! b (make-butter-bs 4 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(undo))
(revert-sound)
(test-scanned-synthesis .1 10000 1.0 0.1 0.0)
-
(close-sound ind))
- (let ((gen (make-sawtooth-wave 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-sawtooth-wave 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-sawtooth-wave 440.0)))
(print-and-check gen
"sawtooth-wave"
"sawtooth-wave freq: 440.000Hz, phase: 3.142, amp: 1.000")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (sawtooth-wave gen 0.0)))
- (fill-float-vector v1 (if (sawtooth-wave? gen1) (sawtooth-wave gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map sawtooth: ~A ~A" v0 v1))
- (if (not (sawtooth-wave? gen)) (snd-display #__line__ ";~A not sawtooth-wave?" gen))
- (if (fneq (mus-phase gen) 4.39538) (snd-display #__line__ ";sawtooth-wave phase: ~F?" (mus-phase gen))) ;starts at pi
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";sawtooth-wave frequency: ~F?" (mus-frequency gen)))
- (set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";set! sawtooth-wave frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 1.0) (snd-display #__line__ ";sawtooth-wave scaler: ~F?" (mus-scaler gen)))
- (set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! sawtooth-wave scaler: ~F?" (mus-scaler gen)))
- (if (or (fneq (v0 1) 0.04) (fneq (v0 8) .319)) (snd-display #__line__ ";sawtooth-wave output: ~A" v0)))
+ (let ((v0 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (sawtooth-wave gen 0.0)))
+ (let ((gen1 (make-sawtooth-wave 440.0))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (sawtooth-wave? gen1) (sawtooth-wave gen1 0.0) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map sawtooth: ~A ~A" v0 v1)))
+ (if (not (sawtooth-wave? gen)) (snd-display ";~A not sawtooth-wave?" gen))
+ (if (fneq (mus-phase gen) 4.39538) (snd-display ";sawtooth-wave phase: ~F?" (mus-phase gen))) ;starts at pi
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";sawtooth-wave frequency: ~F?" (mus-frequency gen)))
+ (set! (mus-frequency gen) 100.0)
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";set! sawtooth-wave frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 1.0) (snd-display ";sawtooth-wave scaler: ~F?" (mus-scaler gen)))
+ (set! (mus-scaler gen) 0.5)
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! sawtooth-wave scaler: ~F?" (mus-scaler gen)))
+ (if (or (fneq (v0 1) 0.04) (fneq (v0 8) .319)) (snd-display ";sawtooth-wave output: ~A" v0))))
(test-gen-equal (make-sawtooth-wave 440.0) (make-sawtooth-wave 440.0) (make-sawtooth-wave 120.0))
(test-gen-equal (make-sawtooth-wave 440.0) (make-sawtooth-wave 440.0) (make-sawtooth-wave 440.0 1.0 1.0))
@@ -15318,34 +14875,34 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (+ (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";sawtooth +-: ~A" mx)))
+ (snd-display ";sawtooth +-: ~A" mx)))
- (let ((gen (make-square-wave 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-square-wave 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-square-wave 440.0)))
(print-and-check gen
"square-wave"
"square-wave freq: 440.000Hz, phase: 0.000, amp: 1.000")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (square-wave gen 0.0)))
- (let ((w 1.0))
- (fill-float-vector v1 (begin
- (set! w (mus-width gen1))
- (if (square-wave? gen1) (square-wave gen1 0.0) -1.0)))
- (if (fneq w 0.5) (snd-display #__line__ ";mus-width opt: ~A" w)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map square-wave: ~A ~A" v0 v1))
- (if (not (square-wave? gen)) (snd-display #__line__ ";~A not square-wave?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";square-wave phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";square-wave frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 1.0) (snd-display #__line__ ";square-wave scaler: ~F?" (mus-scaler gen)))
- (set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! square-wave scaler: ~F?" (mus-scaler gen)))
- (if (fneq (mus-width gen) 0.5) (snd-display #__line__ ";square-wave width: ~A" (mus-width gen)))
- (set! (mus-width gen) 0.75)
- (if (fneq (mus-width gen) 0.75) (snd-display #__line__ ";set! square-wave width: ~A" (mus-width gen)))
- (if (or (fneq (v0 1) 1.0) (fneq (v0 8) 1.0)) (snd-display #__line__ ";square-wave output: ~A" v0)))
+ (let ((v0 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (square-wave gen 0.0)))
+ (let ((w 1.0)
+ (gen1 (make-square-wave 440.0))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (begin
+ (set! w (mus-width gen1))
+ (if (square-wave? gen1) (square-wave gen1 0.0) -1.0)))
+ (if (fneq w 0.5) (snd-display ";mus-width opt: ~A" w))
+ (if (not (vequal v0 v1)) (snd-display ";map square-wave: ~A ~A" v0 v1)))
+ (if (not (square-wave? gen)) (snd-display ";~A not square-wave?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";square-wave phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";square-wave frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 1.0) (snd-display ";square-wave scaler: ~F?" (mus-scaler gen)))
+ (set! (mus-scaler gen) 0.5)
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! square-wave scaler: ~F?" (mus-scaler gen)))
+ (if (fneq (mus-width gen) 0.5) (snd-display ";square-wave width: ~A" (mus-width gen)))
+ (set! (mus-width gen) 0.75)
+ (if (fneq (mus-width gen) 0.75) (snd-display ";set! square-wave width: ~A" (mus-width gen)))
+ (if (or (fneq (v0 1) 1.0) (fneq (v0 8) 1.0)) (snd-display ";square-wave output: ~A" v0))))
(test-gen-equal (make-square-wave 440.0) (make-square-wave 440.0) (make-square-wave 120.0))
(test-gen-equal (make-square-wave 440.0) (make-square-wave 440.0) (make-square-wave 440.0 1.0 1.0))
@@ -15359,30 +14916,30 @@ EDITS: 2
((= i 20))
(set! (v0 i) (gen)))
(if (not (vequal v0 (float-vector -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5)))
- (snd-display #__line__ ";square-wave -.5: ~A " v0)))
+ (snd-display ";square-wave -.5: ~A " v0)))
(set! *clm-srate* old-srate))
(let ((gen (make-triangle-wave 440.0))
- (gen1 (make-triangle-wave 440.0 1.0 pi))
- (v0 (make-float-vector 10))
- (gen2 (make-triangle-wave 440.0))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"triangle-wave"
"triangle-wave freq: 440.000Hz, phase: 0.000, amp: 1.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (triangle-wave gen 0.0)))
- (fill-float-vector v1 (if (triangle-wave? gen2) (triangle-wave gen2 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map triangle-wave: ~A ~A" v0 v1))
- (if (not (triangle-wave? gen)) (snd-display #__line__ ";~A not triangle-wave?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";triangle-wave phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-phase gen1) pi) (snd-display #__line__ ";init triangle-wave phase: ~F?" (mus-phase gen1)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";triangle-wave frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 1.0) (snd-display #__line__ ";triangle-wave scaler: ~F?" (mus-scaler gen)))
+ (let ((gen2 (make-triangle-wave 440.0))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (triangle-wave? gen2) (triangle-wave gen2 0.0) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map triangle-wave: ~A ~A" v0 v1)))
+ (if (not (triangle-wave? gen)) (snd-display ";~A not triangle-wave?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";triangle-wave phase: ~F?" (mus-phase gen)))
+ (let ((gen1 (make-triangle-wave 440.0 1.0 pi)))
+ (if (fneq (mus-phase gen1) pi) (snd-display ";init triangle-wave phase: ~F?" (mus-phase gen1))))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";triangle-wave frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 1.0) (snd-display ";triangle-wave scaler: ~F?" (mus-scaler gen)))
(set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! triangle-wave scaler: ~F?" (mus-scaler gen)))
- (if (or (fneq (v0 1) 0.080) (fneq (v0 8) 0.639)) (snd-display #__line__ ";triangle-wave output: ~A" v0)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! triangle-wave scaler: ~F?" (mus-scaler gen)))
+ (if (or (fneq (v0 1) 0.080) (fneq (v0 8) 0.639)) (snd-display ";triangle-wave output: ~A" v0)))
(let ((gen1 (make-triangle-wave 100.0))
(gen2 (make-triangle-wave -100.0))
@@ -15391,31 +14948,31 @@ EDITS: 2
((= i 100))
(set! mx (max mx (abs (+ (gen1) (gen2))))))
(if (fneq mx 0.0)
- (snd-display #__line__ ";triangle +-: ~A" mx)))
+ (snd-display ";triangle +-: ~A" mx)))
(test-gen-equal (make-triangle-wave 440.0) (make-triangle-wave 440.0) (make-triangle-wave 120.0))
(test-gen-equal (make-triangle-wave 440.0) (make-triangle-wave 440.0) (make-triangle-wave 440.0 1.0 1.0))
(test-gen-equal (make-triangle-wave 440.0) (make-triangle-wave 440.0) (make-triangle-wave 440.0 0.5))
(let ((gen (make-pulse-train 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-pulse-train 440.0))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"pulse-train"
"pulse-train freq: 440.000Hz, phase: 0.000, amp: 1.000")
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (pulse-train gen 0.0)))
- (fill-float-vector v1 (if (pulse-train? gen1) (pulse-train gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map pulse-train: ~A ~A" v0 v1))
- (if (not (pulse-train? gen)) (snd-display #__line__ ";~A not pulse-train?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";pulse-train phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";pulse-train frequency: ~F?" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 1.0) (snd-display #__line__ ";pulse-train scaler: ~F?" (mus-scaler gen)))
+ (let ((gen1 (make-pulse-train 440.0))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (pulse-train? gen1) (pulse-train gen1 0.0) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map pulse-train: ~A ~A" v0 v1)))
+ (if (not (pulse-train? gen)) (snd-display ";~A not pulse-train?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";pulse-train phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";pulse-train frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 1.0) (snd-display ";pulse-train scaler: ~F?" (mus-scaler gen)))
(set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! pulse-train scaler: ~F?" (mus-scaler gen)))
- (if (or (fneq (v0 0) 1.0) (fneq (v0 8) 0.0)) (snd-display #__line__ ";pulse-train output: ~A" v0)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! pulse-train scaler: ~F?" (mus-scaler gen)))
+ (if (or (fneq (v0 0) 1.0) (fneq (v0 8) 0.0)) (snd-display ";pulse-train output: ~A" v0)))
(test-gen-equal (make-pulse-train 440.0) (make-pulse-train 440.0) (make-pulse-train 120.0))
(test-gen-equal (make-pulse-train 440.0) (make-pulse-train 440.0) (make-pulse-train 440.0 1.0 1.0))
@@ -15429,50 +14986,48 @@ EDITS: 2
((= i 20))
(set! (v0 i) (gen)))
(if (not (vequal v0 (float-vector 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5)))
- (snd-display #__line__ ";pulse-train -.5: ~A " v0)))
+ (snd-display ";pulse-train -.5: ~A " v0)))
(set! *clm-srate* old-srate))
(let ((gen (make-two-pole 1200.0 .1)))
- (if (not (two-pole? gen)) (snd-display #__line__ ";~A not 2-polar?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";2-polar order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display #__line__ ";2-polar a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-ycoeff gen 1) -.188) (snd-display #__line__ ";2-polar b1: ~F?" (mus-ycoeff gen 1)))
- (if (fneq (mus-ycoeff gen 2) .01) (snd-display #__line__ ";2-polar b2: ~F?" (mus-ycoeff gen 2)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";freq 2-polar: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.1) (snd-display #__line__ ";scaler 2-polar: ~A" (mus-scaler gen))))
+ (if (not (two-pole? gen)) (snd-display ";~A not 2-polar?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";2-polar order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display ";2-polar a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-ycoeff gen 1) -.188) (snd-display ";2-polar b1: ~F?" (mus-ycoeff gen 1)))
+ (if (fneq (mus-ycoeff gen 2) .01) (snd-display ";2-polar b2: ~F?" (mus-ycoeff gen 2)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";freq 2-polar: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.1) (snd-display ";scaler 2-polar: ~A" (mus-scaler gen))))
(let ((gen (make-two-pole :frequency 1200.0 :radius .1)))
- (if (not (two-pole? gen)) (snd-display #__line__ ";~A not f2-polar?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";f2-polar order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display #__line__ ";f2-polar a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-ycoeff gen 1) -.188) (snd-display #__line__ ";f2-polar b1: ~F?" (mus-ycoeff gen 1)))
- (if (fneq (mus-ycoeff gen 2) .01) (snd-display #__line__ ";f2-polar b2: ~F?" (mus-ycoeff gen 2)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";freq f2-polar: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.1) (snd-display #__line__ ";scaler f2-polar: ~A" (mus-scaler gen))))
+ (if (not (two-pole? gen)) (snd-display ";~A not f2-polar?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";f2-polar order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display ";f2-polar a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-ycoeff gen 1) -.188) (snd-display ";f2-polar b1: ~F?" (mus-ycoeff gen 1)))
+ (if (fneq (mus-ycoeff gen 2) .01) (snd-display ";f2-polar b2: ~F?" (mus-ycoeff gen 2)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";freq f2-polar: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.1) (snd-display ";scaler f2-polar: ~A" (mus-scaler gen))))
(let ((gen (make-two-zero :radius .1 :frequency 1200.0)))
- (if (not (two-zero? gen)) (snd-display #__line__ ";~A not 2-zp?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";2-zp order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display #__line__ ";2-zp a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-xcoeff gen 1) -.188) (snd-display #__line__ ";2-zp a1: ~F?" (mus-xcoeff gen 1)))
- (if (fneq (mus-xcoeff gen 2) .01) (snd-display #__line__ ";2-zp a2: ~F?" (mus-xcoeff gen 2)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";freq 2-zp: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.1) (snd-display #__line__ ";scaler 2-zp: ~A" (mus-scaler gen))))
+ (if (not (two-zero? gen)) (snd-display ";~A not 2-zp?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";2-zp order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display ";2-zp a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-xcoeff gen 1) -.188) (snd-display ";2-zp a1: ~F?" (mus-xcoeff gen 1)))
+ (if (fneq (mus-xcoeff gen 2) .01) (snd-display ";2-zp a2: ~F?" (mus-xcoeff gen 2)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";freq 2-zp: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.1) (snd-display ";scaler 2-zp: ~A" (mus-scaler gen))))
(let ((gen (make-two-zero 1200.0 .1)))
- (if (not (two-zero? gen)) (snd-display #__line__ ";~A not f2-zp?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";f2-zp order: ~D?" (mus-order gen)))
- (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display #__line__ ";f2-zp a0: ~F?" (mus-xcoeff gen 0)))
- (if (fneq (mus-xcoeff gen 1) -.188) (snd-display #__line__ ";f2-zp a1: ~F?" (mus-xcoeff gen 1)))
- (if (fneq (mus-xcoeff gen 2) .01) (snd-display #__line__ ";f2-zp a2: ~F?" (mus-xcoeff gen 2)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";freq f2-zp: ~A" (mus-frequency gen)))
- (if (fneq (mus-scaler gen) 0.1) (snd-display #__line__ ";scaler f2-zp: ~A" (mus-scaler gen))))
+ (if (not (two-zero? gen)) (snd-display ";~A not f2-zp?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";f2-zp order: ~D?" (mus-order gen)))
+ (if (fneq (mus-xcoeff gen 0) 1.0) (snd-display ";f2-zp a0: ~F?" (mus-xcoeff gen 0)))
+ (if (fneq (mus-xcoeff gen 1) -.188) (snd-display ";f2-zp a1: ~F?" (mus-xcoeff gen 1)))
+ (if (fneq (mus-xcoeff gen 2) .01) (snd-display ";f2-zp a2: ~F?" (mus-xcoeff gen 2)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";freq f2-zp: ~A" (mus-frequency gen)))
+ (if (fneq (mus-scaler gen) 0.1) (snd-display ";scaler f2-zp: ~A" (mus-scaler gen))))
(let ((gen (make-formant 1200.0 0.9))
- (v0 (make-float-vector 10))
- (gen1 (make-formant 1200.0 0.9))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"formant"
"formant frequency: 1200.000, radius: 0.900")
@@ -15480,19 +15035,21 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 10))
(set! (v0 i) (formant gen 0.0)))
- (let ((inp 1.0))
+ (let ((gen1 (make-formant 1200.0 0.9))
+ (v1 (make-float-vector 10))
+ (inp 1.0))
(fill-float-vector v1 (let ((val (if (formant? gen1) (formant gen1 inp) -1.0)))
- (set! inp 0.0)
- val)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map formant: ~A ~A" v0 v1))
- (if (not (formant? gen)) (snd-display #__line__ ";~A not formant?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";formant order: ~D?" (mus-order gen)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";formant frequency: ~F?" (mus-frequency gen)))
- (if (or (fneq (v0 0) .095) (fneq (v0 1) .161)) (snd-display #__line__ ";formant output: ~A" v0))
- (if (fneq (mus-scaler gen) 0.9) (snd-display #__line__ ";formant gain: ~F?" (mus-scaler gen)))
+ (set! inp 0.0)
+ val))
+ (if (not (vequal v0 v1)) (snd-display ";map formant: ~A ~A" v0 v1)))
+ (if (not (formant? gen)) (snd-display ";~A not formant?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";formant order: ~D?" (mus-order gen)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";formant frequency: ~F?" (mus-frequency gen)))
+ (if (or (fneq (v0 0) .095) (fneq (v0 1) .161)) (snd-display ";formant output: ~A" v0))
+ (if (fneq (mus-scaler gen) 0.9) (snd-display ";formant gain: ~F?" (mus-scaler gen)))
(set! (mus-scaler gen) 2.0)
- (if (fneq (mus-scaler gen) 2.0) (snd-display #__line__ ";formant set gain: ~F?" (mus-scaler gen))))
+ (if (fneq (mus-scaler gen) 2.0) (snd-display ";formant set gain: ~F?" (mus-scaler gen))))
(test-gen-equal (let ((f1 (make-formant 1200.0 0.9))) (formant f1 1.0) f1)
(let ((f2 (make-formant 1200.0 0.9))) (formant f2 1.0) f2)
@@ -15521,7 +15078,7 @@ EDITS: 2
(set! (v0 i) (+ (* 0.5 (formant f0 val)) (* 0.25 (formant f1 val))))
(set! (v1 i) (formant-bank fs val))
(set! val 0.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";formant bank 1: ~A ~A" v0 v1)))
+ (if (not (vequal v0 v1)) (snd-display ";formant bank 1: ~A ~A" v0 v1)))
(let ((fs (make-vector 2))
(amps (make-float-vector 2 1.0))
@@ -15533,26 +15090,28 @@ EDITS: 2
(set! (amps 0) 0.5)
(set! (amps 1) 0.25)
(fill-float-vector v (let ((res (formant-bank fs val))) (set! val 0.0) res))
- (if (not (vequal v (float-vector 0.368 0.095 -0.346 -0.091 -0.020))) (snd-display #__line__ ";run formant-bank: ~A" v)))
+ (if (not (vequal v (float-vector 0.368 0.095 -0.346 -0.091 -0.020))) (snd-display ";run formant-bank: ~A" v)))
(let ((ob (open-sound "oboe.snd")))
- (define (poltergeist frek amp R gain frek-env R-env)
- ;; test courtesy of Anders Vinjar
- (let ((filt (make-formant frek R))
- (fe (make-env :envelope frek-env :length (framples) :offset frek))
- (re (make-env :envelope R-env :length (framples) :offset R)))
- (lambda (y)
- (let ((outval (* gain (formant filt (* amp y)))))
- (mus-set-formant-radius-and-frequency filt (env re) (env fe))
- outval))))
- (map-channel (poltergeist 300 0.1 0.0 30.0 '(0 100 1 4000.0) '(0 0.99 1 .9))) ;; should sound like "whyieee?"
- (play ob :wait #t)
+ ;; test courtesy of Anders Vinjar
+ (map-channel (let ((frek 300)
+ (amp 0.1000)
+ (R 0.0000)
+ (gain 30.0000)
+ (frek-env '(0 100 1 4000.0))
+ (R-env '(0 0.99 1 0.9)))
+ (let ((filt (make-formant frek R))
+ (fe (make-env :envelope frek-env :length (framples) :offset frek))
+ (re (make-env :envelope R-env :length (framples) :offset R)))
+ (lambda (y)
+ (let ((outval (* gain (formant filt (* amp y)))))
+ (mus-set-formant-radius-and-frequency filt (env re) (env fe))
+ outval)))))
+ (play ob :wait #t) ;; should sound like "whyieee?"
(close-sound ob))
(let ((gen (make-firmant 1200.0 0.9))
- (v0 (make-float-vector 10))
- (gen1 (make-firmant 1200.0 0.9))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"firmant"
"firmant frequency: 1200.000, radius: 0.900")
@@ -15560,19 +15119,21 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 10))
(set! (v0 i) (firmant gen 0.0)))
- (let ((inp 1.0))
+ (let ((inp 1.0)
+ (gen1 (make-firmant 1200.0 0.9))
+ (v1 (make-float-vector 10)))
(fill-float-vector v1 (let ((val (if (firmant? gen1) (firmant gen1 inp) -1.0)))
- (set! inp 0.0)
- val)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map firmant: ~A ~A" v0 v1))
- (if (not (firmant? gen)) (snd-display #__line__ ";~A not firmant?" gen))
- (if (not (= (mus-order gen) 2)) (snd-display #__line__ ";firmant order: ~D?" (mus-order gen)))
- (if (fneq (mus-frequency gen) 1200.0) (snd-display #__line__ ";firmant frequency: ~F?" (mus-frequency gen)))
- (if (or (fneq (v0 0) .058) (fneq (v0 1) .099)) (snd-display #__line__ ";firmant output: ~A" v0))
- (if (fneq (mus-scaler gen) 0.9) (snd-display #__line__ ";firmant gain: ~F?" (mus-scaler gen)))
+ (set! inp 0.0)
+ val))
+ (if (not (vequal v0 v1)) (snd-display ";map firmant: ~A ~A" v0 v1)))
+ (if (not (firmant? gen)) (snd-display ";~A not firmant?" gen))
+ (if (not (= (mus-order gen) 2)) (snd-display ";firmant order: ~D?" (mus-order gen)))
+ (if (fneq (mus-frequency gen) 1200.0) (snd-display ";firmant frequency: ~F?" (mus-frequency gen)))
+ (if (or (fneq (v0 0) .058) (fneq (v0 1) .099)) (snd-display ";firmant output: ~A" v0))
+ (if (fneq (mus-scaler gen) 0.9) (snd-display ";firmant gain: ~F?" (mus-scaler gen)))
(set! (mus-scaler gen) .20)
- (if (fneq (mus-scaler gen) .20) (snd-display #__line__ ";firmant set gain: ~F?" (mus-scaler gen))))
+ (if (fneq (mus-scaler gen) .20) (snd-display ";firmant set gain: ~F?" (mus-scaler gen))))
(test-gen-equal (let ((f1 (make-firmant 1200.0 0.9))) (firmant f1 1.0) f1)
(let ((f2 (make-firmant 1200.0 0.9))) (firmant f2 1.0) f2)
@@ -15586,90 +15147,90 @@ EDITS: 2
(let ((gen (make-fft-window hamming-window 16)))
(if (not (vequal gen (float-vector 0.080 0.115 0.215 0.364 0.540 0.716 0.865 1.000 1.000 0.865 0.716 0.540 0.364 0.215 0.115 0.080)))
- (snd-display #__line__ ";hamming window: ~A" gen)))
+ (snd-display ";hamming window: ~A" gen)))
(let ((gen (make-fft-window rectangular-window 16)))
(if (not (vequal gen (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
- (snd-display #__line__ ";rectangular window: ~A" gen)))
+ (snd-display ";rectangular window: ~A" gen)))
(let ((gen (make-fft-window hann-window 16)))
(if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
- (snd-display #__line__ ";hann window: ~A" gen)))
+ (snd-display ";hann window: ~A" gen)))
(let ((gen (make-fft-window welch-window 16)))
(if (not (vequal gen (float-vector 0.000 0.234 0.438 0.609 0.750 0.859 0.938 1.000 1.000 0.938 0.859 0.750 0.609 0.438 0.234 0.000)))
- (snd-display #__line__ ";welch window: ~A" gen)))
+ (snd-display ";welch window: ~A" gen)))
(let ((gen (make-fft-window connes-window 16)))
(if (not (vequal gen (float-vector 0.000 0.055 0.191 0.371 0.562 0.739 0.879 1.000 1.000 0.879 0.739 0.562 0.371 0.191 0.055 0.000)))
- (snd-display #__line__ ";connes window: ~A" gen)))
+ (snd-display ";connes window: ~A" gen)))
(let ((gen (make-fft-window parzen-window 16)))
(if (not (vequal gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
- (snd-display #__line__ ";parzen window: ~A" gen)))
+ (snd-display ";parzen window: ~A" gen)))
(let ((gen (make-fft-window bartlett-window 16)))
(if (not (vequal gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
- (snd-display #__line__ ";bartlett window: ~A" gen)))
+ (snd-display ";bartlett window: ~A" gen)))
(let ((gen (make-fft-window blackman2-window 16)))
(if (not (vequal gen (float-vector 0.005 0.020 0.071 0.177 0.344 0.558 0.775 1.000 1.000 0.775 0.558 0.344 0.177 0.071 0.020 0.005)))
- (snd-display #__line__ ";blackman2 window: ~A" gen)))
+ (snd-display ";blackman2 window: ~A" gen)))
(let ((gen (make-fft-window blackman3-window 16)))
(if (not (vequal gen (float-vector 0.000 0.003 0.022 0.083 0.217 0.435 0.696 1.000 1.000 0.696 0.435 0.217 0.083 0.022 0.003 0.000)))
- (snd-display #__line__ ";blackman3 window: ~A" gen)))
+ (snd-display ";blackman3 window: ~A" gen)))
(let ((gen (make-fft-window blackman4-window 16)))
(if (not (vequal gen (float-vector 0.002 0.002 0.003 0.017 0.084 0.263 0.562 1.000 1.000 0.562 0.263 0.084 0.017 0.003 0.002 0.002)))
- (snd-display #__line__ ";blackman4 window: ~A" gen)))
+ (snd-display ";blackman4 window: ~A" gen)))
(let ((gen (make-fft-window blackman5-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.003 0.022 0.097 0.280 0.574 1.000 1.000 0.574 0.280 0.097 0.022 0.003 0.000 0.000)))
- (snd-display #__line__ ";blackman5 window: ~A" gen)))
+ (snd-display ";blackman5 window: ~A" gen)))
(let ((gen (make-fft-window blackman6-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.001 0.011 0.064 0.223 0.520 1.000 1.000 0.520 0.223 0.064 0.011 0.001 0.000 0.000)))
- (snd-display #__line__ ";blackman6 window: ~A" gen)))
+ (snd-display ";blackman6 window: ~A" gen)))
(let ((gen (make-fft-window blackman7-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.000 0.006 0.042 0.177 0.471 1.000 1.000 0.471 0.177 0.042 0.006 0.000 0.000 0.000)))
- (snd-display #__line__ ";blackman7 window: ~A" gen)))
+ (snd-display ";blackman7 window: ~A" gen)))
(let ((gen (make-fft-window blackman8-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.000 0.003 0.028 0.141 0.426 1.000 1.000 0.426 0.141 0.028 0.003 0.000 0.000 0.000)))
- (snd-display #__line__ ";blackman8 window: ~A" gen)))
+ (snd-display ";blackman8 window: ~A" gen)))
(let ((gen (make-fft-window blackman9-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.000 0.001 0.018 0.112 0.385 1.000 1.000 0.385 0.112 0.018 0.001 0.000 0.000 -0.000)))
- (snd-display #__line__ ";blackman9 window: ~A" gen)))
+ (snd-display ";blackman9 window: ~A" gen)))
(let ((gen (make-fft-window blackman10-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.000 0.001 0.012 0.089 0.349 1.000 1.000 0.349 0.089 0.012 0.001 0.000 0.000 -0.000)))
- (snd-display #__line__ ";blackman10 window: ~A" gen)))
+ (snd-display ";blackman10 window: ~A" gen)))
(let ((gen (make-fft-window rv2-window 16)))
(if (not (vequal gen (float-vector 0.000 0.001 0.021 0.095 0.250 0.478 0.729 1.000 1.000 0.729 0.478 0.250 0.095 0.021 0.001 0.000)))
- (snd-display #__line__ ";rv2 window: ~A" gen)))
+ (snd-display ";rv2 window: ~A" gen)))
(let ((gen (make-fft-window rv3-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.003 0.029 0.125 0.330 0.622 1.000 1.000 0.622 0.330 0.125 0.029 0.003 0.000 0.000)))
- (snd-display #__line__ ";rv3 window: ~A" gen)))
+ (snd-display ";rv3 window: ~A" gen)))
(let ((gen (make-fft-window rv4-window 16)))
(if (not (vequal gen (float-vector 0.000 0.000 0.000 0.009 0.062 0.228 0.531 1.000 1.000 0.531 0.228 0.062 0.009 0.000 0.000 0.000)))
- (snd-display #__line__ ";rv4 window: ~A" gen)))
+ (snd-display ";rv4 window: ~A" gen)))
(let ((gen (make-fft-window exponential-window 16)))
(if (not (vequal gen (float-vector 0.000 0.087 0.181 0.283 0.394 0.515 0.646 0.944 0.944 0.646 0.515 0.394 0.283 0.181 0.087 0.000)))
- (snd-display #__line__ ";exponential window: ~A" gen)))
+ (snd-display ";exponential window: ~A" gen)))
(let ((gen (make-fft-window riemann-window 16)))
(if (not (vequal gen (float-vector 0.000 0.139 0.300 0.471 0.637 0.784 0.900 1.000 1.000 0.900 0.784 0.637 0.471 0.300 0.139 0.000)))
- (snd-display #__line__ ";riemann window: ~A" gen)))
+ (snd-display ";riemann window: ~A" gen)))
(let ((gen (make-fft-window kaiser-window 16 2.5)))
(if (not (vequal gen (float-vector 0.304 0.426 0.550 0.670 0.779 0.871 0.941 1.000 1.000 0.941 0.871 0.779 0.670 0.550 0.426 0.304)))
- (snd-display #__line__ ";kaiser window: ~A" gen)))
+ (snd-display ";kaiser window: ~A" gen)))
(let ((gen (make-fft-window cauchy-window 16 2.5)))
(if (not (vequal gen (float-vector 0.138 0.173 0.221 0.291 0.390 0.532 0.719 1.000 1.000 0.719 0.532 0.390 0.291 0.221 0.173 0.138)))
- (snd-display #__line__ ";cauchy window: ~A" gen)))
+ (snd-display ";cauchy window: ~A" gen)))
(let ((gen (make-fft-window poisson-window 16 2.5)))
(if (not (vequal gen (float-vector 0.082 0.112 0.153 0.210 0.287 0.392 0.535 1.000 1.000 0.535 0.392 0.287 0.210 0.153 0.112 0.082)))
- (snd-display #__line__ ";poisson window: ~A" gen)))
+ (snd-display ";poisson window: ~A" gen)))
(let ((gen (make-fft-window gaussian-window 16 1.0)))
(if (not (vequal gen (float-vector 0.607 0.682 0.755 0.823 0.882 0.932 0.969 1.000 1.000 0.969 0.932 0.882 0.823 0.755 0.682 0.607)))
- (snd-display #__line__ ";gaussian window: ~A" gen)))
+ (snd-display ";gaussian window: ~A" gen)))
(let ((gen (make-fft-window tukey-window 16)))
(if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
- (snd-display #__line__ ";tukey window: ~A" gen)))
+ (snd-display ";tukey window: ~A" gen)))
(let ((gen (make-fft-window hann-poisson-window 16)))
(if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
- (snd-display #__line__ ";tukey window: ~A" gen)))
+ (snd-display ";tukey window: ~A" gen)))
(let ((gen (make-fft-window bohman-window 16)))
(if (not (vequal gen (float-vector 0.000 0.006 0.048 0.151 0.318 0.533 0.755 1.000 1.000 0.755 0.533 0.318 0.151 0.048 0.006 0.000)))
- (snd-display #__line__ ";bohman window: ~A" gen)))
+ (snd-display ";bohman window: ~A" gen)))
(for-each
(lambda (window-data)
@@ -15687,7 +15248,7 @@ EDITS: 2
(set! (v2 i) val)
(set! (v2 j) val)))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";~A by hand:~%; mus: ~A~%; loc: ~A" name v1 v2)))))
+ (snd-display ";~A by hand:~%; mus: ~A~%; loc: ~A" name v1 v2)))))
(list
(list hann-window "hann" (lambda (ang)
@@ -15871,7 +15432,7 @@ EDITS: 2
(if (> (abs (- val (win i))) .03)
(begin
(set! unhappy #t)
- (snd-display #__line__ ";bartlett-hann at ~D: ~A ~A" i val (win i)))))))
+ (snd-display ";bartlett-hann at ~D: ~A ~A" i val (win i)))))))
(let ((win (make-fft-window flat-top-window 32))
(unhappy #f))
(do ((i 0 (+ i 1)))
@@ -15884,150 +15445,149 @@ EDITS: 2
(if (> (abs (- val (win i))) .1) ; error is much less, of course, in a bigger window
(begin
(set! unhappy #t)
- (snd-display #__line__ ";flat-top at ~D: ~A ~A" i val (win i)))))))
+ (snd-display ";flat-top at ~D: ~A ~A" i val (win i)))))))
(catch #t
(lambda ()
(let ((gen (make-fft-window samaraki-window 16)))
(if (not (vequal gen (float-vector 1.000 0.531 0.559 0.583 0.604 0.620 0.631 0.638 0.640 0.638 0.631 0.620 0.604 0.583 0.559 0.531)))
- (snd-display #__line__ ";samaraki window: ~A" gen)))
+ (snd-display ";samaraki window: ~A" gen)))
(let ((gen (make-fft-window ultraspherical-window 16)))
(if (not (vequal gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
- (snd-display #__line__ ";ultraspherical window: ~A" gen)))
+ (snd-display ";ultraspherical window: ~A" gen)))
(let ((gen (make-fft-window dolph-chebyshev-window 16)))
(if (not (vequal gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
- (snd-display #__line__ ";dolph-chebyshev window: ~A" gen)))
+ (snd-display ";dolph-chebyshev window: ~A" gen)))
(without-errors
(let ((gen (make-fft-window dolph-chebyshev-window 16 1.0)))
(if (not (vequal gen (float-vector 1.000 0.274 0.334 0.393 0.446 0.491 0.525 0.546 0.553 0.546 0.525 0.491 0.446 0.393 0.334 0.274)))
- (snd-display #__line__ ";dolph-chebyshev window: ~A" gen))))
+ (snd-display ";dolph-chebyshev window: ~A" gen))))
(let ((val1 (make-fft-window ultraspherical-window 16 0.0 0.0))
(val2 (make-fft-window dolph-chebyshev-window 16 0.0)))
- (if (not (vequal val1 val2)) (snd-display #__line__ ";ultra/dolph 0: ~A ~A" val1 val2)))
+ (if (not (vequal val1 val2)) (snd-display ";ultra/dolph 0: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.0 1.0))
(val2 (make-fft-window samaraki-window 16 0.0)))
- (if (not (vequal val1 val2)) (snd-display #__line__ ";ultra/sam 0: ~A ~A" val1 val2)))
+ (if (not (vequal val1 val2)) (snd-display ";ultra/sam 0: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.5 0.0))
(val2 (make-fft-window dolph-chebyshev-window 16 0.5)))
- (if (not (vequal val1 val2)) (snd-display #__line__ ";ultra/dolph 5: ~A ~A" val1 val2)))
+ (if (not (vequal val1 val2)) (snd-display ";ultra/dolph 5: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.5 1.0))
(val2 (make-fft-window samaraki-window 16 0.5)))
- (if (not (vequal val1 val2)) (snd-display #__line__ ";ultra/sam 5: ~A ~A" val1 val2)))
+ (if (not (vequal val1 val2)) (snd-display ";ultra/sam 5: ~A ~A" val1 val2)))
(let ((val1 (dolph 16 1.0))
(val2 (make-fft-window dolph-chebyshev-window 16 1.0)))
- (if (not (vequal val1 val2)) (snd-display #__line__ ";dolph/dolph 1: ~A ~A" val1 val2))))
- (lambda args (snd-display #__line__ ";new windows: ~A" args)))
-
- (if (defined? 'gsl-eigenvectors)
- (begin
- (let ((win (make-dpss-window 16 .01)))
- (if (not (vequal win (float-vector 0.964 0.973 0.981 0.987 0.992 0.996 0.999 1.000 1.000 0.999 0.996 0.992 0.987 0.981 0.973 0.964)))
- (snd-display #__line__ ";make-dpss-window 16 .01: ~A" win)))
- (let ((win (make-dpss-window 16 .1)))
- (if (not (vequal win (float-vector 0.090 0.193 0.332 0.494 0.664 0.818 0.936 1.000 1.000 0.936 0.818 0.664 0.494 0.332 0.193 0.090)))
- (snd-display #__line__ ";make-dpss-window 16 .1: ~A" win)))
- (let ((win (make-dpss-window 32 .09)))
- (if (not (vequal win (float-vector 0.004 0.011 0.025 0.050 0.086 0.138 0.206 0.290 0.388 0.496 0.610 0.722 0.823 0.908 0.968 1.000
- 1.000 0.968 0.908 0.823 0.722 0.610 0.496 0.388 0.290 0.206 0.138 0.086 0.050 0.025 0.011 0.004)))
- (snd-display #__line__ ";make-dpss-window 32 .09: ~A" win)))
-
- (for-each
- (lambda (n)
- (for-each
- (lambda (beta)
- (let ((win1 (make-dpss-window n beta))
- (win2 (make-fft-window dpss-window n beta)))
- (if (not (vequal win1 win2))
- (snd-display #__line__ ";dpss-windows:~% ~A~% ~A" win1 win2))))
- (list .01 .07 .12 .2)))
- (list 16 32))))
+ (if (not (vequal val1 val2)) (snd-display ";dolph/dolph 1: ~A ~A" val1 val2))))
+ (lambda args (snd-display ";new windows: ~A" args)))
+
+ (when (defined? 'gsl-eigenvectors)
+ (let ((win (make-dpss-window 16 .01)))
+ (if (not (vequal win (float-vector 0.964 0.973 0.981 0.987 0.992 0.996 0.999 1.000 1.000 0.999 0.996 0.992 0.987 0.981 0.973 0.964)))
+ (snd-display ";make-dpss-window 16 .01: ~A" win)))
+ (let ((win (make-dpss-window 16 .1)))
+ (if (not (vequal win (float-vector 0.090 0.193 0.332 0.494 0.664 0.818 0.936 1.000 1.000 0.936 0.818 0.664 0.494 0.332 0.193 0.090)))
+ (snd-display ";make-dpss-window 16 .1: ~A" win)))
+ (let ((win (make-dpss-window 32 .09)))
+ (if (not (vequal win (float-vector 0.004 0.011 0.025 0.050 0.086 0.138 0.206 0.290 0.388 0.496 0.610 0.722 0.823 0.908 0.968 1.000
+ 1.000 0.968 0.908 0.823 0.722 0.610 0.496 0.388 0.290 0.206 0.138 0.086 0.050 0.025 0.011 0.004)))
+ (snd-display ";make-dpss-window 32 .09: ~A" win)))
+
+ (for-each
+ (lambda (n)
+ (for-each
+ (lambda (beta)
+ (let ((win1 (make-dpss-window n beta))
+ (win2 (make-fft-window dpss-window n beta)))
+ (if (not (vequal win1 win2))
+ (snd-display ";dpss-windows:~% ~A~% ~A" win1 win2))))
+ (list .01 .07 .12 .2)))
+ (list 16 32)))
(let ((win (make-papoulis-window 32)))
(if (not (vequal win (float-vector 0.000 0.001 0.006 0.021 0.048 0.091 0.151 0.227 0.318 0.422 0.533 0.647 0.755 0.852 0.930 0.982
1.000 0.982 0.930 0.852 0.755 0.647 0.533 0.422 0.318 0.227 0.151 0.091 0.048 0.021 0.006 0.001)))
- (snd-display #__line__ ";make-papoulis-window 32: ~A" win)))
+ (snd-display ";make-papoulis-window 32: ~A" win)))
(for-each
(lambda (n)
(let ((win1 (make-papoulis-window n))
(win2 (make-fft-window papoulis-window n)))
(if (not (vequal win1 win2))
- (snd-display #__line__ ";papoulis-windows:~% ~A~% ~A" win1 win2))))
+ (snd-display ";papoulis-windows:~% ~A~% ~A" win1 win2))))
(list 32 64 256))
(let ((v0 (make-float-vector 10))
- (gen (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 11))
- (v1 (make-float-vector 10))
- (gen1 (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 11)))
+ (gen (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 11)))
(print-and-check gen
"env"
"env linear, pass: 0 (dur: 11), index: 0, scaler: 0.5000, offset: 0.0000, data: [0 0 1 1 2 0]")
- (if (not (env? gen)) (snd-display #__line__ ";~A not env?" gen))
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";env scaler ~F?" (mus-scaler gen)))
- (if (fneq (mus-increment gen) 1.0) (snd-display #__line__ ";env base (1.0): ~A?" (mus-increment gen)))
- (if (not (= (mus-length gen) 11)) (snd-display #__line__ ";env length: ~A" (mus-length gen)))
+ (if (not (env? gen)) (snd-display ";~A not env?" gen))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";env scaler ~F?" (mus-scaler gen)))
+ (if (fneq (mus-increment gen) 1.0) (snd-display ";env base (1.0): ~A?" (mus-increment gen)))
+ (if (not (= (mus-length gen) 11)) (snd-display ";env length: ~A" (mus-length gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (env gen)))
- (let ((off 123.0))
+ (let ((off 123.0)
+ (v1 (make-float-vector 10))
+ (gen1 (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 11)))
(fill-float-vector v1 (begin
- (set! off (mus-offset gen1))
- (if (env? gen1) (env gen1) -1.0)))
- (if (fneq off 0.0) (snd-display #__line__ ";mus-offset opt: ~A" off)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map env: ~A ~A" v0 v1))
+ (set! off (mus-offset gen1))
+ (if (env? gen1) (env gen1) -1.0)))
+ (if (fneq off 0.0) (snd-display ";mus-offset opt: ~A" off))
+ (if (not (vequal v0 v1)) (snd-display ";map env: ~A ~A" v0 v1)))
(if (or (fneq (v0 0) 0.0) (fneq (v0 1) .1) (fneq (v0 6) .4))
- (snd-display #__line__ ";~A output: ~A" gen v0))
- (if (fneq (env-interp 1.6 gen) 0.2) (snd-display #__line__ ";env-interp ~A at 1.6: ~F?" gen (env-interp 1.5 gen)))
+ (snd-display ";~A output: ~A" gen v0))
+ (if (fneq (env-interp 1.6 gen) 0.2) (snd-display ";env-interp ~A at 1.6: ~F?" gen (env-interp 1.5 gen)))
(set! gen (make-env :envelope '(0 1 1 0) :base 32.0 :length 11))
- (if (fneq (mus-increment gen) 32.0) (snd-display #__line__ ";env base (32.0): ~A?" (mus-increment gen)))
+ (if (fneq (mus-increment gen) 32.0) (snd-display ";env base (32.0): ~A?" (mus-increment gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (env gen)))
(if (or (fneq (v0 0) 1.0) (fneq (v0 1) .698) (fneq (v0 8) .032))
- (snd-display #__line__ ";~A output: ~A" gen v0))
+ (snd-display ";~A output: ~A" gen v0))
(set! gen (make-env :envelope '(0 1 1 0) :base .0325 :length 11))
- (if (fneq (mus-increment gen) .0325) (snd-display #__line__ ";env base (.0325): ~A?" (mus-increment gen)))
+ (if (fneq (mus-increment gen) .0325) (snd-display ";env base (.0325): ~A?" (mus-increment gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (env gen)))
(if (or (fneq (v0 0) 1.0) (fneq (v0 1) .986) (fneq (v0 8) .513))
- (snd-display #__line__ ";~A output: ~A" gen v0))
+ (snd-display ";~A output: ~A" gen v0))
(set! gen (make-env :envelope '(0 1 1 .5 2 0) :base 0.0 :length 11 :offset 1.0))
- (if (fneq (mus-offset gen) 1.0) (snd-display #__line__ ";mus-offset: ~A" (mus-offset gen)))
- (if (fneq (mus-increment gen) 0.0) (snd-display #__line__ ";env base (0.0): ~A?" (mus-increment gen)))
+ (if (fneq (mus-offset gen) 1.0) (snd-display ";mus-offset: ~A" (mus-offset gen)))
+ (if (fneq (mus-increment gen) 0.0) (snd-display ";env base (0.0): ~A?" (mus-increment gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(if (and (= i 3)
(not (= (mus-location gen) 3)))
- (snd-display #__line__ ";env location: ~A?" (mus-location gen)))
+ (snd-display ";env location: ~A?" (mus-location gen)))
(set! (v0 i) (env gen)))
(if (or (fneq (v0 0) 2.0) (fneq (v0 6) 1.5) (fneq (v0 8) 1.5))
- (snd-display #__line__ ";~A output: ~A" gen v0))
- (if (fneq (env-interp 1.5 gen) 1.5) (snd-display #__line__ ";env-interp ~A at 1.5: ~F?" gen (env-interp 1.5 gen)))
+ (snd-display ";~A output: ~A" gen v0))
+ (if (fneq (env-interp 1.5 gen) 1.5) (snd-display ";env-interp ~A at 1.5: ~F?" gen (env-interp 1.5 gen)))
(set! (mus-location gen) 6)
- (if (not (= (mus-location gen) 6)) (snd-display #__line__ ";set! mus-location ~A (6)?" (mus-location gen)))
+ (if (not (= (mus-location gen) 6)) (snd-display ";set! mus-location ~A (6)?" (mus-location gen)))
(let ((val (env gen)))
- (if (fneq val 1.5) (snd-display #__line__ ";set! mus-location 6 -> ~A (1.5)?" val)))
+ (if (fneq val 1.5) (snd-display ";set! mus-location 6 -> ~A (1.5)?" val)))
(set! (mus-location gen) 0)
(let ((val (env gen)))
- (if (fneq val 2.0) (snd-display #__line__ ";set! mus-location 0 -> ~A (2.0)?" val)))
+ (if (fneq val 2.0) (snd-display ";set! mus-location 0 -> ~A (2.0)?" val)))
(let ((gen (make-env '(0 0 1 -1 2 0) :length 11)))
(do ((i 0 (+ i 1)))
((= i 5))
(let ((val (env gen)))
- (if (fneq val (/ i -5.0)) (snd-display #__line__ ";neg env: ~D ~A" i val))))
+ (if (fneq val (/ i -5.0)) (snd-display ";neg env: ~D ~A" i val))))
(do ((i 0 (+ i 1)))
((= i 5))
(let ((val (env gen)))
- (if (fneq val (+ -1.0 (/ i 5.0))) (snd-display #__line__ ";neg env: ~D ~A" (+ i 5) val)))))
+ (if (fneq val (- (/ i 5.0) 1.0)) (snd-display ";neg env: ~D ~A" (+ i 5) val)))))
(let ((gen (make-env '(0 0 1 -1 2 0) :length 11 :base 0.5))
(v (float-vector 0.0 -0.14869 -0.31950 -0.51571 -0.74110 -1.0 -0.74110 -0.51571 -0.31950 -0.14869)))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((val (env gen)))
- (if (fneq val (v i)) (snd-display #__line__ ";neg exp env: ~D ~A" i val))))
+ (if (fneq val (v i)) (snd-display ";neg exp env: ~D ~A" i val))))
(mus-apply gen))
(let ((v (make-float-vector 10)))
@@ -16036,63 +15596,63 @@ EDITS: 2
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
- (snd-display #__line__ ";simple ramp: ~A" v)))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env '(0 0 1 1) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
- (snd-display #__line__ ";simple ramp, base 0: ~A" v))))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env '(0 0 1 1 2 .5) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
- (snd-display #__line__ ";two-step, base 0: ~A" v))))
+ (snd-display ";simple ramp: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env '(0 0 1 1) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (snd-display ";simple ramp, base 0: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env '(0 0 1 1 2 .5) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env '((0 0) (1 1)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
- (snd-display #__line__ ";simple ramp embedded: ~A" v)))
+ (snd-display ";simple ramp embedded: ~A" v)))
(let ((e (make-env '(0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
- (snd-display #__line__ ";simple ramp down: ~A" v)))
+ (snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";simple pyr: ~A" v)))
+ (snd-display ";simple pyr: ~A" v)))
(let ((e (make-env '((0 0) (1 1) (2 0)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";simple pyr embedded: ~A" v)))
+ (snd-display ";simple pyr embedded: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v)))
+ (snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env '((0 0) (1 1) (2 -.5)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5 embedded: ~A" v)))
+ (snd-display ";simple pyr -.5 embedded: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v))))
+ (snd-display ";simple pyr -.5: ~A" v))))
(let ((v (make-float-vector 10)))
(let ((e (make-env (float-vector 0 0 1 1) :length 10)))
@@ -16100,45 +15660,45 @@ EDITS: 2
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
- (snd-display #__line__ ";simple ramp: ~A" v)))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env (float-vector 0 0 1 1) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
- (snd-display #__line__ ";simple ramp, base 0: ~A" v))))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env (float-vector 0 0 1 1 2 .5) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
- (snd-display #__line__ ";two-step, base 0: ~A" v))))
+ (snd-display ";simple ramp: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env (float-vector 0 0 1 1) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (snd-display ";simple ramp, base 0: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env (float-vector 0 0 1 1 2 .5) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env (float-vector 0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
- (snd-display #__line__ ";simple ramp down: ~A" v)))
+ (snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";simple pyr: ~A" v)))
+ (snd-display ";simple pyr: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v)))
+ (snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v))))
+ (snd-display ";simple pyr -.5: ~A" v))))
(let ((v (make-float-vector 10)))
(let ((e (make-env (vector 0 0 1 1) :length 10)))
@@ -16146,95 +15706,95 @@ EDITS: 2
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
- (snd-display #__line__ ";simple ramp: ~A" v)))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env (vector 0 0 1 1) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
- (snd-display #__line__ ";simple ramp, base 0: ~A" v))))
- (let ((v (make-float-vector 10)))
- (let ((e (make-env (vector 0 0 1 1 2 .5) :base 0 :length 8)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
- (snd-display #__line__ ";two-step, base 0: ~A" v))))
+ (snd-display ";simple ramp: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env (vector 0 0 1 1) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (snd-display ";simple ramp, base 0: ~A" v)))
+ (let* ((v (make-float-vector 10))
+ (e (make-env (vector 0 0 1 1 2 .5) :base 0 :length 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (env e)))
+ (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env (vector 0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
- (snd-display #__line__ ";simple ramp down: ~A" v)))
+ (snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";simple pyr: ~A" v)))
+ (snd-display ";simple pyr: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v)))
+ (snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
- (snd-display #__line__ ";simple pyr -.5: ~A" v))))
+ (snd-display ";simple pyr -.5: ~A" v))))
(let ((e (make-env '(0 0 1 1) :length 10)))
- (if (fneq (env-interp 1.0 e) 1.0) (snd-display #__line__ ";env-interp 0011 at 1: ~A" (env-interp 1.0 e)))
- (if (fneq (env-interp 2.0 e) 1.0) (snd-display #__line__ ";env-interp 0011 at 2: ~A" (env-interp 2.0 e)))
- (if (fneq (env-interp 0.0 e) 0.0) (snd-display #__line__ ";env-interp 0011 at 0: ~A" (env-interp 0.0 e)))
- (if (fneq (env-interp 0.444 e) 0.444) (snd-display #__line__ ";env-interp 0011 at .444: ~A" (env-interp 0.45 e)))
+ (if (fneq (env-interp 1.0 e) 1.0) (snd-display ";env-interp 0011 at 1: ~A" (env-interp 1.0 e)))
+ (if (fneq (env-interp 2.0 e) 1.0) (snd-display ";env-interp 0011 at 2: ~A" (env-interp 2.0 e)))
+ (if (fneq (env-interp 0.0 e) 0.0) (snd-display ";env-interp 0011 at 0: ~A" (env-interp 0.0 e)))
+ (if (fneq (env-interp 0.444 e) 0.444) (snd-display ";env-interp 0011 at .444: ~A" (env-interp 0.45 e)))
(mus-reset e)
(do ((i 0 (+ i 1)))
((= i 10))
(let ((val (env e)))
- (if (fneq val (* i .111111)) (snd-display #__line__ ";ramp env over 10: ~A at ~A" val i)))))
+ (if (fneq val (* i .111111)) (snd-display ";ramp env over 10: ~A at ~A" val i)))))
(let ((e (make-env '(0 0 .5 .5 1 1) :base 32 :length 10))
(v (float-vector 0.0 0.0243 0.0667 0.1412 0.2716 0.5000 0.5958 0.7090 0.8425 1.0)))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.11111)))
((= i 10))
(let ((val (env-interp x e)))
- (if (fneq val (v i)) (snd-display #__line__ ";(0 .5 1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
+ (if (fneq val (v i)) (snd-display ";(0 .5 1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
(let ((e (make-env '(0 -1.0 1 1) :base 32 :length 10))
(v (float-vector -1.0 -0.9697 -0.9252 -0.8597 -0.7635 -0.6221 -0.4142 -0.1088 0.34017 1.0)))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.11111)))
((= i 10))
(let ((val (env-interp x e)))
- (if (fneq val (v i)) (snd-display #__line__ ";(-1 1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
+ (if (fneq val (v i)) (snd-display ";(-1 1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
(let ((e (make-env '(0 -1.0 .5 .5 1 0) :base 32 :length 10))
(v (float-vector -1.0 -0.952 -0.855 -0.661 -0.274 0.5 0.356 0.226 0.107 0.0)))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.11111)))
((= i 10))
(let ((val (env-interp x e)))
- (if (fneq val (v i)) (snd-display #__line__ ";(-1 .5 0) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
+ (if (fneq val (v i)) (snd-display ";(-1 .5 0) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
(let ((e (make-env '(0 0.0 .5 .5 1 -1.0) :base 32 :length 10))
(v (float-vector 0.0 0.085 0.177 0.276 0.384 0.5 -0.397 -0.775 -0.933 -1.0)))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.11111)))
((= i 10))
(let ((val (env-interp x e)))
- (if (fneq val (v i)) (snd-display #__line__ ";(0 .5 -1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
+ (if (fneq val (v i)) (snd-display ";(0 .5 -1) env-interp over 10: ~A at ~A (~A)" val i (v i))))))
(let ((e (make-env '(0 0 1 1) :length 10 :base 4.0)))
- (if (fneq (env-interp 1.0 e) 1.0) (snd-display #__line__ ";env-interp 0011 4 at 1: ~A" (env-interp 1.0 e)))
- (if (fneq (env-interp 0.0 e) 0.0) (snd-display #__line__ ";env-interp 0011 4 at 0: ~A" (env-interp 0.0 e)))
- (if (fneq (env-interp 0.45 e) 0.2839) (snd-display #__line__ ";env-interp 0011 4 at .45: ~A" (env-interp 0.45 e))))
+ (if (fneq (env-interp 1.0 e) 1.0) (snd-display ";env-interp 0011 4 at 1: ~A" (env-interp 1.0 e)))
+ (if (fneq (env-interp 0.0 e) 0.0) (snd-display ";env-interp 0011 4 at 0: ~A" (env-interp 0.0 e)))
+ (if (fneq (env-interp 0.45 e) 0.2839) (snd-display ";env-interp 0011 4 at .45: ~A" (env-interp 0.45 e))))
(let ((e (make-env '(0 0 1 1) :length 10 :base 0.2)))
- (if (fneq (env-interp 1.0 e) 1.0) (snd-display #__line__ ";env-interp 0011 2 at 1: ~A" (env-interp 1.0 e)))
- (if (fneq (env-interp 0.0 e) 0.0) (snd-display #__line__ ";env-interp 0011 2 at 0: ~A" (env-interp 0.0 e)))
- (if (fneq (env-interp 0.45 e) 0.6387) (snd-display #__line__ ";env-interp 0011 2 at .45: ~A" (env-interp 0.45 e))))
+ (if (fneq (env-interp 1.0 e) 1.0) (snd-display ";env-interp 0011 2 at 1: ~A" (env-interp 1.0 e)))
+ (if (fneq (env-interp 0.0 e) 0.0) (snd-display ";env-interp 0011 2 at 0: ~A" (env-interp 0.0 e)))
+ (if (fneq (env-interp 0.45 e) 0.6387) (snd-display ";env-interp 0011 2 at .45: ~A" (env-interp 0.45 e))))
(let ((val (let ((e (make-env '(0 0 1 1) :length 10 :offset 2.0))) (set! (mus-offset e) 3.0) (mus-offset e))))
- (if (fneq val 3.0) (snd-display #__line__ ";set mus-offset env: ~A" val)))
+ (if (fneq val 3.0) (snd-display ";set mus-offset env: ~A" val)))
(let ((e (make-env '(0 0 1 1 2 0) :length 10))
(v (make-float-vector 10 0.0)))
@@ -16242,37 +15802,37 @@ EDITS: 2
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";e set off 0: ~A" v))
- (if (not (= (mus-length e) 10)) (snd-display #__line__ ";e set off 0 len: ~A" (mus-length e)))
- (if (fneq (mus-scaler e) 1.0) (snd-display #__line__ ";e set off 0 scl: ~A" (mus-scaler e)))
- (if (fneq (mus-offset e) 0.0) (snd-display #__line__ ";e set off 0 off: ~A" (mus-offset e)))
+ (snd-display ";e set off 0: ~A" v))
+ (if (not (= (mus-length e) 10)) (snd-display ";e set off 0 len: ~A" (mus-length e)))
+ (if (fneq (mus-scaler e) 1.0) (snd-display ";e set off 0 scl: ~A" (mus-scaler e)))
+ (if (fneq (mus-offset e) 0.0) (snd-display ";e set off 0 off: ~A" (mus-offset e)))
(set! (mus-scaler e) 2.0)
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.400 0.800 1.200 1.600 2.000 1.500 1.000 0.500 0.000)))
- (snd-display #__line__ ";e set off 1: ~A" v))
- (if (not (= (mus-length e) 10)) (snd-display #__line__ ";e set off 1 len: ~A" (mus-length e)))
- (if (fneq (mus-scaler e) 2.0) (snd-display #__line__ ";e set off 1 scl: ~A" (mus-scaler e)))
- (if (fneq (mus-offset e) 0.0) (snd-display #__line__ ";e set off 1 off: ~A" (mus-offset e)))
+ (snd-display ";e set off 1: ~A" v))
+ (if (not (= (mus-length e) 10)) (snd-display ";e set off 1 len: ~A" (mus-length e)))
+ (if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 1 scl: ~A" (mus-scaler e)))
+ (if (fneq (mus-offset e) 0.0) (snd-display ";e set off 1 off: ~A" (mus-offset e)))
(set! (mus-offset e) 1.0)
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 1.000 1.400 1.800 2.200 2.600 3.000 2.500 2.000 1.500 1.000)))
- (snd-display #__line__ ";e set off 2: ~A" v))
- (if (not (= (mus-length e) 10)) (snd-display #__line__ ";e set off 2 len: ~A" (mus-length e)))
- (if (fneq (mus-scaler e) 2.0) (snd-display #__line__ ";e set off 2 scl: ~A" (mus-scaler e)))
- (if (fneq (mus-offset e) 1.0) (snd-display #__line__ ";e set off 2 off: ~A" (mus-offset e)))
+ (snd-display ";e set off 2: ~A" v))
+ (if (not (= (mus-length e) 10)) (snd-display ";e set off 2 len: ~A" (mus-length e)))
+ (if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 2 scl: ~A" (mus-scaler e)))
+ (if (fneq (mus-offset e) 1.0) (snd-display ";e set off 2 off: ~A" (mus-offset e)))
(set! (mus-length e) 19)
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 1.000 1.222 1.444 1.667 1.889 2.111 2.333 2.556 2.778 3.000)))
- (snd-display #__line__ ";e set off 3: ~A" v))
- (if (not (= (mus-length e) 19)) (snd-display #__line__ ";e set off 3 len: ~A" (mus-length e)))
- (if (fneq (mus-scaler e) 2.0) (snd-display #__line__ ";e set off 3 scl: ~A" (mus-scaler e)))
- (if (fneq (mus-offset e) 1.0) (snd-display #__line__ ";e set off 3 off: ~A" (mus-offset e))))
+ (snd-display ";e set off 3: ~A" v))
+ (if (not (= (mus-length e) 19)) (snd-display ";e set off 3 len: ~A" (mus-length e)))
+ (if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 3 scl: ~A" (mus-scaler e)))
+ (if (fneq (mus-offset e) 1.0) (snd-display ";e set off 3 off: ~A" (mus-offset e))))
(let ((e (make-env (float-vector 0 0 1 1 2 0) :length 10))
(v (make-float-vector 10 0.0)))
@@ -16280,7 +15840,7 @@ EDITS: 2
((= i 10))
(set! (v i) (env e)))
(if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ ";e from float-vector: ~A" v)))
+ (snd-display ";e from float-vector: ~A" v)))
(let ((e1 (make-env '(0 0 1 1) :base 32.0 :length 11))
(v (float-vector 0.000 0.013 0.032 0.059 0.097 0.150 0.226 0.333 0.484 0.698 1.00)))
@@ -16288,7 +15848,7 @@ EDITS: 2
((> i 10))
(let ((val (env e1)))
(if (fneq val (v i))
- (snd-display #__line__ ";exp env direct (32.0): ~A ~A" val (v i))))))
+ (snd-display ";exp env direct (32.0): ~A ~A" val (v i))))))
(let ((e1 (make-env '(0 1 1 2) :base 32.0 :length 11))
(v (float-vector 1.000 1.013 1.032 1.059 1.097 1.150 1.226 1.333 1.484 1.698 2.00)))
@@ -16296,21 +15856,21 @@ EDITS: 2
((> i 10))
(let ((val (env e1)))
(if (fneq val (v i))
- (snd-display #__line__ ";exp env direct (32.0) offset: ~A ~A" val (v i))))))
+ (snd-display ";exp env direct (32.0) offset: ~A ~A" val (v i))))))
(let ((e1 (make-env '((0 1) (1 2)) :base 32.0 :length 11))
(v (float-vector 1.000 1.013 1.032 1.059 1.097 1.150 1.226 1.333 1.484 1.698 2.00)))
(do ((i 0 (+ i 1)))
((> i 10))
(let ((val (env e1)))
(if (fneq val (v i))
- (snd-display #__line__ ";exp env direct (32.0) offset embedded: ~A ~A" val (v i))))))
+ (snd-display ";exp env direct (32.0) offset embedded: ~A ~A" val (v i))))))
(let ((e1 (make-env '(0 1 1 2) :base 32.0 :length 11))
(v (float-vector 1.000 1.013 1.032 1.059 1.097 1.150 1.226 1.333 1.484 1.698 2.00)))
(do ((i 0 (+ i 1)))
((> i 10))
(let ((val (env e1)))
(if (fneq val (v i))
- (snd-display #__line__ ";exp env direct (32.0) offset (and dur): ~A ~A" val (v i))))))
+ (snd-display ";exp env direct (32.0) offset (and dur): ~A ~A" val (v i))))))
(let ((e1 (make-env '(0 0 1 1) :base 0.032 :length 11))
(v (float-vector 0.000 0.301 0.514 0.665 0.772 0.848 0.902 0.940 0.967 0.986 1.0)))
@@ -16318,7 +15878,7 @@ EDITS: 2
((> i 10))
(let ((val (env e1)))
(if (fneq val (v i))
- (snd-display #__line__ ";exp env direct (.032): ~A ~A" val (v i))))))
+ (snd-display ";exp env direct (.032): ~A ~A" val (v i))))))
(let ((e1 (make-env '(0 0 1 1) :base .03125 :length 11))
(e2 (make-env '(0 0 1 1 2 0) :base 32.0 :length 11))
@@ -16329,13 +15889,13 @@ EDITS: 2
(lv2 (env e1))
(lv3 (env-interp (* i .2) e2))
(lv4 (env e2)))
- (if (ffneq lv1 lv2) (snd-display #__line__ ";env-interp[rmp ~F]: ~A (~A)?" (* .1 i) lv1 lv2))
- (if (ffneq lv3 lv4) (snd-display #__line__ ";env-interp[pyr ~F]: ~A (~A)?" (* .2 i) lv3 lv4))))
+ (if (ffneq lv1 lv2) (snd-display ";env-interp[rmp ~F]: ~A (~A)?" (* .1 i) lv1 lv2))
+ (if (ffneq lv3 lv4) (snd-display ";env-interp[pyr ~F]: ~A (~A)?" (* .2 i) lv3 lv4))))
(do ((i 0 (+ i 1)))
((= i 100))
(let ((lv5 (env-interp (* i .02) e3))
(lv6 (env e3)))
- (if (ffneq lv5 lv6) (snd-display #__line__ ";env-interp[tri ~F]: ~A (~A)?" (* .02 i) lv5 lv6)))))
+ (if (ffneq lv5 lv6) (snd-display ";env-interp[tri ~F]: ~A (~A)?" (* .02 i) lv5 lv6)))))
(let ((e1 (make-env '(0 0 1 1 2 0) :length 10))
(lv1 (make-float-vector 11))
@@ -16345,31 +15905,31 @@ EDITS: 2
(do ((i 0 (+ i 1))) ((= i 11)) (set! (lv2 i) (env e1)))
(mus-reset e1)
(do ((i 0 (+ i 1))) ((= i 11)) (set! (lv3 i) (env e1)))
- (if (not (vequal lv1 lv3)) (snd-display #__line__ ";mus-reset: ~A ~A?" lv1 lv3))
- (if (not (vequal lv2 (make-float-vector 11))) (snd-display #__line__ ";mus-reset 1: ~A?" lv2)))
+ (if (not (vequal lv1 lv3)) (snd-display ";mus-reset: ~A ~A?" lv1 lv3))
+ (if (not (vequal lv2 (make-float-vector 11))) (snd-display ";mus-reset 1: ~A?" lv2)))
(set! gen (make-env '(0 0 1 1 2 0) :length 11))
(do ((i 0 (+ i 1))) ((= i 4)) (env gen))
(let ((val (env gen)))
- (if (fneq val .8) (snd-display #__line__ ";env(5): ~A?" val))
+ (if (fneq val .8) (snd-display ";env(5): ~A?" val))
(mus-reset gen)
(do ((i 0 (+ i 1))) ((= i 4)) (env gen))
(set! val (env gen))
- (if (fneq val .8) (snd-display #__line__ ";mus-reset (via reset): ~A?" val))
+ (if (fneq val .8) (snd-display ";mus-reset (via reset): ~A?" val))
(set! (mus-location gen) 6)
(let ((val (env gen)))
- (if (fneq val 0.8) (snd-display #__line__ ";set! mus-location 6 -> ~A (0.8)?" val)))))
+ (if (fneq val 0.8) (snd-display ";set! mus-location 6 -> ~A (0.8)?" val)))))
(let ((gen (make-env '(0 0 1 1) :base .032 :length 12)))
(set! (mus-location gen) 5)
(let ((val (env gen)))
(if (fneq val 0.817)
- (snd-display #__line__ ";set env location with base: ~A ~A" val gen))))
+ (snd-display ";set env location with base: ~A ~A" val gen))))
(let ((gen (make-env '(0 0 1 1) :base .032 :length 12)))
(set! (mus-location gen) 5)
(let ((val (env gen)))
(if (fneq val 0.817)
- (snd-display #__line__ ";set env location with base and dur: ~A ~A" val gen))))
+ (snd-display ";set env location with base and dur: ~A ~A" val gen))))
(test-gen-equal (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 10) (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 10) (make-env '(0 0 1 1 2 0) :scaler 0.25 :length 10))
(test-gen-equal (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 10) (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 10) (make-env '(0 0 1 1 2 0) :scaler 0.5 :length 11))
@@ -16378,36 +15938,37 @@ EDITS: 2
(let ((var (catch #t (lambda () (make-env :envelope ())) (lambda args args))))
(if (not (eq? (car var) 'no-data))
- (snd-display #__line__ ";make-env null env: ~A" var)))
+ (snd-display ";make-env null env: ~A" var)))
(let ((var (catch #t (lambda () (make-env :length 1)) (lambda args args))))
(if (not (eq? (car var) 'no-data))
- (snd-display #__line__ ";make-env no env: ~A" var)))
+ (snd-display ";make-env no env: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 0) :length -1)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-env bad dur: ~A" var)))
+ (snd-display ";make-env bad dur: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 0) :duration -1.0)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-env bad duration: ~A" var)))
+ (snd-display ";make-env bad duration: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 0) :base -1.0)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-env bad base: ~A" var)))
+ (snd-display ";make-env bad base: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(1 1 0 0) :length 11)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-env bad env 1 1 0 0: ~A" var)))
+ (snd-display ";make-env bad env 1 1 0 0: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 1 -1 0) :length 11)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-env bad env 0 1 -1 0: ~A" var)))
+ (snd-display ";make-env bad env 0 1 -1 0: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 1 1 0) :length 11 :length 10)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-env bad end/dur: ~A" var)))
+ (snd-display ";make-env bad end/dur: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope '(0 0 1 1 2 0 1) :duration 1.0)) (lambda args args))))
(if (not (eq? (car var) 'bad-type))
- (snd-display #__line__ ";make-env odd length env: ~A" var)))
+ (snd-display ";make-env odd length env: ~A" var)))
(let ((var (catch #t (lambda () (make-env :envelope (list "hi" 0 1 1 2 0) :duration 1.0)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-env env of non-number: ~A" var)))
+ (snd-display ";make-env env of non-number: ~A" var)))
;; env-any
+ (define env-any-env '(0 0 1 1 2 0.25 3 1 4 0))
(let* ((env-any-1 (lambda (e func)
(let* ((pts (mus-data e))
(mus-position mus-channels)
@@ -16431,7 +15992,7 @@ EDITS: 2
(blackman4-env-1 (lambda (e)
(env-any-1 e (lambda (y)
(let ((cx (cos (* pi y))))
- (+ 0.084037 (* cx (+ -.29145 (* cx (+ .375696 (* cx (+ -.20762 (* cx .041194)))))))))))))
+ (+ 0.084037 (* cx (- (* cx (+ .375696 (* cx (- (* cx .041194) .20762)))) .29145))))))))
(multi-expt-env-1 (lambda (e expts)
(env-any-1 e (lambda (y)
@@ -16443,93 +16004,93 @@ EDITS: 2
;; assume sine-env square-env blackman4-env and multi-exp-env are available from generators.scm (8)
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (sine-env e))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (sine-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (sine-env-1 e)))))))
(if (not (vequal val1 val2))
- (snd-display #__line__ ";sine-env straight and run: ~%; ~A~%; ~A" val1 val2))
+ (snd-display ";sine-env straight and run: ~%; ~A~%; ~A" val1 val2))
(if (not (vequal val1 val3))
- (snd-display #__line__ ";sine-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
+ (snd-display ";sine-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (square-env e))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (square-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (square-env-1 e)))))))
(if (not (vequal val1 val2))
- (snd-display #__line__ ";square-env straight and run: ~%; ~A~%; ~A" val1 val2))
+ (snd-display ";square-env straight and run: ~%; ~A~%; ~A" val1 val2))
(if (not (vequal val1 val3))
- (snd-display #__line__ ";square-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
+ (snd-display ";square-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (blackman4-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20)))
+ (let ((e (make-env env-any-env :length 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (blackman4-env-1 e)))))))
(if (not (vequal val1 val3))
- (snd-display #__line__ ";blackman4-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
+ (snd-display ";blackman4-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20))
+ (let ((e (make-env env-any-env :length 20))
(bases (float-vector 32.0 0.3 1.5)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (multi-expt-env e bases))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20))
+ (let ((e (make-env env-any-env :length 20))
(bases (float-vector 32.0 0.3 1.5)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (multi-expt-env e bases))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 20))
+ (let ((e (make-env env-any-env :length 20))
(bases (float-vector 32.0 0.3 1.5)))
(do ((i 0 (+ i 1)))
((= i 20))
(outa i (multi-expt-env-1 e bases)))))))
(if (not (vequal val1 val2))
- (snd-display #__line__ ";multi-expt-env straight and run: ~%; ~A~%; ~A" val1 val2))
+ (snd-display ";multi-expt-env straight and run: ~%; ~A~%; ~A" val1 val2))
(if (not (vequal val1 val3))
- (snd-display #__line__ ";multi-expt-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
+ (snd-display ";multi-expt-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 220))
- (let ((e1 (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 220))
- (e2 (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 220)))
+ (let ((e1 (make-env env-any-env :length 220))
+ (e2 (make-env env-any-env :length 220)))
(do ((i 0 (+ i 1)))
((= i 220))
(outa i (env-any e1
@@ -16538,8 +16099,8 @@ EDITS: 2
(lambda (y2)
y2))))))))))
(val2 (with-sound ((make-float-vector 220))
- (let ((e1 (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 220))
- (e2 (make-env '(0 0 1 1 2 .25 3 1 4 0) :length 220)))
+ (let ((e1 (make-env env-any-env :length 220))
+ (e2 (make-env env-any-env :length 220)))
(do ((i 0 (+ i 1)))
((= i 220))
(outa i (env-any e1 ; try it with and without "declare"
@@ -16548,7 +16109,7 @@ EDITS: 2
(lambda (y2)
y2)))))))))))
(if (not (vequal val1 val2))
- (snd-display #__line__ ";env-any recursive: ~%; ~A~%; ~A" val1 val2))))
+ (snd-display ";env-any recursive: ~%; ~A~%; ~A" val1 val2))))
(let ((ind (new-sound :size 20)))
(select-sound ind)
@@ -16556,20 +16117,20 @@ EDITS: 2
(bumpy)
(let ((vals (channel->float-vector)))
(if (not (vequal vals (float-vector 0.0 0.0 0.001 0.021 0.105 0.264 0.467 0.673 0.846 0.960 1.000 0.960 0.846 0.673 0.467 0.264 0.105 0.021 0.001 0.0)))
- (snd-display #__line__ ";bumpy: ~A" vals)))
+ (snd-display ";bumpy: ~A" vals)))
(if (fneq (channel-lp-inf) 1.0) ; just a fancy name for maxamp
- (snd-display #__line__ ";channel-lp-inf: ~A" (channel-lp-inf)))
+ (snd-display ";channel-lp-inf: ~A" (channel-lp-inf)))
(linear-src-channel 2.0)
(let ((vals (channel->float-vector)))
(if (not (vequal vals (float-vector 0.000 0.001 0.105 0.467 0.846 1.000 0.846 0.467 0.105 0.001)))
- (snd-display #__line__ ";linear-src-channel: ~A" vals)))
+ (snd-display ";linear-src-channel: ~A" vals)))
(let ((old-clip *clipping*))
(set! *clipping* #t)
(save-sound-as "tst.snd")
(let ((fvals (file->floats "tst.snd"))
(vals (channel->float-vector)))
(if (not (vequal vals fvals))
- (snd-display #__line__ ";file->floats: ~A ~A" vals fvals)))
+ (snd-display ";file->floats: ~A ~A" vals fvals)))
(mus-sound-forget "tst.snd")
(delete-file "tst.snd")
(set! *clipping* old-clip))
@@ -16577,100 +16138,99 @@ EDITS: 2
(map-channel (lambda (y)
(differentiator hp y))))
(if (fneq (maxamp) .0013)
- (snd-display #__line__ ";differentiator: ~A" (maxamp)))
+ (snd-display ";differentiator: ~A" (maxamp)))
(revert-sound ind)
(let ((val (window-rms)))
- (if (fneq val 0.0) (snd-display #__line__ ";window-rms empty: ~A" val))
+ (if (fneq val 0.0) (snd-display ";window-rms empty: ~A" val))
(set! (sample 10) 1.0)
(set! val (window-rms))
- (if (fneq val .218) (snd-display #__line__ ";window-rms 1: ~A" val))
+ (if (fneq val .218) (snd-display ";window-rms 1: ~A" val))
(let ((vals (window-samples)))
(if (or (not (float-vector? vals))
(not (= (length vals) 21))
(fneq (vals 10) 1.0))
- (snd-display #__line__ ";window-samples: ~A" vals))))
+ (snd-display ";window-samples: ~A" vals))))
(revert-sound ind)
(let ((new-file-name (file-name ind)))
(close-sound ind)
(if (file-exists? new-file-name) (delete-file new-file-name))))
(let ((gen (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1))))
- (gen1 (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1) (make-float-vector 512))))
- ;;(gen2 (partials->wave '(1 1 2 1 3 1 4 1) #f #t))
- (gen3 (make-table-lookup))
(v0 (make-float-vector 10))
- (v1 (make-float-vector 10))
- (gen4 (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1))))
- (v2 (make-float-vector 10)))
+ (v1 (make-float-vector 10)))
(print-and-check gen
"table-lookup"
"table-lookup freq: 440.000Hz, phase: 0.000, length: 512, interp: linear")
- (if (not (= (mus-length gen) 512)) (snd-display #__line__ ";table-lookup length: ~A?" (mus-length gen)))
- (if (not (= (mus-length gen3) 512)) (snd-display #__line__ ";default table-lookup length: ~A?" (mus-length gen3)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (table-lookup gen 0.0))
- (set! (v1 i) (mus-apply gen1 0.0)))
- (fill-float-vector v2 (if (table-lookup? gen4) (table-lookup gen4 0.0) -1.0))
- (if (not (vequal v0 v2)) (snd-display #__line__ ";map table-lookup: ~A ~A" v0 v2))
- (set! gen4 (make-table-lookup 440.0 :wave (partials->wave (float-vector 1 1 2 1))))
- (fill-float-vector v2 (table-lookup gen4))
- (if (not (vequal v0 v2)) (snd-display #__line__ ";map table-lookup (no fm): ~A ~A" v0 v2))
- (if (not (table-lookup? gen)) (snd-display #__line__ ";~A not table-lookup?" gen))
- (if (not (float-vector? (mus-data gen))) (snd-display #__line__ ";mus-data table-lookup: ~A" (mus-data gen)))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";table-lookup phase: ~F?" (mus-phase gen)))
+ (if (not (= (mus-length gen) 512)) (snd-display ";table-lookup length: ~A?" (mus-length gen)))
+ (let ((gen3 (make-table-lookup)))
+ (if (not (= (mus-length gen3) 512)) (snd-display ";default table-lookup length: ~A?" (mus-length gen3))))
+ (let ((gen1 (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1) (make-float-vector 512)))))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (table-lookup gen 0.0))
+ (set! (v1 i) (mus-apply gen1 0.0))))
+ (let ((v2 (make-float-vector 10)))
+ (let ((gen4 (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1)))))
+ (fill-float-vector v2 (if (table-lookup? gen4) (table-lookup gen4 0.0) -1.0))
+ (if (not (vequal v0 v2)) (snd-display ";map table-lookup: ~A ~A" v0 v2))
+ (set! gen4 (make-table-lookup 440.0 :wave (partials->wave (float-vector 1 1 2 1))))
+ (fill-float-vector v2 (table-lookup gen4)))
+ (if (not (vequal v0 v2)) (snd-display ";map table-lookup (no fm): ~A ~A" v0 v2)))
+ (if (not (table-lookup? gen)) (snd-display ";~A not table-lookup?" gen))
+ (if (not (float-vector? (mus-data gen))) (snd-display ";mus-data table-lookup: ~A" (mus-data gen)))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";table-lookup phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";set! table-lookup phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";table-lookup frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";set! table-lookup phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";table-lookup frequency: ~F?" (mus-frequency gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";set! table-lookup frequency: ~F?" (mus-frequency gen)))
- (if (or (fneq (v0 1) 0.373) (fneq (v0 8) 1.75)) (snd-display #__line__ ";table-lookup output: ~A" v0))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";set! table-lookup frequency: ~F?" (mus-frequency gen)))
+ (if (or (fneq (v0 1) 0.373) (fneq (v0 8) 1.75)) (snd-display ";table-lookup output: ~A" v0))
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";mus-apply table-lookup at ~D: ~A ~A?" i (v0 i) (v1 i))))
+ (snd-display ";mus-apply table-lookup at ~D: ~A ~A?" i (v0 i) (v1 i))))
(set! gen (make-table-lookup 440.0 :wave (phase-partials->wave (list 1 1 0 2 1 (* pi .5)))))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (table-lookup gen 0.0)))
- (if (or (fneq (v0 1) 1.094) (fneq (v0 8) .421)) (snd-display #__line__ ";table-lookup phase output: ~A" v0))
+ (if (or (fneq (v0 1) 1.094) (fneq (v0 8) .421)) (snd-display ";table-lookup phase output: ~A" v0))
(if (or (fneq (float-vector-peak (partials->wave '(1 1 2 1))) 1.76035475730896)
(fneq (float-vector-peak (partials->wave '(1 1 2 1) #f #t)) 1.0)
(fneq (float-vector-peak (partials->wave '(1 1 2 1 3 1 4 1) #f #t)) 1.0))
- (snd-display #__line__ ";normalized partials?"))
+ (snd-display ";normalized partials?"))
(set! (mus-data gen) (phase-partials->wave (list 1 1 0 2 1 (* pi .5)) #f #t)))
(let ((tag (catch #t (lambda () (phase-partials->wave (list 1 .3 2 .2))) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";bad length arg to phase-partials->wave: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";bad length arg to phase-partials->wave: ~A" tag)))
(let ((tag (catch #t (lambda () (phase-partials->wave (list "hiho" .3 2 .2))) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";bad harmonic arg to phase-partials->wave: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";bad harmonic arg to phase-partials->wave: ~A" tag)))
(let ((tag (catch #t (lambda () (phase-partials->wave (list))) (lambda args (car args)))))
- (if (not (eq? tag 'no-data)) (snd-display #__line__ ";nil list to phase-partials->wave: ~A" tag)))
+ (if (not (eq? tag 'no-data)) (snd-display ";nil list to phase-partials->wave: ~A" tag)))
(let ((vals (phase-partials->wave (list 1 1 0) (make-float-vector 16) #f)))
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (vals i) (sin (/ (* 2 pi i) 16)))
- (snd-display #__line__ ";phase-partials->wave 1 1 0 at ~D: ~A ~A" i (vals i) (sin (/ (* 2 pi i) 16))))))
+ (snd-display ";phase-partials->wave 1 1 0 at ~D: ~A ~A" i (vals i) (sin (/ (* 2 pi i) 16))))))
(let ((vals (phase-partials->wave (list 1 1 (* .25 pi)) (make-float-vector 16) #f)))
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (vals i) (sin (+ (* .25 pi) (/ (* 2 pi i) 16))))
- (snd-display #__line__ ";phase-partials->wave 1 1 .25 at ~D: ~A ~A" i (vals i) (sin (+ (* .25 pi) (/ (* 2 pi i) 16)))))))
+ (snd-display ";phase-partials->wave 1 1 .25 at ~D: ~A ~A" i (vals i) (sin (+ (* .25 pi) (/ (* 2 pi i) 16)))))))
(let ((vals (phase-partials->wave (float-vector 1 1 0 2 1 0) (make-float-vector 16) #f)))
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (vals i) (+ (sin (/ (* 2 pi i) 16)) (sin (/ (* 4 pi i) 16))))
- (snd-display #__line__ ";phase-partials->wave 1 1 0 2 1 0 at ~D: ~A ~A" i (vals i)
+ (snd-display ";phase-partials->wave 1 1 0 2 1 0 at ~D: ~A ~A" i (vals i)
(+ (sin (/ (* 2 pi i) 16)) (sin (/ (* 4 pi i) 16)))))))
(let ((vals (phase-partials->wave (float-vector 1 1 0 2 1 (* .5 pi)) (make-float-vector 16) #f)))
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (vals i) (+ (sin (/ (* 2 pi i) 16)) (sin (+ (* .5 pi) (/ (* 4 pi i) 16)))))
- (snd-display #__line__ ";phase-partials->wave 1 1 0 2 1 .5 at ~D: ~A ~A" i (vals i)
+ (snd-display ";phase-partials->wave 1 1 0 2 1 .5 at ~D: ~A ~A" i (vals i)
(+ (sin (/ (* 2 pi i) 16)) (sin (+ (* .5 pi) (/ (* 4 pi i) 16))))))))
(test-gen-equal (make-table-lookup 440.0 :wave (partials->wave (float-vector 1 1 2 1)))
@@ -16683,12 +16243,12 @@ EDITS: 2
(make-table-lookup-with-env 440.0 (list 0 0 1 1))
(make-table-lookup-with-env 440.0 '(0 0 1 1 2 0)))
(let ((tag (catch #t (lambda () (partials->wave (list .5 .3 .2))) (lambda args (car args)))))
- (if (not (eq? tag 'bad-type)) (snd-display #__line__ ";odd length arg to partials->wave: ~A" tag)))
+ (if (not (eq? tag 'bad-type)) (snd-display ";odd length arg to partials->wave: ~A" tag)))
(let ((hi (make-table-lookup :size 256)))
- (if (not (= (mus-length hi) 256)) (snd-display #__line__ ";table-lookup set length: ~A?" (mus-length hi))))
+ (if (not (= (mus-length hi) 256)) (snd-display ";table-lookup set length: ~A?" (mus-length hi))))
(let ((tag (catch #t (lambda () (make-table-lookup :size 0)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";table-lookup size 0: ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";table-lookup size 0: ~A" tag)))
(let ((gen (make-table-lookup 440.0 :wave (partials->wave '(1 1))))
(incr (/ (* 2 pi 440.0) 22050.0)))
@@ -16698,7 +16258,7 @@ EDITS: 2
(let ((val1 (sin a))
(val2 (gen 0.0)))
(if (fneq val1 val2)
- (snd-display #__line__ ";table lookup (1 1): ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";table lookup (1 1): ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-table-lookup 4.0 :wave (partials->wave '(1 1))))
(incr (/ (* 2 pi 4.0) 22050.0)))
@@ -16708,7 +16268,7 @@ EDITS: 2
(let ((val1 (sin a))
(val2 (gen 0.0)))
(if (fneq val1 val2)
- (snd-display #__line__ ";table lookup (1 1) 4: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";table lookup (1 1) 4: ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-table-lookup 440.0 :wave (partials->wave '(1 .75 3 .25))))
(incr (/ (* 2 pi 440.0) 22050.0)))
@@ -16718,7 +16278,7 @@ EDITS: 2
(let ((val1 (+ (* .75 (sin a)) (* .25 (sin (* 3 a)))))
(val2 (gen 0.0)))
(if (fneq val1 val2)
- (snd-display #__line__ ";table lookup (1 .75 3 .25): ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";table lookup (1 .75 3 .25): ~A: ~A ~A" i val1 val2)))))
(let ((gen (make-table-lookup 0.0 :wave (partials->wave '(1 1))))
(gen1 (make-table-lookup 40.0 :wave (partials->wave '(1 1))))
@@ -16732,7 +16292,7 @@ EDITS: 2
(val2 (table-lookup gen (table-lookup gen1 0.0))))
(set! a1 (+ a1 fm))
(if (fneq val1 val2)
- (snd-display #__line__ ";lookup/lookup fm: ~A: ~A ~A" i val1 val2)))))
+ (snd-display ";lookup/lookup fm: ~A: ~A ~A" i val1 val2)))))
(for-each
(lambda (args)
@@ -16744,12 +16304,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (table-lookup tbl1 (* .1 pi))))
- (if (and (not (vequal v vals))
- (not (= type mus-interp-all-pass))
- (or (not (= type mus-interp-none))
- (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000)))))
- (snd-display #__line__ ";tbl interp ~A: ~A" type v))
- (if (not (= (mus-interp-type tbl1) type)) (snd-display #__line__ ";tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
+ (if (not (or (vequal v vals)
+ (= type mus-interp-all-pass)
+ (and (= type mus-interp-none)
+ (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000)))))
+ (snd-display ";tbl interp ~A: ~A" type v))
+ (if (not (= (mus-interp-type tbl1) type)) (snd-display ";tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
(list
(list mus-interp-none (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 1.000))
(list mus-interp-linear (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.800 0.600 0.400 0.200))
@@ -16758,16 +16318,15 @@ EDITS: 2
(list mus-interp-hermite (float-vector 0.000 0.168 0.424 0.696 0.912 1.000 0.912 0.696 0.424 0.168))))
;; this is different if doubles -- not sure whether it's a bug or not
- (let ((size 1000)
- (tbl-size 1024))
-
+ (let ((size 1000))
(define (test-tbl beg end freq amp mc-ratio index)
- (let* ((sine (let ((v (make-float-vector tbl-size))
- (xp (/ (* 2 pi) tbl-size)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x xp)))
- ((= i tbl-size) v)
- (set! (v i) (sin x)))))
+ (let* ((tbl-size 1024)
+ (sine (do ((v (make-float-vector tbl-size))
+ (xp (/ (* 2 pi) tbl-size))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x xp)))
+ ((= i tbl-size) v)
+ (set! (v i) (sin x))))
(fm (make-table-lookup (* mc-ratio freq) :wave sine))
(carrier (make-table-lookup freq :wave sine)))
(do ((i beg (+ i 1)))
@@ -16785,7 +16344,7 @@ EDITS: 2
(v2 (with-sound ((make-float-vector size) :srate 44100) (test-fm1 0 size 200 1 1 1))))
(if (and (not (vequal v1 v2))
(> (float-vector-peak (float-vector-subtract! v1 v2)) .002))
- (snd-display #__line__ ";fm/tbl peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
+ (snd-display ";fm/tbl peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -16795,41 +16354,41 @@ EDITS: 2
(v2 (with-sound ((make-float-vector size) :srate 44100) (test-fm1 0 size 20 1 ratio index))))
(if (and (not (vequal v1 v2))
(> (float-vector-peak (float-vector-subtract! v1 v2)) .002))
- (snd-display #__line__ ";fm/tbl peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
+ (snd-display ";fm/tbl peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
(let ((gen0 (make-polyshape 440.0 :coeffs (partials->polynomial '(1 1))))
(gen (make-polyshape 440.0 :partials '(1 1) :kind mus-chebyshev-first-kind))
- (v0 (make-float-vector 10))
- (gen1 (make-polyshape 440.0))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"polyshape"
"polyshape freq: 440.000Hz, phase: 0.000, coeffs[2]: [0 1]")
- (if (not (= (mus-length gen) 2)) (snd-display #__line__ ";polyshape length: ~A?" (mus-length gen)))
+ (if (not (= (mus-length gen) 2)) (snd-display ";polyshape length: ~A?" (mus-length gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((val0 (polyshape gen0 1.0 0.0))
(val (polyshape gen 1.0 0.0)))
- (if (fneq val val0) (snd-display #__line__ ";polyshape: ~A is not ~F?" val val0))
+ (if (fneq val val0) (snd-display ";polyshape: ~A is not ~F?" val val0))
(set! (v0 i) val)))
- (fill-float-vector v1 (if (polyshape? gen1) (polyshape gen1 1.0 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map polyshape: ~A ~A" v0 v1))
- (set! gen1 (make-polyshape 440.0 :coeffs (partials->polynomial '(1 1))))
- (fill-float-vector v1 (polyshape gen1 1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";1 map polyshape: ~A ~A" v0 v1))
- (if (not (polyshape? gen)) (snd-display #__line__ ";~A not polyshape?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";polyshape phase: ~F?" (mus-phase gen)))
+ (let ((v1 (make-float-vector 10)))
+ (let ((gen1 (make-polyshape 440.0)))
+ (fill-float-vector v1 (if (polyshape? gen1) (polyshape gen1 1.0 0.0) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map polyshape: ~A ~A" v0 v1))
+ (set! gen1 (make-polyshape 440.0 :coeffs (partials->polynomial '(1 1))))
+ (fill-float-vector v1 (polyshape gen1 1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";1 map polyshape: ~A ~A" v0 v1)))
+ (if (not (polyshape? gen)) (snd-display ";~A not polyshape?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";polyshape phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";set! polyshape phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";polyshape frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";set! polyshape phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";polyshape frequency: ~F?" (mus-frequency gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";polyshape frequency: ~F?" (mus-frequency gen)))
- (if (not (float-vector? (mus-data gen))) (snd-display #__line__ ";mus-data polyshape: ~A" (mus-data gen)))
- (if (or (fneq (v0 1) 0.992) (fneq (v0 8) 0.538)) (snd-display #__line__ ";polyshape output: ~A" v0))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";polyshape frequency: ~F?" (mus-frequency gen)))
+ (if (not (float-vector? (mus-data gen))) (snd-display ";mus-data polyshape: ~A" (mus-data gen)))
+ (if (or (fneq (v0 1) 0.992) (fneq (v0 8) 0.538)) (snd-display ";polyshape output: ~A" v0))
(set! (mus-data gen0) (make-float-vector 32))
(set! (mus-length gen0) 32)
- (if (not (= (mus-length gen0) 32)) (snd-display #__line__ ";set mus-length polyshape: ~A" (mus-length gen0))))
+ (if (not (= (mus-length gen0) 32)) (snd-display ";set mus-length polyshape: ~A" (mus-length gen0))))
(test-gen-equal (make-polyshape 440.0 :partials '(1 1))
(make-polyshape 440.0)
@@ -16853,7 +16412,7 @@ EDITS: 2
(val2 (gen 1.0 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polyshaper (1 1) ~A: ~A ~A" i val1 val2)
+ (snd-display ";polyshaper (1 1) ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(let ((gen (make-polyshape 440.0)) ; check default for partials: '(1 1)
@@ -16866,7 +16425,7 @@ EDITS: 2
(val2 (gen 1.0 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polyshaper default: '(1 1) ~A: ~A ~A" i val1 val2)
+ (snd-display ";polyshaper default: '(1 1) ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(let ((gen (make-polyshape 440.0 :partials (float-vector 1 1)))
@@ -16878,12 +16437,12 @@ EDITS: 2
(val2 (gen 0.5 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polyshaper (1 1) .5 index ~A: ~A ~A" i val1 val2)
+ (snd-display ";polyshaper (1 1) .5 index ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(let ((var (catch #t (lambda () (make-polyshape 440.0 :coeffs 3.14)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-polyshape bad coeffs: ~A" var)))
+ (snd-display ";make-polyshape bad coeffs: ~A" var)))
(let ((gen (make-polyshape 0.0 :coeffs (partials->polynomial '(1 1))))
(gen1 (make-polyshape 40.0 :coeffs (partials->polynomial '(1 1))))
@@ -16899,7 +16458,7 @@ EDITS: 2
(set! a1 (+ a1 fm))
(if (> (abs (- val1 val2)) .002)
(begin
- (snd-display #__line__ ";polyshape fm: ~A: ~A ~A" i val1 val2)
+ (snd-display ";polyshape fm: ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(for-each
@@ -16927,7 +16486,7 @@ EDITS: 2
(let ((fudge *mus-float-equal-fudge-factor*))
(set! *mus-float-equal-fudge-factor* .0001)
(if (not (mus-arrays-equal? data1 data2))
- (snd-display #__line__ "~A: ~A~%~A~%" name data1 data2))
+ (snd-display "~A: ~A~%~A~%" name data1 data2))
(set! *mus-float-equal-fudge-factor* fudge))))
(list (float-vector 0.0 1.0)
@@ -16964,7 +16523,7 @@ EDITS: 2
(let ((fudge *mus-float-equal-fudge-factor*))
(set! *mus-float-equal-fudge-factor* .0001)
(if (not (mus-arrays-equal? data1 data2))
- (snd-display #__line__ "~A: ~A~%~A~%" name data1 data2))
+ (snd-display "~A: ~A~%~A~%" name data1 data2))
(set! *mus-float-equal-fudge-factor* fudge))))
(list (float-vector 0.0 1.0)
@@ -17024,35 +16583,36 @@ EDITS: 2
'thousand-tu))
;; polywave
- (let ((gen0 (make-polywave 440.0 '(1 1)))
- (gen (make-polywave 440.0 :partials '(1 1) :type mus-chebyshev-first-kind))
- (v0 (make-float-vector 10))
- (gen1 (make-polywave 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-polywave 440.0 :partials '(1 1) :type mus-chebyshev-first-kind))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"polywave"
"polywave freq: 440.000Hz, phase: 0.000, coeffs[2]: [0 1]")
- (if (not (= (mus-length gen) 2)) (snd-display #__line__ ";polywave length: ~A?" (mus-length gen)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (let ((val0 (polywave gen0 0.0))
- (val (polywave gen 0.0)))
- (if (fneq val val0) (snd-display #__line__ ";polywave: ~A is not ~F?" val val0))
- (set! (v0 i) val)))
- (fill-float-vector v1 (if (polywave? gen1) (polywave gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map polywave: ~A ~A" v0 v1))
- (set! gen1 (make-polywave 440.0 (float-vector 1 1)))
- (fill-float-vector v1 (polywave gen1))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";1 map polywave: ~A ~A" v0 v1))
- (if (not (polywave? gen)) (snd-display #__line__ ";~A not polywave?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";polywave phase: ~F?" (mus-phase gen)))
+ (if (not (= (mus-length gen) 2)) (snd-display ";polywave length: ~A?" (mus-length gen)))
+
+ (let ((gen0 (make-polywave 440.0 '(1 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (let ((val0 (polywave gen0 0.0))
+ (val (polywave gen 0.0)))
+ (if (fneq val val0) (snd-display ";polywave: ~A is not ~F?" val val0))
+ (set! (v0 i) val))))
+ (let ((gen1 (make-polywave 440.0))
+ (v1 (make-float-vector 10)))
+ (fill-float-vector v1 (if (polywave? gen1) (polywave gen1 0.0) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map polywave: ~A ~A" v0 v1))
+ (set! gen1 (make-polywave 440.0 (float-vector 1 1)))
+ (fill-float-vector v1 (polywave gen1))
+ (if (not (vequal v0 v1)) (snd-display ";1 map polywave: ~A ~A" v0 v1)))
+ (if (not (polywave? gen)) (snd-display ";~A not polywave?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";polywave phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";set! polywave phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";polywave frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";set! polywave phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";polywave frequency: ~F?" (mus-frequency gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";polywave frequency: ~F?" (mus-frequency gen)))
- (if (not (float-vector? (mus-data gen))) (snd-display #__line__ ";mus-data polywave: ~A" (mus-data gen)))
- (if (or (fneq (v0 1) 0.992) (fneq (v0 8) 0.538)) (snd-display #__line__ ";polywave output: ~A" v0)))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";polywave frequency: ~F?" (mus-frequency gen)))
+ (if (not (float-vector? (mus-data gen))) (snd-display ";mus-data polywave: ~A" (mus-data gen)))
+ (if (or (fneq (v0 1) 0.992) (fneq (v0 8) 0.538)) (snd-display ";polywave output: ~A" v0)))
(test-gen-equal (make-polywave 440.0 :partials '(1 1))
(make-polywave 440.0)
@@ -17076,7 +16636,7 @@ EDITS: 2
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polywaver (1 1) ~A: ~A ~A" i val1 val2)
+ (snd-display ";polywaver (1 1) ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(let ((gen (make-polywave 440.0)) ; check default for partials: '(1 1)
@@ -17088,7 +16648,7 @@ EDITS: 2
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polywaver default: '(1 1) ~A: ~A ~A" i val1 val2)
+ (snd-display ";polywaver default: '(1 1) ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
(let ((gen (make-polywave 440.0 (float-vector 1 1)))
@@ -17101,30 +16661,30 @@ EDITS: 2
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
- (snd-display #__line__ ";polywaver (1 1) .5 index ~A: ~A ~A" i val1 val2)
+ (snd-display ";polywaver (1 1) .5 index ~A: ~A ~A" i val1 val2)
(set! happy #f))))))
- (let ((old-srate *clm-srate*)
- (v0 (make-float-vector 4410))
- (v1 (make-float-vector 4410)))
+ (let ((old-srate *clm-srate*))
(set! *clm-srate* 44100)
- (for-each
- (lambda (k)
- (let ((gen (make-polywave 100.0 (list 1 0.5 k 0.5)))
- (incr (/ (* 2.0 pi 100.0) 44100))
- (kincr (/ (* 2.0 k pi 100.0) 44100)))
- (do ((i 0 (+ i 1)))
- ((= i 4410))
- (set! (v0 i) (polywave gen)))
- (do ((i 0 (+ i 1))
- (ph 0.0 (+ ph incr))
- (kph 0.0 (+ kph kincr)))
- ((= i 4410))
- (float-vector-set! v1 i (+ (cos ph) (cos kph))))
+ (let ((v0 (make-float-vector 4410))
+ (v1 (make-float-vector 4410)))
+ (for-each
+ (lambda (k)
+ (let ((gen (make-polywave 100.0 (list 1 0.5 k 0.5)))
+ (incr (/ (* 2.0 pi 100.0) 44100))
+ (kincr (/ (* 2.0 k pi 100.0) 44100)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4410))
+ (set! (v0 i) (polywave gen)))
+ (do ((i 0 (+ i 1))
+ (ph 0.0 (+ ph incr))
+ (kph 0.0 (+ kph kincr)))
+ ((= i 4410))
+ (float-vector-set! v1 i (+ (cos ph) (cos kph)))))
(float-vector-scale! v1 0.5)
(if (not (vequal v0 v1))
- (snd-display #__line__ ";polywave ~D vs cos: ~A" k (float-vector-peak-and-location (float-vector-subtract! v0 v1))))))
- (list 2 19 20 29 30 39 40 60 100))
+ (snd-display ";polywave ~D vs cos: ~A" k (float-vector-peak-and-location (float-vector-subtract! v0 v1)))))
+ (list 2 19 20 29 30 39 40 60 100)))
(for-each
(lambda (n)
@@ -17138,7 +16698,7 @@ EDITS: 2
(if (fneq val1 val2)
(begin
(set! happy #f)
- (snd-display #__line__ ";polywave ~A at ~A: ~A ~A" n i val1 val2)))))))
+ (snd-display ";polywave ~A at ~A: ~A ~A" n i val1 val2)))))))
(list 1 8 50 128))
(for-each
@@ -17153,7 +16713,7 @@ EDITS: 2
(if (fneq val1 val2)
(begin
(set! happy #f)
- (snd-display #__line__ ";polywave second ~A at ~A: ~A ~A" n i val1 val2)))))))
+ (snd-display ";polywave second ~A at ~A: ~A ~A" n i val1 val2)))))))
(list 1 8 50 128))
(for-each
@@ -17168,7 +16728,7 @@ EDITS: 2
(if (fneq val1 val2)
(begin
(set! happy #f)
- (snd-display #__line__ ";polyshape ~A at ~A: ~A ~A" n i val1 val2)))))))
+ (snd-display ";polyshape ~A at ~A: ~A ~A" n i val1 val2)))))))
(list 1 8 16))
(for-each
@@ -17183,7 +16743,7 @@ EDITS: 2
(if (fneq val1 val2)
(begin
(set! happy #f)
- (snd-display #__line__ ";polyshape second ~A at ~A: ~A ~A" n i val1 val2)))))))
+ (snd-display ";polyshape second ~A at ~A: ~A ~A" n i val1 val2)))))))
(list 1 8 16))
(for-each
@@ -17197,7 +16757,7 @@ EDITS: 2
(val2 (oscil gen2)))
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
- (snd-display #__line__ ";polywave run ~A: ~A" n max-dist))))
+ (snd-display ";polywave run ~A: ~A" n max-dist))))
(list 1 3 30 200))
(for-each
@@ -17211,7 +16771,7 @@ EDITS: 2
(val2 (oscil gen2)))
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
- (snd-display #__line__ ";polywave second run ~A: ~A" n max-dist))))
+ (snd-display ";polywave second run ~A: ~A" n max-dist))))
(list 1 3 30 200))
(for-each
@@ -17225,7 +16785,7 @@ EDITS: 2
(val2 (oscil gen2)))
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
- (snd-display #__line__ ";polyshape run ~A: ~A" n max-dist))))
+ (snd-display ";polyshape run ~A: ~A" n max-dist))))
(list 1 3 25))
(for-each
@@ -17239,29 +16799,29 @@ EDITS: 2
(val2 (oscil gen2)))
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
- (snd-display #__line__ ";polyshape second run ~A: ~A" n max-dist))))
+ (snd-display ";polyshape second run ~A: ~A" n max-dist))))
(list 1 3 25))
- (let ((gen (make-polywave 100.0 (list 1 .9 3 .1 4 0.0))))
- (let ((vals (mus-data gen)))
- (if (or (not (float-vector? vals))
- (not (vequal vals (float-vector 0.000 0.900 0.000 0.100 0.00))))
- (snd-display #__line__ ";polywave mus-data: ~A" vals)
- (begin
- (float-vector-set! (mus-data gen) 2 .1)
- (float-vector-set! (mus-data gen) 3 0.0)
- (let ((happy #t)
- (gen1 (make-oscil 100.0 (/ pi 2)))
- (gen2 (make-oscil 200.0 (/ pi 2))))
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i 1000)))
- (let ((val1 (polywave gen))
- (val2 (+ (* .9 (oscil gen1))
- (* .1 (oscil gen2)))))
- (if (fneq val1 val2)
- (begin
- (set! happy #f)
- (snd-display #__line__ ";polywave set mus-data at ~A: ~A ~A" i val1 val2))))))))))
+ (let* ((gen (make-polywave 100.0 (list 1 .9 3 .1 4 0.0)))
+ (vals (mus-data gen)))
+ (if (not (and (float-vector? vals)
+ (vequal vals (float-vector 0.000 0.900 0.000 0.100 0.00))))
+ (snd-display ";polywave mus-data: ~A" vals)
+ (begin
+ (float-vector-set! (mus-data gen) 2 .1)
+ (float-vector-set! (mus-data gen) 3 0.0)
+ (let ((happy #t)
+ (gen1 (make-oscil 100.0 (/ pi 2)))
+ (gen2 (make-oscil 200.0 (/ pi 2))))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i 1000)))
+ (let ((val1 (polywave gen))
+ (val2 (+ (* .9 (oscil gen1))
+ (* .1 (oscil gen2)))))
+ (if (fneq val1 val2)
+ (begin
+ (set! happy #f)
+ (snd-display ";polywave set mus-data at ~A: ~A ~A" i val1 val2)))))))))
(set! *clm-srate* old-srate))
;; check dc
@@ -17271,10 +16831,10 @@ EDITS: 2
(do ((k 0 (+ k 2)))
((>= k (length cfs)))
(set! (cfs k) (/ k 2)))
- (let ((p (make-polywave 100.0 cfs mus-chebyshev-second-kind)))
- (let ((val (polywave p)))
- (if (fneq val 0.1)
- (snd-display #__line__ ";polywave ~D order second 0-coeff: ~A" i val))))))
+ (let* ((p (make-polywave 100.0 cfs mus-chebyshev-second-kind))
+ (val (polywave p)))
+ (if (fneq val 0.1)
+ (snd-display ";polywave ~D order second 0-coeff: ~A" i val)))))
(do ((i 2 (+ i 1)))
((= i 7))
@@ -17282,46 +16842,46 @@ EDITS: 2
(do ((k 0 (+ k 2)))
((>= k (length cfs)))
(set! (cfs k) (/ k 2)))
- (let ((p (make-polywave 100.0 cfs mus-chebyshev-first-kind)))
- (let ((val (polywave p)))
- (if (fneq val (* 0.1 i))
- (snd-display #__line__ ";polywave ~D order first 0-coeff: ~A" i val))))))
+ (let* ((p (make-polywave 100.0 cfs mus-chebyshev-first-kind))
+ (val (polywave p)))
+ (if (fneq val (* 0.1 i))
+ (snd-display ";polywave ~D order first 0-coeff: ~A" i val)))))
(let ((var (catch #t (lambda () (make-polywave 440.0 3.14)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-polywave bad coeffs: ~A" var)))
+ (snd-display ";make-polywave bad coeffs: ~A" var)))
(let ((gen (make-wave-train 440.0 0.0 (make-float-vector 20)))
- (v0 (make-float-vector 10))
- (gen1 (make-wave-train 440.0 0.0 (make-float-vector 20)))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"wave-train"
"wave-train freq: 440.000Hz, phase: 0.000, size: 20, interp: linear")
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (float-vector-set! (mus-data gen) i (* i .5))
- (float-vector-set! (mus-data gen1) i ((mus-data gen) i)))
- (if (not (= (length (mus-data gen)) 20)) (snd-display #__line__ ";wave-train data length: ~A?" (length (mus-data gen))))
- (if (not (= (mus-length gen) 20)) (snd-display #__line__ ";wave-train length: ~A?" (mus-length gen)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (wave-train gen 0.0)))
- (fill-float-vector v1 (if (wave-train? gen1) (wave-train gen1) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map wave-train: ~A ~A" v0 v1))
- (if (not (wave-train? gen)) (snd-display #__line__ ";~A not wave-train?" gen))
- (if (fneq (mus-phase gen) 0.0) (snd-display #__line__ ";wave-train phase: ~F?" (mus-phase gen)))
+ (let ((gen1 (make-wave-train 440.0 0.0 (make-float-vector 20)))
+ (v1 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (float-vector-set! (mus-data gen) i (* i .5))
+ (float-vector-set! (mus-data gen1) i ((mus-data gen) i)))
+ (if (not (= (length (mus-data gen)) 20)) (snd-display ";wave-train data length: ~A?" (length (mus-data gen))))
+ (if (not (= (mus-length gen) 20)) (snd-display ";wave-train length: ~A?" (mus-length gen)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (wave-train gen 0.0)))
+ (fill-float-vector v1 (if (wave-train? gen1) (wave-train gen1) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map wave-train: ~A ~A" v0 v1)))
+ (if (not (wave-train? gen)) (snd-display ";~A not wave-train?" gen))
+ (if (fneq (mus-phase gen) 0.0) (snd-display ";wave-train phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
- (if (fneq (mus-phase gen) 1.0) (snd-display #__line__ ";set wave-train phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";wave-train frequency: ~F?" (mus-frequency gen)))
+ (if (fneq (mus-phase gen) 1.0) (snd-display ";set wave-train phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";wave-train frequency: ~F?" (mus-frequency gen)))
(set! (mus-frequency gen) 100.0)
- (if (fneq (mus-frequency gen) 100.0) (snd-display #__line__ ";set wave-train freq: ~A" (mus-frequency gen)))
- (if (or (fneq (v0 1) 0.5) (fneq (v0 8) 4.0)) (snd-display #__line__ ";wave-train output: ~A" v0))
+ (if (fneq (mus-frequency gen) 100.0) (snd-display ";set wave-train freq: ~A" (mus-frequency gen)))
+ (if (or (fneq (v0 1) 0.5) (fneq (v0 8) 4.0)) (snd-display ";wave-train output: ~A" v0))
(mus-reset gen)
- (if (fneq (mus-phase gen) 0.0) (snd-display #__line__ ";wt reset phase: ~A" (mus-phase gen)))
+ (if (fneq (mus-phase gen) 0.0) (snd-display ";wt reset phase: ~A" (mus-phase gen)))
(let ((val (wave-train gen 0.0)))
- (if (fneq val 0.0) (snd-display #__line__ ";wt reset data: ~A" val)))
- (if (not (float-vector? (mus-data gen))) (snd-display #__line__ ";mus-data wave-train: ~A" (mus-data gen)))
+ (if (fneq val 0.0) (snd-display ";wt reset data: ~A" val)))
+ (if (not (float-vector? (mus-data gen))) (snd-display ";mus-data wave-train: ~A" (mus-data gen)))
(set! (mus-data gen) (make-float-vector 3)))
(test-gen-equal (make-wave-train 440.0 0.0 (make-float-vector 20)) (make-wave-train 440.0 0.0 (make-float-vector 20)) (make-wave-train 100.0 0.0 (make-float-vector 20)))
@@ -17332,9 +16892,9 @@ EDITS: 2
(make-wave-train-with-env 440.0 '(0 0 1 1 2 0)))
(let ((hi (make-wave-train :size 256)))
- (if (not (= (mus-length hi) 256)) (snd-display #__line__ ";wave-train set length: ~A?" (mus-length hi)))
+ (if (not (= (mus-length hi) 256)) (snd-display ";wave-train set length: ~A?" (mus-length hi)))
(set! (mus-length hi) 128)
- (if (not (= (mus-length hi) 128)) (snd-display #__line__ ";set wave-train set length: ~A?" (mus-length hi))))
+ (if (not (= (mus-length hi) 128)) (snd-display ";set wave-train set length: ~A?" (mus-length hi))))
(for-each
(lambda (args)
@@ -17347,8 +16907,8 @@ EDITS: 2
((= i 10))
(set! (v i) (wave-train tbl1 0.0))) ;(wave-train tbl1 (/ (* 2 pi .2) 4))))
(if (not (vequal v vals))
- (snd-display #__line__ ";wt tbl interp ~A: ~A ~A" type v (mus-describe tbl1)))
- (if (not (= (mus-interp-type tbl1) type)) (snd-display #__line__ ";wt tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
+ (snd-display ";wt tbl interp ~A: ~A ~A" type v (mus-describe tbl1)))
+ (if (not (= (mus-interp-type tbl1) type)) (snd-display ";wt tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
(list
(list mus-interp-none (float-vector 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000))
(list mus-interp-linear (float-vector 0.200 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.200 0.800))
@@ -17356,135 +16916,135 @@ EDITS: 2
(list mus-interp-hermite (float-vector 0.168 0.912 -0.064 -0.016 0.000 0.000 0.000 0.000 0.168 0.912))))
(let ((tag (catch #t (lambda () (make-wave-train :size 0)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range)) (snd-display #__line__ ";wave-train size 0: ~A" tag)))
+ (if (not (eq? tag 'out-of-range)) (snd-display ";wave-train size 0: ~A" tag)))
(let ((ind (new-sound "fmv.snd" :size 10 :comment "line 20501")))
- (if (not (= (framples) 10)) (snd-display #__line__ ";new-sound size(10): ~A" (framples)))
+ (if (not (= (framples) 10)) (snd-display ";new-sound size(10): ~A" (framples)))
(map-channel (lambda (y) 1.0) 7 8)
- (if (not (= (framples) 15)) (snd-display #__line__ ";map-channel 7 8: ~A" (framples)))
+ (if (not (= (framples) 15)) (snd-display ";map-channel 7 8: ~A" (framples)))
(map-channel (lambda (y) 1.0))
- (if (not (= (framples) 15)) (snd-display #__line__ ";map-channel (no dur): ~A" (framples)))
+ (if (not (= (framples) 15)) (snd-display ";map-channel (no dur): ~A" (framples)))
(revert-sound ind)
(map-channel (lambda (y) 1.0) 9 10)
- (if (not (= (framples) 19)) (snd-display #__line__ ";map-channel 9 10: ~A" (framples)))
- (if (> (edit-position ind 0) 2) (snd-display #__line__ ";map-channel pad edits: ~A" (edit-position ind 0)))
+ (if (not (= (framples) 19)) (snd-display ";map-channel 9 10: ~A" (framples)))
+ (if (> (edit-position ind 0) 2) (snd-display ";map-channel pad edits: ~A" (edit-position ind 0)))
(revert-sound ind)
(map-channel (lambda (y) 1.0) 10 10)
- (if (not (= (framples) 20)) (snd-display #__line__ ";map-channel 10 10: ~A" (framples)))
- (if (> (edit-position ind 0) 2) (snd-display #__line__ ";map-channel pad edits (2): ~A" (edit-position ind 0)))
+ (if (not (= (framples) 20)) (snd-display ";map-channel 10 10: ~A" (framples)))
+ (if (> (edit-position ind 0) 2) (snd-display ";map-channel pad edits (2): ~A" (edit-position ind 0)))
(revert-sound ind)
(map-channel (lambda (y) 1.0) 20 10)
- (if (not (= (framples) 30)) (snd-display #__line__ ";map-channel 20 10: ~A" (framples)))
- (if (> (edit-position ind 0) 2) (snd-display #__line__ ";map-channel pad edits (3): ~A" (edit-position ind 0)))
+ (if (not (= (framples) 30)) (snd-display ";map-channel 20 10: ~A" (framples)))
+ (if (> (edit-position ind 0) 2) (snd-display ";map-channel pad edits (3): ~A" (edit-position ind 0)))
(revert-sound ind)
- (if (scan-channel (lambda (y) #f) 30 10) (snd-display #__line__ ";scan-channel past end?"))
+ (if (scan-channel (lambda (y) #f) 30 10) (snd-display ";scan-channel past end?"))
(let ((new-file-name (file-name ind)))
(close-sound ind)
(if (file-exists? new-file-name) (delete-file new-file-name))))
- (let ((ind (new-sound :size 1000)))
- (let* ((table (float-vector 0.0 .1 .2 .3 .4 .5 .6))
- (gen (make-wave-train 1000.0 :wave table)))
- (map-channel (lambda (y) (wave-train gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.6) (snd-display #__line__ ";wt 0 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600)))
- (snd-display #__line__ ";wt 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300)))
- (snd-display #__line__ ";wt 0 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (let* ((ind (new-sound :size 1000))
+ (table (float-vector 0.0 .1 .2 .3 .4 .5 .6))
+ (gen (make-wave-train 1000.0 :wave table)))
+ (map-channel (lambda (y) (wave-train gen)))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.6) (snd-display ";wt 0 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600)))
+ (snd-display ";wt 0 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300)))
+ (snd-display ";wt 0 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 1000.0 :initial-phase pi :wave table))) ; initial-phase is confusing in this context!
- (map-channel (lambda (y) (wave-train gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";wt 1 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000)))
- (let ((op *print-length*))
- (set! *print-length* 32)
- (snd-display #__line__ ";wt 1 data: ~A" (channel->float-vector 0 30))
- (set! *print-length* op)))
- (undo))
+ (map-channel (lambda (y) (wave-train gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";wt 1 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000)))
+ (let ((op *print-length*))
+ (set! *print-length* 32)
+ (snd-display ";wt 1 data: ~A" (channel->float-vector 0 30))
+ (set! *print-length* op)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 2000.0 :wave table)))
- (map-channel (lambda (y) (wave-train gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";wt 2 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
- (snd-display #__line__ ";wt 2 data: ~A" (channel->float-vector 0 30)))
- (if (and (not (vequal (channel->float-vector 440 30)
- (float-vector 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100)))
- ;; if double, round off is just enough different to cause an off-by-1 problem here (and below)
- (not (vequal (channel->float-vector 440 30)
- (float-vector 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100))))
- (snd-display #__line__ ";wt 2 data 440: ~A" (channel->float-vector 440 30)))
- (undo))
+ (map-channel (lambda (y) (wave-train gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";wt 2 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
+ (snd-display ";wt 2 data: ~A" (channel->float-vector 0 30)))
+ (if (not (or (vequal (channel->float-vector 440 30)
+ (float-vector 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100))
+ ;; if double, round off is just enough different to cause an off-by-1 problem here (and below)
+ (vequal (channel->float-vector 440 30)
+ (float-vector 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100))))
+ (snd-display ";wt 2 data 440: ~A" (channel->float-vector 440 30)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 3000.0 :wave table)))
- (map-channel (lambda (y) (wave-train gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.2) (snd-display #__line__ ";wt 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100
- 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100)))
- (snd-display #__line__ ";wt 3 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100
- 0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100)))
- (snd-display #__line__ ";wt 3 data 440: ~A" (channel->float-vector 440 30)))
- (undo))
+ (map-channel (lambda (y) (wave-train gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.2) (snd-display ";wt 3 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100
+ 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100)))
+ (snd-display ";wt 3 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100
+ 0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100)))
+ (snd-display ";wt 3 data 440: ~A" (channel->float-vector 440 30)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 5000.0 :wave table)))
- (map-channel (lambda (y) (wave-train gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.3) (snd-display #__line__ ";wt 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300
- 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200)))
- (snd-display #__line__ ";wt 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.300 0.200 0.200 0.200
- 0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200)))
- (snd-display #__line__ ";wt 4 data 440: ~A" (channel->float-vector 440 30)))
- (undo))
+ (map-channel (lambda (y) (wave-train gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.3) (snd-display ";wt 4 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300
+ 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200)))
+ (snd-display ";wt 4 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.300 0.200 0.200 0.200
+ 0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200)))
+ (snd-display ";wt 4 data 440: ~A" (channel->float-vector 440 30)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 1000.0 :wave table))
- (e (make-env '(0 1 1 2) :length 1001))
- (base-freq (mus-frequency gen)))
+ (base-freq (mus-frequency gen))
+ (e (make-env '(0 1 1 2) :length 1001)))
(map-channel
(lambda (y)
(let ((result (wave-train gen)))
(set! (mus-frequency gen) (* base-freq (env e)))
- result)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";wt 5 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
- (snd-display #__line__ ";wt 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.100)))
- (snd-display #__line__ ";wt 5 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
- (float-vector 0.100 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100 0.100)))
- (snd-display #__line__ ";wt 5 data 900: ~A" (channel->float-vector 900 30)))
- (undo))
+ result))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";wt 5 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
+ (snd-display ";wt 5 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.100)))
+ (snd-display ";wt 5 data 440: ~A" (channel->float-vector 440 30)))
+ (if (not (vequal (channel->float-vector 900 30)
+ (float-vector 0.100 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100 0.100)))
+ (snd-display ";wt 5 data 900: ~A" (channel->float-vector 900 30)))
+ (undo)
(let* ((table (make-float-vector 10 .1))
(gen (make-wave-train 500.0 :wave table))
@@ -17497,63 +17057,63 @@ EDITS: 2
(set! ctr 0)
(float-vector-scale! (mus-data gen) 1.05))
(set! ctr (+ ctr 1)))
- result)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.704) (snd-display #__line__ ";wt 6 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";wt 6 data: ~A" (channel->float-vector 0 30)))
- (if (and (not (vequal (channel->float-vector 440 30)
- (float-vector 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal (channel->float-vector 440 30)
- (float-vector 0.000 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";wt 6 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.639 0.639 0.639)))
- (snd-display #__line__ ";wt 6 data 900: ~A" (channel->float-vector 900 30)))
- (undo))
+ result))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.704) (snd-display ";wt 6 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";wt 6 data: ~A" (channel->float-vector 0 30)))
+ (if (not (or (vequal (channel->float-vector 440 30)
+ (float-vector 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal (channel->float-vector 440 30)
+ (float-vector 0.000 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";wt 6 data 440: ~A" (channel->float-vector 440 30)))
+ (if (not (vequal (channel->float-vector 900 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.639 0.639 0.639)))
+ (snd-display ";wt 6 data 900: ~A" (channel->float-vector 900 30)))
+ (undo)
(let ((fname (file-name ind)))
(close-sound ind)
(delete-file fname)))
(let ((gen (make-readin "oboe.snd" 0 1490))
- (v0 (make-float-vector 10))
- (gen1 (make-readin "oboe.snd" 0 1490))
- (v1 (make-float-vector 10)))
+ (v0 (make-float-vector 10)))
(print-and-check gen
"readin"
"readin oboe.snd[chan 0], loc: 1490, dir: 1")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (readin gen)))
- (fill-float-vector v1 (if (readin? gen1)
- (if (= (mus-channel gen1) 0)
- (readin gen1)
- 1.0)
- (if (string=? (mus-file-name gen1) "oboe.snd")
- -1.0
- 1.0)))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map readin: ~A ~A" v0 v1))
- (if (not (readin? gen)) (snd-display #__line__ ";~A not readin?" gen))
- (if (not (mus-input? gen)) (snd-display #__line__ ";~A not input?" gen))
- (if (not (= (mus-length gen) 50828)) (snd-display #__line__ ";readin length: ~A?" (mus-length gen)))
- (if (not (= (mus-channel gen) 0)) (snd-display #__line__ ";readin chan: ~A?" (mus-channel gen)))
- (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display #__line__ ";readin mus-file-name: ~A" (mus-file-name gen)))
- (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display #__line__ ";readin output: ~A" v0))
+ (let ((gen1 (make-readin "oboe.snd" 0 1490))
+ (v1 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (readin gen)))
+ (fill-float-vector v1 (if (readin? gen1)
+ (if (= (mus-channel gen1) 0)
+ (readin gen1)
+ 1.0)
+ (if (string=? (mus-file-name gen1) "oboe.snd")
+ -1.0
+ 1.0)))
+ (if (not (vequal v0 v1)) (snd-display ";map readin: ~A ~A" v0 v1)))
+ (if (not (readin? gen)) (snd-display ";~A not readin?" gen))
+ (if (not (mus-input? gen)) (snd-display ";~A not input?" gen))
+ (if (not (= (mus-length gen) 50828)) (snd-display ";readin length: ~A?" (mus-length gen)))
+ (if (not (= (mus-channel gen) 0)) (snd-display ";readin chan: ~A?" (mus-channel gen)))
+ (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display ";readin mus-file-name: ~A" (mus-file-name gen)))
+ (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display ";readin output: ~A" v0))
(set! (mus-location gen) 1000)
- (if (not (= (mus-location gen) 1000)) (snd-display #__line__ ";set! mus-location: ~A?" (mus-location gen)))
+ (if (not (= (mus-location gen) 1000)) (snd-display ";set! mus-location: ~A?" (mus-location gen)))
(let ((val (readin gen)))
- (if (fneq val 0.033) (snd-display #__line__ ";set! mus-location readin: ~A?" val)))
+ (if (fneq val 0.033) (snd-display ";set! mus-location readin: ~A?" val)))
(set! (mus-increment gen) -1)
- (if (fneq (mus-increment gen) -1.0) (snd-display #__line__ ";set increment readin: ~A" (mus-increment gen))))
+ (if (fneq (mus-increment gen) -1.0) (snd-display ";set increment readin: ~A" (mus-increment gen))))
(let ((tag (catch #t (lambda () (make-readin "/baddy/hiho" 0 124)) (lambda args args))))
- (if (not (eq? (car tag) 'no-such-file)) (snd-display #__line__ ";make-readin w/o file: ~A" tag)))
+ (if (not (eq? (car tag) 'no-such-file)) (snd-display ";make-readin w/o file: ~A" tag)))
(let ((tag (catch #t (lambda () (make-readin "oboe.snd" 123 124)) (lambda args args))))
- (if (not (eq? (car tag) 'out-of-range)) (snd-display #__line__ ";make-readin with bad chan: ~A" tag)))
+ (if (not (eq? (car tag) 'out-of-range)) (snd-display ";make-readin with bad chan: ~A" tag)))
(test-gen-equal (make-readin "oboe.snd" 0) (make-readin "oboe.snd" 0) (make-readin "oboe.snd" 0 1230))
(test-gen-equal (make-readin "oboe.snd" 0 :size 512) (make-readin "oboe.snd" 0 :size 512) (make-readin "pistol.snd" 0 :size 512))
@@ -17567,8 +17127,8 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (readin gen)))
- (if (not (= (mus-channel gen) 1)) (snd-display #__line__ ";readin chan 1: ~A?" (mus-channel gen)))
- (if (or (fneq (v0 1) 0.010) (fneq (v0 7) -.006)) (snd-display #__line__ ";readin 1 output: ~A" v0))
+ (if (not (= (mus-channel gen) 1)) (snd-display ";readin chan 1: ~A?" (mus-channel gen)))
+ (if (or (fneq (v0 1) 0.010) (fneq (v0 7) -.006)) (snd-display ";readin 1 output: ~A" v0))
(print-and-check gen
"readin"
"readin 2.snd[chan 1], loc: 10, dir: 1"))
@@ -17578,17 +17138,17 @@ EDITS: 2
(print-and-check gen
"file->sample"
"file->sample oboe.snd")
- (if (not (mus-input? gen)) (snd-display #__line__ ";~A not input?" gen))
- (if (not (= (mus-length gen) 50828)) (snd-display #__line__ ";file->sample length: ~A?" (mus-length gen)))
- (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display #__line__ ";file->sample mus-file-name: ~A" (mus-file-name gen)))
+ (if (not (mus-input? gen)) (snd-display ";~A not input?" gen))
+ (if (not (= (mus-length gen) 50828)) (snd-display ";file->sample length: ~A?" (mus-length gen)))
+ (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display ";file->sample mus-file-name: ~A" (mus-file-name gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (file->sample gen (+ 1490 i))))
- (if (not (file->sample? gen)) (snd-display #__line__ ";~A not file->sample?" gen))
- (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display #__line__ ";file->sample output: ~A" v0))
- (if (fneq (mus-increment gen) 0.0) (snd-display #__line__ ";file->sample increment: ~A" (mus-increment gen)))
+ (if (not (file->sample? gen)) (snd-display ";~A not file->sample?" gen))
+ (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display ";file->sample output: ~A" v0))
+ (if (fneq (mus-increment gen) 0.0) (snd-display ";file->sample increment: ~A" (mus-increment gen)))
(set! (mus-increment gen) 1.0)
- (if (fneq (mus-increment gen) 1.0) (snd-display #__line__ ";file->sample set increment: ~A" (mus-increment gen)))
+ (if (fneq (mus-increment gen) 1.0) (snd-display ";file->sample set increment: ~A" (mus-increment gen)))
(mus-reset gen)) ; a no-op I hope
(let* ((ind (open-sound "oboe.snd"))
@@ -17598,40 +17158,40 @@ EDITS: 2
(print-and-check gen
"snd->sample"
"snd->sample reading oboe.snd (1 chan) at 0:[no readers]")
- (if (equal? gen gen1) (snd-display #__line__ ";snd->sample eq? not itself?"))
- (if (not (mus-input? gen)) (snd-display #__line__ ";snd->sample ~A not input?" gen))
- (if (not (= (framples ind) (mus-length gen))) (snd-display #__line__ ";snd->sample len: ~A ~A" (framples ind) (mus-length gen)))
+ (if (equal? gen gen1) (snd-display ";snd->sample eq? not itself?"))
+ (if (not (mus-input? gen)) (snd-display ";snd->sample ~A not input?" gen))
+ (if (not (= (framples ind) (mus-length gen))) (snd-display ";snd->sample len: ~A ~A" (framples ind) (mus-length gen)))
(if (not (string=? (mus-file-name gen) (string-append cwd "oboe.snd")))
- (snd-display #__line__ ";snd->sample mus-file-name: ~A ~A" (mus-file-name gen) (string-append cwd "oboe.snd")))
+ (snd-display ";snd->sample mus-file-name: ~A ~A" (mus-file-name gen) (string-append cwd "oboe.snd")))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (snd->sample gen (+ 1490 i))))
- (if (not (snd->sample? gen)) (snd-display #__line__ ";~A not snd->sample?" gen))
- (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display #__line__ ";snd->sample output: ~A" v0))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";snd->sample channels: ~A" (mus-channels gen)))
- (if (not (= (mus-location gen) 1499)) (snd-display #__line__ ";snd->sample location: ~A" (mus-location gen)))
+ (if (not (snd->sample? gen)) (snd-display ";~A not snd->sample?" gen))
+ (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display ";snd->sample output: ~A" v0))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";snd->sample channels: ~A" (mus-channels gen)))
+ (if (not (= (mus-location gen) 1499)) (snd-display ";snd->sample location: ~A" (mus-location gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (ina (+ 1490 i) gen)))
- (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display #__line__ ";snd->sample ina output: ~A" v0))
+ (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display ";snd->sample ina output: ~A" v0))
(close-sound ind))
(let* ((ind (open-sound "2.snd"))
- (gen (make-snd->sample ind))
- (v0 (make-float-vector 10)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (snd->sample gen (+ 1490 i) 0))
- (set! (v0 i) (snd->sample gen (+ 1490 i) 1)))
+ (gen (make-snd->sample ind)))
+ (let ((v0 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (snd->sample gen (+ 1490 i) 0))
+ (set! (v0 i) (snd->sample gen (+ 1490 i) 1))))
(print-and-check gen
"snd->sample"
"snd->sample reading 2.snd (2 chans) at 1499:[#<sampler: 2.snd[0: 0] from 1490, at 1500, forward>, #<sampler: 2.snd[1: 0] from 1490, at 1500, forward>]")
- (if (not (mus-input? gen)) (snd-display #__line__ ";snd->sample ~A not input?" gen))
+ (if (not (mus-input? gen)) (snd-display ";snd->sample ~A not input?" gen))
(if (not (string=? (mus-file-name gen) (string-append cwd "2.snd")))
- (snd-display #__line__ ";snd->sample mus-file-name: ~A ~A" (mus-file-name gen) (string-append cwd "2.snd")))
- (if (not (snd->sample? gen)) (snd-display #__line__ ";~A not snd->sample?" gen))
- (if (not (= (mus-channels gen) 2)) (snd-display #__line__ ";snd->sample channels (2): ~A" (mus-channels gen)))
- (if (not (= (mus-location gen) 1499)) (snd-display #__line__ ";snd->sample location (2): ~A" (mus-location gen)))
+ (snd-display ";snd->sample mus-file-name: ~A ~A" (mus-file-name gen) (string-append cwd "2.snd")))
+ (if (not (snd->sample? gen)) (snd-display ";~A not snd->sample?" gen))
+ (if (not (= (mus-channels gen) 2)) (snd-display ";snd->sample channels (2): ~A" (mus-channels gen)))
+ (if (not (= (mus-location gen) 1499)) (snd-display ";snd->sample location (2): ~A" (mus-location gen)))
(close-sound ind))
(let ((gen (make-file->frample "oboe.snd"))
@@ -17641,14 +17201,14 @@ EDITS: 2
"file->frample"
"file->frample oboe.snd"
"file->frample oboe.snd")
- (if (not (mus-input? gen)) (snd-display #__line__ ";~A not input?" gen))
- (if (not (= (mus-length gen) 50828)) (snd-display #__line__ ";file->frample length: ~A?" (mus-length gen)))
- (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display #__line__ ";file->frample mus-file-name: ~A" (mus-file-name gen)))
+ (if (not (mus-input? gen)) (snd-display ";~A not input?" gen))
+ (if (not (= (mus-length gen) 50828)) (snd-display ";file->frample length: ~A?" (mus-length gen)))
+ (if (not (string=? (mus-file-name gen) "oboe.snd")) (snd-display ";file->frample mus-file-name: ~A" (mus-file-name gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) ((file->frample gen (+ 1490 i) g1) 0)))
- (if (not (file->frample? gen)) (snd-display #__line__ ";~A not file->frample?" gen))
- (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display #__line__ ";file->frample output: ~A" v0)))
+ (if (not (file->frample? gen)) (snd-display ";~A not file->frample?" gen))
+ (if (or (fneq (v0 1) -0.009) (fneq (v0 7) .029)) (snd-display ";file->frample output: ~A" v0)))
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
(if (file-exists? "fmv1.snd") (delete-file "fmv1.snd"))
@@ -17658,12 +17218,12 @@ EDITS: 2
(print-and-check gen
"sample->file"
"sample->file fmv.snd")
- (if (not (mus-output? gen)) (snd-display #__line__ ";~A not output?" gen))
- (if (not (sample->file? gen)) (snd-display #__line__ ";~A not sample->file?" gen))
- (if (not (= (mus-length gen) *clm-file-buffer-size*)) (snd-display #__line__ ";sample->file length: ~A?" (mus-length gen)))
+ (if (not (mus-output? gen)) (snd-display ";~A not output?" gen))
+ (if (not (sample->file? gen)) (snd-display ";~A not sample->file?" gen))
+ (if (not (= (mus-length gen) *clm-file-buffer-size*)) (snd-display ";sample->file length: ~A?" (mus-length gen)))
(let ((genx gen))
- (if (not (equal? genx gen)) (snd-display #__line__ ";sample->file equal? ~A ~A" genx gen)))
- (if (not (string=? (mus-file-name gen) "fmv.snd")) (snd-display #__line__ ";sample->file mus-file-name: ~A" (mus-file-name gen)))
+ (if (not (equal? genx gen)) (snd-display ";sample->file equal? ~A ~A" genx gen)))
+ (if (not (string=? (mus-file-name gen) "fmv.snd")) (snd-display ";sample->file mus-file-name: ~A" (mus-file-name gen)))
(do ((i 0 (+ i 1)))
((= i 100))
(sample->file gen i 0 (* i .001))
@@ -17687,13 +17247,13 @@ EDITS: 2
(print-and-check gen
"file->sample"
"file->sample fmv.snd")
- (if (not (= (mus-channels gen) 2)) (snd-display #__line__ ";make-sample->file chans: ~A?" (mus-channels gen)))
- (if (not (mus-input? gen)) (snd-display #__line__ ";~A not input?" gen))
- (if (or (fneq val0 .02) (fneq val1 .2)) (snd-display #__line__ ";in-any: ~A ~A?" val0 val1))
- (if (or (fneq val2 .03) (fneq val3 .3)) (snd-display #__line__ ";inab: ~A ~A?" val2 val3))
- (if (or (fneq val4 .04) (fneq val5 .4)) (snd-display #__line__ ";sample->file: ~A ~A?" val4 val5))
- (if (or (fneq val6 .065) (fneq val7 .65)) (snd-display #__line__ ";outab: ~A ~A?" val6 val7))
- (if (or (fneq val8 .075) (fneq val9 .75)) (snd-display #__line__ ";out-any: ~A ~A?" val8 val9)))
+ (if (not (= (mus-channels gen) 2)) (snd-display ";make-sample->file chans: ~A?" (mus-channels gen)))
+ (if (not (mus-input? gen)) (snd-display ";~A not input?" gen))
+ (if (or (fneq val0 .02) (fneq val1 .2)) (snd-display ";in-any: ~A ~A?" val0 val1))
+ (if (or (fneq val2 .03) (fneq val3 .3)) (snd-display ";inab: ~A ~A?" val2 val3))
+ (if (or (fneq val4 .04) (fneq val5 .4)) (snd-display ";sample->file: ~A ~A?" val4 val5))
+ (if (or (fneq val6 .065) (fneq val7 .65)) (snd-display ";outab: ~A ~A?" val6 val7))
+ (if (or (fneq val8 .075) (fneq val9 .75)) (snd-display ";out-any: ~A ~A?" val8 val9)))
(let ((gen (make-float-vector 10)))
(do ((i 0 (+ i 1))
@@ -17701,14 +17261,14 @@ EDITS: 2
((= i 10))
(outa i x gen))
(if (not (vequal gen (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9)))
- (snd-display #__line__ ";outa->float-vector ramp: ~A" gen))
+ (snd-display ";outa->float-vector ramp: ~A" gen))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.1)))
((= i 10))
(outa i x gen))
(if (not (vequal gen (float-vector-scale! (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9) 2.0)))
- (snd-display #__line__ ";outa->float-vector ramp 2: ~A" gen))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";mus-channels float-vector: ~A" (mus-channels gen))))
+ (snd-display ";outa->float-vector ramp 2: ~A" gen))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";mus-channels float-vector: ~A" (mus-channels gen))))
(let ((gen (make-float-vector (list 4 100) 0.0)))
(do ((i 0 (+ i 1)))
@@ -17730,8 +17290,8 @@ EDITS: 2
(fneq (inb i gen) .22)
(fneq (in-any i 2 gen) .33)
(fneq (in-any i 3 gen) .44))
- (snd-display #__line__ ";4-chan sd out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen))))
- (if (not (= (mus-channels gen) 4)) (snd-display #__line__ ";mus-channels sd 4: ~A" (mus-channels gen))))
+ (snd-display ";4-chan sd out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen))))
+ (if (not (= (mus-channels gen) 4)) (snd-display ";mus-channels sd 4: ~A" (mus-channels gen))))
(let ((gen (make-float-vector (list 4 100) 0.0)))
(do ((i 0 (+ i 1)))
@@ -17752,13 +17312,12 @@ EDITS: 2
(fneq (in-any i 1 gen) .22)
(fneq (in-any i 2 gen) .33)
(fneq (in-any i 3 gen) .44))
- (snd-display #__line__ ";4-chan sd out/in-any[~A]: ~A ~A ~A ~A?" i (in-any i 0 gen) (in-any i 1 gen) (in-any i 2 gen) (in-any i 3 gen)))))
+ (snd-display ";4-chan sd out/in-any[~A]: ~A ~A ~A ~A?" i (in-any i 0 gen) (in-any i 1 gen) (in-any i 2 gen) (in-any i 3 gen)))))
- (let ((gen (make-oscil 440.0)))
- (let ((tag (catch #t (lambda () (outa 0 .1 gen)) (lambda args (car args)))))
- (if (and (not (eq? tag 'wrong-type-arg))
- (not (eq? tag 'mus-error)))
- (snd-display #__line__ ";outa -> oscil: ~A" tag))))
+ (let* ((gen (make-oscil 440.0))
+ (tag (catch #t (lambda () (outa 0 .1 gen)) (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg mus-error)))
+ (snd-display ";outa -> oscil: ~A" tag)))
(let ((gen (make-sample->file "fmv.snd" 4 mus-lshort mus-riff)))
(print-and-check gen
@@ -17787,7 +17346,7 @@ EDITS: 2
(fneq (inb i gen) .22)
(fneq (in-any i 2 gen) .33)
(fneq (in-any i 3 gen) .44))
- (snd-display #__line__ ";4-chan out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen)))))
+ (snd-display ";4-chan out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen)))))
(let ((gen (make-sample->file "fmv.snd" 4 mus-lshort mus-riff)))
(do ((i 0 (+ i 1)))
@@ -17810,20 +17369,20 @@ EDITS: 2
(fneq (inb i gen) .22)
(fneq (in-any i 2 gen) .33)
(fneq (in-any i 3 gen) .44))
- (snd-display #__line__ ";4-chan out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen)))))
+ (snd-display ";4-chan out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen)))))
(let ((var (catch #t (lambda () (make-sample->file "fmv.snd" -1 mus-lshort mus-next)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-sample->file bad chans: ~A" var)))
+ (snd-display ";make-sample->file bad chans: ~A" var)))
(let ((var (catch #t (lambda () (mus-location (make-oscil))) (lambda args args))))
- (if (or (not (list? var)) (not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";mus-location oscil: ~A" var)))
+ (if (not (and (pair? var) (eq? (car var) 'mus-error)))
+ (snd-display ";mus-location oscil: ~A" var)))
(let ((var (catch #t (lambda () (make-sample->file "fmv.snd" 1 -1 mus-next)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-sample->file bad format: ~A" var)))
+ (snd-display ";make-sample->file bad format: ~A" var)))
(let ((var (catch #t (lambda () (make-sample->file "fmv.snd" 1 mus-lshort -1)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-sample->file bad type: ~A" var)))
+ (snd-display ";make-sample->file bad type: ~A" var)))
(let ((v (vector 1.0 0.5 0.25 0.125 0.0))
(v1 (make-float-vector 5 0.0)))
@@ -17831,7 +17390,7 @@ EDITS: 2
((= i 5))
(set! (v1 i) (in-any i 0 v)))
(if (not (vequal v1 (float-vector 1.0 0.5 0.25 0.125 0.0)))
- (snd-display #__line__ ";vector in-any -> ~A?" v1)))
+ (snd-display ";vector in-any -> ~A?" v1)))
(let ((invals (make-float-vector 10)))
(do ((i 0 (+ i 1)))
@@ -17842,7 +17401,7 @@ EDITS: 2
((= i 10))
(outa i (ina i invals))))))
(if (not (vequal result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
- (snd-display #__line__ ";ina from float-vector: ~A" result))))
+ (snd-display ";ina from float-vector: ~A" result))))
(let ((invals (make-float-vector 10)))
(do ((i 0 (+ i 1)))
@@ -17853,27 +17412,27 @@ EDITS: 2
((= i 10))
(outa i (ina i invals))))))
(if (not (vequal result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
- (snd-display #__line__ ";run ina from float-vector: ~A" result))))
+ (snd-display ";run ina from float-vector: ~A" result))))
(for-each close-sound (sounds))
(let ((vals (with-sound ((make-float-vector 4410))
(fm-violin 0 .1 440 .1))))
(if (fneq (float-vector-peak vals) .1)
- (snd-display #__line__ ";locsig to float-vector fm-violin peak: ~A" (float-vector-peak vals))))
+ (snd-display ";locsig to float-vector fm-violin peak: ~A" (float-vector-peak vals))))
- (let ((vals (with-sound ((make-float-vector (list 2 4410) 0.0))
- (fm-violin 0 .1 440 .1 :degree 30))))
- (let ((mxs (maxamp vals)))
- (if (fneq mxs 0.0666)
- (snd-display #__line__ ";locsig to sound-data fm-violin peak: ~A" mxs))))
+ (let* ((vals (with-sound ((make-float-vector (list 2 4410) 0.0))
+ (fm-violin 0 .1 440 .1 :degree 30)))
+ (mxs (maxamp vals)))
+ (if (fneq mxs 0.0666)
+ (snd-display ";locsig to sound-data fm-violin peak: ~A" mxs)))
(let ((gen (make-sample->file "fmv2.snd" 4 mus-bshort mus-aifc)))
(print-and-check gen
"sample->file"
"sample->file fmv2.snd")
- (if (not (mus-output? gen)) (snd-display #__line__ ";~A not output?" gen))
- (if (not (sample->file? gen)) (snd-display #__line__ ";~A not sample->file?" gen))
+ (if (not (mus-output? gen)) (snd-display ";~A not output?" gen))
+ (if (not (sample->file? gen)) (snd-display ";~A not sample->file?" gen))
(do ((i 0 (+ i 1)))
((= i 100))
(sample->file gen i 0 (* i .001))
@@ -17896,11 +17455,11 @@ EDITS: 2
(val3 (file->sample gen 50 3))
(val4 (file->sample gen 60 2))
(val5 (file->sample gen 60 3)))
- (if (not (= (mus-channels gen) 4)) (snd-display #__line__ ";make-file->sample (4) chans: ~A?" (mus-channels gen)))
- (if (not (= (mus-increment gen) 0.0)) (snd-display #__line__ ";file->sample increment: ~A" (mus-increment gen))) ; dir never set in this case
- (if (or (fneq val0 .04) (fneq val1 .06)) (snd-display #__line__ ";in-any(0, 4): ~A ~A?" val0 val1))
- (if (or (fneq val2 .12) (fneq val3 .18)) (snd-display #__line__ ";file->sample(4): ~A ~A?" val2 val3))
- (if (or (fneq val4 .14) (fneq val5 .21)) (snd-display #__line__ ";in-any(4, 4): ~A ~A?" val4 val5)))
+ (if (not (= (mus-channels gen) 4)) (snd-display ";make-file->sample (4) chans: ~A?" (mus-channels gen)))
+ (if (not (= (mus-increment gen) 0.0)) (snd-display ";file->sample increment: ~A" (mus-increment gen))) ; dir never set in this case
+ (if (or (fneq val0 .04) (fneq val1 .06)) (snd-display ";in-any(0, 4): ~A ~A?" val0 val1))
+ (if (or (fneq val2 .12) (fneq val3 .18)) (snd-display ";file->sample(4): ~A ~A?" val2 val3))
+ (if (or (fneq val4 .14) (fneq val5 .21)) (snd-display ";in-any(4, 4): ~A ~A?" val4 val5)))
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
(mus-sound-forget "fmv.snd")
@@ -17911,17 +17470,17 @@ EDITS: 2
(sample->file sf i 1 (* i .01)))
(mus-close sf)
(if (not (= (mus-sound-chans "fmv.snd") 2))
- (snd-display #__line__ ";sample->file chans: ~A" (mus-sound-chans "fmv.snd")))
+ (snd-display ";sample->file chans: ~A" (mus-sound-chans "fmv.snd")))
(if (not (= (mus-sound-framples "fmv.snd") 10))
- (snd-display #__line__ ";sample->file framples: ~A" (mus-sound-framples "fmv.snd")))
+ (snd-display ";sample->file framples: ~A" (mus-sound-framples "fmv.snd")))
(if (not (= (mus-sound-samples "fmv.snd") 20))
- (snd-display #__line__ ";sample->file samples: ~A" (mus-sound-samples "fmv.snd")))
+ (snd-display ";sample->file samples: ~A" (mus-sound-samples "fmv.snd")))
(if (not (= (mus-sound-header-type "fmv.snd") mus-next))
- (snd-display #__line__ ";sample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";sample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-bshort))
- (snd-display #__line__ ";sample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";sample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";sample->file comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";sample->file comment: ~A" (mus-sound-comment "fmv.snd")))
(let ((rd (make-file->sample "fmv.snd"))
(happy #t))
(do ((i 0 (+ i 1)))
@@ -17931,7 +17490,7 @@ EDITS: 2
(if (or (fneq c0 (* i .1))
(fneq c1 (* i .01)))
(begin
- (snd-display #__line__ ";sample->file->sample at ~A: ~A ~A" i c0 c1)
+ (snd-display ";sample->file->sample at ~A: ~A ~A" i c0 c1)
(set! happy #f)))))
(mus-close rd))
(set! sf (continue-sample->file "fmv.snd"))
@@ -17942,24 +17501,24 @@ EDITS: 2
(mus-close sf)
(mus-sound-forget "fmv.snd")
(if (not (= (mus-sound-chans "fmv.snd") 2))
- (snd-display #__line__ ";continue-sample->file chans: ~A" (mus-sound-chans "fmv.snd")))
+ (snd-display ";continue-sample->file chans: ~A" (mus-sound-chans "fmv.snd")))
(if (not (= (mus-sound-framples "fmv.snd") 15))
- (snd-display #__line__ ";continue-sample->file framples: ~A" (mus-sound-framples "fmv.snd")))
+ (snd-display ";continue-sample->file framples: ~A" (mus-sound-framples "fmv.snd")))
(if (not (= (mus-sound-samples "fmv.snd") 30))
- (snd-display #__line__ ";continue-sample->file samples: ~A" (mus-sound-samples "fmv.snd")))
+ (snd-display ";continue-sample->file samples: ~A" (mus-sound-samples "fmv.snd")))
(if (not (= (mus-sound-header-type "fmv.snd") mus-next))
- (snd-display #__line__ ";continue-sample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";continue-sample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-bshort))
- (snd-display #__line__ ";continue-sample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";continue-sample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";continue-sample->file comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";continue-sample->file comment: ~A" (mus-sound-comment "fmv.snd")))
(let ((ind (open-sound "fmv.snd")))
(let ((c0 (channel->float-vector 0 15 ind 0))
(c1 (channel->float-vector 0 15 ind 1)))
(if (not (vequal c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
- (snd-display #__line__ ";continue-sample->file (0): ~A" c0))
+ (snd-display ";continue-sample->file (0): ~A" c0))
(if (not (vequal c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
- (snd-display #__line__ ";continue-sample->file (1): ~A" c1)))
+ (snd-display ";continue-sample->file (1): ~A" c1)))
(close-sound ind))
(delete-file "fmv.snd")
(mus-sound-forget "fmv.snd"))
@@ -17969,14 +17528,14 @@ EDITS: 2
(m1 (float-vector .5 .25 .125 1.0)))
(let ((result (frample->frample m1 f1 2 f2 2)))
(if (not (equal? result (float-vector 0.625 1.25)))
- (snd-display #__line__ ";frample->frample: ~A" result))))
+ (snd-display ";frample->frample: ~A" result))))
(let ((f1 (float-vector 1.0 2.0 3.0))
(f2 (float-vector 0.0 0.0 0.0))
(m1 (float-vector 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0)))
(let ((result (frample->frample m1 f1 3 f2 3)))
(if (not (equal? result (float-vector 30.0 36.0 42.0)))
- (snd-display #__line__ ";frample->frample 1: ~A" result))))
+ (snd-display ";frample->frample 1: ~A" result))))
(let ((sf (make-frample->file "fmv.snd" 2 mus-lfloat mus-riff "this is a comment")))
(do ((i 0 (+ i 1)))
@@ -17984,17 +17543,17 @@ EDITS: 2
(frample->file sf i (float-vector (* i .1) (* i .01))))
(mus-close sf)
(if (not (= (mus-sound-chans "fmv.snd") 2))
- (snd-display #__line__ ";frample->file chans: ~A" (mus-sound-chans "fmv.snd")))
+ (snd-display ";frample->file chans: ~A" (mus-sound-chans "fmv.snd")))
(if (not (= (mus-sound-framples "fmv.snd") 10))
- (snd-display #__line__ ";frample->file framples: ~A" (mus-sound-framples "fmv.snd")))
+ (snd-display ";frample->file framples: ~A" (mus-sound-framples "fmv.snd")))
(if (not (= (mus-sound-samples "fmv.snd") 20))
- (snd-display #__line__ ";frample->file samples: ~A" (mus-sound-samples "fmv.snd")))
+ (snd-display ";frample->file samples: ~A" (mus-sound-samples "fmv.snd")))
(if (not (= (mus-sound-header-type "fmv.snd") mus-riff))
- (snd-display #__line__ ";frample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";frample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-lfloat))
- (snd-display #__line__ ";frample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";frample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";frample->file comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";frample->file comment: ~A" (mus-sound-comment "fmv.snd")))
(let ((rd (make-file->frample "fmv.snd"))
(f0 (float-vector 0.0 0.0))
(happy #t))
@@ -18005,7 +17564,7 @@ EDITS: 2
(fneq (f0 0) (* i .1))
(fneq (f0 1) (* i .01)))
(begin
- (snd-display #__line__ ";frample->file->frample at ~A: ~A" i f0)
+ (snd-display ";frample->file->frample at ~A: ~A" i f0)
(set! happy #f))))
(mus-close rd))
(set! sf (continue-frample->file "fmv.snd"))
@@ -18015,50 +17574,50 @@ EDITS: 2
(mus-close sf)
(mus-sound-forget "fmv.snd")
(if (not (= (mus-sound-chans "fmv.snd") 2))
- (snd-display #__line__ ";continue-frample->file chans: ~A" (mus-sound-chans "fmv.snd")))
+ (snd-display ";continue-frample->file chans: ~A" (mus-sound-chans "fmv.snd")))
(if (not (= (mus-sound-framples "fmv.snd") 15))
- (snd-display #__line__ ";continue-frample->file framples: ~A" (mus-sound-framples "fmv.snd")))
+ (snd-display ";continue-frample->file framples: ~A" (mus-sound-framples "fmv.snd")))
(if (not (= (mus-sound-samples "fmv.snd") 30))
- (snd-display #__line__ ";continue-frample->file samples: ~A" (mus-sound-samples "fmv.snd")))
+ (snd-display ";continue-frample->file samples: ~A" (mus-sound-samples "fmv.snd")))
(if (not (= (mus-sound-header-type "fmv.snd") mus-riff))
- (snd-display #__line__ ";continue-frample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
+ (snd-display ";continue-frample->file type: ~A" (mus-header-type-name (mus-sound-header-type "fmv.snd"))))
(if (not (= (mus-sound-sample-type "fmv.snd") mus-lfloat))
- (snd-display #__line__ ";continue-frample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
+ (snd-display ";continue-frample->file format: ~A" (mus-sample-type-name (mus-sound-sample-type "fmv.snd"))))
(if (not (string=? (mus-sound-comment "fmv.snd") "this is a comment"))
- (snd-display #__line__ ";continue-frample->file comment: ~A" (mus-sound-comment "fmv.snd")))
+ (snd-display ";continue-frample->file comment: ~A" (mus-sound-comment "fmv.snd")))
(let ((ind (open-sound "fmv.snd")))
(let ((c0 (channel->float-vector 0 15 ind 0))
(c1 (channel->float-vector 0 15 ind 1)))
(if (not (vequal c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
- (snd-display #__line__ ";continue-frample->file (0): ~A" c0))
+ (snd-display ";continue-frample->file (0): ~A" c0))
(if (not (vequal c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
- (snd-display #__line__ ";continue-frample->file (1): ~A" c1)))
+ (snd-display ";continue-frample->file (1): ~A" c1)))
(close-sound ind))
(delete-file "fmv.snd")
(mus-sound-forget "fmv.snd"))
- (let ((v0 (make-float-vector 1000))
- (os (make-oscil 440.0)))
- (do ((i 0 (+ i 1)))
- ((= i 1000))
- (set! (v0 i) (* .1 (oscil os))))
+ (let ((v0 (make-float-vector 1000)))
+ (let ((os (make-oscil 440.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i 1000))
+ (set! (v0 i) (* .1 (oscil os)))))
(array->file "fmv3.snd" v0 10000 22050 1) ; 10000 deliberate
(let ((v1 (make-float-vector 1000)))
(file->array "fmv3.snd" 0 0 1000 v1)
(do ((i 0 (+ i 1)))
((= i 1000))
(if (fneq (v0 i) (v1 i))
- (snd-display #__line__ ";array->file->array: ~A ~A ~A?" i (v0 i) (v1 i)))))
+ (snd-display ";array->file->array: ~A ~A ~A?" i (v0 i) (v1 i)))))
(let ((var (catch #t (lambda () (array->file "fmv3.snd" v0 -1 1000 1)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";array->file bad samps: ~A" var)))
+ (snd-display ";array->file bad samps: ~A" var)))
(let ((var (catch #t (lambda () (array->file "/bad/baddy/fmv3.snd" v0 1 1000 1)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";array->file bad file: ~A" var)))
+ (snd-display ";array->file bad file: ~A" var)))
(let ((var (catch #t (lambda () (file->array "fmv3.snd" -1 0 -1 v0)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";file->array bad samps: ~A" var))))
+ (snd-display ";file->array bad samps: ~A" var))))
(let ((gen (make-rand 10000.0))
(v0 (make-float-vector 10)))
@@ -18068,12 +17627,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (rand gen)))
- (if (not (rand? gen)) (snd-display #__line__ ";~A not rand?" gen))
- (if (fneq (mus-phase gen) 3.3624296) (snd-display #__line__ ";rand phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 10000.0) (snd-display #__line__ ";rand frequency: ~F?" (mus-frequency gen)))
+ (if (not (rand? gen)) (snd-display ";~A not rand?" gen))
+ (if (fneq (mus-phase gen) 3.3624296) (snd-display ";rand phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 10000.0) (snd-display ";rand frequency: ~F?" (mus-frequency gen)))
(set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! mus-scaler rand: ~A" (mus-scaler gen)))
- (if (= (v0 1) (v0 8)) (snd-display #__line__ ";rand output: ~A" v0)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! mus-scaler rand: ~A" (mus-scaler gen)))
+ (if (= (v0 1) (v0 8)) (snd-display ";rand output: ~A" v0)))
(let ((gen (make-rand 10000.0 :envelope '(0 0 1 1)))
(v0 (make-float-vector 10)))
@@ -18083,13 +17642,13 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (rand gen)))
- (if (not (rand? gen)) (snd-display #__line__ ";(dist) ~A not rand?" gen))
- (if (fneq (mus-frequency gen) 10000.0) (snd-display #__line__ ";(dist) rand frequency: ~F?" (mus-frequency gen)))
- (if (= (v0 1) (v0 8)) (snd-display #__line__ ";(dist) rand output: ~A" v0))
- (if (or (not (float-vector? (mus-data gen)))
- (not (= (mus-length gen) (length (mus-data gen))))
- (not (= (mus-length gen) 512)))
- (snd-display #__line__ ";(dist) rand data: ~A ~A" (mus-length gen) (mus-data gen))))
+ (if (not (rand? gen)) (snd-display ";(dist) ~A not rand?" gen))
+ (if (fneq (mus-frequency gen) 10000.0) (snd-display ";(dist) rand frequency: ~F?" (mus-frequency gen)))
+ (if (= (v0 1) (v0 8)) (snd-display ";(dist) rand output: ~A" v0))
+ (if (not (and (float-vector? (mus-data gen))
+ (= (mus-length gen) (length (mus-data gen)))
+ (= (mus-length gen) 512)))
+ (snd-display ";(dist) rand data: ~A ~A" (mus-length gen) (mus-data gen))))
(let ((gen1 (make-rand 10000.0 :envelope '(0 0 1 1)))
(gen2 (make-rand 10000.0 :envelope '(0 1 1 0)))
@@ -18117,7 +17676,7 @@ EDITS: 2
(not (= bad2 0))
(> (* 2 down1) up1)
(> (* 2 up2) down2))
- (snd-display #__line__ "; rand dist: ~A ~A ~A, ~A ~A ~A" down1 up1 bad1 down2 up2 bad2)))
+ (snd-display "; rand dist: ~A ~A ~A, ~A ~A ~A" down1 up1 bad1 down2 up2 bad2)))
; (test-gen-equal (make-rand 1000) (make-rand 1000) (make-rand 500))
; (test-gen-equal (make-rand 1000) (make-rand 1000) (make-rand 1000 0.5))
@@ -18127,7 +17686,7 @@ EDITS: 2
((= i 10))
(let ((val (rand-interp gen)))
(if (not (zero? val))
- (snd-display #__line__ ";rand-interp 0 amp: ~A" val)))))
+ (snd-display ";rand-interp 0 amp: ~A" val)))))
(let ((gen (make-rand-interp 4000.0))
(v0 (make-float-vector 10)))
@@ -18137,12 +17696,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (rand-interp gen 0.0)))
- (if (not (rand-interp? gen)) (snd-display #__line__ ";~A not rand-interp?" gen))
- (if (fneq (mus-phase gen) 5.114882) (snd-display #__line__ ";rand-interp phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 4000.0) (snd-display #__line__ ";rand-interp frequency: ~F?" (mus-frequency gen)))
+ (if (not (rand-interp? gen)) (snd-display ";~A not rand-interp?" gen))
+ (if (fneq (mus-phase gen) 5.114882) (snd-display ";rand-interp phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 4000.0) (snd-display ";rand-interp frequency: ~F?" (mus-frequency gen)))
(set! (mus-scaler gen) 0.5)
- (if (fneq (mus-scaler gen) 0.5) (snd-display #__line__ ";set! mus-scaler rand-interp: ~A" (mus-scaler gen)))
- (if (= (v0 1) (v0 8)) (snd-display #__line__ ";rand-interp output: ~A" v0)))
+ (if (fneq (mus-scaler gen) 0.5) (snd-display ";set! mus-scaler rand-interp: ~A" (mus-scaler gen)))
+ (if (= (v0 1) (v0 8)) (snd-display ";rand-interp output: ~A" v0)))
(let ((gen (make-rand-interp 4000.0 :envelope '(-1 1 0 0 1 1)))
(v0 (make-float-vector 10)))
@@ -18152,12 +17711,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (rand-interp gen 0.0)))
- (if (not (rand-interp? gen)) (snd-display #__line__ ";(dist) ~A not rand-interp?" gen))
- (if (= (v0 1) (v0 8)) (snd-display #__line__ ";(dist) rand-interp output: ~A" v0))
- (if (or (not (float-vector? (mus-data gen)))
- (not (= (mus-length gen) (length (mus-data gen))))
- (not (= (mus-length gen) 512)))
- (snd-display #__line__ ";(dist) rand-interp data: ~A ~A" (mus-length gen) (mus-data gen))))
+ (if (not (rand-interp? gen)) (snd-display ";(dist) ~A not rand-interp?" gen))
+ (if (= (v0 1) (v0 8)) (snd-display ";(dist) rand-interp output: ~A" v0))
+ (if (not (and (float-vector? (mus-data gen))
+ (= (mus-length gen) (length (mus-data gen)))
+ (= (mus-length gen) 512)))
+ (snd-display ";(dist) rand-interp data: ~A ~A" (mus-length gen) (mus-data gen))))
(let ((gen (make-rand 10000.0 1.0))
(gen1 (make-rand-interp 10000.0 1.0)))
@@ -18165,12 +17724,10 @@ EDITS: 2
((= i 1000))
(let ((val1 (gen 0.0))
(val2 (gen1 0.0)))
- (if (or (> val1 1.0)
- (< val1 -1.0))
- (snd-display #__line__ ";rand: ~A ~A" val1 gen))
- (if (or (> val2 1.0)
- (< val2 -1.0))
- (snd-display #__line__ ";rand-interp: ~A ~A" val2 gen1)))))
+ (if (not (>= 1.0 val1 -1.0))
+ (snd-display ";rand: ~A ~A" val1 gen))
+ (if (not (>= 1.0 val2 -1.0))
+ (snd-display ";rand-interp: ~A ~A" val2 gen1)))))
(let ((gen (make-rand 10000.0 :distribution (inverse-integrate '(0 0 1 1))))
(v0 (make-float-vector 10)))
@@ -18180,13 +17737,13 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (rand gen)))
- (if (not (rand? gen)) (snd-display #__line__ ";(dist 2) ~A not rand?" gen))
- (if (fneq (mus-frequency gen) 10000.0) (snd-display #__line__ ";(dist 2) rand frequency: ~F?" (mus-frequency gen)))
- (if (= (v0 1) (v0 8)) (snd-display #__line__ ";(dist 2) rand output: ~A" v0))
- (if (or (not (float-vector? (mus-data gen)))
- (not (= (mus-length gen) (length (mus-data gen))))
- (not (= (mus-length gen) 512)))
- (snd-display #__line__ ";(dist 2) rand data: ~A ~A" (mus-length gen) (mus-data gen))))
+ (if (not (rand? gen)) (snd-display ";(dist 2) ~A not rand?" gen))
+ (if (fneq (mus-frequency gen) 10000.0) (snd-display ";(dist 2) rand frequency: ~F?" (mus-frequency gen)))
+ (if (= (v0 1) (v0 8)) (snd-display ";(dist 2) rand output: ~A" v0))
+ (if (not (and (float-vector? (mus-data gen))
+ (= (mus-length gen) (length (mus-data gen)))
+ (= (mus-length gen) 512)))
+ (snd-display ";(dist 2) rand data: ~A ~A" (mus-length gen) (mus-data gen))))
(let ((gen1 (make-rand 10000.0 :distribution (inverse-integrate '(0 0 1 1))))
(gen2 (make-rand 10000.0 :distribution (inverse-integrate '(0 1 1 0))))
@@ -18214,17 +17771,17 @@ EDITS: 2
(not (= bad2 0))
(> (* 2.5 down1) up1)
(> (* 2.0 up2) down2))
- (snd-display #__line__ "; rand dist 2: ~A ~A ~A, ~A ~A ~A" down1 up1 bad1 down2 up2 bad2))) ; 234 766 0, 705 295 0
+ (snd-display "; rand dist 2: ~A ~A ~A, ~A ~A ~A" down1 up1 bad1 down2 up2 bad2))) ; 234 766 0, 705 295 0
(let ((ind (new-sound :size 100)))
(select-sound ind)
(map-channel (lambda (y) (any-random 1.0 '(0 1 1 1))))
(let ((place (scan-channel (lambda (y) (not (<= 0.0 y 1.0)))))) ; (or (< y 0.0) (> y 1.0))))))
- (if place (snd-display #__line__ ";any-random 0 to 1: ~A" place)))
- (if (< (maxamp) .5) (snd-display #__line__ ";any-random maxamp: ~A" (maxamp))) ; possible, but extremely unlikely
+ (if place (snd-display ";any-random 0 to 1: ~A" place)))
+ (if (< (maxamp) .5) (snd-display ";any-random maxamp: ~A" (maxamp))) ; possible, but extremely unlikely
(let ((avg 0.0))
(scan-channel (lambda (y) (set! avg (+ avg y)) #f))
- (if (> (abs (- (/ avg (framples)) .5)) .2) (snd-display #__line__ ";any-random skewed?")))
+ (if (> (abs (- (/ avg (framples)) .5)) .2) (snd-display ";any-random skewed?")))
(let ((g (gaussian-distribution 1.0)))
(map-channel (lambda (y) (any-random 1.0 g))))
(let ((g (pareto-distribution 1.0)))
@@ -18235,48 +17792,46 @@ EDITS: 2
(let ((v1 (inverse-integrate '(-1 1 1 1))))
(if (fneq (v1 4) -0.984)
- (snd-display #__line__ ";inverse-integrate -1 to 1 uniform: ~A" v1)))
+ (snd-display ";inverse-integrate -1 to 1 uniform: ~A" v1)))
(let ((v1 (inverse-integrate '(0 1 1 1))))
(if (fneq (v1 4) .008)
- (snd-display #__line__ ";inverse-integrate 0 to 1 uniform: ~A" v1)))
+ (snd-display ";inverse-integrate 0 to 1 uniform: ~A" v1)))
(let ((v1 (inverse-integrate '(0 1 1 0))))
(if (fneq (v1 4) .004)
- (snd-display #__line__ ";inverse-integrate 0 to 1 1 to 0: ~A" v1)))
+ (snd-display ";inverse-integrate 0 to 1 1 to 0: ~A" v1)))
(let ((v1 (inverse-integrate '(0 0 .5 1 1 0))))
(if (fneq (v1 4) .073)
- (snd-display #__line__ ";inverse-integrate triangle: ~A" v1)))
+ (snd-display ";inverse-integrate triangle: ~A" v1)))
(let ((v1 (inverse-integrate (gaussian-envelope 1.0))))
(if (fneq (v1 4) -0.593)
- (snd-display #__line__ ";inverse-integrate gaussian: ~A" v1)))
+ (snd-display ";inverse-integrate gaussian: ~A" v1)))
(let ((minp 1.0)
(maxp -1.0))
(do ((i 0 (+ i 1)))
((= i 1100))
(let ((val1 (mus-random 1.0)))
- (if (< val1 minp) (set! minp val1))
- (if (> val1 maxp) (set! maxp val1))
- (if (or (> val1 1.0)
- (< val1 -1.0))
- (snd-display #__line__ ";mus-random: ~A" val1))))
+ (set! minp (min minp val1))
+ (set! maxp (max maxp val1))
+ (if (not (>= 1.0 val1 -1.0))
+ (snd-display ";mus-random: ~A" val1))))
(if (or (< maxp .9)
(> minp -.9))
- (snd-display #__line__ ";mus-random: ~A ~A" minp maxp))
+ (snd-display ";mus-random: ~A ~A" minp maxp))
(set! minp 12.0)
(set! maxp -12.0)
(do ((i 0 (+ i 1)))
((= i 1100))
(let ((val1 (mus-random 12.0)))
- (if (< val1 minp) (set! minp val1))
- (if (> val1 maxp) (set! maxp val1))
- (if (or (> val1 12.0)
- (< val1 -12.0))
- (snd-display #__line__ ";mus-random (12): ~A" val1))))
+ (set! minp (min minp val1))
+ (set! maxp (max maxp val1))
+ (if (not (>= 12.0 val1 -12.0))
+ (snd-display ";mus-random (12): ~A" val1))))
(if (or (< maxp 11.0)
(> minp -11.0))
- (snd-display #__line__ ";mus-random (12): ~A ~A" minp maxp)))
+ (snd-display ";mus-random (12): ~A ~A" minp maxp)))
- (let ((v (lambda (n) ; chi^2 or mus-random
+ (let* ((v (lambda (n) ; chi^2 or mus-random
(let ((hits (make-vector 10 0)))
(do ((i 0 (+ 1 i )))
((= i n))
@@ -18287,17 +17842,17 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10) sum)
(let ((num (- (vector-ref hits i) p)))
- (set! sum (+ sum (/ (* num num) p))))))))))
+ (set! sum (+ sum (/ (* num num) p)))))))))
;;:(v 10000)
;;#(999 1017 1002 1024 1048 971 963 1000 980 996) 5.8
;; if less than 3 complain
- (let ((vr (v 10000)))
- (if (< vr 3.0)
- (snd-display #__line__ ";mus-random not so random? ~A (chi)" vr))))
+ (vr (v 10000)))
+ (if (< vr 3.0)
+ (snd-display ";mus-random not so random? ~A (chi)" vr)))
- (let ((v1 (lambda (n)
+ (let* ((v1 (lambda (n)
(let ((hits (make-vector 10 0))
(gen (make-rand 22050.0 5)))
(do ((i 0 (+ 1 i )))
@@ -18309,14 +17864,14 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10) sum)
(let ((num (- (vector-ref hits i) p)))
- (set! sum (+ sum (/ (* num num) p))))))))))
+ (set! sum (+ sum (/ (* num num) p)))))))))
;;:(v1 10000)
;;#(979 1015 977 1008 954 1049 997 1020 1015 986) 6.606
- (let ((vr (v1 10000)))
- (if (< vr 3.5)
- (snd-display #__line__ ";rand not so random? ~A (chi)" vr))))
+ (vr (v1 10000)))
+ (if (< vr 3.5)
+ (snd-display ";rand not so random? ~A (chi)" vr)))
(let ((data (make-float-vector 65536)))
(do ((i 0 (+ i 1)))
@@ -18326,12 +17881,12 @@ EDITS: 2
(peak (float-vector-peak ndat))
(sum 0.0))
(if (> peak 1000.0)
- (snd-display #__line__ ";mus-random spectral peak: ~A" peak))
+ (snd-display ";mus-random spectral peak: ~A" peak))
(do ((i 0 (+ i 1)))
((= i 32768))
(set! sum (+ sum (float-vector-ref ndat i))))
(if (> (/ sum 32768.0) 200.0)
- (snd-display #__line__ ";random average: ~A ~A" (/ sum 32768.0) (ndat 0)))
+ (snd-display ";random average: ~A ~A" (/ sum 32768.0) (ndat 0)))
(do ((i 0 (+ i 1)))
((= i 65536))
(set! (data i) (mus-random 1.0)))
@@ -18339,72 +17894,72 @@ EDITS: 2
(set! (data 0) 0.0)
(let ((pk (float-vector-peak data)))
(if (> pk 1000)
- (snd-display #__line__ ";random autocorrelate peak: ~A" (float-vector-peak data)))
- (set! sum 0.0)
- (float-vector-abs! data)
- (do ((i 0 (+ i 1)))
- ((= i 32768))
- (set! sum (+ sum (float-vector-ref data i))))
- (if (> (/ sum 32768.0) 200.0)
- (snd-display #__line__ ";random autocorrelate average: ~A" (/ sum 32768.0))))))
+ (snd-display ";random autocorrelate peak: ~A" (float-vector-peak data))))
+ (set! sum 0.0)
+ (float-vector-abs! data)
+ (do ((i 0 (+ i 1)))
+ ((= i 32768))
+ (set! sum (+ sum (float-vector-ref data i))))
+ (if (> (/ sum 32768.0) 200.0)
+ (snd-display ";random autocorrelate average: ~A" (/ sum 32768.0)))))
(set! (locsig-type) mus-interp-linear)
- (let* ((gen (make-locsig 30.0 :channels 2))
- (gen1 (make-locsig 60.0 :channels 2))
- (gen2 (make-locsig 60.0 :channels 4))
- (gen200 (make-locsig 200.0 :channels 4))
- (gen3 gen1))
+ (let ((gen (make-locsig 30.0 :channels 2))
+ (gen1 (make-locsig 60.0 :channels 2)))
(locsig gen 0 1.0)
(print-and-check gen
"locsig"
"locsig chans 2, outn: [0.667 0.333], interp: linear")
- (if (not (locsig? gen)) (snd-display #__line__ ";~A not locsig?" gen))
- (if (not (eq? gen1 gen3)) (snd-display #__line__ ";locsig eq? ~A ~A" gen1 gen3))
- (if (not (equal? gen1 gen3)) (snd-display #__line__ ";locsig equal? ~A ~A" gen1 gen3))
- (if (eq? gen1 gen2) (snd-display #__line__ ";locsig 1 eq? ~A ~A" gen1 gen2))
- (if (equal? gen gen1) (snd-display #__line__ ";locsig 2 equal? ~A ~A" gen gen1))
- (if (equal? gen gen2) (snd-display #__line__ ";locsig 3 equal? ~A ~A" gen gen2))
- (if (or (fneq (locsig-ref gen 0) .667) (fneq (locsig-ref gen 1) .333))
- (snd-display #__line__ ";locsig ref: ~F ~F?" (locsig-ref gen 0) (locsig-ref gen 1)))
- (if (not (vequal (mus-data gen) (float-vector 0.667 0.333)))
- (snd-display #__line__ ";locsig gen outn: ~A" (mus-data gen)))
- (if (not (vequal (mus-data gen1) (float-vector 0.333 0.667)))
- (snd-display #__line__ ";locsig gen2 outn: ~A" (mus-data gen1)))
- (if (not (vequal (mus-data gen2) (float-vector 0.333 0.667 0.000 0.000)))
- (snd-display #__line__ ";locsig gen2 outn: ~A" (mus-data gen2)))
- (if (not (vequal (mus-data gen200) (float-vector 0.000 0.000 0.778 0.222)))
- (snd-display #__line__ ";locsig gen200 outn: ~A" (mus-data gen200)))
+ (if (not (locsig? gen)) (snd-display ";~A not locsig?" gen))
+ (let ((gen3 gen1))
+ (if (not (eq? gen1 gen3)) (snd-display ";locsig eq? ~A ~A" gen1 gen3))
+ (if (not (equal? gen1 gen3)) (snd-display ";locsig equal? ~A ~A" gen1 gen3)))
+ (let ((gen2 (make-locsig 60.0 :channels 4)))
+ (if (eq? gen1 gen2) (snd-display ";locsig 1 eq? ~A ~A" gen1 gen2))
+ (if (equal? gen gen1) (snd-display ";locsig 2 equal? ~A ~A" gen gen1))
+ (if (equal? gen gen2) (snd-display ";locsig 3 equal? ~A ~A" gen gen2))
+ (if (or (fneq (locsig-ref gen 0) .667) (fneq (locsig-ref gen 1) .333))
+ (snd-display ";locsig ref: ~F ~F?" (locsig-ref gen 0) (locsig-ref gen 1)))
+ (if (not (vequal (mus-data gen) (float-vector 0.667 0.333)))
+ (snd-display ";locsig gen outn: ~A" (mus-data gen)))
+ (if (not (vequal (mus-data gen1) (float-vector 0.333 0.667)))
+ (snd-display ";locsig gen2 outn: ~A" (mus-data gen1)))
+ (if (not (vequal (mus-data gen2) (float-vector 0.333 0.667 0.000 0.000)))
+ (snd-display ";locsig gen2 outn: ~A" (mus-data gen2))))
+ (let ((gen200 (make-locsig 200.0 :channels 4)))
+ (if (not (vequal (mus-data gen200) (float-vector 0.000 0.000 0.778 0.222)))
+ (snd-display ";locsig gen200 outn: ~A" (mus-data gen200))))
(locsig-set! gen 0 .25)
(if (not (vequal (mus-data gen) (float-vector 0.250 0.333)))
- (snd-display #__line__ ";locsig gen .25 outn: ~A" (mus-data gen)))
+ (snd-display ";locsig gen .25 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(locsig-set! gen 0 .5)
(if (not (vequal (mus-data gen) (float-vector 0.500 0.333)))
- (snd-display #__line__ ";locsig gen .5 outn: ~A" (mus-data gen)))
+ (snd-display ";locsig gen .5 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(set! gen (make-locsig 120.0 2.0 .1 :channels 4))
(if (not (vequal (mus-data gen) (float-vector 0.000 0.333 0.167 0.000)))
- (snd-display #__line__ ";locsig gen 120 outn: ~A" (mus-data gen)))
+ (snd-display ";locsig gen 120 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(set! gen (make-locsig 300.0 2.0 .1 :channels 4))
(if (not (vequal (mus-data gen) (float-vector 0.167 0.000 0.000 0.333)))
- (snd-display #__line__ ";locsig gen 300 outn: ~A" (mus-data gen)))
+ (snd-display ";locsig gen 300 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(move-locsig gen1 90.0 1.0)
(if (not (vequal (mus-data gen1) (float-vector 0.000 1.000)))
- (snd-display #__line__ ";locsig gen1 90 outn: ~A" (mus-data gen1)))
+ (snd-display ";locsig gen1 90 outn: ~A" (mus-data gen1)))
(move-locsig gen1 0.0 1.0)
(if (not (vequal (mus-data gen1) (float-vector 1.000 0.000)))
- (snd-display #__line__ ";locsig gen1 0 outn: ~A" (mus-data gen1)))
+ (snd-display ";locsig gen1 0 outn: ~A" (mus-data gen1)))
(move-locsig gen1 45.0 1.0)
(if (not (vequal (mus-data gen1) (float-vector 0.500 0.500)))
- (snd-display #__line__ ";locsig gen1 45 outn: ~A" (mus-data gen1)))
+ (snd-display ";locsig gen1 45 outn: ~A" (mus-data gen1)))
(move-locsig gen1 135.0 2.0)
(if (not (vequal (mus-data gen1) (float-vector 0.000 0.500)))
- (snd-display #__line__ ";locsig gen1 135 outn: ~A" (mus-data gen1)))
+ (snd-display ";locsig gen1 135 outn: ~A" (mus-data gen1)))
(move-locsig gen1 -270.0 3.0)
(if (not (vequal (mus-data gen1) (float-vector 0.333 0.0)))
- (snd-display #__line__ ";locsig gen1 -270 outn: ~A" (mus-data gen1))))
+ (snd-display ";locsig gen1 -270 outn: ~A" (mus-data gen1))))
(for-each
(lambda (chans)
@@ -18419,98 +17974,98 @@ EDITS: 2
(move-locsig loc x 1.0)
(if (or (< (float-vector-min data) 0.0)
(> (float-vector-max data) 1.0))
- (format #t ";locsig, chans: ~D, degree: ~F, ~A~%" chans x data))
+ (format () ";locsig, chans: ~D, degree: ~F, ~A~%" chans x data))
(let ((diff (float-vector-peak (float-vector-subtract! last data))))
(copy data last)
(if (> diff .25)
- (format #t ";locsig, increment ~F with deg ~F~%" diff x))))))
+ (format () ";locsig, increment ~F with deg ~F~%" diff x))))))
(list 1 2 4 5 8))
(for-each
(lambda (chans)
(let ((m1 (make-locsig :channels chans)))
- (if (or (not (= (mus-channels m1) chans))
- (not (= (mus-length m1) chans)))
- (snd-display #__line__ ";locsig ~A chans but: ~A ~A" chans (mus-channels m1) (mus-length m1)))
+ (if (not (and (= (mus-channels m1) chans)
+ (= (mus-length m1) chans)))
+ (snd-display ";locsig ~A chans but: ~A ~A" chans (mus-channels m1) (mus-length m1)))
(do ((i 0 (+ i 1)))
((= i chans))
(locsig-set! m1 i (* i .1)))
(do ((i 0 (+ i 1)))
((= i chans))
(if (fneq (locsig-ref m1 i) (* i .1))
- (snd-display #__line__ ";locsig[~A] = ~A (~A)?" i (locsig-ref m1 i) (* i .1))))))
+ (snd-display ";locsig[~A] = ~A (~A)?" i (locsig-ref m1 i) (* i .1))))))
(list 1 2 4 8))
(let ((var (catch #t (lambda () (make-locsig :channels 0)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
- (snd-display #__line__ ";make-locsig bad (0) chans: ~A" var)))
+ (snd-display ";make-locsig bad (0) chans: ~A" var)))
(let ((var (catch #t (lambda () (make-locsig :channels -2)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-locsig bad (-2) chans: ~A" var)))
+ (snd-display ";make-locsig bad (-2) chans: ~A" var)))
(let ((var (catch #t (lambda () (make-locsig :output 1)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-locsig bad output: ~A" var)))
+ (snd-display ";make-locsig bad output: ~A" var)))
(let ((var (catch #t (lambda () (locsig-ref (make-locsig) 1)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";locsig-ref bad chan: ~A" var)))
+ (snd-display ";locsig-ref bad chan: ~A" var)))
(let ((var (catch #t (lambda () (make-locsig :revout 1)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'wrong-type-arg)))
- (snd-display #__line__ ";make-locsig bad revout: ~A" var)))
- (let ((var (catch #t (lambda () (let ((locs (make-locsig 200 :channels 2))) (locsig-ref locs -1))) (lambda args args))))
+ (snd-display ";make-locsig bad revout: ~A" var)))
+ (let ((var (catch #t (lambda () (locsig-ref (make-locsig 200 :channels 2) -1)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";locsig-ref bad chan: ~A" var)))
- (let ((var (catch #t (lambda () (let ((locs (make-locsig))) (locsig-set! locs 2 .1))) (lambda args args))))
+ (snd-display ";locsig-ref bad chan: ~A" var)))
+ (let ((var (catch #t (lambda () (locsig-set! (make-locsig) 2 .1)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";locsig-set! bad chan (2): ~A" var)))
- (let ((var (catch #t (lambda () (let ((locs (make-locsig :reverb .1))) (locsig-reverb-ref locs 2))) (lambda args args))))
+ (snd-display ";locsig-set! bad chan (2): ~A" var)))
+ (let ((var (catch #t (lambda () (locsig-reverb-ref (make-locsig :reverb .1) 2)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";locsig-reverb-ref bad reverb chan (2): ~A" var)))
- (let ((var (catch #t (lambda () (let ((locs (make-locsig :reverb .1))) (locsig-reverb-set! locs 2 .1))) (lambda args args))))
+ (snd-display ";locsig-reverb-ref bad reverb chan (2): ~A" var)))
+ (let ((var (catch #t (lambda () (locsig-reverb-set! (make-locsig :reverb .1) 2 .1)) (lambda args args))))
(if (and (pair? var)
(not (eq? (car var) 'mus-error)))
- (snd-display #__line__ ";locsig-reverb-set! bad reverb chan (2): ~A" var)))
+ (snd-display ";locsig-reverb-set! bad reverb chan (2): ~A" var)))
(let ((locs (make-locsig :channels 8 :degree 0)))
(move-locsig locs 180 1.0)
- (if (fneq (locsig-ref locs 0) 0.0) (snd-display #__line__ ";move-locsig by jump: ~A" (mus-data locs)))
+ (if (fneq (locsig-ref locs 0) 0.0) (snd-display ";move-locsig by jump: ~A" (mus-data locs)))
(if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";move-locsig by jump data: ~A" (mus-data locs)))
+ (snd-display ";move-locsig by jump data: ~A" (mus-data locs)))
(move-locsig locs 120.0 1.0)
(if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.333 0.667 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";move-locsig by jump 120 data: ~A" (mus-data locs)))
+ (snd-display ";move-locsig by jump 120 data: ~A" (mus-data locs)))
(move-locsig locs -20.0 1.0)
(if (not (vequal (mus-data locs) (float-vector 0.556 0.000 0.000 0.000 0.000 0.000 0.000 0.444)))
- (snd-display #__line__ ";move-locsig by jump -20 data: ~A" (mus-data locs))))
+ (snd-display ";move-locsig by jump -20 data: ~A" (mus-data locs))))
(let ((sf (make-sample->file "fmv4.snd" 8 mus-bshort mus-next "this is a comment"))
(sfrev (make-sample->file "fmv4.reverb" 8 mus-bshort mus-next "this is a comment")))
(let ((locs (make-locsig :channels 8 :degree 0 :distance 1.0 :reverb 0.1
:output sf :revout sfrev :type mus-interp-linear)))
(if (not (vequal (mus-data locs) (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";ws not move-locsig by jump data: ~A" (mus-data locs)))
+ (snd-display ";ws not move-locsig by jump data: ~A" (mus-data locs)))
(if (not (vequal (mus-xcoeffs locs) (float-vector 0.100 0.000 0.000 0.000 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";ws not move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
+ (snd-display ";ws not move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs 180 2.0)
- (if (fneq (locsig-ref locs 0) 0.0) (snd-display #__line__ ";ws move-locsig by jump: ~A" (mus-data locs)))
+ (if (fneq (locsig-ref locs 0) 0.0) (snd-display ";ws move-locsig by jump: ~A" (mus-data locs)))
(if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000)))
- (snd-display #__line__ ";ws move-locsig by jump data: ~A" (mus-data locs)))
+ (snd-display ";ws move-locsig by jump data: ~A" (mus-data locs)))
(if (not (vequal (mus-xcoeffs locs) (float-vector 0.000 0.000 0.000 0.000 0.071 0.000 0.000 0.000)))
- (snd-display #__line__ ";ws move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
+ (snd-display ";ws move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs 120.0 3.0)
(if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.111 0.222 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";ws move-locsig by jump 120 data: ~A" (mus-data locs)))
+ (snd-display ";ws move-locsig by jump 120 data: ~A" (mus-data locs)))
(if (not (vequal (mus-xcoeffs locs) (float-vector 0.000 0.000 0.019 0.038 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";ws move-locsig by jump 120 rev data: ~A" (mus-xcoeffs locs)))
+ (snd-display ";ws move-locsig by jump 120 rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs -20.0 4.0)
(if (not (vequal (mus-data locs) (float-vector 0.139 0.000 0.000 0.000 0.000 0.000 0.000 0.111)))
- (snd-display #__line__ ";ws move-locsig by jump -20 data: ~A" (mus-data locs)))
+ (snd-display ";ws move-locsig by jump -20 data: ~A" (mus-data locs)))
(if (not (vequal (mus-xcoeffs locs) (float-vector 0.028 0.000 0.000 0.000 0.000 0.000 0.000 0.022)))
- (snd-display #__line__ ";ws move-locsig by jump -20 rev data: ~A" (mus-xcoeffs locs))))
+ (snd-display ";ws move-locsig by jump -20 rev data: ~A" (mus-xcoeffs locs))))
(mus-close sf)
(mus-close sfrev))
@@ -18530,9 +18085,9 @@ EDITS: 2
(do ((k 0 (+ k 1)))
((= k 8))
(if (and (= k i) (fneq (samps k) 0.5))
- (snd-display #__line__ ";8 out ~A chan ~A samp ~A (0.5): ~A" (mus-header-type->string ht) i k (samps k)))
+ (snd-display ";8 out ~A chan ~A samp ~A (0.5): ~A" (mus-header-type->string ht) i k (samps k)))
(if (and (not (= i k)) (fneq (samps k) 0.0))
- (snd-display #__line__ ";8 out ~A chan ~A samp ~A (0.0): ~A" (mus-header-type->string ht) i k (samps k))))))
+ (snd-display ";8 out ~A chan ~A samp ~A (0.0): ~A" (mus-header-type->string ht) i k (samps k))))))
(close-sound ind)))
(list mus-caff mus-aifc mus-next mus-riff mus-rf64))
@@ -18542,9 +18097,9 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 100))
(locsig lc i 1.0))
- (if (fneq (locsig-reverb-ref lc 0) .1) (snd-display #__line__ ";locsig reverb ref: ~A?" (locsig-reverb-ref lc 0)))
+ (if (fneq (locsig-reverb-ref lc 0) .1) (snd-display ";locsig reverb ref: ~A?" (locsig-reverb-ref lc 0)))
(locsig-reverb-set! lc 0 .2)
- (if (fneq (locsig-reverb-ref lc 0) .2) (snd-display #__line__ ";locsig reverb set: ~A?" (locsig-reverb-ref lc 0)))
+ (if (fneq (locsig-reverb-ref lc 0) .2) (snd-display ";locsig reverb set: ~A?" (locsig-reverb-ref lc 0)))
(mus-close gen)
(mus-close rev)
(let ((v0 (make-float-vector 100))
@@ -18553,8 +18108,8 @@ EDITS: 2
(file->array "fmv4.snd" 0 0 100 v0)
(file->array "fmv4.snd" 1 0 100 v1)
(file->array "fmv4.reverb" 0 0 100 v2)
- (if (fneq (v2 0) .1) (snd-display #__line__ ";locsig reverb: ~A?" v2))
- (if (fneq (* 2 (v0 0)) (v1 0)) (snd-display #__line__ ";locsig direct: ~A ~A?" (v0 0) (v1 0)))))
+ (if (fneq (v2 0) .1) (snd-display ";locsig reverb: ~A?" v2))
+ (if (fneq (* 2 (v0 0)) (v1 0)) (snd-display ";locsig direct: ~A ~A?" (v0 0) (v1 0)))))
(let* ((gen (make-frample->file "fmv4.snd" 4 mus-bshort mus-next))
(rev (make-frample->file "fmv4.reverb" 4 mus-bshort mus-next))
@@ -18569,15 +18124,15 @@ EDITS: 2
((= i 4))
(locsig-reverb-set! lc i (* i .1))
(if (fneq (locsig-reverb-ref lc i) (* i .1))
- (snd-display #__line__ ";locsig reverb set![~A]: ~A?" i (locsig-reverb-ref lc i))))
+ (snd-display ";locsig reverb set![~A]: ~A?" i (locsig-reverb-ref lc i))))
(print-and-check lc
"locsig"
"locsig chans 4, outn: [0.083 0.167 0.000 0.000], revn: [0.000 0.100 0.200 0.300], interp: linear")
- (if (not (float-vector? (mus-data lc))) (snd-display #__line__ ";out data locsig: ~A" (mus-data lc)))
- (if (not (float-vector? (mus-xcoeffs lc))) (snd-display #__line__ ";rev data locsig: ~A" (mus-xcoeffs lc)))
+ (if (not (float-vector? (mus-data lc))) (snd-display ";out data locsig: ~A" (mus-data lc)))
+ (if (not (float-vector? (mus-xcoeffs lc))) (snd-display ";rev data locsig: ~A" (mus-xcoeffs lc)))
(let ((xcs (mus-xcoeffs lc)))
- (if (fneq (mus-xcoeff lc 0) (xcs 0)) (snd-display #__line__ ";locsig xcoeff: ~A ~A" (mus-xcoeff lc 0) (xcs 0)))
- (if (fneq (mus-xcoeff lc 1) .1) (snd-display #__line__ ";locsig xcoeff 1: ~A ~A (.1)" (mus-xcoeff lc 0) (xcs 0))))
+ (if (fneq (mus-xcoeff lc 0) (xcs 0)) (snd-display ";locsig xcoeff: ~A ~A" (mus-xcoeff lc 0) (xcs 0)))
+ (if (fneq (mus-xcoeff lc 1) .1) (snd-display ";locsig xcoeff 1: ~A ~A (.1)" (mus-xcoeff lc 0) (xcs 0))))
(mus-close gen)
(mus-close rev))
@@ -18608,55 +18163,54 @@ EDITS: 2
(print-and-check (make-locsig 0 :channels 1 :output (make-float-vector 10))
"locsig"
"locsig chans 1, outn: [1.000], interp: linear")
- (letrec ((locsig-data
- (lambda (gen)
- (let* ((chans (mus-channels gen))
- (dat (make-float-vector chans)))
- (do ((i 0 (+ i 1)))
- ((= i chans))
- (set! (dat i) (locsig-ref gen i)))
- dat))))
- (let ((gen (make-locsig -.1 :channels 8)))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
- (snd-display #__line__ ";locsig -.1(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig -359.9 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.002 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";locsig -359.9(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig -359.9 :channels 4))
- (if (not (vequal (locsig-data gen) (float-vector 0.999 0.001 0.000 0.000)))
- (snd-display #__line__ ";locsig -359.9(4): ~A" (locsig-data gen)))
- (set! gen (make-locsig -360.1 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
- (snd-display #__line__ ";locsig -360.1(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig -700 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.556 0.444 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";locsig -700(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig -700 :channels 2))
- (if (not (vequal (locsig-data gen) (float-vector 1.000 0.000)))
- (snd-display #__line__ ";locsig -700(2): ~A" (locsig-data gen)))
- (set! gen (make-locsig 20 :channels 2))
- (if (not (vequal (locsig-data gen) (float-vector 0.778 0.222)))
- (snd-display #__line__ ";locsig 20(2): ~A" (locsig-data gen)))
- (set! gen (make-locsig 123456.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
- (snd-display #__line__ ";locsig 123456(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig 336.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
- (snd-display #__line__ ";locsig 336(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig -123456.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";locsig -123456(8): ~A" (locsig-data gen)))
- (set! gen (make-locsig 24.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";locsig 24(8): ~A" (locsig-data gen)))))
+ (let* ((locsig-data
+ (lambda (gen)
+ (let* ((chans (mus-channels gen))
+ (dat (make-float-vector chans)))
+ (do ((i 0 (+ i 1)))
+ ((= i chans))
+ (set! (dat i) (locsig-ref gen i)))
+ dat)))
+ (gen (make-locsig -.1 :channels 8)))
+ (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
+ (snd-display ";locsig -.1(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -359.9 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.998 0.002 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";locsig -359.9(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -359.9 :channels 4))
+ (if (not (vequal (locsig-data gen) (float-vector 0.999 0.001 0.000 0.000)))
+ (snd-display ";locsig -359.9(4): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -360.1 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
+ (snd-display ";locsig -360.1(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -700 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.556 0.444 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";locsig -700(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -700 :channels 2))
+ (if (not (vequal (locsig-data gen) (float-vector 1.000 0.000)))
+ (snd-display ";locsig -700(2): ~A" (locsig-data gen)))
+ (set! gen (make-locsig 20 :channels 2))
+ (if (not (vequal (locsig-data gen) (float-vector 0.778 0.222)))
+ (snd-display ";locsig 20(2): ~A" (locsig-data gen)))
+ (set! gen (make-locsig 123456.0 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
+ (snd-display ";locsig 123456(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig 336.0 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
+ (snd-display ";locsig 336(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig -123456.0 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";locsig -123456(8): ~A" (locsig-data gen)))
+ (set! gen (make-locsig 24.0 :channels 8))
+ (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";locsig 24(8): ~A" (locsig-data gen))))
(for-each
(lambda (rev-chans)
(define (locsig-scalers chans degree type)
(define (xmodulo a b)
- (let ((pos (floor (/ a b))))
- (- a (* pos b))))
+ (- a (* (floor (/ a b)) b)))
(if (= chans 1)
(float-vector 1.0)
(let* ((deg (if (= chans 2)
@@ -18690,96 +18244,96 @@ EDITS: 2
(lambda (type)
;; global type def as well as local par override etc
- (if happy
- (begin
- (set! (locsig-type) type)
- (if (not (= (locsig-type) type)) (snd-display #__line__ ";locsig-type: ~A ~A" type (locsig-type)))
-
- (for-each
- (lambda (deg)
- (let ((gen (make-locsig deg :channels 1 :revout revfile :reverb .1 :distance 2.0))
- (revs (if revfile (locsig-scalers rev-chans deg type))))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";locsig ~A: ~A" deg gen))
- (if (fneq (locsig-ref gen 0) 0.5) (snd-display #__line__ ";locsig scaler[~A] ~A: ~A" type deg (locsig-ref gen 0)))
- (if revfile
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i rev-chans)))
- (if (fneq (locsig-reverb-ref gen i) (* (/ .1 (sqrt 2.0)) (revs i)))
- (begin
- (snd-display #__line__ ";mono locrev[~A] ~A at ~A: ~A ~A"
- type gen deg
- (locsig-reverb-ref gen i)
- (* (/ .1 (sqrt 2.0)) (revs i)))
- (set! happy #f)))))))
- (list 0.0 45.0 90.0 1234.0))
-
- (for-each
- (lambda (ltype)
- (for-each
- (lambda (deg)
- (let ((gen (make-locsig deg :channels 1 :type ltype)))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";locsig ~A: ~A" deg gen))
- (if (fneq (locsig-ref gen 0) 1.0) (snd-display #__line__ ";locsig[~A] scaler ~A: ~A" ltype deg (locsig-ref gen 0)))))
- (list 0.0 45.0 90.0 1234.0)))
- (list mus-interp-linear mus-interp-sinusoidal))
-
- (for-each
- (lambda (chans)
- (for-each
- (lambda (deg)
- (let ((gen (make-locsig deg :channels chans :revout revfile :reverb .1)))
- (if (not (= (mus-channels gen) chans)) (snd-display #__line__ ";multi locsig ~A: ~A" deg gen))
- (let ((scalers (locsig-scalers chans deg type))
- (revs (if revfile (locsig-scalers rev-chans deg type))))
+ (when happy
+ (set! (locsig-type) type)
+ (if (not (= (locsig-type) type)) (snd-display ";locsig-type: ~A ~A" type (locsig-type)))
+
+ (for-each
+ (lambda (deg)
+ (let ((gen (make-locsig deg :channels 1 :revout revfile :reverb .1 :distance 2.0))
+ (revs (if revfile (locsig-scalers rev-chans deg type))))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";locsig ~A: ~A" deg gen))
+ (if (fneq (locsig-ref gen 0) 0.5) (snd-display ";locsig scaler[~A] ~A: ~A" type deg (locsig-ref gen 0)))
+ (if revfile
+ (do ((sq (/ .1 (sqrt 2)))
+ (i 0 (+ i 1)))
+ ((or (not happy) (= i rev-chans)))
+ (if (fneq (locsig-reverb-ref gen i) (* sq (revs i)))
+ (begin
+ (snd-display ";mono locrev[~A] ~A at ~A: ~A ~A"
+ type gen deg
+ (locsig-reverb-ref gen i)
+ (* sq (revs i)))
+ (set! happy #f)))))))
+ (list 0.0 45.0 90.0 1234.0))
+
+ (for-each
+ (lambda (ltype)
+ (for-each
+ (lambda (deg)
+ (let ((gen (make-locsig deg :channels 1 :type ltype)))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";locsig ~A: ~A" deg gen))
+ (if (fneq (locsig-ref gen 0) 1.0) (snd-display ";locsig[~A] scaler ~A: ~A" ltype deg (locsig-ref gen 0)))))
+ (list 0.0 45.0 90.0 1234.0)))
+ (list mus-interp-linear mus-interp-sinusoidal))
+
+ (for-each
+ (lambda (chans)
+ (for-each
+ (lambda (deg)
+ (let ((gen (make-locsig deg :channels chans :revout revfile :reverb .1)))
+ (if (not (= (mus-channels gen) chans)) (snd-display ";multi locsig ~A: ~A" deg gen))
+ (let ((scalers (locsig-scalers chans deg type))
+ (revs (if revfile (locsig-scalers rev-chans deg type))))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i chans)))
+ (if (fneq (locsig-ref gen i) (scalers i))
+ (begin
+ (snd-display ";locsig[~A] ~A at ~A: ~A ~A" type gen deg (locsig-ref gen i) (scalers i))
+ (set! happy #f))))
+ (if revfile
(do ((i 0 (+ i 1)))
- ((or (not happy) (= i chans)))
- (if (fneq (locsig-ref gen i) (scalers i))
+ ((or (not happy) (= i rev-chans)))
+ (if (fneq (locsig-reverb-ref gen i) (* .1 (revs i)))
(begin
- (snd-display #__line__ ";locsig[~A] ~A at ~A: ~A ~A" type gen deg (locsig-ref gen i) (scalers i))
- (set! happy #f))))
- (if revfile
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i rev-chans)))
- (if (fneq (locsig-reverb-ref gen i) (* .1 (revs i)))
- (begin
- (snd-display #__line__ ";locrev[~A] ~A at ~A: ~A ~A"
- type gen deg
- (locsig-reverb-ref gen i)
- (* .1 (revs i)))
- (set! happy #f))))))))
- (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
- (list 2 3 4 5 8 12 16 24))
-
- (for-each
- (lambda (chans)
- (for-each
- (lambda (ltype)
- (for-each
- (lambda (deg)
- (let ((gen (make-locsig deg :channels chans :type ltype :revout revfile :reverb .1)))
- (if (not (= (mus-channels gen) chans)) (snd-display #__line__ ";stereo locsig ~A: ~A" deg gen))
- (let ((scalers (locsig-scalers chans deg ltype))
- (revs (if revfile (locsig-scalers rev-chans deg ltype))))
+ (snd-display ";locrev[~A] ~A at ~A: ~A ~A"
+ type gen deg
+ (locsig-reverb-ref gen i)
+ (* .1 (revs i)))
+ (set! happy #f))))))))
+ (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
+ (list 2 3 4 5 8 12 16 24))
+
+ (for-each
+ (lambda (chans)
+ (for-each
+ (lambda (ltype)
+ (for-each
+ (lambda (deg)
+ (let ((gen (make-locsig deg :channels chans :type ltype :revout revfile :reverb .1)))
+ (if (not (= (mus-channels gen) chans)) (snd-display ";stereo locsig ~A: ~A" deg gen))
+ (let ((scalers (locsig-scalers chans deg ltype))
+ (revs (if revfile (locsig-scalers rev-chans deg ltype))))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i chans)))
+ (if (fneq (locsig-ref gen i) (scalers i))
+ (begin
+ (snd-display ";locsig[~A] ~A at ~A: ~A ~A" ltype gen deg (locsig-ref gen i) (scalers i))
+ (set! happy #f))))
+ (if revfile
(do ((i 0 (+ i 1)))
- ((or (not happy) (= i chans)))
- (if (fneq (locsig-ref gen i) (scalers i))
- (begin
- (snd-display #__line__ ";locsig[~A] ~A at ~A: ~A ~A" ltype gen deg (locsig-ref gen i) (scalers i))
- (set! happy #f))))
- (if revfile
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i rev-chans)))
- (if (fneq (locsig-reverb-ref gen i) (* .1 (revs i)))
- (begin
- (snd-display #__line__ ";locrev[~A] ~A at ~A: ~A ~A"
- type gen deg
- (locsig-reverb-ref gen i)
- (* .1 (revs i)))
- (set! happy #f))))))))
- (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
- (list mus-interp-linear mus-interp-sinusoidal)))
- (list 2 3 4 5 8 12 16 24))
- )))
+ ((or (not happy) (= i rev-chans)))
+ (if (fneq (locsig-reverb-ref gen i) (* .1 (revs i)))
+ (begin
+ (snd-display ";locrev[~A] ~A at ~A: ~A ~A"
+ type gen deg
+ (locsig-reverb-ref gen i)
+ (* .1 (revs i)))
+ (set! happy #f))))))))
+ (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
+ (list mus-interp-linear mus-interp-sinusoidal)))
+ (list 2 3 4 5 8 12 16 24))
+ ))
(list mus-interp-linear mus-interp-sinusoidal))
(if revfile (mus-close revfile))))
(list 0 1 2 4))
@@ -18787,84 +18341,84 @@ EDITS: 2
(set! (locsig-type) mus-interp-linear)
(let* ((outp (make-float-vector (list 1 10) 0.0))
(gen (make-locsig 0.0 :output outp)))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";make-locsig->sd chans (1): ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";make-locsig->sd chans (1): ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal (outp 0) (make-float-vector 10 1.0)))
- (snd-display #__line__ ";locsig->sd chan 0: ~A" (outp 0))))
+ (snd-display ";locsig->sd chan 0: ~A" (outp 0))))
(let* ((outp (make-float-vector (list 2 10) 0.0))
(gen (make-locsig 0.0 :output outp)))
- (if (not (= (mus-channels gen) 2)) (snd-display #__line__ ";make-locsig->sd chans: ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 2)) (snd-display ";make-locsig->sd chans: ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal (outp 0) (make-float-vector 10 1.0)))
- (snd-display #__line__ ";locsig->sd chan 0: ~A" (outp 0)))
+ (snd-display ";locsig->sd chan 0: ~A" (outp 0)))
(if (not (vequal (outp 1) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";locsig->sd chan 1: ~A" (outp 1))))
+ (snd-display ";locsig->sd chan 1: ~A" (outp 1))))
(let* ((outp (make-float-vector (list 2 10) 0.0))
(gen (make-locsig 45.0 :output outp)))
- (if (not (= (mus-channels gen) 2)) (snd-display #__line__ ";make-locsig->sd chans: ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 2)) (snd-display ";make-locsig->sd chans: ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal (outp 0) (make-float-vector 10 0.5)))
- (snd-display #__line__ ";locsig->sd chan 0 (0.5): ~A (~A)" (outp 0) gen))
+ (snd-display ";locsig->sd chan 0 (0.5): ~A (~A)" (outp 0) gen))
(if (not (vequal (outp 1) (make-float-vector 10 0.5)))
- (snd-display #__line__ ";locsig->sd chan 1 (0.5): ~A" (outp 1)))
+ (snd-display ";locsig->sd chan 1 (0.5): ~A" (outp 1)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
(if (not (vequal (outp 0) (make-float-vector 10 0.75)))
- (snd-display #__line__ ";locsig->sd chan 0 (0.75) (~A): ~A" (outp 0) gen))
+ (snd-display ";locsig->sd chan 0 (0.75) (~A): ~A" (outp 0) gen))
(if (not (vequal (outp 1) (make-float-vector 10 0.75)))
- (snd-display #__line__ ";locsig->sd chan 1 (0.75): ~A" (outp 1))))
+ (snd-display ";locsig->sd chan 1 (0.75): ~A" (outp 1))))
(let* ((outp (make-float-vector 10))
(gen (make-locsig 0.0 :output outp)))
- (if (not (= (mus-channels gen) 1)) (snd-display #__line__ ";make-locsig->float-vector chans: ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 1)) (snd-display ";make-locsig->float-vector chans: ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal outp (make-float-vector 10 1.0)))
- (snd-display #__line__ ";locsig->float-vector chan 0: ~A" outp))
+ (snd-display ";locsig->float-vector chan 0: ~A" outp))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
(if (not (vequal outp (make-float-vector 10 1.5)))
- (snd-display #__line__ ";locsig->float-vector chan 0: ~A" outp)))
+ (snd-display ";locsig->float-vector chan 0: ~A" outp)))
(let* ((outp (make-float-vector 10))
(gen (make-locsig 45.0 :channels 2 :output outp)))
- (if (not (= (mus-channels gen) 2)) (snd-display #__line__ ";make-locsig->float-vector chans (2): ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 2)) (snd-display ";make-locsig->float-vector chans (2): ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal outp (make-float-vector 10 0.5)))
- (snd-display #__line__ ";locsig(2)->float-vector chan 0: ~A" outp))
+ (snd-display ";locsig(2)->float-vector chan 0: ~A" outp))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
(if (not (vequal outp (make-float-vector 10 0.75)))
- (snd-display #__line__ ";locsig(2)->float-vector chan 0: ~A" outp)))
+ (snd-display ";locsig(2)->float-vector chan 0: ~A" outp)))
(let* ((outp (make-float-vector (list 4 10) 0.0))
(gen (make-locsig 135.0 :output outp)))
- (if (not (= (mus-channels gen) 4)) (snd-display #__line__ ";make-locsig->sd chans (4): ~A" (mus-channels gen)))
+ (if (not (= (mus-channels gen) 4)) (snd-display ";make-locsig->sd chans (4): ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
(if (not (vequal (outp 0) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";locsig(4)->sd chan 0 (0.5): ~A" (outp 0)))
+ (snd-display ";locsig(4)->sd chan 0 (0.5): ~A" (outp 0)))
(if (not (vequal (outp 1) (make-float-vector 10 0.5)))
- (snd-display #__line__ ";locsig(4)->sd chan 1 (0.5) (~A): ~A" (outp 1) gen))
+ (snd-display ";locsig(4)->sd chan 1 (0.5) (~A): ~A" (outp 1) gen))
(if (not (vequal (outp 2) (make-float-vector 10 0.5)))
- (snd-display #__line__ ";locsig(4)->sd chan 2 (0.5): ~A" (outp 2)))
+ (snd-display ";locsig(4)->sd chan 2 (0.5): ~A" (outp 2)))
(if (not (vequal (outp 3) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";locsig(4)->sd chan 3 (0.5): ~A" (outp 3))))
+ (snd-display ";locsig(4)->sd chan 3 (0.5): ~A" (outp 3))))
(set! *mus-array-print-length* 8)
(let* ((outf1 (make-frample->file "fmv.snd" 1 mus-ldouble mus-next))
@@ -18956,10 +18510,10 @@ EDITS: 2
free: arrays: true, gens: false
")
- (if (not (move-sound? gen1)) (snd-display #__line__ ";move-sound?"))
- (if (equal? gen1 gen2) (snd-display #__line__ ";move-sounds are equal?"))
- (if (not (= (mus-channels gen1) 1)) (snd-display #__line__ ";mus-channels move-sound (1): ~A" (mus-channels gen1)))
- (if (not (= (mus-channels gen2) 4)) (snd-display #__line__ ";mus-channels move-sound (4): ~A" (mus-channels gen2)))
+ (if (not (move-sound? gen1)) (snd-display ";move-sound?"))
+ (if (equal? gen1 gen2) (snd-display ";move-sounds are equal?"))
+ (if (not (= (mus-channels gen1) 1)) (snd-display ";mus-channels move-sound (1): ~A" (mus-channels gen1)))
+ (if (not (= (mus-channels gen2) 4)) (snd-display ";mus-channels move-sound (4): ~A" (mus-channels gen2)))
(mus-reset gen1) ; a no-op
(let ((v (make-float-vector 10 0.0)))
@@ -18969,7 +18523,7 @@ EDITS: 2
(gen2 i 0.25)
(move-sound gen3 i 0.125))))
(if (not (vequal v (make-float-vector 10 0.875)))
- (snd-display #__line__ ";move-sound output: ~A" v)))
+ (snd-display ";move-sound output: ~A" v)))
(let ((var (catch #t (lambda () (make-move-sound (list 0 1000 1 0 (make-oscil 32) (make-env '(0 0 1 1) :length 1001)
(make-env '(0 0 1 1) :length 1001) (vector (make-delay 32))
@@ -18977,20 +18531,20 @@ EDITS: 2
outf1))
(lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-move-sound bad doppler delay: ~A" var)))
+ (snd-display ";make-move-sound bad doppler delay: ~A" var)))
(let ((var (catch #t (lambda () (make-move-sound (list 0 1000 1 0 (make-oscil 32) (make-env '(0 0 1 1) :length 1001)
(make-env '(0 0 1 1) :length 1001) (vector (make-delay 32)))
outf1))
(lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-move-sound truncated list: ~A" var)))
+ (snd-display ";make-move-sound truncated list: ~A" var)))
(let ((var (catch #t (lambda () (make-move-sound (list 0 1000 1 0 (make-delay 32) (make-env '(0 0 1 1) :length 1001)
#f (vector #f)
(vector (make-env '(0 0 1 1) :length 1001)) #f #f)
outf1))
(lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
- (snd-display #__line__ ";make-move-sound no out map: ~A" var)))
+ (snd-display ";make-move-sound no out map: ~A" var)))
(mus-close outf1)
@@ -19020,9 +18574,9 @@ EDITS: 2
(fneq (vo i) 0.0))
(set! start i)))
(if (not (= start 64))
- (snd-display #__line__ ";move-sound float-vector output start: ~A" start))
+ (snd-display ";move-sound float-vector output start: ~A" start))
(if (fneq (float-vector-peak vo) 0.484)
- (snd-display #__line__ ";move-sound float-vector output: ~A" (float-vector-peak vo))))
+ (snd-display ";move-sound float-vector output: ~A" (float-vector-peak vo))))
(let* ((vo (make-float-vector (list 1 1000) 0.0))
(gen1 (make-move-sound (list 0 1000 1 0
@@ -19042,9 +18596,9 @@ EDITS: 2
(fneq (vo 0 i) 0.0))
(set! start i)))
(if (not (= start 64))
- (snd-display #__line__ ";move-sound sd output start: ~A" start))
+ (snd-display ";move-sound sd output start: ~A" start))
(if (fneq (maxamp vo) 0.484)
- (snd-display #__line__ ";move-sound sd output: ~A" (maxamp vo))))
+ (snd-display ";move-sound sd output: ~A" (maxamp vo))))
(let* ((vo (make-float-vector 1000))
(gen1 (make-move-sound (list 0 1000 1 0
@@ -19064,9 +18618,9 @@ EDITS: 2
(> (abs (vo i)) 0.001))
(set! start i)))
(if (not (= start 64))
- (snd-display #__line__ ";move-sound opt float-vector output start: ~A" start))
+ (snd-display ";move-sound opt float-vector output start: ~A" start))
(if (fneq (float-vector-peak vo) 0.484)
- (snd-display #__line__ ";move-sound opt float-vector output: ~A" (float-vector-peak vo))))
+ (snd-display ";move-sound opt float-vector output: ~A" (float-vector-peak vo))))
(let* ((vo (make-float-vector (list 1 1000) 0.0))
(gen1 (make-move-sound (list 0 1000 1 0
@@ -19086,20 +18640,18 @@ EDITS: 2
(> (abs (vo 0 i)) 0.001))
(set! start i)))
(if (not (= start 64))
- (snd-display #__line__ ";move-sound opt sd output start: ~A" start))
+ (snd-display ";move-sound opt sd output start: ~A" start))
(if (fneq (maxamp vo) 0.484)
- (snd-display #__line__ ";move-sound opt sd output: ~A" (maxamp vo))))
+ (snd-display ";move-sound opt sd output: ~A" (maxamp vo))))
(let ((var (catch #t (lambda () (make-src :width -1)) (lambda args args))))
(if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-src bad width: ~A" var)))
+ (snd-display ";make-src bad width: ~A" var)))
(let ((s1 (make-src (lambda (y) 1.0) 2.0)))
- (src s1 25.0) ; try to tickle segfault
- (src s1 25.0)
- (src s1 125.0)
- (src s1 -25.0)
- (src s1 -125.0))
+ (for-each (lambda (arg)
+ (src s1 arg))
+ '(25.0 25.0 125.0 -25.0 -125.0)))
(do ((i 0 (+ i 1)))
((= i 10))
(make-src (lambda (y) 1.0) 1.5 :width (+ 5 (* i 10))))
@@ -19117,7 +18669,7 @@ EDITS: 2
(let ((old-val (v0 i))
(new-val (src gen 0.0)))
(if (fneq old-val new-val)
- (snd-display #__line__ ";reset src ~A ~A ~A" i old-val new-val))))))
+ (snd-display ";reset src ~A ~A ~A" i old-val new-val))))))
(let ()
(define (so1 s p)
@@ -19136,82 +18688,82 @@ EDITS: 2
(let ((x2 (src s2 ex2))
(x3 (so1 s3 e3)))
(if (not (= x1 x2 x3))
- (format #t "~D ~A ~A ~A~%" i x1 x2 x3)))))))
-
- (let ((gen (make-granulate :expansion 2.0 :input (make-readin "oboe.snd" 0 4000 1 2048)))
- (v0 (make-float-vector 1000))
- (v1 (make-float-vector 1000))
- (rd1b (make-readin :file "oboe.snd" :channel 0 :start 4000 :direction 1 :size *clm-file-buffer-size*)))
- (let ((gen1 (make-granulate :expansion 2.0
- :input (lambda (dir) (readin rd1b)))))
- (print-and-check gen
- "granulate"
- "granulate expansion: 2.000 (551/1102), scaler: 0.600, length: 0.150 secs (3308 samps), ramp: 0.060")
- (do ((i 0 (+ i 1)))
- ((= i 1000))
- (set! (v0 i) (granulate gen)))
- (fill-float-vector v1 (if (granulate? gen1) (granulate gen1) -1.0))
- (let ((worst (abs (- (float-vector-peak v0) (float-vector-peak v1)))))
- (if (> worst .01) (snd-display #__line__ ";run granulate: ~A" worst)))
- (let ((genx gen1))
- (if (not (equal? genx gen1))
- (snd-display #__line__ ";granulate equal? ~A ~A ~A" genx gen1 (equal? genx gen1))))
- (if (equal? gen gen1) (snd-display #__line__ ";granulate equal? ~A ~A" gen gen1))
- (if (= (float-vector-peak v0) 0.0) (snd-display #__line__ ";granulate output peak: ~F?" (float-vector-peak v0)))
- (if (not (granulate? gen)) (snd-display #__line__ ";~A not granulate?" gen))
- (if (fneq (mus-increment gen) 2.0) (snd-display #__line__ ";granulate increment: ~F?" (mus-increment gen)))
- (if (fneq (mus-scaler gen) 0.6) (snd-display #__line__ ";granulate scaler: ~F?" (mus-scaler gen)))
- (if (ffneq (mus-frequency gen) 0.05) (snd-display #__line__ ";granulate frequency: ~F?" (mus-frequency gen)))
- (if (not (= (mus-ramp gen) 1323)) (snd-display #__line__ ";granulate ramp: ~F?" (mus-ramp gen)))
- (if (not (= (mus-length gen) 3308)) (snd-display #__line__ ";granulate length: ~A?" (mus-length gen)))
- (if (not (= (mus-hop gen) 1102)) (snd-display #__line__ ";granulate hop: ~A?" (mus-hop gen)))
- (set! (mus-hop gen) 1000) (if (not (= (mus-hop gen) 1000)) (snd-display #__line__ ";granulate set-hop: ~A?" (mus-hop gen)))
- (set! (mus-ramp gen) 1000) (if (not (= (mus-ramp gen) 1000)) (snd-display #__line__ ";granulate set-ramp: ~A?" (mus-ramp gen)))
- (set! (mus-length gen) 3000) (if (not (= (mus-length gen) 3000)) (snd-display #__line__ ";granulate set-length: ~A?" (mus-length gen)))
- (set! (mus-increment gen) 3.0)
- (if (> (abs (- (mus-increment gen) 3.0)) .01) (snd-display #__line__ ";granulate set-increment: ~F?" (mus-increment gen)))
- (set! (mus-increment gen) 0.0) ; should be a no-op
- (if (> (abs (- (mus-increment gen) 3.0)) .01) (snd-display #__line__ ";granulate set-increment 0.0: ~F?" (mus-increment gen)))
- (set! (mus-location gen) 1)
- (if (not (= (mus-location gen) 1)) (snd-display #__line__ ";mus-location grn: ~A" (mus-location gen)))
- (set! (mus-frequency gen) .1)
- (if (fneq (mus-frequency gen) .1) (snd-display #__line__ ";set granulate freq: ~A" (mus-frequency gen))))
- (let ((var (catch #t (lambda () (make-granulate :hop 35.0 :length 35.0)) (lambda args args))))
- (if (not (eq? (car var) 'out-of-range))
- (snd-display #__line__ ";make-granulate bad sizes: ~A" var))))
+ (format () "~D ~A ~A ~A~%" i x1 x2 x3)))))))
+
+ (let ((gen (make-granulate :expansion 2.0 :input (make-readin "oboe.snd" 0 4000 1 2048))))
+ (print-and-check gen
+ "granulate"
+ "granulate expansion: 2.000 (551/1102), scaler: 0.600, length: 0.150 secs (3308 samps), ramp: 0.060")
+ (let ((rd1b (make-readin :file "oboe.snd" :channel 0 :start 4000 :direction 1 :size *clm-file-buffer-size*))
+ (v0 (make-float-vector 1000)))
+ (let ((gen1 (make-granulate :expansion 2.0
+ :input (lambda (dir) (readin rd1b)))))
+ (do ((i 0 (+ i 1)))
+ ((= i 1000))
+ (set! (v0 i) (granulate gen)))
+ (let ((v1 (make-float-vector 1000)))
+ (fill-float-vector v1 (if (granulate? gen1) (granulate gen1) -1.0))
+ (let ((worst (abs (- (float-vector-peak v0) (float-vector-peak v1)))))
+ (if (> worst .01) (snd-display ";run granulate: ~A" worst))))
+ (let ((genx gen1))
+ (if (not (equal? genx gen1))
+ (snd-display ";granulate equal? ~A ~A ~A" genx gen1 (equal? genx gen1))))
+ (if (equal? gen gen1) (snd-display ";granulate equal? ~A ~A" gen gen1)))
+ (if (= (float-vector-peak v0) 0.0) (snd-display ";granulate output peak: ~F?" (float-vector-peak v0))))
+ (if (not (granulate? gen)) (snd-display ";~A not granulate?" gen))
+ (if (fneq (mus-increment gen) 2.0) (snd-display ";granulate increment: ~F?" (mus-increment gen)))
+ (if (fneq (mus-scaler gen) 0.6) (snd-display ";granulate scaler: ~F?" (mus-scaler gen)))
+ (if (ffneq (mus-frequency gen) 0.05) (snd-display ";granulate frequency: ~F?" (mus-frequency gen)))
+ (if (not (= (mus-ramp gen) 1323)) (snd-display ";granulate ramp: ~F?" (mus-ramp gen)))
+ (if (not (= (mus-length gen) 3308)) (snd-display ";granulate length: ~A?" (mus-length gen)))
+ (if (not (= (mus-hop gen) 1102)) (snd-display ";granulate hop: ~A?" (mus-hop gen)))
+ (set! (mus-hop gen) 1000) (if (not (= (mus-hop gen) 1000)) (snd-display ";granulate set-hop: ~A?" (mus-hop gen)))
+ (set! (mus-ramp gen) 1000) (if (not (= (mus-ramp gen) 1000)) (snd-display ";granulate set-ramp: ~A?" (mus-ramp gen)))
+ (set! (mus-length gen) 3000) (if (not (= (mus-length gen) 3000)) (snd-display ";granulate set-length: ~A?" (mus-length gen)))
+ (set! (mus-increment gen) 3.0)
+ (if (> (abs (- (mus-increment gen) 3.0)) .01) (snd-display ";granulate set-increment: ~F?" (mus-increment gen)))
+ (set! (mus-increment gen) 0.0) ; should be a no-op
+ (if (> (abs (- (mus-increment gen) 3.0)) .01) (snd-display ";granulate set-increment 0.0: ~F?" (mus-increment gen)))
+ (set! (mus-location gen) 1)
+ (if (not (= (mus-location gen) 1)) (snd-display ";mus-location grn: ~A" (mus-location gen)))
+ (set! (mus-frequency gen) .1)
+ (if (fneq (mus-frequency gen) .1) (snd-display ";set granulate freq: ~A" (mus-frequency gen))))
+ (let ((var (catch #t (lambda () (make-granulate :hop 35.0 :length 35.0)) (lambda args args))))
+ (if (not (eq? (car var) 'out-of-range))
+ (snd-display ";make-granulate bad sizes: ~A" var)))
(let ((ind (new-sound :size 10)))
(set! (sample 2) .1)
(set! (sample 6) -.5)
- (let ((rd (make-sampler)))
- (let ((vals (map values rd)))
- (if (not (morally-equal? vals '(0.0 0.0 0.1 0.0 0.0 0.0 -0.5 0.0 0.0 0.0)))
- (snd-display #__line__ ";rd new: ~A" vals))))
+ (let* ((rd (make-sampler))
+ (vals (map values rd)))
+ (if (not (morally-equal? vals '(0.0 0.0 0.1 0.0 0.0 0.0 -0.5 0.0 0.0 0.0)))
+ (snd-display ";rd new: ~A" vals)))
(close-sound ind))
- (let ((ind (open-sound "oboe.snd"))
- (mx (maxamp)))
- (let ((rd (make-sampler 0)))
- (if (not (= (length rd) 50828))
- (snd-display #__line__ ";sampler (oboe) length: ~A" (length rd)))
- (let ((grn (make-granulate :expansion 2.0
- :input (lambda (dir) (read-sample rd))
- :edit (lambda (g)
- (float-vector-scale! (mus-data g) 2.0)
- 0))))
- (map-channel (lambda (y) (granulate grn)))
- (if (or (< (/ (maxamp) mx) 1.4) (> (/ mx (maxamp)) 2.5))
- (snd-display #__line__ ";gran edit 2* (0): ~A ~A" mx (maxamp)))
- (undo)))
- (let ((rd (make-sampler 0)))
- (let ((grn (make-granulate :expansion 2.0
- :input (lambda (dir) (read-sample rd))
- :edit (lambda (g)
- (float-vector-scale! (mus-data g) 4.0)
- 0))))
- (map-channel (lambda (y) (granulate grn)))
- (if (or (< (/ (maxamp) mx) 3.0) (> (/ mx (maxamp)) 6.0))
- (snd-display #__line__ ";gran edit 4* (0): ~A ~A" mx (maxamp)))
- (revert-sound ind)))
+ (let* ((ind (open-sound "oboe.snd"))
+ (mx (maxamp))
+ (rd (make-sampler 0)))
+ (if (not (= (length rd) 50828))
+ (snd-display ";sampler (oboe) length: ~A" (length rd)))
+ (let ((grn (make-granulate :expansion 2.0
+ :input (lambda (dir) (read-sample rd))
+ :edit (lambda (g)
+ (float-vector-scale! (mus-data g) 2.0)
+ 0))))
+ (map-channel (lambda (y) (granulate grn)))
+ (if (or (< (/ (maxamp) mx) 1.4) (> (/ mx (maxamp)) 2.5))
+ (snd-display ";gran edit 2* (0): ~A ~A" mx (maxamp)))
+ (undo))
+ (let* ((rd (make-sampler 0))
+ (grn (make-granulate :expansion 2.0
+ :input (lambda (dir) (read-sample rd))
+ :edit (lambda (g)
+ (float-vector-scale! (mus-data g) 4.0)
+ 0))))
+ (map-channel (lambda (y) (granulate grn)))
+ (if (or (< (/ (maxamp) mx) 3.0) (> (/ mx (maxamp)) 6.0))
+ (snd-display ";gran edit 4* (0): ~A ~A" mx (maxamp)))
+ (revert-sound ind))
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0
:input (lambda (dir) (read-sample rd))
@@ -19220,7 +18772,7 @@ EDITS: 2
0))))
(map-channel (lambda (y) (granulate grn)))
(if (or (< (/ (maxamp) mx) 1.4) (> (/ mx (maxamp)) 2.5))
- (snd-display #__line__ ";gran edit 2* (1): ~A ~A" mx (maxamp)))
+ (snd-display ";gran edit 2* (1): ~A ~A" mx (maxamp)))
(undo)
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0
@@ -19230,7 +18782,7 @@ EDITS: 2
:input (lambda (dir) (read-sample rd)))))
(map-channel (lambda (y) (granulate grn)))
(if (or (< (/ (maxamp) mx) 2.9) (> (/ mx (maxamp)) 6.0))
- (snd-display #__line__ ";gran edit 4* (1): ~A ~A" mx (maxamp)))
+ (snd-display ";gran edit 4* (1): ~A ~A" mx (maxamp)))
(revert-sound ind)))
(let ((grn (make-granulate :expansion 2.0
:input (make-sampler 0)
@@ -19239,7 +18791,7 @@ EDITS: 2
0))))
(map-channel (lambda (y) (granulate grn)))
(if (or (< (/ (maxamp) mx) 1.4) (> (/ mx (maxamp)) 2.5))
- (snd-display #__line__ ";gran edit 2* (2): ~A ~A" mx (maxamp)))
+ (snd-display ";gran edit 2* (2): ~A ~A" mx (maxamp)))
(undo)
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0
@@ -19247,7 +18799,7 @@ EDITS: 2
:edit (lambda (g) (float-vector-scale! (mus-data g) 4.0) 0))))
(map-channel (lambda (y) (granulate grn)))
(if (or (< (/ (maxamp) mx) 3.0) (> (/ mx (maxamp)) 6.0))
- (snd-display #__line__ ";gran edit 4* (2): ~A ~A" mx (maxamp)))))
+ (snd-display ";gran edit 4* (2): ~A ~A" mx (maxamp)))))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
@@ -19255,187 +18807,187 @@ EDITS: 2
(grn (make-granulate :expansion 2.0 :length .01 :hop .05 :input (lambda (dir) (next-sample rd)))))
(map-channel (lambda (y) (granulate grn)))
(let ((mx (maxamp)))
- (if (> mx .2) (snd-display #__line__ ";trouble in granulate len .01 hop .05: ~A" mx))
+ (if (> mx .2) (snd-display ";trouble in granulate len .01 hop .05: ~A" mx))
(undo)))
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0 :length .04 :hop .05 :input (lambda (dir) (next-sample rd)))))
(map-channel (lambda (y) (granulate grn)))
(let ((mx (maxamp)))
- (if (> mx .2) (snd-display #__line__ ";trouble in granulate len .04 hop .05: ~A" mx))
+ (if (> mx .2) (snd-display ";trouble in granulate len .04 hop .05: ~A" mx))
(undo)))
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0 :length .01 :hop .25 :input (lambda (dir) (next-sample rd)))))
(map-channel (lambda (y) (granulate grn)))
(let ((mx (maxamp)))
- (if (> mx .2) (snd-display #__line__ ";trouble in granulate len .01 hop .25: ~A" mx))
+ (if (> mx .2) (snd-display ";trouble in granulate len .01 hop .25: ~A" mx))
(undo)))
(let* ((rd (make-sampler 0))
(grn (make-granulate :expansion 2.0 :length .4 :hop .5 :input (lambda (dir) (next-sample rd)))))
(map-channel (lambda (y) (granulate grn)))
(let ((mx (maxamp)))
- (if (> mx .2) (snd-display #__line__ ";trouble in granulate len .4 hop .5: ~A" mx))
+ (if (> mx .2) (snd-display ";trouble in granulate len .4 hop .5: ~A" mx))
(undo)))
(close-sound ind))
(let ((ind (new-sound :size 1000)))
(let ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";gran 0 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
- 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060
- 0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 0 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";gran 0 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
+ 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 0 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 0 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .002 :length .001 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";gran 1 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
- 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 1 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 40 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060
- 0.060 0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 1 data 40: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";gran 1 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
+ 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 1 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 40 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000)))
+ (snd-display ";gran 1 data 40: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .002 :length .001 :ramp .1 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";gran 2 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 2 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 40 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 2 data 40: ~A" (channel->float-vector 40 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";gran 2 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 2 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 40 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000)))
+ (snd-display ";gran 2 data 40: ~A" (channel->float-vector 40 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .002 :length .001 :ramp .5 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";gran 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
- 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 3 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.000 0.000 0.000 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
- 0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 3 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";gran 3 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
+ 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 3 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
+ 0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 3 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .001 :ramp .5 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";gran 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
- 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038)))
- (snd-display #__line__ ";gran 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
- 0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022)))
- (snd-display #__line__ ";gran 4 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";gran 4 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
+ 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038)))
+ (snd-display ";gran 4 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
+ 0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022)))
+ (snd-display ";gran 4 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .001 :ramp .25 :scaler 1.0 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";gran 5 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
- 0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100)))
- (snd-display #__line__ ";gran 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080)))
- (snd-display #__line__ ";gran 5 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";gran 5 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
+ 0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100)))
+ (snd-display ";gran 5 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080)))
+ (snd-display ";gran 5 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .002 :ramp .5 :scaler 1.0 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.105) (snd-display #__line__ ";gran 6 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.005 0.009 0.014 0.018 0.023 0.027 0.032 0.036 0.041 0.045 0.050 0.055 0.059 0.064 0.068
- 0.073 0.077 0.082 0.086 0.091 0.095 0.100 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
- (snd-display #__line__ ";gran 6 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105
- 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
- (snd-display #__line__ ";gran 6 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.105) (snd-display ";gran 6 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.005 0.009 0.014 0.018 0.023 0.027 0.032 0.036 0.041 0.045 0.050 0.055 0.059 0.064 0.068
+ 0.073 0.077 0.082 0.086 0.091 0.095 0.100 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
+ (snd-display ";gran 6 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105
+ 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
+ (snd-display ";gran 6 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .005 :ramp .5 :scaler 1.0 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.264) (snd-display #__line__ ";gran 7 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
- 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
- (snd-display #__line__ ";gran 7 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
- (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
- 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
- (snd-display #__line__ ";gran 7 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.264) (snd-display ";gran 7 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
+ 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
+ (snd-display ";gran 7 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 85 30)
+ (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
+ 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
+ (snd-display ";gran 7 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .01 :length .001 :ramp .5 :scaler 1.0 :expansion 2.0 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";gran 8 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
- 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 8 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 220 30)
- (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
- 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 8 data 220: ~A" (channel->float-vector 220 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";gran 8 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
+ 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 8 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 220 30)
+ (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
+ 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 8 data 220: ~A" (channel->float-vector 220 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .01 :length .001 :ramp .5 :scaler 1.0 :expansion 0.5 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";gran 9 max: ~A" mx))) ; same as 8 because expansion hits the input counter
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
- 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 9 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 220 30)
- (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
- 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 9 data 220: ~A" (channel->float-vector 220 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";gran 9 max: ~A" mx))) ; same as 8 because expansion hits the input counter
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
+ 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 9 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 220 30)
+ (float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
+ 0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 9 data 220: ~A" (channel->float-vector 220 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .005 :ramp .5 :scaler 1.0
:input (lambda (dir) .1)
:edit (lambda (g)
(float-vector-scale! (mus-data g) 2.0)
0))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx (* 2 0.264)) (snd-display #__line__ ";gran 10 max: ~A" mx)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
- (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
- 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
- (snd-display #__line__ ";gran 10 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
- (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
- 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
- (snd-display #__line__ ";gran 10 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
-
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx (* 2 0.264)) (snd-display ";gran 10 max: ~A" mx)))
+ (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
+ (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
+ 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
+ (snd-display ";gran 10 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
+ (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
+ 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
+ (snd-display ";gran 10 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
+
(let ((forward #t)
(ctr -0.5)
(incr .001))
@@ -19444,166 +18996,165 @@ EDITS: 2
(f2 (lambda (g)
(if forward ; no change to data
(set! forward #f)
- (let ((len (mus-length g)))
- (let ((grain (make-shared-vector (mus-data g) (list len))))
- (set! forward #t)
- (reverse! grain)))) ; should get ramps going up then down across overall rising ramp
+ (let* ((len (mus-length g))
+ (grain (make-shared-vector (mus-data g) (list len))))
+ (set! forward #t)
+ (set! grain (reverse! grain)))) ; should get ramps going up then down across overall rising ramp
(mus-length g))))
(let ((gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0 :input f1 :edit f2)))
- (map-channel (lambda (y) (granulate gen)))))
- (let ((mx (maxamp)))
- (if (> mx 0.6) (snd-display #__line__ ";gran 11 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
- -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
- (snd-display #__line__ ";gran 11 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
- -0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
- (snd-display #__line__ ";gran 11 data 100: ~A" (channel->float-vector 100 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))))
+ (let ((mx (maxamp)))
+ (if (> mx 0.6) (snd-display ";gran 11 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
+ -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
+ (snd-display ";gran 11 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 100 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
+ -0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
+ (snd-display ";gran 11 data 100: ~A" (channel->float-vector 100 30)))
+ (undo)
- (let* ((ctr -0.5)
- (incr .001)
- (gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0
- :input (lambda (dir) (set! ctr (+ ctr incr))))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (> mx 0.6) (snd-display #__line__ ";gran 12 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
- -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
- (snd-display #__line__ ";gran 12 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.389 -0.388 -0.387 -0.386 -0.385
- -0.384 -0.383 -0.382 -0.381 -0.380 -0.379 -0.378 -0.377 -0.376 -0.375 -0.374 -0.373 -0.372 -0.371 -0.370)))
- (snd-display #__line__ ";gran 12 data 100: ~A" (channel->float-vector 100 30)))
- (undo))
+ (let ((ctr -0.5)
+ (incr .001))
+ (let ((gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0
+ :input (lambda (dir) (set! ctr (+ ctr incr))))))
+ (map-channel (lambda (y) (granulate gen)))))
+ (let ((mx (maxamp)))
+ (if (> mx 0.6) (snd-display ";gran 12 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
+ -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
+ (snd-display ";gran 12 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 100 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.389 -0.388 -0.387 -0.386 -0.385
+ -0.384 -0.383 -0.382 -0.381 -0.380 -0.379 -0.378 -0.377 -0.376 -0.375 -0.374 -0.373 -0.372 -0.371 -0.370)))
+ (snd-display ";gran 12 data 100: ~A" (channel->float-vector 100 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .001 :length .005 :ramp .5 :scaler 1.0
:input (lambda (dir) .1)
:edit (lambda (g)
(float-vector-scale! (mus-data g) 2.0)
0))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (> mx .6) (snd-display #__line__ ";gran 13 max: ~A" mx)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
- (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
- 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
- (snd-display #__line__ ";gran 13 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
- (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
- 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
- (snd-display #__line__ ";gran 13 data 85: ~A" (channel->float-vector 85 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (> mx .6) (snd-display ";gran 13 max: ~A" mx)))
+ (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
+ (float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
+ 0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
+ (snd-display ";gran 13 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
+ (float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
+ 0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
+ (snd-display ";gran 13 data 85: ~A" (channel->float-vector 85 30)))
+ (undo)
- (let* ((forward #t)
- (ctr -0.5)
- (incr .001)
- (gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0
- :input (lambda (dir) (set! ctr (+ ctr incr)))
- :edit (lambda (g)
- (if forward
- (set! forward #f)
- (let ((len (mus-length g)))
- (let ((grain (make-shared-vector (mus-data g) (list len))))
- (set! forward #t)
- (reverse! grain))))
- (mus-length g)))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (> mx 0.6) (snd-display #__line__ ";gran 14 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
- -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
- (snd-display #__line__ ";gran 14 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
- (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
- -0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
- (snd-display #__line__ ";gran 14 data 100: ~A" (channel->float-vector 100 30)))
- (undo))
+ (let ((forward #t)
+ (ctr -0.5)
+ (incr .001))
+ (let ((gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0
+ :input (lambda (dir) (set! ctr (+ ctr incr)))
+ :edit (lambda (g)
+ (if forward
+ (set! forward #f)
+ (let* ((len (mus-length g))
+ (grain (make-shared-vector (mus-data g) (list len))))
+ (set! forward #t)
+ (reverse! grain)))
+ (mus-length g)))))
+ (map-channel (lambda (y) (granulate gen)))))
+ (let ((mx (maxamp)))
+ (if (> mx 0.6) (snd-display ";gran 14 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
+ -0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
+ (snd-display ";gran 14 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 100 30)
+ (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
+ -0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
+ (snd-display ";gran 14 data 100: ~A" (channel->float-vector 100 30)))
+ (undo)
- (let* ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1)))
- (e (make-env '(0 0 1 .5) :length 1001))
- (base-ramp-len (mus-length gen)))
- (map-channel
- (lambda (y)
- (let ((result (granulate gen)))
- (set! (mus-ramp gen) (round (* base-ramp-len (env e))))
- result)))
+ (let ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1)))
+ (e (make-env '(0 0 1 .5) :length 1001)))
+ (let ((base-ramp-len (mus-length gen)))
+ (map-channel
+ (lambda (y)
+ (let ((result (granulate gen)))
+ (set! (mus-ramp gen) (round (* base-ramp-len (env e))))
+ result))))
(let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";granf 0 max: ~A" mx)))
+ (if (fneq mx 0.06) (snd-display ";granf 0 max: ~A" mx)))
(if (> (abs (- (mus-ramp gen) (* .5 (mus-length gen)))) 1)
- (snd-display #__line__ ";granf 0 ramp: ~A ~A" (mus-ramp gen) (mus-length gen)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.000 0.012 0.024 0.036 0.048 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.048 0.036 0.024 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 0 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 880 30)
- (float-vector 0.000 0.006 0.012 0.018 0.024 0.030 0.036 0.042 0.048 0.054 0.060 0.060 0.060 0.060
- 0.054 0.048 0.042 0.036 0.030 0.024 0.018 0.012 0.006 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 0 data 880: ~A" (channel->float-vector 880 30)))
- (undo))
-
+ (snd-display ";granf 0 ramp: ~A ~A" (mus-ramp gen) (mus-length gen))))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 0 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.000 0.012 0.024 0.036 0.048 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.048 0.036 0.024 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 0 data 440: ~A" (channel->float-vector 440 30)))
+ (if (not (vequal (channel->float-vector 880 30)
+ (float-vector 0.000 0.006 0.012 0.018 0.024 0.030 0.036 0.042 0.048 0.054 0.060 0.060 0.060 0.060
+ 0.054 0.048 0.042 0.036 0.030 0.024 0.018 0.012 0.006 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 0 data 880: ~A" (channel->float-vector 880 30)))
+ (undo)
- (let* ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1)))
- (e (make-env '(0 1 1 .25) :length 1001))
- (base-hop-len (mus-hop gen)))
- (map-channel
- (lambda (y)
- (let ((result (granulate gen)))
- (set! (mus-hop gen) (round (* base-hop-len (env e))))
- result)))
+ (let ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1))))
+ (let ((base-hop-len (mus-hop gen))
+ (e (make-env '(0 1 1 .25) :length 1001)))
+ (map-channel
+ (lambda (y)
+ (let ((result (granulate gen)))
+ (set! (mus-hop gen) (round (* base-hop-len (env e))))
+ result))))
(let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";granf 1 max: ~A" mx)))
+ (if (fneq mx 0.06) (snd-display ";granf 1 max: ~A" mx)))
(if (> (abs (- (mus-hop gen) (* .001 *clm-srate*))) 1)
- (snd-display #__line__ ";granf 1 hop: ~A ~A, ~A ~A" (mus-hop gen) (abs (- (mus-hop gen) (* .001 (srate)))) (srate) *clm-srate*))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 1 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 900 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
- 0.000 0.000 0.000 0.000 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
- (snd-display #__line__ ";granf 1 data 900: ~A" (channel->float-vector 900 30)))
- (undo))
+ (snd-display ";granf 1 hop: ~A ~A, ~A ~A" (mus-hop gen) (abs (- (mus-hop gen) (* .001 (srate)))) (srate) *clm-srate*)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 1 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 900 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
+ (snd-display ";granf 1 data 900: ~A" (channel->float-vector 900 30)))
+ (undo)
- (let* ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1)))
- (e (make-env '(0 1 1 .25) :length 1001))
- (base-freq (mus-frequency gen)))
- (map-channel
- (lambda (y)
- (let ((result (granulate gen)))
- (set! (mus-frequency gen) (* base-freq (env e)))
- result)))
+ (let ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :input (lambda (dir) .1))))
+ (let ((base-freq (mus-frequency gen))
+ (e (make-env '(0 1 1 .25) :length 1001)))
+ (map-channel
+ (lambda (y)
+ (let ((result (granulate gen)))
+ (set! (mus-frequency gen) (* base-freq (env e)))
+ result))))
(let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";granf 2 max: ~A" mx)))
+ (if (fneq mx 0.06) (snd-display ";granf 2 max: ~A" mx)))
(if (> (abs (- (mus-hop gen) (* .001 *clm-srate*))) 1)
- (snd-display #__line__ ";granf 2 hop: ~A" (mus-hop gen)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 2 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 900 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
- (snd-display #__line__ ";granf 2 data 900: ~A" (channel->float-vector 900 30)))
- (undo))
+ (snd-display ";granf 2 hop: ~A" (mus-hop gen))))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 2 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 900 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
+ (snd-display ";granf 2 data 900: ~A" (channel->float-vector 900 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .002 :length .001 :ramp 0.0 :scaler 1.0 :input (lambda (dir) .1))))
- (map-channel (lambda (y) (granulate gen)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";granf 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";gran 3 data: ~A" (channel->float-vector 0 30)))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";granf 3 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";gran 3 data: ~A" (channel->float-vector 0 30)))
+ (undo)
(let ((gen (make-granulate :jitter 0.0 :hop .004 :length .001 :ramp 0.0 :scaler 1.0 :input (lambda (dir) .1)))
(e (make-env '(0 1 1 0.0) :length 1001)))
@@ -19611,70 +19162,70 @@ EDITS: 2
(lambda (y)
(let ((result (granulate gen)))
(set! (mus-scaler gen) (env e))
- result)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.1) (snd-display #__line__ ";granf 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
- 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056
- 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 4 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
- (float-vector 0.012 0.012 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 4 data 900: ~A" (channel->float-vector 900 30)))
- (undo))
+ result))))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.1) (snd-display ";granf 4 max: ~A" mx)))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
+ 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 4 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056
+ 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 4 data 440: ~A" (channel->float-vector 440 30)))
+ (if (not (vequal (channel->float-vector 900 30)
+ (float-vector 0.012 0.012 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 4 data 900: ~A" (channel->float-vector 900 30)))
+ (undo)
- (let* ((gen (make-granulate :jitter 0.0 :hop .006 :length .001 :ramp 0.0 :max-size 2200 :input (lambda (dir) .1)))
- (e (make-env '(0 1 1 5) :length 1001))
- (base-len (mus-length gen)))
- (map-channel
- (lambda (y)
- (let ((result (granulate gen)))
- (set! (mus-length gen) (round (* base-len (env e))))
- result)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";granf 5 max: ~A" mx)))
- (if (> (abs (- (mus-length gen) (* 5 base-len))) 10)
- (snd-display #__line__ ";granf 5 length: ~A ~A" (mus-length gen) (* 5 base-len)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 5 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 800 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
- (snd-display #__line__ ";granf 5 data 800: ~A" (channel->float-vector 800 30)))
- (undo))
+ (let ((gen (make-granulate :jitter 0.0 :hop .006 :length .001 :ramp 0.0 :max-size 2200 :input (lambda (dir) .1)))
+ (e (make-env '(0 1 1 5) :length 1001)))
+ (let ((base-len (mus-length gen)))
+ (map-channel
+ (lambda (y)
+ (let ((result (granulate gen)))
+ (set! (mus-length gen) (round (* base-len (env e))))
+ result)))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";granf 5 max: ~A" mx)))
+ (if (> (abs (- (mus-length gen) (* 5 base-len))) 10)
+ (snd-display ";granf 5 length: ~A ~A" (mus-length gen) (* 5 base-len)))))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 5 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 440 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 5 data 440: ~A" (channel->float-vector 440 30)))
+ (if (not (vequal (channel->float-vector 800 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
+ (snd-display ";granf 5 data 800: ~A" (channel->float-vector 800 30)))
+ (undo)
- (let* ((gen (make-granulate :jitter 0.0 :hop .006 :length .005 :ramp 0.0 :max-size 2200 :input (lambda (dir) .1)))
- (e (make-env '(0 1 1 .2) :length 1001))
- (base-len (mus-length gen)))
- (map-channel
- (lambda (y)
- (let ((result (granulate gen)))
- (set! (mus-length gen) (round (* base-len (env e))))
- result)))
- (let ((mx (maxamp)))
- (if (fneq mx 0.06) (snd-display #__line__ ";granf 6 max: ~A" mx)))
- (if (> (abs (- (mus-length gen) (* .2 base-len))) 4)
- (snd-display #__line__ ";granf 6 length: ~A ~A" (mus-length gen) (* .2 base-len)))
- (if (not (vequal (channel->float-vector 0 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
- 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
- (snd-display #__line__ ";granf 6 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 820 30)
- (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";granf 6 data 820: ~A" (channel->float-vector 820 30)))
- (undo))
+ (let ((gen (make-granulate :jitter 0.0 :hop .006 :length .005 :ramp 0.0 :max-size 2200 :input (lambda (dir) .1)))
+ (e (make-env '(0 1 1 .2) :length 1001)))
+ (let ((base-len (mus-length gen)))
+ (map-channel
+ (lambda (y)
+ (let ((result (granulate gen)))
+ (set! (mus-length gen) (round (* base-len (env e))))
+ result)))
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.06) (snd-display ";granf 6 max: ~A" mx)))
+ (if (> (abs (- (mus-length gen) (* .2 base-len))) 4)
+ (snd-display ";granf 6 length: ~A ~A" (mus-length gen) (* .2 base-len)))))
+ (if (not (vequal (channel->float-vector 0 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
+ 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
+ (snd-display ";granf 6 data: ~A" (channel->float-vector 0 30)))
+ (if (not (vequal (channel->float-vector 820 30)
+ (float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";granf 6 data 820: ~A" (channel->float-vector 820 30)))
+ (undo)
(let ((max-list (lambda ()
(let ((pts ())
@@ -19692,7 +19243,7 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen)))
(let ((vals (max-list)))
(if (not (equal? vals (list 11 231 451 671 891)))
- (snd-display #__line__ ";grn jitter 0 max: ~A" vals)))
+ (snd-display ";grn jitter 0 max: ~A" vals)))
(undo))
(let ((oldvals #f))
@@ -19701,7 +19252,7 @@ EDITS: 2
;; (11 232 490 736 982) or whatever
(let ((vals (max-list)))
(if (equal? vals (list 11 231 451 671 891))
- (snd-display #__line__ ";grn jitter 0.3 max: ~A" vals))
+ (snd-display ";grn jitter 0.3 max: ~A" vals))
(set! oldvals vals))
(undo))
@@ -19709,216 +19260,214 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen)))
(let ((vals (max-list)))
(if (equal? vals oldvals)
- (snd-display #__line__ ";grn jitter 0.3 max: ~A ~A" vals oldvals)))
+ (snd-display ";grn jitter 0.3 max: ~A ~A" vals oldvals)))
(undo)))
(let ((oldvals #f)
(seed 0))
(let ((gen (make-granulate :jitter 1.0 :hop .01 :length .001 :ramp .5 :scaler 1.0 :expansion 0.5 :input (lambda (dir) .1))))
(set! seed (mus-location gen))
- (map-channel (lambda (y) (granulate gen)))
- (set! oldvals (max-list))
- (undo))
+ (map-channel (lambda (y) (granulate gen))))
+ (set! oldvals (max-list))
+ (undo)
(let ((gen (make-granulate :jitter 1.0 :hop .01 :length .001 :ramp .5 :scaler 1.0 :expansion 0.5 :input (lambda (dir) .1))))
(set! (mus-location gen) seed)
- (map-channel (lambda (y) (granulate gen)))
- (let ((vals (max-list)))
- (if (not (equal? vals oldvals))
- (snd-display #__line__ ";grn jitter 1.0 max with seed: ~A ~A" vals oldvals)))
- (undo))))
+ (map-channel (lambda (y) (granulate gen))))
+ (let ((vals (max-list)))
+ (if (not (equal? vals oldvals))
+ (snd-display ";grn jitter 1.0 max with seed: ~A ~A" vals oldvals)))
+ (undo)))
(let ((fname (file-name ind)))
(close-sound ind)
(delete-file fname)
- (if (and with-motif
- (view-files-dialog #f))
- (begin
- (set! (view-files-files (view-files-dialog #f)) ())
- (if (pair? (view-files-files (view-files-dialog #f)))
- (snd-display #__line__ ";set vf files list null: ~A" (view-files-files (view-files-dialog #f)))))))
- )
+ (when (and with-motif
+ (view-files-dialog #f))
+ (set! (view-files-files (view-files-dialog #f)) ())
+ (if (pair? (view-files-files (view-files-dialog #f)))
+ (snd-display ";set vf files list null: ~A" (view-files-files (view-files-dialog #f)))))))
;; granulate with jitter=0, small hop (comb filter effect)
- (let ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 10000)))
- (let ((gen (make-granulate :expansion 20.0
- :input (lambda (dir) .01)
- :length .00995
- :hop .01
- :ramp 0.0
- :scaler 1.0
- :jitter 0.0)))
- (clm-channel gen) ; -> .01 max (stable)
- (if (fneq (maxamp) .01) (snd-display #__line__ ";granulate stable 1: ~A" (maxamp)))
- (let ((minval (scan-channel (lambda (y) (< y .0099)))))
- (if minval (snd-display #__line__ ";granulate stable 1 min: ~A" minval)))
- (undo)
- (set! gen (make-granulate :expansion 20.0
- :input (lambda (dir) .1)
+ (let* ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 10000))
+ (gen (make-granulate :expansion 20.0
+ :input (lambda (dir) .01)
+ :length .00995
+ :hop .01
+ :ramp 0.0
+ :scaler 1.0
+ :jitter 0.0)))
+ (clm-channel gen) ; -> .01 max (stable)
+ (if (fneq (maxamp) .01) (snd-display ";granulate stable 1: ~A" (maxamp)))
+ (let ((minval (scan-channel (lambda (y) (< y .0099)))))
+ (if minval (snd-display ";granulate stable 1 min: ~A" minval)))
+ (undo)
+ (set! gen (make-granulate :expansion 20.0
+ :input (lambda (dir) .1)
+ :length .00995
+ :hop .01
+ :ramp 0.0
+ :scaler 0.5
+ :jitter 0.0))
+ (clm-channel gen) ; -> .05 max (stable)
+ (if (fneq (maxamp) .05) (snd-display ";granulate stable 2: ~A" (maxamp)))
+ (let ((minval (scan-channel (lambda (y) (< y .0499)))))
+ (if minval (snd-display ";granulate stable 2 min: ~A" minval)))
+ (undo)
+
+ (set! gen (make-granulate :expansion 10.0
+ :input (lambda (dir) .05)
+ :length .099975
+ :hop .1
+ :ramp 0.0
+ :scaler 1.0
+ :jitter 0.0))
+ (clm-channel gen) ; -> .05 max (stable)
+ (if (fneq (maxamp) .05) (snd-display ";granulate stable 3: ~A" (maxamp)))
+ (let ((minval (scan-channel (lambda (y) (< y .0499)))))
+ (if minval (snd-display ";granulate stable 3 min: ~A ~A" minval (sample (cadr minval)))))
+ (undo)
+
+ (let ((ctr -0.0001))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (set! ctr (+ ctr .0001)))
+ :length .01
+ :hop .1
+ :ramp 0.0
+ :scaler 1.0
+ :jitter 0.0))
+ (clm-channel gen))
+ (if (fneq (maxamp) .462) (snd-display ";granulate ramped 4: ~A" (maxamp)))
+ (let ((vals (count-matches (lambda (y) (> (abs y) 0.0)))))
+ (if (> (abs (- vals 1104)) 10) (snd-display ";granulate ramped 4 not 0.0: ~A" vals)))
+ (if (not (and (vequal (channel->float-vector 2203 10)
+ (float-vector 0.000 0.000 0.110 0.110 0.110 0.111 0.111 0.111 0.111 0.111))
+ (vequal (channel->float-vector 4523 10)
+ (float-vector 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.233 0.233))
+ (vequal (channel->float-vector 8928 10)
+ (float-vector 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452))))
+ (snd-display ";granulate ramped 4 data off: ~A ~A ~A"
+ (channel->float-vector 2203 10) (channel->float-vector 4523 10) (channel->float-vector 8928 10)))
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
:length .00995
:hop .01
:ramp 0.0
- :scaler 0.5
+ :scaler 1.0
:jitter 0.0))
- (clm-channel gen) ; -> .05 max (stable)
- (if (fneq (maxamp) .05) (snd-display #__line__ ";granulate stable 2: ~A" (maxamp)))
- (let ((minval (scan-channel (lambda (y) (< y .0499)))))
- (if minval (snd-display #__line__ ";granulate stable 2 min: ~A" minval)))
- (undo)
-
- (set! gen (make-granulate :expansion 10.0
- :input (lambda (dir) .05)
- :length .099975
- :hop .1
- :ramp 0.0
+ (clm-channel gen))
+ (if (fneq (maxamp) .505) (snd-display ";granulate ramped 5: ~A" (maxamp)))
+ (let* ((mxoff 0.0)
+ (mx (maxamp))
+ (len (framples))
+ (cur 0.0)
+ (incr (/ mx len)))
+ (scan-channel (lambda (y)
+ (let ((diff (abs (- cur y))))
+ (set! mxoff (max mxoff diff))
+ (set! cur (+ cur incr))
+ #f)))
+ (if (> mxoff .02) (snd-display ";granulate ramped 5 mxoff: ~A" mxoff))) ; .0108 actually
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
+ :length .00995
+ :hop .01
+ :ramp 0.5
:scaler 1.0
:jitter 0.0))
- (clm-channel gen) ; -> .05 max (stable)
- (if (fneq (maxamp) .05) (snd-display #__line__ ";granulate stable 3: ~A" (maxamp)))
- (let ((minval (scan-channel (lambda (y) (< y .0499)))))
- (if minval (snd-display #__line__ ";granulate stable 3 min: ~A ~A" minval (sample (cadr minval)))))
- (undo)
-
- (let ((ctr -0.0001))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (set! ctr (+ ctr .0001)))
- :length .01
- :hop .1
- :ramp 0.0
- :scaler 1.0
- :jitter 0.0))
- (clm-channel gen)
- (if (fneq (maxamp) .462) (snd-display #__line__ ";granulate ramped 4: ~A" (maxamp)))
- (let ((vals (count-matches (lambda (y) (> (abs y) 0.0)))))
- (if (> (abs (- vals 1104)) 10) (snd-display #__line__ ";granulate ramped 4 not 0.0: ~A" vals)))
- (if (or (not (vequal (channel->float-vector 2203 10)
- (float-vector 0.000 0.000 0.110 0.110 0.110 0.111 0.111 0.111 0.111 0.111)))
- (not (vequal (channel->float-vector 4523 10)
- (float-vector 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.233 0.233)))
- (not (vequal (channel->float-vector 8928 10)
- (float-vector 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452))))
- (snd-display #__line__ ";granulate ramped 4 data off: ~A ~A ~A"
- (channel->float-vector 2203 10) (channel->float-vector 4523 10) (channel->float-vector 8928 10)))
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .00995
- :hop .01
- :ramp 0.0
- :scaler 1.0
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .505) (snd-display #__line__ ";granulate ramped 5: ~A" (maxamp)))
- (let* ((mxoff 0.0)
- (mx (maxamp))
- (len (framples))
- (cur 0.0)
- (incr (/ mx len)))
- (scan-channel (lambda (y)
- (let ((diff (abs (- cur y))))
- (if (> diff mxoff) (set! mxoff diff))
- (set! cur (+ cur incr))
- #f)))
- (if (> mxoff .02) (snd-display #__line__ ";granulate ramped 5 mxoff: ~A" mxoff))) ; .0108 actually
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .00995
- :hop .01
- :ramp 0.5
- :scaler 1.0
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .495) (snd-display #__line__ ";granulate ramped 6: ~A" (maxamp)))
- (if (or (not (vequal (channel->float-vector 2000 10)
- (float-vector 0.018 0.019 0.020 0.021 0.022 0.023 0.024 0.025 0.026 0.027)))
- (not (vequal (channel->float-vector 8000 10)
- (float-vector 0.294 0.298 0.301 0.305 0.309 0.313 0.316 0.320 0.324 0.328))))
- (snd-display #__line__ ";granulate ramped 6 data: ~A ~A"
- (channel->float-vector 2000 10) (channel->float-vector 8000 10)))
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .00995
- :hop .01
- :ramp 0.25
- :scaler 1.0
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .505) (snd-display #__line__ ";granulate ramped 7: ~A" (maxamp)))
- (if (or (not (vequal (channel->float-vector 2000 10)
- (float-vector 0.037 0.039 0.040 0.042 0.044 0.046 0.048 0.050 0.052 0.054)))
- (not (vequal (channel->float-vector 8000 10)
- (float-vector 0.404 0.404 0.404 0.404 0.404 0.405 0.405 0.405 0.405 0.405))))
- (snd-display #__line__ ";granulate ramped 7 data: ~A ~A"
- (channel->float-vector 2000 10) (channel->float-vector 8000 10)))
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .05
- :hop .01
- :ramp 0.25
- :scaler 0.1
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .201) (snd-display #__line__ ";granulate ramped 7: ~A" (maxamp)))
- (let* ((mxoff 0.0)
- (mx (maxamp))
- (len (framples))
- (cur 0.0)
- (incr (/ mx len)))
- (scan-channel (lambda (y)
- (let ((diff (abs (- cur y))))
- (if (> diff mxoff) (set! mxoff diff))
- (set! cur (+ cur incr))
- #f)))
- (if (> mxoff .01) (snd-display #__line__ ";granulate ramped 7 mxoff: ~A" mxoff))) ; .0097 actually
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .1
- :hop .01
- :ramp 0.1
- :scaler 0.1
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .501) (snd-display #__line__ ";granulate ramped 8: ~A" (maxamp)))
- (let* ((mxoff 0.0)
- (mx (maxamp))
- (len (- (framples) 2000))
- (cur (sample 2000))
- (incr (/ (- mx cur) len)))
- (scan-channel (lambda (y)
- (let ((diff (abs (- cur y))))
- (if (> diff mxoff) (set! mxoff diff))
- (set! cur (+ cur incr))
- #f))
- 2000)
- (if (> mxoff .001) (snd-display #__line__ ";granulate ramped 8 mxoff: ~A" mxoff)))
- (undo)
-
- (let ((e (make-env '(0 0 1 1) :length 10000)))
- (set! gen (make-granulate :expansion 2.0
- :input (lambda (dir) (env e))
- :length .4
- :hop .01
- :ramp 0.4
- :scaler 0.025
- :jitter 0.0)))
- (clm-channel gen)
- (if (fneq (maxamp) .433) (snd-display #__line__ ";granulate ramped 9: ~A" (maxamp)))
- (undo)
- (close-sound ind))))
+ (clm-channel gen))
+ (if (fneq (maxamp) .495) (snd-display ";granulate ramped 6: ~A" (maxamp)))
+ (if (not (and (vequal (channel->float-vector 2000 10)
+ (float-vector 0.018 0.019 0.020 0.021 0.022 0.023 0.024 0.025 0.026 0.027))
+ (vequal (channel->float-vector 8000 10)
+ (float-vector 0.294 0.298 0.301 0.305 0.309 0.313 0.316 0.320 0.324 0.328))))
+ (snd-display ";granulate ramped 6 data: ~A ~A"
+ (channel->float-vector 2000 10) (channel->float-vector 8000 10)))
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
+ :length .00995
+ :hop .01
+ :ramp 0.25
+ :scaler 1.0
+ :jitter 0.0))
+ (clm-channel gen))
+ (if (fneq (maxamp) .505) (snd-display ";granulate ramped 7: ~A" (maxamp)))
+ (if (not (and (vequal (channel->float-vector 2000 10)
+ (float-vector 0.037 0.039 0.040 0.042 0.044 0.046 0.048 0.050 0.052 0.054))
+ (vequal (channel->float-vector 8000 10)
+ (float-vector 0.404 0.404 0.404 0.404 0.404 0.405 0.405 0.405 0.405 0.405))))
+ (snd-display ";granulate ramped 7 data: ~A ~A"
+ (channel->float-vector 2000 10) (channel->float-vector 8000 10)))
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
+ :length .05
+ :hop .01
+ :ramp 0.25
+ :scaler 0.1
+ :jitter 0.0))
+ (clm-channel gen))
+ (if (fneq (maxamp) .201) (snd-display ";granulate ramped 7: ~A" (maxamp)))
+ (let* ((mxoff 0.0)
+ (mx (maxamp))
+ (len (framples))
+ (cur 0.0)
+ (incr (/ mx len)))
+ (scan-channel (lambda (y)
+ (let ((diff (abs (- cur y))))
+ (set! mxoff (max mxoff diff))
+ (set! cur (+ cur incr))
+ #f)))
+ (if (> mxoff .01) (snd-display ";granulate ramped 7 mxoff: ~A" mxoff))) ; .0097 actually
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
+ :length .1
+ :hop .01
+ :ramp 0.1
+ :scaler 0.1
+ :jitter 0.0))
+ (clm-channel gen))
+ (if (fneq (maxamp) .501) (snd-display ";granulate ramped 8: ~A" (maxamp)))
+ (let* ((mxoff 0.0)
+ (mx (maxamp))
+ (len (- (framples) 2000))
+ (cur (sample 2000))
+ (incr (/ (- mx cur) len)))
+ (scan-channel (lambda (y)
+ (let ((diff (abs (- cur y))))
+ (set! mxoff (max mxoff diff))
+ (set! cur (+ cur incr))
+ #f))
+ 2000)
+ (if (> mxoff .001) (snd-display ";granulate ramped 8 mxoff: ~A" mxoff)))
+ (undo)
+
+ (let ((e (make-env '(0 0 1 1) :length 10000)))
+ (set! gen (make-granulate :expansion 2.0
+ :input (lambda (dir) (env e))
+ :length .4
+ :hop .01
+ :ramp 0.4
+ :scaler 0.025
+ :jitter 0.0))
+ (clm-channel gen))
+ (if (fneq (maxamp) .433) (snd-display ";granulate ramped 9: ~A" (maxamp)))
+ (undo)
+ (close-sound ind))
(let ((v0 (make-float-vector 32))
(v1 (make-float-vector 256))
@@ -19939,25 +19488,25 @@ EDITS: 2
(print-and-check gen
"convolve"
"convolve size: 64")
- (if (not (convolve? gen)) (snd-display #__line__ ";~A not convolve?" gen))
+ (if (not (convolve? gen)) (snd-display ";~A not convolve?" gen))
(let ((genx gen1))
- (if (not (equal? genx gen1)) (snd-display #__line__ ";convolve equal?: ~A ~A ~A" genx gen1 (equal? genx gen1))))
- (if (equal? gen gen1) (snd-display #__line__ ";convolve equal? ~A ~A" gen gen1))
- (if (not (= (mus-length gen) 64)) (snd-display #__line__ ";convolve fft len: ~D?" (mus-length gen)))
+ (if (not (equal? genx gen1)) (snd-display ";convolve equal?: ~A ~A ~A" genx gen1 (equal? genx gen1))))
+ (if (equal? gen gen1) (snd-display ";convolve equal? ~A ~A" gen gen1))
+ (if (not (= (mus-length gen) 64)) (snd-display ";convolve fft len: ~D?" (mus-length gen)))
(do ((i 0 (+ i 1)))
((= i 128))
(set! (v2 i) (convolve gen)))
(fill-float-vector v21 (if (convolve? gen1) (convolve gen1) -1.0))
- (if (not (vequal v2 v21)) (snd-display #__line__ ";run gran: ~A ~A" v2 v21))
+ (if (not (vequal v2 v21)) (snd-display ";run gran: ~A ~A" v2 v21))
(if (or (fneq (v2 0) 0.0)
(fneq (v2 1) 1.0)
(fneq (v2 4) 0.25)
(fneq (v2 7) 0.143))
- (snd-display #__line__ ";convolve output: ~A?" v2)))
+ (snd-display ";convolve output: ~A?" v2)))
(convolve-files "oboe.snd" "fyow.snd" .5 "fmv.snd")
(if (fneq (cadr (mus-sound-maxamp "fmv.snd")) .5)
- (snd-display #__line__ ";convolve-files: ~A is not .5?" (cadr (mus-sound-maxamp "fmv.snd"))))
+ (snd-display ";convolve-files: ~A is not .5?" (cadr (mus-sound-maxamp "fmv.snd"))))
))
(let ((flt (float-vector 1.0 0.5 0.1 0.2 0.3 0.4 0.5 1.0))
@@ -19972,40 +19521,40 @@ EDITS: 2
((= i 16))
(set! (res i) (convolve g)))
(if (not (vequal res (float-vector 0.0 1.0 0.5 0.1 1.2 0.8 0.5 0.7 1.3 0.4 0.5 1.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";convolve: ~A~%" res))))
+ (snd-display ";convolve: ~A~%" res))))
(let ((ind (new-sound "fmv.snd")))
(set! (sample 1) .1)
(save-sound ind)
(if (not (equal? (edits ind 0) (list 0 0)))
- (snd-display #__line__ ";weird: edits not cleared after save-sound?: ~A" (edits ind 0)))
+ (snd-display ";weird: edits not cleared after save-sound?: ~A" (edits ind 0)))
(close-sound ind)
(set! ind (open-sound "fmv.snd"))
(if (not (= (framples ind 0) 2))
- (snd-display #__line__ ";save-sound 2 samps: ~A?" (framples ind 0)))
+ (snd-display ";save-sound 2 samps: ~A?" (framples ind 0)))
(if (or (fneq (sample 0) 0.0)
(fneq (sample 1) 0.1))
- (snd-display #__line__ ";save-sound: ~A ~A?" (sample 0) (sample 1)))
+ (snd-display ";save-sound: ~A ~A?" (sample 0) (sample 1)))
(do ((i 3 (+ i 1)))
((= i 6))
(set! (sample i) (* i .1))
(save-sound ind)
(if (not (equal? (edits ind 0) (list 0 0)))
- (snd-display #__line__ ";weird: edits not cleared after save-sound ~A?: ~A" i (edits ind 0)))
+ (snd-display ";weird: edits not cleared after save-sound ~A?: ~A" i (edits ind 0)))
(close-sound ind)
(set! ind (open-sound "fmv.snd"))
(if (not (= (framples ind 0) (+ i 1)))
- (snd-display #__line__ ";save-sound ~A samps: ~A?" (+ i 1) (framples ind 0)))
+ (snd-display ";save-sound ~A samps: ~A?" (+ i 1) (framples ind 0)))
(if (or (fneq (sample 0) 0.0)
(fneq (sample 1) 0.1)
(fneq (sample i) (* i 0.1)))
- (snd-display #__line__ ";save-sound ~A: ~A ~A ~A?" i (sample 0) (sample 1) (sample i))))
+ (snd-display ";save-sound ~A: ~A ~A ~A?" i (sample 0) (sample 1) (sample i))))
(close-sound ind))
(let ((ind (new-sound "test.snd" :srate 22050 :channels 1 :size 1000))
(gen (make-ssb-am 100.0)))
(map-channel (lambda (y) (ssb-am gen)))
- (if (fneq (maxamp) 0.0) (snd-display #__line__ ";ssb-am 0.0: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.0) (snd-display ";ssb-am 0.0: ~A" (maxamp)))
(let ((gen1 (make-oscil 220.0)))
(map-channel (lambda (y) (* 0.5 (oscil gen1))))
(set! gen (make-ssb-am 100.0 100))
@@ -20013,7 +19562,7 @@ EDITS: 2
(delete-samples 0 200)
(set! gen1 (make-oscil 320.0 :initial-phase (asin (* 2 (sample 0))))) ; depends on rising side
(map-channel (lambda (y) (- y (* 0.5 (oscil gen1)))))
- (if (> (maxamp) .004) (snd-display #__line__ ";ssb-am cancelled: ~A" (maxamp)))
+ (if (> (maxamp) .004) (snd-display ";ssb-am cancelled: ~A" (maxamp)))
(undo 3)
(set! gen (make-ssb-am 100.0 100))
(let ((hx (hz->radians 50.0)))
@@ -20021,69 +19570,69 @@ EDITS: 2
(delete-samples 0 180)
(set! gen1 (make-oscil 370.0 :initial-phase (asin (* 2 (sample 0))))) ; depends on rising side
(map-channel (lambda (y) (- y (* 0.5 (oscil gen1)))))
- (if (> (maxamp) .004) (snd-display #__line__ ";ssb-am fm cancelled: ~A" (maxamp)))
+ (if (> (maxamp) .004) (snd-display ";ssb-am fm cancelled: ~A" (maxamp)))
(close-sound ind)))
- (let* ((ind (new-sound "test.snd" :srate 22050 :channels 1 :size 1000))
- (scl (/ (* 2 pi) 50))
- (x (- scl)))
- (map-channel (lambda (y) (sin (set! x (+ x scl)))))
+ (let ((ind (new-sound "test.snd" :srate 22050 :channels 1 :size 1000)))
+ (let* ((scl (/ (* 2 pi) 50))
+ (x (- scl)))
+ (map-channel (lambda (y) (sin (set! x (+ x scl))))))
;; 441 Hz
(ssb-bank 441 882 1 100)
(delete-samples 0 217)
(let ((gen1 (make-oscil 882.0 :initial-phase (asin (sample 0)))))
(map-channel (lambda (y) (- y (oscil gen1))))
- (if (> (maxamp) .04) (snd-display #__line__ ";ssb-bank cancelled: ~A" (maxamp))))
+ (if (> (maxamp) .04) (snd-display ";ssb-bank cancelled: ~A" (maxamp))))
(close-sound ind))
(if *output*
(begin
- (snd-display #__line__ ";*output* ~A" *output*)
+ (snd-display ";*output* ~A" *output*)
(set! *output* #f)))
(let ((nind (new-sound "fmv.snd" 1 22050 mus-bshort mus-aifc "this is a comment")))
(time (mix-float-vector (with-temp-sound (:output (make-float-vector 22050)) (fm-violin 0 1 440 .1)) 0 nind 0))
(play nind :wait #t)
(save-sound nind)
- (if (not (sound? nind)) (snd-display #__line__ ";save sound clobbered ~A?" nind))
+ (if (not (sound? nind)) (snd-display ";save sound clobbered ~A?" nind))
(let ((oboe-index (or (find-sound "oboe.snd") (open-sound "oboe.snd"))))
- (if (equal? oboe-index nind) (snd-display #__line__ ";find-sound found bogus case: ~A" oboe-index))
+ (if (equal? oboe-index nind) (snd-display ";find-sound found bogus case: ~A" oboe-index))
(cnvtest oboe-index nind .1)
(select-sound nind)
(select-channel 0)
- (if (not (equal? (selected-sound) nind)) (snd-display #__line__ ";selected-sound: ~A?" (selected-sound)))
- (if (not (= (selected-channel) 0)) (snd-display #__line__ ";selected-channel: ~A?" (selected-channel)))
+ (if (not (equal? (selected-sound) nind)) (snd-display ";selected-sound: ~A?" (selected-sound)))
+ (if (not (= (selected-channel) 0)) (snd-display ";selected-channel: ~A?" (selected-channel)))
(snd-test-jc-reverb 1.0 #f .1 #f)
(play nind :wait #t)
(voiced->unvoiced 1.0 256 2.0 2.0)
(pulse-voice 80 20.0 1.0 1024 0.01)
(map-channel (fltit))
(close-sound oboe-index))
- (if (not (sound? nind)) (snd-display #__line__ ";close sound clobbered ~A?" nind))
+ (if (not (sound? nind)) (snd-display ";close sound clobbered ~A?" nind))
(let ((fr (framples nind 0)))
(do ((k 0 (+ k 1)))
((= k 10))
(delete-samples 10 100 nind 0)
(save-sound nind)) ;flush out memory leaks here
(if (not (= (framples nind 0) (- fr 1000)))
- (snd-display #__line__ ";delete-samples: ~A ~A" fr (framples nind 0))))
+ (snd-display ";delete-samples: ~A ~A" fr (framples nind 0))))
(revert-sound nind)
(close-sound nind))
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
(let ((nind (new-sound "fmv.snd")))
(if (not (= (header-type nind) *default-output-header-type*))
- (snd-display #__line__ ";new-sound default header-type: ~A ~A?"
+ (snd-display ";new-sound default header-type: ~A ~A?"
(mus-header-type-name (header-type nind))
(mus-header-type-name *default-output-header-type*)))
(if (not (= (sample-type nind) *default-output-sample-type*))
- (snd-display #__line__ ";new-sound default sample-type: ~A ~A?"
+ (snd-display ";new-sound default sample-type: ~A ~A?"
(mus-sample-type-name (sample-type nind))
(mus-sample-type-name *default-output-sample-type*)))
(if (not (= (chans nind) *default-output-chans*))
- (snd-display #__line__ ";new-sound default chans: ~A ~A?" (chans nind) *default-output-chans*))
+ (snd-display ";new-sound default chans: ~A ~A?" (chans nind) *default-output-chans*))
(if (not (= (srate nind) *default-output-srate*))
- (snd-display #__line__ ";new-sound default srate: ~A ~A?" (srate nind) *default-output-srate*))
+ (snd-display ";new-sound default srate: ~A ~A?" (srate nind) *default-output-srate*))
(close-sound nind)
(if (file-exists? "fmv.snd") (delete-file "fmv.snd")))
(let ((nind (new-sound "fmv.snd" 1 22050 mus-bshort mus-nist "this is a comment")))
@@ -20091,7 +19640,7 @@ EDITS: 2
(start-progress-report nind)
(convolve-with "oboe.snd")
(progress-report .1 nind)
- (if (fneq (sample 1000) 0.223) (snd-display #__line__ ";convolve-with: ~A?" (sample 1000)))
+ (if (fneq (sample 1000) 0.223) (snd-display ";convolve-with: ~A?" (sample 1000)))
(progress-report .3 nind)
(revert-sound nind)
(progress-report .5 nind)
@@ -20101,44 +19650,44 @@ EDITS: 2
(smooth-sound 0 100)
(finish-progress-report nind)
(if (or (fneq (sample 50) .5) (fneq (sample 30) 0.20608) (fneq (sample 90) 0.9755))
- (snd-display #__line__ ";smooth: ~A ~A ~A?" (sample 50) (sample 30) (sample 90)))
+ (snd-display ";smooth: ~A ~A ~A?" (sample 50) (sample 30) (sample 90)))
(undo)
(let ((old-wid *sinc-width*))
(set! *sinc-width* 40)
(set! (sample 100) 0.5)
- (if (fneq (sample 100) 0.5) (snd-display #__line__ ";set-sample 100: ~A?" (sample 100)))
+ (if (fneq (sample 100) 0.5) (snd-display ";set-sample 100: ~A?" (sample 100)))
(src-sound .1)
(set! *sinc-width* old-wid))
(if (or (fneq (sample 1000) 0.5) (fneq (sample 1024) 0.0625) (fneq (sample 1010) 0.0))
- (snd-display #__line__ ";src-sound: ~A ~A ~A?" (sample 1000) (sample 1024) (sample 1010)))
+ (snd-display ";src-sound: ~A ~A ~A?" (sample 1000) (sample 1024) (sample 1010)))
(revert-sound)
(close-sound nind))
(let ((nind (new-sound "fmv.snd" 1 22050 mus-lshort mus-riff "this is a comment" 22050)))
- (if (not (= (framples nind) 22050)) (snd-display #__line__ "; new-sound initial-length: ~A" (framples nind)))
+ (if (not (= (framples nind) 22050)) (snd-display "; new-sound initial-length: ~A" (framples nind)))
(mix "pistol.snd")
(map-channel (expsrc 2.0 nind))
(undo)
(let ((eds (edits)))
(if (not (= (car eds) 1 (cadr eds)))
- (snd-display #__line__ ";undo edits: ~A?" eds))
+ (snd-display ";undo edits: ~A?" eds))
(if (not (= (edit-position) (car eds)))
- (snd-display #__line__ ";undo edit-position: ~A ~A?" (edit-position) eds)))
+ (snd-display ";undo edit-position: ~A ~A?" (edit-position) eds)))
(expsnd '(0 1 2 .4))
(map-channel (comb-chord .95 100 .3))
(map-channel (formants .99 900 .02 1800 .01 2700))
(map-channel (moving-formant .99 '(0 1200 1 2400)))
(scale-to .3)
(let ((eds (edits)))
- (if (or (not (= (car eds) 6)) (not (= (cadr eds) 0)))
- (snd-display #__line__ ";edits(6): ~A?" eds))
+ (if (not (and (= (car eds) 6) (= (cadr eds) 0)))
+ (snd-display ";edits(6): ~A?" eds))
(if (not (= (edit-position) (car eds)))
- (snd-display #__line__ ";edit-position(6): ~A ~A?" (edit-position) eds)))
+ (snd-display ";edit-position(6): ~A ~A?" (edit-position) eds)))
(set! (edit-position) 1)
(if (not (= (edit-position) 1))
- (snd-display #__line__ ";set edit-position(1) ~A?" (edit-position)))
+ (snd-display ";set edit-position(1) ~A?" (edit-position)))
(set! (edit-position) 4)
(if (not (= (edit-position) 4))
- (snd-display #__line__ ";set edit-position(4): ~A?" (edit-position)))
+ (snd-display ";set edit-position(4): ~A?" (edit-position)))
(revert-sound nind)
(mix "pistol.snd")
(map-channel (zecho .5 .75 6 10.0) 0 65000)
@@ -20152,7 +19701,7 @@ EDITS: 2
(let ((mid (mix-sound "pistol.snd" 0)))
(if (and (mix? mid)
(not (equal? (mix-home mid) (list (selected-sound) 0 #f 0))))
- (snd-display #__line__ ";mix-sound mix-home: ~A" (mix-home mid))))
+ (snd-display ";mix-sound mix-home: ~A" (mix-home mid))))
(hello-dentist 40.0 .1)
(fp 1.0 .3 20)
(revert-sound nind)
@@ -20169,21 +19718,22 @@ EDITS: 2
(stretch-sound-via-dft 2.0 ind 0)
(let ((new-len (framples ind 0)))
(if (> (abs (- (* 2 len) new-len)) 10)
- (snd-display #__line__ ";stretch-sound-via-dft: ~A ~A" len new-len)))
+ (snd-display ";stretch-sound-via-dft: ~A ~A" len new-len)))
(close-sound ind)))
(let ((make-mix-output (lambda (name i)
- (if (or (= i 0) (= i 1))
+ (if (member i '(0 1) =)
name
(continue-sample->file name))))
(make-mix-input (lambda (name i)
- (if (or (= i 0) (= i 2))
+ (if (member i '(0 2) =)
name
(make-file->frample name)))))
- (define (mus-file-mix-1 outf . args)
- (apply mus-file-mix outf args)
- (if (not (string? outf))
- (mus-close outf)))
+ (define (mus-file-mix-1 k . args)
+ (let ((outf (make-mix-output "fmv.snd" k)))
+ (apply mus-file-mix outf args)
+ (if (not (string? outf))
+ (mus-close outf))))
(do ((k 0 (+ k 1)))
((= k 4))
@@ -20201,7 +19751,7 @@ EDITS: 2
(do ((i 0 (+ i 1))) ((= i 12)) (set! (v0 i) (* i .01)))
(array->file "fmv.snd" v0 12 22050 1)
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv1.snd" k))
+ (mus-file-mix-1 k (make-mix-input "fmv1.snd" k))
(file->array "fmv.snd" 0 0 12 v0)
;; v0: #(0.1 0.11 0.12 0.13 0.14 0.15 0.16 0.17 0.18 0.19 0.2 0.21)
@@ -20210,30 +19760,30 @@ EDITS: 2
((or (not happy) (= i 12)))
(if (fneq (v0 i) (+ 0.1 (* i .01)))
(begin
- (snd-display #__line__ ";~D mus-file-mix(1->1): ~A?" k v0)
+ (snd-display ";~D mus-file-mix(1->1): ~A?" k v0)
(set! happy #f)))))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 3 9 0 (float-vector 0.3 0.0 0.7 0.0))
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 3 9 0 (float-vector 0.3 0.0 0.7 0.0))
(file->array "fmv.snd" 0 0 12 v0)
;; v0: #(0.1 0.11 0.12 0.33 0.34 0.35 0.36 0.37 0.38 0.19 0.2 0.21)
- (if (or (fneq (v0 0) .1) (fneq (v0 3) .33) (fneq (v0 9) .19)) (snd-display #__line__ ";~D mus-file-mix(2->1): ~A?" k v0))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv3.snd" k))
+ (if (or (fneq (v0 0) .1) (fneq (v0 3) .33) (fneq (v0 9) .19)) (snd-display ";~D mus-file-mix(2->1): ~A?" k v0))
+ (mus-file-mix-1 k (make-mix-input "fmv3.snd" k))
(file->array "fmv.snd" 0 0 12 v0)
;; ?? v0: #(0.4 0.41 0.42 0.33 0.34 0.35 0.36 0.37 0.38 0.19 0.2 0.21)
- (if (or (fneq (v0 0) .4) (fneq (v0 3) .33)) (snd-display #__line__ ";~D mus-file-mix(4->1): ~A?" k v0))
- (let ((e0 (make-env '(0 0 1 1) :length 11))
- (vf (make-vector 1))
- (vf1 (make-vector 1)))
- (set! (vf 0) vf1)
- (set! (vf1 0) e0)
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv1.snd" k) 0 12 0 (float-vector 1.0) vf)
+ (if (or (fneq (v0 0) .4) (fneq (v0 3) .33)) (snd-display ";~D mus-file-mix(4->1): ~A?" k v0))
+ (let ((vf (make-vector 1)))
+ (let ((e0 (make-env '(0 0 1 1) :length 11))
+ (vf1 (make-vector 1)))
+ (set! (vf 0) vf1)
+ (set! (vf1 0) e0))
+ (mus-file-mix-1 k (make-mix-input "fmv1.snd" k) 0 12 0 (float-vector 1.0) vf)
(file->array "fmv.snd" 0 0 12 v0)
;; ?? v0: #(0.4 0.42 0.4400000000000001 0.36 0.38 0.4 0.42 0.44 0.46 0.28 0.3 0.31)
- (if (or (fneq (v0 0) .4) (fneq (v0 3) .360) (fneq (v0 9) .28)) (snd-display #__line__ ";~D mus-file-mix(env): ~A?" k v0))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
+ (if (or (fneq (v0 0) .4) (fneq (v0 3) .360) (fneq (v0 9) .28)) (snd-display ";~D mus-file-mix(env): ~A?" k v0))
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
;; clm2xen should protect us here
(let ((vf (make-vector 2))
(vf1 (make-vector 2))
@@ -20242,73 +19792,71 @@ EDITS: 2
(set! (vf 1) vf2)
(set! (vf1 0) (make-env '(0 0 1 1) :length 10))
(set! (vf2 1) (make-env '(0 0 1 1) :length 10))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf)
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf)
(let ((tag (catch #t
(lambda ()
(set! (vf 0) (make-oscil))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
(lambda args (car args)))))
(if (not (eq? tag 'bad-type))
- (snd-display #__line__ ";~D mix w oscil-vect: ~A" k tag)))
+ (snd-display ";~D mix w oscil-vect: ~A" k tag)))
(set! (vf 0) vf1)
(set! (vf 1) vf2)
(let ((tag (catch #t
(lambda ()
(set! (vf1 0) (make-oscil))
(set! (vf2 1) 0+i)
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 0 12 0 (float-vector 1.0 1.0 1.0 1.0) vf))
(lambda args (car args)))))
(if (not (eq? tag 'bad-type))
- (snd-display #__line__ ";~D mix w oscil-env: ~A" k tag))))
+ (snd-display ";~D mix w oscil-env: ~A" k tag))))
(delete-file "fmv.snd")
(do ((i 0 (+ i 1))) ((= i 12)) (set! (v0 i) (* i .01)))
(array->file "fmv.snd" v0 12 22050 4)
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv1.snd" k))
+ (mus-file-mix-1 k (make-mix-input "fmv1.snd" k))
(file->array "fmv.snd" 0 0 3 v0) ; chan 0 start 0 len 3
;; v0: #(0.1 0.14 0.18 0.03 0.04 0.05 0.06 0.07000000000000001 0.08 0.09 0.1 0.11)
- (if (or (fneq (v0 0) .1) (fneq (v0 2) .18)) (snd-display #__line__ ";~D mus-file-mix(1->4): ~A?" k v0))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv2.snd" k) 0 3 0 (float-vector 0.3 0.0 0.7 0.0))
+ (if (or (fneq (v0 0) .1) (fneq (v0 2) .18)) (snd-display ";~D mus-file-mix(1->4): ~A?" k v0))
+ (mus-file-mix-1 k (make-mix-input "fmv2.snd" k) 0 3 0 (float-vector 0.3 0.0 0.7 0.0))
(file->array "fmv.snd" 0 0 3 v0)
;; v0: #(0.3 0.34 0.38 0.03 0.04 0.05 0.06 0.07000000000000001 0.08 0.09 0.1 0.11)
- (if (or (fneq (v0 0) .3) (fneq (v0 2) .38)) (snd-display #__line__ ";~D mus-file-mix(2->4): ~A?" k v0))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "fmv3.snd" k) 0 2 0)
+ (if (or (fneq (v0 0) .3) (fneq (v0 2) .38)) (snd-display ";~D mus-file-mix(2->4): ~A?" k v0))
+ (mus-file-mix-1 k (make-mix-input "fmv3.snd" k) 0 2 0)
(file->array "fmv.snd" 0 0 3 v0)
;; v0: #(0.6000000000000001 0.6400000000000001 0.38 0.03 0.04 0.05 0.06 0.07000000000000001 0.08 0.09 0.1 0.11)
- (if (or (fneq (v0 0) .6) (fneq (v0 2) .38)) (snd-display #__line__ ";~D mus-file-mix(4->4): ~A?" k v0)))
+ (if (or (fneq (v0 0) .6) (fneq (v0 2) .38)) (snd-display ";~D mus-file-mix(4->4): ~A?" k v0)))
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
- (let ((v0 (make-float-vector 12))
- (len (mus-sound-framples "oboe.snd")))
- (array->file "fmv.snd" v0 12 22050 1)
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "oboe.snd" k))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "oboe.snd" k) 0 len 0 (float-vector 0.5))
+ (let ((len (mus-sound-framples "oboe.snd")))
+ (array->file "fmv.snd" (make-float-vector 12) 12 22050 1)
+ (mus-file-mix-1 k (make-mix-input "oboe.snd" k))
+ (mus-file-mix-1 k (make-mix-input "oboe.snd" k) 0 len 0 (float-vector 0.5))
(let ((egen (make-vector 1))
(outv (make-vector 1)))
(set! (outv 0) egen)
(set! (egen 0) (make-env :envelope '(0 0 1 1) :length len))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "oboe.snd" k) 0 len 0 #f outv)
+ (mus-file-mix-1 k (make-mix-input "oboe.snd" k) 0 len 0 #f outv)
(set! (egen 0) (make-env :envelope '(0 1 1 0) :length len))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "oboe.snd" k) 0 len 0 (float-vector 1.0) outv))
+ (mus-file-mix-1 k (make-mix-input "oboe.snd" k) 0 len 0 (float-vector 1.0) outv))
(let ((ind-oboe (open-sound "oboe.snd"))
(ind-mix (open-sound "fmv.snd")))
(if (not (vequal (channel->float-vector 1000 10 ind-oboe)
(float-vector-scale! (channel->float-vector 1000 10 ind-mix) (/ 1.0 2.5))))
- (snd-display #__line__ ";~D mus-file-mix 1 chan: ~A ~A" k
+ (snd-display ";~D mus-file-mix 1 chan: ~A ~A" k
(channel->float-vector 1000 10 ind-oboe)
(channel->float-vector 1000 10 ind-mix)))
(close-sound ind-oboe)
(close-sound ind-mix))
(delete-file "fmv.snd")
- (let ((v0 (make-float-vector 12))
- (len (mus-sound-framples "2.snd")))
- (array->file "fmv.snd" v0 12 22050 2)
+ (let ((len (mus-sound-framples "2.snd")))
+ (array->file "fmv.snd" (make-float-vector 12) 12 22050 2)
(if (not (= (mus-sound-chans "fmv.snd") 2))
- (snd-display #__line__ ";~D array->file chans? ~A" k (mus-sound-chans "fmv.snd")))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "2.snd" k))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "2.snd" k) 0 len 0 (float-vector 0.5 0.0 0.0 0.5))
+ (snd-display ";~D array->file chans? ~A" k (mus-sound-chans "fmv.snd")))
+ (mus-file-mix-1 k (make-mix-input "2.snd" k))
+ (mus-file-mix-1 k (make-mix-input "2.snd" k) 0 len 0 (float-vector 0.5 0.0 0.0 0.5))
(let ((egen0 (make-vector 2))
(egen1 (make-vector 2))
(outv (make-vector 2)))
@@ -20316,18 +19864,18 @@ EDITS: 2
(set! (outv 1) egen1)
(set! (egen0 0) (make-env :envelope '(0 0 1 1) :length len))
(set! (egen1 1) (make-env :envelope '(0 0 1 1) :length len))
- (mus-file-mix-1 (make-mix-output "fmv.snd" k) (make-mix-input "2.snd" k) 0 len 0 #f outv))
- (let ((ind-mix (open-sound "fmv.snd")))
- (if (not (= (channels ind-mix) 2))
- (snd-display #__line__ ";~D fmv re-read chans? ~A ~A" k (mus-sound-chans "fmv.snd") (channels ind-mix)))
- (if (not (vequal (channel->float-vector 1000 10 ind-mix 0)
- (float-vector 0.003 0.010 0.012 0.011 0.008 0.004 0.002 0.002 0.007 0.017)))
- (snd-display #__line__ ";~D mus-file-mix 2 chan (2.snd written: ~A): ~A ~A" k
- (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "2.snd")))
- (channel->float-vector 1000 10 ind-mix 0)
- (channel->float-vector 1000 10 ind-mix 1)))
- (close-sound ind-mix)
- (delete-file "fmv.snd"))))
+ (mus-file-mix-1 k (make-mix-input "2.snd" k) 0 len 0 #f outv)))
+ (let ((ind-mix (open-sound "fmv.snd")))
+ (if (not (= (channels ind-mix) 2))
+ (snd-display ";~D fmv re-read chans? ~A ~A" k (mus-sound-chans "fmv.snd") (channels ind-mix)))
+ (if (not (vequal (channel->float-vector 1000 10 ind-mix 0)
+ (float-vector 0.003 0.010 0.012 0.011 0.008 0.004 0.002 0.002 0.007 0.017)))
+ (snd-display ";~D mus-file-mix 2 chan (2.snd written: ~A): ~A ~A" k
+ (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "2.snd")))
+ (channel->float-vector 1000 10 ind-mix 0)
+ (channel->float-vector 1000 10 ind-mix 1)))
+ (close-sound ind-mix)
+ (delete-file "fmv.snd")))
); end do loop
); end let
@@ -20345,14 +19893,13 @@ EDITS: 2
(outa i 1.0)))
(with-sound ("mix.snd")
- (let ((rd (vector (make-readin "flat.snd"))))
- (mus-file-mix-with-envs rd 0 1000 (float-vector 0.5) #f #f #f #f)))
+ (mus-file-mix-with-envs (vector (make-readin "flat.snd")) 0 1000 (float-vector 0.5) #f #f #f #f))
(let ((ind (find-sound "mix.snd")))
(if (sound? ind)
(if (fneq (sample 100 ind) 0.5)
- (snd-display #__line__ ";mus-file-mix-with-envs 1: ~A" (sample 100 ind)))
- (snd-display #__line__ ";mus-file-mix-with envs 1: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 1: ~A" (sample 100 ind)))
+ (snd-display ";mus-file-mix-with envs 1: no output? ~A" (map short-file-name (sounds)))))
(with-sound ("mix.snd")
(let ((rd (vector (make-readin "flat.snd")))
@@ -20362,8 +19909,8 @@ EDITS: 2
(let ((ind (find-sound "mix.snd")))
(if (sound? ind)
(if (fneq (sample 100 ind) 0.1)
- (snd-display #__line__ ";mus-file-mix-with-envs 2: ~A" (sample 100 ind)))
- (snd-display #__line__ ";mus-file-mix-with envs 2: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 2: ~A" (sample 100 ind)))
+ (snd-display ";mus-file-mix-with envs 2: no output? ~A" (map short-file-name (sounds)))))
(with-sound ("mix.snd" 2 :clipped #f)
(let ((rd (vector (make-readin "flat.snd")
@@ -20378,10 +19925,10 @@ EDITS: 2
(if (sound? ind)
(begin
(if (fneq (sample 100 ind 0) 0.51)
- (snd-display #__line__ ";mus-file-mix-with-envs 3 chan 0: ~A" (sample 100 ind 0)))
+ (snd-display ";mus-file-mix-with-envs 3 chan 0: ~A" (sample 100 ind 0)))
(if (fneq (sample 100 ind 1) -0.41)
- (snd-display #__line__ ";mus-file-mix-with-envs 3 chan 1: ~A" (sample 100 ind 1))))
- (snd-display #__line__ ";mus-file-mix-with envs 3: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 3 chan 1: ~A" (sample 100 ind 1))))
+ (snd-display ";mus-file-mix-with envs 3: no output? ~A" (map short-file-name (sounds)))))
(with-sound ("mix.snd" 2 :clipped #f)
(let ((rd (vector (make-readin "flat.snd")))
@@ -20393,10 +19940,10 @@ EDITS: 2
(if (sound? ind)
(begin
(if (fneq (sample 100 ind 0) 0.03)
- (snd-display #__line__ ";mus-file-mix-with-envs 4 chan 0: ~A" (sample 100 ind 0)))
+ (snd-display ";mus-file-mix-with-envs 4 chan 0: ~A" (sample 100 ind 0)))
(if (fneq (sample 100 ind 1) 0.36)
- (snd-display #__line__ ";mus-file-mix-with-envs 4 chan 1: ~A" (sample 100 ind 1))))
- (snd-display #__line__ ";mus-file-mix-with envs 4: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 4 chan 1: ~A" (sample 100 ind 1))))
+ (snd-display ";mus-file-mix-with envs 4: no output? ~A" (map short-file-name (sounds)))))
(with-sound ("mix.snd" 1 :clipped #f)
(let ((rd (vector (make-readin "flat.snd")
@@ -20408,8 +19955,8 @@ EDITS: 2
(let ((ind (find-sound "mix.snd")))
(if (sound? ind)
(if (fneq (sample 100 ind) 0.39)
- (snd-display #__line__ ";mus-file-mix-with-envs 5: ~A" (sample 100 ind)))
- (snd-display #__line__ ";mus-file-mix-with envs 5: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 5: ~A" (sample 100 ind)))
+ (snd-display ";mus-file-mix-with envs 5: no output? ~A" (map short-file-name (sounds)))))
(with-sound ("flat.snd")
(outa 99 0.5)
@@ -20419,8 +19966,7 @@ EDITS: 2
(require snd-jcrev.scm)
(with-sound ("mix.snd" :reverb jc-reverb)
- (let ((rd (vector (make-readin "flat.snd"))))
- (mus-file-mix-with-envs rd 0 1000 (float-vector 0.5) (float-vector 0.1) #f #f #f)))
+ (mus-file-mix-with-envs (vector (make-readin "flat.snd")) 0 1000 (float-vector 0.5) (float-vector 0.1) #f #f #f))
(with-sound ("mix.snd" :reverb jc-reverb)
(let* ((rd (vector (make-readin "flat.snd")
@@ -20432,8 +19978,8 @@ EDITS: 2
(let ((ind (find-sound "mix.snd")))
(if (sound? ind)
(if (fneq (sample 200 ind) 0.5)
- (snd-display #__line__ ";mus-file-mix-with-envs 7: ~A" (sample 200 ind)))
- (snd-display #__line__ ";mus-file-mix-with envs 7: no output? ~A" (map short-file-name (sounds)))))
+ (snd-display ";mus-file-mix-with-envs 7: ~A" (sample 200 ind)))
+ (snd-display ";mus-file-mix-with envs 7: no output? ~A" (map short-file-name (sounds)))))
(for-each close-sound (sounds))
(delete-file "flat.snd")
@@ -20443,9 +19989,9 @@ EDITS: 2
(let* ((gen (make-phase-vocoder #f 512 4 256 1.0 #f #f #f))
(val (catch #t (lambda () (phase-vocoder gen)) (lambda args (car args)))))
- (if (fneq val 0.0) (snd-display #__line__ ";simple no-in pv call: ~A" val))
+ (if (fneq val 0.0) (snd-display ";simple no-in pv call: ~A" val))
(set! val (catch #t (lambda () (set! gen (make-phase-vocoder :fft-size 1234))) (lambda args (car args))))
- (if (not (eq? val 'out-of-range)) (snd-display #__line__ ";pv bad fft: ~A" val))
+ (if (not (eq? val 'out-of-range)) (snd-display ";pv bad fft: ~A" val))
)
(let* ((ind (open-sound "oboe.snd"))
@@ -20457,63 +20003,62 @@ EDITS: 2
#f ;no change to edits
#f ;no change to synthesis
)))
- (if (not (phase-vocoder? pv)) (snd-display #__line__ ";~A not phase-vocoder?" pv))
+ (if (not (phase-vocoder? pv)) (snd-display ";~A not phase-vocoder?" pv))
(print-and-check pv
"phase-vocoder"
"phase-vocoder outctr: 128, interp: 128, filptr: 0, N: 512, D: 128, in_data: nil")
(let ((val (let ((pv (make-phase-vocoder))) (set! (mus-location pv) 120) (mus-location pv))))
- (if (not (= val 120)) (snd-display #__line__ ";pv set outctr: ~A" val)))
+ (if (not (= val 120)) (snd-display ";pv set outctr: ~A" val)))
(select-sound ind)
(map-channel (lambda (val) (phase-vocoder pv)))
(float-vector-set! (phase-vocoder-amp-increments pv) 0 .1)
(if (fneq ((phase-vocoder-amp-increments pv) 0) .1)
- (snd-display #__line__ ";set phase-vocoder-amp-increments: ~A?" ((phase-vocoder-amp-increments pv) 0)))
+ (snd-display ";set phase-vocoder-amp-increments: ~A?" ((phase-vocoder-amp-increments pv) 0)))
(float-vector-set! (phase-vocoder-amps pv) 0 .1)
(if (fneq ((phase-vocoder-amps pv) 0) .1)
- (snd-display #__line__ ";set phase-vocoder-amps: ~A?" ((phase-vocoder-amps pv) 0)))
+ (snd-display ";set phase-vocoder-amps: ~A?" ((phase-vocoder-amps pv) 0)))
(float-vector-set! (phase-vocoder-phases pv) 0 .1)
(if (fneq ((phase-vocoder-phases pv) 0) .1)
- (snd-display #__line__ ";set phase-vocoder-phases: ~A?" ((phase-vocoder-phases pv) 0)))
+ (snd-display ";set phase-vocoder-phases: ~A?" ((phase-vocoder-phases pv) 0)))
(float-vector-set! (phase-vocoder-phase-increments pv) 0 .1)
(if (fneq ((phase-vocoder-phase-increments pv) 0) .1)
- (snd-display #__line__ ";set phase-vocoder-phase-increments: ~A?" ((phase-vocoder-phase-increments pv) 0)))
+ (snd-display ";set phase-vocoder-phase-increments: ~A?" ((phase-vocoder-phase-increments pv) 0)))
(float-vector-set! (phase-vocoder-freqs pv) 0 .1)
(if (fneq ((phase-vocoder-freqs pv) 0) .1)
- (snd-display #__line__ ";set phase-vocoder-freqs: ~A?" ((phase-vocoder-freqs pv) 0)))
+ (snd-display ";set phase-vocoder-freqs: ~A?" ((phase-vocoder-freqs pv) 0)))
(undo 1)
(free-sampler reader)
- (let ((lastphases (make-float-vector 512))
- (diffs (make-float-vector 512)))
- (define (efunc v)
- ;; new editing func changes pitch
- (let ((N (mus-length v)) ;mus-increment => interp, mus-data => in-data
- (D (mus-hop v))
- (freqs (phase-vocoder-freqs v)))
- (copy freqs diffs)
- (float-vector-subtract! diffs lastphases)
- (copy freqs lastphases)
- (let ((N2 (floor (/ N 2)))
- (pscl (/ 1.0 D))
- (kscl (/ pi2 N)))
- (do ((k 0 (+ k 1))
- (kx 0.0 (+ kx kscl)))
- ((= k N2))
- (float-vector-set! freqs k (* 0.5 (+ (* pscl (remainder (float-vector-ref diffs k) pi2)) kx)))))
- #f))
- (set! reader (make-sampler 0))
- (set! pv (make-phase-vocoder (lambda (dir) (next-sample reader))
- 512 4 128 1.0
- #f ;no change to analysis
- efunc
- #f ; no change to synthesis
- ))
- (map-channel (lambda (val) (phase-vocoder pv))))
+ (set! reader (make-sampler 0))
+ (set! pv (make-phase-vocoder (lambda (dir) (next-sample reader))
+ 512 4 128 1.0
+ #f ;no change to analysis
+ (let ((lastphases (make-float-vector 512))
+ (diffs (make-float-vector 512)))
+ (lambda (v)
+ ;; new editing func changes pitch
+ (let ((N (mus-length v)) ;mus-increment => interp, mus-data => in-data
+ (D (mus-hop v))
+ (freqs (phase-vocoder-freqs v)))
+ (copy freqs diffs)
+ (float-vector-subtract! diffs lastphases)
+ (copy freqs lastphases)
+ (do ((N2 (floor (/ N 2)))
+ (pscl (/ 1.0 D))
+ (kscl (/ pi2 N))
+ (k 0 (+ k 1))
+ (kx 0.0 (+ kx kscl)))
+ ((= k N2))
+ (float-vector-set! freqs k (* 0.5 (+ (* pscl (remainder (float-vector-ref diffs k) pi2)) kx))))
+ #f)))
+ #f ; no change to synthesis
+ ))
+ (map-channel (lambda (val) (phase-vocoder pv)))
(undo 1)
(free-sampler reader)
(set! reader (make-sampler 0))
(set! pv (make-phase-vocoder (lambda (dir) (next-sample reader))
- 512 4 (* 128 2) 1.0
+ 512 4 256 1.0
#f ;no change to analysis
#f ;no change to edits
#f ;no change to synthesis
@@ -20529,7 +20074,7 @@ EDITS: 2
(outcalls 0))
(set! reader (make-sampler 0))
(set! pv (make-phase-vocoder (lambda (dir) (next-sample reader))
- 512 4 (* 128 2) 1.0
+ 512 4 256 1.0
(lambda (v infunc)
(set! incalls (+ incalls 1))
#t)
@@ -20546,34 +20091,34 @@ EDITS: 2
(free-sampler reader)
(if (or (= incalls 0)
(= outcalls 0))
- (snd-display #__line__ ";phase-vocoder incalls: ~A, outcalls: ~A" incalls outcalls)))
+ (snd-display ";phase-vocoder incalls: ~A, outcalls: ~A" incalls outcalls)))
(let ((tag (catch #t
(lambda () (make-phase-vocoder #f 512 4 256 1.0 (lambda (a b c) #f) #f #f))
(lambda args args))))
- (if (not (eq? (car tag) 'bad-arity)) (snd-display #__line__ ";make-phase-vocoder bad analyze func: ~A" tag)))
+ (if (not (eq? (car tag) 'bad-arity)) (snd-display ";make-phase-vocoder bad analyze func: ~A" tag)))
(let ((tag (catch #t
(lambda () (make-phase-vocoder #f 512 4 256 1.0 (lambda (a b) 0.0) (lambda (a b c) #f) #f))
(lambda args args))))
- (if (not (eq? (car tag) 'bad-arity)) (snd-display #__line__ ";make-phase-vocoder bad edit func: ~A" tag)))
+ (if (not (eq? (car tag) 'bad-arity)) (snd-display ";make-phase-vocoder bad edit func: ~A" tag)))
(let ((tag (catch #t
(lambda () (make-phase-vocoder #f 512 4 256 1.0 (lambda (a b) 0.0) (lambda (a) #f) (lambda (a b) 0)))
(lambda args args))))
- (if (not (eq? (car tag) 'bad-arity)) (snd-display #__line__ ";make-phase-vocoder bad synthesize func: ~A" tag)))
- (let ((geno (make-phase-vocoder (lambda (dir) 0.0))))
- (let ((genx (make-phase-vocoder :input (lambda (dir) 0.0))))
- (if (equal? geno genx) (snd-display #__line__ ";phase-vocoder equal? ~A ~A" geno genx))
- (if (fneq (mus-frequency genx) 1.0) (snd-display #__line__ ";mus-frequency phase-vocoder: ~A" (mus-frequency genx)))
- (set! (mus-frequency genx) 2.0)
- (if (fneq (mus-frequency genx) 2.0) (snd-display #__line__ ";set mus-frequency phase-vocoder: ~A" (mus-frequency genx)))
- (if (fneq (mus-increment genx) 128) (snd-display #__line__ ";mus-increment phase-vocoder: ~A" (mus-increment genx)))
- (set! (mus-increment genx) 256)
- (if (fneq (mus-increment genx) 256) (snd-display #__line__ ";set mus-increment phase-vocoder: ~A" (mus-increment genx)))
- (if (not (= (mus-hop genx) 128)) (snd-display #__line__ ";phase vocoder hop: ~A" (mus-hop genx)))
- (set! (mus-hop genx) 64)
- (if (not (= (mus-hop genx) 64)) (snd-display #__line__ ";set phase vocoder hop: ~A" (mus-hop genx)))
- (if (not (= (mus-length genx) 512)) (snd-display #__line__ ";phase vocoder length: ~A" (mus-length genx)))
- (let ((genxx genx))
- (if (not (equal? genx genxx)) (snd-display #__line__ ";phase-vocoder equal: ~A ~A" genxx genx)))))
+ (if (not (eq? (car tag) 'bad-arity)) (snd-display ";make-phase-vocoder bad synthesize func: ~A" tag)))
+ (let* ((geno (make-phase-vocoder (lambda (dir) 0.0)))
+ (genx (make-phase-vocoder :input (lambda (dir) 0.0))))
+ (if (equal? geno genx) (snd-display ";phase-vocoder equal? ~A ~A" geno genx))
+ (if (fneq (mus-frequency genx) 1.0) (snd-display ";mus-frequency phase-vocoder: ~A" (mus-frequency genx)))
+ (set! (mus-frequency genx) 2.0)
+ (if (fneq (mus-frequency genx) 2.0) (snd-display ";set mus-frequency phase-vocoder: ~A" (mus-frequency genx)))
+ (if (fneq (mus-increment genx) 128) (snd-display ";mus-increment phase-vocoder: ~A" (mus-increment genx)))
+ (set! (mus-increment genx) 256)
+ (if (fneq (mus-increment genx) 256) (snd-display ";set mus-increment phase-vocoder: ~A" (mus-increment genx)))
+ (if (not (= (mus-hop genx) 128)) (snd-display ";phase vocoder hop: ~A" (mus-hop genx)))
+ (set! (mus-hop genx) 64)
+ (if (not (= (mus-hop genx) 64)) (snd-display ";set phase vocoder hop: ~A" (mus-hop genx)))
+ (if (not (= (mus-length genx) 512)) (snd-display ";phase vocoder length: ~A" (mus-length genx)))
+ (let ((genxx genx))
+ (if (not (equal? genx genxx)) (snd-display ";phase-vocoder equal: ~A ~A" genxx genx))))
(close-sound ind))
(let ((old-fudge *mus-float-equal-fudge-factor*) ; some phase-vocoder tests
@@ -20589,9 +20134,9 @@ EDITS: 2
(let ((v (channel->float-vector 0 50))
(v0 (float-vector 0.00022 0.00130 0.00382 0.00810 0.01381 0.01960 0.02301 0.02143 0.01421 0.00481 0.00000 0.00396 0.01168 0.01231 0.00413 0.00018 0.00704 0.00984 0.00189 0.00197 0.00881 0.00290 0.00151 0.00781 0.00091 0.00404 0.00498 0.00047 0.00641 -0.00017 0.00590 0.00006 0.00492 0.00031 0.00380 0.00052 0.00290 0.00066 0.00219 0.00074 0.00164 0.00076 0.00123 0.00074 0.00092 0.00067 0.00069 0.00058 0.00052 0.00048)))
- (if (and (not (mus-arrays-equal? v v0))
- (not (mus-arrays-equal? (float-vector-scale! v -1.0) v0)))
- (snd-display #__line__ ";pv 1 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (if (not (or (mus-arrays-equal? v v0)
+ (mus-arrays-equal? (float-vector-scale! v -1.0) v0)))
+ (snd-display ";pv 1 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(undo)
@@ -20602,7 +20147,7 @@ EDITS: 2
(let ((v (channel->float-vector 0 50))
(v0 (float-vector 0.00044 0.00255 0.00705 0.01285 0.01595 0.01177 0.00281 0.00069 0.00782 0.00702 0.00001 0.00584 0.00385 0.00138 0.00547 0.00035 0.00494 0.00082 0.00305 0.00310 0.00003 0.00380 0.00245 -0.00019 0.00159 0.00348 0.00268 0.00087 -0.00020 -0.00036 -0.00010 0.00012 0.00036 0.00057 0.00075 0.00089 0.00099 0.00105 0.00108 0.00107 0.00104 0.00099 0.00094 0.00087 0.00080 0.00073 0.00066 0.00059 0.00053 0.00047)))
(if (not (mus-arrays-equal? v v0))
- (snd-display #__line__ ";pv 2 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (snd-display ";pv 2 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(undo)
@@ -20613,7 +20158,7 @@ EDITS: 2
(let ((v (channel->float-vector 0 50))
(v0 (float-vector 0.00011 0.00065 0.00195 0.00428 0.00785 0.01266 0.01845 0.02456 0.02989 0.03305 0.03267 0.02803 0.01970 0.00993 0.00228 0.00009 0.00441 0.01250 0.01858 0.01759 0.00975 0.00160 0.00079 0.00795 0.01454 0.01201 0.00325 0.00024 0.00716 0.01261 0.00704 0.00003 0.00384 0.00962 0.00620 0.00027 0.00196 0.00655 0.00492 0.00040 0.00101 0.00448 0.00375 0.00041 0.00053 0.00305 0.00273 0.00033 0.00029 0.00204)))
(if (not (mus-arrays-equal? v v0))
- (snd-display #__line__ ";pv 3 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (snd-display ";pv 3 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(undo)
@@ -20624,7 +20169,7 @@ EDITS: 2
(let ((v (channel->float-vector 0 100))
(v0 (float-vector 0.00005 0.00033 0.00098 0.00214 0.00392 0.00633 0.00923 0.01228 0.01495 0.01652 0.01633 0.01401 0.00985 0.00497 0.00114 0.00004 0.00221 0.00625 0.00929 0.00880 0.00488 0.00080 0.00040 0.00397 0.00727 0.00601 0.00162 0.00012 0.00358 0.00630 0.00352 0.00002 0.00217 0.00552 0.00300 -0.00008 0.00299 0.00479 0.00083 0.00098 0.00457 0.00175 0.00033 0.00412 0.00172 0.00039 0.00399 0.00087 0.00118 0.00356 -0.00016 0.00280 0.00169 0.00051 0.00326 -0.00030 0.00301 0.00040 0.00184 0.00144 0.00078 0.00213 0.00015 0.00242 -0.00017 0.00240 -0.00038 0.00230 -0.00049 0.00214 -0.00053 0.00194 -0.00051 0.00172 -0.00047 0.00150 -0.00040 0.00127 -0.00033 0.00106 -0.00025 0.00086 -0.00019 0.00068 -0.00013 0.00052 -0.00008 0.00039 -0.00005 0.00027 -0.00002 0.00017 -0.00001 0.00009 -0.00000 0.00003 -0.00000 -0.00002 -0.00001 -0.00006)))
(if (not (mus-arrays-equal? v v0))
- (snd-display #__line__ ";pv 4 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (snd-display ";pv 4 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(undo)
@@ -20637,7 +20182,7 @@ EDITS: 2
(let ((v (channel->float-vector 0 100))
(v0 (float-vector 0.00100 0.00598 0.01756 0.03708 0.06286 0.08826 0.10172 0.09163 0.05680 0.01564 -0.00075 0.02124 0.05164 0.04457 0.00861 0.00529 0.03648 0.02747 -0.00875 0.00936 0.02402 -0.00553 -0.00090 -0.02262 -0.00221 0.06633 -0.03229 0.01861 0.05228 0.00672 0.00885 0.01442 -0.00484 -0.02293 -0.01893 -0.02256 -0.10229 -0.22474 0.31110 0.07597 0.07127 0.03670 0.02583 0.03173 0.02260 0.01550 0.01485 0.03212 -0.00966 0.00779 -0.00964 0.00698 0.01100 0.00468 0.00107 0.00517 0.00469 0.00131 0.00058 0.00530 0.00582 -0.00652 0.00011 0.00000 -0.00000 -0.00000 -0.00000 0.00000 -0.00000 0.00000 0.00000 -0.00000 -0.00000 -0.00000 -0.00000 -0.00000 -0.00000 0.00000 -0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 -0.00000 -0.00000 -0.00000 0.00000 0.00000 0.00000 -0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000)))
(if (not (mus-arrays-equal? v v0))
- (snd-display #__line__ ";pv 5 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (snd-display ";pv 5 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(undo)
@@ -20650,7 +20195,7 @@ EDITS: 2
(let ((v (channel->float-vector 0 100))
(v0 (float-vector 0.00332 0.01977 0.05805 0.12252 0.20738 0.29035 0.33291 0.29696 0.18017 0.04637 -0.00003 0.08250 0.18618 0.15495 0.02775 0.02252 0.13597 0.09767 -0.03116 0.05301 0.10256 -0.05005 0.01966 0.06176 -0.04418 0.04118 -0.11409 -0.04115 -0.05157 -0.11409 0.07815 -0.08155 -0.00536 0.02090 -0.18804 -0.10686 -0.11931 -0.42989 0.39009 0.03157 0.14253 0.05984 0.05439 0.00764 0.02636 -0.02799 -0.01346 -0.01011 -0.04925 -0.02896 -0.07812 -0.07880 -0.11338 -0.13133 -0.41421 0.38140 0.08676 0.07712 0.00983 0.03731 0.01585 0.00108 0.00101 0.00282 -0.01106 -0.00403 -0.02165 -0.02054 -0.02452 -0.02382 -0.03213 -0.02693 -0.03734 -0.03978 -0.04879 -0.07504 -0.09597 -0.31426 0.32995 0.13460 0.04120 0.05029 0.01900 0.02517 0.01163 0.01294 0.00827 0.00576 0.00640 0.00141 0.00489 -0.00057 0.00301 -0.00089 0.00099 -0.00000 0.00000 -0.00000 -0.00000 -0.00000)))
(if (not (mus-arrays-equal? v v0))
- (snd-display #__line__ ";pv 6 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
+ (snd-display ";pv 6 diff: ~A" (float-vector-peak (float-vector-subtract! v v0)))))
(close-sound ind)
(set! *mus-float-equal-fudge-factor* old-fudge))
@@ -20660,28 +20205,30 @@ EDITS: 2
(let ((N2 (floor (/ size 2))))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
- (lastphases (make-float-vector N2))
(two-pi (* 2 pi))
- (osc (make-oscil 1000.0))
(amps #f) (paincrs #f) (ppincrs #f) (phases #f) (freqs #f))
- (define (ifunc dir)
- (oscil osc))
-
- (define (efunc c)
- (let* ((D (floor (/ size 4))) ; overlap = 4
- (pscl (/ 1.0 D))
- (kscl (/ two-pi size)))
- (do ((k 0 (+ k 1))
- (ks 0.0 (+ ks kscl)))
- ((= k N2))
- (let* ((freq (freqs k))
- (diff (- freq (lastphases k))))
- (set! (lastphases k) freq)
- (if (> diff pi) (set! diff (- diff two-pi)))
- (if (< diff (- pi)) (set! diff (+ diff two-pi)))
- (set! (freqs k) (+ (* diff pscl) ks))))
- #f))
+ (define ifunc
+ (let ((osc (make-oscil 1000.0)))
+ (lambda (dir)
+ (oscil osc))))
+
+ (define efunc
+ (let ((lastphases (make-float-vector N2)))
+ (lambda (c)
+ (let* ((D (floor (/ size 4))) ; overlap = 4
+ (pscl (/ 1.0 D))
+ (kscl (/ two-pi size)))
+ (do ((k 0 (+ k 1))
+ (ks 0.0 (+ ks kscl)))
+ ((= k N2))
+ (let* ((freq (freqs k))
+ (diff (- freq (lastphases k))))
+ (set! (lastphases k) freq)
+ (if (> diff pi) (set! diff (- diff two-pi)))
+ (if (< diff (- pi)) (set! diff (+ diff two-pi)))
+ (set! (freqs k) (+ (* diff pscl) ks))))
+ #f))))
(define (sfunc c)
(float-vector-add! amps paincrs)
@@ -20713,20 +20260,20 @@ EDITS: 2
(do ((i 55 (+ i 1)))
((= i 65))
(if (> (abs (- (v i) .196)) .01)
- (snd-display #__line__ ";pvoc-d at ~D: ~A~%" i (v i))))
+ (snd-display ";pvoc-d at ~D: ~A~%" i (v i))))
(do ((i 75 (+ i 1)))
((= i 85))
- (if (> (abs (- (v i) -.196)) .01)
- (snd-display #__line__ ";pvoc-d at ~D: ~A~%" i (v i)))))
+ (if (> (abs (+ (v i) .196)) .01)
+ (snd-display ";pvoc-d at ~D: ~A~%" i (v i)))))
)
(let ((ind (open-sound "oboe.snd")))
(let ((gen (make-moog-filter 500.0 .1)))
- (if (fneq 500.0 (moog-frequency gen)) (snd-display #__line__ ";moog freq: ~A" (moog-frequency gen))) ; moog-frequency is a separate function
- (if (fneq .1 (gen 'Q)) (snd-display #__line__ ";moog Q: ~A" (gen 'Q)))
-; (if (not (float-vector? (gen 's))) (snd-display #__line__ ";moog state: ~A" (gen 's)))
- (if (fneq 0.0 (gen 'y)) (snd-display #__line__ ";moog A? ~A" (gen 'y)))
- (if (fneq -0.861 (gen 'fc)) (snd-display #__line__ ";moog freqtable: ~A" (gen 'fc)))
+ (if (fneq 500.0 (moog-frequency gen)) (snd-display ";moog freq: ~A" (moog-frequency gen))) ; moog-frequency is a separate function
+ (if (fneq .1 (gen 'Q)) (snd-display ";moog Q: ~A" (gen 'Q)))
+; (if (not (float-vector? (gen 's))) (snd-display ";moog state: ~A" (gen 's)))
+ (if (fneq 0.0 (gen 'y)) (snd-display ";moog A? ~A" (gen 'y)))
+ (if (fneq -0.861 (gen 'fc)) (snd-display ";moog freqtable: ~A" (gen 'fc)))
(let ((vals (make-float-vector 20)))
(set! (vals 0) (moog-filter gen 1.0))
(do ((i 1 (+ i 1)))
@@ -20734,33 +20281,33 @@ EDITS: 2
(set! (vals i) (moog-filter gen 0.0)))
(if (not (vequal vals (float-vector 0.0 0.0 0.0025 0.0062 0.0120 0.0198 0.0292 0.0398 0.0510 0.0625
0.0739 0.0847 0.0946 0.1036 0.1113 0.1177 0.1228 0.1266 0.1290 0.1301)))
- (snd-display #__line__ ";moog output: ~A" vals))))
+ (snd-display ";moog output: ~A" vals))))
(close-sound ind))
- (let ((gen (make-ssb-am 440.0))
- (v0 (make-float-vector 10))
- (gen1 (make-ssb-am 440.0))
- (v1 (make-float-vector 10)))
+ (let ((gen (make-ssb-am 440.0)))
(print-and-check gen
"ssb-am"
"ssb-am shift: up, sin/cos: 439.999975 Hz (0.000000 radians), order: 41"
"ssb-am shift: up, sin/cos: 440.000000 Hz (0.000000 radians), order: 41"
"ssb-am shift: up, sin/cos: 439.999969 Hz (0.000000 radians), order: 41")
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v0 i) (ssb-am gen)))
- (fill-float-vector v1 (if (ssb-am? gen1) (ssb-am gen1) -1.0))
- (if (not (vequal v0 v1)) (snd-display #__line__ ";map ssb-am: ~A ~A" v0 v1))
- (if (not (ssb-am? gen)) (snd-display #__line__ ";~A not ssb-am?" gen))
- (if (fneq (mus-phase gen) 1.253787) (snd-display #__line__ ";ssb-am phase: ~F?" (mus-phase gen)))
- (if (fneq (mus-frequency gen) 440.0) (snd-display #__line__ ";ssb-am frequency: ~F?" (mus-frequency gen)))
- (if (not (= (mus-order gen) 41)) (snd-display #__line__ ";ssb-am order: ~F?" (mus-order gen)))
- (if (not (= (mus-length gen) 41)) (snd-display #__line__ ";ssb-am length: ~D?" (mus-length gen)))
- (if (not (= (mus-interp-type gen) mus-interp-none)) (snd-display #__line__ ";ssb-am interp type: ~D?" (mus-interp-type gen)))
- (if (fneq (mus-xcoeff gen 0) -0.00124) (snd-display #__line__ ";ssb-am xcoeff 0: ~A" (mus-xcoeff gen 0)))
- (if (fneq (mus-xcoeff gen 1) 0.0) (snd-display #__line__ ";ssb-am xcoeff 1: ~A" (mus-xcoeff gen 1)))
- ; (if (not (float-vector? (mus-data gen))) (snd-display #__line__ ";mus-data ssb-am: ~A" (mus-data gen)))
- ; (if (not (float-vector? (mus-xcoeffs gen))) (snd-display #__line__ ";mus-xcoeffs ssb-am: ~A" (mus-xcoeffs gen)))
+ (let ((gen1 (make-ssb-am 440.0))
+ (v0 (make-float-vector 10))
+ (v1 (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v0 i) (ssb-am gen)))
+ (fill-float-vector v1 (if (ssb-am? gen1) (ssb-am gen1) -1.0))
+ (if (not (vequal v0 v1)) (snd-display ";map ssb-am: ~A ~A" v0 v1)))
+ (if (not (ssb-am? gen)) (snd-display ";~A not ssb-am?" gen))
+ (if (fneq (mus-phase gen) 1.253787) (snd-display ";ssb-am phase: ~F?" (mus-phase gen)))
+ (if (fneq (mus-frequency gen) 440.0) (snd-display ";ssb-am frequency: ~F?" (mus-frequency gen)))
+ (if (not (= (mus-order gen) 41)) (snd-display ";ssb-am order: ~F?" (mus-order gen)))
+ (if (not (= (mus-length gen) 41)) (snd-display ";ssb-am length: ~D?" (mus-length gen)))
+ (if (not (= (mus-interp-type gen) mus-interp-none)) (snd-display ";ssb-am interp type: ~D?" (mus-interp-type gen)))
+ (if (fneq (mus-xcoeff gen 0) -0.00124) (snd-display ";ssb-am xcoeff 0: ~A" (mus-xcoeff gen 0)))
+ (if (fneq (mus-xcoeff gen 1) 0.0) (snd-display ";ssb-am xcoeff 1: ~A" (mus-xcoeff gen 1)))
+ ; (if (not (float-vector? (mus-data gen))) (snd-display ";mus-data ssb-am: ~A" (mus-data gen)))
+ ; (if (not (float-vector? (mus-xcoeffs gen))) (snd-display ";mus-xcoeffs ssb-am: ~A" (mus-xcoeffs gen)))
;; these apparently aren't handled in clm2xen
)
@@ -20776,7 +20323,7 @@ EDITS: 2
(o2o (ssb-am-1 o2 inval)))
(if (fneq o1o o2o)
(begin
- (snd-display #__line__ ";ssb-am (up): ~A ~A at ~A" o1o o2o i)
+ (snd-display ";ssb-am (up): ~A ~A at ~A" o1o o2o i)
(set! happy #f))))))
(let ((o1 (make-ssb-am 400.0))
@@ -20790,7 +20337,7 @@ EDITS: 2
(o2o (ssb-am-1 o2 inval fmval)))
(if (fneq o1o o2o)
(begin
- (snd-display #__line__ ";ssb-am + fm (up): ~A ~A at ~A" o1o o2o i)
+ (snd-display ";ssb-am + fm (up): ~A ~A at ~A" o1o o2o i)
(set! happy #f))))))
(let ((o1 (make-ssb-am -100.0))
@@ -20803,7 +20350,7 @@ EDITS: 2
(o2o (ssb-am-1 o2 inval)))
(if (fneq o1o o2o)
(begin
- (snd-display #__line__ ";ssb-am (down): ~A ~A at ~A" o1o o2o i)
+ (snd-display ";ssb-am (down): ~A ~A at ~A" o1o o2o i)
(set! happy #f))))))
(let ((o1 (make-ssb-am 1000.0 100))
@@ -20816,7 +20363,7 @@ EDITS: 2
(o2o (ssb-am-1 o2 inval)))
(if (fneq o1o o2o)
(begin
- (snd-display #__line__ ";ssb-am (down): ~A ~A at ~A" o1o o2o i)
+ (snd-display ";ssb-am (down): ~A ~A at ~A" o1o o2o i)
(set! happy #f))))))
(let ((index (open-sound "pistol.snd"))
@@ -20825,16 +20372,16 @@ EDITS: 2
(let ((scl (maxamp)))
(convolve-with "oboe.snd" scl index 0 0)
(if (ffneq (maxamp) scl)
- (snd-display #__line__ ";convolve-with amps: ~A ~A" (maxamp) scl)))
+ (snd-display ";convolve-with amps: ~A ~A" (maxamp) scl)))
(revert-sound index)
(agc)
- (if (fneq (maxamp index 0) 1.29) (snd-display #__line__ ";agc: ~A" (maxamp index 0)))
+ (if (fneq (maxamp index 0) 1.29) (snd-display ";agc: ~A" (maxamp index 0)))
(close-sound index)
(let ((reader (make-sampler 0 "pistol.snd")))
(do ((i 0 (+ i 1)))
((= i 10))
(if (fneq (data i) (next-sample reader))
- (snd-display #__line__ ";external reader trouble")))
+ (snd-display ";external reader trouble")))
(free-sampler reader)))
(let ((make-procs (list
@@ -20891,28 +20438,28 @@ EDITS: 2
(for-each
(lambda (make runp ques arg name)
(let ((gen (make)))
- (if (not (ques gen)) (snd-display #__line__ ";~A: ~A -> ~A?" name make gen))
+ (if (not (ques gen)) (snd-display ";~A: ~A -> ~A?" name make gen))
(let ((tag (catch #t (lambda () (if arg (runp gen arg) (runp gen))) (lambda args args))))
- (if (and (not (number? tag))
- (not (float-vector? tag)))
- (snd-display #__line__ ";~A: ~A ~A ~A: ~A" name runp gen arg tag)))
+ (if (not (or (number? tag)
+ (float-vector? tag)))
+ (snd-display ";~A: ~A ~A ~A: ~A" name runp gen arg tag)))
(for-each
(lambda (func genname)
(let ((tag (catch #t (lambda () (func #f)) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";generic func with #f: (~A #f) -> ~A" genname tag)))
+ (snd-display ";generic func with #f: (~A #f) -> ~A" genname tag)))
(let ((g1 (make-oscil))
(g2 (make-one-pole .1 .9)))
(let ((tag (catch #t (lambda () (func g1)) (lambda args (car args)))))
(if (and (symbol? tag)
(not (eq? tag 'wrong-type-arg))
(not (eq? tag 'mus-error)))
- (snd-display #__line__ ";generic ~A of oscil: ~A" genname tag)))
+ (snd-display ";generic ~A of oscil: ~A" genname tag)))
(let ((tag (catch #t (lambda () (func g2)) (lambda args (car args)))))
(if (and (symbol? tag)
(not (eq? tag 'wrong-type-arg))
(not (eq? tag 'mus-error)))
- (snd-display #__line__ ";generic ~A of delay: ~A" genname tag))))
+ (snd-display ";generic ~A of delay: ~A" genname tag))))
(let ((tag (catch #t (lambda () (func gen)) (lambda args (car args)))))
(if (and (not (symbol? tag))
(dilambda? func)
@@ -20922,7 +20469,7 @@ EDITS: 2
(if (and (symbol? tag1)
(not (eq? tag1 'mus-error))
(not (eq? tag1 'out-of-range)))
- (snd-display #__line__ ";~A set ~A ~A ~A -> ~A" name genname gen tag tag1))))))
+ (snd-display ";~A set ~A ~A ~A -> ~A" name genname gen tag tag1))))))
generic-procs generic-names)
(mus-reset gen)))
make-procs gen-procs ques-procs gen-args func-names)
@@ -20978,7 +20525,9 @@ EDITS: 2
(for-each
(lambda (make runp name)
(let ((gen (make))
- (data (make-float-vector 10)))
+ (data (make-float-vector 10))
+ (eloc (memq name '(env locsig)))
+ (pssb (memq name '(polyshape ssb-am))))
(set! (data 0) (runp gen 1.0))
(do ((i 1 (+ i 1)))
((= i 10))
@@ -20986,110 +20535,107 @@ EDITS: 2
(do ((k 0 (+ k 1)))
((= k 2))
(mus-reset gen)
- (if (and (not (eq? name 'env))
- (not (eq? name 'locsig)))
- (let ((not-zero #f))
- (let ((first-val (if (= k 0) (runp gen 1.0) (mus-apply gen 1.0 0.0))))
- (if (not (= (data 0) 0.0)) (set! not-zero #t))
- (if (fneq (data 0) first-val)
- (snd-display #__line__ ";[~A] ~A: ~A ~A ~A" (if (= k 0) 'run 'apply) name 0 (data 0) first-val)))
- (do ((i 1 (+ i 1)))
- ((= i 10))
- (let ((old-val (data i))
- (new-val (if (= k 0) (runp gen 0.0) (mus-apply gen 0.0 0.0))))
- (if (not (= old-val 0.0)) (set! not-zero #t))
- (if (fneq old-val new-val)
- (snd-display #__line__ ";[~A] ~A: ~A ~A ~A" (if (= k 0) 'run 'apply) name i old-val new-val))))
- (if (and (not (eq? name 'polyshape))
- (not (eq? name 'ssb-am))
- (not not-zero))
- (snd-display #__line__ ";~A not much of a reset test!" name)))))))
+ (unless eloc
+ (let ((not-zero #f)
+ (k0 (= k 0))
+ (ra (if (= k 0) 'run 'apply)))
+ (let ((first-val (if k0 (runp gen 1.0) (mus-apply gen 1.0 0.0))))
+ (if (not (= (data 0) 0.0)) (set! not-zero #t))
+ (if (fneq (data 0) first-val)
+ (snd-display ";[~A] ~A: ~A ~A ~A" ra name 0 (data 0) first-val)))
+ (do ((i 1 (+ i 1)))
+ ((= i 10))
+ (let ((old-val (data i))
+ (new-val (if k0 (runp gen 0.0) (mus-apply gen 0.0 0.0))))
+ (if (not (= old-val 0.0)) (set! not-zero #t))
+ (if (fneq old-val new-val)
+ (snd-display ";[~A] ~A: ~A ~A ~A" ra name i old-val new-val))))
+ (if (not (or pssb not-zero))
+ (snd-display ";~A not much of a reset test!" name)))))))
make-procs gen-procs func-names))
- (if (and all-args (= clmtest 0))
- (begin
- (for-each
- (lambda (make runp)
- (catch #t
- (lambda ()
- (let ((gen (make)))
- ;; run args
- (for-each
- (lambda (arg1)
- ;; how did this ever work??
- (catch #t (lambda () (runp gen arg1)) (lambda args (car args)))
- (for-each
- (lambda (arg2)
- (catch #t (lambda () (runp gen arg1 arg2)) (lambda args (car args))))
- (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
- () 3 4 2 8 16 32 64 (make-vector 0) '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
- )))
- (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
- () 3 4 2 8 16 32 64 (make-vector 0) '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
- ))
-
- ;; generic args
- (for-each
- (lambda (func name)
- (catch #t
- (lambda ()
- (let ((default-value (func gen)))
- (for-each
- (lambda (arg1)
- (catch #t
- (lambda ()
- (func gen)
- (set! (func gen) arg1))
- (lambda args #f)))
- (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 3/4 'mus-error 0+i
- (lambda () #t) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
- () 3 4 64 -64 (make-vector 0) '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
- (lambda (a) a)))
- (if (not (equal? (func gen) default-value))
- (catch #t
- (lambda ()
- (set! (func gen) default-value))
- (lambda args #f)))))
- (lambda args #f)))
- generic-procs generic-names)
- (mus-reset gen)))
- (lambda args (car args))))
- make-procs gen-procs)
-
- (let ((new-wave (make-float-vector 1)))
- (for-each
- (lambda (g g1)
- (let ((gen (g :wave new-wave)))
- (g1 gen 1.0)))
- (list make-table-lookup)
- (list table-lookup)))
-
- (let ((old-clm-srate *clm-srate*))
- (for-each
- (lambda (n)
- (set! *clm-srate* n)
+ (when (and all-args (= clmtest 0))
+ (for-each
+ (lambda (make runp)
+ (catch #t
+ (lambda ()
+ (let ((gen (make)))
+ ;; run args
(for-each
- (lambda (g name)
- (let ((tag (catch #t (lambda () (g :frequency 440.0)) (lambda args (car args)))))
- (if (not (memq tag '(wrong-type-arg out-of-range)))
- (snd-display #__line__ ";key-check ~A: ~A -> ~A" n name tag))))
- (list make-oscil make-asymmetric-fm
- make-triangle-wave make-square-wave make-pulse-train make-sawtooth-wave
- make-rand make-rand-interp)
- (list 'oscil 'asymmetric-fm
- 'triangle-wave 'square-wave 'pusle-train 'sawtooth-wave
- 'rand 'rand-interp)))
- (list 100 1))
- (set! *clm-srate* old-clm-srate))
-
- (let ((random-args (list
- (expt 2.0 21.5) (expt 2.0 -18.0)
- 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .1 .2 .3) #(0 1) 3/4 0+i (make-delay 32)
- (lambda () 0.0) (lambda (dir) 1.0) (lambda (a b c) 1.0) 0 1 -1 #f #t #\c 0.0 1.0 -1.0 () 32 '(1 . 2)
- ))
- (gen-make-procs (list make-all-pass make-asymmetric-fm make-moving-average make-moving-max make-moving-norm
+ (lambda (arg1)
+ ;; how did this ever work??
+ (catch #t (lambda () (runp gen arg1)) (lambda args (car args)))
+ (for-each
+ (lambda (arg2)
+ (catch #t (lambda () (runp gen arg1 arg2)) (lambda args (car args))))
+ (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
+ (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ () 3 4 2 8 16 32 64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
+ )))
+ (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
+ (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ () 3 4 2 8 16 32 64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
+ ))
+
+ ;; generic args
+ (for-each
+ (lambda (func name)
+ (catch #t
+ (lambda ()
+ (let ((default-value (func gen)))
+ (for-each
+ (lambda (arg1)
+ (catch #t
+ (lambda ()
+ (func gen)
+ (set! (func gen) arg1))
+ (lambda args #f)))
+ (list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 3/4 'mus-error 0+i
+ (lambda () #t) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ () 3 4 64 -64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
+ (lambda (a) a)))
+ (if (not (equal? (func gen) default-value))
+ (catch #t
+ (lambda ()
+ (set! (func gen) default-value))
+ (lambda args #f)))))
+ (lambda args #f)))
+ generic-procs generic-names)
+ (mus-reset gen)))
+ (lambda args (car args))))
+ make-procs gen-procs)
+
+ (let ((new-wave (make-float-vector 1)))
+ (for-each
+ (lambda (g g1)
+ (g1 (g :wave new-wave) 1.0))
+ (list make-table-lookup)
+ (list table-lookup)))
+
+ (let ((old-clm-srate *clm-srate*))
+ (for-each
+ (lambda (n)
+ (set! *clm-srate* n)
+ (for-each
+ (lambda (g name)
+ (let ((tag (catch #t (lambda () (g :frequency 440.0)) (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg out-of-range)))
+ (snd-display ";key-check ~A: ~A -> ~A" n name tag))))
+ (list make-oscil make-asymmetric-fm
+ make-triangle-wave make-square-wave make-pulse-train make-sawtooth-wave
+ make-rand make-rand-interp)
+ (list 'oscil 'asymmetric-fm
+ 'triangle-wave 'square-wave 'pusle-train 'sawtooth-wave
+ 'rand 'rand-interp)))
+ (list 100 1))
+ (set! *clm-srate* old-clm-srate))
+
+ (let ((random-args (list
+ (expt 2.0 21.5) (expt 2.0 -18.0)
+ 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .1 .2 .3) #(0 1) 3/4 0+i (make-delay 32)
+ (lambda () 0.0) (lambda (dir) 1.0) (lambda (a b c) 1.0) 0 1 -1 #f #t #\c 0.0 1.0 -1.0 () 32 '(1 . 2))))
+ (define (random-gen args)
+ (let ((gen-make-procs (list make-all-pass make-asymmetric-fm make-moving-average make-moving-max make-moving-norm
make-table-lookup make-triangle-wave
make-comb ;make-convolve
make-delay make-env make-fft-window
@@ -21099,99 +20645,96 @@ EDITS: 2
make-square-wave ;make-src
make-two-pole make-two-zero make-wave-train
make-ssb-am)))
-
- (define (random-gen args)
- (for-each
- (lambda (n)
- (let ((gen (catch #t
- (lambda () (apply n args))
- (lambda args (car args)))))
- (if (mus-generator? gen)
- (for-each
- (lambda (arg)
- (catch #t
- (lambda () (gen arg))
- (lambda args (car args))))
- random-args))))
- gen-make-procs))
-
- (random-gen ())
(for-each
- (lambda (arg1)
- (random-gen (list arg1))
- (for-each
- (lambda (arg2)
- (random-gen (list arg1 arg2))
- (for-each
- (lambda (arg3)
- (random-gen (list arg1 arg2 arg3))
- (for-each
- (lambda (arg4)
- (random-gen (list arg1 arg2 arg3 arg4)))
- random-args))
- random-args))
- random-args))
- random-args)))))
-
-
- (let ((gen (make-moving-max 4)))
- (let ((ov (make-float-vector 10))
- (iv (float-vector .1 .05 -.2 .15 -1.5 0.1 0.01 0.001 0.0 0.0))
- (tv (float-vector .1 .1 .2 .2 1.5 1.5 1.5 1.5 0.1 0.01)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (ov i) (moving-max gen (iv i))))
- (if (not (vequal tv ov))
- (snd-display #__line__ ";moving-max: ~A ~A" ov tv))))
+ (lambda (n)
+ (let ((gen (catch #t
+ (lambda () (apply n args))
+ (lambda args (car args)))))
+ (if (mus-generator? gen)
+ (for-each
+ (lambda (arg)
+ (catch #t
+ (lambda () (gen arg))
+ (lambda args (car args))))
+ random-args))))
+ gen-make-procs)))
+
+ (random-gen ())
+ (for-each
+ (lambda (arg1)
+ (random-gen (list arg1))
+ (for-each
+ (lambda (arg2)
+ (random-gen (list arg1 arg2))
+ (for-each
+ (lambda (arg3)
+ (random-gen (list arg1 arg2 arg3))
+ (for-each
+ (lambda (arg4)
+ (random-gen (list arg1 arg2 arg3 arg4)))
+ random-args))
+ random-args))
+ random-args))
+ random-args))))
+
+ (let* ((gen (make-moving-max 4))
+ (ov (make-float-vector 10))
+ (iv (float-vector .1 .05 -.2 .15 -1.5 0.1 0.01 0.001 0.0 0.0))
+ (tv (float-vector .1 .1 .2 .2 1.5 1.5 1.5 1.5 0.1 0.01)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (ov i) (moving-max gen (iv i))))
+ (if (not (vequal tv ov))
+ (snd-display ";moving-max: ~A ~A" ov tv)))
(let ((g1 (make-moving-max 10)))
(do ((i 0 (+ i 1)))
((= i 1000))
- (let ((val (moving-max g1 (random 1.0))))
- (let ((pk (float-vector-peak (mus-data g1))))
- (if (not (= pk val))
- (snd-display #__line__ ";moving-max ~A ~A" pk val))))))
+ (let* ((val (moving-max g1 (random 1.0)))
+ (pk (float-vector-peak (mus-data g1))))
+ (if (not (= pk val))
+ (snd-display ";moving-max ~A ~A" pk val)))))
(let ((odata (make-float-vector 15 0.0))
(data (float-vector 1.0 0.0 -1.1 1.1001 0.1 -1.1 1.0 1.0 0.5 -0.01 0.02 0.0 0.0 0.0 0.0))
(g (make-moving-max 3)))
(do ((i 0 (+ i 1))) ((= i 15)) (set! (odata i) (moving-max g (data i))))
(if (not (vequal odata (float-vector 1.000 1.000 1.100 1.100 1.100 1.100 1.100 1.100 1.000 1.000 0.500 0.020 0.020 0.000 0.000)))
- (snd-display #__line__ ";moving max odata: ~A" odata))
+ (snd-display ";moving max odata: ~A" odata))
(if (= (odata 4) (odata 7))
- (snd-display #__line__ ";moving-max .0001 offset?"))
+ (snd-display ";moving-max .0001 offset?"))
(set! odata (make-float-vector 15 0.0))
(set! data (float-vector 0.1 -0.2 0.3 0.4 -0.5 0.6 0.7 0.8 -0.9 1.0 0.0 0.0))
(set! g (make-moving-sum 3))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-sum g (data i))))
(if (not (vequal odata (float-vector 0.100 0.300 0.600 0.900 1.200 1.500 1.800 2.100 2.400 2.700 1.900 1.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";moving-sum odata: ~A" odata))
+ (snd-display ";moving-sum odata: ~A" odata))
(set! odata (make-float-vector 15 0.0))
(set! g (make-moving-rms 4))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-rms g (data i))))
(if (not (vequal odata (float-vector 0.050 0.112 0.187 0.274 0.367 0.464 0.561 0.660 0.758 0.857 0.783 0.673 0.000 0.000 0.000)))
- (snd-display #__line__ ";moving-rms odata: ~A" odata))
+ (snd-display ";moving-rms odata: ~A" odata))
(set! odata (make-float-vector 15 0.0))
(set! g (make-moving-length 4))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-length g (data i))))
(if (not (vequal odata (float-vector 0.100 0.224 0.374 0.548 0.735 0.927 1.122 1.319 1.517 1.715 1.565 1.345 0.000 0.000 0.000)))
- (snd-display #__line__ ";moving-length odata: ~A" odata))
+ (snd-display ";moving-length odata: ~A" odata))
(let ((ind (new-sound "test.snd" :size 20)))
(set! (sample 3) 1.0)
- (let ((gen1 (make-weighted-moving-average 4))
+ (let ((gen1 (make-weighted-moving-average 4)))
+ (map-channel (lambda (y) (weighted-moving-average gen1 y))))
+ (let ((data1 (channel->float-vector))
(gen2 (make-fir-filter 4 (float-vector 0.4 0.3 0.2 0.1))))
- (map-channel (lambda (y) (weighted-moving-average gen1 y)))
- (let ((data1 (channel->float-vector)))
- (undo)
- (map-channel (lambda (y) (fir-filter gen2 y)))
- (let ((data2 (channel->float-vector)))
- (if (not (vequal data1 data2))
- (snd-display #__line__ ";weighted-moving-average and fir:~%; ~A~%: ~A" data1 data2)))
- (undo)))
+ (undo)
+ (map-channel (lambda (y) (fir-filter gen2 y)))
+ (let ((data2 (channel->float-vector)))
+ (if (not (vequal data1 data2))
+ (snd-display ";weighted-moving-average and fir:~%; ~A~%: ~A" data1 data2)))
+ (undo))
(close-sound ind))
(do ((i 0 (+ i 1)))
@@ -21207,7 +20750,7 @@ EDITS: 2
((= j 4))
(if (>= (+ i j) 0)
(set! sum (+ sum (* (data (+ i j)) (data (+ i j)))))))
- (if (fneq (odata k) (sqrt sum)) (snd-display #__line__ ";moving length ran: ~A ~A" (odata k) (sqrt sum)))))
+ (if (fneq (odata k) (sqrt sum)) (snd-display ";moving length ran: ~A ~A" (odata k) (sqrt sum)))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -21222,7 +20765,7 @@ EDITS: 2
((= j 4))
(if (>= (+ i j) 0)
(set! sum (+ sum (abs (data (+ i j)))))))
- (if (fneq (odata k) sum) (snd-display #__line__ ";moving sum ran: ~A ~A" (odata k) sum))))
+ (if (fneq (odata k) sum) (snd-display ";moving sum ran: ~A ~A" (odata k) sum))))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -21237,7 +20780,7 @@ EDITS: 2
((= j 4))
(if (>= (+ i j) 0)
(set! sum (+ sum (* (data (+ i j)) (data (+ i j)))))))
- (if (fneq (odata k) (sqrt (/ sum 4))) (snd-display #__line__ ";moving rms ran: ~A ~A" (odata k) (sqrt (/ sum 4)))))))
+ (if (fneq (odata k) (sqrt (/ sum 4))) (snd-display ";moving rms ran: ~A ~A" (odata k) (sqrt (/ sum 4)))))))
(let ((ind (open-sound "oboe.snd")))
(harmonicizer 550.0 (list 1 .5 2 .3 3 .2) 10)
@@ -21254,7 +20797,7 @@ EDITS: 2
(lambda () (apply make arglist))
(lambda args (car args)))))
(if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";long arglist to ~A: ~A" name tag))))
+ (snd-display ";long arglist to ~A: ~A" name tag))))
(list make-wave-train make-polyshape make-delay make-moving-average make-moving-max make-moving-norm make-comb make-filtered-comb make-notch
make-rand make-rand-interp make-table-lookup make-env
make-readin make-locsig make-granulate make-convolve make-phase-vocoder)
@@ -21265,76 +20808,76 @@ EDITS: 2
(let ((v1 (make-float-vector 10 .1)))
(let ((g1 (make-table-lookup :wave v1)))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";table-lookup data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";table-lookup data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";table-lookup data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";table-lookup data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";table-lookup data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";table-lookup data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";table-lookup float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";table-lookup float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";table-lookup float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";table-lookup float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-wave-train :wave v1)))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";wave-train data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";wave-train data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";wave-train data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";wave-train data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";wave-train data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";wave-train data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";wave-train float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";wave-train float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";wave-train float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";wave-train float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-polyshape :coeffs v1)))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";polyshape data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";polyshape data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";polyshape data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";polyshape data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";polyshape data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";polyshape data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";polyshape float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";polyshape float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";polyshape float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";polyshape float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-delay :initial-contents v1)))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";delay data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";delay data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";delay data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";delay data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";delay data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";delay data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";delay float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";delay float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";delay float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";delay float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-filtered-comb :scaler .5 :initial-contents v1 :filter (make-one-zero .1 .2))))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";filtered-comb data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";filtered-comb data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";filtered-comb data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";filtered-comb data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";filtered-comb data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";filtered-comb data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";filtered-comb float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";filtered-comb float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";filtered-comb float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";filtered-comb float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-rand :distribution v1)))
- (if (not (eq? v1 (mus-data g1))) (snd-display #__line__ ";rand data not eq?: ~A ~A" v1 (mus-data g1)))
- (if (not (eqv? v1 (mus-data g1))) (snd-display #__line__ ";rand data not eqv?: ~A ~A" v1 (mus-data g1)))
- (if (not (equal? v1 (mus-data g1))) (snd-display #__line__ ";rand data not equal?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eq? v1 (mus-data g1))) (snd-display ";rand data not eq?: ~A ~A" v1 (mus-data g1)))
+ (if (not (eqv? v1 (mus-data g1))) (snd-display ";rand data not eqv?: ~A ~A" v1 (mus-data g1)))
+ (if (not (equal? v1 (mus-data g1))) (snd-display ";rand data not equal?: ~A ~A" v1 (mus-data g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-data g1) 1) .3) (snd-display #__line__ ";rand float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
+ (if (fneq ((mus-data g1) 1) .3) (snd-display ";rand float-vectorset: ~A ~A" (v1 1) ((mus-data g1) 1)))
(float-vector-set! (mus-data g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";rand float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";rand float-vectorref: ~A ~A" (v1 1) ((mus-data g1) 1))))
(let ((g1 (make-fir-filter :xcoeffs v1)))
- (if (not (eq? v1 (mus-xcoeffs g1))) (snd-display #__line__ ";fir-filter xcoeffs not eq?: ~A ~A" v1 (mus-xcoeffs g1)))
- (if (not (eqv? v1 (mus-xcoeffs g1))) (snd-display #__line__ ";fir-filter xcoeffs not eqv?: ~A ~A" v1 (mus-xcoeffs g1)))
- (if (not (equal? v1 (mus-xcoeffs g1))) (snd-display #__line__ ";fir-filter xcoeffs not equal?: ~A ~A" v1 (mus-xcoeffs g1)))
+ (if (not (eq? v1 (mus-xcoeffs g1))) (snd-display ";fir-filter xcoeffs not eq?: ~A ~A" v1 (mus-xcoeffs g1)))
+ (if (not (eqv? v1 (mus-xcoeffs g1))) (snd-display ";fir-filter xcoeffs not eqv?: ~A ~A" v1 (mus-xcoeffs g1)))
+ (if (not (equal? v1 (mus-xcoeffs g1))) (snd-display ";fir-filter xcoeffs not equal?: ~A ~A" v1 (mus-xcoeffs g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-xcoeffs g1) 1) .3) (snd-display #__line__ ";fir-filter float-vectorset: ~A ~A" (v1 1) ((mus-xcoeffs g1) 1)))
+ (if (fneq ((mus-xcoeffs g1) 1) .3) (snd-display ";fir-filter float-vectorset: ~A ~A" (v1 1) ((mus-xcoeffs g1) 1)))
(float-vector-set! (mus-xcoeffs g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";fir-filter float-vectorref: ~A ~A" (v1 1) ((mus-xcoeffs g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";fir-filter float-vectorref: ~A ~A" (v1 1) ((mus-xcoeffs g1) 1))))
(let ((g1 (make-iir-filter :ycoeffs v1)))
- (if (not (eq? v1 (mus-ycoeffs g1))) (snd-display #__line__ ";iir-filter ycoeffs not eq?: ~A ~A" v1 (mus-ycoeffs g1)))
- (if (not (eqv? v1 (mus-ycoeffs g1))) (snd-display #__line__ ";iir-filter ycoeffs not eqv?: ~A ~A" v1 (mus-ycoeffs g1)))
- (if (not (equal? v1 (mus-ycoeffs g1))) (snd-display #__line__ ";iir-filter ycoeffs not equal?: ~A ~A" v1 (mus-ycoeffs g1)))
+ (if (not (eq? v1 (mus-ycoeffs g1))) (snd-display ";iir-filter ycoeffs not eq?: ~A ~A" v1 (mus-ycoeffs g1)))
+ (if (not (eqv? v1 (mus-ycoeffs g1))) (snd-display ";iir-filter ycoeffs not eqv?: ~A ~A" v1 (mus-ycoeffs g1)))
+ (if (not (equal? v1 (mus-ycoeffs g1))) (snd-display ";iir-filter ycoeffs not equal?: ~A ~A" v1 (mus-ycoeffs g1)))
(set! (v1 1) .3)
- (if (fneq ((mus-ycoeffs g1) 1) .3) (snd-display #__line__ ";iir-filter float-vectorset: ~A ~A" (v1 1) ((mus-ycoeffs g1) 1)))
+ (if (fneq ((mus-ycoeffs g1) 1) .3) (snd-display ";iir-filter float-vectorset: ~A ~A" (v1 1) ((mus-ycoeffs g1) 1)))
(float-vector-set! (mus-ycoeffs g1) 1 .5)
- (if (fneq (v1 1) .5) (snd-display #__line__ ";iir-filter float-vectorref: ~A ~A" (v1 1) ((mus-ycoeffs g1) 1))))
+ (if (fneq (v1 1) .5) (snd-display ";iir-filter float-vectorref: ~A ~A" (v1 1) ((mus-ycoeffs g1) 1))))
)
(let ((tanh-1 (lambda (x)
@@ -21345,18 +20888,12 @@ EDITS: 2
(* 62/2835 x x x x x x x x x)
(* -1382/155925 x x x x x x x x x x x))))
(tanh-2 (lambda (y)
- (let ((x (sin y))
- (x3 (sin (* 3 y)))
- (x5 (sin (* 5 y)))
- (x7 (sin (* 7 y)))
- (x9 (sin (* 9 y)))
- (x11 (sin (* 11 y))))
- (+ (* 140069/172800 x)
- (* 13319/241920 x3)
- (* 1973/483840 x5)
- (* 799/1451520 x7)
- (* -71/7257600 x9)
- (* 691/79833600 x11))))))
+ (+ (* 140069/172800 (sin y))
+ (* 13319/241920 (sin (* 3 y)))
+ (* 1973/483840 (sin (* 5 y)))
+ (* 799/1451520 (sin (* 7 y)))
+ (* -71/7257600 (sin (* 9 y)))
+ (* 691/79833600 (sin (* 11 y)))))))
(for-each
(lambda (x)
(let ((val (tanh (sin x)))
@@ -21364,7 +20901,7 @@ EDITS: 2
(val2 (tanh-2 x)))
(if (or (fneq val val1)
(fneq val1 val2))
- (snd-display #__line__ ";tanh(~A): ~A ~A ~A" x val val1 val2))))
+ (snd-display ";tanh(~A): ~A ~A ~A" x val val1 val2))))
(list 1.0 0.1 0.1 0.333)))
(if all-args
@@ -21385,25 +20922,25 @@ EDITS: 2
(set! maxerr err)
(set! max-case (/ m n)))))))))
(if (> maxerr 1e-12)
- (snd-display #__line__ "sin-m*pi/n (~A cases) max err ~A at ~A~%" cases maxerr max-case))))
+ (snd-display "sin-m*pi/n (~A cases) max err ~A at ~A~%" cases maxerr max-case))))
(let ((tag (catch #t
(lambda () (with-sound () (outa -1 .1)))
(lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";outa -1 -> ~A" tag)))
+ (snd-display ";outa -1 -> ~A" tag)))
(let ((tag (catch #t
- (lambda () (let ((v (with-sound ((make-float-vector 10)) (outa -1 .1)))) v))
+ (lambda () (with-sound ((make-float-vector 10)) (outa -1 .1)))
(lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";outa (float-vector) -1 -> ~A" tag)))
+ (snd-display ";outa (float-vector) -1 -> ~A" tag)))
(let ((tag (catch #t
- (lambda () (let ((v (with-sound ((make-float-vector (list 1 10) 0.0)) (outa -1 .1)))) v))
+ (lambda () (with-sound ((make-float-vector (list 1 10) 0.0)) (outa -1 .1)))
(lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";outa (vector 2) -1 -> ~A" tag)))
+ (snd-display ";outa (vector 2) -1 -> ~A" tag)))
(let ((v (with-sound () (catch #t (lambda ()
(outa -1 .1))
@@ -21411,23 +20948,23 @@ EDITS: 2
(if (file-exists? v)
(begin
(if (> (cadr (mus-sound-maxamp v)) 0.0)
- (snd-display #__line__ ";outa to file at -1: ~A" v))
+ (snd-display ";outa to file at -1: ~A" v))
(if (> (mus-sound-chans v) 1)
- (snd-display #__line__ ";outa to file at -1 chans: ~A" (mus-sound-chans v)))
- (if (find-sound v) (close-sound (find-sound v)))
+ (snd-display ";outa to file at -1 chans: ~A" (mus-sound-chans v)))
+ (cond ((find-sound v) => close-sound))
(delete-file v))))
(let ((v (with-sound ((make-float-vector 10)) (catch #t (lambda ()
(outa -1 .1))
(lambda args 'error)))))
- (if (> (float-vector-peak v) 0.0) (snd-display #__line__ ";outa to float-vector at -1: ~A" v)))
+ (if (> (float-vector-peak v) 0.0) (snd-display ";outa to float-vector at -1: ~A" v)))
(let ((v (with-sound ((make-float-vector (list 1 10) 0.0)) (catch #t (lambda ()
(outa -1 .1))
(lambda args 'error)))))
- (if (> (maxamp v) 0.0) (snd-display #__line__ ";outa to vector1 at -1: ~A" v)))
+ (if (> (maxamp v) 0.0) (snd-display ";outa to vector1 at -1: ~A" v)))
- (if (not (= (signum 0) 0)) (snd-display #__line__ ";signum 0: ~A" (signum 0)))
- (if (not (= (signum 10) 1)) (snd-display #__line__ ";signum 10: ~A" (signum 10)))
- (if (not (= (signum -32) -1)) (snd-display #__line__ ";signum -32: ~A" (signum -32)))
+ (if (not (= (signum 0) 0)) (snd-display ";signum 0: ~A" (signum 0)))
+ (if (not (= (signum 10) 1)) (snd-display ";signum 10: ~A" (signum 10)))
+ (if (not (= (signum -32) -1)) (snd-display ";signum -32: ~A" (signum -32)))
(let ((c1 (make-comb .5 3))
@@ -21438,7 +20975,7 @@ EDITS: 2
(let ((x0 (comb c1 x))
(x1 (comb-bank c2 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(comb .5 3) ~A, comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(comb .5 3) ~A, comb: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-comb .5 3))
(c2 (make-comb .2 10))
@@ -21450,7 +20987,7 @@ EDITS: 2
(let ((x0 (+ (comb c1 x) (comb c2 x)))
(x1 (comb-bank c3 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(comb .5 3) + (comb .2 10) ~A, comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(comb .5 3) + (comb .2 10) ~A, comb: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-comb .5 3))
(c2 (make-comb .2 10))
@@ -21464,7 +21001,7 @@ EDITS: 2
(let ((x0 (+ (comb c1 x) (comb c2 x) (comb c3 x)))
(x1 (comb-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(comb .5 3) + (comb .2 10) + (comb -.7 11) ~A, comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(comb .5 3) + (comb .2 10) + (comb -.7 11) ~A, comb: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-all-pass -.5 .5 3))
@@ -21475,7 +21012,7 @@ EDITS: 2
(let ((x0 (all-pass c1 x))
(x1 (all-pass-bank c2 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(all-pass -.5 .5 3) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(all-pass -.5 .5 3) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-all-pass -.5 .5 3))
(c2 (make-all-pass -.2 .2 10))
@@ -21487,7 +21024,7 @@ EDITS: 2
(let ((x0 (all-pass c1 (all-pass c2 x)))
(x1 (all-pass-bank c3 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(all-pass -.5 .5 3) + (all-pass -.2 .2 10) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(all-pass -.5 .5 3) + (all-pass -.2 .2 10) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-all-pass -.5 .5 3))
(c2 (make-all-pass -.2 .2 10))
@@ -21501,7 +21038,7 @@ EDITS: 2
(let ((x0 (all-pass c1 (all-pass c2 (all-pass c3 x))))
(x1 (all-pass-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(all-pass -.5 .5 3) + (all-pass -.2 .2 10) + (all-pass -.7 .1 11) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(all-pass -.5 .5 3) + (all-pass -.2 .2 10) + (all-pass -.7 .1 11) ~A, all-pass: ~A, bank: ~A" i x0 x1)))))
@@ -21513,7 +21050,7 @@ EDITS: 2
(let ((x0 (filtered-comb c1 x))
(x1 (filtered-comb-bank c2 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(filtered-comb .5 3) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(filtered-comb .5 3) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-filtered-comb .5 3))
(c2 (make-filtered-comb .2 10))
@@ -21525,7 +21062,7 @@ EDITS: 2
(let ((x0 (+ (filtered-comb c1 x) (filtered-comb c2 x)))
(x1 (filtered-comb-bank c3 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(filtered-comb .5 3) + (filtered-comb .2 10) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(filtered-comb .5 3) + (filtered-comb .2 10) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-filtered-comb .5 3))
(c2 (make-filtered-comb .2 10))
@@ -21539,7 +21076,7 @@ EDITS: 2
(let ((x0 (+ (filtered-comb c1 x) (filtered-comb c2 x) (filtered-comb c3 x)))
(x1 (filtered-comb-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(filtered-comb .5 3) + (filtered-comb .2 10) + (filtered-comb -.7 11) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(filtered-comb .5 3) + (filtered-comb .2 10) + (filtered-comb -.7 11) ~A, filtered-comb: ~A, bank: ~A" i x0 x1)))))
;; make-formant-bank tests
@@ -21551,7 +21088,7 @@ EDITS: 2
(let ((x0 (formant c1 x))
(x1 (formant-bank c2 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(formant 440.0 .5) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(formant 440.0 .5) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .5))
(c2 (make-formant 1000.0 .2))
@@ -21563,7 +21100,7 @@ EDITS: 2
(let ((x0 (+ (formant c1 x) (formant c2 x)))
(x1 (formant-bank c3 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(formant 440.0 .5) + (formant 1000.0 .2) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(formant 440.0 .5) + (formant 1000.0 .2) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .5))
(c2 (make-formant 1000.0 .2))
@@ -21577,7 +21114,7 @@ EDITS: 2
(let ((x0 (+ (formant c1 x) (formant c2 x) (formant c3 x)))
(x1 (formant-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(formant 440.0 .5) + (formant 1000.0 .2) + (formant 34.0 .1) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(formant 440.0 .5) + (formant 1000.0 .2) + (formant 34.0 .1) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .75))
(c2 (make-formant 1000.0 .75))
@@ -21591,7 +21128,7 @@ EDITS: 2
(let ((x0 (+ (formant c1 x) (formant c2 x) (formant c3 x)))
(x1 (formant-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";(formant 440.0 .75) + (formant 1000.0 .75) + (formant 34.0 .75) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";(formant 440.0 .75) + (formant 1000.0 .75) + (formant 34.0 .75) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .5))
(c2 (make-formant 1000.0 .2))
@@ -21606,7 +21143,7 @@ EDITS: 2
(let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 x)) (* .4 (formant c3 x))))
(x1 (formant-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3 with amps at ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";fb 3 with amps at ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .9))
(c2 (make-formant 1000.0 .9))
@@ -21621,7 +21158,7 @@ EDITS: 2
(let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 x)) (* .4 (formant c3 x))))
(x1 (formant-bank c4 x)))
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3 with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";fb 3 with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .5))
(c2 (make-formant 1000.0 .2))
@@ -21637,7 +21174,7 @@ EDITS: 2
(x1 (formant-bank c4 inputs)))
(fill! inputs 0.0)
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";many (formant 440.0 .5) + (formant 1000.0 .2) + (formant 34.0 .1) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";many (formant 440.0 .5) + (formant 1000.0 .2) + (formant 34.0 .1) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .75))
(c2 (make-formant 1000.0 .75))
@@ -21653,7 +21190,7 @@ EDITS: 2
(x1 (formant-bank c4 inputs)))
(fill! inputs 0.0)
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";many (formant 440.0 .75) + (formant 1000.0 .75) + (formant 34.0 .75) ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";many (formant 440.0 .75) + (formant 1000.0 .75) + (formant 34.0 .75) ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .5))
@@ -21671,7 +21208,7 @@ EDITS: 2
(x1 (formant-bank c4 inputs)))
(fill! inputs 0.0)
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3 with amps at ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";fb 3 with amps at ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .9))
(c2 (make-formant 1000.0 .9))
@@ -21688,7 +21225,7 @@ EDITS: 2
(x1 (formant-bank c4 inputs)))
(fill! inputs 0.0)
(if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3 with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))
+ (snd-display ";fb 3 with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))
(let ((c1 (make-formant 440.0 .9))
(c2 (make-formant 1000.0 .9))
@@ -21703,37 +21240,36 @@ EDITS: 2
(y 1.0 0.0)
(z 1.0 0.0))
((= i 40))
- (if (< i 10)
- (let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 y)) (* .4 (formant c3 z))))
- (x1 (formant-bank c4 inputs)))
- (fill! inputs 0.0)
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3(1) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))
- (if (< i 20)
- (let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 y)) (* .4 (formant c3 z))))
- (x1 (formant-bank c4 0.0)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3(2) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))
- (if (< i 30)
- (begin
- (set! x 0.5)
- (set! y 0.25)
- (set! z 0.125)
- (set! (inputs 0) x)
- (set! (inputs 1) y)
- (set! (inputs 2) z)
- (let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 y)) (* .4 (formant c3 z))))
- (x1 (formant-bank c4 inputs)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3(3) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
- (begin
- (set! x 0.25)
- (set! y 0.25)
- (set! z 0.25)
- (let ((x0 (+ (* .5 (formant c1 x)) (* .3 (formant c2 y)) (* .4 (formant c3 z))))
- (x1 (formant-bank c4 .25)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 3(4) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))))))
+ (cond ((< i 10)
+ (let ((x0 (+ (* 0.5 (formant c1 x)) (* 0.3 (formant c2 y)) (* 0.4 (formant c3 z))))
+ (x1 (formant-bank c4 inputs)))
+ (fill! inputs 0.0)
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 3(1) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ ((< i 20)
+ (let ((x0 (+ (* 0.5 (formant c1 x)) (* 0.3 (formant c2 y)) (* 0.4 (formant c3 z))))
+ (x1 (formant-bank c4 0.0)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 3(2) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ ((< i 30)
+ (set! x 0.5)
+ (set! y 0.25)
+ (set! z 0.125)
+ (set! (inputs 0) x)
+ (set! (inputs 1) y)
+ (set! (inputs 2) z)
+ (let ((x0 (+ (* 0.5 (formant c1 x)) (* 0.3 (formant c2 y)) (* 0.4 (formant c3 z))))
+ (x1 (formant-bank c4 inputs)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 3(3) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ (else
+ (set! x 0.25)
+ (set! y 0.25)
+ (set! z 0.25)
+ (let ((x0 (+ (* 0.5 (formant c1 x)) (* 0.3 (formant c2 y)) (* 0.4 (formant c3 z))))
+ (x1 (formant-bank c4 0.25)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 3(4) with amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))))
(let ((c1 (make-formant 440.0 .9))
(c2 (make-formant 1000.0 .9))
@@ -21753,43 +21289,42 @@ EDITS: 2
(a 1.0 0.0)
(b 1.0 0.0))
((= i 40))
- (if (< i 10)
- (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
- (x1 (formant-bank c6 inputs)))
- (fill! inputs 0.0)
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 5(1) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))
- (if (< i 20)
- (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
- (x1 (formant-bank c6 0.0)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 5(2) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))
- (if (< i 30)
- (begin
- (set! x 0.5)
- (set! y 0.25)
- (set! z 0.125)
- (set! a .1)
- (set! b .3)
- (set! (inputs 0) x)
- (set! (inputs 1) y)
- (set! (inputs 2) z)
- (set! (inputs 3) a)
- (set! (inputs 4) b)
- (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
- (x1 (formant-bank c6 inputs)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 5(3) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
- (begin
- (set! x 0.25)
- (set! y 0.25)
- (set! z 0.25)
- (set! a 0.25)
- (set! b 0.25)
- (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
- (x1 (formant-bank c6 .25)))
- (if (not (morally-equal? x0 x1))
- (snd-display #__line__ ";fb 5(4) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))))))
+ (cond ((< i 10)
+ (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
+ (x1 (formant-bank c6 inputs)))
+ (fill! inputs 0.0)
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 5(1) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ ((< i 20)
+ (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
+ (x1 (formant-bank c6 0.0)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 5(2) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ ((< i 30)
+ (set! x 0.5)
+ (set! y 0.25)
+ (set! z 0.125)
+ (set! a 0.1)
+ (set! b 0.3)
+ (set! (inputs 0) x)
+ (set! (inputs 1) y)
+ (set! (inputs 2) z)
+ (set! (inputs 3) a)
+ (set! (inputs 4) b)
+ (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
+ (x1 (formant-bank c6 inputs)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 5(3) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1))))
+ (else
+ (set! x 0.25)
+ (set! y 0.25)
+ (set! z 0.25)
+ (set! a 0.25)
+ (set! b 0.25)
+ (let ((x0 (+ (formant c1 x) (formant c2 y) (formant c3 z) (formant c4 a) (formant c5 b)))
+ (x1 (formant-bank c6 0.25)))
+ (if (not (morally-equal? x0 x1))
+ (snd-display ";fb 5(4) no amps c1_c2 at ~A, formant: ~A, bank: ~A" i x0 x1)))))))
(set! *clm-srate* 44100)
(if (file-exists? "jcrev-ip.snd")
@@ -21798,7 +21333,7 @@ EDITS: 2
(let ((s1 (find-sound "test.snd"))
(s2 (open-sound "jcrev-ip.snd")))
(if (not (= (channel-distance s1 0 s2 0) 0.0))
- (snd-display #__line__ ";jcrev ip: ~A" (channel-distance s1 0 s2 0)))
+ (snd-display ";jcrev ip: ~A" (channel-distance s1 0 s2 0)))
(close-sound s1)
(close-sound s2))))
@@ -21808,7 +21343,7 @@ EDITS: 2
(let ((s1 (find-sound "test.snd"))
(s2 (open-sound "nrev-ip.snd")))
(if (not (= (channel-distance s1 0 s2 0) 0.0))
- (snd-display #__line__ ";nrev ip: ~A" (channel-distance s1 0 s2 0)))
+ (snd-display ";nrev ip: ~A" (channel-distance s1 0 s2 0)))
(close-sound s1)
(close-sound s2))))
@@ -21818,7 +21353,7 @@ EDITS: 2
(let ((s1 (find-sound "test.snd"))
(s2 (open-sound "freeverb-ip.snd")))
(if (not (= (channel-distance s1 0 s2 0) 0.0))
- (snd-display #__line__ ";freeverb ip: ~A" (channel-distance s1 0 s2 0)))
+ (snd-display ";freeverb ip: ~A" (channel-distance s1 0 s2 0)))
(close-sound s1)
(close-sound s2))))
@@ -21901,7 +21436,7 @@ EDITS: 2
(v3 (rxyk!cos-direct x x 0.5 12)))
(if (or (> (abs (- v1 v2)) 1e-6)
(> (abs (- v1 v3)) 1e-6))
- (format #t ";rxyk!cos ~A ~A: ~A ~A ~A -> ~A~%" i x v1 v2 v3 (max (abs (- v1 v2)) (abs (- v1 v3))))))))
+ (format () ";rxyk!cos ~A ~A: ~A ~A ~A -> ~A~%" i x v1 v2 v3 (max (abs (- v1 v2)) (abs (- v1 v3))))))))
(let ((g1 (make-rxyk!sin 100.0))
(g2 (make-old-rxyk!sin 100.0))
@@ -21914,7 +21449,7 @@ EDITS: 2
(v3 (rxyk!sin-direct x x 0.5 12)))
(if (or (> (abs (- v1 v2)) 1e-6)
(> (abs (- v1 v3)) 1e-6))
- (format #t ";rxyk!sin ~A ~A: ~A ~A ~A -> ~A~%" i x v1 v2 v3 (max (abs (- v1 v2)) (abs (- v1 v3))))))))
+ (format () ";rxyk!sin ~A ~A: ~A ~A ~A -> ~A~%" i x v1 v2 v3 (max (abs (- v1 v2)) (abs (- v1 v3))))))))
(let ((g1 (make-rxyk!cos 100.0 :ratio 2.0 :r 0.25))
(g2 (make-old-rxyk!cos 100.0 :ratio 2.0 :r 0.25)))
@@ -21923,7 +21458,7 @@ EDITS: 2
(let ((v1 (rxyk!cos g1))
(v2 (old-rxyk!cos g2)))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";rxyk!cos ratio:2: ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
+ (format () ";rxyk!cos ratio:2: ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
(let ((g1 (make-rxyk!sin 100.0 :ratio 2.0 :r 0.25))
(g2 (make-old-rxyk!sin 100.0 :ratio 2.0 :r 0.25)))
@@ -21932,7 +21467,7 @@ EDITS: 2
(let ((v1 (rxyk!sin g1))
(v2 (old-rxyk!sin g2)))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";rxyk!sin ratio:2: ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
+ (format () ";rxyk!sin ratio:2: ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
(let ((g1 (make-rxyk!cos 100.0 :ratio 2.0 :r 0.25))
(o1 (make-oscil 400.0))
@@ -21943,7 +21478,7 @@ EDITS: 2
(let ((v1 (rxyk!cos g1 (oscil o1)))
(v2 (old-rxyk!cos g2 (oscil o2))))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";rxyk!cos fm ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
+ (format () ";rxyk!cos fm ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
(let ((g1 (make-rxyk!sin 100.0 :ratio 2.0 :r 0.25))
(o1 (make-oscil 400.0))
@@ -21954,7 +21489,7 @@ EDITS: 2
(let ((v1 (rxyk!sin g1 (oscil o1)))
(v2 (old-rxyk!sin g2 (oscil o2))))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";rxyk!sin fm ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2))))))))
+ (format () ";rxyk!sin fm ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2))))))))
(let ()
(defgenerator one-pole-allpass coeff input x1 y1)
@@ -22004,7 +21539,7 @@ EDITS: 2
(let ((v1 (one-pole-all-pass o1 impulse))
(v2 (one-pole-allpass o2 impulse)))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";one-pole-all-pass (1) ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
+ (format () ";one-pole-all-pass (1) ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
(let ((o1 (make-one-pole-all-pass 8 .5))
(o2 (make-one-pole-allpass-bank .5)))
@@ -22014,7 +21549,7 @@ EDITS: 2
(let ((v1 (one-pole-all-pass o1 impulse))
(v2 (one-pole-allpass-bank o2 impulse)))
(if (> (abs (- v1 v2)) 1e-6)
- (format #t ";one-pole-all-pass (1) ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
+ (format () ";one-pole-all-pass (1) ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
)
(let ((old-srate *clm-srate*))
@@ -22029,7 +21564,7 @@ EDITS: 2
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";pulsed-env: ~A" v)))
+ (snd-display ";pulsed-env: ~A" v)))
(set! *clm-srate* old-srate))
(copy-test (make-oscil 330.0))
@@ -22073,49 +21608,49 @@ EDITS: 2
;; formant-bank isn't really testing equality yet
- (let ((o (make-rand 100.0)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";rand copy ~A != ~A~%" o p))))
+ (let* ((o (make-rand 100.0))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";rand copy ~A != ~A~%" o p)))
- (let ((o (make-rand-interp 100.0)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";rand-interp copy ~A != ~A~%" o p))))
+ (let* ((o (make-rand-interp 100.0))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";rand-interp copy ~A != ~A~%" o p)))
- (let ((v1 (make-float-vector 10 .1)))
- (let ((o (make-rand 100.0 :distribution v1)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";rand+dist copy ~A != ~A~%" o p))))
-
- (let ((o (make-rand-interp 100.0 :distribution v1)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";rand-interp+dist copy ~A != ~A~%" o p)))))
-
- (let ((o (make-nssb 440.0)))
- (let ((p (copy o)))
+ (let* ((v1 (make-float-vector 10 .1))
+ (o (make-rand 100.0 :distribution v1))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";rand+dist copy ~A != ~A~%" o p))
+
+ (let* ((o (make-rand-interp 100.0 :distribution v1))
+ (p (copy o)))
(if (not (equal? o p))
- (snd-display #__line__ ";nssb copy ~A != ~A~%" o p))
- (nssb o 1.0)
- (if (equal? o p)
- (snd-display #__line__ ";nssb copy/run ~A == ~A~%" o p))))
-
- (let ((v1 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9)))
- (let ((o (make-wave-train 100 :wave v1)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";wave-train copy ~A != ~A~%" o p)))))
-
- (let ((v1 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9)))
- (let ((o (make-table-lookup 440.0 :wave v1)))
- (let ((p (copy o)))
- (if (not (equal? o p))
- (snd-display #__line__ ";table-lookup copy ~A != ~A~%" o p))
- (table-lookup o 1.0)
- (if (equal? o p)
- (snd-display #__line__ ";table-lookup run ~A == ~A~%" o p)))))
+ (snd-display ";rand-interp+dist copy ~A != ~A~%" o p))))
+
+ (let* ((o (make-nssb 440.0))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";nssb copy ~A != ~A~%" o p))
+ (nssb o 1.0)
+ (if (equal? o p)
+ (snd-display ";nssb copy/run ~A == ~A~%" o p)))
+
+ (let* ((v1 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9))
+ (o (make-wave-train 100 :wave v1))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";wave-train copy ~A != ~A~%" o p)))
+
+ (let* ((v1 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9))
+ (o (make-table-lookup 440.0 :wave v1))
+ (p (copy o)))
+ (if (not (equal? o p))
+ (snd-display ";table-lookup copy ~A != ~A~%" o p))
+ (table-lookup o 1.0)
+ (if (equal? o p)
+ (snd-display ";table-lookup run ~A == ~A~%" o p)))
))
@@ -22133,59 +21668,61 @@ EDITS: 2
(if (sound? oldie)
(close-sound oldie)))
- (let ((violin-sync 1)
- (violin-color (make-color 0 0 1)) ; blue
- (cello-sync 2)
- (cello-color (make-color 0 1 0)) ; green
- (index (new-sound "test.snd" :channels 1 :size (* 22050 22))))
-
- (define (violin beg dur freq amp)
- (let ((id (car (mix (with-temp-sound () ; write instrument output to temp sound
- (fm-violin 0 dur (->frequency freq #t) amp)) ; our favorite FM instrument
- (->sample beg) 0 index 0 ; mix start, file in-chan, sound, channel
- #t #t)))) ; mix with tag and auto-delete
- (if (symbol? freq)
- (set! (mix-name id) (symbol->string freq)))
- (set! (mix-sync id) violin-sync)
- (set! (mix-color id) violin-color)
- (set! (mix-tag-y id) (frequency->tag-y (->frequency freq #t) (->frequency 'c2) 3))))
-
- (define (cello beg dur freq amp)
- (let ((id (car (mix (with-temp-sound ()
- (fm-violin 0 dur (->frequency freq #t) amp :fm-index 1.5))
- (->sample beg) 0 index 0
- #t #t))))
- (if (symbol? freq)
- (set! (mix-name id) (symbol->string freq)))
- (set! (mix-sync id) cello-sync)
- (set! (mix-color id) cello-color)
- (set! (mix-tag-y id) (frequency->tag-y (->frequency freq #t) (->frequency 'c2) 3))))
+ (let ((index (new-sound "test.snd" :channels 1 :size 485100))) ;(* 22050 22)
+
+ (define violin
+ (let ((violin-sync 1)
+ (violin-color (make-color 0 0 1))) ; blue
+ (lambda (beg dur freq)
+ (let ((id (car (mix (with-temp-sound () ; write instrument output to temp sound
+ (fm-violin 0 dur (->frequency freq #t) 0.2)) ; our favorite FM instrument
+ (->sample beg) 0 index 0 ; mix start, file in-chan, sound, channel
+ #t #t)))) ; mix with tag and auto-delete
+ (if (symbol? freq)
+ (set! (mix-name id) (symbol->string freq)))
+ (set! (mix-sync id) violin-sync)
+ (set! (mix-color id) violin-color)
+ (set! (mix-tag-y id) (frequency->tag-y (->frequency freq #t) (->frequency 'c2) 3))))))
+
+ (define cello
+ (let ((cello-sync 2)
+ (cello-color (make-color 0 1 0))) ; green
+ (lambda (beg dur freq)
+ (let ((id (car (mix (with-temp-sound ()
+ (fm-violin 0 dur (->frequency freq #t) 0.2 :fm-index 1.5))
+ (->sample beg) 0 index 0
+ #t #t))))
+ (if (symbol? freq)
+ (set! (mix-name id) (symbol->string freq)))
+ (set! (mix-sync id) cello-sync)
+ (set! (mix-color id) cello-color)
+ (set! (mix-tag-y id) (frequency->tag-y (->frequency freq #t) (->frequency 'c2) 3))))))
(as-one-edit
(lambda ()
- (violin 0 1 'e4 .2) (violin 1 1.5 'g4 .2) (violin 2.5 .5 'g3 .2)
- (cello 0 1 'c3 .2) (cello 1 1.5 'e3 .2) (cello 2.5 .5 'g2 .2)
+ (violin 0 1 'e4) (violin 1 1.5 'g4) (violin 2.5 .5 'g3)
+ (cello 0 1 'c3) (cello 1 1.5 'e3) (cello 2.5 .5 'g2)
- (violin 3 3 'f4 .2)
- (cello 3 3 'd3 .2)
+ (violin 3 3 'f4)
+ (cello 3 3 'd3)
- (violin 6 1 'e4 .2) (violin 7 1 'g3 .2) (violin 8 1 'e4 .2)
- (cello 6 1 'c3 .2) (cello 7 1 'g2 .2) (cello 8 1 'c3 .2)
+ (violin 6 1 'e4) (violin 7 1 'g3) (violin 8 1 'e4)
+ (cello 6 1 'c3) (cello 7 1 'g2) (cello 8 1 'c3)
- (violin 9 3 'd4 .2)
- (cello 9 3 'b2 .2)
+ (violin 9 3 'd4)
+ (cello 9 3 'b2)
- (violin 12 1 'f4 .2) (violin 13 1.5 'a4 .2) (violin 14.5 .5 'g3 .2)
- (cello 12 1 'd3 .2) (cello 13 1.5 'f3 .2) (cello 14.5 .5 'g2 .2)
+ (violin 12 1 'f4) (violin 13 1.5 'a4) (violin 14.5 .5 'g3)
+ (cello 12 1 'd3) (cello 13 1.5 'f3) (cello 14.5 .5 'g2)
- (violin 15 3 'g4 .2)
- (cello 15 3 'e3 .2)
+ (violin 15 3 'g4)
+ (cello 15 3 'e3)
- (violin 18 1 'f4 .2) (violin 19 1 'g3 .2) (violin 20 1 'f4 .2)
- (cello 18 1 'd3 .2) (cello 19 1 'g2 .2) (cello 20 1 'd3 .2)
+ (violin 18 1 'f4) (violin 19 1 'g3) (violin 20 1 'f4)
+ (cello 18 1 'd3) (cello 19 1 'g2) (cello 20 1 'd3)
- (violin 21 3 'e4 .2)
- (cello 21 3 'c3 .2)
+ (violin 21 3 'e4)
+ (cello 21 3 'c3)
index))))
@@ -22206,1696 +21743,1671 @@ EDITS: 2
(if (sound? oldie)
(close-sound oldie)))
- (let ((soprano ())
- (alto ())
- (tenor ())
- (bass ())
-
- (ind (new-sound "test.snd" :channels 1))
-
- (f1 (seg '(0 0 1 25 1 75 0 100)))
- (f5 (seg '(-1 0 .25 10 0 20 0 100)))
- ;; (grc1 (seg '(1 0 .5 10 0 20 0 50 0 100)))
- ;; (grc2 (seg '(0 0 1 10 0 20 0 50 0 100)))
- ;; (grc3 (seg '(.5 0 1 10 0 20 0 50 0 100)))
- ;; (grc4 (seg '(1 0 0 10 1 20 0 30 1 40 0 50 1 60 0 70 1 80 0 90 1 100)))
- ;; (grc5 (seg '(1 0 .5 10 1 20 0 30 1 40 .5 50 1 60 0 70 1 80 .5 90 1 100)))
- ;; (grc6 (seg '(1 0 .5 10 0 20 -.5 30 -1 40 -.5 50 0 60 .5 70 1 80 .5 90 0 100)))
- (f6 (seg '(1 1 .5 10 .75 50 .4 75 .6 90 0 100)))
- (f7 (seg '(0 1 .5 10 .25 25 .75 50 .5 75 1 90 0 100)))
- ;; (f2 (seg '(0 1 .5 10 .4 90 0 100)))
- ;; (f3 (seg '(1 0 .5 10 .75 90 0 100)))
- ;; (ramp (seg '(0 0 1 2.5 1 7.5 0 10 1 12.5 1 17.5 0 20 1 22.5 1 27.5 0 30 1 32.5 1 37.5
- ;; 0 40 1 42.5 1 47.5 0 50 1 52.5 1 57.5 0 60 1 62.5 1 67.5 0 70 1 72.5 1 77.5
- ;; 0 80 1 82.5 1 87.5 0 90 1 92.5 1 97.5 0 100)))
- ;; (str (seg '(1 1 1 100)))
- )
-
- (define (mix-fmsimp beg dur freq amp ampfunc freqfunc rat1 indx1 rat2 indx2 ignored)
- (let ((freq1 (if (> freq (/ *clm-srate* 8)) (/ freq 8) freq))
- (amp1 (* amp .175)))
- (let ((id (car (mix (with-temp-sound ()
- (fm-violin 0 dur freq1 amp1
- :fm1-rat (* 1.002 rat1)
- :fm1-index (* .5 rat1 indx1 (hz->radians freq))
- :fm1-env f6
- :fm2-rat (* 1.003 rat2)
- :fm2-index (* .5 indx2 rat2 (hz->radians freq))
- :fm2-env f7
- :fm3-index 0.0
- :reverb-amount 1.0
- :amp-env ampfunc))
- (->sample beg) 0 ind 0 #t #t)))) ; with tag and auto-delete
- (set! (mix-name id) (number->string (floor freq)))
- (if (> freq 700) (set! soprano (cons id soprano))
- (if (> freq 500) (set! alto (cons id alto))
- (if (> freq 300) (set! tenor (cons id tenor))
- (set! bass (cons id bass))))))))
+ (let ((ind (new-sound "test.snd" :channels 1))
+ (f1 (seg '(0 0 1 25 1 75 0 100))))
+
+ (define mix-fmsimp
+ (let ((soprano ())
+ (alto ())
+ (tenor ())
+ (bass ())
+ (f6 (seg '(1 1 .5 10 .75 50 .4 75 .6 90 0 100)))
+ (f7 (seg '(0 1 .5 10 .25 25 .75 50 .5 75 1 90 0 100))))
+ (lambda (beg dur freq amp ampfunc rat1 indx1 rat2 indx2)
+ (let ((freq1 (if (> freq (/ *clm-srate* 8)) (/ freq 8) freq))
+ (amp1 (* amp .175)))
+ (let ((id (car (mix (with-temp-sound ()
+ (fm-violin 0 dur freq1 amp1
+ :fm1-rat (* 1.002 rat1)
+ :fm1-index (* .5 rat1 indx1 (hz->radians freq))
+ :fm1-env f6
+ :fm2-rat (* 1.003 rat2)
+ :fm2-index (* .5 indx2 rat2 (hz->radians freq))
+ :fm2-env f7
+ :fm3-index 0.0
+ :reverb-amount 1.0
+ :amp-env ampfunc))
+ (->sample beg) 0 ind 0 #t #t)))) ; with tag and auto-delete
+ (set! (mix-name id) (number->string (floor freq)))
+ (cond ((> freq 700) (set! soprano (cons id soprano)))
+ ((> freq 500) (set! alto (cons id alto)))
+ ((> freq 300) (set! tenor (cons id tenor)))
+ (else (set! bass (cons id bass)))))))))
(as-one-edit
(lambda ()
- (mix-fmsimp .000 2.488 659.255 .500 f1 f5 5.000 1.260 2.000 .501 .000 )
- (mix-fmsimp .750 1.988 654.084 .167 f1 f5 3.000 1.260 1.000 .710 .000 )
- (mix-fmsimp 1.000 2.738 880.000 .500 f1 f5 5.000 1.260 1.000 .140 .001 )
- (mix-fmsimp 2.000 2.488 880.000 .500 f1 f5 1.000 1.671 2.000 .745 .001 )
- (mix-fmsimp 2.750 1.969 871.429 .495 f1 f5 5.000 1.312 1.000 .447 .001 )
- (mix-fmsimp 3.000 2.750 493.883 .100 f1 f5 1.000 1.260 2.000 1.069 .002 )
- (mix-fmsimp 4.000 2.488 654.568 .500 f1 f5 3.000 1.671 5.000 .793 .002 )
- (mix-fmsimp 4.750 1.988 590.042 .241 f1 f5 2.000 1.671 5.000 1.046 .002 )
- (mix-fmsimp 5.000 2.238 551.574 .500 f1 f5 4.000 1.671 1.000 .073 .003 )
- (mix-fmsimp 5.500 2.238 664.174 .504 f1 f5 3.000 1.671 4.000 .791 .003 )
- (mix-fmsimp 6.000 1.988 659.255 .400 f1 f5 2.000 1.671 2.000 .955 .003 )
- (mix-fmsimp 6.250 2.738 880.000 .400 f1 f5 5.000 1.260 5.000 .645 .003 )
- (mix-fmsimp 7.250 2.505 885.724 .336 f1 f5 5.000 1.260 4.000 .302 .004 )
- (mix-fmsimp 8.000 1.988 880.000 .500 f1 f5 3.000 1.260 2.000 .672 .004 )
- (mix-fmsimp 8.250 2.738 493.883 .100 f1 f5 4.000 1.671 1.000 .013 .004 )
- (mix-fmsimp 9.250 2.488 659.255 .250 f1 f5 3.000 1.671 3.000 1.167 .005 )
- (mix-fmsimp 10.000 1.988 587.330 .240 f1 f5 2.000 1.314 5.000 .423 .005 )
- (mix-fmsimp 10.250 2.238 554.365 .500 f1 f5 1.000 1.671 2.000 .078 .005 )
- (mix-fmsimp 10.750 2.238 659.255 .500 f1 f5 1.000 1.260 5.000 .797 .005 )
- (mix-fmsimp 11.250 1.988 651.332 .400 f1 f5 5.000 1.671 1.000 .883 .006 )
- (mix-fmsimp 11.500 1.926 878.372 .200 f1 f5 1.000 1.434 4.000 .322 .006 )
- (mix-fmsimp 11.688 2.497 880.000 .335 f1 f5 2.000 1.671 4.000 .879 .006 )
- (mix-fmsimp 12.438 2.006 887.764 .288 f1 f5 1.000 1.671 4.000 .652 .006 )
- (mix-fmsimp 12.688 2.738 493.883 .100 f1 f5 1.000 1.671 4.000 .521 .006 )
- (mix-fmsimp 13.688 2.488 659.255 .250 f1 f5 2.000 1.671 2.000 1.247 .007 )
- (mix-fmsimp 14.438 1.988 587.330 .240 f1 f5 1.000 1.260 2.000 1.182 .007 )
- (mix-fmsimp 14.688 2.238 547.848 .494 f1 f5 4.000 1.671 2.000 .432 .007 )
- (mix-fmsimp 15.188 3.238 867.651 .500 f1 f5 4.000 1.671 1.000 .571 .008 )
- (mix-fmsimp 16.688 2.238 659.255 .400 f1 f5 4.000 1.671 4.000 .477 .008 )
- (mix-fmsimp 17.188 1.988 652.468 .495 f1 f5 3.000 1.671 2.000 .438 .009 )
- (mix-fmsimp 17.438 1.926 880.000 .200 f1 f5 2.000 1.671 4.000 1.107 .009 )
- (mix-fmsimp 17.625 2.523 880.000 .500 f1 f5 5.000 1.671 1.000 .830 .009 )
- (mix-fmsimp 18.375 1.988 880.000 .400 f1 f5 4.000 1.671 3.000 .186 .009 )
- (mix-fmsimp 18.625 2.738 493.883 .100 f1 f5 1.000 1.260 5.000 .407 .009 )
- (mix-fmsimp 19.625 2.488 657.231 .166 f1 f5 5.000 1.260 2.000 .389 .010 )
- (mix-fmsimp 20.375 1.976 587.330 .238 f1 f5 2.000 1.671 1.000 .712 .010 )
- (mix-fmsimp 20.625 2.238 554.365 .500 f1 f5 3.000 1.260 5.000 .171 .010 )
- (mix-fmsimp 21.125 3.238 880.000 .500 f1 f5 4.000 1.671 1.000 .507 .011 )
- (mix-fmsimp 22.625 2.238 650.838 .395 f1 f5 3.000 1.671 4.000 .160 .011 )
- (mix-fmsimp 23.125 1.978 659.255 .497 f1 f5 1.000 1.671 1.000 .867 .012 )
- (mix-fmsimp 23.375 1.926 885.243 .333 f1 f5 2.000 1.412 4.000 .811 .012 )
- (mix-fmsimp 23.563 2.488 880.000 .500 f1 f5 4.000 1.671 3.000 .439 .012 )
- (mix-fmsimp 24.313 1.995 882.799 .401 f1 f5 1.000 1.671 4.000 1.089 .012 )
- (mix-fmsimp 24.563 2.730 246.942 .100 f1 f5 2.000 1.671 1.000 .092 .012 )
- (mix-fmsimp 25.563 2.488 329.628 .167 f1 f5 2.000 1.671 2.000 1.149 .012 )
- (mix-fmsimp 26.313 2.007 587.330 .242 f1 f5 3.000 1.671 3.000 .472 .011 )
- (mix-fmsimp 26.563 2.238 548.468 .495 f1 f5 2.000 1.671 1.000 .259 .011 )
- (mix-fmsimp 27.063 3.238 439.221 .500 f1 f5 3.000 1.260 3.000 1.014 .011 )
- (mix-fmsimp 28.563 2.493 441.603 .401 f1 f5 3.000 1.671 5.000 .056 .010 )
- (mix-fmsimp 29.313 2.220 659.255 .500 f1 f5 3.000 1.260 3.000 1.108 .010 )
- (mix-fmsimp 29.813 1.960 329.628 .500 f1 f5 1.000 1.671 1.000 .944 .010 )
- (mix-fmsimp 30.063 1.894 440.000 .333 f1 f5 1.000 1.260 4.000 .602 .009 )
- (mix-fmsimp 30.250 2.453 443.160 .400 f1 f5 1.000 1.260 3.000 .750 .009 )
- (mix-fmsimp 31.000 1.938 441.168 .333 f1 f5 5.000 1.671 3.000 .522 .009 )
- (mix-fmsimp 31.250 2.684 246.942 .100 f1 f5 5.000 1.654 1.000 1.020 .009 )
- (mix-fmsimp 32.250 2.415 325.263 .167 f1 f5 4.000 1.671 3.000 .014 .008 )
- (mix-fmsimp 33.000 1.901 587.330 .240 f1 f5 4.000 1.671 5.000 1.106 .008 )
- (mix-fmsimp 33.250 2.149 554.936 .501 f1 f5 2.000 1.260 2.000 1.159 .008 )
- (mix-fmsimp 33.750 3.137 440.000 .500 f1 f5 2.000 1.671 1.000 .647 .008 )
- (mix-fmsimp 35.250 2.359 440.000 .400 f1 f5 5.000 1.671 4.000 1.149 .007 )
- (mix-fmsimp 36.000 2.101 661.109 .501 f1 f5 4.000 1.377 2.000 1.121 .006 )
- (mix-fmsimp 36.500 1.836 329.628 .500 f1 f5 2.000 1.671 4.000 1.459 .006 )
- (mix-fmsimp 36.750 1.768 440.000 .250 f1 f5 5.000 1.671 5.000 .601 .006 )
- (mix-fmsimp 36.938 2.327 442.815 .400 f1 f5 2.000 1.671 3.000 .354 .006 )
- (mix-fmsimp 37.688 1.813 440.000 .400 f1 f5 4.000 1.671 2.000 .205 .006 )
- (mix-fmsimp 37.938 2.559 246.712 .100 f1 f5 4.000 1.671 2.000 1.044 .006 )
- (mix-fmsimp 38.938 2.290 329.628 .167 f1 f5 1.000 1.260 2.000 1.316 .005 )
- (mix-fmsimp 39.688 1.781 587.330 .240 f1 f5 1.000 1.671 3.000 .524 .005 )
- (mix-fmsimp 39.938 2.021 554.365 .500 f1 f5 1.000 1.671 2.000 .522 .005 )
- (mix-fmsimp 40.438 2.998 438.022 .498 f1 f5 3.000 1.260 4.000 .264 .004 )
- (mix-fmsimp 41.938 2.253 443.810 .403 f1 f5 1.000 1.671 4.000 1.157 .004 )
- (mix-fmsimp 42.688 1.720 414.691 .319 f1 f5 4.000 1.671 1.000 .612 .003 )
- (mix-fmsimp 42.938 1.965 659.255 .500 f1 f5 2.000 1.671 2.000 .559 .003 )
- (mix-fmsimp 43.438 1.690 329.628 .496 f1 f5 5.000 1.671 2.000 1.457 .003 )
- (mix-fmsimp 43.688 1.630 440.000 .249 f1 f5 2.000 1.671 5.000 .505 .003 )
- (mix-fmsimp 43.875 2.197 440.000 .400 f1 f5 3.000 1.260 3.000 .843 .003 )
- (mix-fmsimp 44.625 1.678 440.000 .332 f1 f5 2.000 1.671 5.000 1.165 .002 )
- (mix-fmsimp 44.875 2.405 246.942 .100 f1 f5 4.000 1.671 3.000 .105 .002 )
- (mix-fmsimp 45.875 2.160 332.580 .168 f1 f5 1.000 1.260 5.000 1.107 .002 )
- (mix-fmsimp 46.625 1.646 583.584 .238 f1 f5 4.000 1.673 5.000 .201 .001 )
- (mix-fmsimp 46.875 1.891 553.184 .492 f1 f5 1.000 1.304 2.000 1.230 .001 )
- (mix-fmsimp 47.375 2.882 438.012 .489 f1 f5 5.000 1.737 4.000 .024 .001 )
- (mix-fmsimp 48.875 2.104 440.000 .487 f1 f5 2.000 1.770 2.000 .308 .000 )
- (mix-fmsimp 49.625 1.590 414.068 .319 f1 f5 4.000 1.866 3.000 .415 .001 )
- (mix-fmsimp 49.875 1.835 659.255 .467 f1 f5 1.000 1.914 3.000 .477 .001 )
- (mix-fmsimp 50.375 1.592 333.127 .470 f1 f5 5.000 1.930 2.000 .230 .001 )
- (mix-fmsimp 50.625 1.509 440.000 .250 f1 f5 5.000 1.963 1.000 .829 .001 )
- (mix-fmsimp 50.813 2.068 440.000 .400 f1 f5 3.000 1.979 1.000 1.450 .001 )
- (mix-fmsimp 51.563 1.536 434.964 .330 f1 f5 4.000 1.991 2.000 .308 .002 )
- (mix-fmsimp 51.813 2.299 246.942 .088 f1 f5 4.000 1.581 5.000 1.149 .002 )
- (mix-fmsimp 52.813 2.030 329.628 .167 f1 f5 5.000 1.916 5.000 1.234 .002 )
- (mix-fmsimp 53.563 1.524 590.360 .241 f1 f5 4.000 2.119 4.000 .374 .003 )
- (mix-fmsimp 53.813 1.761 554.365 .433 f1 f5 3.000 2.168 3.000 .269 .003 )
- (mix-fmsimp 54.313 2.720 434.908 .425 f1 f5 3.000 2.184 1.000 1.209 .003 )
- (mix-fmsimp 55.813 1.966 440.000 .426 f1 f5 4.000 2.196 2.000 1.493 .004 )
- (mix-fmsimp 56.563 1.446 415.305 .316 f1 f5 4.000 2.312 1.000 .753 .004 )
- (mix-fmsimp 56.813 2.205 369.994 .406 f1 f5 2.000 2.361 1.000 .292 .004 )
- (mix-fmsimp 57.813 1.668 329.628 .400 f1 f5 4.000 2.377 1.000 .179 .005 )
- (mix-fmsimp 58.313 1.422 329.628 .394 f1 f5 4.000 2.441 3.000 1.117 .005 )
- (mix-fmsimp 58.563 1.360 435.856 .250 f1 f5 1.000 1.960 5.000 .811 .005 )
- (mix-fmsimp 58.750 1.919 440.000 .389 f1 f5 2.000 2.489 3.000 .242 .005 )
- (mix-fmsimp 59.500 1.405 439.947 .387 f1 f5 3.000 2.501 4.000 1.265 .006 )
- (mix-fmsimp 59.750 2.173 249.594 .073 f1 f5 2.000 2.550 2.000 .351 .006 )
- (mix-fmsimp 60.750 1.881 329.628 .200 f1 f5 2.000 2.566 2.000 1.431 .006 )
- (mix-fmsimp 61.500 1.367 293.665 .240 f1 f5 1.000 2.096 1.000 1.378 .007 )
- (mix-fmsimp 61.750 1.613 554.365 .363 f1 f5 1.000 2.678 1.000 .201 .007 )
- (mix-fmsimp 62.250 2.603 433.901 .356 f1 f5 2.000 2.694 5.000 .950 .007 )
- (mix-fmsimp 63.750 1.809 440.000 .354 f1 f5 4.000 2.727 4.000 .459 .008 )
- (mix-fmsimp 64.500 1.314 415.305 .320 f1 f5 3.000 2.265 1.000 1.059 .008 )
- (mix-fmsimp 64.750 2.057 374.139 .341 f1 f5 2.000 2.307 3.000 .054 .008 )
- (mix-fmsimp 65.750 1.538 329.628 .335 f1 f5 4.000 2.887 3.000 1.281 .009 )
- (mix-fmsimp 66.250 1.278 329.628 .326 f1 f5 3.000 2.952 4.000 .363 .009 )
- (mix-fmsimp 66.500 1.211 440.000 .322 f1 f5 5.000 2.405 4.000 .361 .009 )
- (mix-fmsimp 66.688 1.769 440.000 .319 f1 f5 4.000 2.419 3.000 .190 .009 )
- (mix-fmsimp 67.438 1.256 437.237 .316 f1 f5 1.000 2.430 2.000 1.121 .010 )
- (mix-fmsimp 67.688 1.979 246.942 .056 f1 f5 2.000 2.472 4.000 1.172 .010 )
- (mix-fmsimp 68.688 1.736 330.174 .250 f1 f5 4.000 2.486 3.000 .893 .010 )
- (mix-fmsimp 69.438 1.213 292.204 .238 f1 f5 5.000 2.732 1.000 1.265 .011 )
- (mix-fmsimp 69.688 1.462 553.724 .294 f1 f5 3.000 3.189 3.000 .427 .011 )
- (mix-fmsimp 70.188 2.455 440.000 .292 f1 f5 2.000 2.598 5.000 .489 .011 )
- (mix-fmsimp 71.688 1.654 440.000 .284 f1 f5 5.000 3.237 2.000 1.299 .012 )
- (mix-fmsimp 72.438 1.175 415.305 .277 f1 f5 3.000 2.995 4.000 .916 .012 )
- (mix-fmsimp 72.688 1.933 369.994 .271 f1 f5 1.000 3.382 1.000 .886 .012 )
- (mix-fmsimp 73.688 1.639 440.000 .046 f1 f5 4.000 3.398 5.000 .993 .012 )
- (mix-fmsimp 74.438 15.942 329.628 .257 f1 f5 1.000 2.822 1.000 .402 .011 )
- (mix-fmsimp 74.938 (- 45.394 20) 329.628 .249 f1 f5 1.000 2.864 2.000 1.093 .011 )
- (mix-fmsimp 75.438 (- 45.063 20) 440.000 .246 f1 f5 3.000 3.543 2.000 .978 .011 )
- (mix-fmsimp 75.625 (- 45.335 20) 444.508 .244 f1 f5 2.000 2.920 4.000 .563 .011 )
- (mix-fmsimp 76.375 (- 44.125 20) 445.106 .240 f1 f5 3.000 2.931 2.000 .768 .010 )
- (mix-fmsimp 76.625 (- 43.875 20) 248.294 .038 f1 f5 2.000 2.973 2.000 .155 .010 )
- (mix-fmsimp 77.625 (- 43.455 20) 334.084 .234 f1 f5 3.000 2.987 4.000 .047 .010 )
- (mix-fmsimp 78.375 (- 41.938 20) 292.359 .222 f1 f5 3.000 3.521 5.000 1.140 .009 )
- (mix-fmsimp 78.625 (- 41.605 20) 554.365 .215 f1 f5 2.000 3.085 4.000 .595 .009 )
- (mix-fmsimp 79.125 (- 41.769 20) 440.000 .214 f1 f5 3.000 3.780 3.000 .541 .009 )
- (mix-fmsimp 80.625 (- 39.875 20) 440.000 .200 f1 f5 3.000 3.812 2.000 1.111 .008 )
- (mix-fmsimp 91.130 (- 29.335 20) 415.305 .111 f1 f5 3.000 3.759 2.000 .490 .003 )
+ (mix-fmsimp .000 2.488 659.255 .500 f1 5.000 1.260 2.000 .501)
+ (mix-fmsimp .750 1.988 654.084 .167 f1 3.000 1.260 1.000 .710)
+ (mix-fmsimp 1.000 2.738 880.000 .500 f1 5.000 1.260 1.000 .140)
+ (mix-fmsimp 2.000 2.488 880.000 .500 f1 1.000 1.671 2.000 .745)
+ (mix-fmsimp 2.750 1.969 871.429 .495 f1 5.000 1.312 1.000 .447)
+ (mix-fmsimp 3.000 2.750 493.883 .100 f1 1.000 1.260 2.000 1.069)
+ (mix-fmsimp 4.000 2.488 654.568 .500 f1 3.000 1.671 5.000 .793)
+ (mix-fmsimp 4.750 1.988 590.042 .241 f1 2.000 1.671 5.000 1.046)
+ (mix-fmsimp 5.000 2.238 551.574 .500 f1 4.000 1.671 1.000 .073)
+ (mix-fmsimp 5.500 2.238 664.174 .504 f1 3.000 1.671 4.000 .791)
+ (mix-fmsimp 6.000 1.988 659.255 .400 f1 2.000 1.671 2.000 .955)
+ (mix-fmsimp 6.250 2.738 880.000 .400 f1 5.000 1.260 5.000 .645)
+ (mix-fmsimp 7.250 2.505 885.724 .336 f1 5.000 1.260 4.000 .302)
+ (mix-fmsimp 8.000 1.988 880.000 .500 f1 3.000 1.260 2.000 .672)
+ (mix-fmsimp 8.250 2.738 493.883 .100 f1 4.000 1.671 1.000 .013)
+ (mix-fmsimp 9.250 2.488 659.255 .250 f1 3.000 1.671 3.000 1.167)
+ (mix-fmsimp 10.000 1.988 587.330 .240 f1 2.000 1.314 5.000 .423)
+ (mix-fmsimp 10.250 2.238 554.365 .500 f1 1.000 1.671 2.000 .078)
+ (mix-fmsimp 10.750 2.238 659.255 .500 f1 1.000 1.260 5.000 .797)
+ (mix-fmsimp 11.250 1.988 651.332 .400 f1 5.000 1.671 1.000 .883)
+ (mix-fmsimp 11.500 1.926 878.372 .200 f1 1.000 1.434 4.000 .322)
+ (mix-fmsimp 11.688 2.497 880.000 .335 f1 2.000 1.671 4.000 .879)
+ (mix-fmsimp 12.438 2.006 887.764 .288 f1 1.000 1.671 4.000 .652)
+ (mix-fmsimp 12.688 2.738 493.883 .100 f1 1.000 1.671 4.000 .521)
+ (mix-fmsimp 13.688 2.488 659.255 .250 f1 2.000 1.671 2.000 1.247)
+ (mix-fmsimp 14.438 1.988 587.330 .240 f1 1.000 1.260 2.000 1.182)
+ (mix-fmsimp 14.688 2.238 547.848 .494 f1 4.000 1.671 2.000 .432)
+ (mix-fmsimp 15.188 3.238 867.651 .500 f1 4.000 1.671 1.000 .571)
+ (mix-fmsimp 16.688 2.238 659.255 .400 f1 4.000 1.671 4.000 .477)
+ (mix-fmsimp 17.188 1.988 652.468 .495 f1 3.000 1.671 2.000 .438)
+ (mix-fmsimp 17.438 1.926 880.000 .200 f1 2.000 1.671 4.000 1.107)
+ (mix-fmsimp 17.625 2.523 880.000 .500 f1 5.000 1.671 1.000 .830)
+ (mix-fmsimp 18.375 1.988 880.000 .400 f1 4.000 1.671 3.000 .186)
+ (mix-fmsimp 18.625 2.738 493.883 .100 f1 1.000 1.260 5.000 .407)
+ (mix-fmsimp 19.625 2.488 657.231 .166 f1 5.000 1.260 2.000 .389)
+ (mix-fmsimp 20.375 1.976 587.330 .238 f1 2.000 1.671 1.000 .712)
+ (mix-fmsimp 20.625 2.238 554.365 .500 f1 3.000 1.260 5.000 .171)
+ (mix-fmsimp 21.125 3.238 880.000 .500 f1 4.000 1.671 1.000 .507)
+ (mix-fmsimp 22.625 2.238 650.838 .395 f1 3.000 1.671 4.000 .160)
+ (mix-fmsimp 23.125 1.978 659.255 .497 f1 1.000 1.671 1.000 .867)
+ (mix-fmsimp 23.375 1.926 885.243 .333 f1 2.000 1.412 4.000 .811)
+ (mix-fmsimp 23.563 2.488 880.000 .500 f1 4.000 1.671 3.000 .439)
+ (mix-fmsimp 24.313 1.995 882.799 .401 f1 1.000 1.671 4.000 1.089)
+ (mix-fmsimp 24.563 2.730 246.942 .100 f1 2.000 1.671 1.000 .092)
+ (mix-fmsimp 25.563 2.488 329.628 .167 f1 2.000 1.671 2.000 1.149)
+ (mix-fmsimp 26.313 2.007 587.330 .242 f1 3.000 1.671 3.000 .472)
+ (mix-fmsimp 26.563 2.238 548.468 .495 f1 2.000 1.671 1.000 .259)
+ (mix-fmsimp 27.063 3.238 439.221 .500 f1 3.000 1.260 3.000 1.014)
+ (mix-fmsimp 28.563 2.493 441.603 .401 f1 3.000 1.671 5.000 .056)
+ (mix-fmsimp 29.313 2.220 659.255 .500 f1 3.000 1.260 3.000 1.108)
+ (mix-fmsimp 29.813 1.960 329.628 .500 f1 1.000 1.671 1.000 .944)
+ (mix-fmsimp 30.063 1.894 440.000 .333 f1 1.000 1.260 4.000 .602)
+ (mix-fmsimp 30.250 2.453 443.160 .400 f1 1.000 1.260 3.000 .750)
+ (mix-fmsimp 31.000 1.938 441.168 .333 f1 5.000 1.671 3.000 .522)
+ (mix-fmsimp 31.250 2.684 246.942 .100 f1 5.000 1.654 1.000 1.020)
+ (mix-fmsimp 32.250 2.415 325.263 .167 f1 4.000 1.671 3.000 .014)
+ (mix-fmsimp 33.000 1.901 587.330 .240 f1 4.000 1.671 5.000 1.106)
+ (mix-fmsimp 33.250 2.149 554.936 .501 f1 2.000 1.260 2.000 1.159)
+ (mix-fmsimp 33.750 3.137 440.000 .500 f1 2.000 1.671 1.000 .647)
+ (mix-fmsimp 35.250 2.359 440.000 .400 f1 5.000 1.671 4.000 1.149)
+ (mix-fmsimp 36.000 2.101 661.109 .501 f1 4.000 1.377 2.000 1.121)
+ (mix-fmsimp 36.500 1.836 329.628 .500 f1 2.000 1.671 4.000 1.459)
+ (mix-fmsimp 36.750 1.768 440.000 .250 f1 5.000 1.671 5.000 .601)
+ (mix-fmsimp 36.938 2.327 442.815 .400 f1 2.000 1.671 3.000 .354)
+ (mix-fmsimp 37.688 1.813 440.000 .400 f1 4.000 1.671 2.000 .205)
+ (mix-fmsimp 37.938 2.559 246.712 .100 f1 4.000 1.671 2.000 1.044)
+ (mix-fmsimp 38.938 2.290 329.628 .167 f1 1.000 1.260 2.000 1.316)
+ (mix-fmsimp 39.688 1.781 587.330 .240 f1 1.000 1.671 3.000 .524)
+ (mix-fmsimp 39.938 2.021 554.365 .500 f1 1.000 1.671 2.000 .522)
+ (mix-fmsimp 40.438 2.998 438.022 .498 f1 3.000 1.260 4.000 .264)
+ (mix-fmsimp 41.938 2.253 443.810 .403 f1 1.000 1.671 4.000 1.157)
+ (mix-fmsimp 42.688 1.720 414.691 .319 f1 4.000 1.671 1.000 .612)
+ (mix-fmsimp 42.938 1.965 659.255 .500 f1 2.000 1.671 2.000 .559)
+ (mix-fmsimp 43.438 1.690 329.628 .496 f1 5.000 1.671 2.000 1.457)
+ (mix-fmsimp 43.688 1.630 440.000 .249 f1 2.000 1.671 5.000 .505)
+ (mix-fmsimp 43.875 2.197 440.000 .400 f1 3.000 1.260 3.000 .843)
+ (mix-fmsimp 44.625 1.678 440.000 .332 f1 2.000 1.671 5.000 1.165)
+ (mix-fmsimp 44.875 2.405 246.942 .100 f1 4.000 1.671 3.000 .105)
+ (mix-fmsimp 45.875 2.160 332.580 .168 f1 1.000 1.260 5.000 1.107)
+ (mix-fmsimp 46.625 1.646 583.584 .238 f1 4.000 1.673 5.000 .201)
+ (mix-fmsimp 46.875 1.891 553.184 .492 f1 1.000 1.304 2.000 1.230)
+ (mix-fmsimp 47.375 2.882 438.012 .489 f1 5.000 1.737 4.000 .024)
+ (mix-fmsimp 48.875 2.104 440.000 .487 f1 2.000 1.770 2.000 .308)
+ (mix-fmsimp 49.625 1.590 414.068 .319 f1 4.000 1.866 3.000 .415)
+ (mix-fmsimp 49.875 1.835 659.255 .467 f1 1.000 1.914 3.000 .477)
+ (mix-fmsimp 50.375 1.592 333.127 .470 f1 5.000 1.930 2.000 .230)
+ (mix-fmsimp 50.625 1.509 440.000 .250 f1 5.000 1.963 1.000 .829)
+ (mix-fmsimp 50.813 2.068 440.000 .400 f1 3.000 1.979 1.000 1.450)
+ (mix-fmsimp 51.563 1.536 434.964 .330 f1 4.000 1.991 2.000 .308)
+ (mix-fmsimp 51.813 2.299 246.942 .088 f1 4.000 1.581 5.000 1.149)
+ (mix-fmsimp 52.813 2.030 329.628 .167 f1 5.000 1.916 5.000 1.234)
+ (mix-fmsimp 53.563 1.524 590.360 .241 f1 4.000 2.119 4.000 .374)
+ (mix-fmsimp 53.813 1.761 554.365 .433 f1 3.000 2.168 3.000 .269)
+ (mix-fmsimp 54.313 2.720 434.908 .425 f1 3.000 2.184 1.000 1.209)
+ (mix-fmsimp 55.813 1.966 440.000 .426 f1 4.000 2.196 2.000 1.493)
+ (mix-fmsimp 56.563 1.446 415.305 .316 f1 4.000 2.312 1.000 .753)
+ (mix-fmsimp 56.813 2.205 369.994 .406 f1 2.000 2.361 1.000 .292)
+ (mix-fmsimp 57.813 1.668 329.628 .400 f1 4.000 2.377 1.000 .179)
+ (mix-fmsimp 58.313 1.422 329.628 .394 f1 4.000 2.441 3.000 1.117)
+ (mix-fmsimp 58.563 1.360 435.856 .250 f1 1.000 1.960 5.000 .811)
+ (mix-fmsimp 58.750 1.919 440.000 .389 f1 2.000 2.489 3.000 .242)
+ (mix-fmsimp 59.500 1.405 439.947 .387 f1 3.000 2.501 4.000 1.265)
+ (mix-fmsimp 59.750 2.173 249.594 .073 f1 2.000 2.550 2.000 .351)
+ (mix-fmsimp 60.750 1.881 329.628 .200 f1 2.000 2.566 2.000 1.431)
+ (mix-fmsimp 61.500 1.367 293.665 .240 f1 1.000 2.096 1.000 1.378)
+ (mix-fmsimp 61.750 1.613 554.365 .363 f1 1.000 2.678 1.000 .201)
+ (mix-fmsimp 62.250 2.603 433.901 .356 f1 2.000 2.694 5.000 .950)
+ (mix-fmsimp 63.750 1.809 440.000 .354 f1 4.000 2.727 4.000 .459)
+ (mix-fmsimp 64.500 1.314 415.305 .320 f1 3.000 2.265 1.000 1.059)
+ (mix-fmsimp 64.750 2.057 374.139 .341 f1 2.000 2.307 3.000 .054)
+ (mix-fmsimp 65.750 1.538 329.628 .335 f1 4.000 2.887 3.000 1.281)
+ (mix-fmsimp 66.250 1.278 329.628 .326 f1 3.000 2.952 4.000 .363)
+ (mix-fmsimp 66.500 1.211 440.000 .322 f1 5.000 2.405 4.000 .361)
+ (mix-fmsimp 66.688 1.769 440.000 .319 f1 4.000 2.419 3.000 .190)
+ (mix-fmsimp 67.438 1.256 437.237 .316 f1 1.000 2.430 2.000 1.121)
+ (mix-fmsimp 67.688 1.979 246.942 .056 f1 2.000 2.472 4.000 1.172)
+ (mix-fmsimp 68.688 1.736 330.174 .250 f1 4.000 2.486 3.000 .893)
+ (mix-fmsimp 69.438 1.213 292.204 .238 f1 5.000 2.732 1.000 1.265)
+ (mix-fmsimp 69.688 1.462 553.724 .294 f1 3.000 3.189 3.000 .427)
+ (mix-fmsimp 70.188 2.455 440.000 .292 f1 2.000 2.598 5.000 .489)
+ (mix-fmsimp 71.688 1.654 440.000 .284 f1 5.000 3.237 2.000 1.299)
+ (mix-fmsimp 72.438 1.175 415.305 .277 f1 3.000 2.995 4.000 .916)
+ (mix-fmsimp 72.688 1.933 369.994 .271 f1 1.000 3.382 1.000 .886)
+ (mix-fmsimp 73.688 1.639 440.000 .046 f1 4.000 3.398 5.000 .993)
+ (mix-fmsimp 74.438 15.942 329.628 .257 f1 1.000 2.822 1.000 .402)
+ (mix-fmsimp 74.938 (- 45.394 20) 329.628 .249 f1 1.000 2.864 2.000 1.093)
+ (mix-fmsimp 75.438 (- 45.063 20) 440.000 .246 f1 3.000 3.543 2.000 .978)
+ (mix-fmsimp 75.625 (- 45.335 20) 444.508 .244 f1 2.000 2.920 4.000 .563)
+ (mix-fmsimp 76.375 (- 44.125 20) 445.106 .240 f1 3.000 2.931 2.000 .768)
+ (mix-fmsimp 76.625 (- 43.875 20) 248.294 .038 f1 2.000 2.973 2.000 .155)
+ (mix-fmsimp 77.625 (- 43.455 20) 334.084 .234 f1 3.000 2.987 4.000 .047)
+ (mix-fmsimp 78.375 (- 41.938 20) 292.359 .222 f1 3.000 3.521 5.000 1.140)
+ (mix-fmsimp 78.625 (- 41.605 20) 554.365 .215 f1 2.000 3.085 4.000 .595)
+ (mix-fmsimp 79.125 (- 41.769 20) 440.000 .214 f1 3.000 3.780 3.000 .541)
+ (mix-fmsimp 80.625 (- 39.875 20) 440.000 .200 f1 3.000 3.812 2.000 1.111)
+ (mix-fmsimp 91.130 (- 29.335 20) 415.305 .111 f1 3.000 3.759 2.000 .490)
ind))))
- (if with-gui
- (begin
-
- (do ((test-ctr 0 (+ 1 test-ctr)))
- ((= test-ctr tests))
-
- (let ((ind (new-sound "test.snd" :size 10)))
- (let ((v (float-vector .1 .2 .3)))
- (let ((id (mix-float-vector v 0)))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector .1 .2 .3 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix v at 0: ~A" nv)))
- (let ((eds (edit-tree ind 0)))
- (if (not (feql eds '((0 0 0 2 0.0 0.0 0.0 3) (3 0 3 9 0.0 0.0 0.0 2) (10 -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";mix v at 0 eds: ~A" eds)))
- (if (not (mix? id))
- (snd-display #__line__ ";mix v at 0 id from mix?: ~A" id))
- (if (fneq (mix-amp id) 1.0) (snd-display #__line__ ";mix v at 0 amp: ~A" (mix-amp id)))
- (if (fneq (mix-speed id) 1.0) (snd-display #__line__ ";mix v at 0 speed: ~A" (mix-speed id)))
- (if (not (= (mix-sync id) 0)) (snd-display #__line__ ";mix v at 0 sync: ~A" (mix-sync id)))
- (if (not (null? (mix-amp-env id))) (snd-display #__line__ ";mix v at 0 amp-env: ~A" (mix-amp-env id)))
- (if (not (= (mix-position id) 0)) (snd-display #__line__ ";mix v at 0 beg: ~A" (mix-position id)))
- (if (not (= (mix-length id) 3)) (snd-display #__line__ ";mix v at 0 length: ~A" (mix-length id)))
- (if (not (equal? (mix-name id) "")) (snd-display #__line__ ";mix v at 0 name: ~A" (mix-name id)))
- (if (not (null? (mix-properties id))) (snd-display #__line__ ";mix v at 0 properties: ~A" (mix-properties id)))
- (if (not (equal? (mix-color id) *mix-color*)) (snd-display #__line__ ";mix v at 0 color: ~A" (mix-color id)))
- (if (not (= (mix-tag-y id) 0)) (snd-display #__line__ ";mix v at 0 tag-y: ~A" (mix-tag-y id)))
- (let ((sf (make-mix-sampler id))
- (data (make-float-vector 10)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-mix-sample sf)))
- (if (not (vequal data (channel->float-vector)))
- (snd-display #__line__ ";mix v at 0 read mix samples: ~A" data))
- (if (not (sampler-at-end? sf)) (snd-display #__line__ ";mix v at 0 reader not at end?"))
- (free-sampler sf))
- (if (not (equal? (mixes ind 0) (list id))) (snd-display #__line__ ";mix v at 0 mixes: ~A" (mixes ind 0)))
- (if (not (equal? (mix-home id) (list ind 0 #f 0))) (snd-display #__line__ ";mix v at 0 home: ~A" (mix-home id)))
- (undo))
- (mix-float-vector v 8)
- (if (not (= (framples ind 0) 11)) (snd-display #__line__ ";mix v at 8 new len: ~A" (framples ind 0)))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0 0 0 0 0 0 0 0 .1 .2 .3)))
- (snd-display #__line__ ";mix v at 8: ~A" nv)))
- (undo)
- (mix-float-vector v 3)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";mix v at 3 new len: ~A" (framples ind 0)))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0 0 0 .1 .2 .3 0 0 0 0)))
- (snd-display #__line__ ";mix v at 3: ~A" nv)))
- (undo))
- (let ((v (make-float-vector 20 .5)))
- (mix-float-vector v 0)
- (if (not (= (framples ind 0) 20)) (snd-display #__line__ ";mix v20 at 0 new len: ~A" (framples ind 0))))
- (close-sound ind))
+ (when with-gui
+ (do ((test-ctr 0 (+ 1 test-ctr)))
+ ((= test-ctr tests))
+
+ (let ((ind (new-sound "test.snd" :size 10)))
+ (let ((v (float-vector .1 .2 .3)))
+ (let ((id (mix-float-vector v 0)))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector .1 .2 .3 0 0 0 0 0 0 0)))
+ (snd-display ";mix v at 0: ~A" nv)))
+ (let ((eds (edit-tree ind 0)))
+ (if (not (feql eds '((0 0 0 2 0.0 0.0 0.0 3) (3 0 3 9 0.0 0.0 0.0 2) (10 -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";mix v at 0 eds: ~A" eds)))
+ (if (not (mix? id))
+ (snd-display ";mix v at 0 id from mix?: ~A" id))
+ (if (fneq (mix-amp id) 1.0) (snd-display ";mix v at 0 amp: ~A" (mix-amp id)))
+ (if (fneq (mix-speed id) 1.0) (snd-display ";mix v at 0 speed: ~A" (mix-speed id)))
+ (if (not (= (mix-sync id) 0)) (snd-display ";mix v at 0 sync: ~A" (mix-sync id)))
+ (if (not (null? (mix-amp-env id))) (snd-display ";mix v at 0 amp-env: ~A" (mix-amp-env id)))
+ (if (not (= (mix-position id) 0)) (snd-display ";mix v at 0 beg: ~A" (mix-position id)))
+ (if (not (= (mix-length id) 3)) (snd-display ";mix v at 0 length: ~A" (mix-length id)))
+ (if (not (equal? (mix-name id) "")) (snd-display ";mix v at 0 name: ~A" (mix-name id)))
+ (if (not (null? (mix-properties id))) (snd-display ";mix v at 0 properties: ~A" (mix-properties id)))
+ (if (not (equal? (mix-color id) *mix-color*)) (snd-display ";mix v at 0 color: ~A" (mix-color id)))
+ (if (not (= (mix-tag-y id) 0)) (snd-display ";mix v at 0 tag-y: ~A" (mix-tag-y id)))
+ (let ((sf (make-mix-sampler id))
+ (data (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-mix-sample sf)))
+ (if (not (vequal data (channel->float-vector)))
+ (snd-display ";mix v at 0 read mix samples: ~A" data))
+ (if (not (sampler-at-end? sf)) (snd-display ";mix v at 0 reader not at end?"))
+ (free-sampler sf))
+ (if (not (equal? (mixes ind 0) (list id))) (snd-display ";mix v at 0 mixes: ~A" (mixes ind 0)))
+ (if (not (equal? (mix-home id) (list ind 0 #f 0))) (snd-display ";mix v at 0 home: ~A" (mix-home id)))
+ (undo))
+ (mix-float-vector v 8)
+ (if (not (= (framples ind 0) 11)) (snd-display ";mix v at 8 new len: ~A" (framples ind 0)))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector 0 0 0 0 0 0 0 0 .1 .2 .3)))
+ (snd-display ";mix v at 8: ~A" nv)))
+ (undo)
+ (mix-float-vector v 3)
+ (if (not (= (framples ind 0) 10)) (snd-display ";mix v at 3 new len: ~A" (framples ind 0)))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector 0 0 0 .1 .2 .3 0 0 0 0)))
+ (snd-display ";mix v at 3: ~A" nv)))
+ (undo))
+ (let ((v (make-float-vector 20 .5)))
+ (mix-float-vector v 0)
+ (if (not (= (framples ind 0) 20)) (snd-display ";mix v20 at 0 new len: ~A" (framples ind 0))))
+ (close-sound ind))
+
+ (let ((ind (new-sound "test.snd" :size 100000)))
+ (let ((id (car (mix "oboe.snd" 0))))
+ (if (not (mix? id))
+ (snd-display ";mix oboe at 0 id from mix?: ~A" id))
+ (if (fneq (mix-amp id) 1.0) (snd-display ";mix oboe at 0 amp: ~A" (mix-amp id)))
+ (if (fneq (mix-speed id) 1.0) (snd-display ";mix oboe at 0 speed: ~A" (mix-speed id)))
+ (if (not (= (mix-sync id) 0)) (snd-display ";mix oboe at 0 sync: ~A" (mix-sync id)))
+ (if (not (null? (mix-amp-env id))) (snd-display ";mix oboe at 0 amp-env: ~A" (mix-amp-env id)))
+ (if (not (= (mix-position id) 0)) (snd-display ";mix oboe at 0 beg: ~A" (mix-position id)))
+ (if (not (= (mix-length id) 50828)) (snd-display ";mix oboe at 0 length: ~A" (mix-length id)))
+ (if (not (equal? (mix-name id) "")) (snd-display ";mix oboe at 0 name: ~A" (mix-name id)))
+ (if (not (null? (mix-properties id))) (snd-display ";mix oboe at 0 properties: ~A" (mix-properties id)))
+ (if (not (equal? (mix-color id) *mix-color*)) (snd-display ";mix oboe at 0 color: ~A" (mix-color id)))
+ (if (not (= (mix-tag-y id) 0)) (snd-display ";mix oboe at 0 tag-y: ~A" (mix-tag-y id)))
- (let ((ind (new-sound "test.snd" :size 100000)))
- (let ((id (car (mix "oboe.snd" 0))))
- (if (not (mix? id))
- (snd-display #__line__ ";mix oboe at 0 id from mix?: ~A" id))
- (if (fneq (mix-amp id) 1.0) (snd-display #__line__ ";mix oboe at 0 amp: ~A" (mix-amp id)))
- (if (fneq (mix-speed id) 1.0) (snd-display #__line__ ";mix oboe at 0 speed: ~A" (mix-speed id)))
- (if (not (= (mix-sync id) 0)) (snd-display #__line__ ";mix oboe at 0 sync: ~A" (mix-sync id)))
- (if (not (null? (mix-amp-env id))) (snd-display #__line__ ";mix oboe at 0 amp-env: ~A" (mix-amp-env id)))
- (if (not (= (mix-position id) 0)) (snd-display #__line__ ";mix oboe at 0 beg: ~A" (mix-position id)))
- (if (not (= (mix-length id) 50828)) (snd-display #__line__ ";mix oboe at 0 length: ~A" (mix-length id)))
- (if (not (equal? (mix-name id) "")) (snd-display #__line__ ";mix oboe at 0 name: ~A" (mix-name id)))
- (if (not (null? (mix-properties id))) (snd-display #__line__ ";mix oboe at 0 properties: ~A" (mix-properties id)))
- (if (not (equal? (mix-color id) *mix-color*)) (snd-display #__line__ ";mix oboe at 0 color: ~A" (mix-color id)))
- (if (not (= (mix-tag-y id) 0)) (snd-display #__line__ ";mix oboe at 0 tag-y: ~A" (mix-tag-y id)))
-
- (if (fneq (maxamp ind 0) .14724) (snd-display #__line__ ";mix oboe maxamp: ~A" (maxamp ind 0)))
- (if (not (equal? (mixes ind 0) (list id))) (snd-display #__line__ ";mix oboe at 0 mixes: ~A" (mixes ind 0)))
- (if (not (equal? (mix-home id) (list ind 0 "/home/bil/cl/oboe.snd" 0))) (snd-display #__line__ ";mix oboe at 0 home: ~A" (mix-home id))))
- (undo)
- (mix "oboe.snd" 70000)
- (if (not (= (framples ind 0) (+ 70000 50828))) (snd-display #__line__ ";mix oboe at 70k framples: ~A" (framples ind 0)))
- (close-sound ind))
-
- (let ((ind (new-sound "test.snd" :size 10)))
- (let ((v (float-vector .1 .2 .3)))
- (let ((id (mix-float-vector v 0)))
- (scale-by 2.0)
- (if (not (mix? id)) (snd-display #__line__ ";scaled (2) mix not active?"))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector-scale! (float-vector .1 .2 .3 0 0 0 0 0 0 0) 2.0)))
- (snd-display #__line__ ";mix v at 0 scale-by 2: ~A" nv)))
- (if (fneq (mix-amp id) 2.0) (snd-display #__line__ ";mix then scale mix amp: ~A" (mix-amp id)))
- (undo)
- (delete-sample 1)
- (if (not (mix? id)) (snd-display #__line__ ";delete hit mix: ~A" (mix? id)))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector .1 .3 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix v at 0 delete .2: ~A" nv)))
- (revert-sound ind))
- (let ((id (mix-float-vector v 0)))
- (delete-sample 7)
- (reverse-sound ind 0)
- (if (not (mix? id)) (snd-display #__line__ ";reversed mix: ~A" (mix? id)))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (reverse! (float-vector .1 .2 .3 0 0 0 0 0 0))))
- (snd-display #__line__ ";mix v at 0 reversed: ~A" nv)))
- (undo)
- (if (not (mix? id)) (snd-display #__line__ ";revert reverse mix: ~A" (mix? id)))
- (map-channel (lambda (y) .1))
- (if (not (mix? id)) (snd-display #__line__ ";clobbered mix: ~A" (mixes)))
- (scale-by 2.0)
- (let ((id (mix-float-vector v 0)))
- (if (not (mix? id)) (snd-display #__line__ ";mix on scale (2) not active?"))
- (scale-by 3.0)
- (if (not (mix? id)) (snd-display #__line__ ";scaled (3) mix not active?"))
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector-scale! (float-vector-add! (make-float-vector 9 .2) (float-vector .1 .2 .3)) 3.0)))
- (snd-display #__line__ ";mix v at 0 scale-by 2 and 3: ~A" nv))))
- (revert-sound ind)
- (map-channel (lambda (y) 1.0))
- (env-channel '(0 0 1 1 2 0) 0 11)
- (let ((v (float-vector .1 .2 .3)))
- (mix-float-vector v 3)
- (let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0.000 0.200 0.400 0.700 1.000 1.300 0.800 0.600 0.400 0.200)))
- (snd-display #__line__ ";mix v at 3 after env: ~A" nv))))
- (close-sound ind))))
-
- (let ((ind (new-sound "test.snd" :size 100)))
- (let ((v (float-vector .1 .2 .3)))
- (let ((id (mix-float-vector v 10)))
- (pad-channel 0 10)
- (if (not (mix? id)) (snd-display #__line__ ";padded mix not active?"))
- (if (not (= (mix-position id) 20)) (snd-display #__line__ ";after pad mix pos: ~A" (mix-position id)))
- (set! (mix-sync id) 2)
- (if (not (= (mix-sync id) 2)) (snd-display #__line__ ";set mix sync 2: ~A" (mix-sync id)))
- (if (and full-test (< (mix-sync-max) 2)) (snd-display #__line__ ";mix-sync-max: ~A" (mix-sync-max)))
- (pad-channel 50 10)
- (if (not (mix? id)) (snd-display #__line__ ";padded 50 mix not active?"))
- (if (not (= (mix-position id) 20)) (snd-display #__line__ ";after pad 50 mix pos: ~A" (mix-position id)))
- (undo 1)
- (let ((id1 (mix-float-vector v 22))
- (id2 (mix-float-vector v 21)))
- (let ((vals (channel->float-vector 18 10)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.300 0.600 0.500 0.300 0.000 0.000 0.000)))
- (snd-display #__line__ ";mix 3 vs: ~A" vals))
- (if (not (mix? id)) (snd-display #__line__ ";mix 3vs 1 not active?"))
- (if (not (mix? id1)) (snd-display #__line__ ";mix 3vs 2 not active?"))
- (if (not (mix? id2)) (snd-display #__line__ ";mix 3vs 3 not active?"))
- (set! (mix-position id) 10)
- (set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.100 0.300 0.500 0.300 0.000 0.000 0.000)))
- (snd-display #__line__ ";mix 3 vs then move first: ~A" vals))
- (set! (mix-position id2) 30)
- (set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.000 0.000 0.000)))
- (snd-display #__line__ ";mix 3 vs then move 2: ~A" vals))
- (scale-by 2.0)
- (if (not (mix? id)) (snd-display #__line__ ";mix 3vs 1 scl not active?"))
- (if (not (mix? id1)) (snd-display #__line__ ";mix 3vs 2 scl not active?"))
- (if (not (mix? id2)) (snd-display #__line__ ";mix 3vs 3 scl not active?"))
- (set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.200 0.400 0.600 0.000 0.000 0.000)))
- (snd-display #__line__ ";mix 3 vs then move 2 scl: ~A" vals))
- (delete-sample 15)
- (if (not (mix? id)) (snd-display #__line__ ";mix 3vs 1 scl del not active?"))
- (if (not (mix? id1)) (snd-display #__line__ ";mix 3vs 2 scl del not active?"))
- (if (not (mix? id2)) (snd-display #__line__ ";mix 3vs 3 scl del not active?"))
- (if (not (= (mix-position id) 10)) (snd-display #__line__ ";mix 3vs etc pos: ~A" (mix-position id)))
- (if (not (= (mix-position id1) 21)) (snd-display #__line__ ";mix 3vs etc pos 1: ~A" (mix-position id1)))
- (if (not (= (mix-position id2) 29)) (snd-display #__line__ ";mix 3vs etc pos 2: ~A" (mix-position id2)))
- ))))
- (close-sound ind))
-
- (let ((ind (new-sound "test.snd" :size 15)))
- (let ((id (mix-float-vector (make-float-vector 11 1.0) 2)))
- (set! (mix-amp-env id) '(0 0 1 1))
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 0 0)))
- (snd-display #__line__ ";ramp mix amp env: ~A" vals)))
- (set! (mix-amp-env id) #f)
- (if (pair? (mix-amp-env id)) (snd-display #__line__ ";set mix-amp-env to null: ~A" (mix-amp-env id)))
- (set! (mix-speed id) 0.5)
- (if (not (= (framples) 24)) (snd-display #__line__ ";mix speed lengthens 24: ~A" (framples)))
- (set! (mix-speed id) 1.0)
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";return to mix original index: ~A" vals)))
- (set! (mix-amp-env id) '(0 0 1 1 2 1 3 0))
- (set! (mix-speed id) 0.5)
- (set! (mix-amp-env id) #f)
- (set! (mix-speed id) 1.0)
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";return again to mix original index: ~A" vals)))
- (close-sound ind)))
-
-
- (let ((id (open-sound "oboe.snd")))
- (make-selection 1000 2000 id 0)
- (let ((mix-id (car (mix-selection 3000 id 0))))
- (set! (mix-amp mix-id) .5)
- (if (fneq (mix-amp mix-id) .5)
- (snd-display #__line__ ";mix-amp .5: ~A" (mix-amp mix-id)))
- (scale-by .5)
- (undo)
- (close-sound id)))
- (set! *print-length* 30)
-
- (let* ((ind (open-sound "2.snd"))
- (md (car (mix "1a.snd" 1000 0 ind 1 #t))))
- (if (fneq (maxamp ind 1) .1665) (snd-display #__line__ ";maxamp after mix into chan 2: ~A" (maxamp ind 1)))
- (set! (mix-amp md) 0.0)
- (if (or (not (equal? (edits ind 0) (list 0 0)))
- (not (equal? (edits ind 1) (list 2 0))))
- (snd-display #__line__ ";mix into chan2 zeroed: ~A ~A" (edits ind 0) (edits ind 1)))
- (if (fneq (maxamp ind 1) .066) (snd-display #__line__ ";maxamp after mix zeroed into chan 2: ~A" (maxamp ind 1)))
- (set! (mix-amp md) 0.5)
- (if (fneq (maxamp ind 1) .116) (snd-display #__line__ ";maxamp after mix 0.5 into chan 2: ~A" (maxamp ind 1)))
- (set! (mix-speed md) 2.0)
- (if (fneq (/ (mix-length md) (mus-sound-framples "1a.snd")) 0.5)
- (snd-display #__line__ ";mix srate chan 2: ~A ~A" (mix-length md) (mus-sound-framples "1a.snd")))
- (update-time-graph)
- (set! (mix-speed md) 0.5)
- (update-time-graph)
- (set! (mix-amp md) 1.0)
- (if (fneq (maxamp ind 1) .166)
- (snd-display #__line__ ";non-sync mix-speed maxamp: ~A" (maxamp ind 1)))
- (set! (mix-amp-env md) '(0 0 1 1 2 0))
- (update-time-graph)
- (set! (mix-speed md) 1.0)
- (update-time-graph)
- (revert-sound ind)
- (set! (sync ind) 1)
- (let ((m0 (maxamp ind 0))
- (m1 (maxamp ind 1))
- (len (framples ind 0)))
- (set! md (mix "2.snd" 0 #t)) ; should double both chans, no len change
- (if (or (not (= (framples ind 0) len))
- (fneq (maxamp ind 0) (* 2 m0))
- (fneq (maxamp ind 1) (* 2 m1)))
- (snd-display #__line__ ";mix twice syncd: 0: ~A -> ~A, m1: ~A -> ~A, len: ~A -> ~A"
- m0 (maxamp ind 0) m1 (maxamp ind 1) len (framples ind 0)))
- (set! (hook-functions mix-release-hook) ())
- (close-sound ind)))
-
- (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "mix tests")))
- (insert-silence 0 20 ind)
- (let ((indout (new-sound "test.snd" 1 22050 mus-ldouble mus-next "mix tests")))
- (insert-silence 0 10 indout)
- (set! (sample 2 indout 0) .5)
- (set! (sample 5 indout 0) .25)
- (save-sound indout)
- (close-sound indout))
- (let ((tag (car (mix "test.snd"))))
- (let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
- (set! (v 2) .5)
- (set! (v 5) .25)
- (if (not (vequal samps v))
- (snd-display #__line__ ";mix 1->1: ~A ~A" samps v)))
- (if (not (mix? tag)) (snd-display #__line__ ";mix 1->1 tag: ~A" tag))
- (undo))
- (let ((tag (car (mix "test.snd" 5))))
- (let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
- (set! (v 7) .5)
- (set! (v 10) .25)
- (if (not (vequal samps v))
- (snd-display #__line__ ";mix 1->1 at 5: ~A ~A" samps v)))
- (if (not (mix? tag)) (snd-display #__line__ ";mix 1->1 at 5 tag: ~A" tag))
- (undo))
- (let ((tag (mix "test.snd" 0 0 ind 0 #f)))
- (let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
- (set! (v 2) .5)
- (set! (v 5) .25)
- (if (not (vequal samps v))
- (snd-display #__line__ ";mix 1->1 at 0 #f: ~A ~A" samps v)))
- (if (mix? tag) (snd-display #__line__ ";mix 1->1 at 5 #f tag: ~A" tag))
- (undo))
- (let ((indout (new-sound "test.snd" 2 22050 mus-ldouble mus-next "mix tests")))
- (insert-silence 0 10 indout 0)
- (insert-silence 0 10 indout 1)
- (set! (sample 2 indout 0) .5)
- (set! (sample 5 indout 0) .25)
- (set! (sample 2 indout 1) .95)
- (set! (sample 5 indout 1) .125)
- (save-sound indout)
- (close-sound indout))
- (let ((tag (car (mix "test.snd" 0 1))))
- (let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
- (set! (v 2) .95)
- (set! (v 5) .125)
- (if (not (vequal samps v))
- (snd-display #__line__ ";mix 2->1: ~A ~A" samps v)))
- (if (not (mix? tag)) (snd-display #__line__ ";mix 2->1 tag: ~A" tag))
- (undo))
- (let ((tag (car (mix "test.snd" 5 1))))
- (let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
- (set! (v 7) .95)
- (set! (v 10) .125)
- (if (not (vequal samps v))
- (snd-display #__line__ ";mix 2->1 at 5: ~A ~A" samps v)))
- (if (not (mix? tag)) (snd-display #__line__ ";mix 2->1 at 5 tag: ~A" tag))
- (undo))
- (close-sound ind)
- (set! ind (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "mix tests"))
- (insert-silence 0 20 ind 0)
- (insert-silence 0 20 ind 1)
- (let ((tag (car (mix "test.snd" 0 #t))))
- (let ((samps0 (channel->float-vector 0 20 ind 0))
- (samps1 (channel->float-vector 0 20 ind 1))
- (v (make-float-vector 20 0.0)))
- (set! (v 2) .95)
- (set! (v 5) .125)
- (if (not (vequal samps1 v))
- (snd-display #__line__ ";mix 1->1 (2): ~A ~A" samps1 v))
- (set! (v 2) .5)
- (set! (v 5) .25)
- (if (not (vequal samps0 v))
- (snd-display #__line__ ";mix 1->1 (3): ~A ~A" samps0 v)))
- (if (not (mix? tag)) (snd-display #__line__ ";mix 1->1 tag: ~A" tag))
- (undo 1 ind 0)
- (undo 1 ind 1))
- (let ((tag (mix "test.snd" 0 1 ind 1 #f))) ; samp:0, in-chan: 1
- (let ((samps0 (channel->float-vector 0 20 ind 0))
- (samps1 (channel->float-vector 0 20 ind 1))
- (v (make-float-vector 20 0.0)))
- (if (not (vequal samps0 v))
- (snd-display #__line__ ";mix 1->1 (4): ~A ~A" samps0 v))
- (set! (v 2) .95)
- (set! (v 5) .125)
- (if (not (vequal samps1 v))
- (snd-display #__line__ ";mix 1->1 (5): ~A ~A" samps1 v)))
- (if (mix? tag) (snd-display #__line__ ";mix 1->1 tag (5): ~A" tag))
- (undo 1 ind 1))
- (set! (sync ind) 1)
- (mix "test.snd" 0 #t)
- (let ((samps0 (channel->float-vector 0 20 ind 0))
- (samps1 (channel->float-vector 0 20 ind 1))
- (v (make-float-vector 20 0.0)))
- (set! (v 2) .5)
- (set! (v 5) .25)
- (if (not (vequal samps0 v))
- (snd-display #__line__ ";mix 1->1 (6): ~A ~A" samps0 v))
- (set! (v 2) .95)
- (set! (v 5) .125)
+ (if (fneq (maxamp ind 0) .14724) (snd-display ";mix oboe maxamp: ~A" (maxamp ind 0)))
+ (if (not (equal? (mixes ind 0) (list id))) (snd-display ";mix oboe at 0 mixes: ~A" (mixes ind 0)))
+ (if (not (equal? (mix-home id) (list ind 0 "/home/bil/cl/oboe.snd" 0))) (snd-display ";mix oboe at 0 home: ~A" (mix-home id))))
+ (undo)
+ (mix "oboe.snd" 70000)
+ (if (not (= (framples ind 0) 120828)) ;(+ 70000 50828)
+ (snd-display ";mix oboe at 70k framples: ~A" (framples ind 0)))
+ (close-sound ind))
+
+ (let ((ind (new-sound "test.snd" :size 10))
+ (v (float-vector .1 .2 .3)))
+ (let ((id (mix-float-vector v 0)))
+ (scale-by 2.0)
+ (if (not (mix? id)) (snd-display ";scaled (2) mix not active?"))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector-scale! (float-vector .1 .2 .3 0 0 0 0 0 0 0) 2.0)))
+ (snd-display ";mix v at 0 scale-by 2: ~A" nv)))
+ (if (fneq (mix-amp id) 2.0) (snd-display ";mix then scale mix amp: ~A" (mix-amp id)))
+ (undo)
+ (delete-sample 1)
+ (if (not (mix? id)) (snd-display ";delete hit mix: ~A" (mix? id)))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector .1 .3 0 0 0 0 0 0 0)))
+ (snd-display ";mix v at 0 delete .2: ~A" nv)))
+ (revert-sound ind))
+ (let ((id (mix-float-vector v 0)))
+ (delete-sample 7)
+ (reverse-sound ind 0)
+ (if (not (mix? id)) (snd-display ";reversed mix: ~A" (mix? id)))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (reverse! (float-vector .1 .2 .3 0 0 0 0 0 0))))
+ (snd-display ";mix v at 0 reversed: ~A" nv)))
+ (undo)
+ (if (not (mix? id)) (snd-display ";revert reverse mix: ~A" (mix? id)))
+ (map-channel (lambda (y) .1))
+ (if (not (mix? id)) (snd-display ";clobbered mix: ~A" (mixes)))
+ (scale-by 2.0)
+ (let ((id (mix-float-vector v 0)))
+ (if (not (mix? id)) (snd-display ";mix on scale (2) not active?"))
+ (scale-by 3.0)
+ (if (not (mix? id)) (snd-display ";scaled (3) mix not active?"))
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector-scale! (float-vector-add! (make-float-vector 9 .2) (float-vector .1 .2 .3)) 3.0)))
+ (snd-display ";mix v at 0 scale-by 2 and 3: ~A" nv))))
+ (revert-sound ind)
+ (map-channel (lambda (y) 1.0))
+ (env-channel '(0 0 1 1 2 0) 0 11)
+ (let ((v (float-vector .1 .2 .3)))
+ (mix-float-vector v 3)
+ (let ((nv (channel->float-vector)))
+ (if (not (vequal nv (float-vector 0.000 0.200 0.400 0.700 1.000 1.300 0.800 0.600 0.400 0.200)))
+ (snd-display ";mix v at 3 after env: ~A" nv))))
+ (close-sound ind)))
+
+ (let* ((ind (new-sound "test.snd" :size 100))
+ (v (float-vector .1 .2 .3))
+ (id (mix-float-vector v 10)))
+ (pad-channel 0 10)
+ (if (not (mix? id)) (snd-display ";padded mix not active?"))
+ (if (not (= (mix-position id) 20)) (snd-display ";after pad mix pos: ~A" (mix-position id)))
+ (set! (mix-sync id) 2)
+ (if (not (= (mix-sync id) 2)) (snd-display ";set mix sync 2: ~A" (mix-sync id)))
+ (if (and full-test (< (mix-sync-max) 2)) (snd-display ";mix-sync-max: ~A" (mix-sync-max)))
+ (pad-channel 50 10)
+ (if (not (mix? id)) (snd-display ";padded 50 mix not active?"))
+ (if (not (= (mix-position id) 20)) (snd-display ";after pad 50 mix pos: ~A" (mix-position id)))
+ (undo 1)
+ (let ((id1 (mix-float-vector v 22))
+ (id2 (mix-float-vector v 21)))
+ (let ((vals (channel->float-vector 18 10)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.300 0.600 0.500 0.300 0.000 0.000 0.000)))
+ (snd-display ";mix 3 vs: ~A" vals))
+ (if (not (mix? id)) (snd-display ";mix 3vs 1 not active?"))
+ (if (not (mix? id1)) (snd-display ";mix 3vs 2 not active?"))
+ (if (not (mix? id2)) (snd-display ";mix 3vs 3 not active?"))
+ (set! (mix-position id) 10)
+ (set! vals (channel->float-vector 18 10))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.100 0.300 0.500 0.300 0.000 0.000 0.000)))
+ (snd-display ";mix 3 vs then move first: ~A" vals))
+ (set! (mix-position id2) 30)
+ (set! vals (channel->float-vector 18 10))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.000 0.000 0.000)))
+ (snd-display ";mix 3 vs then move 2: ~A" vals))
+ (scale-by 2.0)
+ (if (not (mix? id)) (snd-display ";mix 3vs 1 scl not active?"))
+ (if (not (mix? id1)) (snd-display ";mix 3vs 2 scl not active?"))
+ (if (not (mix? id2)) (snd-display ";mix 3vs 3 scl not active?"))
+ (set! vals (channel->float-vector 18 10))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.200 0.400 0.600 0.000 0.000 0.000)))
+ (snd-display ";mix 3 vs then move 2 scl: ~A" vals))
+ (delete-sample 15)
+ (if (not (mix? id)) (snd-display ";mix 3vs 1 scl del not active?"))
+ (if (not (mix? id1)) (snd-display ";mix 3vs 2 scl del not active?"))
+ (if (not (mix? id2)) (snd-display ";mix 3vs 3 scl del not active?"))
+ (if (not (= (mix-position id) 10)) (snd-display ";mix 3vs etc pos: ~A" (mix-position id)))
+ (if (not (= (mix-position id1) 21)) (snd-display ";mix 3vs etc pos 1: ~A" (mix-position id1)))
+ (if (not (= (mix-position id2) 29)) (snd-display ";mix 3vs etc pos 2: ~A" (mix-position id2)))
+ ))
+ (close-sound ind))
+
+ (let* ((ind (new-sound "test.snd" :size 15))
+ (id (mix-float-vector (make-float-vector 11 1.0) 2)))
+ (set! (mix-amp-env id) '(0 0 1 1))
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0 0 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 0 0)))
+ (snd-display ";ramp mix amp env: ~A" vals)))
+ (set! (mix-amp-env id) #f)
+ (if (pair? (mix-amp-env id)) (snd-display ";set mix-amp-env to null: ~A" (mix-amp-env id)))
+ (set! (mix-speed id) 0.5)
+ (if (not (= (framples) 24)) (snd-display ";mix speed lengthens 24: ~A" (framples)))
+ (set! (mix-speed id) 1.0)
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
+ (snd-display ";return to mix original index: ~A" vals)))
+ (set! (mix-amp-env id) '(0 0 1 1 2 1 3 0))
+ (set! (mix-speed id) 0.5)
+ (set! (mix-amp-env id) #f)
+ (set! (mix-speed id) 1.0)
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
+ (snd-display ";return again to mix original index: ~A" vals)))
+ (close-sound ind))
+
+
+ (let ((id (open-sound "oboe.snd")))
+ (make-selection 1000 2000 id 0)
+ (let ((mix-id (car (mix-selection 3000 id 0))))
+ (set! (mix-amp mix-id) .5)
+ (if (fneq (mix-amp mix-id) .5)
+ (snd-display ";mix-amp .5: ~A" (mix-amp mix-id))))
+ (scale-by .5)
+ (undo)
+ (close-sound id))
+ (set! *print-length* 30)
+
+ (let* ((ind (open-sound "2.snd"))
+ (md (car (mix "1a.snd" 1000 0 ind 1 #t))))
+ (if (fneq (maxamp ind 1) .1665) (snd-display ";maxamp after mix into chan 2: ~A" (maxamp ind 1)))
+ (set! (mix-amp md) 0.0)
+ (if (not (and (equal? (edits ind 0) (list 0 0))
+ (equal? (edits ind 1) (list 2 0))))
+ (snd-display ";mix into chan2 zeroed: ~A ~A" (edits ind 0) (edits ind 1)))
+ (if (fneq (maxamp ind 1) .066) (snd-display ";maxamp after mix zeroed into chan 2: ~A" (maxamp ind 1)))
+ (set! (mix-amp md) 0.5)
+ (if (fneq (maxamp ind 1) .116) (snd-display ";maxamp after mix 0.5 into chan 2: ~A" (maxamp ind 1)))
+ (set! (mix-speed md) 2.0)
+ (if (fneq (/ (mix-length md) (mus-sound-framples "1a.snd")) 0.5)
+ (snd-display ";mix srate chan 2: ~A ~A" (mix-length md) (mus-sound-framples "1a.snd")))
+ (update-time-graph)
+ (set! (mix-speed md) 0.5)
+ (update-time-graph)
+ (set! (mix-amp md) 1.0)
+ (if (fneq (maxamp ind 1) .166)
+ (snd-display ";non-sync mix-speed maxamp: ~A" (maxamp ind 1)))
+ (set! (mix-amp-env md) '(0 0 1 1 2 0))
+ (update-time-graph)
+ (set! (mix-speed md) 1.0)
+ (update-time-graph)
+ (revert-sound ind)
+ (set! (sync ind) 1)
+ (let ((m0 (maxamp ind 0))
+ (m1 (maxamp ind 1))
+ (len (framples ind 0)))
+ (set! md (mix "2.snd" 0 #t)) ; should double both chans, no len change
+ (if (or (not (= (framples ind 0) len))
+ (fneq (maxamp ind 0) (* 2 m0))
+ (fneq (maxamp ind 1) (* 2 m1)))
+ (snd-display ";mix twice syncd: 0: ~A -> ~A, m1: ~A -> ~A, len: ~A -> ~A"
+ m0 (maxamp ind 0) m1 (maxamp ind 1) len (framples ind 0))))
+ (set! (hook-functions mix-release-hook) ())
+ (close-sound ind))
+
+ (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "mix tests")))
+ (insert-silence 0 20 ind)
+ (let ((indout (new-sound "test.snd" 1 22050 mus-ldouble mus-next "mix tests")))
+ (insert-silence 0 10 indout)
+ (set! (sample 2 indout 0) .5)
+ (set! (sample 5 indout 0) .25)
+ (save-sound indout)
+ (close-sound indout))
+ (let ((tag (car (mix "test.snd"))))
+ (let ((samps (channel->float-vector 0 20))
+ (v (make-float-vector 20 0.0)))
+ (set! (v 2) .5)
+ (set! (v 5) .25)
+ (if (not (vequal samps v))
+ (snd-display ";mix 1->1: ~A ~A" samps v)))
+ (if (not (mix? tag)) (snd-display ";mix 1->1 tag: ~A" tag))
+ (undo))
+ (let ((tag (car (mix "test.snd" 5))))
+ (let ((samps (channel->float-vector 0 20))
+ (v (make-float-vector 20 0.0)))
+ (set! (v 7) .5)
+ (set! (v 10) .25)
+ (if (not (vequal samps v))
+ (snd-display ";mix 1->1 at 5: ~A ~A" samps v)))
+ (if (not (mix? tag)) (snd-display ";mix 1->1 at 5 tag: ~A" tag))
+ (undo))
+ (let ((tag (mix "test.snd" 0 0 ind 0 #f)))
+ (let ((samps (channel->float-vector 0 20))
+ (v (make-float-vector 20 0.0)))
+ (set! (v 2) .5)
+ (set! (v 5) .25)
+ (if (not (vequal samps v))
+ (snd-display ";mix 1->1 at 0 #f: ~A ~A" samps v)))
+ (if (mix? tag) (snd-display ";mix 1->1 at 5 #f tag: ~A" tag))
+ (undo))
+ (let ((indout (new-sound "test.snd" 2 22050 mus-ldouble mus-next "mix tests")))
+ (insert-silence 0 10 indout 0)
+ (insert-silence 0 10 indout 1)
+ (set! (sample 2 indout 0) .5)
+ (set! (sample 5 indout 0) .25)
+ (set! (sample 2 indout 1) .95)
+ (set! (sample 5 indout 1) .125)
+ (save-sound indout)
+ (close-sound indout))
+ (let ((tag (car (mix "test.snd" 0 1))))
+ (let ((samps (channel->float-vector 0 20))
+ (v (make-float-vector 20 0.0)))
+ (set! (v 2) .95)
+ (set! (v 5) .125)
+ (if (not (vequal samps v))
+ (snd-display ";mix 2->1: ~A ~A" samps v)))
+ (if (not (mix? tag)) (snd-display ";mix 2->1 tag: ~A" tag))
+ (undo))
+ (let ((tag (car (mix "test.snd" 5 1))))
+ (let ((samps (channel->float-vector 0 20))
+ (v (make-float-vector 20 0.0)))
+ (set! (v 7) .95)
+ (set! (v 10) .125)
+ (if (not (vequal samps v))
+ (snd-display ";mix 2->1 at 5: ~A ~A" samps v)))
+ (if (not (mix? tag)) (snd-display ";mix 2->1 at 5 tag: ~A" tag))
+ (undo))
+ (close-sound ind)
+ (set! ind (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "mix tests"))
+ (insert-silence 0 20 ind 0)
+ (insert-silence 0 20 ind 1)
+ (let ((tag (car (mix "test.snd" 0 #t))))
+ (let ((v (make-float-vector 20 0.0)))
+ (set! (v 2) .95)
+ (set! (v 5) .125)
+ (let ((samps1 (channel->float-vector 0 20 ind 1)))
(if (not (vequal samps1 v))
- (snd-display #__line__ ";mix 1->1 (7): ~A ~A" samps1 v))
- (undo))
- (close-sound ind))
- (delete-file "test.snd")
- (delete-file "fmv.snd")
-
- ;; check ripple_mixes
- (let* ((ind (open-sound "oboe.snd"))
- (data (channel->float-vector 100 100))
- (m1 (mix-float-vector data 321 ind 0 #t))
- (m2 (mix-float-vector data 123 ind 0 #t)))
- (set! (mix-position m1) 500)
- (if (not (= (mix-position m1) 500)) (snd-display #__line__ ";mix-position m1[0]: ~A" (mix-position m1)))
- (if (not (= (mix-position m2) 123)) (snd-display #__line__ ";mix-position m2[0]: ~A" (mix-position m2)))
- (undo)
- (set! (mix-position m2) 500)
- (if (not (= (mix-position m2) 500)) (snd-display #__line__ ";mix-position m2[1]: ~A" (mix-position m2)))
- (if (not (= (mix-position m1) 321)) (snd-display #__line__ ";mix-position m1[1]: ~A" (mix-position m1)))
- (undo)
- (insert-silence 0 100)
- (if (not (= (mix-position m1) (+ 100 321))) (snd-display #__line__ ";mix-position m1[2]: ~A" (mix-position m1)))
- (if (not (= (mix-position m2) (+ 100 123))) (snd-display #__line__ ";mix-position m2[2]: ~A" (mix-position m2)))
- (delete-samples 0 50)
- (if (not (= (mix-position m1) (+ 50 321))) (snd-display #__line__ ";mix-position m1[3]: ~A" (mix-position m1)))
- (if (not (= (mix-position m2) (+ 50 123))) (snd-display #__line__ ";mix-position m2[3]: ~A" (mix-position m2)))
- (undo 2)
- (set! (mix-position m2) 500)
- (undo)
- (scale-channel 0.5 1000 100)
- (if (not (= (mix-position m2) 123)) (snd-display #__line__ ";mix-position m2[5]: ~A" (mix-position m2)))
- (if (not (= (mix-position m1) 321)) (snd-display #__line__ ";mix-position m1[5]: ~A" (mix-position m1)))
- (undo)
- (set! (mix-position m2) 500)
- (undo)
- (set! (mix-position m2) 500)
- (undo-edit)
- (ramp-channel 0.0 1.0 3000 100)
- (catch #t
- (lambda ()
- (if (not (= (mix-position m2) 123)) (snd-display #__line__ ";mix-position m2[7]: ~A" (mix-position m2)))
- (if (not (= (mix-position m1) 321)) (snd-display #__line__ ";mix-position m1[7]: ~A" (mix-position m1))))
- (lambda args (snd-display #__line__ ";mix-position trouble: ~A" args)))
- (undo)
- (delay-channel-mixes 200 100 ind 0)
- (if (not (= (mix-position m2) 123)) (snd-display #__line__ ";delay-channel mixes mix-position m2: ~A" (mix-position m2)))
- (if (not (= (mix-position m1) 421)) (snd-display #__line__ ";delay-channel-mixes mix-position m1: ~A" (mix-position m1)))
- (check-mix-tags ind 0)
- (close-sound ind))
-
- ;; check that current console is correct
- (let ((ind (open-sound "storm.snd")))
- (set! (x-bounds) (list 0 80.0))
- (make-selection 1000000 1050000)
- (let ((m1 (car (mix-selection 900000)))
- (m2 (car (mix-selection 400000))))
- (as-one-edit (lambda ()
- (set! (mix-position m1) 0)
- (set! (mix-position m2) 1)))
- (if (or (not (= (mix-position m1) 0))
- (not (= (mix-position m2) 1)))
- (snd-display #__line__ ";as-one-edit positions: ~A ~A" (mix-position m1) (mix-position m2)))
- (undo-channel)
- (if (or (not (= (mix-position m1) 900000))
- (not (= (mix-position m2) 400000)))
- (snd-display #__line__ ";as-one-edit positions after undo: (~A): ~A (~A): ~A" m1 (mix-position m1) m2 (mix-position m2)))
- (redo-channel)
- (if (or (not (= (mix-position m1) 0))
- (not (= (mix-position m2) 1)))
- (snd-display #__line__ ";as-one-edit positions after redo: ~A ~A" (mix-position m1) (mix-position m2)))
- (close-sound ind)))
+ (snd-display ";mix 1->1 (2): ~A ~A" samps1 v)))
+ (set! (v 2) .5)
+ (set! (v 5) .25)
+ (let ((samps0 (channel->float-vector 0 20 ind 0)))
+ (if (not (vequal samps0 v))
+ (snd-display ";mix 1->1 (3): ~A ~A" samps0 v))))
+ (if (not (mix? tag)) (snd-display ";mix 1->1 tag: ~A" tag)))
+ (undo 1 ind 0)
+ (undo 1 ind 1)
+ (let ((tag (mix "test.snd" 0 1 ind 1 #f))) ; samp:0, in-chan: 1
+ (let ((samps1 (channel->float-vector 0 20 ind 1))
+ (v (make-float-vector 20 0.0)))
+ (let ((samps0 (channel->float-vector 0 20 ind 0)))
+ (if (not (vequal samps0 v))
+ (snd-display ";mix 1->1 (4): ~A ~A" samps0 v)))
+ (set! (v 2) .95)
+ (set! (v 5) .125)
+ (if (not (vequal samps1 v))
+ (snd-display ";mix 1->1 (5): ~A ~A" samps1 v)))
+ (if (mix? tag) (snd-display ";mix 1->1 tag (5): ~A" tag)))
+ (undo 1 ind 1)
+ (set! (sync ind) 1)
+ (mix "test.snd" 0 #t)
+ (let ((samps1 (channel->float-vector 0 20 ind 1))
+ (v (make-float-vector 20 0.0)))
+ (let ((samps0 (channel->float-vector 0 20 ind 0)))
+ (set! (v 2) .5)
+ (set! (v 5) .25)
+ (if (not (vequal samps0 v))
+ (snd-display ";mix 1->1 (6): ~A ~A" samps0 v)))
+ (set! (v 2) .95)
+ (set! (v 5) .125)
+ (if (not (vequal samps1 v))
+ (snd-display ";mix 1->1 (7): ~A ~A" samps1 v)))
+ (undo)
+ (close-sound ind))
+ (delete-file "test.snd")
+ (delete-file "fmv.snd")
+
+ ;; check ripple_mixes
+ (let* ((ind (open-sound "oboe.snd"))
+ (data (channel->float-vector 100 100))
+ (m1 (mix-float-vector data 321 ind 0 #t))
+ (m2 (mix-float-vector data 123 ind 0 #t)))
+ (set! (mix-position m1) 500)
+ (if (not (= (mix-position m1) 500)) (snd-display ";mix-position m1[0]: ~A" (mix-position m1)))
+ (if (not (= (mix-position m2) 123)) (snd-display ";mix-position m2[0]: ~A" (mix-position m2)))
+ (undo)
+ (set! (mix-position m2) 500)
+ (if (not (= (mix-position m2) 500)) (snd-display ";mix-position m2[1]: ~A" (mix-position m2)))
+ (if (not (= (mix-position m1) 321)) (snd-display ";mix-position m1[1]: ~A" (mix-position m1)))
+ (undo)
+ (insert-silence 0 100)
+ (if (not (= (mix-position m1) 421)) (snd-display ";mix-position m1[2]: ~A" (mix-position m1)))
+ (if (not (= (mix-position m2) 223)) (snd-display ";mix-position m2[2]: ~A" (mix-position m2)))
+ (delete-samples 0 50)
+ (if (not (= (mix-position m1) 371)) (snd-display ";mix-position m1[3]: ~A" (mix-position m1)))
+ (if (not (= (mix-position m2) 173)) (snd-display ";mix-position m2[3]: ~A" (mix-position m2)))
+ (undo 2)
+ (set! (mix-position m2) 500)
+ (undo)
+ (scale-channel 0.5 1000 100)
+ (if (not (= (mix-position m2) 123)) (snd-display ";mix-position m2[5]: ~A" (mix-position m2)))
+ (if (not (= (mix-position m1) 321)) (snd-display ";mix-position m1[5]: ~A" (mix-position m1)))
+ (undo)
+ (set! (mix-position m2) 500)
+ (undo)
+ (set! (mix-position m2) 500)
+ (undo-edit)
+ (ramp-channel 0.0 1.0 3000 100)
+ (catch #t
+ (lambda ()
+ (if (not (= (mix-position m2) 123)) (snd-display ";mix-position m2[7]: ~A" (mix-position m2)))
+ (if (not (= (mix-position m1) 321)) (snd-display ";mix-position m1[7]: ~A" (mix-position m1))))
+ (lambda args (snd-display ";mix-position trouble: ~A" args)))
+ (undo)
+ (delay-channel-mixes 200 100 ind 0)
+ (if (not (= (mix-position m2) 123)) (snd-display ";delay-channel mixes mix-position m2: ~A" (mix-position m2)))
+ (if (not (= (mix-position m1) 421)) (snd-display ";delay-channel-mixes mix-position m1: ~A" (mix-position m1)))
+ (check-mix-tags ind 0)
+ (close-sound ind))
+
+ ;; check that current console is correct
+ (let ((ind (open-sound "storm.snd")))
+ (set! (x-bounds) (list 0 80.0))
+ (make-selection 1000000 1050000)
+ (let ((m1 (car (mix-selection 900000)))
+ (m2 (car (mix-selection 400000))))
+ (as-one-edit (lambda ()
+ (set! (mix-position m1) 0)
+ (set! (mix-position m2) 1)))
+ (if (not (and (= (mix-position m1) 0)
+ (= (mix-position m2) 1)))
+ (snd-display ";as-one-edit positions: ~A ~A" (mix-position m1) (mix-position m2)))
+ (undo-channel)
+ (if (not (and (= (mix-position m1) 900000)
+ (= (mix-position m2) 400000)))
+ (snd-display ";as-one-edit positions after undo: (~A): ~A (~A): ~A" m1 (mix-position m1) m2 (mix-position m2)))
+ (redo-channel)
+ (if (not (and (= (mix-position m1) 0)
+ (= (mix-position m2) 1)))
+ (snd-display ";as-one-edit positions after redo: ~A ~A" (mix-position m1) (mix-position m2)))
+ (close-sound ind)))
+
+ (let ((ind (open-sound "2.snd")))
+ (make-selection 0 10000 ind)
+ (if (not (= (selection-chans) 2))
+ (snd-display ";stereo selection: ~A" (selection-chans)))
+ (set! (sync ind) #t)
+ (let ((md (car (mix-selection 500 ind))))
+ (if (not (mix? (integer->mix (+ 1 (mix->integer md)))))
+ (snd-display ";where is second mix? ~A ~A" md (mixes)))
+ (if (not (= (edit-position ind 0) 1))
+ (snd-display ";edit-position 0 after stereo mix selection: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 1))
+ (snd-display ";edit-position 1 after stereo mix selection: ~A" (edit-position ind 1)))
+ (set! (sync ind) #f)
+ (undo-edit 1 ind 0)
+ (delete-sample 25 ind 0)
+ (set! (mix-position (integer->mix (+ 1 (mix->integer md)))) 750)
+ (if (not (= (edit-position ind 1) 2))
+ (snd-display ";edit-position 1 after stereo mix selection moved: ~A" (edit-position ind 2)))
+ (revert-sound ind)
+ (close-sound ind)))
+
+ (let ((ind (new-sound "test.snd"))
+ (v (make-float-vector 20)))
+ (do ((i 0 (+ i 1))) ((= i 20)) (set! (v i) (* i .01)))
+ (float-vector->channel v)
+ (do ((i 0 (+ i 1))) ((= i 20)) (set! (v i) (* i -.01)))
+ (let ((mx (mix-float-vector v 10)))
+ (let ((hi (make-mix-sampler mx))
+ (ho (make-mix-sampler mx 5))
+ (happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i 10)))
+ (let ((ho-val (ho))
+ (hi-val (hi)))
+ (if (fneq hi-val (* i -.01))
+ (begin
+ (snd-display ";mix-reader at ~A from 0: ~A" i hi-val)
+ (set! happy #f)))
+ (if (fneq ho-val (* (+ i 5) -.01))
+ (begin
+ (snd-display ";mix-reader at ~A from 5: ~A" i ho-val)
+ (set! happy #f)))))))
+ (revert-sound ind)
+ (set! v (make-float-vector 21))
+ (fill! v 0.5)
+ (float-vector->channel v)
+ (let ((mx (mix-float-vector v 10)))
+ (set! (mix-amp-env mx) '(0 0 1 1))
+ (let ((hi (make-mix-sampler mx 0))
+ (ho (make-mix-sampler mx 10))
+ (happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i 10)))
+ (let ((ho-val (ho))
+ (hi-val (hi)))
+ (if (fneq hi-val (* i .025))
+ (begin
+ (snd-display ";mix-reader env'd at ~A from 0: ~A" i hi-val)
+ (set! happy #f)))
+ (if (fneq ho-val (* (+ i 10) .025))
+ (begin
+ (snd-display ";mix-reader env'd at ~A from 10: ~A" i ho-val)
+ (set! happy #f)))))))
+ (close-sound ind))
+
+ (let ((ind (open-sound "oboe.snd"))
+ (id (mix-float-vector (make-float-vector 10 .1))))
+ (set! (mix-position id) 100)
+ (if (not (and (= (mix-position id) 100)
+ (= (edit-position ind 0) 2)))
+ (snd-display ";mix-position init: ~A ~A" (mix-position id) (edit-position ind 0)))
+ (set! (mix-position id) 100)
+ (if (not (and (= (mix-position id) (mix-position id))
+ (= (edit-position ind 0) 2)))
+ (snd-display ";mix-position 2 (no-op): ~A ~A" (mix-position id) (edit-position ind 0)))
+ (set! (mix-amp id) 1.0)
+ (if (or (fneq (mix-amp id) 1.0)
+ (not (= (edit-position ind 0) 2)))
+ (snd-display ";mix-amp no-op: ~A ~A" (mix-amp id) (edit-position ind 0)))
+ (set! (mix-amp id) 0.5)
+ (if (or (fneq (mix-amp id) 0.5)
+ (not (= (edit-position ind 0) 3)))
+ (snd-display ";mix-amp .5: ~A ~A" (mix-amp id) (edit-position ind 0)))
+ (set! (mix-speed id) 1.0)
+ (if (or (fneq (mix-speed id) 1.0)
+ (not (= (edit-position ind 0) 3)))
+ (snd-display ";mix-speed no-op: ~A ~A" (mix-speed id) (edit-position ind 0)))
+ (set! (mix-speed id) .5)
+ (if (or (fneq (mix-speed id) 0.5)
+ (not (= (edit-position ind 0) 4)))
+ (snd-display ";mix-speed .5: ~A ~A" (mix-speed id) (edit-position ind 0)))
+ (set! (mix-amp-env id) '(0 0 1 1))
+ (if (not (= (edit-position ind 0) 5))
+ (snd-display ";mix-amp-env init: ~A ~A" (mix-amp-env id) (edit-position ind 0)))
+ (set! (mix-amp-env id) '(0 0 1 1))
+ (if (not (= (edit-position ind 0) 5))
+ (snd-display ";mix-amp-env no-op: ~A ~A" (mix-amp-env id) (edit-position ind 0)))
+ (close-sound ind))
+
+ (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "color-mix tests" 300))
+ (old-color *mix-color*))
+ (set! *mix-color* (make-color-with-catch 1 1 0))
+ (let ((mix1 (mix-float-vector (make-float-vector 10 .5) 10)))
+ (if (not (and (or (equal? (color->list *mix-color*) (list 1.0 1.0 0.0))
+ (equal? (color->list *mix-color*) (list 1.0 1.0 0.0 1.0)))
+ (or (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0))
+ (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0 1.0)))))
+ (snd-display ";set mix-color: ~A ~A ~A ~A"
+ (color->list *mix-color*) (color->list (mix-color mix1)) (list 1.0 1.0 0.0) (color->list old-color)))
+ (set! *mix-color* old-color)
+ (save-mix mix1 "test1.snd")
+ (let ((ind1 (open-sound "test1.snd")))
+ (if (not (= (framples ind1) (mix-length mix1))) (snd-display ";save-mix framples: ~A ~A" (mix-length mix1) (framples ind1)))
+ (if (not (vequal (channel->float-vector 0 10) (mix->float-vector mix1)))
+ (snd-display ";save-mix data: ~A ~A" (mix->float-vector mix1) (channel->float-vector 0 10 ind1)))
+
+ (define mix7 (integer->mix 71231))
+ (if (mix? mix7) (snd-display ";mix? ~A~%" mix7))
+ (catch #t
+ (lambda ()
+ (save-mix mix7 "test.snd")
+ (snd-display ";save-mix of a bad mix??"))
+ (lambda args #f))
+ (close-sound ind1)
+ (if (file-exists? "test1.snd") (delete-file "test1.snd"))))
+ (close-sound ind))
+
+ (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "lock mix tests" 300)))
+ (let ((mix1 (mix-float-vector (make-float-vector 10 .5) 10)))
+ (set! (mix-amp mix1) 0.0))
+ (if (fneq (maxamp ind 0) 0.0) (snd-display ";delete-mix maxamp: ~A" (maxamp ind 0)))
+ (undo-channel 1 ind 0)
+ (if (fneq (maxamp ind 0) 0.5) (snd-display ";undelete-mix maxamp: ~A" (maxamp ind 0)))
+ (redo-channel 1 ind 0)
+ (if (fneq (maxamp ind 0) 0.0) (snd-display ";redelete-mix maxamp: ~A" (maxamp ind 0)))
+ (undo 2)
+ (if (fneq (maxamp ind 0) 0.0) (snd-display ";no delete-mix maxamp: ~A" (maxamp ind 0)))
+ (redo)
+ (if (fneq (maxamp ind 0) 0.5) (snd-display ";reundelete-mix maxamp: ~A" (maxamp ind 0)))
+ (close-sound ind))
+
+ (let* ((ind (new-sound "test.snd" :size 100))
+ (id (mix-float-vector (make-float-vector 5 .5) 11)))
+
+ ;; pad-channel
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11: ~A" (channel->float-vector 10 10)))
+ (pad-channel 0 10)
+ (if (not (mix? id))
+ (snd-display ";pad locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 21))
+ (snd-display ";float-vector .5 at 21 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 21: ~A" (channel->float-vector 20 10)))
+ (if (not (vequal (channel->float-vector 10 10) (make-float-vector 10 0.0)))
+ (snd-display ";float-vector .5 at 21 at 10: ~A" (channel->float-vector 10 10)))
+ (pad-channel 30 10)
+ (if (not (mix? id))
+ (snd-display ";pad 30 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 21))
+ (snd-display ";float-vector .5 at 21 position 30: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 21 30: ~A" (channel->float-vector 20 10)))
+ (pad-channel 150 10)
+ (if (not (mix? id))
+ (snd-display ";pad 150 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 21))
+ (snd-display ";float-vector .5 at 21 position 150: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 21 150: ~A" (channel->float-vector 20 10)))
+ (pad-channel 20 10)
+ (if (not (mix? id))
+ (snd-display ";pad 20 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 31))
+ (snd-display ";float-vector .5 at 31 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 31: ~A" (channel->float-vector 30 10)))
+ (pad-channel 32 3)
+ ; (if (mix? id) (snd-display ";pad within mix but exists?: ~A" (mix? id)))
+ (if (not (mix? id)) (snd-display ";pad within mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 0 0 0 .5 .5 .5 .5 0)))
+ (snd-display ";float-vector .5 at 31 pad at 32: ~A" (channel->float-vector 30 10)))
+
+ (set! (edit-position) 1)
+ (if (not (mix? id)) (snd-display ";mix float-vector after reset edit position: ~A" (mix? id)))
+ (if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after reset edit position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 after reset edit: ~A" (channel->float-vector 10 10)))
+
+ ;; delete
+ (delete-samples 0 10)
+ (if (not (mix? id))
+ (snd-display ";delete locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 1))
+ (snd-display ";float-vector .5 at 1 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 1: ~A" (channel->float-vector 0 10)))
+ (delete-samples 30 10)
+ (if (not (mix? id))
+ (snd-display ";delete 30 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 1))
+ (snd-display ";float-vector .5 at 1 position del 30: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 1 del 30: ~A" (channel->float-vector 0 10)))
+ (delete-samples 3 3)
+ ; (if (mix? id) (snd-display ";delete within mix but exists?: ~A" (mix? id)))
+ (if (not (mix? id)) (snd-display ";delete within mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 0 0 0 0 0 0 0)))
+ (snd-display ";float-vector .5 at 1 del at 3: ~A" (channel->float-vector 0 10)))
+
+ (set! (edit-position) 1)
+ (if (not (mix? id)) (snd-display ";mix float-vector after del reset edit position: ~A" (mix? id)))
+ (if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after del reset edit position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 after del reset edit: ~A" (channel->float-vector 10 10)))
+
+ ;; change
+ (set! (samples 0 5) (make-float-vector 5 .6))
+ (if (not (mix? id))
+ (snd-display ";set locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 set position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 set: ~A" (channel->float-vector 10 10)))
+ (set! (samples 20 5) (make-float-vector 5 .7))
+ (if (not (mix? id))
+ (snd-display ";set 20 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 set 20 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 set 20: ~A" (channel->float-vector 10 10)))
+ (set! (samples 12 2) (float-vector -.5 .8))
+ ; (if (mix? id) (snd-display ";set within mix but exists?: ~A" (mix? id)))
+ (if (not (mix? id)) (snd-display ";set within mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 -.5 .8 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 set at 12: ~A" (channel->float-vector 10 10)))
+
+ (set! (edit-position) 1)
+ (if (not (mix? id)) (snd-display ";mix float-vector after set reset edit position: ~A" (mix? id)))
+ (if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after set reset edit position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 after set reset edit: ~A" (channel->float-vector 10 10)))
+
+ ;; scale
+ (scale-channel 2.0)
+ (if (not (mix? id))
+ (snd-display ";scale locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 scale position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 1 1 1 1 1 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 scale: ~A" (channel->float-vector 10 10)))
+ (scale-channel 0.5)
+ (if (not (mix? id))
+ (snd-display ";unscale locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 unscale position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 unscale: ~A" (channel->float-vector 10 10)))
+ (scale-channel -1.0 0 5)
+ (if (not (mix? id))
+ (snd-display ";scale at 0 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 scale at 0 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 scale at 0: ~A" (channel->float-vector 10 10)))
+ (scale-channel -1.0 22 10)
+ (if (not (mix? id))
+ (snd-display ";scale at 22 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 scale at 22 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 scale at 22: ~A" (channel->float-vector 10 10)))
+ (scale-channel 2.0 12 2)
+ ; (if (mix? id) (snd-display ";scale within mix but exists?: ~A" (mix? id)))
+ (if (not (mix? id)) (snd-display ";scale within mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 1 1 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 scale at 12: ~A" (channel->float-vector 10 10)))
+
+ (set! (edit-position) 1)
+ (if (not (mix? id)) (snd-display ";mix float-vector after scale reset edit position: ~A" (mix? id)))
+ (if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after scale reset edit position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 after scale reset edit: ~A" (channel->float-vector 10 10)))
+
+ ;; envelopes
+ (env-channel '(0 0 1 1) 0 8)
+ (if (not (mix? id))
+ (snd-display ";env locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 env position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 env: ~A" (channel->float-vector 10 10)))
+ (env-channel '(0 0 1 1) 17 10)
+ (if (not (mix? id))
+ (snd-display ";env 17 locked mix? ~A" (mix? id)))
+ (if (not (= (mix-position id) 11))
+ (snd-display ";float-vector .5 at 11 env 17 position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 env 17: ~A" (channel->float-vector 10 10)))
+ (env-channel '(0 0 1 1))
+ ; (if (mix? id) (snd-display ";env over mix but exists?: ~A" (mix? id)))
+ (if (not (mix? id)) (snd-display ";env over mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0.000 0.056 0.061 0.066 0.071 0.076 0.000 0.000 0.000 0.000)))
+ (snd-display ";float-vector .5 at 11 over env: ~A" (channel->float-vector 10 10)))
+
+ (set! (edit-position) 1)
+ ; (if (not (mix? id)) (snd-display ";mix float-vector after env reset edit position: ~A" (mix? id)))
+ (if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after env reset edit position: ~A" (mix-position id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (snd-display ";float-vector .5 at 11 after env reset edit: ~A" (channel->float-vector 10 10)))
+
+ (scale-by 0.0)
+ (if (not (mix? id)) (snd-display ";zero mix but no mix?: ~A" (mix? id)))
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0 0 0 0 0 0 0 0 0 0)))
+ (snd-display ";float-vector 1 at 11 scale 0: ~A" (channel->float-vector 10 10)))
+ (undo 2)
+
+ (let ((ids ()))
+ (do ((i 0 (+ i 1)))
+ ((= i 5))
+ (set! ids (cons (mix-float-vector (make-float-vector 5 .1) (+ i 10)) ids)))
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";pile up mixes: ~A" vals)))
+ (let ((mx (mixes-maxamp ids)))
+ (if (fneq mx .1)
+ (snd-display ";mixes-maxamp: ~A" mx)))
+ (let ((len (mixes-length ids)))
+ (if (not (= len 10))
+ (snd-display ";mixes-length: ~A" len)))
+ (sync-all-mixes 21)
+ (for-each (lambda (m) (if (not (= (mix-sync m) 21)) (snd-display ";sync-all-mixes ~A: ~A" m (mix-sync m)))) ids)
+ (sync-all-mixes 0)
+ (for-each (lambda (m) (if (not (= (mix-sync m) 0)) (snd-display ";re sync-all-mixes ~A: ~A" m (mix-sync m)))) ids)
+ (scale-mixes ids -2.0)
+ (for-each (lambda (m) (if (fneq (mix-amp m) -2.0) (snd-display ";scale-mixes ~A: ~A" m (mix-amp m)))) ids)
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 -0.200 -0.400 -0.600 -0.800 -1.000 -0.800 -0.600 -0.400 -0.200 0.000 0.000 0.000)))
+ (snd-display ";scale piled up mixes: ~A" vals)))
+ (silence-mixes ids)
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (make-float-vector 14 0.0)))
+ (snd-display ";silence piled up mixes: ~A" vals)))
+ (undo 2)
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";undo 2 to pile up mixes: ~A" vals)))
+ (play-mixes ids)
+ (set-mixes-tag-y ids 100)
+ (for-each (lambda (m) (if (not (= (mix-tag-y m) 100)) (snd-display ";set-mixes-tag-y ~A: ~A" m (mix-tag-y m)))) ids)
+ (set-mixes-tag-y ids 0)
+ (move-mixes ids 10)
+ (let ((vals (channel->float-vector 18 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";move piled up mixes: ~A" vals)))
+ (let ((vals (channel->float-vector 8 8)))
+ (if (not (vequal vals (make-float-vector 8 0.0)))
+ (snd-display ";move piled up mixes original: ~A" vals)))
+ (move-mixes ids -10)
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";move piled up mixes -10: ~A" vals)))
+ (let ((vals (channel->float-vector 23 8)))
+ (if (not (vequal vals (make-float-vector 8 0.0)))
+ (snd-display ";move piled up mixes -10: ~A" vals)))
+ (for-each (lambda (m) (set! (mix-sync m) 24)) ids)
+ (let ((mxs (syncd-mixes 24)))
+ (if (not (= (length mxs) (length ids)))
+ (snd-display ";syncd-mixes: ~A ~A" mxs ids))
+ (for-each (lambda (m) (if (not (member m ids)) (snd-display ";syncd-mixes: ~A not in ~A" m ids))) mxs))
+ (sync-all-mixes 0)
+ (env-mixes ids '(0 0 1 1 2 0))
+ (let ((vals (channel->float-vector 10 10)))
+ (if (not (vequal vals (float-vector 0.000 0.045 0.137 0.278 0.460 0.360 0.203 0.087 0.020 0.000)))
+ (snd-display ";env-mixes: ~A" vals)))
+ (undo 3)
+ (let ((vals (channel->float-vector 8 14)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";undo 3 mixes envd: ~A" vals)))
+ (color-mixes ids (make-color 0 1 0))
+ (scale-tempo ids 2.0)
+ (let ((begs (map mix-position ids)))
+ (if (not (equal? begs (list 18 16 14 12 10)))
+ (snd-display ";scale-tempo by 2: ~A" begs)))
+ (let ((vals (channel->float-vector 10 15)))
+ (if (not (vequal vals (float-vector 0.100 0.100 0.200 0.200 0.300 0.200 0.300 0.200 0.300 0.200 0.200 0.100 0.100 0.000 0.000)))
+ (snd-display ";scale-tempo 2 vals: ~A" vals)))
+ (scale-tempo ids 0.5)
+ (let ((begs (map mix-position ids)))
+ (if (not (equal? begs (list 14 13 12 11 10)))
+ (snd-display ";scale-tempo by 0.5: ~A" begs)))
+ (let ((vals (channel->float-vector 10 10)))
+ (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000)))
+ (snd-display ";scale-tempo back 0.5: ~A" vals)))
+ (scale-tempo ids -1.0)
+ (let ((begs (map mix-position ids)))
+ (if (not (equal? begs (list 6 7 8 9 10)))
+ (snd-display ";scale-tempo by -1: ~A" begs)))
+ (let ((vals (channel->float-vector 0 15)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100)))
+ (snd-display ";scale-tempo -1 vals: ~A" vals)))
+ (undo 3)
+ (set! *sinc-width* 10)
+ (src-mixes ids 0.5)
+ (if (fneq (mix-speed (car ids)) 0.5)
+ (snd-display ";src-mixes speed: ~A" (mix-speed (car ids))))
+ (if (not (= (mixes-length ids) 15))
+ (snd-display ";src-mixes length: ~A" (mixes-length ids)))
+ (let ((vals (channel->float-vector 10 15)))
+ (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
+ (snd-display ";src-mixes 0.5 vals: ~A" vals)))
+ (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (snd-display ";src-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (undo)
+ (transpose-mixes ids -12)
+ (if (fneq (mix-speed (car ids)) 0.5)
+ (snd-display ";transpose-mixes speed: ~A" (mix-speed (car ids))))
+ (if (not (= (mixes-length ids) 15))
+ (snd-display ";transpose-mixes length: ~A" (mixes-length ids)))
+ (let ((vals (channel->float-vector 10 15)))
+ (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
+ (snd-display ";transpose-mixes 0.5 vals: ~A" vals)))
+ (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (snd-display ";transpose-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (revert-sound))
+ (close-sound ind))
+
+ ;; check locks
+ (let* ((ind (new-sound "test.snd" :size 100))
+ (id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (if (not (mix? id))
+ (snd-display ";mix lock 0: ~A ~A" id (mix? id)))
+ (ramp-channel 0.0 1.0 0 20)
+ (if (not (mix? id))
+ (snd-display ";mix lock 5: ~A ~A" id (mix? id)))
+ (undo)
+ (xramp-channel 0.0 1.0 32.0 0 20)
+ (if (not (mix? id))
+ (snd-display ";mix lock 6: ~A ~A" id (mix? id)))
+ (undo 2)
+ (delete-sample 52)
+ (if (not (mix? id))
+ (snd-display ";mix lock 7: ~A ~A" id (mix? id)))
+ (undo)
+ (delete-sample 10)
+ (if (not (mix? id))
+ (snd-display ";mix lock 8: ~A ~A" id (mix? id)))
+ (undo)
+ (insert-samples 51 2 (float-vector .1 .2))
+ (if (not (mix? id))
+ (snd-display ";mix lock 9: ~A ~A" id (mix? id)))
+ (undo)
+ (insert-samples 1 2 (float-vector .1 .2))
+ (if (not (mix? id))
+ (snd-display ";mix lock 10: ~A ~A" id (mix? id)))
+ (undo)
+ (set! (sample 51) 1.0)
+ (if (not (mix? id))
+ (snd-display ";mix lock 11: ~A ~A" id (mix? id)))
+ (undo)
+ (set! (sample 1) 1.0)
+ (if (not (mix? id))
+ (snd-display ";mix lock 12: ~A ~A" id (mix? id)))
+ (undo)
+ (xramp-channel 0 1 32 0 40)
+ (if (not (mix? id))
+ (snd-display ";mix lock 13: ~A ~A" id (mix? id)))
+ (xramp-channel 0 1 32 0 40)
+ (if (not (mix? id))
+ (snd-display ";mix lock 14: ~A ~A" id (mix? id)))
+ (close-sound ind))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 2))
+
+ (let ((ind (new-sound "test.snd" :size 100))
+ (tag *with-mix-tags*))
- (let ((ind (open-sound "2.snd")))
- (make-selection 0 10000 ind)
- (if (not (= (selection-chans) 2))
- (snd-display #__line__ ";stereo selection: ~A" (selection-chans)))
- (set! (sync ind) #t)
- (let ((md (car (mix-selection 500 ind))))
- (if (not (mix? (integer->mix (+ 1 (mix->integer md)))))
- (snd-display #__line__ ";where is second mix? ~A ~A" md (mixes)))
- (if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";edit-position 0 after stereo mix selection: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 1))
- (snd-display #__line__ ";edit-position 1 after stereo mix selection: ~A" (edit-position ind 1)))
- (set! (sync ind) #f)
- (undo-edit 1 ind 0)
- (delete-sample 25 ind 0)
- (set! (mix-position (integer->mix (+ 1 (mix->integer md)))) 750)
- (if (not (= (edit-position ind 1) 2))
- (snd-display #__line__ ";edit-position 1 after stereo mix selection moved: ~A" (edit-position ind 2)))
- (revert-sound ind)
- (close-sound ind)))
+ ;; check various mix ops briefly
+ (map-channel (lambda (y) 1.0))
+ (env-channel '(0 0 1 1))
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576)))
+ (snd-display ";mix on env: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on env: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 5)))
+ (snd-display ";mix on env edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576))))
+ (snd-display ";read mix on env reversed: ~A" data)))
+ (undo)
- (let ((ind (new-sound "test.snd"))
- (v (make-float-vector 20)))
- (do ((i 0 (+ i 1))) ((= i 20)) (set! (v i) (* i .01)))
- (float-vector->channel v)
- (do ((i 0 (+ i 1))) ((= i 20)) (set! (v i) (* i -.01)))
- (let ((mx (mix-float-vector v 10)))
- (let ((hi (make-mix-sampler mx))
- (ho (make-mix-sampler mx 5))
- (happy #t))
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i 10)))
- (let ((ho-val (ho))
- (hi-val (hi)))
- (if (fneq hi-val (* i -.01))
- (begin
- (snd-display #__line__ ";mix-reader at ~A from 0: ~A" i hi-val)
- (set! happy #f)))
- (if (fneq ho-val (* (+ i 5) -.01))
- (begin
- (snd-display #__line__ ";mix-reader at ~A from 5: ~A" i ho-val)
- (set! happy #f)))))))
- (revert-sound ind)
- (set! v (make-float-vector 21))
- (fill! v 0.5)
- (float-vector->channel v)
- (let ((mx (mix-float-vector v 10)))
- (set! (mix-amp-env mx) '(0 0 1 1))
- (let ((hi (make-mix-sampler mx 0))
- (ho (make-mix-sampler mx 10))
- (happy #t))
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i 10)))
- (let ((ho-val (ho))
- (hi-val (hi)))
- (if (fneq hi-val (* i .025))
- (begin
- (snd-display #__line__ ";mix-reader env'd at ~A from 0: ~A" i hi-val)
- (set! happy #f)))
- (if (fneq ho-val (* (+ i 10) .025))
- (begin
- (snd-display #__line__ ";mix-reader env'd at ~A from 10: ~A" i ho-val)
- (set! happy #f)))))))
- (close-sound ind))
+ (env-channel '(0 0 1 1))
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331)))
+ (snd-display ";mix on env 1: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on env 1: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 7)))
+ (snd-display ";mix on env1 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331))))
+ (snd-display ";read mix on env1 reversed: ~A" data)))
+ (undo)
- (let ((ind (open-sound "oboe.snd"))
- (id (mix-float-vector (make-float-vector 10 .1))))
- (set! (mix-position id) 100)
- (if (or (not (= (mix-position id) 100))
- (not (= (edit-position ind 0) 2)))
- (snd-display #__line__ ";mix-position init: ~A ~A" (mix-position id) (edit-position ind 0)))
- (set! (mix-position id) 100)
- (if (or (not (= (mix-position id) (mix-position id)))
- (not (= (edit-position ind 0) 2)))
- (snd-display #__line__ ";mix-position 2 (no-op): ~A ~A" (mix-position id) (edit-position ind 0)))
- (set! (mix-amp id) 1.0)
- (if (or (fneq (mix-amp id) 1.0)
- (not (= (edit-position ind 0) 2)))
- (snd-display #__line__ ";mix-amp no-op: ~A ~A" (mix-amp id) (edit-position ind 0)))
- (set! (mix-amp id) 0.5)
- (if (or (fneq (mix-amp id) 0.5)
- (not (= (edit-position ind 0) 3)))
- (snd-display #__line__ ";mix-amp .5: ~A ~A" (mix-amp id) (edit-position ind 0)))
- (set! (mix-speed id) 1.0)
- (if (or (fneq (mix-speed id) 1.0)
- (not (= (edit-position ind 0) 3)))
- (snd-display #__line__ ";mix-speed no-op: ~A ~A" (mix-speed id) (edit-position ind 0)))
- (set! (mix-speed id) .5)
- (if (or (fneq (mix-speed id) 0.5)
- (not (= (edit-position ind 0) 4)))
- (snd-display #__line__ ";mix-speed .5: ~A ~A" (mix-speed id) (edit-position ind 0)))
- (set! (mix-amp-env id) '(0 0 1 1))
- (if (not (= (edit-position ind 0) 5))
- (snd-display #__line__ ";mix-amp-env init: ~A ~A" (mix-amp-env id) (edit-position ind 0)))
- (set! (mix-amp-env id) '(0 0 1 1))
- (if (not (= (edit-position ind 0) 5))
- (snd-display #__line__ ";mix-amp-env no-op: ~A ~A" (mix-amp-env id) (edit-position ind 0)))
- (close-sound ind))
+ (env-channel '(0 0 1 1))
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191)))
+ (snd-display ";mix on env 2: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on env 2: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
+ (snd-display ";mix on env2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191))))
+ (snd-display ";read mix on env2 reversed: ~A" data)))
+ (undo)
- (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "color-mix tests" 300))
- (old-color *mix-color*))
- (set! *mix-color* (make-color-with-catch 1 1 0))
- (let ((mix1 (mix-float-vector (make-float-vector 10 .5) 10)))
- (if (or (and (not (equal? (color->list *mix-color*) (list 1.0 1.0 0.0)))
- (not (equal? (color->list *mix-color*) (list 1.0 1.0 0.0 1.0))))
- (and (not (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0)))
- (not (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0 1.0)))))
- (snd-display #__line__ ";set mix-color: ~A ~A ~A ~A"
- (color->list *mix-color*) (color->list (mix-color mix1)) (list 1.0 1.0 0.0) (color->list old-color)))
- (set! *mix-color* old-color)
- (save-mix mix1 "test1.snd")
- (let ((ind1 (open-sound "test1.snd")))
- (if (not (= (framples ind1) (mix-length mix1))) (snd-display #__line__ ";save-mix framples: ~A ~A" (mix-length mix1) (framples ind1)))
- (if (not (vequal (channel->float-vector 0 10) (mix->float-vector mix1)))
- (snd-display #__line__ ";save-mix data: ~A ~A" (mix->float-vector mix1) (channel->float-vector 0 10 ind1)))
-
- (define mix7 (integer->mix 71231))
- (if (mix? mix7) (snd-display #__line__ ";mix? ~A~%" mix7))
- (catch #t
- (lambda ()
- (save-mix mix7 "test.snd")
- (snd-display #__line__ ";save-mix of a bad mix??"))
- (lambda args #f))
- (close-sound ind1)
- (if (file-exists? "test1.snd") (delete-file "test1.snd"))))
- (close-sound ind))
+ (env-channel '(0 0 1 1))
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110)))
+ (snd-display ";mix on env 3: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on env 3: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
+ (snd-display ";mix on env3 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110))))
+ (snd-display ";read mix on env3 reversed: ~A" data)))
+ (undo)
- (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "lock mix tests" 300))
- (mix1 (mix-float-vector (make-float-vector 10 .5) 10)))
- (set! (mix-amp mix1) 0.0)
- (if (fneq (maxamp ind 0) 0.0) (snd-display #__line__ ";delete-mix maxamp: ~A" (maxamp ind 0)))
- (undo-channel 1 ind 0)
- (if (fneq (maxamp ind 0) 0.5) (snd-display #__line__ ";undelete-mix maxamp: ~A" (maxamp ind 0)))
- (redo-channel 1 ind 0)
- (if (fneq (maxamp ind 0) 0.0) (snd-display #__line__ ";redelete-mix maxamp: ~A" (maxamp ind 0)))
- (undo 2)
- ; (if (mix? mix1) (snd-display #__line__ ";undo 2 kept mix?"))
- (if (fneq (maxamp ind 0) 0.0) (snd-display #__line__ ";no delete-mix maxamp: ~A" (maxamp ind 0)))
- (redo)
- (if (fneq (maxamp ind 0) 0.5) (snd-display #__line__ ";reundelete-mix maxamp: ~A" (maxamp ind 0)))
- (close-sound ind))
+ (env-channel '(0 0 1 1))
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063)))
+ (snd-display ";mix on env 4: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on env 4: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
+ (snd-display ";mix on env4 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063))))
+ (snd-display ";read mix on env4 reversed: ~A" data)))
+ (undo)
- (let ((ind (new-sound "test.snd" :size 100)))
- (let ((id (mix-float-vector (make-float-vector 5 .5) 11)))
-
- ;; pad-channel
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11: ~A" (channel->float-vector 10 10)))
- (pad-channel 0 10)
- (if (not (mix? id))
- (snd-display #__line__ ";pad locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 21))
- (snd-display #__line__ ";float-vector .5 at 21 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 21: ~A" (channel->float-vector 20 10)))
- (if (not (vequal (channel->float-vector 10 10) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";float-vector .5 at 21 at 10: ~A" (channel->float-vector 10 10)))
- (pad-channel 30 10)
- (if (not (mix? id))
- (snd-display #__line__ ";pad 30 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 21))
- (snd-display #__line__ ";float-vector .5 at 21 position 30: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 21 30: ~A" (channel->float-vector 20 10)))
- (pad-channel 150 10)
- (if (not (mix? id))
- (snd-display #__line__ ";pad 150 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 21))
- (snd-display #__line__ ";float-vector .5 at 21 position 150: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 21 150: ~A" (channel->float-vector 20 10)))
- (pad-channel 20 10)
- (if (not (mix? id))
- (snd-display #__line__ ";pad 20 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 31))
- (snd-display #__line__ ";float-vector .5 at 31 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 31: ~A" (channel->float-vector 30 10)))
- (pad-channel 32 3)
- ; (if (mix? id) (snd-display #__line__ ";pad within mix but exists?: ~A" (mix? id)))
- (if (not (mix? id)) (snd-display #__line__ ";pad within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 0 0 0 .5 .5 .5 .5 0)))
- (snd-display #__line__ ";float-vector .5 at 31 pad at 32: ~A" (channel->float-vector 30 10)))
-
- (set! (edit-position) 1)
- (if (not (mix? id)) (snd-display #__line__ ";mix float-vector after reset edit position: ~A" (mix? id)))
- (if (not (= (mix-position id) 11)) (snd-display #__line__ ";mix float-vector position after reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 after reset edit: ~A" (channel->float-vector 10 10)))
-
- ;; delete
- (delete-samples 0 10)
- (if (not (mix? id))
- (snd-display #__line__ ";delete locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 1))
- (snd-display #__line__ ";float-vector .5 at 1 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 1: ~A" (channel->float-vector 0 10)))
- (delete-samples 30 10)
- (if (not (mix? id))
- (snd-display #__line__ ";delete 30 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 1))
- (snd-display #__line__ ";float-vector .5 at 1 position del 30: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 1 del 30: ~A" (channel->float-vector 0 10)))
- (delete-samples 3 3)
- ; (if (mix? id) (snd-display #__line__ ";delete within mix but exists?: ~A" (mix? id)))
- (if (not (mix? id)) (snd-display #__line__ ";delete within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 1 del at 3: ~A" (channel->float-vector 0 10)))
-
- (set! (edit-position) 1)
- (if (not (mix? id)) (snd-display #__line__ ";mix float-vector after del reset edit position: ~A" (mix? id)))
- (if (not (= (mix-position id) 11)) (snd-display #__line__ ";mix float-vector position after del reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 after del reset edit: ~A" (channel->float-vector 10 10)))
-
- ;; change
- (set! (samples 0 5) (make-float-vector 5 .6))
- (if (not (mix? id))
- (snd-display #__line__ ";set locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 set position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 set: ~A" (channel->float-vector 10 10)))
- (set! (samples 20 5) (make-float-vector 5 .7))
- (if (not (mix? id))
- (snd-display #__line__ ";set 20 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 set 20 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 set 20: ~A" (channel->float-vector 10 10)))
- (set! (samples 12 2) (float-vector -.5 .8))
- ; (if (mix? id) (snd-display #__line__ ";set within mix but exists?: ~A" (mix? id)))
- (if (not (mix? id)) (snd-display #__line__ ";set within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 -.5 .8 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 set at 12: ~A" (channel->float-vector 10 10)))
-
- (set! (edit-position) 1)
- (if (not (mix? id)) (snd-display #__line__ ";mix float-vector after set reset edit position: ~A" (mix? id)))
- (if (not (= (mix-position id) 11)) (snd-display #__line__ ";mix float-vector position after set reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 after set reset edit: ~A" (channel->float-vector 10 10)))
-
- ;; scale
- (scale-channel 2.0)
- (if (not (mix? id))
- (snd-display #__line__ ";scale locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 scale position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 1 1 1 1 1 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 scale: ~A" (channel->float-vector 10 10)))
- (scale-channel 0.5)
- (if (not (mix? id))
- (snd-display #__line__ ";unscale locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 unscale position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 unscale: ~A" (channel->float-vector 10 10)))
- (scale-channel -1.0 0 5)
- (if (not (mix? id))
- (snd-display #__line__ ";scale at 0 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 scale at 0 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 scale at 0: ~A" (channel->float-vector 10 10)))
- (scale-channel -1.0 22 10)
- (if (not (mix? id))
- (snd-display #__line__ ";scale at 22 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 scale at 22 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 scale at 22: ~A" (channel->float-vector 10 10)))
- (scale-channel 2.0 12 2)
- ; (if (mix? id) (snd-display #__line__ ";scale within mix but exists?: ~A" (mix? id)))
- (if (not (mix? id)) (snd-display #__line__ ";scale within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 1 1 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 scale at 12: ~A" (channel->float-vector 10 10)))
-
- (set! (edit-position) 1)
- (if (not (mix? id)) (snd-display #__line__ ";mix float-vector after scale reset edit position: ~A" (mix? id)))
- (if (not (= (mix-position id) 11)) (snd-display #__line__ ";mix float-vector position after scale reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 after scale reset edit: ~A" (channel->float-vector 10 10)))
-
- ;; envelopes
- (env-channel '(0 0 1 1) 0 8)
- (if (not (mix? id))
- (snd-display #__line__ ";env locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 env position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 env: ~A" (channel->float-vector 10 10)))
- (env-channel '(0 0 1 1) 17 10)
- (if (not (mix? id))
- (snd-display #__line__ ";env 17 locked mix? ~A" (mix? id)))
- (if (not (= (mix-position id) 11))
- (snd-display #__line__ ";float-vector .5 at 11 env 17 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 env 17: ~A" (channel->float-vector 10 10)))
- (env-channel '(0 0 1 1))
- ; (if (mix? id) (snd-display #__line__ ";env over mix but exists?: ~A" (mix? id)))
- (if (not (mix? id)) (snd-display #__line__ ";env over mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0.000 0.056 0.061 0.066 0.071 0.076 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";float-vector .5 at 11 over env: ~A" (channel->float-vector 10 10)))
-
- (set! (edit-position) 1)
- ; (if (not (mix? id)) (snd-display #__line__ ";mix float-vector after env reset edit position: ~A" (mix? id)))
- (if (not (= (mix-position id) 11)) (snd-display #__line__ ";mix float-vector position after env reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
- (snd-display #__line__ ";float-vector .5 at 11 after env reset edit: ~A" (channel->float-vector 10 10)))
-
- (scale-by 0.0)
- (if (not (mix? id)) (snd-display #__line__ ";zero mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";float-vector 1 at 11 scale 0: ~A" (channel->float-vector 10 10)))
- (undo 2)
-
- (let ((ids ()))
- (do ((i 0 (+ i 1)))
- ((= i 5))
- (set! ids (cons (mix-float-vector (make-float-vector 5 .1) (+ i 10)) ids)))
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";pile up mixes: ~A" vals)))
- (let ((mx (mixes-maxamp ids)))
- (if (fneq mx .1)
- (snd-display #__line__ ";mixes-maxamp: ~A" mx)))
- (let ((len (mixes-length ids)))
- (if (not (= len 10))
- (snd-display #__line__ ";mixes-length: ~A" len)))
- (sync-all-mixes 21)
- (for-each (lambda (m) (if (not (= (mix-sync m) 21)) (snd-display #__line__ ";sync-all-mixes ~A: ~A" m (mix-sync m)))) ids)
- (sync-all-mixes 0)
- (for-each (lambda (m) (if (not (= (mix-sync m) 0)) (snd-display #__line__ ";re sync-all-mixes ~A: ~A" m (mix-sync m)))) ids)
- (scale-mixes ids -2.0)
- (for-each (lambda (m) (if (fneq (mix-amp m) -2.0) (snd-display #__line__ ";scale-mixes ~A: ~A" m (mix-amp m)))) ids)
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 -0.200 -0.400 -0.600 -0.800 -1.000 -0.800 -0.600 -0.400 -0.200 0.000 0.000 0.000)))
- (snd-display #__line__ ";scale piled up mixes: ~A" vals)))
- (silence-mixes ids)
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (make-float-vector 14 0.0)))
- (snd-display #__line__ ";silence piled up mixes: ~A" vals)))
- (undo 2)
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";undo 2 to pile up mixes: ~A" vals)))
- (play-mixes ids)
- (set-mixes-tag-y ids 100)
- (for-each (lambda (m) (if (not (= (mix-tag-y m) 100)) (snd-display #__line__ ";set-mixes-tag-y ~A: ~A" m (mix-tag-y m)))) ids)
- (set-mixes-tag-y ids 0)
- (move-mixes ids 10)
- (let ((vals (channel->float-vector 18 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";move piled up mixes: ~A" vals)))
- (let ((vals (channel->float-vector 8 8)))
- (if (not (vequal vals (make-float-vector 8 0.0)))
- (snd-display #__line__ ";move piled up mixes original: ~A" vals)))
- (move-mixes ids -10)
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";move piled up mixes -10: ~A" vals)))
- (let ((vals (channel->float-vector 23 8)))
- (if (not (vequal vals (make-float-vector 8 0.0)))
- (snd-display #__line__ ";move piled up mixes -10: ~A" vals)))
- (for-each (lambda (m) (set! (mix-sync m) 24)) ids)
- (let ((mxs (syncd-mixes 24)))
- (if (not (= (length mxs) (length ids)))
- (snd-display #__line__ ";syncd-mixes: ~A ~A" mxs ids))
- (for-each (lambda (m) (if (not (member m ids)) (snd-display #__line__ ";syncd-mixes: ~A not in ~A" m ids))) mxs))
- (sync-all-mixes 0)
- (env-mixes ids '(0 0 1 1 2 0))
- (let ((vals (channel->float-vector 10 10)))
- (if (not (vequal vals (float-vector 0.000 0.045 0.137 0.278 0.460 0.360 0.203 0.087 0.020 0.000)))
- (snd-display #__line__ ";env-mixes: ~A" vals)))
- (undo 3)
- (let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";undo 3 mixes envd: ~A" vals)))
- (color-mixes ids (make-color 0 1 0))
- (scale-tempo ids 2.0)
- (let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 18 16 14 12 10)))
- (snd-display #__line__ ";scale-tempo by 2: ~A" begs)))
- (let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.100 0.200 0.200 0.300 0.200 0.300 0.200 0.300 0.200 0.200 0.100 0.100 0.000 0.000)))
- (snd-display #__line__ ";scale-tempo 2 vals: ~A" vals)))
- (scale-tempo ids 0.5)
- (let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 14 13 12 11 10)))
- (snd-display #__line__ ";scale-tempo by 0.5: ~A" begs)))
- (let ((vals (channel->float-vector 10 10)))
- (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000)))
- (snd-display #__line__ ";scale-tempo back 0.5: ~A" vals)))
- (scale-tempo ids -1.0)
- (let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 6 7 8 9 10)))
- (snd-display #__line__ ";scale-tempo by -1: ~A" begs)))
- (let ((vals (channel->float-vector 0 15)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100)))
- (snd-display #__line__ ";scale-tempo -1 vals: ~A" vals)))
- (undo 3)
- (set! *sinc-width* 10)
- (src-mixes ids 0.5)
- (if (fneq (mix-speed (car ids)) 0.5)
- (snd-display #__line__ ";src-mixes speed: ~A" (mix-speed (car ids))))
- (if (not (= (mixes-length ids) 15))
- (snd-display #__line__ ";src-mixes length: ~A" (mixes-length ids)))
- (let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
- (snd-display #__line__ ";src-mixes 0.5 vals: ~A" vals)))
- (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
- (snd-display #__line__ ";src-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
- (undo)
- (transpose-mixes ids -12)
- (if (fneq (mix-speed (car ids)) 0.5)
- (snd-display #__line__ ";transpose-mixes speed: ~A" (mix-speed (car ids))))
- (if (not (= (mixes-length ids) 15))
- (snd-display #__line__ ";transpose-mixes length: ~A" (mixes-length ids)))
- (let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
- (snd-display #__line__ ";transpose-mixes 0.5 vals: ~A" vals)))
- (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
- (snd-display #__line__ ";transpose-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
- (revert-sound))
- (close-sound ind)))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108)))
+ (snd-display ";mix on xramp: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 9)))
+ (snd-display ";mix on xramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108))))
+ (snd-display ";read mix on xramp reversed: ~A" data)))
- ;; check locks
- (let ((ind (new-sound "test.snd" :size 100)))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 0: ~A ~A" id (mix? id)))
- (ramp-channel 0.0 1.0 0 20)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 5: ~A ~A" id (mix? id)))
- (undo)
- (xramp-channel 0.0 1.0 32.0 0 20)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 6: ~A ~A" id (mix? id)))
- (undo 2)
- (delete-sample 52)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 7: ~A ~A" id (mix? id)))
- (undo)
- (delete-sample 10)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 8: ~A ~A" id (mix? id)))
- (undo)
- (insert-samples 51 2 (float-vector .1 .2))
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 9: ~A ~A" id (mix? id)))
- (undo)
- (insert-samples 1 2 (float-vector .1 .2))
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 10: ~A ~A" id (mix? id)))
- (undo)
- (set! (sample 51) 1.0)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 11: ~A ~A" id (mix? id)))
- (undo)
- (set! (sample 1) 1.0)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 12: ~A ~A" id (mix? id)))
- (undo)
- (xramp-channel 0 1 32 0 40)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 13: ~A ~A" id (mix? id)))
- (xramp-channel 0 1 32 0 40)
- (if (not (mix? id))
- (snd-display #__line__ ";mix lock 14: ~A ~A" id (mix? id)))
- (close-sound ind)))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (xramp-channel 1 0 32.0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012)))
+ (snd-display ";mix on xramp2: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp2: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 13)))
+ (snd-display ";mix on xramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012))))
+ (snd-display ";read mix on xramp2 reversed: ~A" data)))
- (do ((i 0 (+ i 1)))
- ((= i 2))
-
- (let ((ind (new-sound "test.snd" :size 100))
- (tag *with-mix-tags*))
-
- ;; check various mix ops briefly
- (map-channel (lambda (y) 1.0))
- (env-channel '(0 0 1 1))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576)))
- (snd-display #__line__ ";mix on env: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on env: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 5)))
- (snd-display #__line__ ";mix on env edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576))))
- (snd-display #__line__ ";read mix on env reversed: ~A" data)))
- (undo))
-
- (env-channel '(0 0 1 1))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331)))
- (snd-display #__line__ ";mix on env 1: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on env 1: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 7)))
- (snd-display #__line__ ";mix on env1 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331))))
- (snd-display #__line__ ";read mix on env1 reversed: ~A" data)))
- (undo))
-
- (env-channel '(0 0 1 1))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191)))
- (snd-display #__line__ ";mix on env 2: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on env 2: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
- (snd-display #__line__ ";mix on env2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191))))
- (snd-display #__line__ ";read mix on env2 reversed: ~A" data)))
- (undo))
-
- (env-channel '(0 0 1 1))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110)))
- (snd-display #__line__ ";mix on env 3: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on env 3: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
- (snd-display #__line__ ";mix on env3 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110))))
- (snd-display #__line__ ";read mix on env3 reversed: ~A" data)))
- (undo))
-
- (env-channel '(0 0 1 1))
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063)))
- (snd-display #__line__ ";mix on env 4: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on env 4: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 11)))
- (snd-display #__line__ ";mix on env4 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063))))
- (snd-display #__line__ ";read mix on env4 reversed: ~A" data)))
- (undo))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108)))
- (snd-display #__line__ ";mix on xramp: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 9)))
- (snd-display #__line__ ";mix on xramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108))))
- (snd-display #__line__ ";read mix on xramp reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (xramp-channel 1 0 32.0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012)))
- (snd-display #__line__ ";mix on xramp2: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp2: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 13)))
- (snd-display #__line__ ";mix on xramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012))))
- (snd-display #__line__ ";read mix on xramp2 reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (xramp-channel 1 0 32.0)
- (ramp-channel 1 0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005)))
- (snd-display #__line__ ";mix on xramp2_ramp: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp2_ramp: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
- (snd-display #__line__ ";mix on xramp2_ramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005))))
- (snd-display #__line__ ";read mix on xramp2_ramp reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (xramp-channel 1 0 32.0)
- (ramp-channel 1 0)
- (ramp-channel 1 0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002)))
- (snd-display #__line__ ";mix on xramp2_ramp2: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp2_ramp2: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
- (snd-display #__line__ ";mix on xramp2_ramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002))))
- (snd-display #__line__ ";read mix on xramp2_ramp2 reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (ramp-channel 1 0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046)))
- (snd-display #__line__ ";mix on xramp_ramp: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp_ramp: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
- (snd-display #__line__ ";mix on xramp_ramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046))))
- (snd-display #__line__ ";read mix on xramp_ramp reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (ramp-channel 1 0)
- (ramp-channel 1 0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019)))
- (snd-display #__line__ ";mix on xramp_ramp2: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp_ramp2: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
- (snd-display #__line__ ";mix on xramp_ramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019))))
- (snd-display #__line__ ";read mix on xramp_ramp2 reversed: ~A" data))))
-
- (set! (edit-position ind 0) 1)
- (xramp-channel 1 0 32.0)
- (ramp-channel 1 0)
- (ramp-channel 1 0)
- (ramp-channel 1 0)
- (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
- (let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008)))
- (snd-display #__line__ ";mix on xramp_ramp3: ~A" vals)))
- (if (and tag (not (mix? id)))
- (snd-display #__line__ ";mix on xramp_ramp3: ~A ~A" id (mix? id)))
- (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
- (snd-display #__line__ ";mix on xramp_ramp3 edit-tree: ~A" ((cadr (edit-tree)) 7)))
- (let ((data (make-float-vector 10))
- (reader (make-sampler 57 ind 0 -1)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008))))
- (snd-display #__line__ ";read mix on xramp_ramp3 reversed: ~A" data))))
-
- (set! *with-mix-tags* #t)
- (revert-sound)
- (mix-float-vector (float-vector .1 .2 .3) 50)
- (reverse-sound)
- (let ((vals (channel->float-vector 45 8)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.300 0.200 0.100 0.000 0.000 0.000)))
- (snd-display #__line__ ";reversed mix vals: ~A" vals)))
- (close-sound ind))
-
- (set! *with-mix-tags* #f))
- (set! *with-mix-tags* #t)
-
- (let ((ind (open-sound "oboe.snd")))
- (mix-float-vector (make-float-vector 100 .1) 1000)
- (for-each
- (lambda (mtest)
- (let ((func (car mtest))
- ;;(beg (cadr mtest))
- ;;(lock (caddr mtest))
- ;;(name (cadddr mtest))
- (edpos (edit-position ind 0)))
- (func)
- (set! (edit-position ind 0) edpos)))
- (list
- (list (lambda () (pad-channel 0 100)) 1100 #f 'pad0)
- (list (lambda () (pad-channel 0 2000)) 3000 #f 'pad20)
- (list (lambda () (pad-channel 800 100)) 1100 #f 'pad800)
- (list (lambda () (pad-channel 850 100)) 1100 #f 'pad800)
- (list (lambda () (pad-channel 990 100)) 1100 #f 'pad990)
- (list (lambda () (pad-channel 1010 100)) 1000 #t 'pad1010)
- (list (lambda () (pad-channel 1050 10)) 1000 #t 'pad1050)
- (list (lambda () (pad-channel 1110 100)) 1000 #f 'pad1110)
- (list (lambda () (pad-channel 2000 100)) 1000 #f 'pad2000)
-
- (list (lambda () (insert-samples 0 100 (make-float-vector 100 .2))) 1100 #f 'insert0)
- (list (lambda () (insert-samples 800 100 (make-float-vector 100 .2))) 1100 #f 'insert800)
- (list (lambda () (insert-samples 990 100 (make-float-vector 100 .2))) 1100 #f 'insert990)
- (list (lambda () (insert-samples 1010 100 (make-float-vector 100 .2))) 1000 #t 'insert1010)
- (list (lambda () (insert-samples 1050 10 (make-float-vector 100 .2))) 1000 #t 'insert1050)
- (list (lambda () (insert-samples 1110 100 (make-float-vector 100 .2))) 1000 #f 'insert1110)
- (list (lambda () (insert-samples 2000 100 (make-float-vector 100 .2))) 1000 #f 'insert2000)
-
- (let ((fr (mus-sound-framples "1a.snd")))
- (list (lambda () (insert-sound "1a.snd" 0)) (+ fr 1000) #f 'inserts0)
- (list (lambda () (insert-sound "1a.snd" 800)) (+ fr 1000) #f 'inserts800)
- (list (lambda () (insert-sound "1a.snd" 990)) (+ fr 1000) #f 'inserts990)
- (list (lambda () (insert-sound "1a.snd" 1010)) 1000 #t 'inserts1010)
- (list (lambda () (insert-sound "1a.snd" 1050)) 1000 #t 'inserts1050)
- (list (lambda () (insert-sound "1a.snd" 1110)) 1000 #f 'inserts1110)
- (list (lambda () (insert-sound "1a.snd" 2000)) 1000 #f 'inserts2000))
-
- (list (lambda () (delete-samples 0 100)) 900 #f 'delete0)
- (list (lambda () (delete-samples 0 2000)) 1000 #t 'delete20)
- (list (lambda () (delete-samples 800 100)) 900 #f 'delete800)
- (list (lambda () (delete-samples 850 100)) 900 #f 'delete850)
- (list (lambda () (delete-samples 950 40)) 960 #f 'delete950)
- (list (lambda () (delete-samples 990 100)) 1000 #t 'delete990)
- (list (lambda () (delete-samples 1010 100)) 1000 #t 'delete1010)
- (list (lambda () (delete-samples 1050 10)) 1000 #t 'delete1050)
- (list (lambda () (delete-samples 1110 100)) 1000 #f 'delete1110)
- (list (lambda () (delete-samples 2000 100)) 1000 #f 'delete2000)
-
- (list (lambda () (set! (samples 0 100) (make-float-vector 100 .2))) 1000 #f 'set0)
- (list (lambda () (set! (samples 0 2000) (make-float-vector 2000 .2))) 1000 #t 'set0)
- (list (lambda () (set! (samples 800 100) (make-float-vector 100 .2))) 1000 #f 'set800)
- (list (lambda () (set! (samples 990 100) (make-float-vector 100 .2))) 1000 #t 'set990)
- (list (lambda () (set! (samples 1010 100) (make-float-vector 100 .2))) 1000 #t 'set1010)
- (list (lambda () (set! (samples 1050 10) (make-float-vector 100 .2))) 1000 #t 'set1050)
- (list (lambda () (set! (samples 1110 100) (make-float-vector 100 .2))) 1000 #f 'set1110)
- (list (lambda () (set! (samples 2000 100) (make-float-vector 100 .2))) 1000 #f 'set2000)
-
- (list (lambda () (scale-channel 2.0 0 100)) 1000 #f 'scale0)
- (list (lambda () (scale-channel 2.0 0 2000)) 1000 #t 'scale20)
- (list (lambda () (scale-channel 2.0 800 100)) 1000 #f 'scale800)
- (list (lambda () (scale-channel 2.0 850 100)) 1000 #f 'scale850)
- (list (lambda () (scale-channel 2.0 950 40)) 1000 #f 'scale950)
- (list (lambda () (scale-channel 2.0 990 100)) 1000 #t 'scale990)
- (list (lambda () (scale-channel 2.0 1010 100)) 1000 #t 'scale1010)
- (list (lambda () (scale-channel 2.0 1050 10)) 1000 #t 'scale1050)
- (list (lambda () (scale-channel 2.0 1110 100)) 1000 #f 'scale1110)
- (list (lambda () (scale-channel 2.0 2000 100)) 1000 #f 'scale2000)
-
- (list (lambda () (env-channel '(0 0 1 1) 0 100)) 1000 #f 'env0)
- (list (lambda () (env-channel '(0 0 1 1) 0 2000)) 1000 #t 'env20)
- (list (lambda () (env-channel '(0 0 1 1) 800 100)) 1000 #f 'env800)
- (list (lambda () (env-channel '(0 0 1 1) 850 100)) 1000 #f 'env850)
- (list (lambda () (env-channel '(0 0 1 1) 950 40)) 1000 #f 'env950)
- (list (lambda () (env-channel '(0 0 1 1) 990 100)) 1000 #t 'env990)
- (list (lambda () (env-channel '(0 0 1 1) 1010 100)) 1000 #t 'env1010)
- (list (lambda () (env-channel '(0 0 1 1) 1050 10)) 1000 #t 'env1050)
- (list (lambda () (env-channel '(0 0 1 1) 1110 100)) 1000 #f 'env1110)
- (list (lambda () (env-channel '(0 0 1 1) 2000 100)) 1000 #f 'env2000)
-
- ))
- (close-sound ind))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (xramp-channel 1 0 32.0)
+ (ramp-channel 1 0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005)))
+ (snd-display ";mix on xramp2_ramp: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp2_ramp: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
+ (snd-display ";mix on xramp2_ramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005))))
+ (snd-display ";read mix on xramp2_ramp reversed: ~A" data)))
- (let ((ind (open-sound "4.aiff"))
- (selind (open-sound "oboe.snd")))
- (make-selection 100 500 selind 0)
- (mix-selection 500 ind 2)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";mix-selection 0->2 0: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 0)) (snd-display #__line__ ";mix-selection 0->2 1: ~A" (edit-position ind 1)))
- (if (not (= (edit-position ind 2) 1)) (snd-display #__line__ ";mix-selection 0->2 2: ~A" (edit-position ind 2)))
- (if (not (= (edit-position ind 3) 0)) (snd-display #__line__ ";mix-selection 0->2 3: ~A" (edit-position ind 3)))
- (revert-sound ind)
- (set! (sync ind) 1234)
- (mix-selection 500 ind 1)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";mix-selection 1->2 0: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 1)) (snd-display #__line__ ";mix-selection 1->2 1: ~A" (edit-position ind 1)))
- (if (not (= (edit-position ind 2) 0)) (snd-display #__line__ ";mix-selection 1->2 2: ~A" (edit-position ind 2)))
- (if (not (= (edit-position ind 3) 0)) (snd-display #__line__ ";mix-selection 1->2 3: ~A" (edit-position ind 3)))
- (revert-sound ind)
- (set! (sync ind) 0)
- (insert-selection 500 ind 2)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";insert-selection 0->2 0: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 0)) (snd-display #__line__ ";insert-selection 0->2 1: ~A" (edit-position ind 1)))
- (if (not (= (edit-position ind 2) 1)) (snd-display #__line__ ";insert-selection 0->2 2: ~A" (edit-position ind 2)))
- (if (not (= (edit-position ind 3) 0)) (snd-display #__line__ ";insert-selection 0->2 3: ~A" (edit-position ind 3)))
- (revert-sound ind)
- (set! (sync ind) 1234)
- (insert-selection 500 ind 1)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";insert-selection 1->2 0: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 1)) (snd-display #__line__ ";insert-selection 1->2 1: ~A" (edit-position ind 1)))
- (if (not (= (edit-position ind 2) 0)) (snd-display #__line__ ";insert-selection 1->2 2: ~A" (edit-position ind 2)))
- (if (not (= (edit-position ind 3) 0)) (snd-display #__line__ ";insert-selection 1->2 3: ~A" (edit-position ind 3)))
- (revert-sound ind)
- (set! (sync ind) 0)
- (close-sound ind)
- (close-sound selind))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (xramp-channel 1 0 32.0)
+ (ramp-channel 1 0)
+ (ramp-channel 1 0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002)))
+ (snd-display ";mix on xramp2_ramp2: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp2_ramp2: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
+ (snd-display ";mix on xramp2_ramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002))))
+ (snd-display ";read mix on xramp2_ramp2 reversed: ~A" data)))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (ramp-channel 1 0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046)))
+ (snd-display ";mix on xramp_ramp: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp_ramp: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
+ (snd-display ";mix on xramp_ramp edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046))))
+ (snd-display ";read mix on xramp_ramp reversed: ~A" data)))
- (let ((new-index (new-sound "hiho.wave" 1 22050 mus-ldouble mus-next)))
- (log-mem test-ctr)
- (select-sound new-index)
- (if (find-mix 0 new-index 0) (snd-display #__line__ ";found non-existent mix? ~A" (find-mix 0 new-index 0)))
- (let ((mix-id (car (mix "pistol.snd" 100))))
- (if (not (mix? mix-id)) (snd-display #__line__ ";~A not mix?" mix-id))
- (view-mixes-dialog)
- (let ((pos (mix-position mix-id))
- (len (mix-length mix-id))
- (spd (mix-speed mix-id))
- (snd (car (mix-home mix-id)))
- (chn (cadr (mix-home mix-id)))
- (nam (mix-name mix-id))
- (amp (mix-amp mix-id))
- (mr (make-mix-sampler mix-id)))
- (if (not (mix-sampler? mr)) (snd-display #__line__ ";~A not mix-sampler?" mr))
- (if (region-sampler? mr) (snd-display #__line__ ";mix sampler: region ~A" mr))
- ; (if (sampler? mr) (snd-display #__line__ ";mix sampler: normal ~A" mr))
- (if (not (= (sampler-position mr) 0)) (snd-display #__line__ ";mix sampler position: ~A" (sampler-position mr)))
- (if (sampler-at-end? mr) (snd-display #__line__ ";mix sampler at end? ~A" mr))
- (if (not (equal? (sampler-home mr) mix-id))
- (snd-display #__line__ ";~A home: ~A" mr (sampler-home mr)))
- (let ((reader-string (format #f "~A" mr)))
- (if (not (string=? (substring reader-string 0 16) "#<mix-sampler mi"))
- (snd-display #__line__ ";mix sampler actually got: [~S]" (substring reader-string 0 16))))
- (do ((i 0 (+ i 1)))
- ((= i 99))
- (let ((mx (read-mix-sample mr))
- (sx (sample (+ 100 i))))
- (if (fneq mx sx) (snd-display #__line__ ";read-mix-sample: ~A ~A?" mx sx))))
- (let ((mx (mr))
- (sx (sample 199)))
- (if (fneq mx sx) (snd-display #__line__ ";mix-sample 100: ~A ~A?" mx sx)))
- (free-sampler mr)
- (if (not (= pos 100)) (snd-display #__line__ ";mix-position: ~A?" pos))
- (if (not (= len 41623)) (snd-display #__line__ ";mix-length: ~A?" len))
- (if (not (equal? snd new-index)) (snd-display #__line__ ";s mix-home: ~A?" snd))
- (if (not (= chn 0)) (snd-display #__line__ ";c mix-home: ~A?" chn))
- (if (fneq amp 1.0) (snd-display #__line__ ";mix-amp: ~A?" amp))
- (if (fneq spd 1.0) (snd-display #__line__ ";mix-speed: ~A?" spd))
- (if (not (equal? nam "")) (snd-display #__line__ ";mix-name: ~A" nam))
- (catch 'mus-error
- (lambda () (play mix-id))
- (lambda args (snd-display #__line__ ";can't play mix: ~A" args)))
- (catch 'mus-error
- (lambda () (play mix-id 1000))
- (lambda args (snd-display #__line__ ";can't play mix from 1000: ~A" args)))
- (set! (mix-name mix-id) "test-mix")
- (if (or (not (string? (mix-name mix-id)))
- (not (string=? (mix-name mix-id) "test-mix")))
- (snd-display #__line__ ";mix-name set: ~A" (mix-name mix-id)))
- (let ((id (mix-name->id "test-mix")))
- (if (not (equal? id mix-id)) (snd-display #__line__ ";mix-name->id: ~A ~A" id mix-id)))
- (set! (mix-name mix-id) "test-mix-again") ; make sure previous name is freed
- (if (or (not (string? (mix-name mix-id)))
- (not (string=? (mix-name mix-id) "test-mix-again")))
- (snd-display #__line__ ";mix-name set again: ~A" (mix-name mix-id)))
- (set! (mix-name mix-id) "")
- (if (not (equal? (mix-name mix-id) "")) (snd-display #__line__ ";set mix-name #f: ~A" (mix-name mix-id)))
- (set! (mix-position mix-id) 200)
- (set! (mix-amp mix-id) 0.5)
- (set! (mix-speed mix-id) 2.0)
-
- (set! (mix-amp-env mix-id) '(0.0 0.0 1.0 1.0))
- (set! (mix-tag-y mix-id) 20)
- (let ((pos (mix-position mix-id))
- (spd (mix-speed mix-id))
- (amp (mix-amp mix-id))
- (my (mix-tag-y mix-id)))
- (if (not (= pos 200)) (snd-display #__line__ ";set-mix-position: ~A?" pos))
- (if (not (= my 20)) (snd-display #__line__ ";set-mix-tag-y: ~A?" my))
- (if (fneq amp 0.5) (snd-display #__line__ ";set-mix-amp: ~A?" amp))
- (if (fneq spd 2.0) (snd-display #__line__ ";set-mix-speed: ~A?" spd))
- (if (not (equal? (mix-amp-env mix-id) '(0.0 0.0 1.0 1.0))) (snd-display #__line__ ";set-mix-amp-env: ~A?" (mix-amp-env mix-id))))
- ))
- (mix-float-vector (make-float-vector 3 .1) 100)
- (set! (cursor) 0)
- (let ((nid (find-mix 100)))
- (if (or (not (mix? nid))
- (not (= (mix-position nid) 100)))
- (snd-display #__line__ ";find-mix(100): ~A ~A ~A?" nid (and (mix? nid) (mix-position nid)) (map mix-position (mixes new-index 0)))))
- (let ((nid (find-mix 200)))
- (if (or (not (mix? nid))
- (not (= (mix-position nid) 200)))
- (snd-display #__line__ ";find-mix(200): ~A ~A?" nid (and (mix? nid) (mix-position nid)))))
- (let ((mix-id (car (mix "oboe.snd" 100))))
- (set! *mix-waveform-height* 40)
- (set! (mix-property :hiho mix-id) 123)
- (if (not (= (mix-property :hiho mix-id) 123)) (snd-display #__line__ ";mix-property: ~A" (mix-property :hiho mix-id)))
- (if (mix-property :not-there mix-id) (snd-display #__line__ ";mix-not-property: ~A" (mix-property :not-there mix-id)))
- (update-time-graph)
- (set! *mix-waveform-height* 20))
- (close-sound new-index))
- )
- (dismiss-all-dialogs)
-
- ;; pan-mix tests
- (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "pan-mix tests")))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (ramp-channel 1 0)
+ (ramp-channel 1 0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019)))
+ (snd-display ";mix on xramp_ramp2: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp_ramp2: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
+ (snd-display ";mix on xramp_ramp2 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019))))
+ (snd-display ";read mix on xramp_ramp2 reversed: ~A" data)))
- (let ((id0 (car (pan-mix "1a.snd" 10000 '(0 0 1 1)))))
- (if (or (fneq (mix-amp id0) 1.0)
- (not (feql (mix-amp-env id0) '(0 1 1 0))))
- (snd-display #__line__ ";pan-mix 1->1 2: ~A ~A" (mix-amp id0) (mix-amp-env id0)))
- (if (not (= (mix-position id0) 10000)) (snd-display #__line__ ";pan-mix 1->1 pos 2: ~A" (mix-position id0)))
- (revert-sound ind))
+ (set! (edit-position ind 0) 1)
+ (xramp-channel 1 0 32.0)
+ (ramp-channel 1 0)
+ (ramp-channel 1 0)
+ (ramp-channel 1 0)
+ (let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
+ (let ((vals (channel->float-vector 48 10)))
+ (if (not (vequal vals (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008)))
+ (snd-display ";mix on xramp_ramp3: ~A" vals)))
+ (if (and tag (not (mix? id)))
+ (snd-display ";mix on xramp_ramp3: ~A ~A" id (mix? id))))
+ (if (and tag (not (= ((cadr (edit-tree)) 7) 15)))
+ (snd-display ";mix on xramp_ramp3 edit-tree: ~A" ((cadr (edit-tree)) 7)))
+ (let ((data (make-float-vector 10))
+ (reader (make-sampler 57 ind 0 -1)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (data i) (read-sample reader)))
+ (if (not (vequal data (reverse! (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008))))
+ (snd-display ";read mix on xramp_ramp3 reversed: ~A" data)))
- (let* ((ids (pan-mix "2a.snd" 100 '(0 0 1 1)))
- (id0 (car ids))
- (id1 (cadr ids)))
- (if (or (not (mix? id0)) (not (mix? id1)))
- (snd-display #__line__ ";pan-mix 2->1: ~A ~A" id0 id1))
- (if (not (= (mix-position id0) (mix-position id1) 100))
- (snd-display #__line__ ";pan-mix 2->1 pos: ~A ~A" (mix-position id0) (mix-position id1)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix 2->1 mix amps 3: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
- (snd-display #__line__ ";pan-mix 2->1 ramp env: ~A" (mix-amp-env id0)))
- (revert-sound ind))
+ (set! *with-mix-tags* #t)
+ (revert-sound)
+ (mix-float-vector (float-vector .1 .2 .3) 50)
+ (reverse-sound)
+ (let ((vals (channel->float-vector 45 8)))
+ (if (not (vequal vals (float-vector 0.000 0.000 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (snd-display ";reversed mix vals: ~A" vals)))
(close-sound ind))
- (let ((ind (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "pan-mix tests")))
- (let* ((ids (pan-mix "1a.snd" 100 '(0 0 1 1 2 0)))
- (id0 (car ids))
- (id1 (cadr ids)))
- (if (or (not (mix? id0)) (not (mix? id1)))
- (snd-display #__line__ ";pan-mix 1->2: ~A ~A" id0 id1))
- (if (not (= (mix-position id0) (mix-position id1) 100))
- (snd-display #__line__ ";pan-mix 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0 2 1)))
- (snd-display #__line__ ";pan-mix 1->2 env 0: ~A" (mix-amp-env id0)))
- (if (not (feql (mix-amp-env id1) '(0 0 1 1 2 0)))
- (snd-display #__line__ ";pan-mix 1->2 env 1: ~A" (mix-amp-env id1)))
- (revert-sound ind))
+ (set! *with-mix-tags* #f))
+ (set! *with-mix-tags* #t)
+
+ (let ((ind (open-sound "oboe.snd"))
+ (fr (mus-sound-framples "1a.snd")))
+ (mix-float-vector (make-float-vector 100 .1) 1000)
+ (for-each
+ (lambda (mtest)
+ (let ((func (car mtest))
+ (edpos (edit-position ind 0)))
+ (func)
+ (set! (edit-position ind 0) edpos)))
+ (list
+ (list (lambda () (pad-channel 0 100)) 1100 #f 'pad0)
+ (list (lambda () (pad-channel 0 2000)) 3000 #f 'pad20)
+ (list (lambda () (pad-channel 800 100)) 1100 #f 'pad800)
+ (list (lambda () (pad-channel 850 100)) 1100 #f 'pad800)
+ (list (lambda () (pad-channel 990 100)) 1100 #f 'pad990)
+ (list (lambda () (pad-channel 1010 100)) 1000 #t 'pad1010)
+ (list (lambda () (pad-channel 1050 10)) 1000 #t 'pad1050)
+ (list (lambda () (pad-channel 1110 100)) 1000 #f 'pad1110)
+ (list (lambda () (pad-channel 2000 100)) 1000 #f 'pad2000)
- (let* ((ids (pan-mix "2a.snd" 100 '(0 0 1 1 2 0)))
- (id0 (car ids))
- (id1 (cadr ids))
- (id2 (caddr ids))
- (id3 (cadddr ids)))
-
- (if (or (not (mix? id0)) (not (mix? id1)) (not (mix? id2)) (not (mix? id3)))
- (snd-display #__line__ ";pan-mix 2->2: ~A ~A ~A ~A" id0 id1 id2 id3))
- (if (not (= (mix-position id0) (mix-position id1) (mix-position id2) (mix-position id3) 100))
- (snd-display #__line__ ";pan-mix 2->2 pos: ~A ~A ~A ~A" (mix-position id0) (mix-position id1) (mix-position id2) (mix-position id3)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix 2->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0 2 1)))
- (snd-display #__line__ ";pan-mix 2->2 env 0: ~A" (mix-amp-env id0)))
- (if (not (feql (mix-amp-env id1) '(0 0 1 1 2 0)))
- (snd-display #__line__ ";pan-mix 2->2 env 1: ~A" (mix-amp-env id1)))
- (if (not (feql (mix-amp-env id2) '(0 1 1 0 2 1)))
- (snd-display #__line__ ";pan-mix 2->2 env 2: ~A" (mix-amp-env id2)))
- (if (not (feql (mix-amp-env id3) '(0 0 1 1 2 0)))
- (snd-display #__line__ ";pan-mix 2->2 env 3: ~A" (mix-amp-env id3)))
- (revert-sound ind))
- (close-sound ind))
-
- (let ((ind (new-sound "test.snd" 2 22050 mus-ldouble mus-next "pan-mix-* tests" 1000)))
- (let* ((ids (pan-mix-float-vector (make-float-vector 100 .3) 100 '(0 0 1 1)))
- (id0 (car ids))
- (id1 (cadr ids)))
- (if (or (not (mix? id0)) (not (mix? id1)))
- (snd-display #__line__ ";pan-mix-float-vector 1->2: ~A ~A" id0 id1))
- (if (not (= (mix-position id0) (mix-position id1) 100))
- (snd-display #__line__ ";pan-mix-float-vector 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix-float-vector 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
- (snd-display #__line__ ";pan-mix-float-vector 1->2 env 0: ~A" (mix-amp-env id0)))
- (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
- (snd-display #__line__ ";pan-mix-float-vector 1->2 env 1: ~A" (mix-amp-env id1)))
- (revert-sound ind))
+ (list (lambda () (insert-samples 0 100 (make-float-vector 100 .2))) 1100 #f 'insert0)
+ (list (lambda () (insert-samples 800 100 (make-float-vector 100 .2))) 1100 #f 'insert800)
+ (list (lambda () (insert-samples 990 100 (make-float-vector 100 .2))) 1100 #f 'insert990)
+ (list (lambda () (insert-samples 1010 100 (make-float-vector 100 .2))) 1000 #t 'insert1010)
+ (list (lambda () (insert-samples 1050 10 (make-float-vector 100 .2))) 1000 #t 'insert1050)
+ (list (lambda () (insert-samples 1110 100 (make-float-vector 100 .2))) 1000 #f 'insert1110)
+ (list (lambda () (insert-samples 2000 100 (make-float-vector 100 .2))) 1000 #f 'insert2000)
+
+ (list (lambda () (insert-sound "1a.snd" 0)) (+ fr 1000) #f 'inserts0)
+ (list (lambda () (insert-sound "1a.snd" 800)) (+ fr 1000) #f 'inserts800)
+ (list (lambda () (insert-sound "1a.snd" 990)) (+ fr 1000) #f 'inserts990)
+ (list (lambda () (insert-sound "1a.snd" 1010)) 1000 #t 'inserts1010)
+ (list (lambda () (insert-sound "1a.snd" 1050)) 1000 #t 'inserts1050)
+ (list (lambda () (insert-sound "1a.snd" 1110)) 1000 #f 'inserts1110)
+ (list (lambda () (insert-sound "1a.snd" 2000)) 1000 #f 'inserts2000)
- (let* ((reg (make-region 0 50 ind 0))
- (ids (pan-mix-region reg 100 '(0 0 1 1)))
- (id0 (car ids))
- (id1 (cadr ids)))
- (if (or (not (mix? id0)) (not (mix? id1)))
- (snd-display #__line__ ";pan-mix-region 1->2: ~A ~A" id0 id1))
- (if (not (= (mix-position id0) (mix-position id1) 100))
- (snd-display #__line__ ";pan-mix-region 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix-region 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
- (snd-display #__line__ ";pan-mix-region 1->2 env 0: ~A" (mix-amp-env id0)))
- (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
- (snd-display #__line__ ";pan-mix-region 1->2 env 1: ~A" (mix-amp-env id1)))
- (revert-sound ind))
+ (list (lambda () (delete-samples 0 100)) 900 #f 'delete0)
+ (list (lambda () (delete-samples 0 2000)) 1000 #t 'delete20)
+ (list (lambda () (delete-samples 800 100)) 900 #f 'delete800)
+ (list (lambda () (delete-samples 850 100)) 900 #f 'delete850)
+ (list (lambda () (delete-samples 950 40)) 960 #f 'delete950)
+ (list (lambda () (delete-samples 990 100)) 1000 #t 'delete990)
+ (list (lambda () (delete-samples 1010 100)) 1000 #t 'delete1010)
+ (list (lambda () (delete-samples 1050 10)) 1000 #t 'delete1050)
+ (list (lambda () (delete-samples 1110 100)) 1000 #f 'delete1110)
+ (list (lambda () (delete-samples 2000 100)) 1000 #f 'delete2000)
- (select-all)
- (let* ((ids (pan-mix-selection 100 '(0 0 1 1)))
- (id0 (car ids))
- (id1 (cadr ids)))
- (if (or (not (mix? id0)) (not (mix? id1)))
- (snd-display #__line__ ";pan-mix-selection 1->2: ~A ~A" id0 id1))
- (if (not (= (mix-position id0) (mix-position id1) 100))
- (snd-display #__line__ ";pan-mix-selection 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
- (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
- (snd-display #__line__ ";pan-mix-selection 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
- (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
- (snd-display #__line__ ";pan-mix-selection 1->2 env 0: ~A" (mix-amp-env id0)))
- (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
- (snd-display #__line__ ";pan-mix-selection 1->2 env 1: ~A" (mix-amp-env id1)))
- (revert-sound ind))
- (close-sound ind))
-
- ;; copy mix
- (let ((snd (new-sound "test.snd")))
- (let ((v (make-float-vector 1000)))
- (do ((i 0 (+ i 1)))
- ((= i 1000))
- (set! (v i) (* i .001)))
- (let ((mx (mix-float-vector v 0 snd 0)))
- (let ((mx-copy (copy mx)))
- (if (not (= (length mx) (length mx-copy)))
- (snd-display #__line__ ";copy mix lengths: ~A ~A" (length mx) (length mx-copy)))
- (if (not (= (mix-position mx) (mix-position mx-copy)))
- (snd-display #__line__ ";copy mix positions: ~A ~A" (mix-position mx) (mix-position mx-copy)))
- (set! (mix-position mx-copy) 2000)
- (let ((rd1 (make-sampler 0))
- (rd2 (make-sampler 2000))
- (happy #t))
- (do ((i 0 (+ i 1)))
- ((or (not happy)
- (= i 1000)))
- (let ((x1 (rd1))
- (x2 (rd2)))
- (if (or (fneq x1 x2) (fneq x1 (* i .001)))
- (begin
- (set! happy #f)
- (snd-display #__line__ ";copy mix at ~A: ~A ~A ~A" i x1 x2 (* i .001))))))))))
- (close-sound snd))
-
- (if all-args
- (begin
- (let ((ind (make-waltz)))
- ;; mix.scm stuff...
- (close-sound ind))
-
- (let ((ind (make-bagatelle)))
- (close-sound ind))))
-
- )))
+ (list (lambda () (set! (samples 0 100) (make-float-vector 100 .2))) 1000 #f 'set0)
+ (list (lambda () (set! (samples 0 2000) (make-float-vector 2000 .2))) 1000 #t 'set0)
+ (list (lambda () (set! (samples 800 100) (make-float-vector 100 .2))) 1000 #f 'set800)
+ (list (lambda () (set! (samples 990 100) (make-float-vector 100 .2))) 1000 #t 'set990)
+ (list (lambda () (set! (samples 1010 100) (make-float-vector 100 .2))) 1000 #t 'set1010)
+ (list (lambda () (set! (samples 1050 10) (make-float-vector 100 .2))) 1000 #t 'set1050)
+ (list (lambda () (set! (samples 1110 100) (make-float-vector 100 .2))) 1000 #f 'set1110)
+ (list (lambda () (set! (samples 2000 100) (make-float-vector 100 .2))) 1000 #f 'set2000)
+
+ (list (lambda () (scale-channel 2.0 0 100)) 1000 #f 'scale0)
+ (list (lambda () (scale-channel 2.0 0 2000)) 1000 #t 'scale20)
+ (list (lambda () (scale-channel 2.0 800 100)) 1000 #f 'scale800)
+ (list (lambda () (scale-channel 2.0 850 100)) 1000 #f 'scale850)
+ (list (lambda () (scale-channel 2.0 950 40)) 1000 #f 'scale950)
+ (list (lambda () (scale-channel 2.0 990 100)) 1000 #t 'scale990)
+ (list (lambda () (scale-channel 2.0 1010 100)) 1000 #t 'scale1010)
+ (list (lambda () (scale-channel 2.0 1050 10)) 1000 #t 'scale1050)
+ (list (lambda () (scale-channel 2.0 1110 100)) 1000 #f 'scale1110)
+ (list (lambda () (scale-channel 2.0 2000 100)) 1000 #f 'scale2000)
+
+ (list (lambda () (env-channel '(0 0 1 1) 0 100)) 1000 #f 'env0)
+ (list (lambda () (env-channel '(0 0 1 1) 0 2000)) 1000 #t 'env20)
+ (list (lambda () (env-channel '(0 0 1 1) 800 100)) 1000 #f 'env800)
+ (list (lambda () (env-channel '(0 0 1 1) 850 100)) 1000 #f 'env850)
+ (list (lambda () (env-channel '(0 0 1 1) 950 40)) 1000 #f 'env950)
+ (list (lambda () (env-channel '(0 0 1 1) 990 100)) 1000 #t 'env990)
+ (list (lambda () (env-channel '(0 0 1 1) 1010 100)) 1000 #t 'env1010)
+ (list (lambda () (env-channel '(0 0 1 1) 1050 10)) 1000 #t 'env1050)
+ (list (lambda () (env-channel '(0 0 1 1) 1110 100)) 1000 #f 'env1110)
+ (list (lambda () (env-channel '(0 0 1 1) 2000 100)) 1000 #f 'env2000)
+
+ ))
+ (close-sound ind))
+
+ (let ((ind (open-sound "4.aiff"))
+ (selind (open-sound "oboe.snd")))
+ (make-selection 100 500 selind 0)
+ (mix-selection 500 ind 2)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";mix-selection 0->2 0: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 0)) (snd-display ";mix-selection 0->2 1: ~A" (edit-position ind 1)))
+ (if (not (= (edit-position ind 2) 1)) (snd-display ";mix-selection 0->2 2: ~A" (edit-position ind 2)))
+ (if (not (= (edit-position ind 3) 0)) (snd-display ";mix-selection 0->2 3: ~A" (edit-position ind 3)))
+ (revert-sound ind)
+ (set! (sync ind) 1234)
+ (mix-selection 500 ind 1)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";mix-selection 1->2 0: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 1)) (snd-display ";mix-selection 1->2 1: ~A" (edit-position ind 1)))
+ (if (not (= (edit-position ind 2) 0)) (snd-display ";mix-selection 1->2 2: ~A" (edit-position ind 2)))
+ (if (not (= (edit-position ind 3) 0)) (snd-display ";mix-selection 1->2 3: ~A" (edit-position ind 3)))
+ (revert-sound ind)
+ (set! (sync ind) 0)
+ (insert-selection 500 ind 2)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";insert-selection 0->2 0: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 0)) (snd-display ";insert-selection 0->2 1: ~A" (edit-position ind 1)))
+ (if (not (= (edit-position ind 2) 1)) (snd-display ";insert-selection 0->2 2: ~A" (edit-position ind 2)))
+ (if (not (= (edit-position ind 3) 0)) (snd-display ";insert-selection 0->2 3: ~A" (edit-position ind 3)))
+ (revert-sound ind)
+ (set! (sync ind) 1234)
+ (insert-selection 500 ind 1)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";insert-selection 1->2 0: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 1)) (snd-display ";insert-selection 1->2 1: ~A" (edit-position ind 1)))
+ (if (not (= (edit-position ind 2) 0)) (snd-display ";insert-selection 1->2 2: ~A" (edit-position ind 2)))
+ (if (not (= (edit-position ind 3) 0)) (snd-display ";insert-selection 1->2 3: ~A" (edit-position ind 3)))
+ (revert-sound ind)
+ (set! (sync ind) 0)
+ (close-sound ind)
+ (close-sound selind))
+
+
+ (let ((new-index (new-sound "hiho.wave" 1 22050 mus-ldouble mus-next)))
+ (log-mem test-ctr)
+ (select-sound new-index)
+ (if (find-mix 0 new-index 0) (snd-display ";found non-existent mix? ~A" (find-mix 0 new-index 0)))
+ (let ((mix-id (car (mix "pistol.snd" 100))))
+ (if (not (mix? mix-id)) (snd-display ";~A not mix?" mix-id))
+ (view-mixes-dialog)
+ (let ((snd (car (mix-home mix-id)))
+ (pos (mix-position mix-id))
+ (len (mix-length mix-id)))
+ (let ((mr (make-mix-sampler mix-id)))
+ (if (not (mix-sampler? mr)) (snd-display ";~A not mix-sampler?" mr))
+ (if (region-sampler? mr) (snd-display ";mix sampler: region ~A" mr))
+ ; (if (sampler? mr) (snd-display ";mix sampler: normal ~A" mr))
+ (if (not (= (sampler-position mr) 0)) (snd-display ";mix sampler position: ~A" (sampler-position mr)))
+ (if (sampler-at-end? mr) (snd-display ";mix sampler at end? ~A" mr))
+ (if (not (equal? (sampler-home mr) mix-id))
+ (snd-display ";~A home: ~A" mr (sampler-home mr)))
+ (let ((reader-string (format #f "~A" mr)))
+ (if (not (string=? (substring reader-string 0 16) "#<mix-sampler mi"))
+ (snd-display ";mix sampler actually got: [~S]" (substring reader-string 0 16))))
+ (do ((i 0 (+ i 1)))
+ ((= i 99))
+ (let ((mx (read-mix-sample mr))
+ (sx (sample (+ 100 i))))
+ (if (fneq mx sx) (snd-display ";read-mix-sample: ~A ~A?" mx sx))))
+ (let ((mx (mr))
+ (sx (sample 199)))
+ (if (fneq mx sx) (snd-display ";mix-sample 100: ~A ~A?" mx sx)))
+ (free-sampler mr))
+ (if (not (= pos 100)) (snd-display ";mix-position: ~A?" pos))
+ (if (not (= len 41623)) (snd-display ";mix-length: ~A?" len))
+ (if (not (equal? snd new-index)) (snd-display ";s mix-home: ~A?" snd)))
+ (let ((chn (cadr (mix-home mix-id))))
+ (if (not (= chn 0)) (snd-display ";c mix-home: ~A?" chn)))
+ (let ((amp (mix-amp mix-id)))
+ (if (fneq amp 1.0) (snd-display ";mix-amp: ~A?" amp)))
+ (let ((spd (mix-speed mix-id)))
+ (if (fneq spd 1.0) (snd-display ";mix-speed: ~A?" spd)))
+ (let ((nam (mix-name mix-id)))
+ (if (not (equal? nam "")) (snd-display ";mix-name: ~A" nam)))
+ (catch 'mus-error
+ (lambda () (play mix-id))
+ (lambda args (snd-display ";can't play mix: ~A" args)))
+ (catch 'mus-error
+ (lambda () (play mix-id 1000))
+ (lambda args (snd-display ";can't play mix from 1000: ~A" args)))
+ (set! (mix-name mix-id) "test-mix")
+ (if (not (and (string? (mix-name mix-id))
+ (string=? (mix-name mix-id) "test-mix")))
+ (snd-display ";mix-name set: ~A" (mix-name mix-id)))
+ (let ((id (mix-name->id "test-mix")))
+ (if (not (equal? id mix-id)) (snd-display ";mix-name->id: ~A ~A" id mix-id)))
+ (set! (mix-name mix-id) "test-mix-again") ; make sure previous name is freed
+ (if (not (and (string? (mix-name mix-id))
+ (string=? (mix-name mix-id) "test-mix-again")))
+ (snd-display ";mix-name set again: ~A" (mix-name mix-id)))
+ (set! (mix-name mix-id) "")
+ (if (not (equal? (mix-name mix-id) "")) (snd-display ";set mix-name #f: ~A" (mix-name mix-id)))
+ (set! (mix-position mix-id) 200)
+ (set! (mix-amp mix-id) 0.5)
+ (set! (mix-speed mix-id) 2.0)
+
+ (set! (mix-amp-env mix-id) '(0.0 0.0 1.0 1.0))
+ (set! (mix-tag-y mix-id) 20)
+ (let ((pos (mix-position mix-id)))
+ (if (not (= pos 200)) (snd-display ";set-mix-position: ~A?" pos)))
+ (let ((my (mix-tag-y mix-id)))
+ (if (not (= my 20)) (snd-display ";set-mix-tag-y: ~A?" my)))
+ (let ((amp (mix-amp mix-id)))
+ (if (fneq amp 0.5) (snd-display ";set-mix-amp: ~A?" amp)))
+ (let ((spd (mix-speed mix-id)))
+ (if (fneq spd 2.0) (snd-display ";set-mix-speed: ~A?" spd)))
+ (if (not (equal? (mix-amp-env mix-id) '(0.0 0.0 1.0 1.0))) (snd-display ";set-mix-amp-env: ~A?" (mix-amp-env mix-id))))
+
+ (mix-float-vector (make-float-vector 3 .1) 100)
+ (set! (cursor) 0)
+ (let ((nid (find-mix 100)))
+ (if (not (and (mix? nid)
+ (= (mix-position nid) 100)))
+ (snd-display ";find-mix(100): ~A ~A ~A?" nid (and (mix? nid) (mix-position nid)) (map mix-position (mixes new-index 0)))))
+ (let ((nid (find-mix 200)))
+ (if (not (and (mix? nid)
+ (= (mix-position nid) 200)))
+ (snd-display ";find-mix(200): ~A ~A?" nid (and (mix? nid) (mix-position nid)))))
+ (let ((mix-id (car (mix "oboe.snd" 100))))
+ (set! *mix-waveform-height* 40)
+ (set! (mix-property :hiho mix-id) 123)
+ (if (not (= (mix-property :hiho mix-id) 123)) (snd-display ";mix-property: ~A" (mix-property :hiho mix-id)))
+ (if (mix-property :not-there mix-id) (snd-display ";mix-not-property: ~A" (mix-property :not-there mix-id)))
+ (update-time-graph)
+ (set! *mix-waveform-height* 20))
+ (close-sound new-index))
+ )
+ (dismiss-all-dialogs)
+
+ ;; pan-mix tests
+ (let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "pan-mix tests")))
+
+ (let ((id0 (car (pan-mix "1a.snd" 10000 '(0 0 1 1)))))
+ (if (or (fneq (mix-amp id0) 1.0)
+ (not (feql (mix-amp-env id0) '(0 1 1 0))))
+ (snd-display ";pan-mix 1->1 2: ~A ~A" (mix-amp id0) (mix-amp-env id0)))
+ (if (not (= (mix-position id0) 10000)) (snd-display ";pan-mix 1->1 pos 2: ~A" (mix-position id0)))
+ (revert-sound ind))
+
+ (let* ((ids (pan-mix "2a.snd" 100 '(0 0 1 1)))
+ (id0 (car ids))
+ (id1 (cadr ids)))
+ (if (not (and (mix? id0) (mix? id1)))
+ (snd-display ";pan-mix 2->1: ~A ~A" id0 id1))
+ (if (not (= (mix-position id0) (mix-position id1) 100))
+ (snd-display ";pan-mix 2->1 pos: ~A ~A" (mix-position id0) (mix-position id1)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix 2->1 mix amps 3: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
+ (snd-display ";pan-mix 2->1 ramp env: ~A" (mix-amp-env id0)))
+ (revert-sound ind))
+ (close-sound ind))
+
+ (let ((ind (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "pan-mix tests")))
+ (let* ((ids (pan-mix "1a.snd" 100 '(0 0 1 1 2 0)))
+ (id0 (car ids))
+ (id1 (cadr ids)))
+ (if (not (and (mix? id0) (mix? id1)))
+ (snd-display ";pan-mix 1->2: ~A ~A" id0 id1))
+ (if (not (= (mix-position id0) (mix-position id1) 100))
+ (snd-display ";pan-mix 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0 2 1)))
+ (snd-display ";pan-mix 1->2 env 0: ~A" (mix-amp-env id0)))
+ (if (not (feql (mix-amp-env id1) '(0 0 1 1 2 0)))
+ (snd-display ";pan-mix 1->2 env 1: ~A" (mix-amp-env id1)))
+ (revert-sound ind))
+
+ (let* ((ids (pan-mix "2a.snd" 100 '(0 0 1 1 2 0)))
+ (id0 (car ids))
+ (id1 (cadr ids))
+ (id2 (caddr ids))
+ (id3 (cadddr ids)))
+
+ (if (not (and (mix? id0) (mix? id1) (mix? id2) (mix? id3)))
+ (snd-display ";pan-mix 2->2: ~A ~A ~A ~A" id0 id1 id2 id3))
+ (if (not (= (mix-position id0) (mix-position id1) (mix-position id2) (mix-position id3) 100))
+ (snd-display ";pan-mix 2->2 pos: ~A ~A ~A ~A" (mix-position id0) (mix-position id1) (mix-position id2) (mix-position id3)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix 2->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0 2 1)))
+ (snd-display ";pan-mix 2->2 env 0: ~A" (mix-amp-env id0)))
+ (if (not (feql (mix-amp-env id1) '(0 0 1 1 2 0)))
+ (snd-display ";pan-mix 2->2 env 1: ~A" (mix-amp-env id1)))
+ (if (not (feql (mix-amp-env id2) '(0 1 1 0 2 1)))
+ (snd-display ";pan-mix 2->2 env 2: ~A" (mix-amp-env id2)))
+ (if (not (feql (mix-amp-env id3) '(0 0 1 1 2 0)))
+ (snd-display ";pan-mix 2->2 env 3: ~A" (mix-amp-env id3)))
+ (revert-sound ind))
+ (close-sound ind))
+
+ (let ((ind (new-sound "test.snd" 2 22050 mus-ldouble mus-next "pan-mix-* tests" 1000)))
+ (let* ((ids (pan-mix-float-vector (make-float-vector 100 .3) 100 '(0 0 1 1)))
+ (id0 (car ids))
+ (id1 (cadr ids)))
+ (if (not (and (mix? id0) (mix? id1)))
+ (snd-display ";pan-mix-float-vector 1->2: ~A ~A" id0 id1))
+ (if (not (= (mix-position id0) (mix-position id1) 100))
+ (snd-display ";pan-mix-float-vector 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix-float-vector 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
+ (snd-display ";pan-mix-float-vector 1->2 env 0: ~A" (mix-amp-env id0)))
+ (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
+ (snd-display ";pan-mix-float-vector 1->2 env 1: ~A" (mix-amp-env id1)))
+ (revert-sound ind))
+
+ (let* ((reg (make-region 0 50 ind 0))
+ (ids (pan-mix-region reg 100 '(0 0 1 1)))
+ (id0 (car ids))
+ (id1 (cadr ids)))
+ (if (not (and (mix? id0) (mix? id1)))
+ (snd-display ";pan-mix-region 1->2: ~A ~A" id0 id1))
+ (if (not (= (mix-position id0) (mix-position id1) 100))
+ (snd-display ";pan-mix-region 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix-region 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
+ (snd-display ";pan-mix-region 1->2 env 0: ~A" (mix-amp-env id0)))
+ (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
+ (snd-display ";pan-mix-region 1->2 env 1: ~A" (mix-amp-env id1)))
+ (revert-sound ind))
+
+ (select-all)
+ (let* ((ids (pan-mix-selection 100 '(0 0 1 1)))
+ (id0 (car ids))
+ (id1 (cadr ids)))
+ (if (not (and (mix? id0) (mix? id1)))
+ (snd-display ";pan-mix-selection 1->2: ~A ~A" id0 id1))
+ (if (not (= (mix-position id0) (mix-position id1) 100))
+ (snd-display ";pan-mix-selection 1->2 pos: ~A ~A" (mix-position id0) (mix-position id1)))
+ (if (or (fneq (mix-amp id0) 1.0) (fneq (mix-amp id1) 1.0))
+ (snd-display ";pan-mix-selection 1->2 amps: ~A ~A" (mix-amp id0) (mix-amp id1)))
+ (if (not (feql (mix-amp-env id0) '(0 1 1 0)))
+ (snd-display ";pan-mix-selection 1->2 env 0: ~A" (mix-amp-env id0)))
+ (if (not (feql (mix-amp-env id1) '(0 0 1 1)))
+ (snd-display ";pan-mix-selection 1->2 env 1: ~A" (mix-amp-env id1)))
+ (revert-sound ind))
+ (close-sound ind))
+
+ ;; copy mix
+ (let* ((snd (new-sound "test.snd"))
+ (v (make-float-vector 1000)))
+ (do ((i 0 (+ i 1)))
+ ((= i 1000))
+ (set! (v i) (* i .001)))
+ (let* ((mx (mix-float-vector v 0 snd 0))
+ (mx-copy (copy mx)))
+ (if (not (= (length mx) (length mx-copy)))
+ (snd-display ";copy mix lengths: ~A ~A" (length mx) (length mx-copy)))
+ (if (not (= (mix-position mx) (mix-position mx-copy)))
+ (snd-display ";copy mix positions: ~A ~A" (mix-position mx) (mix-position mx-copy)))
+ (set! (mix-position mx-copy) 2000)
+ (let ((rd1 (make-sampler 0))
+ (rd2 (make-sampler 2000))
+ (happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy)
+ (= i 1000)))
+ (let ((x1 (rd1))
+ (x2 (rd2)))
+ (if (or (fneq x1 x2) (fneq x1 (* i .001)))
+ (begin
+ (set! happy #f)
+ (snd-display ";copy mix at ~A: ~A ~A ~A" i x1 x2 (* i .001))))))))
+ (close-sound snd))
+
+ (if all-args
+ (begin
+ (close-sound (make-waltz))
+ (close-sound (make-bagatelle))))
+ ))
;;; ---------------- test 10: marks ----------------
@@ -23916,14 +23428,14 @@ EDITS: 2
(all-chans))
maxval)
- (define (data-max2 beg end snd)
+ (define (data-max2 snd)
(set! maxval 0.0)
(do ((i 0 (+ i 1)))
((= i (chans snd)) maxval)
- (set! maxval (max maxval (float-vector-peak (samples beg (- end beg) snd i))))))
+ (set! maxval (max maxval (float-vector-peak (samples 0 9 snd i))))))
- (define (data-max1 beg dur snd chn)
- (float-vector-peak (samples beg dur snd chn)))
+ (define (data-max1 snd chn)
+ (float-vector-peak (samples 0 9 snd chn)))
;; from marks.scm (commented out)
@@ -23967,69 +23479,68 @@ EDITS: 2
(log-mem test-ctr)
(let ((ind0 (view-sound "oboe.snd"))
- (ind1 (view-sound "pistol.snd"))
- (v0 (make-float-vector 100))
- (vc (make-vector 10)))
- (fill! v0 .1)
- (set! (vc 0) (mix-float-vector v0 0 ind0))
- (set! (vc 1) (mix-float-vector v0 1000 ind0))
- (set! (vc 2) (mix-float-vector v0 2000 ind0))
- (set! (vc 3) (mix-float-vector v0 3000 ind0))
- (set! (vc 4) (mix-float-vector v0 4000 ind0))
- (set! (vc 5) (mix-float-vector v0 0 ind1))
- (set! (vc 6) (mix-float-vector v0 1000 ind1))
- (set! (vc 7) (mix-float-vector v0 2000 ind1))
- (set! (vc 8) (mix-float-vector v0 3000 ind1))
- (set! (vc 9) (mix-float-vector v0 4000 ind1))
+ (ind1 (view-sound "pistol.snd")))
+ (let ((v0 (make-float-vector 100)))
+ (fill! v0 .1)
+ (let ((vc (make-vector 10)))
+ (set! (vc 0) (mix-float-vector v0 0 ind0))
+ (set! (vc 1) (mix-float-vector v0 1000 ind0))
+ (set! (vc 2) (mix-float-vector v0 2000 ind0))
+ (set! (vc 3) (mix-float-vector v0 3000 ind0))
+ (set! (vc 4) (mix-float-vector v0 4000 ind0))
+ (set! (vc 5) (mix-float-vector v0 0 ind1))
+ (set! (vc 6) (mix-float-vector v0 1000 ind1))
+ (set! (vc 7) (mix-float-vector v0 2000 ind1))
+ (set! (vc 8) (mix-float-vector v0 3000 ind1))
+ (set! (vc 9) (mix-float-vector v0 4000 ind1))))
(close-sound ind0)
(close-sound ind1)
(set! ind0 (new-sound "fmv.snd" 1 22050 mus-bshort mus-aifc "this is a comment"))
- (let ((v0 (make-vector 10 1.0)))
- (insert-samples 0 10 v0 ind0)
- (time (env-sound '(0 0 1 1) 0 10 1.0 ind0))
- (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) (* i .1111)) (snd-display #__line__ ";1 env-sound[~D]: ~A?" i (sample i))))
- (undo)
- (env-sound (make-env '(0 0 1 1) :length 10) 0 10 1.0 ind0)
- (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) (* i .1111)) (snd-display #__line__ ";2 env-sound[~D]: ~A?" i (sample i))))
- (undo)
- (env-sound '(0 0 .5 1 1 1) 0 10 0.0 ind0)
- (if (or (fneq (sample 3) 0.0) (fneq (sample 8) 1.0) )
- (snd-display #__line__ ";env-sound stepped: ~A ~A?" (sample 3) (sample 8)))
- (undo)
- (env-sound '(0 0 1 1) 0 10 32.0 ind0)
- (if (or (fneq (sample 3) 0.070) (fneq (sample 8) 0.67) )
- (snd-display #__line__ ";env-sound exp: ~A ~A?" (sample 3) (sample 8)))
- (undo)
- (env-sound (make-env '(0 0 1 1) :base 32.0 :length 10) 0 10 32.0 ind0)
- (if (or (fneq (sample 3) 0.070) (fneq (sample 8) 0.67) )
- (snd-display #__line__ ";env-sound exp: ~A ~A?" (sample 3) (sample 8)))
- (undo)
- (env-sound '(0 2))
- (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) 2.0) (snd-display #__line__ ";3 env-sound[~D]: ~A?" i (sample i))))
- (undo)
- (env-sound '(0 2) 2 4 1.0 ind0)
- (if (or (fneq (sample 1) 1.0) (fneq (sample 2) 2.0) (fneq (sample 5) 2.0) (fneq (sample 8) 1.0))
- (snd-display #__line__ ";3 env-sound exp: ~A ~A ~A ~A?" (sample 1) (sample 2) (sample 5) (sample 8)))
- (undo)
- (do ((i 1 (+ i 1))) ((= i 10)) (set! (sample i) 0.0))
- (filter-sound '(0 1 1 0) 4)
- (if (or (fneq (sample 1) 0.3678) (fneq (sample 2) .3678) (fneq (sample 3) .132) (fneq (sample 4) 0.0))
- (snd-display #__line__ ";filter-sound env: ~A?" (samples 0 8)))
- (undo)
- (filter-sound '(0 1 1 0) 1024)
- (undo)
- (filter-sound (make-fir-filter 6 (float-vector .1 .2 .3 .3 .2 .1)))
- (undo)
- (filter-sound (make-delay 120))
- (undo)
- (filter-sound (make-formant 1200 .99))
- (undo)
- (let ((vc0 (make-float-vector 4)))
- (set! (vc0 0) .125) (set! (vc0 1) .25) (set! (vc0 2) .25) (set! (vc0 3) .125)
- (filter-sound vc0 4)
- (if (or (fneq (sample 0) 0.125) (fneq (sample 1) .25) (fneq (sample 2) .25) (fneq (sample 5) 0.0))
- (snd-display #__line__ ";filter-sound direct: ~A?" (samples 0 8)))
- (revert-sound)))
+ (insert-samples 0 10 (make-vector 10 1.0) ind0)
+ (time (env-sound '(0 0 1 1) 0 10 1.0 ind0))
+ (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) (* i .1111)) (snd-display ";1 env-sound[~D]: ~A?" i (sample i))))
+ (undo)
+ (env-sound (make-env '(0 0 1 1) :length 10) 0 10 1.0 ind0)
+ (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) (* i .1111)) (snd-display ";2 env-sound[~D]: ~A?" i (sample i))))
+ (undo)
+ (env-sound '(0 0 .5 1 1 1) 0 10 0.0 ind0)
+ (if (or (fneq (sample 3) 0.0) (fneq (sample 8) 1.0) )
+ (snd-display ";env-sound stepped: ~A ~A?" (sample 3) (sample 8)))
+ (undo)
+ (env-sound '(0 0 1 1) 0 10 32.0 ind0)
+ (if (or (fneq (sample 3) 0.070) (fneq (sample 8) 0.67) )
+ (snd-display ";env-sound exp: ~A ~A?" (sample 3) (sample 8)))
+ (undo)
+ (env-sound (make-env '(0 0 1 1) :base 32.0 :length 10) 0 10 32.0 ind0)
+ (if (or (fneq (sample 3) 0.070) (fneq (sample 8) 0.67) )
+ (snd-display ";env-sound exp: ~A ~A?" (sample 3) (sample 8)))
+ (undo)
+ (env-sound '(0 2))
+ (do ((i 0 (+ i 1))) ((= i 10)) (if (fneq (sample i) 2.0) (snd-display ";3 env-sound[~D]: ~A?" i (sample i))))
+ (undo)
+ (env-sound '(0 2) 2 4 1.0 ind0)
+ (if (or (fneq (sample 1) 1.0) (fneq (sample 2) 2.0) (fneq (sample 5) 2.0) (fneq (sample 8) 1.0))
+ (snd-display ";3 env-sound exp: ~A ~A ~A ~A?" (sample 1) (sample 2) (sample 5) (sample 8)))
+ (undo)
+ (do ((i 1 (+ i 1))) ((= i 10)) (set! (sample i) 0.0))
+ (filter-sound '(0 1 1 0) 4)
+ (if (or (fneq (sample 1) 0.3678) (fneq (sample 2) .3678) (fneq (sample 3) .132) (fneq (sample 4) 0.0))
+ (snd-display ";filter-sound env: ~A?" (samples 0 8)))
+ (undo)
+ (filter-sound '(0 1 1 0) 1024)
+ (undo)
+ (filter-sound (make-fir-filter 6 (float-vector .1 .2 .3 .3 .2 .1)))
+ (undo)
+ (filter-sound (make-delay 120))
+ (undo)
+ (filter-sound (make-formant 1200 .99))
+ (undo)
+ (let ((vc0 (make-float-vector 4)))
+ (set! (vc0 0) .125) (set! (vc0 1) .25) (set! (vc0 2) .25) (set! (vc0 3) .125)
+ (filter-sound vc0 4)
+ (if (or (fneq (sample 0) 0.125) (fneq (sample 1) .25) (fneq (sample 2) .25) (fneq (sample 5) 0.0))
+ (snd-display ";filter-sound direct: ~A?" (samples 0 8)))
+ (revert-sound))
(close-sound ind0)
(set! ind0 (new-sound "fmv.snd" 2 22050 mus-bshort mus-aifc "this is a comment"))
@@ -24043,24 +23554,24 @@ EDITS: 2
(env-sound '(0 0 1 1) 0 10 1.0 ind0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (sample i ind0 0) (* i .1111)) (snd-display #__line__ ";ind0:0 1 env-sound[~D]: ~A?" i (sample i ind0 0)))
- (if (fneq (sample i ind0 1) (* i .1111)) (snd-display #__line__ ";ind0:1 1 env-sound[~D]: ~A?" i (sample i ind0 1)))
- (if (fneq (sample i ind1 0) (* i .1111)) (snd-display #__line__ ";ind1:0 1 env-sound[~D]: ~A?" i (sample i ind1 0))))
+ (if (fneq (sample i ind0 0) (* i .1111)) (snd-display ";ind0:0 1 env-sound[~D]: ~A?" i (sample i ind0 0)))
+ (if (fneq (sample i ind0 1) (* i .1111)) (snd-display ";ind0:1 1 env-sound[~D]: ~A?" i (sample i ind0 1)))
+ (if (fneq (sample i ind1 0) (* i .1111)) (snd-display ";ind1:0 1 env-sound[~D]: ~A?" i (sample i ind1 0))))
(undo)
(env-sound (make-env '(0 0 1 1) :length 10) 0 10 1.0 ind0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (sample i ind0 0) (* i .1111)) (snd-display #__line__ ";ind0:0 2 env-sound[~D]: ~A?" i (sample i ind0 0)))
- (if (fneq (sample i ind0 1) (* i .1111)) (snd-display #__line__ ";ind0:1 2 env-sound[~D]: ~A?" i (sample i ind0 1)))
- (if (fneq (sample i ind1 0) (* i .1111)) (snd-display #__line__ ";ind1:0 2 env-sound[~D]: ~A?" i (sample i ind1 0))))
+ (if (fneq (sample i ind0 0) (* i .1111)) (snd-display ";ind0:0 2 env-sound[~D]: ~A?" i (sample i ind0 0)))
+ (if (fneq (sample i ind0 1) (* i .1111)) (snd-display ";ind0:1 2 env-sound[~D]: ~A?" i (sample i ind0 1)))
+ (if (fneq (sample i ind1 0) (* i .1111)) (snd-display ";ind1:0 2 env-sound[~D]: ~A?" i (sample i ind1 0))))
(undo)
(env-sound '(0 0 .5 1 1 1) 0 10 0.0 ind0)
(if (or (fneq (sample 3 ind0 0) 0.0) (fneq (sample 8 ind0 0) 1.0) )
- (snd-display #__line__ ";ind0:0 env-sound stepped: ~A ~A?" (sample 3 ind0 0) (sample 8 ind0 0)))
+ (snd-display ";ind0:0 env-sound stepped: ~A ~A?" (sample 3 ind0 0) (sample 8 ind0 0)))
(if (or (fneq (sample 3 ind0 1) 0.0) (fneq (sample 8 ind0 1) 1.0) )
- (snd-display #__line__ ";ind0:1 env-sound stepped: ~A ~A?" (sample 3 ind0 1) (sample 8 ind0 1)))
+ (snd-display ";ind0:1 env-sound stepped: ~A ~A?" (sample 3 ind0 1) (sample 8 ind0 1)))
(if (or (fneq (sample 3 ind1 0) 0.0) (fneq (sample 8 ind1 0) 1.0) )
- (snd-display #__line__ ";ind1:0 env-sound stepped: ~A ~A?" (sample 3 ind1 0) (sample 8 ind1 0)))
+ (snd-display ";ind1:0 env-sound stepped: ~A ~A?" (sample 3 ind1 0) (sample 8 ind1 0)))
(undo)
(revert-sound ind0)
(revert-sound ind1)
@@ -24070,30 +23581,30 @@ EDITS: 2
(filter-sound (make-one-zero :a0 0.5 :a1 0.0) 0 ind0)
(do ((i 0 (+ i 1)))
((= i 10))
- (if (fneq (sample i ind0 0) 0.5) (snd-display #__line__ ";ind0:0 1 filter-sound[~D]: ~A?" i (sample i ind0 0)))
- (if (fneq (sample i ind0 1) 0.5) (snd-display #__line__ ";ind0:1 1 filter-sound[~D]: ~A?" i (sample i ind0 1)))
- (if (fneq (sample i ind1 0) 0.5) (snd-display #__line__ ";ind1:0 1 filter-sound[~D]: ~A?" i (sample i ind1 0))))
+ (if (fneq (sample i ind0 0) 0.5) (snd-display ";ind0:0 1 filter-sound[~D]: ~A?" i (sample i ind0 0)))
+ (if (fneq (sample i ind0 1) 0.5) (snd-display ";ind0:1 1 filter-sound[~D]: ~A?" i (sample i ind0 1)))
+ (if (fneq (sample i ind1 0) 0.5) (snd-display ";ind1:0 1 filter-sound[~D]: ~A?" i (sample i ind1 0))))
(close-sound ind1))
(close-sound ind0)
(set! ind0 (new-sound "fmv.snd" 1 22050 mus-bshort mus-aifc "this is a comment"))
- (let ((v0 (make-float-vector 10))
- (old5 (sample 5 ind0)))
+ (let ((v0 (make-float-vector 10)))
(fill! v0 0.1)
- (insert-samples 10 10 v0 ind0)
- (env-sound '(0 0 1 2) 10 10 1.0 ind0)
- (do ((i 0 (+ i 1))) ((= i 10))
- (if (fneq (sample (+ i 10) ind0) (* i .0222)) (snd-display #__line__ ";env-sound [~D]: ~A?" (+ i 10) (sample (+ i 10) ind0))))
- (if (fneq (sample 5 ind0) old5) (snd-display #__line__ ";env-sound 5: ~A ~A?" old5 (sample 5 ind0)))
+ (let ((old5 (sample 5 ind0)))
+ (insert-samples 10 10 v0 ind0)
+ (env-sound '(0 0 1 2) 10 10 1.0 ind0)
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (if (fneq (sample (+ i 10) ind0) (* i .0222)) (snd-display ";env-sound [~D]: ~A?" (+ i 10) (sample (+ i 10) ind0))))
+ (if (fneq (sample 5 ind0) old5) (snd-display ";env-sound 5: ~A ~A?" old5 (sample 5 ind0))))
(undo)
(env-sound '(0 0 1 2) 10 10 4.0 ind0)
(set! v0 (channel->float-vector 10 10))
- (if (or (fneq (v0 3) 0.039) (fneq (v0 8) .162)) (snd-display #__line__ ";env-sound 4: ~A" v0))
+ (if (or (fneq (v0 3) 0.039) (fneq (v0 8) .162)) (snd-display ";env-sound 4: ~A" v0))
(undo)
(env-sound '(0 0 1 2) 10 10 .05 ind0)
(set! v0 (channel->float-vector 10 10))
- (if (or (fneq (v0 3) 0.133) (fneq (v0 8) .196)) (snd-display #__line__ ";env-sound 05: ~A" v0)))
+ (if (or (fneq (v0 3) 0.133) (fneq (v0 8) .196)) (snd-display ";env-sound 05: ~A" v0)))
(close-sound ind0)
(set! ind0 (new-sound "fmv.snd" 2 22050 mus-bshort mus-aifc "this is a comment"))
@@ -24104,18 +23615,18 @@ EDITS: 2
(insert-samples 0 10 v0 ind0 1)
(fill! v0 0.01)
(insert-samples 0 10 v0 ind1 0)
- (let ((val (data-max1 0 9 ind0 0)))
- (if (fneq val 1.0) (snd-display #__line__ ";scan-chan[0,0]: ~A?" val)))
- (let ((val (data-max1 0 9 ind0 1)))
- (if (fneq val 0.1) (snd-display #__line__ ";scan-chan[0,1]: ~A?" val)))
- (let ((val (data-max1 0 9 ind1 0)))
- (if (fneq val 0.01) (snd-display #__line__ ";scan-chan[1,0]: ~A?" val)))
- (let ((val (data-max1 0 9 #f #f)))
- (if (fneq val 0.01) (snd-display #__line__ ";scan-chans: ~A?" val)))
+ (let ((val (data-max1 ind0 0)))
+ (if (fneq val 1.0) (snd-display ";scan-chan[0,0]: ~A?" val)))
+ (let ((val (data-max1 ind0 1)))
+ (if (fneq val 0.1) (snd-display ";scan-chan[0,1]: ~A?" val)))
+ (let ((val (data-max1 ind1 0)))
+ (if (fneq val 0.01) (snd-display ";scan-chan[1,0]: ~A?" val)))
+ (let ((val (data-max1 #f #f)))
+ (if (fneq val 0.01) (snd-display ";scan-chans: ~A?" val)))
(let ((val (data-max 0 9)))
- (if (fneq val 1.0) (snd-display #__line__ ";scan-all-chans: ~A?" val)))
- (let ((val (data-max2 0 9 ind0)))
- (if (fneq val 1.0) (snd-display #__line__ ";scan-across-sound-chans: ~A?" val))))
+ (if (fneq val 1.0) (snd-display ";scan-all-chans: ~A?" val)))
+ (let ((val (data-max2 ind0)))
+ (if (fneq val 1.0) (snd-display ";scan-across-sound-chans: ~A?" val))))
(close-sound ind0)
(close-sound ind1)
@@ -24129,176 +23640,174 @@ EDITS: 2
(undo)
(save-sound)
(if (not (= (length (marks ind0 0)) 2))
- (snd-display #__line__ ";marks after save: ~A" (marks ind0 0)))
- (if (or (not (mark? m1))
- (not (= (mark-sample m1) 99)))
- (snd-display #__line__ ";save-sound mark1: ~A" (mark-sample m1)))
- (if (or (not (mark? m2))
- (not (= (mark-sample m2) 200)))
- (snd-display #__line__ ";save-sound mark2: ~A" (mark-sample m2)))
- (if (mark? m3) (snd-display #__line__ ";save-sound mark3: ~A" m3)))))
+ (snd-display ";marks after save: ~A" (marks ind0 0)))
+ (if (not (and (mark? m1)
+ (= (mark-sample m1) 99)))
+ (snd-display ";save-sound mark1: ~A" (mark-sample m1)))
+ (if (not (and (mark? m2)
+ (= (mark-sample m2) 200)))
+ (snd-display ";save-sound mark2: ~A" (mark-sample m2)))
+ (if (mark? m3) (snd-display ";save-sound mark3: ~A" m3)))))
(close-sound ind0)
(let ((fd (open-sound "oboe.snd"))
(m1 (add-mark 123))
(sync-val (+ 1 (mark-sync-max))))
- (if (not (mark? m1)) (snd-display #__line__ ";mark?"))
- (if (not (= (mark-sample m1) 123)) (snd-display #__line__ ";add-mark: ~A? " (mark-sample m1)))
+ (if (not (mark? m1)) (snd-display ";mark?"))
+ (if (not (= (mark-sample m1) 123)) (snd-display ";add-mark: ~A? " (mark-sample m1)))
(set! (mark-property :hiho m1) 123)
- (if (not (= (mark-property :hiho m1) 123)) (snd-display #__line__ ";mark-property: ~A" (mark-property :hiho m1)))
- (if (mark-property :not-there m1) (snd-display #__line__ ";mark-not-property: ~A" (mark-property :not-there m1)))
+ (if (not (= (mark-property :hiho m1) 123)) (snd-display ";mark-property: ~A" (mark-property :hiho m1)))
+ (if (mark-property :not-there m1) (snd-display ";mark-not-property: ~A" (mark-property :not-there m1)))
(if (not (eq? (without-errors (mark-sample (integer->mark 12345678))) 'no-such-mark))
- (snd-display #__line__ ";mark-sample err: ~A?" (without-errors (mark-sample 12345678))))
+ (snd-display ";mark-sample err: ~A?" (without-errors (mark-sample 12345678))))
(if (not (eq? (without-errors (add-mark 123 123)) 'no-such-sound))
- (snd-display #__line__ ";add-mark err: ~A?" (without-errors (add-mark 123 123))))
+ (snd-display ";add-mark err: ~A?" (without-errors (add-mark 123 123))))
(let ((m2 (without-errors (add-mark 12345 fd 0))))
- (if (eq? m2 'no-such-mark) (snd-display #__line__ ";add-mark failed?"))
- (if (not (= (mark-sample m2) 12345)) (snd-display #__line__ ";add-mark 0 0: ~A?" (mark-sample m2)))
- (if (not (= (mark-sync m2) 0)) (snd-display #__line__ ";init mark-sync: ~A?" (mark-sync m2)))
+ (if (eq? m2 'no-such-mark) (snd-display ";add-mark failed?"))
+ (if (not (= (mark-sample m2) 12345)) (snd-display ";add-mark 0 0: ~A?" (mark-sample m2)))
+ (if (not (= (mark-sync m2) 0)) (snd-display ";init mark-sync: ~A?" (mark-sync m2)))
(set! (mark-sync m2) sync-val)
- (if (not (= (mark-sync m2) sync-val)) (snd-display #__line__ ";set-mark-sync (~A): ~A?" sync-val (mark-sync m2)))
+ (if (not (= (mark-sync m2) sync-val)) (snd-display ";set-mark-sync (~A): ~A?" sync-val (mark-sync m2)))
(let* ((syncs (syncd-marks sync-val))
(chans (marks fd 0))
(samps (map mark-sample chans)))
- (if (not (equal? syncs (list m2))) (snd-display #__line__ ";syncd-marks: ~A?" syncs))
- (if (not (equal? chans (list m1 m2))) (snd-display #__line__ ";marks: ~A?" chans))
- (if (not (equal? samps (list (mark-sample m1) (mark-sample m2)))) (snd-display #__line__ ";map samps: ~A?" samps))
+ (if (not (equal? syncs (list m2))) (snd-display ";syncd-marks: ~A?" syncs))
+ (if (not (equal? chans (list m1 m2))) (snd-display ";marks: ~A?" chans))
+ (if (not (equal? samps (list (mark-sample m1) (mark-sample m2)))) (snd-display ";map samps: ~A?" samps))
(delete-samples 200 100 fd 0)
(set! chans (marks fd))
(set! samps (map mark-sample (car chans)))
- (if (not (equal? samps (list (mark-sample m1 0) (- (mark-sample m2 0) 100)))) (snd-display #__line__ ";map samps: ~A?" samps))
+ (if (not (equal? samps (list (mark-sample m1 0) (- (mark-sample m2 0) 100)))) (snd-display ";map samps: ~A?" samps))
(let ((descr (describe-mark m2)))
(if (not (list? descr))
- (snd-display #__line__ ";describe-mark: ~A?" descr)))
+ (snd-display ";describe-mark: ~A?" descr)))
(set! (mark-sync m1) (mark-sync m2))
(move-syncd-marks sync-val 100)
(set! chans (marks fd))
(set! samps (map mark-sample (car chans)))
- (if (not (equal? samps (list (+ (mark-sample m1 0) 100) (mark-sample m2 0)))) (snd-display #__line__ ";syncd move samps: ~A?" samps))
+ (if (not (equal? samps (list (+ (mark-sample m1 0) 100) (mark-sample m2 0)))) (snd-display ";syncd move samps: ~A?" samps))
(set! (cursor) 500)
(set! (mark-sync m1) #t)
- (if (not (= (mark-sync m1) 1)) (snd-display #__line__ ";mark-sync via bool: ~A" (mark-sync m1)))
+ (if (not (= (mark-sync m1) 1)) (snd-display ";mark-sync via bool: ~A" (mark-sync m1)))
(delete-mark m1)
(set! chans (marks fd 0))
- (if (not (equal? chans (list m2))) (snd-display #__line__ ";delete-mark? ~A" chans))
+ (if (not (equal? chans (list m2))) (snd-display ";delete-mark? ~A" chans))
(undo)
(set! chans (marks fd 0))
- (if (not (equal? chans (list m1 m2))) (snd-display #__line__ ";delete-mark then undo? ~A" chans))
+ (if (not (equal? chans (list m1 m2))) (snd-display ";delete-mark then undo? ~A" chans))
(redo)
- (if (not (string=? (mark-name m2) "")) (snd-display #__line__ ";init mark-name: ~A?" (mark-name m2)))
+ (if (not (string=? (mark-name m2) "")) (snd-display ";init mark-name: ~A?" (mark-name m2)))
(set! (mark-name m2) "hiho!")
- (if (not (string=? (mark-name m2) "hiho!")) (snd-display #__line__ ";set-mark-name: ~A?" (mark-name m2)))
+ (if (not (string=? (mark-name m2) "hiho!")) (snd-display ";set-mark-name: ~A?" (mark-name m2)))
(undo)
- (if (not (string=? (mark-name m2) "")) (snd-display #__line__ ";undo mark-name: ~A?" (mark-name m2)))
+ (if (not (string=? (mark-name m2) "")) (snd-display ";undo mark-name: ~A?" (mark-name m2)))
(redo)
- (if (not (string=? (mark-name m2) "hiho!")) (snd-display #__line__ ";redo mark-name: ~A?" (mark-name m2)))
+ (if (not (string=? (mark-name m2) "hiho!")) (snd-display ";redo mark-name: ~A?" (mark-name m2)))
+
(let ((m3 (find-mark "hiho!"))
- (m4 (find-mark (mark-sample m2)))
- (m5 (find-mark "not-a-mark"))
- (m6 (find-mark 123456787))
- (m7 (mark-name->id "hiho!")))
- (if (or (not (equal? m2 m3)) (not (equal? m4 m7)) (not (equal? m2 m4))) (snd-display #__line__ ";find-mark: ~A ~A ~A ~A?" m2 m3 m4 m7))
- (if (or (not (equal? m5 m6)) m5) (snd-display #__line__ ";find-not-a-mark: ~A ~A?" m5 m6))
+ (m4 (find-mark (mark-sample m2))))
+ (let ((m5 (find-mark "not-a-mark"))
+ (m6 (find-mark 123456787)))
+ (let ((m7 (mark-name->id "hiho!")))
+ (if (not (and (equal? m2 m3) (equal? m4 m7) (equal? m2 m4))) (snd-display ";find-mark: ~A ~A ~A ~A?" m2 m3 m4 m7)))
+ (if (or (not (equal? m5 m6)) m5) (snd-display ";find-not-a-mark: ~A ~A?" m5 m6)))
(set! (mark-sample m2) 2000)
(set! m1 (add-mark 1000))
(set! m3 (add-mark 3000))
(set! m4 (add-mark 4000))
(insert-samples 2500 500 (make-float-vector 500) fd 0)
(set! samps (map mark-sample (marks fd 0)))
- (if (not (equal? samps '(1000 2000 3500 4500))) (snd-display #__line__ ";insert ripple: ~A?" samps))
+ (if (not (equal? samps '(1000 2000 3500 4500))) (snd-display ";insert ripple: ~A?" samps))
(set! (mark-sample m3) 300)
(set! (cursor) 500)
(let ((sd (open-sound "4.aiff")))
(set! m3 (add-mark 1000 sd 2))
(set! m4 (add-mark 1000 sd 3))
- (if (not (equal? (mark-home m3) (list sd 2))) (snd-display #__line__ ";marks->sound 4: ~A?" (mark-home m3)))
- (close-sound sd))
- (let ((file (save-marks fd)))
- (if (or (not file)
- (not (string=? file (string-append cwd "oboe.marks"))))
- (snd-display #__line__ ";save-marks -> ~A?" file)))
- (let ((file (save-marks fd "hiho.marks")))
- (if (or (not file)
- (not (string=? file "hiho.marks")))
- (snd-display #__line__ ";save-marks with arg -> ~A?" file))
- (let ((val (system (format #f "diff hiho.marks ~A" (string-append cwd "oboe.marks")))))
- (if (not (= val 0))
- (snd-display #__line__ ";save marks differs"))))
+ (if (not (equal? (mark-home m3) (list sd 2))) (snd-display ";marks->sound 4: ~A?" (mark-home m3)))
+ (close-sound sd)))
+
+ (let ((file (save-marks fd)))
+ (if (not (equal? file (string-append cwd "oboe.marks")))
+ (snd-display ";save-marks -> ~A?" file)))
+ (let ((file (save-marks fd "hiho.marks")))
+ (if (not (equal? file "hiho.marks"))
+ (snd-display ";save-marks with arg -> ~A?" file))
+ (if (not (zero? (system (format #f "diff hiho.marks \"~Aoboe.marks\"" cwd))))
+ (snd-display ";save marks differs")))
+ (close-sound fd)
+ (let ((s1 (open-sound "oboe.snd"))
+ (s2 (open-sound "oboe.snd")))
+ (add-mark 123 s1 0)
+ (add-mark 321 s2 0)
+ (set! *with-verbose-cursor* #t)
+ (if (file-exists? "s61.scm") (delete-file "s61.scm"))
+ (save-state "s61.scm")
+ (set! *with-verbose-cursor* #f)
+ (close-sound s1)
+ (close-sound s2))
+ (load (string-append cwd "s61.scm"))
+ (if (not *with-verbose-cursor*) (snd-display ";save-state with-verbose-cursor?"))
+ (let ((s1 (find-sound "oboe.snd" 0))
+ (s2 (find-sound "oboe.snd" 1)))
+ (if (not (and (sound? s1) (sound? s2)))
+ (snd-display ";can't re-open sounds? ~A ~A" s1 s2)
+ (let ((m1 (marks s1))
+ (m2 (marks s2)))
+ (if (not (and (pair? m1) (null? (cdr m1))
+ (pair? m2) (null? (cdr m2))
+ (pair? (car m1)) (null? (cdar m1))
+ (pair? (car m2)) (null? (cdar m2))))
+ (snd-display ";save-marks via save-state to: ~A ~A" m1 m2)
+ (let ((samp1 (mark-sample (caar m1)))
+ (samp2 (mark-sample (caar m2))))
+ (if (not (and (= samp1 123)
+ (= samp2 321)))
+ (snd-display ";save-marks via save-state positions: ~A ~A" samp1 samp2))))))
+ (if (sound? s1) (close-sound s1))
+ (if (sound? s2) (close-sound s2)))
+ (let ((fd (open-sound "pistol.snd")))
+ (let ((file (save-marks)))
+ (if file
+ (snd-display ";save-marks no marks -> ~A?" file)))
+ (close-sound fd))
+ (let ((fd (open-sound "oboe.snd")))
+ (load (string-append cwd "oboe.marks"))
+ (let ((mlst (marks fd 0)))
+ (if (not (= (length mlst) 4))
+ (snd-display ";restore oboe.marks: ~A, marks: ~A" (file->string "oboe.marks") (marks fd 0))))
+ (close-sound fd))
+ (let ((fd (open-sound "oboe.snd")))
+ (add-mark 1000)
+ (add-mark 2500)
+ (add-mark (- (framples) 4000))
+ (let ((ms (marks fd 0)))
+ (src-sound -.5)
+ (if (not (equal? (marks fd 0) (reverse (marks fd 0 0))))
+ (snd-display ";src rev marks: ~A ~A ~A" ms (marks fd 0) (reverse (marks fd 0 0))))
+ (let ((ms1 (map mark-sample (marks fd 0))))
+ (if (not (equal? ms1 (list 7998 96654 99654))) ; off-by-1 somewhere...
+ (snd-display ";src rev mark locs: ~A" ms1))))
+ (close-sound fd))
+ (let ((fd (open-sound "4.aiff")))
+ (add-mark 1000 fd 0)
+ (add-mark 2000 fd 1)
+ (add-mark 3000 fd 2)
+ (add-mark 4000 fd 3)
+ (if (null? (marks)) (snd-display ";marks (no args): ~A" (marks)))
+ (save-marks fd)
(close-sound fd)
- (let ((s1 (open-sound "oboe.snd"))
- (s2 (open-sound "oboe.snd")))
- (add-mark 123 s1 0)
- (add-mark 321 s2 0)
- (set! *with-verbose-cursor* #t)
- (if (file-exists? "s61.scm") (delete-file "s61.scm"))
- (save-state "s61.scm")
- (set! *with-verbose-cursor* #f)
- (close-sound s1)
- (close-sound s2))
- (load (string-append cwd "s61.scm"))
- (if (not *with-verbose-cursor*) (snd-display #__line__ ";save-state with-verbose-cursor?"))
- (let ((s1 (find-sound "oboe.snd" 0))
- (s2 (find-sound "oboe.snd" 1)))
- (if (or (not (sound? s1)) (not (sound? s2)))
- (snd-display #__line__ ";can't re-open sounds? ~A ~A" s1 s2)
- (let ((m1 (marks s1))
- (m2 (marks s2)))
- (if (or (not (= (length m1) 1))
- (not (= (length m2) 1))
- (not (= (length (car m1)) 1))
- (not (= (length (car m2)) 1)))
- (snd-display #__line__ ";save-marks via save-state to: ~A ~A" m1 m2)
- (let ((samp1 (mark-sample (caar m1)))
- (samp2 (mark-sample (caar m2))))
- (if (or (not (= samp1 123))
- (not (= samp2 321)))
- (snd-display #__line__ ";save-marks via save-state positions: ~A ~A" samp1 samp2))))))
- (if (sound? s1) (close-sound s1))
- (if (sound? s2) (close-sound s2)))
- (let ((fd (open-sound "pistol.snd")))
- (let ((file (save-marks)))
- (if file
- (snd-display #__line__ ";save-marks no marks -> ~A?" file)))
- (close-sound fd))
- (let ((fd (open-sound "oboe.snd")))
- (load (string-append cwd "oboe.marks"))
- (let ((mlst (marks fd 0)))
- (if (not (= (length mlst) 4))
- (snd-display #__line__ ";restore oboe.marks: ~A, marks: ~A" (file->string "oboe.marks") (marks fd 0))))
- (close-sound fd))
- (let ((fd (open-sound "oboe.snd")))
- (add-mark 1000)
- (add-mark 2500)
- (add-mark (- (framples) 4000))
- (let ((ms (marks fd 0)))
- (src-sound -.5)
- (if (not (equal? (marks fd 0) (reverse (marks fd 0 0))))
- (snd-display #__line__ ";src rev marks: ~A ~A ~A" ms (marks fd 0) (reverse (marks fd 0 0))))
- (let ((ms1 (map mark-sample (marks fd 0))))
- (if (not (equal? ms1 (list 7998 96654 99654))) ; off-by-1 somewhere...
- (snd-display #__line__ ";src rev mark locs: ~A" ms1))))
- (close-sound fd))
- (let ((fd (open-sound "4.aiff")))
- (add-mark 1000 fd 0)
- (add-mark 2000 fd 1)
- (add-mark 3000 fd 2)
- (add-mark 4000 fd 3)
- (if (= (length (marks)) 0) (snd-display #__line__ ";marks (no args): ~A" (marks)))
- (save-marks fd)
- (close-sound fd)
- (set! fd (open-sound "4.aiff"))
- (load (string-append cwd "4.marks"))
- (delete-file "4.marks")
- (do ((i 0 (+ i 1)))
- ((= i 4))
- (let ((mlst (marks fd i)))
- (if (not (= (length mlst) 1))
- (snd-display #__line__ ";save-marks[~A]: ~A?" i mlst))
- (if (not (= (mark-sample (car mlst)) (* (+ i 1) 1000)))
- (snd-display #__line__ ";save-marks[~A] at ~A?" i (mark-sample (car mlst))))))
- (close-sound fd))
-
- ))))
+ (set! fd (open-sound "4.aiff"))
+ (load (string-append cwd "4.marks"))
+ (delete-file "4.marks")
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (let ((mlst (marks fd i)))
+ (if (not (= (length mlst) 1))
+ (snd-display ";save-marks[~A]: ~A?" i mlst))
+ (if (not (= (mark-sample (car mlst)) (* (+ i 1) 1000)))
+ (snd-display ";save-marks[~A] at ~A?" i (mark-sample (car mlst))))))
+ (close-sound fd))
+ )))
(let ((fd (open-sound "oboe.snd"))
(m1 (add-mark 1234)))
@@ -24306,14 +23815,14 @@ EDITS: 2
(set! (mark-sync m1) 1234)
(let ((m2 (copy m1)))
(if (not (mark? m2))
- (snd-display #__line__ "; copy mark: ~A?" m2)
+ (snd-display "; copy mark: ~A?" m2)
(begin
(if (not (= (mark-sample m1) (mark-sample m2) 1234))
- (snd-display #__line__ ";copy mark sample: ~A ~A" (mark-sample m1) (mark-sample m2)))
+ (snd-display ";copy mark sample: ~A ~A" (mark-sample m1) (mark-sample m2)))
(if (not (= (mark-sync m1) (mark-sync m2) 1234))
- (snd-display #__line__ ";copy mark sync: ~A ~A" (mark-sync m1) (mark-sync m2)))
+ (snd-display ";copy mark sync: ~A ~A" (mark-sync m1) (mark-sync m2)))
(if (not (string=? (mark-name m2) "1234"))
- (snd-display #__line__ ";copy mark name: ~A?" (mark-name m2))))))
+ (snd-display ";copy mark name: ~A?" (mark-name m2))))))
(close-sound fd))
(let* ((ind (open-sound "pistol.snd"))
@@ -24323,94 +23832,94 @@ EDITS: 2
(m2 (add-mark samp2)))
(set! (mark-sync m1) 123)
(set! (mark-sync m2) 100)
- (if (not (= (mark-sync-max) 1234)) (snd-display #__line__ ";mark-sync-max: ~A" (mark-sync-max)))
+ (if (not (= (mark-sync-max) 1234)) (snd-display ";mark-sync-max: ~A" (mark-sync-max)))
(src-sound -1)
(if (not (= (mark-sample m1) 39788))
- (snd-display #__line__ ";src -1 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src -1 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) 33277))
- (snd-display #__line__ ";src -1 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src -1 m2 -> ~A" (mark-sample m2)))
(undo)
(src-sound .5)
(if (not (= (mark-sample m1) (* 2 samp1)))
- (snd-display #__line__ ";src .5 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src .5 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) (* 2 samp2)))
- (snd-display #__line__ ";src .5 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src .5 m2 -> ~A" (mark-sample m2)))
(undo)
(delete-samples 1000 100)
(if (not (= (mark-sample m1) (- samp1 100)))
- (snd-display #__line__ ";delete 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";delete 100 m1 -> ~A" (mark-sample m1)))
(insert-silence 1000 100)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";insert 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";insert 100 m1 -> ~A" (mark-sample m1)))
(revert-sound ind)
(delete-samples 2000 100)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";delete(2) 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";delete(2) 100 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) (- samp2 100)))
- (snd-display #__line__ ";delete(2) 100 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";delete(2) 100 m2 -> ~A" (mark-sample m2)))
(insert-silence 2000 100)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";insert(2) 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";insert(2) 100 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) samp2))
- (snd-display #__line__ ";insert(2) 100 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";insert(2) 100 m2 -> ~A" (mark-sample m2)))
(revert-sound ind)
(delete-samples 10000 100)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";delete(3) 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";delete(3) 100 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) samp2))
- (snd-display #__line__ ";delete(3) 100 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";delete(3) 100 m2 -> ~A" (mark-sample m2)))
(insert-silence 10000 100)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";insert(3) 100 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";insert(3) 100 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) samp2))
- (snd-display #__line__ ";insert(3) 100 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";insert(3) 100 m2 -> ~A" (mark-sample m2)))
(src-sound '(0 .5 1 .5 2 1))
(if (not (= (mark-sample m1) (* 2 samp1)))
- (snd-display #__line__ ";src env .5 m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src env .5 m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) (* 2 samp2)))
- (snd-display #__line__ ";src env .5 m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src env .5 m2 -> ~A" (mark-sample m2)))
(undo)
(reverse-sound)
(if (not (= (mark-sample m1) 39788))
- (snd-display #__line__ ";reverse-sound m1 -> ~A" (mark-sample m1)))
+ (snd-display ";reverse-sound m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) 33277))
- (snd-display #__line__ ";reverse-sound m2 -> ~A" (mark-sample m2)))
+ (snd-display ";reverse-sound m2 -> ~A" (mark-sample m2)))
(undo)
(src-sound '(0 -.5 1 -.5 2 -1))
(if (not (= (mark-sample m1) 68598))
- (snd-display #__line__ ";src -env m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src -env m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) 61160))
- (snd-display #__line__ ";src -env m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src -env m2 -> ~A" (mark-sample m2)))
(revert-sound ind)
(src-channel (make-env '(0 .5 1 1) :length 8001) 2000 10000)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";src-channel(1) m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src-channel(1) m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) 11345))
- (snd-display #__line__ ";src-channel(1) m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src-channel(1) m2 -> ~A" (mark-sample m2)))
(undo)
(src-channel (make-env '(0 .5 1 1) :length 8001) 0 8000)
(if (not (= (mark-sample m1) 3303))
- (snd-display #__line__ ";src-channel(2) m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src-channel(2) m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) samp2))
- (snd-display #__line__ ";src-channel(2) m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src-channel(2) m2 -> ~A" (mark-sample m2)))
(undo)
(src-channel (make-env '(0 .5 1 1) :length 8001) 10000 8000)
(if (not (= (mark-sample m1) samp1))
- (snd-display #__line__ ";src-channel(3) m1 -> ~A" (mark-sample m1)))
+ (snd-display ";src-channel(3) m1 -> ~A" (mark-sample m1)))
(if (not (= (mark-sample m2) samp2))
- (snd-display #__line__ ";src-channel(3) m2 -> ~A" (mark-sample m2)))
+ (snd-display ";src-channel(3) m2 -> ~A" (mark-sample m2)))
(close-sound ind)
(set! ind (open-sound "2.snd"))
(set! (sync ind) #t)
(let ((m3 (add-mark 1000 ind 0))
(m4 (add-mark 8000 ind 1)))
(swap-channels)
- (if (or (not (equal? (mark-home m3) (list ind 1)))
- (not (equal? (mark-home m4) (list ind 0))))
- (snd-display #__line__ ";swapped mark homes: ~A ~A?" (mark-home m3) (mark-home m4)))
- (if (or (not (= (mark-sample m3) 1000))
- (not (= (mark-sample m4) 8000)))
- (snd-display #__line__ ";swapped mark samples: ~A ~A?" (mark-sample m3) (mark-sample m4)))
+ (if (not (and (equal? (mark-home m3) (list ind 1))
+ (equal? (mark-home m4) (list ind 0))))
+ (snd-display ";swapped mark homes: ~A ~A?" (mark-home m3) (mark-home m4)))
+ (if (not (and (= (mark-sample m3) 1000)
+ (= (mark-sample m4) 8000)))
+ (snd-display ";swapped mark samples: ~A ~A?" (mark-sample m3) (mark-sample m4)))
(close-sound ind))
(set! ind (open-sound "2.snd"))
(set! (sync ind) #t)
@@ -24418,48 +23927,47 @@ EDITS: 2
(delete-samples 1000 10 ind 1)
(swap-channels)
(if (not (equal? (mark-home m3) (list ind 1)))
- (snd-display #__line__ ";edited swapped mark home: ~A?" (mark-home m3)))
+ (snd-display ";edited swapped mark home: ~A?" (mark-home m3)))
(if (not (= (mark-sample m3) 1000))
- (snd-display #__line__ ";edited swapped mark sample: ~A" (mark-sample m3)))
+ (snd-display ";edited swapped mark sample: ~A" (mark-sample m3)))
(delete-marks))
(close-sound ind))
(let* ((ind (open-sound "oboe.snd"))
(m1 (add-mark 123 ind 0))
- (m2 (add-mark 234 ind 0))
- (sel #f))
+ (m2 (add-mark 234 ind 0)))
(define-selection-via-marks m1 m2)
- (set! sel (selection))
- (if (or (not (selection?))
- (not (selection? sel)))
- (snd-display #__line__ ";define-selection-via-marks failed?")
- (let ((mc (selection-members)))
- (if (not (equal? mc (list (list ind 0)))) (snd-display #__line__ ";selection-members after mark definition: ~A (should be '((~A 0)))" mc ind))
- (if (not (= (selection-position) 123)) (snd-display #__line__ ";selection-position 123: ~A" (selection-position)))
- (if (not (= (selection-framples) 112)) (snd-display #__line__ ";selection-framples 112: ~A" (selection-framples)))))
+ (let ((sel (selection)))
+ (if (not (and (selection?)
+ (selection? sel)))
+ (snd-display ";define-selection-via-marks failed?")
+ (let ((mc (selection-members)))
+ (if (not (equal? mc (list (list ind 0)))) (snd-display ";selection-members after mark definition: ~A (should be '((~A 0)))" mc ind))
+ (if (not (= (selection-position) 123)) (snd-display ";selection-position 123: ~A" (selection-position)))
+ (if (not (= (selection-framples) 112)) (snd-display ";selection-framples 112: ~A" (selection-framples))))))
(set! m1 (add-mark 1000 ind 0))
(set! m2 (add-mark 2000 ind 0))
(define-selection-via-marks m1 m2)
(if (not (selection?))
- (snd-display #__line__ ";define-selection-via-marks repeat failed?")
+ (snd-display ";define-selection-via-marks repeat failed?")
(let ((mc (selection-members)))
- (if (not (equal? mc (list (list ind 0)))) (snd-display #__line__ ";selection-members after second mark definition: ~A (should be '((~A 0)))" mc ind))
- (if (not (= (selection-position) 1000)) (snd-display #__line__ ";selection-position 1000: ~A" (selection-position)))
- (if (not (= (selection-framples) 1001)) (snd-display #__line__ ";selection-framples 1001: ~A" (selection-framples)))))
+ (if (not (equal? mc (list (list ind 0)))) (snd-display ";selection-members after second mark definition: ~A (should be '((~A 0)))" mc ind))
+ (if (not (= (selection-position) 1000)) (snd-display ";selection-position 1000: ~A" (selection-position)))
+ (if (not (= (selection-framples) 1001)) (snd-display ";selection-framples 1001: ~A" (selection-framples)))))
(set! (selection-member? #t) #f)
- (if (selection?) (snd-display #__line__ ";can't clear selection via selection-member?"))
- (if (selection) (snd-display #__line__ ";(inactive) selection returns: ~A" (selection)))
+ (if (selection?) (snd-display ";can't clear selection via selection-member?"))
+ (if (selection) (snd-display ";(inactive) selection returns: ~A" (selection)))
(set! (selection-member? ind 0) #t)
(set! (selection-position ind 0) 2000)
(set! (selection-framples ind 0) 1234)
(snap-marks)
(set! m1 (find-mark 2000 ind 0))
- (if (not (mark? m1)) (snd-display #__line__ ";snap-marks start: ~A" (map mark-sample (marks ind 0))))
- (set! m2 (find-mark (+ 2000 1234)))
- (if (not (mark? m2)) (snd-display #__line__ ";snap-marks end: ~A" (map mark-sample (marks ind 0))))
+ (if (not (mark? m1)) (snd-display ";snap-marks start: ~A" (map mark-sample (marks ind 0))))
+ (set! m2 (find-mark 3234))
+ (if (not (mark? m2)) (snd-display ";snap-marks end: ~A" (map mark-sample (marks ind 0))))
(set! (selection-position ind 0) (+ (framples ind 0) 1123))
(if (not (= (selection-position ind 0) (- (framples ind) 1)))
- (snd-display #__line__ ";selection position past eof: ~A ~A" (selection-position ind 0) (- (framples ind) 1)))
+ (snd-display ";selection position past eof: ~A ~A" (selection-position ind 0) (- (framples ind) 1)))
(revert-sound ind)
(src-sound '(0 .5 1 1.75665))
;; trying to hit previous dur on the nose "by accident..."
@@ -24484,8 +23992,8 @@ EDITS: 2
(if (pair? current-marks)
(let ((id (current-marks (random (- (length current-marks) 1)))))
(if (not (equal? id (find-mark (mark-sample id))))
- (snd-display #__line__ ";~A: two marks at ~A? ~A" i (mark-sample id) (map mark-sample current-marks)))
- (if (find-mark "not-a-name") (snd-display #__line__ ";find-bogus-mark: ~A" (find-mark "not-a-name")))))
+ (snd-display ";~A: two marks at ~A? ~A" i (mark-sample id) (map mark-sample current-marks)))
+ (if (find-mark "not-a-name") (snd-display ";find-bogus-mark: ~A" (find-mark "not-a-name")))))
(case (random 15)
((0) (let ((beg (random (framples)))
@@ -24495,39 +24003,41 @@ EDITS: 2
(lambda (id old-loc)
(if (> old-loc beg)
(if (not (mark? id))
- (snd-display #__line__ ";insert clobbered mark: ~A" id)
+ (snd-display ";insert clobbered mark: ~A" id)
(if (not (= (mark-sample id) (+ old-loc dur)))
- (snd-display #__line__ ";insert, mark ~D ~D -> ~D (~D)" id old-loc (mark-sample id) dur)))))
+ (snd-display ";insert, mark ~D ~D -> ~D (~D)" id old-loc (mark-sample id) dur)))))
current-marks
current-samples)))
((1) (if (> (car (edits ind 0)) 0) (undo)))
((2) (if (> (cadr (edits ind 0)) 0) (redo)))
- ((3) (if (> (maxamp ind 0) .1) (scale-channel .5) (scale-channel 2.0))
+ ((3)
+ (scale-channel (if (> (maxamp ind 0) .1) .5 2.0))
(if (not (equal? (marks ind 0) current-marks))
- (snd-display #__line__ ";scaling changed marks: ~A ~A" (marks ind 0) current-marks))
+ (snd-display ";scaling changed marks: ~A ~A" (marks ind 0) current-marks))
(if (not (equal? (map mark-sample (marks ind 0)) current-samples))
- (snd-display #__line__ ";scaling changed mark locations: ~A ~A" (map mark-sample (marks ind 0)) current-samples)))
- ((4) (set! (sample (random (- (framples) 1))) .5)
+ (snd-display ";scaling changed mark locations: ~A ~A" (map mark-sample (marks ind 0)) current-samples)))
+ ((4)
+ (set! (sample (random (- (framples) 1))) .5)
(if (not (equal? (marks ind 0) current-marks))
- (snd-display #__line__ ";set-sample changed marks: ~A ~A" (marks ind 0) current-marks))
+ (snd-display ";set-sample changed marks: ~A ~A" (marks ind 0) current-marks))
(if (not (equal? (map mark-sample (marks ind 0)) current-samples))
- (snd-display #__line__ ";set-sample changed mark locations: ~A ~A" (map mark-sample (marks ind 0)) current-samples)))
+ (snd-display ";set-sample changed mark locations: ~A ~A" (map mark-sample (marks ind 0)) current-samples)))
((5) (let* ((beg (random (framples)))
(dur (max 1 (random 100)))
(end (+ beg dur)))
(delete-samples beg dur)
(for-each
(lambda (id old-loc)
- (if (and (> old-loc beg)
- (< old-loc end)
- (mark? id))
- (snd-display #__line__ ";delete did not clobber mark: ~A ~A [~A ~A]" id old-loc beg end)
- (if (and (> old-loc end)
- (not (= (mark-sample id) (- old-loc dur))))
- (snd-display #__line__ ";delete ripple mark ~D ~D -> ~D (~D)" id old-loc (mark-sample id) dur)
- (if (and (< old-loc beg)
- (not (= (mark-sample id) old-loc)))
- (snd-display #__line__ ";delete but mark before: ~A ~A ~A ~A" id old-loc (mark-sample id) beg)))))
+ (cond ((and (> old-loc beg)
+ (< old-loc end)
+ (mark? id))
+ (snd-display ";delete did not clobber mark: ~A ~A [~A ~A]" id old-loc beg end))
+ ((and (> old-loc end)
+ (not (= (mark-sample id) (- old-loc dur))))
+ (snd-display ";delete ripple mark ~D ~D -> ~D (~D)" id old-loc (mark-sample id) dur))
+ ((and (< old-loc beg)
+ (not (= (mark-sample id) old-loc)))
+ (snd-display ";delete but mark before: ~A ~A ~A ~A" id old-loc (mark-sample id) beg))))
current-marks
current-samples)))
((6) (revert-sound))
@@ -24536,17 +24046,17 @@ EDITS: 2
(let ((id (current-marks (random (- (length current-marks) 1)))))
(delete-mark id)
(if (mark? id)
- (snd-display #__line__ ";delete-mark failed? ~A" id))
+ (snd-display ";delete-mark failed? ~A" id))
(if (not (= (length (marks ind 0)) (- (length current-marks) 1)))
- (snd-display #__line__ ";delete-mark list trouble: ~A ~A ~A" id current-marks (marks ind 0))))))
+ (snd-display ";delete-mark list trouble: ~A ~A ~A" id current-marks (marks ind 0))))))
((8) (let ((rate (if (> (framples) 200000) 2.0 0.5)))
(src-channel rate)
(for-each
(lambda (id old-loc)
(if (not (mark? id))
- (snd-display #__line__ ";src-channel clobbered mark: ~A" id)
+ (snd-display ";src-channel clobbered mark: ~A" id)
(if (> (abs (- (/ old-loc rate) (mark-sample id))) 2)
- (snd-display #__line__ ";src moved mark: ~A ~A ~A (~A -> ~A)"
+ (snd-display ";src moved mark: ~A ~A ~A (~A -> ~A)"
id old-loc (mark-sample id) rate (- (/ old-loc rate) (mark-sample id))))))
current-marks
current-samples)))
@@ -24554,9 +24064,9 @@ EDITS: 2
(for-each
(lambda (id old-loc)
(if (not (mark? id))
- (snd-display #__line__ ";reverse-channel clobbered mark: ~A" id)
+ (snd-display ";reverse-channel clobbered mark: ~A" id)
(if (> (abs (- (framples) old-loc (mark-sample id))) 2)
- (snd-display #__line__ ";reverse moved mark: ~A ~A ~A (~A)"
+ (snd-display ";reverse moved mark: ~A ~A ~A (~A)"
id old-loc (- (framples) old-loc) (mark-sample id)))))
current-marks
current-samples))
@@ -24570,18 +24080,18 @@ EDITS: 2
(let ((m1 (add-mark 1234)))
(let ((val0 (describe-mark m0))
(val1 (describe-mark m1)))
- (if (or (not (equal? ((car val0) 0) m0))
- (not (equal? ((car val0) 2) ind))
- (not (= ((car val0) 5) 0))
- (not (= (val0 1) 4321))
- (not (= (val0 2) 4320)))
- (snd-display #__line__ ";describe-mark m0: ~A" val0))
+ (if (not (and (equal? ((car val0) 0) m0)
+ (equal? ((car val0) 2) ind)
+ (= ((car val0) 5) 0)
+ (= (val0 1) 4321)
+ (= (val0 2) 4320)))
+ (snd-display ";describe-mark m0: ~A" val0))
(if (or (not (equal? ((car val1) 0) m1))
(not (equal? ((car val1) 2) ind))
(not (= ((car val1) 5) 0))
(val1 1)
(not (= (val1 2) 1234)))
- (snd-display #__line__ ";describe-mark m1: ~A" val1))
+ (snd-display ";describe-mark m1: ~A" val1))
(delete-mark m0)
(delete-sample 5000)
(set! val0 (describe-mark m0))
@@ -24592,30 +24102,28 @@ EDITS: 2
(not (= (val0 1) 4321))
(val0 2)
(val0 3))
- (snd-display #__line__ ";describe-mark m0 [1]: ~A" val0))
+ (snd-display ";describe-mark m0 [1]: ~A" val0))
(if (or (not (equal? ((car val1) 0) m1))
(not (equal? ((car val1) 2) ind))
(not (= ((car val1) 5) 0))
(val1 1)
(not (= (val1 2) 1234))
(not (= (val1 3) 1234)))
- (snd-display #__line__ ";describe-mark m1 [1]: ~A" val1)))))
+ (snd-display ";describe-mark m1 [1]: ~A" val1)))))
(revert-sound ind)
(hook-push draw-mark-hook (lambda (hook) #t))
- (let ((m0 (add-mark 4321))
- (m1 (add-mark 1234))
- (dur (/ (framples ind) (srate ind))))
- (pad-marks (list m0 m1) .01)
- (if (fneq (/ (framples ind) (srate ind)) (+ dur .02))
- (snd-display #__line__ ";pad-marks: ~A ~A" dur (/ (framples ind) (srate ind))))
- (if (and (not (= (mark-sample m0) 4763))
- (not (= (mark-sample m0) 4761)))
- (snd-display #__line__ ";pad-marks m0 pos: ~A" (mark-sample m0)))
- (if (fneq (sample 1235) 0.0) (snd-display #__line__ ";pad-marks 1235: ~A" (sample 1235))))
+ (let ((m0 (add-mark 4321)))
+ (let ((dur (/ (framples ind) (srate ind))))
+ (pad-marks (list m0 (add-mark 1234)) .01)
+ (if (fneq (/ (framples ind) (srate ind)) (+ dur .02))
+ (snd-display ";pad-marks: ~A ~A" dur (/ (framples ind) (srate ind)))))
+ (if (not (member (mark-sample m0) '(4763 4761) =))
+ (snd-display ";pad-marks m0 pos: ~A" (mark-sample m0)))
+ (if (fneq (sample 1235) 0.0) (snd-display ";pad-marks 1235: ~A" (sample 1235))))
(close-sound ind))
(set! (hook-functions draw-mark-hook) ())
(let ((ind (open-sound "oboe.snd")))
- (if (find-mark 12345) (snd-display #__line__ ";find-mark when no marks: ~A" (find-mark 12345)))
+ (if (find-mark 12345) (snd-display ";find-mark when no marks: ~A" (find-mark 12345)))
(add-mark 123 ind 0)
(delete-sample 0)
(let ((m1 (add-mark 23 ind 0)))
@@ -24624,29 +24132,29 @@ EDITS: 2
(let ((m00 (find-mark 123 ind 0 0))
(m01 (find-mark "23"))
(m02 (find-mark 121)))
- (if (not m00) (snd-display #__line__ ";can't find 00th mark"))
- (if (not m01) (snd-display #__line__ ";can't find 01th mark"))
- (if (not m02) (snd-display #__line__ ";can't find 02th mark"))
- (delete-mark (find-mark "23"))
- (scale-by 2.0)
- (set! m1 (add-mark 1234))
- (set! (mark-name m1) "23")
- (let ((m10 (find-mark "23"))
- (m11 (find-mark "23" ind 0 1))
- (m12 (find-mark "23" ind 0 2)))
- (if (not m10) (snd-display #__line__ ";can't find 10th mark")
- (if (not (= (mark-sample m10) 1234)) (snd-display #__line__ ";mark 10th: ~A" (mark-sample m10))))
- (if (not m11) (snd-display #__line__ ";can't find 11th mark")
- (if (not (= (mark-sample m11 1) 23)) (snd-display #__line__ ";mark 11th: ~A" (mark-sample m11 1))))
- (if (mark? m12) (snd-display #__line__ ";found 12th mark: ~A ~A ~A" m12 (mark-sample m12 2) (mark-name m12))))
- (set! (mark-name m1) #f)))
+ (if (not m00) (snd-display ";can't find 00th mark"))
+ (if (not m01) (snd-display ";can't find 01th mark"))
+ (if (not m02) (snd-display ";can't find 02th mark")))
+ (delete-mark (find-mark "23"))
+ (scale-by 2.0)
+ (set! m1 (add-mark 1234))
+ (set! (mark-name m1) "23")
+ (let ((m10 (find-mark "23"))
+ (m11 (find-mark "23" ind 0 1))
+ (m12 (find-mark "23" ind 0 2)))
+ (if (not m10) (snd-display ";can't find 10th mark")
+ (if (not (= (mark-sample m10) 1234)) (snd-display ";mark 10th: ~A" (mark-sample m10))))
+ (if (not m11) (snd-display ";can't find 11th mark")
+ (if (not (= (mark-sample m11 1) 23)) (snd-display ";mark 11th: ~A" (mark-sample m11 1))))
+ (if (mark? m12) (snd-display ";found 12th mark: ~A ~A ~A" m12 (mark-sample m12 2) (mark-name m12))))
+ (set! (mark-name m1) #f))
(close-sound ind))
(if (string? sf-dir)
(let ((ind (open-sound (string-append sf-dir "forest.aiff"))))
(mark-loops)
(let ((pos (map mark-sample (marks ind 0))))
(if (not (equal? pos (list 24981 144332)))
- (snd-display #__line__ ";forest marked loops: ~A ~A" (marks ind 0) pos)))
+ (snd-display ";forest marked loops: ~A ~A" (marks ind 0) pos)))
(close-sound ind)))
))
@@ -24664,39 +24172,38 @@ EDITS: 2
(load (string-append cwd "oboe.marks"))
(let ((m (find-mark 123 ind 0)))
(if (not (mark? m))
- (snd-display #__line__ ";save marks missed 123?")
+ (snd-display ";save marks missed 123?")
(begin
- (if (not (= (length (mark-name m)) 0)) (snd-display #__line__ ";saved mark 123 name: ~A" (mark-name m)))
- (if (not (= (mark-sync m) 0)) (snd-display #__line__ ";saved mark 123 sync: ~A" (mark-sync m))))))
+ (if (not (= (length (mark-name m)) 0)) (snd-display ";saved mark 123 name: ~A" (mark-name m)))
+ (if (not (= (mark-sync m) 0)) (snd-display ";saved mark 123 sync: ~A" (mark-sync m))))))
(let ((m1-sync 0))
(let ((m (find-mark 234 ind 0)))
(if (not (mark? m))
- (snd-display #__line__ ";save marks missed 234?")
+ (snd-display ";save marks missed 234?")
(begin
- (if (not (string=? (mark-name m) "hiho")) (snd-display #__line__ ";saved mark 234 name: ~A" (mark-name m)))
- (if (or (= (mark-sync m) 0) (= (mark-sync m) 1)) (snd-display #__line__ ";saved mark 234 sync: ~A" (mark-sync m)))
+ (if (not (string=? (mark-name m) "hiho")) (snd-display ";saved mark 234 name: ~A" (mark-name m)))
+ (if (or (= (mark-sync m) 0) (= (mark-sync m) 1)) (snd-display ";saved mark 234 sync: ~A" (mark-sync m)))
(set! m1-sync (mark-sync m)))))
(let ((m (find-mark 345 ind 0)))
(if (not (mark? m))
- (snd-display #__line__ ";save marks missed 345?")
+ (snd-display ";save marks missed 345?")
(begin
- (if (not (= (length (mark-name m)) 0)) (snd-display #__line__ ";saved mark 345 name: ~A" (mark-name m)))
- (if (not (= (mark-sync m) m1-sync)) (snd-display #__line__ ";saved mark 345 sync: ~A ~A" (mark-sync m) m1-sync)))))
+ (if (not (= (length (mark-name m)) 0)) (snd-display ";saved mark 345 name: ~A" (mark-name m)))
+ (if (not (= (mark-sync m) m1-sync)) (snd-display ";saved mark 345 sync: ~A ~A" (mark-sync m) m1-sync)))))
(let ((m (find-mark 567 ind 0)))
(if (not (mark? m))
- (snd-display #__line__ ";save marks missed 567?")
+ (snd-display ";save marks missed 567?")
(begin
- (if (not (= (length (mark-name m)) 0)) (snd-display #__line__ ";saved mark 567 name: ~A" (mark-name m)))
- (if (not (= (mark-sync m) m1-sync)) (snd-display #__line__ ";saved mark 567 sync: ~A ~A" (mark-sync m) m1-sync)))))
+ (if (not (= (length (mark-name m)) 0)) (snd-display ";saved mark 567 name: ~A" (mark-name m)))
+ (if (not (= (mark-sync m) m1-sync)) (snd-display ";saved mark 567 sync: ~A ~A" (mark-sync m) m1-sync)))))
(let ((m (find-mark 456 ind 0)))
(if (not (mark? m))
- (snd-display #__line__ ";save marks missed 456?")
+ (snd-display ";save marks missed 456?")
(begin
- (if (not (string=? (mark-name m) "a mark")) (snd-display #__line__ ";saved mark 456 name: ~A" (mark-name m)))
+ (if (not (string=? (mark-name m) "a mark")) (snd-display ";saved mark 456 name: ~A" (mark-name m)))
(if (or (= (mark-sync m) m1-sync)
- (= (mark-sync m) 0)
- (= (mark-sync m) 1))
- (snd-display #__line__ ";saved mark 456 sync: ~A ~A" (mark-sync m) m1-sync)))))
+ (member (mark-sync m) '(0 1) =))
+ (snd-display ";saved mark 456 sync: ~A ~A" (mark-sync m) m1-sync)))))
)
(delete-file "oboe.marks")
@@ -24721,48 +24228,48 @@ EDITS: 2
(let ((m1 (find-mark 1 ind 0))
(m2 (find-mark 2 ind 1)))
- (if (or (not (mark? m1)) (not (mark? m2)))
- (snd-display #__line__ ";save-marks 2a 1,2: ~A ~A" m1 m2)
- (if (or (not (= (mark-sync m1) 0)) (not (= (mark-sync m2) 0)))
- (snd-display #__line__ ";save-marks 2a 1,2 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))))
+ (if (not (and (mark? m1) (mark? m2)))
+ (snd-display ";save-marks 2a 1,2: ~A ~A" m1 m2)
+ (if (not (and (= (mark-sync m1) 0) (= (mark-sync m2) 0)))
+ (snd-display ";save-marks 2a 1,2 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))))
(let ((m1 (find-mark 5 ind 0))
(m2 (find-mark 10 ind 1)))
- (if (or (not (mark? m1)) (not (mark? m2)))
- (snd-display #__line__ ";save-marks 2a 5,10: ~A ~A" m1 m2)
+ (if (not (and (mark? m1) (mark? m2)))
+ (snd-display ";save-marks 2a 5,10: ~A ~A" m1 m2)
(if (or (= (mark-sync m1) 0)
(not (= (mark-sync m1) (mark-sync m2))))
- (snd-display #__line__ ";save-marks 2a 5,10 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))))
+ (snd-display ";save-marks 2a 5,10 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))))
(let ((m1 (find-mark 4 ind 0))
(m2 (find-mark 8 ind 1))
(m3 (find-mark 5 ind 0)))
- (if (or (not (mark? m1)) (not (mark? m2)))
- (snd-display #__line__ ";save-marks 2a 4,8: ~A ~A" m1 m2)
+ (if (not (and (mark? m1) (mark? m2)))
+ (snd-display ";save-marks 2a 4,8: ~A ~A" m1 m2)
(if (or (= (mark-sync m1) 0)
(= (mark-sync m2) 0)
(= (mark-sync m1) (mark-sync m2))
(= (mark-sync m1) (mark-sync m3)))
- (snd-display #__line__ ";save-marks 2a 4,8 syncs: ~A ~A ~A" (mark-sync m1) (mark-sync m2) (mark-sync m3)))))
+ (snd-display ";save-marks 2a 4,8 syncs: ~A ~A ~A" (mark-sync m1) (mark-sync m2) (mark-sync m3)))))
(let ((m1 (find-mark 3 ind 0))
(m2 (find-mark 6 ind 1)))
- (if (or (not (mark? m1)) (not (mark? m2)))
- (snd-display #__line__ ";save-marks 2a 3,6: ~A ~A" m1 m2)
+ (if (not (and (mark? m1) (mark? m2)))
+ (snd-display ";save-marks 2a 3,6: ~A ~A" m1 m2)
(begin
- (if (or (not (= (mark-sync m1) 0)) (not (= (mark-sync m2) 0)))
- (snd-display #__line__ ";save-marks 2a 3,6 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))
- (if (not (string=? (mark-name m1) "hi3")) (snd-display #__line__ ";save-marks 2a 3 name: ~A" (mark-name m1)))
- (if (not (string=? (mark-name m2) "hi6")) (snd-display #__line__ ";save-marks 2a 6 name: ~A" (mark-name m2))))))
+ (if (not (and (= (mark-sync m1) 0) (= (mark-sync m2) 0)))
+ (snd-display ";save-marks 2a 3,6 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))
+ (if (not (string=? (mark-name m1) "hi3")) (snd-display ";save-marks 2a 3 name: ~A" (mark-name m1)))
+ (if (not (string=? (mark-name m2) "hi6")) (snd-display ";save-marks 2a 6 name: ~A" (mark-name m2))))))
(let ((m1 (find-mark 4 ind 0))
(m2 (find-mark 5 ind 0))
(m3 (find-mark 20 ind 0))
(m4 (find-mark 40 ind 1))
(m5 (find-mark 60 ind 1)))
- (if (or (not (mark? m3)) (not (mark? m4)) (not (mark? m5)))
- (snd-display #__line__ ";save-marks 2a 20...: ~A ~A ~A" m3 m4 m5)
+ (if (not (and (mark? m3) (mark? m4) (mark? m5)))
+ (snd-display ";save-marks 2a 20...: ~A ~A ~A" m3 m4 m5)
(if (or (= (mark-sync m3) 0)
(= (mark-sync m1) (mark-sync m3))
(= (mark-sync m2) (mark-sync m3))
(not (= (mark-sync m3) (mark-sync m4) (mark-sync m5))))
- (snd-display #__line__ ";save-marks 2a 10... syncs: ~A ~A ~A" (mark-sync m3) (mark-sync m4) (mark-sync m5)))))
+ (snd-display ";save-marks 2a 10... syncs: ~A ~A ~A" (mark-sync m3) (mark-sync m4) (mark-sync m5)))))
(delete-file "test.marks")
(close-sound ind))
@@ -24783,51 +24290,51 @@ EDITS: 2
(eval-header ind)
(let ((ms (marks ind 0)))
- (if (not (= (length ms) 5)) (snd-display #__line__ ";eval-header + marks->string: ~A" ms))
+ (if (not (= (length ms) 5)) (snd-display ";eval-header + marks->string: ~A" ms))
(let ((samps (map mark-sample ms)))
- (if (or (not (memv 123 samps))
- (not (memv 567 samps)))
- (snd-display #__line__ ";eval marked header samps: ~A" samps)))
- (if (not (find-mark 234)) (snd-display #__line__ ";eval mark header no mark at 234?"))
- (if (mark? (find-mark 456))
- (if (not (= (mark-sync (find-mark 456)) 2))
- (snd-display #__line__ ";eval mark header sync: ~A" (mark-sync (find-mark 456))))
- (snd-display #__line__ ";no mark at 456")))
+ (if (not (and (memv 123 samps)
+ (memv 567 samps)))
+ (snd-display ";eval marked header samps: ~A" samps))))
+ (if (not (find-mark 234)) (snd-display ";eval mark header no mark at 234?"))
+ (if (mark? (find-mark 456))
+ (if (not (= (mark-sync (find-mark 456)) 2))
+ (snd-display ";eval mark header sync: ~A" (mark-sync (find-mark 456))))
+ (snd-display ";no mark at 456"))
(close-sound ind)
(mus-sound-forget "tst.snd")
(delete-file "tst.snd"))
;; mark-explode
- (let ((ind (new-sound :size 31))
- (ctr -1))
- (map-channel (lambda (y) (set! ctr (+ ctr 1)) (if (< ctr 10) .1 (if (< ctr 20) .4 .8))))
+ (let ((ind (new-sound :size 31)))
+ (let ((ctr -1))
+ (map-channel (lambda (y) (set! ctr (+ ctr 1)) (if (< ctr 10) .1 (if (< ctr 20) .4 .8)))))
(add-mark 10)
(add-mark 20)
(add-mark 30)
(mark-explode)
- (if (file-exists? "mark-0.snd")
+ (if (not (file-exists? "mark-0.snd"))
+ (snd-display ";mark-explode did not write mark-0.snd?")
(let ((ind1 (open-sound "mark-0.snd")))
- (if (not (= (framples ind1 0) 10)) (snd-display #__line__ ";mark-0 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .1))) (snd-display #__line__ ";mark-0 vals: ~A" (channel->float-vector)))
+ (if (not (= (framples ind1 0) 10)) (snd-display ";mark-0 framples: ~A" (framples ind1 0)))
+ (if (not (vequal (channel->float-vector) (make-float-vector 10 .1))) (snd-display ";mark-0 vals: ~A" (channel->float-vector)))
(close-sound ind1)
- (delete-file "mark-0.snd"))
- (snd-display #__line__ ";mark-explode did not write mark-0.snd?"))
- (if (file-exists? "mark-1.snd")
+ (delete-file "mark-0.snd")))
+ (if (not (file-exists? "mark-1.snd"))
+ (snd-display ";mark-explode did not write mark-1.snd?")
(let ((ind1 (open-sound "mark-1.snd")))
- (if (not (= (framples ind1 0) 10)) (snd-display #__line__ ";mark-1 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .4))) (snd-display #__line__ ";mark-1 vals: ~A" (channel->float-vector)))
+ (if (not (= (framples ind1 0) 10)) (snd-display ";mark-1 framples: ~A" (framples ind1 0)))
+ (if (not (vequal (channel->float-vector) (make-float-vector 10 .4))) (snd-display ";mark-1 vals: ~A" (channel->float-vector)))
(close-sound ind1)
- (delete-file "mark-1.snd"))
- (snd-display #__line__ ";mark-explode did not write mark-1.snd?"))
- (if (file-exists? "mark-2.snd")
+ (delete-file "mark-1.snd")))
+ (if (not (file-exists? "mark-2.snd"))
+ (snd-display ";mark-explode did not write mark-2.snd?")
(let ((ind1 (open-sound "mark-2.snd")))
- (if (not (= (framples ind1 0) 10)) (snd-display #__line__ ";mark-2 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .8))) (snd-display #__line__ ";mark-2 vals: ~A" (channel->float-vector)))
+ (if (not (= (framples ind1 0) 10)) (snd-display ";mark-2 framples: ~A" (framples ind1 0)))
+ (if (not (vequal (channel->float-vector) (make-float-vector 10 .8))) (snd-display ";mark-2 vals: ~A" (channel->float-vector)))
(close-sound ind1)
- (delete-file "mark-2.snd"))
- (snd-display #__line__ ";mark-explode did not write mark-2.snd?"))
- (if (file-exists? "mark-3.snd") (snd-display #__line__ ";mark-explode wrote too many files?"))
+ (delete-file "mark-2.snd")))
+ (if (file-exists? "mark-3.snd") (snd-display ";mark-explode wrote too many files?"))
(let ((name (file-name ind)))
(close-sound ind)
(if (file-exists? name) (delete-file name))))
@@ -24836,13 +24343,10 @@ EDITS: 2
;;; ---------------- test 11: dialogs ----------------
-(define-envelope env1 '(0 0 1 0))
-(define-envelope env2 '(0 0 1 1))
-(define-envelope ramp-up-env '(0 0 1 1))
-(define-envelope env4 '(0 1 1 0))
-
(define (snd_test_11)
+ (define-envelope env4 '(0 1 1 0))
+
(define (string-equal-ignoring-white-space s1 s2)
(or (string=? s1 s2)
(let ((len1 (length s1))
@@ -24861,160 +24365,158 @@ EDITS: 2
(char=? (s1 i1) (s2 i2))
(loop (+ i1 1) (+ i2 1))))))))))
- (if with-gui
- (begin
- (without-errors (peaks))
- (enved-dialog)
- (color-orientation-dialog)
- (transform-dialog)
- (if with-motif (view-files-dialog))
- (view-regions-dialog)
- (if (not (provided? 'snd-gtk)) (print-dialog))
- (without-errors (edit-header-dialog))
- (open-file-dialog #f)
- (mix-file-dialog #f)
- (insert-file-dialog #f)
- (help-dialog "Test" "snd-test here")
- (save-envelopes "hiho.env")
- (load (string-append cwd "hiho.env"))
- (if (not (equal? env4 (list 0.0 1.0 1.0 0.0))) (snd-display #__line__ ";save-envelopes: ~A?" env4))
- (delete-file "hiho.env")
- (help-dialog "test2" "this is the next test"
- (list "string 1{open-sound}" "{env-sound}string2" "string{close-sound}3")
- (list "extsnd.html#sndopen" "extsnd.html#sndenv" "extsnd.html#sndclose"))
- (dismiss-all-dialogs)
-
- (let ((ind (open-sound "oboe.snd")))
- (edit-header-dialog ind)
- (dismiss-all-dialogs)
- (close-sound ind))
- (if (not (string=? (snd-url 'open-sound) "extsnd.html#opensound"))
- (snd-display #__line__ ";snd-url 'open-sound: ~A" (snd-url 'open-sound)))
- (if (not (string=? (snd-url "open-sound") "extsnd.html#opensound"))
- (snd-display #__line__ ";snd-url \"open-sound\": ~A" (snd-url "open-sound")))
- (if (not (list? (snd-urls))) (snd-display #__line__ ";snd-urls: ~A" (snd-urls)))
- (let ((str1 (snd-help open-sound))
- (str2 (snd-help 'open-sound))
- (str3 (snd-help "open-sound")))
- (if (or (not (string? str1)) ; can happen if we're running -DTIMING
- (not (string? str2))
- (not (string? str3))
- (not (string-equal-ignoring-white-space str2 str3)))
- (snd-display #__line__ ";snd-help open-sound: ~A ~A ~A" str1 str2 str3)))
+ (when with-gui
+ (without-errors (peaks))
+ (enved-dialog)
+ (color-orientation-dialog)
+ (transform-dialog)
+ (if with-motif (view-files-dialog))
+ (view-regions-dialog)
+ (if (not (provided? 'snd-gtk)) (print-dialog))
+ (without-errors (edit-header-dialog))
+ (open-file-dialog #f)
+ (mix-file-dialog #f)
+ (insert-file-dialog #f)
+ (help-dialog "Test" "snd-test here")
+ (save-envelopes "hiho.env")
+ (load (string-append cwd "hiho.env"))
+ (if (not (equal? env4 (list 0.0 1.0 1.0 0.0))) (snd-display ";save-envelopes: ~A?" env4))
+ (delete-file "hiho.env")
+ (help-dialog "test2" "this is the next test"
+ (list "string 1{open-sound}" "{env-sound}string2" "string{close-sound}3")
+ (list "extsnd.html#sndopen" "extsnd.html#sndenv" "extsnd.html#sndclose"))
+ (dismiss-all-dialogs)
+
+ (let ((ind (open-sound "oboe.snd")))
+ (edit-header-dialog ind)
+ (dismiss-all-dialogs)
+ (close-sound ind))
+ (if (not (string=? (snd-url 'open-sound) "extsnd.html#opensound"))
+ (snd-display ";snd-url 'open-sound: ~A" (snd-url 'open-sound)))
+ (if (not (string=? (snd-url "open-sound") "extsnd.html#opensound"))
+ (snd-display ";snd-url \"open-sound\": ~A" (snd-url "open-sound")))
+ (if (not (list? (snd-urls))) (snd-display ";snd-urls: ~A" (snd-urls)))
+ (let ((str1 (snd-help open-sound))
+ (str2 (snd-help 'open-sound))
+ (str3 (snd-help "open-sound")))
+ (if (not (and (string? str1) ; can happen if we're running -DTIMING
+ (string? str2)
+ (string? str3)
+ (string-equal-ignoring-white-space str2 str3)))
+ (snd-display ";snd-help open-sound: ~A ~A ~A" str1 str2 str3)))
; (if (not (string? (snd-help 'open-soud)))
- ; (snd-display #__line__ ";snd-help open-soud (misspelled on purpose) failed"))
- (if (not (string-equal-ignoring-white-space (snd-help enved-base) "(enved-base): envelope editor exponential base value (1.0)"))
- (snd-display #__line__ ";snd-help enved-base: ~A?" (snd-help enved-base)))
- (if (not (string-equal-ignoring-white-space (snd-help 'enved-base) "(enved-base): envelope editor exponential base value (1.0)"))
- (snd-display #__line__ ";snd-help 'enved-base: ~A?" (snd-help 'enved-base)))
- (if (not (string-equal-ignoring-white-space (snd-help "enved-base") "(enved-base): envelope editor exponential base value (1.0)"))
- (snd-display #__line__ ";snd-help \"enved-base\": ~A?" (snd-help "enved-base")))
- (let ((old-val hamming-window))
- (let ((str1 (snd-help 'hamming-window))
- (str2 (snd-help "hamming-window")))
- (if (or (not (string? str1)) (not (string? str2))
- (not (string-equal-ignoring-white-space str1 str2))
- (not (string-equal-ignoring-white-space str1 "A raised cosine")))
- (snd-display #__line__ ";snd-help hamming-window: ~A ~A" str1 str2)))
- (if (not (= hamming-window old-val))
- (snd-display #__line__ ";snd-help clobbered out-of-module variable: ~A ~A" old-val hamming-window)))
- (let ((vals (snd-urls)))
- (do ((i 0 (+ i 1)))
- ((= i 25)) ; need to cycle the 8's
- (if (defined? (string->symbol (car (vals i))))
- (snd-help (car (vals i)) #f))))
-
- (set! *show-indices* #t)
- (let ((ind (open-sound "oboe.snd")))
- (if (< (length (sound-widgets ind)) 4)
- (snd-display #__line__ ";sound-widgets: ~A?" (sound-widgets ind)))
- (status-report "hi there" ind)
- (status-report "")
- (close-sound ind))
- (set! *show-indices* #f)
-
- (define-envelope test-ramp '(0 0 1 1))
- (if (not (equal? test-ramp '(0 0 1 1))) (snd-display #__line__ ";define-envelope test-ramp: ~A" test-ramp))
- (define-envelope test-ramp '(0 1 1 0))
- (if (not (equal? test-ramp '(0 1 1 0))) (snd-display #__line__ ";re-define-envelope test-ramp: ~A" test-ramp))
-
- (if with-motif
- (let ((dialog (view-files-dialog #f)))
- (let ((vfamp (view-files-amp dialog))
- (vfs (view-files-speed dialog))
- (vfsort (view-files-sort))
- (vfsort1 (view-files-sort dialog))
- (vfe (view-files-amp-env dialog))
- (vffiles (view-files-files dialog))
- (vfsel (view-files-selected-files dialog))
- (selected-file #f))
- (if (fneq vfamp 1.0) (snd-display #__line__ ";vf amp: ~A" vfamp))
- (if (fneq vfs 1.0) (snd-display #__line__ ";vf spd: ~A" vfs))
- (if (not (= vfsort 0)) (snd-display #__line__ ";vf sort: ~A" vfsort))
- (if (not (= vfsort1 0)) (snd-display #__line__ ";vf sort(d): ~A" vfsort1))
- (if (not (feql vfe (list 0.0 1.0 1.0 1.0))) (snd-display #__line__ ";vf amp env: ~A" vfe))
- (if (not (list? vffiles)) (snd-display #__line__ ";vf files: ~A" vffiles))
- (if (not (list? vfsel)) (snd-display #__line__ ";vf selected files: ~A" vfsel))
- (if (not (= (view-files-speed-style dialog) *speed-control-style*))
- (snd-display #__line__ ";vf speed-style def: ~A ~A" (view-files-speed-style dialog) *speed-control-style*))
- (set! (view-files-amp dialog) 0.5)
- (if (fneq (view-files-amp dialog) 0.5) (snd-display #__line__ ";set vf amp: ~A" (view-files-amp dialog)))
- (set! (view-files-speed dialog) 0.5)
- (if (fneq (view-files-speed dialog) 0.5) (snd-display #__line__ ";set vf spd: ~A" (view-files-speed dialog)))
- (set! (view-files-speed-style dialog) speed-control-as-ratio)
- (if (not (= (view-files-speed-style dialog) speed-control-as-ratio))
- (snd-display #__line__ ";vf speed-style set: ~A" (view-files-speed-style dialog)))
- (set! (view-files-sort dialog) 2)
- (if (not (= (view-files-sort) 0)) (snd-display #__line__ ";vf global sort after local set: ~A" (view-files-sort)))
- (if (not (= (view-files-sort dialog) 2)) (snd-display #__line__ ";vf local sort after local set: ~A" (view-files-sort dialog)))
- (set! (view-files-sort) 4)
- (if (not (= (view-files-sort) 4)) (snd-display #__line__ ";vf global sort after global set: ~A" (view-files-sort)))
- (if (not (= (view-files-sort dialog) 2)) (snd-display #__line__ ";vf local sort after global set: ~A" (view-files-sort dialog)))
- (set! (view-files-files dialog) (list "oboe.snd" "1a.snd" "pistol.snd" "storm.snd"))
- (let ((vf-files (view-files-files dialog)))
- (if (or (and (not (member "1a.snd" vf-files))
- (not (member (string-append home-dir "/cl/1a.snd") vf-files))
- (not (member (string-append home-dir "/snd-16/1a.snd") vf-files)))
- (and (not (member "pistol.snd" vf-files))
- (not (member (string-append home-dir "/cl/pistol.snd") vf-files))
- (not (member (string-append home-dir "/snd-16/pistol.snd") vf-files)))
- (not (= (length vf-files) 4)))
- (snd-display #__line__ ";vf files set: ~A (~A, ~A)" vf-files (string-append home-dir "/cl/1a.snd") (length vf-files))))
- (set! (hook-functions view-files-select-hook) ())
- (hook-push view-files-select-hook (lambda (hook)
- (if (not (string? (hook 'name)))
- (snd-display #__line__ ";vf select hook arg: ~A" (hook 'name)))
- (if (not (hook 'widget)) (snd-display #__line__ ";vf select hook dialog: ~A" (hook 'widget)))
- (set! selected-file (hook 'name))))
- (set! (view-files-selected-files dialog) (list "1a.snd"))
- (if (or (not (string? selected-file))
- (and (not (equal? selected-file "1a.snd"))
- (not (equal? selected-file (string-append home-dir "/cl/1a.snd")))
- (not (equal? selected-file (string-append home-dir "/snd-16/1a.snd")))))
- (snd-display #__line__ ";vf set selected select hook arg: ~A" selected-file))
- (if (and (not (equal? (view-files-selected-files dialog) (list "1a.snd")))
- (not (equal? (view-files-selected-files dialog) (list (string-append home-dir "/cl/1a.snd"))))
- (not (equal? (view-files-selected-files dialog) (list (string-append home-dir "/snd-16/1a.snd")))))
- (snd-display #__line__ ";vf selected files set: ~A" (view-files-selected-files dialog)))
- (hide-widget dialog)
- )))
- (dismiss-all-dialogs)
- )))
-
-
+ ; (snd-display ";snd-help open-soud (misspelled on purpose) failed"))
+ (if (not (string-equal-ignoring-white-space (snd-help enved-base) "(enved-base): envelope editor exponential base value (1.0)"))
+ (snd-display ";snd-help enved-base: ~A?" (snd-help enved-base)))
+ (if (not (string-equal-ignoring-white-space (snd-help 'enved-base) "(enved-base): envelope editor exponential base value (1.0)"))
+ (snd-display ";snd-help 'enved-base: ~A?" (snd-help 'enved-base)))
+ (if (not (string-equal-ignoring-white-space (snd-help "enved-base") "(enved-base): envelope editor exponential base value (1.0)"))
+ (snd-display ";snd-help \"enved-base\": ~A?" (snd-help "enved-base")))
+ (let ((old-val hamming-window))
+ (let ((str1 (snd-help 'hamming-window))
+ (str2 (snd-help "hamming-window")))
+ (if (not (and (string? str1) (string? str2)
+ (string-equal-ignoring-white-space str1 str2)
+ (string-equal-ignoring-white-space str1 "A raised cosine")))
+ (snd-display ";snd-help hamming-window: ~A ~A" str1 str2)))
+ (if (not (= hamming-window old-val))
+ (snd-display ";snd-help clobbered out-of-module variable: ~A ~A" old-val hamming-window)))
+ (let ((vals (snd-urls)))
+ (do ((i 0 (+ i 1)))
+ ((= i 25)) ; need to cycle the 8's
+ (if (defined? (string->symbol (car (vals i))))
+ (snd-help (car (vals i)) #f))))
+
+ (set! *show-indices* #t)
+ (let ((ind (open-sound "oboe.snd")))
+ (if (< (length (sound-widgets ind)) 4)
+ (snd-display ";sound-widgets: ~A?" (sound-widgets ind)))
+ (status-report "hi there" ind)
+ (status-report "")
+ (close-sound ind))
+ (set! *show-indices* #f)
+
+ (define-envelope test-ramp1 '(0 0 1 1))
+ (if (not (equal? test-ramp1 '(0 0 1 1))) (snd-display ";define-envelope test-ramp1: ~A" test-ramp1))
+ (define-envelope test-ramp '(0 1 1 0))
+ (if (not (equal? test-ramp '(0 1 1 0))) (snd-display ";re-define-envelope test-ramp: ~A" test-ramp))
+
+ (when with-motif
+ (let ((dialog (view-files-dialog #f)))
+ (let ((vfamp (view-files-amp dialog)))
+ (if (fneq vfamp 1.0) (snd-display ";vf amp: ~A" vfamp)))
+ (let ((vfs (view-files-speed dialog)))
+ (if (fneq vfs 1.0) (snd-display ";vf spd: ~A" vfs)))
+ (let ((vfsort (view-files-sort)))
+ (if (not (= vfsort 0)) (snd-display ";vf sort: ~A" vfsort)))
+ (let ((vfsort1 (view-files-sort dialog)))
+ (if (not (= vfsort1 0)) (snd-display ";vf sort(d): ~A" vfsort1)))
+ (let ((vfe (view-files-amp-env dialog)))
+ (if (not (feql vfe (list 0.0 1.0 1.0 1.0))) (snd-display ";vf amp env: ~A" vfe)))
+ (let ((vffiles (view-files-files dialog)))
+ (if (not (list? vffiles)) (snd-display ";vf files: ~A" vffiles)))
+ (let ((vfsel (view-files-selected-files dialog)))
+ (if (not (list? vfsel)) (snd-display ";vf selected files: ~A" vfsel)))
+ (if (not (= (view-files-speed-style dialog) *speed-control-style*))
+ (snd-display ";vf speed-style def: ~A ~A" (view-files-speed-style dialog) *speed-control-style*))
+ (set! (view-files-amp dialog) 0.5)
+ (if (fneq (view-files-amp dialog) 0.5) (snd-display ";set vf amp: ~A" (view-files-amp dialog)))
+ (set! (view-files-speed dialog) 0.5)
+ (if (fneq (view-files-speed dialog) 0.5) (snd-display ";set vf spd: ~A" (view-files-speed dialog)))
+ (set! (view-files-speed-style dialog) speed-control-as-ratio)
+ (if (not (= (view-files-speed-style dialog) speed-control-as-ratio))
+ (snd-display ";vf speed-style set: ~A" (view-files-speed-style dialog)))
+ (set! (view-files-sort dialog) 2)
+ (if (not (= (view-files-sort) 0)) (snd-display ";vf global sort after local set: ~A" (view-files-sort)))
+ (if (not (= (view-files-sort dialog) 2)) (snd-display ";vf local sort after local set: ~A" (view-files-sort dialog)))
+ (set! (view-files-sort) 4)
+ (if (not (= (view-files-sort) 4)) (snd-display ";vf global sort after global set: ~A" (view-files-sort)))
+ (if (not (= (view-files-sort dialog) 2)) (snd-display ";vf local sort after global set: ~A" (view-files-sort dialog)))
+ (set! (view-files-files dialog) (list "oboe.snd" "1a.snd" "pistol.snd" "storm.snd"))
+ (let ((vf-files (view-files-files dialog)))
+ (if (not (and (or (member "1a.snd" vf-files)
+ (member (string-append home-dir "/cl/1a.snd") vf-files)
+ (member (string-append home-dir "/snd-16/1a.snd") vf-files))
+ (or (member "pistol.snd" vf-files)
+ (member (string-append home-dir "/cl/pistol.snd") vf-files)
+ (member (string-append home-dir "/snd-16/pistol.snd") vf-files))
+ (= (length vf-files) 4)))
+ (snd-display ";vf files set: ~A (~A, ~A)" vf-files (string-append home-dir "/cl/1a.snd") (length vf-files))))
+ (set! (hook-functions view-files-select-hook) ())
+ (let ((selected-file #f))
+ (hook-push view-files-select-hook (lambda (hook)
+ (if (not (string? (hook 'name)))
+ (snd-display ";vf select hook arg: ~A" (hook 'name)))
+ (if (not (hook 'widget)) (snd-display ";vf select hook dialog: ~A" (hook 'widget)))
+ (set! selected-file (hook 'name))))
+ (set! (view-files-selected-files dialog) (list "1a.snd"))
+ (if (not (or (equal? selected-file "1a.snd")
+ (equal? selected-file (string-append home-dir "/cl/1a.snd"))
+ (equal? selected-file (string-append home-dir "/snd-16/1a.snd"))))
+ (snd-display ";vf set selected select hook arg: ~A" selected-file))
+ (if (not (or (equal? (view-files-selected-files dialog) (list "1a.snd"))
+ (equal? (view-files-selected-files dialog) (list (string-append home-dir "/cl/1a.snd")))
+ (equal? (view-files-selected-files dialog) (list (string-append home-dir "/snd-16/1a.snd")))))
+ (snd-display ";vf selected files set: ~A" (view-files-selected-files dialog))))
+ (hide-widget dialog)
+ ))
+ (dismiss-all-dialogs)
+ ))
;;; ---------------- test 12: extensions ----------------
(define (snd_test_12)
- (define (spectral-difference snd1 snd2)
- (let* ((size (max (framples snd1) (framples snd2)))
- (pow2 (ceiling (log size 2)))
- (fftlen (expt 2 pow2))
- (fdr1 (channel->float-vector 0 fftlen snd1 0))
- (fdr2 (channel->float-vector 0 fftlen snd2 0)))
- (let* ((spectr1 (snd-spectrum fdr1 blackman2-window fftlen #t))
+ (define (test-spectral-difference snd1 snd2 maxok)
+
+ (define (spectral-difference snd1 snd2)
+ (let* ((size (max (framples snd1) (framples snd2)))
+ (pow2 (ceiling (log size 2)))
+ (fftlen (expt 2 pow2))
+ (fdr1 (channel->float-vector 0 fftlen snd1 0))
+ (fdr2 (channel->float-vector 0 fftlen snd2 0))
+ (spectr1 (snd-spectrum fdr1 blackman2-window fftlen #t))
(spectr2 (snd-spectrum fdr2 blackman2-window fftlen #t))
(diffs (float-vector-subtract! spectr1 spectr2))
(len (length diffs))
@@ -25022,24 +24524,23 @@ EDITS: 2
(float-vector-abs! diffs)
(do ((i 0 (+ i 1)))
((= i len) (one-pole incr 0.0))
- (one-pole incr (float-vector-ref diffs i))))))
+ (one-pole incr (float-vector-ref diffs i)))))
- (define (test-spectral-difference snd1 snd2 maxok)
(let ((s1 (open-sound snd1))
(s2 (open-sound snd2)))
- (if (or (not (sound? s1))
- (not (sound? s2)))
- (snd-display #__line__ ";open-sound ~A or ~A failed?" snd1 snd2))
+ (if (not (and (sound? s1)
+ (sound? s2)))
+ (snd-display ";open-sound ~A or ~A failed?" snd1 snd2))
(let ((diff (spectral-difference s1 s2)))
(close-sound s1)
(close-sound s2)
(if (> diff maxok)
- (snd-display #__line__ ";translate spectral difference ~A ~A: ~A > ~A?" snd1 snd2 diff maxok)))))
+ (snd-display ";translate spectral difference ~A ~A: ~A > ~A?" snd1 snd2 diff maxok)))))
- (define (remove-if p l)
- (cond ((null? l) ())
- ((p (car l)) (remove-if p (cdr l)))
- (else (cons (car l) (remove-if p (cdr l))))))
+ (define (remove-if p lst)
+ (cond ((null? lst) ())
+ ((p (car lst)) (remove-if p (cdr lst)))
+ (else (cons (car lst) (remove-if p (cdr lst))))))
(if (null? (sound-file-extensions))
@@ -25064,206 +24565,203 @@ EDITS: 2
good-files)))
(sf-dir-len (if sf-dir-files (length sf-dir-files) 0)))
- (if (and with-gui
- (> sf-dir-len 0))
- (let ((open-files ())
- (open-ctr 0))
+ (when (and with-gui
+ (> sf-dir-len 0))
+ (let ((open-files ())
+ (open-ctr 0))
+
+ (add-sound-file-extension "wave")
+ (let ((exts (sound-file-extensions)))
+ (if (not (member "wave" exts))
+ (snd-display ";sound-file-extensions: ~A" exts))
+ (set! (sound-file-extensions) (list))
+ (if (pair? (sound-file-extensions))
+ (snd-display ";sound-file-extesions set to (): ~A" (sound-file-extensions)))
+ (set! (sound-file-extensions) exts)
+ (if (not (member "wave" exts))
+ (snd-display ";sound-file-extensions reset: ~A" (sound-file-extensions))))
+
+ (do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
+ (log-mem clmtest)
- (add-sound-file-extension "wave")
- (let ((exts (sound-file-extensions)))
- (if (not (member "wave" exts))
- (snd-display #__line__ ";sound-file-extensions: ~A" exts))
- (set! (sound-file-extensions) (list))
- (if (pair? (sound-file-extensions))
- (snd-display #__line__ ";sound-file-extesions set to (): ~A" (sound-file-extensions)))
- (set! (sound-file-extensions) exts)
- (if (not (member "wave" exts))
- (snd-display #__line__ ";sound-file-extensions reset: ~A" (sound-file-extensions))))
+ (do ()
+ ((= open-ctr 32))
+ (let ((len (length open-files)))
+ (if (or (= len 0) (> (random 1.0) .5))
+ (let* ((choice (floor (random sf-dir-len)))
+ (name (string-append sf-dir (sf-dir-files choice)))
+ (ht (catch #t (lambda () (mus-sound-header-type name)) (lambda args 0)))
+ (df (catch #t (lambda () (mus-sound-sample-type name)) (lambda args 0)))
+ (fd (if (or (= ht mus-raw)
+ (= ht mus-unknown-header)
+ (= df mus-unknown-sample))
+ -1
+ (or (catch #t
+ (lambda () (view-sound name))
+ (lambda args
+ (snd-display ";~A ~A ~A" name ht df)
+ -1))
+ -1))))
+ (if (not (eqv? fd -1))
+ (begin
+ (set! open-ctr (+ open-ctr 1))
+ (set! open-files (cons fd open-files)))))
+ (if (and (> len 0) (> (random 1.0) 0.3))
+ (let* ((choice (floor (random (* 1.0 (length open-files)))))
+ (fd (open-files choice)))
+ (close-sound fd)
+ (set! open-files (remove-if (lambda (a) (equal? a fd)) open-files)))))))
+ (if (pair? open-files) (for-each close-sound open-files))
+ (set! open-files ())
- (do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
- (log-mem clmtest)
-
- (do ()
- ((= open-ctr 32))
- (let ((len (length open-files)))
- (if (or (= len 0) (> (random 1.0) .5))
- (let* ((choice (floor (random sf-dir-len)))
- (name (string-append sf-dir (sf-dir-files choice)))
- (ht (catch #t (lambda () (mus-sound-header-type name)) (lambda args 0)))
- (df (catch #t (lambda () (mus-sound-sample-type name)) (lambda args 0)))
- (fd (if (or (= ht mus-raw)
- (= ht mus-unknown-header)
- (= df mus-unknown-sample))
- -1
- (or (catch #t
- (lambda () (view-sound name))
- (lambda args
- (snd-display #__line__ ";~A ~A ~A" name ht df)
- -1))
- -1))))
- (if (not (eqv? fd -1))
- (begin
- (set! open-ctr (+ open-ctr 1))
- (set! open-files (cons fd open-files)))))
- (if (and (> len 0) (> (random 1.0) 0.3))
- (let* ((choice (floor (random (* 1.0 (length open-files)))))
- (fd (open-files choice)))
- (close-sound fd)
- (set! open-files (remove-if (lambda (a) (equal? a fd)) open-files)))))))
- (if open-files (for-each close-sound open-files))
- (set! open-files ())
-
- (if (not (= (length (sounds)) 0)) (snd-display #__line__ ";active-sounds: ~A ~A?" (sounds) (map short-file-name (sounds))))
- (let ((fd (open-raw-sound :file (string-append sf-dir "addf8.nh") :channels 1 :srate 8012 :sample-type mus-mulaw)))
- (if (not (= (sample-type fd) mus-mulaw)) (snd-display #__line__ ";open-raw-sound: ~A?" (mus-sample-type-name (sample-type fd))))
- (close-sound fd))
-
- (set! (hook-functions bad-header-hook) ())
+ (if (pair? (sounds)) (snd-display ";active-sounds: ~A ~A?" (sounds) (map short-file-name (sounds))))
+ (let ((fd (open-raw-sound :file (string-append sf-dir "addf8.nh") :channels 1 :srate 8012 :sample-type mus-mulaw)))
+ (if (not (= (sample-type fd) mus-mulaw)) (snd-display ";open-raw-sound: ~A?" (mus-sample-type-name (sample-type fd))))
+ (close-sound fd))
+
+ (set! (hook-functions bad-header-hook) ())
; (time (test-spectral-difference "oboe.snd" (string-append sf-dir "oboe.g723_24") 20.0))
; (test-spectral-difference "oboe.snd" (string-append sf-dir "oboe.g723_40") 3.0)
; (test-spectral-difference "oboe.snd" (string-append sf-dir "oboe.g721") 6.0)
- (test-spectral-difference (string-append sf-dir "o2.wave") (string-append sf-dir "o2_dvi.wave") 10.0)
- (test-spectral-difference (string-append sf-dir "wood.riff") (string-append sf-dir "wood.sds") 4.0)
- (test-spectral-difference (string-append sf-dir "nist-10.wav") (string-append sf-dir "nist-shortpack.wav") 1.0)
- (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
-
- ;; dangling readers (overall)
- (let ((ind (open-sound "oboe.snd")))
- (let ((hi (make-sampler 0 ind 0)))
- (close-sound ind)
- (if (not (sampler? hi)) (snd-display #__line__ ";dangling reader? ~A" hi))
- (let ((name (format #f "~A" hi)))
- (if (not (string? name)) (snd-display #__line__ ";dangling reader format: ~A" name)))
- (let ((val (hi))
- (val1 (next-sample hi))
- (val2 (previous-sample hi))
- (val3 (read-sample hi)))
- (if (or (fneq val 0.0) (fneq val1 0.0) (fneq val2 0.0) (fneq val3 0.0))
- (snd-display #__line__ ";dangling read: ~A ~A ~A ~A" val val1 val2 val3))
- (if (sampler-home hi) (snd-display #__line__ ";dangling reader home: ~A" (sampler-home hi)))
- (if (not (= (sampler-position hi) 0)) (snd-display #__line__ ";dangling sampler-position: ~A" (sampler-position hi)))
- (if (not (sampler-at-end? hi)) (snd-display #__line__ ";dangling reader eof: ~A" (sampler-at-end? hi)))
- (free-sampler hi))))
- ;; same (pruned edit)
- (let ((ind (open-sound "oboe.snd")))
+ (test-spectral-difference (string-append sf-dir "o2.wave") (string-append sf-dir "o2_dvi.wave") 10.0)
+ (test-spectral-difference (string-append sf-dir "wood.riff") (string-append sf-dir "wood.sds") 4.0)
+ (test-spectral-difference (string-append sf-dir "nist-10.wav") (string-append sf-dir "nist-shortpack.wav") 1.0)
+ (hook-push bad-header-hook (lambda (hook) (set! (hook 'result) #t)))
+
+ ;; dangling readers (overall)
+ (let* ((ind (open-sound "oboe.snd"))
+ (hi (make-sampler 0 ind 0)))
+ (close-sound ind)
+ (if (not (sampler? hi)) (snd-display ";dangling reader? ~A" hi))
+ (let ((name (format #f "~A" hi)))
+ (if (not (string? name)) (snd-display ";dangling reader format: ~A" name)))
+ (let ((val (hi))
+ (val1 (next-sample hi))
+ (val2 (previous-sample hi))
+ (val3 (read-sample hi)))
+ (if (or (fneq val 0.0) (fneq val1 0.0) (fneq val2 0.0) (fneq val3 0.0))
+ (snd-display ";dangling read: ~A ~A ~A ~A" val val1 val2 val3)))
+ (if (sampler-home hi) (snd-display ";dangling reader home: ~A" (sampler-home hi)))
+ (if (not (= (sampler-position hi) 0)) (snd-display ";dangling sampler-position: ~A" (sampler-position hi)))
+ (if (not (sampler-at-end? hi)) (snd-display ";dangling reader eof: ~A" (sampler-at-end? hi)))
+ (free-sampler hi))
+ ;; same (pruned edit)
+ (let ((ind (open-sound "oboe.snd")))
+ (delete-samples 100 100)
+ (let ((hi (make-sampler 0 ind 0)))
+ (revert-sound)
(delete-samples 100 100)
- (let ((hi (make-sampler 0 ind 0)))
- (revert-sound)
- (delete-samples 100 100)
- (if (not (sampler? hi)) (snd-display #__line__ ";pruned dangling reader? ~A" hi))
- (let ((name (format #f "~A" hi)))
- (if (not (string? name)) (snd-display #__line__ ";pruned dangling reader format: ~A" name)))
- (let ((val (hi))
- (val1 (next-sample hi))
- (val2 (previous-sample hi))
- (val3 (read-sample hi)))
- (if (or (fneq val 0.0) (fneq val1 0.0) (fneq val2 0.0) (fneq val3 0.0))
- (snd-display #__line__ ";pruned dangling read: ~A ~A ~A ~A" val val1 val2 val3))
- (if (not (equal? (sampler-home hi) (list ind 0))) (snd-display #__line__ ";pruned dangling reader home: ~A" (sampler-home hi)))
- (if (not (sampler-at-end? hi)) (snd-display #__line__ ";pruned dangling reader eof: ~A" (sampler-at-end? hi)))
- (free-sampler hi)))
- (close-sound ind))
-
- ;; region reader
- (let ((ind (open-sound "2.snd")))
- (set! (sync ind) 1)
- (let ((reg (make-region 90 220 ind #t)))
- (if (not (= (region-framples reg) (+ 1 (- 220 90)))) (snd-display #__line__ ";make-region framples: ~A" (region-framples reg)))
- (if (not (= (region-chans reg) 2)) (snd-display #__line__ ";make-region chans: ~A" (region-chans reg)))
- (if (not (= (region-framples reg 0) (+ 1 (- 220 90)))) (snd-display #__line__ ";make-region framples[0]: ~A" (region-framples reg 0)))
- (if (not (= (region-framples reg 1) (+ 1 (- 220 90)))) (snd-display #__line__ ";make-region framples[1]: ~A" (region-framples reg 1)))
- (if (not (= (region-position reg 0) 90)) (snd-display #__line__ ";make-region position[0]: ~A" (region-position reg 0)))
- (if (not (= (region-position reg 1) 90)) (snd-display #__line__ ";make-region position[1]: ~A" (region-position reg 1)))
- (if (not (= (region-position reg) 90)) (snd-display #__line__ ";make-region position[]: ~A" (region-position reg)))
-
- ;; beg = 0, chan 2 not highlighted
-
- (let ((rd1 (make-region-sampler reg 0 0))
- (rd2 (make-region-sampler reg 100 1)))
- (let ((rd11 (copy-sampler rd1))
- (rd22 (copy-sampler rd2)))
- (if (or (not (region-sampler? rd11)) (not (region-sampler? rd22)))
- (snd-display #__line__ ";copy-sampler (region): ~A ~A" rd11 rd22))
- (if (or (mix-sampler? rd11) (mix-sampler? rd22)
- (sampler? rd11) (sampler? rd22))
- (snd-display #__line__ ";copy (region) sampler-p trouble: ~A ~A ~A ~A"
- (mix-sampler? rd11) (mix-sampler? rd22)
- (sampler? rd11) (sampler? rd22)))
- (if (or (not (equal? (sampler-home rd11) (list reg 0)))
- (not (equal? (sampler-home rd22) (list reg 1))))
- (snd-display #__line__ ";copy region reader home: ~A ~A" (sampler-home rd11) (sampler-home rd22)))
- (if (or (sampler-at-end? rd11) (sampler-at-end? rd22))
- (snd-display #__line__ ";copy region reader end?: ~A ~A" (sampler-at-end? rd11) (sampler-at-end? rd22)))
- (if (or (not (= (sampler-position rd11) (sampler-position rd1) 0))
- (not (= (sampler-position rd22) (sampler-position rd2) 100)))
- (snd-display #__line__ ";copy region reader position: ~A ~A ~A ~A"
- (sampler-position rd11) (sampler-position rd1)
- (sampler-position rd22) (sampler-position rd2)))
- (free-sampler rd1)
- (free-sampler rd11))))
- (close-sound ind))
-
+ (if (not (sampler? hi)) (snd-display ";pruned dangling reader? ~A" hi))
+ (let ((name (format #f "~A" hi)))
+ (if (not (string? name)) (snd-display ";pruned dangling reader format: ~A" name)))
+ (let ((val (hi))
+ (val1 (next-sample hi))
+ (val2 (previous-sample hi))
+ (val3 (read-sample hi)))
+ (if (or (fneq val 0.0) (fneq val1 0.0) (fneq val2 0.0) (fneq val3 0.0))
+ (snd-display ";pruned dangling read: ~A ~A ~A ~A" val val1 val2 val3)))
+ (if (not (equal? (sampler-home hi) (list ind 0))) (snd-display ";pruned dangling reader home: ~A" (sampler-home hi)))
+ (if (not (sampler-at-end? hi)) (snd-display ";pruned dangling reader eof: ~A" (sampler-at-end? hi)))
+ (free-sampler hi))
+ (close-sound ind))
+
+ ;; region reader
+ (let ((ind (open-sound "2.snd")))
+ (set! (sync ind) 1)
+ (let ((reg (make-region 90 220 ind #t)))
+ (if (not (= (region-framples reg) 131)) (snd-display ";make-region framples: ~A" (region-framples reg)))
+ (if (not (= (region-chans reg) 2)) (snd-display ";make-region chans: ~A" (region-chans reg)))
+ (if (not (= (region-framples reg 0) 131)) (snd-display ";make-region framples[0]: ~A" (region-framples reg 0)))
+ (if (not (= (region-framples reg 1) 131)) (snd-display ";make-region framples[1]: ~A" (region-framples reg 1)))
+ (if (not (= (region-position reg 0) 90)) (snd-display ";make-region position[0]: ~A" (region-position reg 0)))
+ (if (not (= (region-position reg 1) 90)) (snd-display ";make-region position[1]: ~A" (region-position reg 1)))
+ (if (not (= (region-position reg) 90)) (snd-display ";make-region position[]: ~A" (region-position reg)))
+
+ ;; beg = 0, chan 2 not highlighted
+
+ (let ((rd1 (make-region-sampler reg 0 0))
+ (rd2 (make-region-sampler reg 100 1)))
+ (let ((rd11 (copy-sampler rd1))
+ (rd22 (copy-sampler rd2)))
+ (if (not (and (region-sampler? rd11) (region-sampler? rd22)))
+ (snd-display ";copy-sampler (region): ~A ~A" rd11 rd22))
+ (if (or (mix-sampler? rd11) (mix-sampler? rd22)
+ (sampler? rd11) (sampler? rd22))
+ (snd-display ";copy (region) sampler-p trouble: ~A ~A ~A ~A"
+ (mix-sampler? rd11) (mix-sampler? rd22)
+ (sampler? rd11) (sampler? rd22)))
+ (if (not (and (equal? (sampler-home rd11) (list reg 0))
+ (equal? (sampler-home rd22) (list reg 1))))
+ (snd-display ";copy region reader home: ~A ~A" (sampler-home rd11) (sampler-home rd22)))
+ (if (or (sampler-at-end? rd11) (sampler-at-end? rd22))
+ (snd-display ";copy region reader end?: ~A ~A" (sampler-at-end? rd11) (sampler-at-end? rd22)))
+ (if (not (and (= (sampler-position rd11) (sampler-position rd1) 0)
+ (= (sampler-position rd22) (sampler-position rd2) 100)))
+ (snd-display ";copy region reader position: ~A ~A ~A ~A"
+ (sampler-position rd11) (sampler-position rd1)
+ (sampler-position rd22) (sampler-position rd2)))
+ (free-sampler rd1)
+ (free-sampler rd11))))
+ (close-sound ind))
+
+ (let* ((ind (open-sound "oboe.snd"))
+ (reg (make-region 1000 2000 ind 0))
+ (rd (make-region-sampler reg 0)))
+ (if (mix-sampler? rd) (snd-display ";region sampler: mix ~A" rd))
+ (if (not (region-sampler? rd)) (snd-display ";region sampler: region ~A" rd))
+ (if (sampler? rd) (snd-display ";region sampler: normal ~A" rd))
+ ;(if (not (= (sampler-position rd) 0)) (snd-display ";region sampler position: ~A" (sampler-position rd)))
+ (if (not (equal? (sampler-home rd) (list reg 0))) (snd-display ";region sampler home: ~A" (sampler-home rd)))
+ (if (sampler-at-end? rd) (snd-display ";region sampler at end?: ~A" (sampler-at-end? rd)))
+ (let ((val (rd)))
+ (if (fneq val .0328) (snd-display ";region-sampler at start: ~A" val))
+ (close-sound ind)
+ (forget-region reg)
+ (set! val (read-sample rd))
+ (if (fneq val 0.0) (snd-display ";region-sampler at end: ~A" val))
+ (if (not (sampler-at-end? rd)) (snd-display ";region-sampler after deletion?"))
+ (free-sampler rd)))
+
+ ;; mix reader
+ (let ()
+ (mix-click-sets-amp)
(let* ((ind (open-sound "oboe.snd"))
(reg (make-region 1000 2000 ind 0))
- (rd (make-region-sampler reg 0)))
- (if (mix-sampler? rd) (snd-display #__line__ ";region sampler: mix ~A" rd))
- (if (not (region-sampler? rd)) (snd-display #__line__ ";region sampler: region ~A" rd))
- (if (sampler? rd) (snd-display #__line__ ";region sampler: normal ~A" rd))
- ;(if (not (= (sampler-position rd) 0)) (snd-display #__line__ ";region sampler position: ~A" (sampler-position rd)))
- (if (not (equal? (sampler-home rd) (list reg 0))) (snd-display #__line__ ";region sampler home: ~A" (sampler-home rd)))
- (if (sampler-at-end? rd) (snd-display #__line__ ";region sampler at end?: ~A" (sampler-at-end? rd)))
+ (md (car (mix-region reg 0 ind 0 0)))
+ (rd (make-mix-sampler md)))
+ (set! (mix-property :hi md) "hi")
+ (if (not (string=? (mix-property :hi md) "hi")) (snd-display ";mix(9)-property: ~A" (mix-property :hi md)))
(let ((val (rd)))
- (if (fneq val .0328) (snd-display #__line__ ";region-sampler at start: ~A" val))
- (if (not (string? (format #f "~A" rd))) (snd-display #__line__ ";region-sampler: ~A" (format #f "~A" rd)))
- (close-sound ind)
- (forget-region reg)
- (set! val (read-sample rd))
- (if (fneq val 0.0) (snd-display #__line__ ";region-sampler at end: ~A" val))
- (if (not (sampler-at-end? rd)) (snd-display #__line__ ";region-sampler after deletion?"))
- (free-sampler rd)))
-
- ;; mix reader
- (let ()
- (mix-click-sets-amp)
- (let* ((ind (open-sound "oboe.snd"))
- (reg (make-region 1000 2000 ind 0))
- (md (car (mix-region reg 0 ind 0 0)))
- (rd (make-mix-sampler md)))
- (set! (mix-property :hi md) "hi")
- (if (not (string=? (mix-property :hi md) "hi")) (snd-display #__line__ ";mix(9)-property: ~A" (mix-property :hi md)))
- (let ((val (rd)))
- (if (fneq val .0328) (snd-display #__line__ ";mix-sampler at start: ~A" val))
- (if (not (string? (format #f "~A" rd))) (snd-display #__line__ ";mix-sampler: ~A" (format #f "~A" rd)))
- (close-sound ind)
- (let ((tag (catch #t
- (lambda () (mix-property :hi md))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-mix)) (snd-display #__line__ ";mix-property bad mix: ~A" tag)))
- (let ((str (format #f "~A" rd)))
- (if (not (string=? str "#<mix-sampler: inactive>")) (snd-display #__line__ ";mix-sampler released: ~A" str))
- (free-sampler rd)))))
- (set! (hook-functions mix-click-hook) ())
- (set! (hook-functions close-hook) ())
-
- (let ((sfiles ())
- (ffiles ()))
- (for-each-sound-file
- (lambda (file)
- (if (> (mus-sound-chans file) 16)
- (set! ffiles (cons file ffiles)))))
- (map-sound-files
- (lambda (file)
- (if (> (mus-sound-chans file) 16)
- (set! sfiles (cons file sfiles)))))
- (if (and (file-exists? "s24.snd")
- (or (not (equal? ffiles (list "s24.snd")))
- (not (equal? sfiles (list "s24.snd")))))
- (snd-display #__line__ ";map|for-each-sound-file(s): ~A ~A" ffiles sfiles)))
- )
+ (if (fneq val .0328) (snd-display ";mix-sampler at start: ~A" val)))
+ (close-sound ind)
+ (let ((tag (catch #t
+ (lambda () (mix-property :hi md))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-mix)) (snd-display ";mix-property bad mix: ~A" tag)))
+ (let ((str (format #f "~A" rd)))
+ (if (not (string=? str "#<mix-sampler: inactive>")) (snd-display ";mix-sampler released: ~A" str))
+ (free-sampler rd))))
+ (set! (hook-functions mix-click-hook) ())
+ (set! (hook-functions close-hook) ())
+
+ (let ((sfiles ())
+ (ffiles ()))
+ (for-each-sound-file
+ (lambda (file)
+ (if (> (mus-sound-chans file) 16)
+ (set! ffiles (cons file ffiles)))))
+ (map-sound-files
+ (lambda (file)
+ (if (> (mus-sound-chans file) 16)
+ (set! sfiles (cons file sfiles)))))
+ (if (and (file-exists? "s24.snd")
+ (not (and (equal? ffiles (list "s24.snd"))
+ (equal? sfiles (list "s24.snd")))))
+ (snd-display ";map|for-each-sound-file(s): ~A ~A" ffiles sfiles)))
+ )
; (if sf-dir-files
; (for-each (lambda (n) (mus-sound-forget (string-append sf-dir n))) sf-dir-files))
-
- ))))
+ ))))
@@ -25274,120 +24772,89 @@ EDITS: 2
(if (and (provided? 'snd-motif) (provided? 'xm) (not (provided? 'snd-new-effects.scm))) (load "new-effects.scm"))
(if (and (provided? 'snd-gtk) (provided? 'xg) (not (provided? 'snd-gtk-effects.scm))) (load "gtk-effects.scm"))
-(if (provided? 'snd-ladspa)
- (define (analyze-ladspa library label)
- (let* ((descriptor (ladspa-descriptor library label))
- (data ())
- (names (.PortNames descriptor))
- (hints (.PortRangeHints descriptor))
- (descriptors (.PortDescriptors descriptor))
- (name (.Name descriptor))
- (maker (.Maker descriptor))
- (copy (.Copyright descriptor)))
- (for-each
- (lambda (port ranges port-name)
- (if (and (not (= (logand port LADSPA_PORT_CONTROL) 0))
- (not (= (logand port LADSPA_PORT_INPUT) 0)))
- (let ((ldata ())
- (hint (car ranges))
- (lo (cadr ranges))
- (hi (caddr ranges)))
- (if (not (= (logand hint LADSPA_HINT_TOGGLED) 0)) (set! ldata (cons "toggle" ldata)))
- (if (not (= (logand hint LADSPA_HINT_LOGARITHMIC) 0)) (set! ldata (cons "logarithmic" ldata)))
- (if (not (= (logand hint LADSPA_HINT_INTEGER) 0)) (set! ldata (cons "integer" ldata)))
- (if (not (= (logand hint LADSPA_HINT_SAMPLE_RATE) 0)) (set! ldata (cons "sample_rate" ldata)))
- (if (not (= (logand hint LADSPA_HINT_BOUNDED_ABOVE) 0))
- (set! ldata (cons "maximum" (cons hi ldata))))
- (if (not (= (logand hint LADSPA_HINT_BOUNDED_BELOW) 0) )
- (set! ldata (cons "minimum" (cons lo ldata))))
- (set! ldata (cons port-name ldata))
- (set! data (cons ldata data)))))
- descriptors hints names)
- (append (list name maker copy) data))))
-
-(if (provided? 'snd-ladspa)
- (define* (ladspa-it library label :rest plugin-parameters)
- ;; (ladspa-it "delay" "delay_5s" .3 .5)
- (init-ladspa)
- (let* ((descriptor (ladspa-descriptor library label))
- (handle (ladspa-instantiate descriptor (srate)))
- (block-size 256)
- (in-block (make-float-vector block-size))
- (out-block (make-float-vector block-size))
- (len (framples))
- (ra (ladspa-run-adding descriptor handle block-size)))
- (if ra (snd-display #__line__ ";ladspa-run-adding: ~A" ra))
- (ladspa-set-run-adding-gain descriptor handle block-size)
- (dynamic-wind
- (lambda ()
- (let ((count 0))
- (for-each
- (lambda (port)
- (if (not (= (logand port LADSPA_PORT_CONTROL) 0))
- (let ((parameter (make-float-vector 1 (car plugin-parameters))))
- (set! plugin-parameters (cdr plugin-parameters))
- (ladspa-connect-port descriptor handle count parameter))
- (if (not (= (logand port LADSPA_PORT_INPUT) 0))
- (ladspa-connect-port descriptor handle count in-block)
- (ladspa-connect-port descriptor handle count out-block)))
- (set! count (+ 1 count)))
- (.PortDescriptors descriptor))))
- (lambda ()
- (ladspa-activate descriptor handle)
- (catch #t
- (lambda ()
- (do ((i 0 (+ i block-size)))
- ((>= i len))
- (set! in-block (channel->float-vector i block-size))
- (ladspa-run descriptor handle block-size)
- ;; here do something with the data
- ))
- (lambda args (snd-display #__line__ ";ladspa-it: ~A" args))))
- (lambda ()
- (ladspa-deactivate descriptor handle)
- (ladspa-cleanup descriptor handle))))))
-
-
+(when (provided? 'snd-ladspa)
+ (define (analyze-ladspa library label)
+ (let* ((descriptor (ladspa-descriptor library label))
+ (data ())
+ (names (.PortNames descriptor))
+ (hints (.PortRangeHints descriptor))
+ (descriptors (.PortDescriptors descriptor))
+ (name (.Name descriptor))
+ (maker (.Maker descriptor))
+ (copy (.Copyright descriptor)))
+ (for-each
+ (lambda (port ranges port-name)
+ (unless (or (= (logand port LADSPA_PORT_CONTROL) 0)
+ (= (logand port LADSPA_PORT_INPUT) 0))
+ (let ((ldata ())
+ (hint (car ranges))
+ (lo (cadr ranges))
+ (hi (caddr ranges)))
+ (if (not (= (logand hint LADSPA_HINT_TOGGLED) 0)) (set! ldata (cons "toggle" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_LOGARITHMIC) 0)) (set! ldata (cons "logarithmic" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_INTEGER) 0)) (set! ldata (cons "integer" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_SAMPLE_RATE) 0)) (set! ldata (cons "sample_rate" ldata)))
+ (if (not (= (logand hint LADSPA_HINT_BOUNDED_ABOVE) 0))
+ (set! ldata (cons "maximum" (cons hi ldata))))
+ (if (not (= (logand hint LADSPA_HINT_BOUNDED_BELOW) 0) )
+ (set! ldata (cons "minimum" (cons lo ldata))))
+ (set! ldata (cons port-name ldata))
+ (set! data (cons ldata data)))))
+ descriptors hints names)
+ (append (list name maker copy) data)))
+
+ (define* (ladspa-it library label :rest plugin-parameters)
+ ;; (ladspa-it "delay" "delay_5s" .3 .5)
+ (init-ladspa)
+ (let* ((descriptor (ladspa-descriptor library label))
+ (handle (ladspa-instantiate descriptor (srate)))
+ (block-size 256)
+ (in-block (make-float-vector block-size))
+ (out-block (make-float-vector block-size))
+ (len (framples))
+ (ra (ladspa-run-adding descriptor handle block-size)))
+ (if ra (snd-display ";ladspa-run-adding: ~A" ra))
+ (ladspa-set-run-adding-gain descriptor handle block-size)
+ (dynamic-wind
+ (lambda ()
+ (let ((count 0))
+ (for-each
+ (lambda (port)
+ (if (= (logand port LADSPA_PORT_CONTROL) 0)
+ (ladspa-connect-port descriptor handle count (if (not (= (logand port LADSPA_PORT_INPUT) 0)) in-block out-block))
+ (let ((parameter (make-float-vector 1 (car plugin-parameters))))
+ (set! plugin-parameters (cdr plugin-parameters))
+ (ladspa-connect-port descriptor handle count parameter)))
+ (set! count (+ 1 count)))
+ (.PortDescriptors descriptor))))
+ (lambda ()
+ (ladspa-activate descriptor handle)
+ (catch #t
+ (lambda ()
+ (do ((i 0 (+ i block-size)))
+ ((>= i len))
+ (set! in-block (channel->float-vector i block-size))
+ (ladspa-run descriptor handle block-size)
+ ;; here do something with the data
+ ))
+ (lambda args (snd-display ";ladspa-it: ~A" args))))
+ (lambda ()
+ (ladspa-deactivate descriptor handle)
+ (ladspa-cleanup descriptor handle))))))
-(define ladspa_inited #f)
-(define clm_buffer_added #f)
(define (snd_test_13)
+ (define ladspa_inited #f)
+ (define clm_buffer_added #f)
+
(define (test-hooks)
- (define (arg0 hook) (set! (hook 'result) 32))
- (define (arg1 hook) (let ((n (hook (car (hook 'args))))) (set! (hook 'result) (if (number? n) (+ n 32) n))))
- (define (arg2 hook) (let ((n (hook (car (hook 'args)))) (m (hook (cadr (hook 'args))))) (set! (hook 'result) (if (and (number? n) (number? m)) (+ n m 32) n))))
- (define (arg3 hook)
- (let ((a (hook (list-ref (hook 'args) 0)))
- (b (hook (list-ref (hook 'args) 1)))
- (c (hook (list-ref (hook 'args) 2))))
- (set! (hook 'result) (if (and (number? a) (number? b) (number? c)) (+ a b c 32) a))))
- (define (arg4 hook)
- (let ((a (hook (list-ref (hook 'args) 0)))
- (b (hook (list-ref (hook 'args) 1)))
- (c (hook (list-ref (hook 'args) 2)))
- (d (hook (list-ref (hook 'args) 3))))
- (set! (hook 'result) (if (and (number? a) (number? b) (number? c) (number? d)) (+ a b c 32) a))))
- (define (arg5 hook)
- (set! (hook 'result) (list 0 0 1 1)))
- (define (arg6 hook)
- (let ((a (hook (list-ref (hook 'args) 0)))
- (b (hook (list-ref (hook 'args) 1)))
- (c (hook (list-ref (hook 'args) 2)))
- (d (hook (list-ref (hook 'args) 3)))
- (e (hook (list-ref (hook 'args) 4)))
- (f (hook (list-ref (hook 'args) 5))))
- (set! (hook 'result) (if (and (number? a) (number? b) (number? c) (number? d) (number? e)) (+ a b c d e f 32) a))))
(reset-all-hooks)
-
(for-each
(lambda (n)
(if (pair? (hook-functions n))
- (snd-display #__line__ ";~A not empty?" n)))
- (snd-hooks))
-
- )
+ (snd-display ";~A not empty?" n)))
+ (snd-hooks)))
(define (test-menus)
(if (provided? 'xm)
@@ -25403,18 +24870,16 @@ EDITS: 2
((*motif* 'XtIsManaged) menu)
((*motif* 'XtIsSensitive) menu)
(not (member ((*motif* 'XtName) menu)
- (list "Exit" "New"
- "Save C-x C-s"
- "Close C-x k"
- "Close all"
- "Save current settings"
- "Mixes" "clm" "fm-violin"))))
+ '("Exit" "New"
+ "Save C-x C-s"
+ "Close C-x k"
+ "Close all"
+ "Save current settings"
+ "Mixes" "clm" "fm-violin"))))
((*motif* 'XtCallCallbacks) menu (*motif* 'XmNactivateCallback) (snd-global-state))))))))))
(for-each close-sound (sounds))
(dismiss-all-dialogs))
- (define (mdt-test id x time drg) #f)
-
(reset-all-hooks)
(let ((fd (view-sound "oboe.snd")))
@@ -25425,13 +24890,13 @@ EDITS: 2
(let ((var (catch #t (lambda () (add-to-menu -1 "fm-violin" (lambda () #f))) (lambda args args))))
(if (not (eq? (car var) 'no-such-menu))
- (snd-display #__line__ ";add-to-menu bad menu: ~A" var)))
+ (snd-display ";add-to-menu bad menu: ~A" var)))
(set! (cursor fd) 2000)
(set! *transform-graph-type* graph-once)
(set! (transform-graph? fd) #t)
(if (not clm_buffer_added)
(begin
- (add-to-menu mb "not here" (lambda () (snd-display #__line__ ";oops")))
+ (add-to-menu mb "not here" (lambda () (snd-display ";oops")))
(remove-from-menu mb "not here")
(add-to-menu 3 "Denoise" (lambda () (status-report "denoise")))))
@@ -25443,18 +24908,18 @@ EDITS: 2
(let ((a (hook (list-ref (hook 'args) 0)))
(b (hook (list-ref (hook 'args) 1))))
(if (not (string=? a "cursor-position"))
- (snd-display #__line__ ";help-hook subject: ~A" a))
+ (snd-display ";help-hook subject: ~A" a))
(if (not (string=? b "(cursor-position :optional snd chn): current cursor position (x y in pixels) in snd's channel chn"))
- (snd-display #__line__ ";help-hook text: ~A" b))
+ (snd-display ";help-hook text: ~A" b))
(set! (hook 'result) (string-append "hiho:" b)))))
(let ((ho (snd-help 'cursor-position)))
(if (not (= (length ho) (+ 5 (length hi))))
- (snd-display #__line__ ";help-hook ~A -> ~A" hi ho))
+ (snd-display ";help-hook ~A -> ~A" hi ho))
(set! (hook-functions help-hook) ())
(hook-push help-hook (lambda (hook) (set! (hook 'result) #f)))
(set! ho (snd-help 'cursor-position))
(if (not (string=? hi ho))
- (snd-display #__line__ ";help-hook #f: ~A ~A" hi ho))
+ (snd-display ";help-hook #f: ~A ~A" hi ho))
(set! (hook-functions help-hook) ())))
(set! (transform-size fd 0) 256)
(when with-motif
@@ -25465,12 +24930,12 @@ EDITS: 2
(update-transform-graph fd 0)
(let ((vals (transform->float-vector fd 0)))
(if (not vals)
- (snd-display #__line__ ";transform graph-type: ~A type: ~A -> data: ~A" dpy-type fft-type vals)
+ (snd-display ";transform graph-type: ~A type: ~A -> data: ~A" dpy-type fft-type vals)
(begin
(if (fneq (transform-sample 0 0 fd 0) (vals 0))
- (snd-display #__line__ ";transform-sample ~A ~A -> ~A ~A" dpy-type fft-type (vals 0) (transform-sample 0 0 fd 0)))
+ (snd-display ";transform-sample ~A ~A -> ~A ~A" dpy-type fft-type (vals 0) (transform-sample 0 0 fd 0)))
(if (< (length vals) 256)
- (snd-display #__line__ ";transform-> float-vector size: ~A" (length vals)))))))
+ (snd-display ";transform-> float-vector size: ~A" (length vals)))))))
(list graph-once graph-as-sonogram graph-as-spectrogram
graph-once graph-as-sonogram graph-as-spectrogram)
(list fourier-transform fourier-transform fourier-transform
@@ -25481,7 +24946,7 @@ EDITS: 2
(transform-sample 5000 0 fd 0))
(lambda args (car args)))))
(if (not (eq? tag 'no-such-sample))
- (snd-display #__line__ ";access invalid (bin) transform sample: ~A" tag))))
+ (snd-display ";access invalid (bin) transform sample: ~A" tag))))
(close-sound fd)
(set! *transform-type* fourier-transform)
@@ -25504,7 +24969,7 @@ EDITS: 2
(let* ((amp-vals (mus-sound-maxamp (file-name snd)))
(max-val (amp-vals (+ (* chn 2) 1))))
(set! (hook 'result) (list 0.0 dur (- max-val) max-val)))
- (set! (hook 'result) (list 0.0 dur -1.0 1.0))))))
+ (set! (hook 'result) (list 0.0 dur -1.0 1.0))))))
(set! (hook-functions after-open-hook) ())
(set! (hook-functions initial-graph-hook) ())
@@ -25522,12 +24987,12 @@ EDITS: 2
(fneq (ax 7) -4.0)
(fneq (ax 8) (mus-sound-duration "2.snd"))
(fneq (ax 9) 4.0)))
- (snd-display #__line__ ";initial-graph-hook with ymin/max: ~A" ax))
+ (snd-display ";initial-graph-hook with ymin/max: ~A" ax))
(set! (hook-functions initial-graph-hook) ()))
(set! (selection-position fd 1) 1000)
(set! (selection-framples fd 1) 10)
(set! (selection-member? fd 1) #t)
- (if (selection-member? fd 0) (snd-display #__line__ ";chan 0 is selection-member?"))
+ (if (selection-member? fd 0) (snd-display ";chan 0 is selection-member?"))
(do ((i 0 (+ i 1))) ((= i 2))
(set! (selection-position fd i) 1000)
(set! (selection-framples fd i) 10)
@@ -25535,163 +25000,162 @@ EDITS: 2
(scale-selection-to (float-vector .5 .25))
(if (or (fneq (maxamp fd 0) .5)
(fneq (maxamp fd 1) .25))
- (snd-display #__line__ ";scale-selection-to with vector: ~A" (maxamp fd #t)))
+ (snd-display ";scale-selection-to with vector: ~A" (maxamp fd #t)))
(close-sound fd)
(set! fd (open-sound "obtest.snd"))
(let ()
+ (set! (hook-functions close-hook) ())
+ (set! *with-background-processes* #t)
(let ((added 0))
- (set! (hook-functions close-hook) ())
- (set! *with-background-processes* #t)
(hook-push new-widget-hook
(lambda (hook)
- (set! added (+ added 1))))
- (if (provided? 'snd-motif)
- (without-errors
- (test-menus)))
+ (set! added (+ added 1)))))
+ (if (provided? 'snd-motif)
+ (without-errors
+ (test-menus)))
+ (dismiss-all-dialogs)
+ (set! (hook-functions close-hook) ())
+ (for-each close-sound (sounds))
+ (if (sound? fd)
+ (begin
+ (snd-display ";close all didn't? ~A ~A ~A ~A ~A" fd (sound? fd) (short-file-name fd) (hook-functions close-hook) (sounds))
+ (close-sound fd)))
+ (set! fd (open-sound "obtest.snd"))
+ (set! *with-background-processes* #f)
+ (set! (hook-functions new-widget-hook) ())
+
+ (when (and (not ladspa_inited)
+ (provided? 'snd-ladspa)
+ (file-exists? "/home/bil/test/ladspa/ladspa_sdk/plugins"))
+ (set! ladspa_inited #t)
+ (set! *ladspa-dir* "/home/bil/test/ladspa/ladspa_sdk/plugins")
+ (init-ladspa)
+ (let* ((ptr (ladspa-descriptor "delay" "delay_5s"))
+ (label (.Label ptr))
+ (name (.Name ptr))
+ (copy (.Copyright ptr))
+ (maker (.Maker ptr))
+ (props (.Properties ptr))
+ (id (.UniqueID ptr))
+ (names (.PortNames ptr))
+ (hints (.PortRangeHints ptr))
+ (count (.PortCount ptr))
+ (descs (.PortDescriptors ptr)))
+ (if (not (string=? label "delay_5s"))
+ (snd-display ";ladspa .Label: ~A" label))
+ (if (not (string=? name "Simple Delay Line"))
+ (snd-display ";ladspa .Name: ~A" name))
+ (if (not (string=? maker "Richard Furse (LADSPA example plugins)"))
+ (snd-display ";ladspa .Maker: ~A" maker))
+ (if (not (string=? copy "None"))
+ (snd-display ";ladspa .Copyright: ~A" copy))
+ (if (not (= id 1043)) (snd-display ";ladspa .UniqueID: ~A" id))
+ (if (not (= count 4)) (snd-display ";ladspa .PortCount: ~A" count))
+ (if (not (= props 4)) (snd-display ";ladspa .Properties: ~A" prop))
+ (if (not (equal? names (list "Delay (Seconds)" "Dry/Wet Balance" "Input" "Output")))
+ (snd-display ";ladspa .PortNames: ~A" names))
+ (if (not (equal? hints (list (list 579 0.0 5.0) (list 195 0.0 1.0) (list 0 0.0 0.0) (list 0 0.0 0.0))))
+ (snd-display ";ladspa .PortRangeHints: ~A" hints))
+ (if (not (equal? descs (list 5 5 9 10)))
+ (snd-display ";ladspa .PortDescriptors: ~A" descs))
+ (if (not (= (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT) 1))
+ (snd-display ";ladspa port hint: ~A" (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT))))
+ (apply-ladspa (make-sampler 0) (list "delay" "delay_5s" .3 .5) 1000 "delayed")
+ (if (not (equal? (analyze-ladspa "delay" "delay_5s")
+ (list "Simple Delay Line" "Richard Furse (LADSPA example plugins)" "None" (list "Dry/Wet Balance" "minimum" 0.0 "maximum" 1.0) (list "Delay (Seconds)" "minimum" 0.0 "maximum" 5.0))))
+ (snd-display ";analyze-ladspa: ~A" (analyze-ladspa "delay" "delay_5s")))
+ (ladspa-it "delay" "delay_5s" .3 .5)
+ (if (provided? 'xm)
+ (let ((w ((menu-widgets) 5)))
+ (if (and (list? w)
+ (not (XmIsRowColumn w)))
+ (let ((option-holder (cadr (XtGetValues w (list XmNsubMenuId 0)))))
+ (for-each-child
+ option-holder
+ (lambda (menu)
+ (if (and (XmIsPushButton menu)
+ (XtIsSensitive menu)
+ (string=? (XtName menu) "Plugins"))
+ (XtCallCallbacks menu XmNactivateCallback (snd-global-state)))))))))
(dismiss-all-dialogs)
- (set! (hook-functions close-hook) ())
- (for-each close-sound (sounds))
- (if (sound? fd)
- (begin
- (snd-display #__line__ ";close all didn't? ~A ~A ~A ~A ~A" fd (sound? fd) (short-file-name fd) (hook-functions close-hook) (sounds))
- (close-sound fd)))
- (set! fd (open-sound "obtest.snd"))
- (set! *with-background-processes* #f)
- (set! (hook-functions new-widget-hook) ()))
-
- (if (and (not ladspa_inited)
- (provided? 'snd-ladspa)
- (file-exists? "/home/bil/test/ladspa/ladspa_sdk/plugins"))
- (begin
- (set! ladspa_inited #t)
- (set! *ladspa-dir* "/home/bil/test/ladspa/ladspa_sdk/plugins")
- (init-ladspa)
- (let* ((ptr (ladspa-descriptor "delay" "delay_5s"))
- (label (.Label ptr))
- (name (.Name ptr))
- (copy (.Copyright ptr))
- (maker (.Maker ptr))
- (props (.Properties ptr))
- (id (.UniqueID ptr))
- (names (.PortNames ptr))
- (hints (.PortRangeHints ptr))
- (count (.PortCount ptr))
- (descs (.PortDescriptors ptr)))
- (if (not (string=? label "delay_5s"))
- (snd-display #__line__ ";ladspa .Label: ~A" label))
- (if (not (string=? name "Simple Delay Line"))
- (snd-display #__line__ ";ladspa .Name: ~A" name))
- (if (not (string=? maker "Richard Furse (LADSPA example plugins)"))
- (snd-display #__line__ ";ladspa .Maker: ~A" maker))
- (if (not (string=? copy "None"))
- (snd-display #__line__ ";ladspa .Copyright: ~A" copy))
- (if (not (= id 1043)) (snd-display #__line__ ";ladspa .UniqueID: ~A" id))
- (if (not (= count 4)) (snd-display #__line__ ";ladspa .PortCount: ~A" count))
- (if (not (= props 4)) (snd-display #__line__ ";ladspa .Properties: ~A" prop))
- (if (not (equal? names (list "Delay (Seconds)" "Dry/Wet Balance" "Input" "Output")))
- (snd-display #__line__ ";ladspa .PortNames: ~A" names))
- (if (not (equal? hints (list (list 579 0.0 5.0) (list 195 0.0 1.0) (list 0 0.0 0.0) (list 0 0.0 0.0))))
- (snd-display #__line__ ";ladspa .PortRangeHints: ~A" hints))
- (if (not (equal? descs (list 5 5 9 10)))
- (snd-display #__line__ ";ladspa .PortDescriptors: ~A" descs))
- (if (not (= (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT) 1))
- (snd-display #__line__ ";ladspa port hint: ~A" (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT))))
- (apply-ladspa (make-sampler 0) (list "delay" "delay_5s" .3 .5) 1000 "delayed")
- (if (not (equal? (analyze-ladspa "delay" "delay_5s")
- (list "Simple Delay Line" "Richard Furse (LADSPA example plugins)" "None" (list "Dry/Wet Balance" "minimum" 0.0 "maximum" 1.0) (list "Delay (Seconds)" "minimum" 0.0 "maximum" 5.0))))
- (snd-display #__line__ ";analyze-ladspa: ~A" (analyze-ladspa "delay" "delay_5s")))
- (ladspa-it "delay" "delay_5s" .3 .5)
- (if (provided? 'xm)
- (let ((w ((menu-widgets) 5)))
- (if (and (list? w)
- (not (XmIsRowColumn w)))
- (let ((option-holder (cadr (XtGetValues w (list XmNsubMenuId 0)))))
- (for-each-child
- option-holder
- (lambda (menu)
- (if (and (XmIsPushButton menu)
- (XtIsSensitive menu)
- (string=? (XtName menu) "Plugins"))
- (XtCallCallbacks menu XmNactivateCallback (snd-global-state)))))))))
- (dismiss-all-dialogs)
- (let ((tag (catch #t
- (lambda ()
- (apply-ladspa (make-sampler 0) (list "delay" "delay_4s" .3 .5) 1000 "delayed"))
- (lambda args args))))
- (if (not (eq? (car tag) 'no-such-plugin))
- (snd-display #__line__ ";apply-ladspa bad plugin: ~A" tag)))
- (let ((tag (catch #t
- (lambda ()
- (apply-ladspa (list (make-sampler 0) (make-sampler 0)) (list "delay" "delay_5s" .3 .5) 1000 "delayed"))
- (lambda args args))))
- (if (not (eq? (car tag) 'plugin-error))
- (snd-display #__line__ ";apply-ladspa reader mismatch: ~A" tag)))
- (let ((vals (list-ladspa)))
- (if (not (pair? vals))
- (snd-display #__line__ ";ladspa list: ~A" vals))
- (let ((descr (analyse-ladspa "delay" "delay_5s")))
- (if (or (not (pair? descr))
- (not (string? (car descr)))
- (not (string=? (car descr) "Simple Delay Line")))
- (snd-display #__line__ ";analyse-ladspa: ~A" descr))))
- (let ((tag (catch #t
- (lambda () (analyse-ladspa "delay" "delay_no_delay"))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-plugin)) (snd-display #__line__ ";analyse-ladspa tag: ~A" tag)))
- (let ((tag (catch #t
- (lambda ()
- (apply-ladspa (list (make-sampler 0) (make-sampler 0)) (list #f) 1000 "delayed"))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";apply-ladspa tag: ~A" tag)))
-
- (set! *ladspa-dir* "/home/bil/test/ladspa/vocoder-0.3")
- (init-ladspa)
- (if (not (equal? (list-ladspa) (list (list "vocoder" "vocoder"))))
- (snd-display #__line__ ";list-ladspa vocoder: ~A" (list-ladspa)))
- (if (not (list? (analyze-ladspa "vocoder" "vocoder")))
- (snd-display #__line__ ";analyze-ladspa vocoder: ~A" (analyze-ladspa "vocoder" "vocoder")))
- (let ((hi (ladspa-descriptor "vocoder" "vocoder")))
- (if (not (string=? (.Name hi) "Vocoder"))
- (snd-display #__line__ ";ladspa vocoder name: ~A" (.Name hi))))
-
- (let ((snd (open-sound "1a.snd")))
- (apply-ladspa (list (make-sampler 0) (make-sampler 0))
- (list "vocoder" "vocoder" 12 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)
- (framples) "vocoder")
- (undo)
-
- (set! *ladspa-dir* "/home/bil/test/ladspa/lib/ladspa")
- (init-ladspa)
- (for-each (lambda (plug) (apply analyse-ladspa plug)) (list-ladspa))
-
- (if (not (list? (analyse-ladspa "amp_1181" "amp")))
- (snd-display #__line__ ";analyze-ladspa can't find amp_1181"))
-
- (apply-ladspa (make-sampler 0) (list "amp_1181" "amp" -6) (framples) "amp")
- (apply-ladspa (make-sampler 0) (list "amp_1181" "amp" 6) (framples) "amp")
- (close-sound snd))
-
- (let ((snd (open-sound "2a.snd")))
-
- (let ((tag
- (catch #t
- (lambda ()
- (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 1))
- (list "amp_1181" "amp" 6 -6) (framples) "amp"))
- (lambda args (car args)))))
- (if (not (eq? tag 'plugin-error))
- (snd-display #__line__ ";apply-ladspa bad inputs: ~A" tag)))
-
- (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 0))
- (list "ringmod_1188" "ringmod_2i1o" 1) (framples) "ringmod")
- (apply-ladspa #f (list "analogue_osc_1416" "analogueOsc" 2 440.0 0.1 0.0) (framples) "osc")
- (apply-ladspa #f (list "sin_cos_1881" "sinCos" 440.0 1.0) (framples) "sincos")
- (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 1))
- (list "dj_eq_1901" "dj_eq" -6 0 6) (framples) "djeq")
- (close-sound snd)))
- ))
+ (let ((tag (catch #t
+ (lambda ()
+ (apply-ladspa (make-sampler 0) (list "delay" "delay_4s" .3 .5) 1000 "delayed"))
+ (lambda args args))))
+ (if (not (eq? (car tag) 'no-such-plugin))
+ (snd-display ";apply-ladspa bad plugin: ~A" tag)))
+ (let ((tag (catch #t
+ (lambda ()
+ (apply-ladspa (list (make-sampler 0) (make-sampler 0)) (list "delay" "delay_5s" .3 .5) 1000 "delayed"))
+ (lambda args args))))
+ (if (not (eq? (car tag) 'plugin-error))
+ (snd-display ";apply-ladspa reader mismatch: ~A" tag)))
+ (let ((vals (list-ladspa)))
+ (if (not (pair? vals))
+ (snd-display ";ladspa list: ~A" vals))
+ (let ((descr (analyse-ladspa "delay" "delay_5s")))
+ (if (not (and (pair? descr)
+ (string? (car descr))
+ (string=? (car descr) "Simple Delay Line")))
+ (snd-display ";analyse-ladspa: ~A" descr))))
+ (let ((tag (catch #t
+ (lambda () (analyse-ladspa "delay" "delay_no_delay"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-plugin)) (snd-display ";analyse-ladspa tag: ~A" tag)))
+ (let ((tag (catch #t
+ (lambda ()
+ (apply-ladspa (list (make-sampler 0) (make-sampler 0)) (list #f) 1000 "delayed"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";apply-ladspa tag: ~A" tag)))
+
+ (set! *ladspa-dir* "/home/bil/test/ladspa/vocoder-0.3")
+ (init-ladspa)
+ (if (not (equal? (list-ladspa) (list (list "vocoder" "vocoder"))))
+ (snd-display ";list-ladspa vocoder: ~A" (list-ladspa)))
+ (if (not (list? (analyze-ladspa "vocoder" "vocoder")))
+ (snd-display ";analyze-ladspa vocoder: ~A" (analyze-ladspa "vocoder" "vocoder")))
+ (let ((hi (ladspa-descriptor "vocoder" "vocoder")))
+ (if (not (string=? (.Name hi) "Vocoder"))
+ (snd-display ";ladspa vocoder name: ~A" (.Name hi))))
+
+ (let ((snd (open-sound "1a.snd")))
+ (apply-ladspa (list (make-sampler 0) (make-sampler 0))
+ (list "vocoder" "vocoder" 12 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)
+ (framples) "vocoder")
+ (undo)
+
+ (set! *ladspa-dir* "/home/bil/test/ladspa/lib/ladspa")
+ (init-ladspa)
+ (for-each (lambda (plug) (apply analyse-ladspa plug)) (list-ladspa))
+
+ (if (not (list? (analyse-ladspa "amp_1181" "amp")))
+ (snd-display ";analyze-ladspa can't find amp_1181"))
+
+ (apply-ladspa (make-sampler 0) (list "amp_1181" "amp" -6) (framples) "amp")
+ (apply-ladspa (make-sampler 0) (list "amp_1181" "amp" 6) (framples) "amp")
+ (close-sound snd))
+
+ (let ((snd (open-sound "2a.snd")))
+
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 1))
+ (list "amp_1181" "amp" 6 -6) (framples) "amp"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'plugin-error))
+ (snd-display ";apply-ladspa bad inputs: ~A" tag)))
+
+ (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 0))
+ (list "ringmod_1188" "ringmod_2i1o" 1) (framples) "ringmod")
+ (apply-ladspa #f (list "analogue_osc_1416" "analogueOsc" 2 440.0 0.1 0.0) (framples) "osc")
+ (apply-ladspa #f (list "sin_cos_1881" "sinCos" 440.0 1.0) (framples) "sincos")
+ (apply-ladspa (list (make-sampler 0 snd 0) (make-sampler 0 snd 1))
+ (list "dj_eq_1901" "dj_eq" -6 0 6) (framples) "djeq")
+ (close-sound snd)))
+ )
(revert-sound fd)
(close-sound fd)
@@ -25709,9 +25173,9 @@ EDITS: 2
(key (char->integer #\x) 4 ind)
(key (char->integer #\z) 4 ind)
(if (not (equal? (edit-fragment) (list "smooth-channel 2000 100" "set" 2000 100)))
- (snd-display #__line__ ";C-x C-z fragment: ~A" (edit-fragment)))
+ (snd-display ";C-x C-z fragment: ~A" (edit-fragment)))
(if (not (vequal (channel->float-vector 2010 10) (float-vector 0.064 0.063 0.063 0.062 0.062 0.061 0.060 0.059 0.059 0.058)))
- (snd-display #__line__ ";C-x C-z samps: ~A" (channel->float-vector 2010 10)))
+ (snd-display ";C-x C-z samps: ~A" (channel->float-vector 2010 10)))
(set! (cursor) 0)
(select-all)
(key (char->integer #\x) 4 ind)
@@ -25728,42 +25192,42 @@ EDITS: 2
(set! (search-procedure) (lambda (n4) (> n4 .1)))
(key (char->integer #\a) 4 ind 0)
(if (not (= (cursor ind 0) 0))
- (snd-display #__line__ ";C-a cursor: ~D?" (cursor ind 0)))
+ (snd-display ";C-a cursor: ~D?" (cursor ind 0)))
(key (char->integer #\s) 4 ind 0)
(key (char->integer #\s) 4 ind 0)
(if (not (= (cursor ind 0) 4423))
- (snd-display #__line__ ";search-procedure C-s C-s cursor: ~D?" (cursor ind 0)))
+ (snd-display ";search-procedure C-s C-s cursor: ~D?" (cursor ind 0)))
(let ((str (with-output-to-string (lambda () (display (procedure-source (search-procedure)))))))
(if (not (string=? str "(lambda (n4) (> n4 0.1))"))
- (snd-display #__line__ ";search-procedure: ~A?" str)))
+ (snd-display ";search-procedure: ~A?" str)))
(set! (search-procedure) (lambda (n) (> n .2)))
(set! (cursor ind 0) 0)
(key (char->integer #\s) 4 ind 0)
(key (char->integer #\s) 4 ind 0)
(if (not (= (cursor ind 0) 0))
- (snd-display #__line__ ";search-procedure C-s C-s cursor failed: ~D?" (cursor ind 0)))
+ (snd-display ";search-procedure C-s C-s cursor failed: ~D?" (cursor ind 0)))
(let ((str (with-output-to-string (lambda () (display (procedure-source (search-procedure)))))))
(if (not (string=? str "(lambda (n) (> n 0.2))"))
- (snd-display #__line__ ";search-procedure (1): ~A?" str)))
+ (snd-display ";search-procedure (1): ~A?" str)))
(set! (hook-functions (edit-hook ind 0)) ())
(hook-push (edit-hook ind 0) (lambda (hook) (set! (hook 'result) #f)))
(let ((str (with-output-to-string (lambda () (display (map procedure-source (hook-functions (edit-hook ind 0))))))))
(if (not (string=? str "((lambda (hook) (set! (hook 'result) #f)))"))
- (snd-display #__line__ ";edit-hook: ~A?" str)))
+ (snd-display ";edit-hook: ~A?" str)))
(set! (hook-functions (edit-hook ind 0)) ())
(set! (hook-functions (after-edit-hook ind 0)) ())
(hook-push (after-edit-hook ind 0) (lambda (hook) (set! (hook 'result) #f)))
(let ((str (with-output-to-string (lambda () (display (map procedure-source (hook-functions (after-edit-hook ind 0))))))))
(if (not (string=? str "((lambda (hook) (set! (hook 'result) #f)))"))
- (snd-display #__line__ ";after-edit-hook: ~A?" str)))
+ (snd-display ";after-edit-hook: ~A?" str)))
(set! (hook-functions (after-edit-hook ind 0)) ())
(set! (hook-functions (undo-hook ind 0)) ())
(hook-push (undo-hook ind 0) (lambda (hook) (set! (hook 'result) #f)))
(let ((str (with-output-to-string (lambda () (display (map procedure-source (hook-functions (undo-hook ind 0))))))))
(if (not (string=? str "((lambda (hook) (set! (hook 'result) #f)))"))
- (snd-display #__line__ ";undo-hook: ~A?" str)))
+ (snd-display ";undo-hook: ~A?" str)))
(set! (hook-functions (undo-hook ind 0)) ())
(let ((calls 0))
(hook-push (undo-hook ind 0) (lambda (hook) (set! calls (+ 1 calls))))
@@ -25771,7 +25235,7 @@ EDITS: 2
(undo 1)
(redo 1)
(revert-sound ind)
- (if (not (= calls 3)) (snd-display #__line__ ";undo-hook called ~A times" calls)))
+ (if (not (= calls 3)) (snd-display ";undo-hook called ~A times" calls)))
(set! (hook-functions (undo-hook ind 0)) ())
(set! (search-procedure) #f)
(close-sound ind)
@@ -25781,11 +25245,11 @@ EDITS: 2
(let ((ind (open-sound "~/sf1/addf8.nh")))
(play ind :wait #t)
(set! (hook-functions open-raw-sound-hook) ())
- (if (or (not (= (chans ind) 1))
- (not (= (srate ind) 22050))
- (not (= (sample-type ind) mus-bshort))
- (not (= (framples ind) 23808)))
- (snd-display #__line__ ";open-raw: ~A ~A ~A ~A"
+ (if (not (and (= (chans ind) 1)
+ (= (srate ind) 22050)
+ (= (sample-type ind) mus-bshort)
+ (= (framples ind) 23808)))
+ (snd-display ";open-raw: ~A ~A ~A ~A"
(chans ind) (srate ind) (sample-type ind) (framples ind)))
(set! (search-procedure) (lambda (n) (> n .2)))
(close-sound ind))
@@ -25807,42 +25271,42 @@ EDITS: 2
(close-sound ind)
(set! (hook-functions open-raw-sound-hook) ())
(set! (hook-functions after-save-as-hook) ())
- (if save-as-dialog (snd-display #__line__ ";after-save-as-hook dialog: ~A" save-as-dialog))
- (if (not (equal? ind save-as-index)) (snd-display #__line__ ";after-save-as-hook index: ~A ~A" ind save-as-index))
- (if (and (not (string=? (string-append home-dir "/cl/test.snd") save-as-name))
- (not (string=? (string-append home-dir "/snd-16/test.snd") save-as-name)))
- (snd-display #__line__ ";after-save-as-hook name: ~A (~A)" save-as-name (string-append home-dir "/cl/test.snd")))
+ (if save-as-dialog (snd-display ";after-save-as-hook dialog: ~A" save-as-dialog))
+ (if (not (equal? ind save-as-index)) (snd-display ";after-save-as-hook index: ~A ~A" ind save-as-index))
+ (if (not (or (string=? (string-append home-dir "/cl/test.snd") save-as-name)
+ (string=? (string-append home-dir "/snd-16/test.snd") save-as-name)))
+ (snd-display ";after-save-as-hook name: ~A (~A)" save-as-name (string-append home-dir "/cl/test.snd")))
(hook-push open-raw-sound-hook
(lambda (hook)
(let ((file (hook 'name))
(choice (hook 'state)))
(if (not (string=? (substring file (- (length file) 8)) "test.snd"))
- (snd-display #__line__ ";open-raw-sound-hook file: ~A?" (substring file (- (length file) 8))))
+ (snd-display ";open-raw-sound-hook file: ~A?" (substring file (- (length file) 8))))
(if choice
- (snd-display #__line__ ";open-raw-sound-hook choice: ~A?" choice))
+ (snd-display ";open-raw-sound-hook choice: ~A?" choice))
(set! (hook 'result) (list 2 44100 mus-mulaw)))))
(set! ind (open-sound "test.snd"))
- (if (or (not (= (header-type ind) mus-raw))
- (not (= (sample-type ind) mus-mulaw))
- (not (= (chans ind) 2))
- (not (= (srate ind) 44100))
- (not (= (framples ind) 50828)))
- (snd-display #__line__ ";open-raw-sound-hook 1: ~A ~A ~A ~A ~A"
+ (if (not (and (= (header-type ind) mus-raw)
+ (= (sample-type ind) mus-mulaw)
+ (= (chans ind) 2)
+ (= (srate ind) 44100)
+ (= (framples ind) 50828)))
+ (snd-display ";open-raw-sound-hook 1: ~A ~A ~A ~A ~A"
(header-type ind) (sample-type ind) (chans ind) (srate ind) (framples ind)))
(close-sound ind)
(hook-append open-raw-sound-hook
(lambda (hook)
(if (not (equal? (hook 'name) "/home/bil/cl/test.snd"))
- (snd-display #__line__ ";open-raw-sound-hook 2: ~A" (hook 'name)))
+ (snd-display ";open-raw-sound-hook 2: ~A" (hook 'name)))
(set! (hook 'result) (list 1 22050 mus-lint))))
(set! ind (open-sound "test.snd"))
- (if (or (not (= (header-type ind) mus-raw))
- (not (= (sample-type ind) mus-lint))
- (not (= (chans ind) 1))
- (not (= (srate ind) 22050))
- (not (= (framples ind) (/ 50828 2))))
- (snd-display #__line__ ";open-raw-sound-hook 3: ~A ~A ~A ~A ~A"
+ (if (not (and (= (header-type ind) mus-raw)
+ (= (sample-type ind) mus-lint)
+ (= (chans ind) 1)
+ (= (srate ind) 22050)
+ (= (framples ind) 25414))) ;(/ 50828 2)
+ (snd-display ";open-raw-sound-hook 3: ~A ~A ~A ~A ~A"
(header-type ind) (sample-type ind) (chans ind) (srate ind) (framples ind)))
(close-sound ind)
(set! (hook-functions open-raw-sound-hook) ())
@@ -25850,11 +25314,11 @@ EDITS: 2
(lambda (hook)
(set! (hook 'result) (list 2))))
(set! ind (open-sound "test.snd"))
- (if (or (not (= (header-type ind) mus-raw))
- (not (= (sample-type ind) mus-lint))
- (not (= (chans ind) 2))
- (not (= (srate ind) 22050)))
- (snd-display #__line__ ";open-raw-sound-hook 4: ~A ~A ~A ~A"
+ (if (not (and (= (header-type ind) mus-raw)
+ (= (sample-type ind) mus-lint)
+ (= (chans ind) 2)
+ (= (srate ind) 22050)))
+ (snd-display ";open-raw-sound-hook 4: ~A ~A ~A ~A"
(header-type ind) (sample-type ind) (chans ind) (srate ind)))
(close-sound ind)
(set! (hook-functions open-raw-sound-hook) ())
@@ -25862,14 +25326,14 @@ EDITS: 2
(lambda (hook)
(set! (hook 'result) (list 1 22050 mus-bshort 120 320))))
(set! ind (open-sound "test.snd"))
- (if (or (not (= (header-type ind) mus-raw))
- (not (= (sample-type ind) mus-bshort))
- (not (= (chans ind) 1))
- (not (= (srate ind) 22050))
- (not (= (data-location ind) 120))
- (not (= (data-size ind) 320))
- (not (= (framples ind) 160)))
- (snd-display #__line__ ";open-raw-sound-hook 5: ~A ~A ~A ~A ~A ~A ~A"
+ (if (not (and (= (header-type ind) mus-raw)
+ (= (sample-type ind) mus-bshort)
+ (= (chans ind) 1)
+ (= (srate ind) 22050)
+ (= (data-location ind) 120)
+ (= (data-size ind) 320)
+ (= (framples ind) 160)))
+ (snd-display ";open-raw-sound-hook 5: ~A ~A ~A ~A ~A ~A ~A"
(header-type ind) (sample-type ind) (chans ind) (srate ind)
(data-location ind) (data-size ind) (/ (framples ind) 2)))
(close-sound ind)
@@ -25877,47 +25341,43 @@ EDITS: 2
(set! (hook-functions during-open-hook) ())
(let ((ind #f)
- (op #f)
- (sl #f)
- (aop #f)
- (dop #f)
- (cl #f)
- (ig #f)
- (scl #f)
(other #f))
- (hook-push open-hook
- (lambda (hook)
- (let ((filename (hook 'name)))
- (if (not (string=? filename (mus-expand-filename "oboe.snd")))
- (snd-display #__line__ ";open-hook: ~A?" filename))
- (set! op #t)
- (set! (hook 'result) #f))))
- (hook-push after-open-hook
- (lambda (hook)
- (set! aop (hook 'snd))))
- (hook-push during-open-hook
- (lambda (hook)
- (let ((filename (hook 'name))
- (reason (hook 'reason)))
- (set! dop #t)
- (if (not (string=? filename (mus-expand-filename "oboe.snd")))
- (snd-display #__line__ ";during-open-hook filename: ~A?" filename))
- (if (not (= reason 1))
- (snd-display #__line__ ";during-open-hook reason: ~A?" reason)))))
- (hook-push initial-graph-hook
- (lambda (hook)
- (if (not (= (hook 'chn) 0))
- (snd-display #__line__ ";initial-graph-hook (channel): ~A not 0?" (hook 'chn)))
- (set! ig #t)
- (set! (hook 'result) #f)))
-
- (set! ind (open-sound "oboe.snd"))
-
- (if (not op) (snd-display #__line__ ";open-hook not called?"))
- (if (not dop) (snd-display #__line__ ";during-open-hook not called?"))
- (when with-gui (if (not ig) (snd-display #__line__ ";initial-graph-hook not called?")))
- (if (not (sound? aop)) (snd-display #__line__ ";after-open-hook not called?"))
- (if (not (equal? aop ind)) (snd-display #__line__ ";after-open-hook ~A but ind: ~A?" aop ind))
+ (let ((op #f)
+ (aop #f)
+ (dop #f)
+ (ig #f))
+ (hook-push open-hook
+ (lambda (hook)
+ (let ((filename (hook 'name)))
+ (if (not (string=? filename (mus-expand-filename "oboe.snd")))
+ (snd-display ";open-hook: ~A?" filename))
+ (set! op #t)
+ (set! (hook 'result) #f))))
+ (hook-push after-open-hook
+ (lambda (hook)
+ (set! aop (hook 'snd))))
+ (hook-push during-open-hook
+ (lambda (hook)
+ (let ((filename (hook 'name))
+ (reason (hook 'reason)))
+ (set! dop #t)
+ (if (not (string=? filename (mus-expand-filename "oboe.snd")))
+ (snd-display ";during-open-hook filename: ~A?" filename))
+ (if (not (= reason 1))
+ (snd-display ";during-open-hook reason: ~A?" reason)))))
+ (hook-push initial-graph-hook
+ (lambda (hook)
+ (if (not (= (hook 'chn) 0))
+ (snd-display ";initial-graph-hook (channel): ~A not 0?" (hook 'chn)))
+ (set! ig #t)
+ (set! (hook 'result) #f)))
+ (set! ind (open-sound "oboe.snd"))
+ (if (not op) (snd-display ";open-hook not called?"))
+ (if (not dop) (snd-display ";during-open-hook not called?"))
+ (when (and with-gui (not ig)) (snd-display ";initial-graph-hook not called?"))
+ (if (not (sound? aop)) (snd-display ";after-open-hook not called?"))
+ (if (not (equal? aop ind)) (snd-display ";after-open-hook ~A but ind: ~A?" aop ind)))
+
(select-all)
(set! (hook-functions open-hook) ())
(set! (hook-functions during-open-hook) ())
@@ -25928,7 +25388,7 @@ EDITS: 2
(let ((pistol (open-sound "pistol.snd")))
(if pistol
(begin
- (snd-display #__line__ ";open-hook #t, but open-sound -> ~A" pistol)
+ (snd-display ";open-hook #t, but open-sound -> ~A" pistol)
(if (sound? pistol) (close-sound pistol)))))
(set! (hook-functions open-hook) ())
@@ -25945,20 +25405,20 @@ EDITS: 2
(let ((snd (hook 'snd))
(chn (hook 'chn)))
(if (not (equal? snd ind))
- (snd-display #__line__ ";graph-hook: ~A not ~A?" snd ind))
+ (snd-display ";graph-hook: ~A not ~A?" snd ind))
(if (not (= chn 0))
- (snd-display #__line__ ";graph-hook (channel): ~A not 0?" chn))
- (set! gr #t)
- (set! (hook 'result) #f))))
+ (snd-display ";graph-hook (channel): ~A not 0?" chn)))
+ (set! gr #t)
+ (set! (hook 'result) #f)))
(hook-push after-graph-hook
(lambda (hook)
(let ((snd (hook 'snd))
(chn (hook 'chn)))
(if (not (equal? snd ind))
- (snd-display #__line__ ";after-graph-hook: ~A not ~A?" snd ind))
+ (snd-display ";after-graph-hook: ~A not ~A?" snd ind))
(if (not (= chn 0))
- (snd-display #__line__ ";after-graph-hook (channel): ~A not 0?" chn))
- (set! agr #t))))
+ (snd-display ";after-graph-hook (channel): ~A not 0?" chn)))
+ (set! agr #t)))
(hook-push before-transform-hook
(lambda (hook)
(set! gbf #t)
@@ -25994,14 +25454,14 @@ EDITS: 2
(XtDispatchEvent (XtAppNextEvent app)))))))
(when with-gui
- (if (and (not gr) (not (provided? 'snd-gtk)))
- (snd-display #__line__ ";graph-hook not called? ~A ~A ~A ~A" (time-graph? ind) (short-file-name ind) ind (sounds)))
- (if (and (not agr) (not (provided? 'snd-gtk)))
- (snd-display #__line__ ";after-graph-hook not called?"))
+ (if (not (or gr (provided? 'snd-gtk)))
+ (snd-display ";graph-hook not called? ~A ~A ~A ~A" (time-graph? ind) (short-file-name ind) ind (sounds)))
+ (if (not (or agr (provided? 'snd-gtk)))
+ (snd-display ";after-graph-hook not called?"))
(if (not gbf)
- (snd-display #__line__ ";before-transform-hook not called?"))
- (if (and (not abf) (not (provided? 'snd-gtk)))
- (snd-display #__line__ ";after-transform-hook not called?")))
+ (snd-display ";before-transform-hook not called?"))
+ (if (not (or abf (provided? 'snd-gtk)))
+ (snd-display ";after-transform-hook not called?")))
(set! (hook-functions before-transform-hook) ())
(set! (transform-graph? ind 0) #f)
(set! (hook-functions graph-hook) ())
@@ -26009,24 +25469,26 @@ EDITS: 2
(set! other (open-sound "pistol.snd"))
- (hook-push select-sound-hook
- (lambda (hook)
- (if (not (equal? (hook 'snd) ind))
- (snd-display #__line__ ";select-sound-hook: ~A not ~A?" (hook 'snd) ind))
- (set! sl #t)))
- (hook-push select-channel-hook
- (lambda (hook)
- (let ((snd (hook 'snd))
- (chn (hook 'chn)))
- (if (not (equal? snd ind))
- (snd-display #__line__ ";select-channel-hook: ~A not ~A?" snd ind))
- (if (not (= chn 0))
- (snd-display #__line__ ";select-channel-hook (channel): ~A not 0?" chn))
- (set! scl #t))))
-
- (select-sound ind)
- (if (not sl) (snd-display #__line__ ";select-sound-hook not called?"))
- (if (not scl) (snd-display #__line__ ";select-channel-hook not called?"))
+ (let ((sl #f))
+ (hook-push select-sound-hook
+ (lambda (hook)
+ (if (not (equal? (hook 'snd) ind))
+ (snd-display ";select-sound-hook: ~A not ~A?" (hook 'snd) ind))
+ (set! sl #t)))
+ (let ((scl #f))
+ (hook-push select-channel-hook
+ (lambda (hook)
+ (let ((snd (hook 'snd)))
+ (if (not (equal? snd ind))
+ (snd-display ";select-channel-hook: ~A not ~A?" snd ind)))
+ (let ((chn (hook 'chn)))
+ (if (not (= chn 0))
+ (snd-display ";select-channel-hook (channel): ~A not 0?" chn)))
+ (set! scl #t)))
+
+ (select-sound ind)
+ (if (not sl) (snd-display ";select-sound-hook not called?"))
+ (if (not scl) (snd-display ";select-channel-hook not called?"))))
(set! (hook-functions select-sound-hook) ())
(set! (hook-functions select-channel-hook) ())
@@ -26036,18 +25498,18 @@ EDITS: 2
(hook-push start-playing-hook
(lambda (hook)
(if (not (equal? (hook 'snd) ind))
- (snd-display #__line__ ";start-playing-hook: ~A not ~A?" (hook 'snd) ind))
+ (snd-display ";start-playing-hook: ~A not ~A?" (hook 'snd) ind))
(set! spl #t)
(set! (hook 'result) #f)))
(hook-push stop-playing-hook
(lambda (hook)
(if (not (equal? (hook 'snd) ind))
- (snd-display #__line__ ";stop-playing-hook: ~A not ~A?" (hook 'snd) ind))
+ (snd-display ";stop-playing-hook: ~A not ~A?" (hook 'snd) ind))
(set! stl #t)))
(hook-push play-hook
(lambda (hook)
(if (< (hook 'size) 128)
- (snd-display #__line__ ";play-hook samps: ~A?" (hook 'size)))
+ (snd-display ";play-hook samps: ~A?" (hook 'size)))
(set! ph #t)))
(set! (expand-control? ind) #t)
@@ -26057,9 +25519,9 @@ EDITS: 2
(set! (expand-control? ind) #f)
(when with-gui
- (if (not spl) (snd-display #__line__ ";start-playing-hook not called?"))
- (if (not stl) (snd-display #__line__ ";stop-playing-hook not called?"))
- (if (not ph) (snd-display #__line__ ";play-hook not called?")))
+ (if (not spl) (snd-display ";start-playing-hook not called?"))
+ (if (not stl) (snd-display ";stop-playing-hook not called?"))
+ (if (not ph) (snd-display ";play-hook not called?")))
(set! (hook-functions start-playing-hook) ())
(set! (hook-functions start-playing-selection-hook) ())
(set! (hook-functions stop-playing-hook) ())
@@ -26088,13 +25550,13 @@ EDITS: 2
(let ((reg (select-all)))
(play (selection) :wait #t)
(if (region? reg) (play reg :wait #t))
- (if (not ss) (snd-display #__line__ ";stop-playing-selection-hook: ~A" ss)))
+ (if (not ss) (snd-display ";stop-playing-selection-hook: ~A" ss)))
(set! (hook-functions stop-playing-selection-hook) ())
(set! *selection-creates-region* old-reg))
(let ((pl (make-player ind 0)))
(free-player pl)
- (if (player? pl) (snd-display #__line__ ";free-player: ~A" pl)))
+ (if (player? pl) (snd-display ";free-player: ~A" pl)))
)
(let ((e0 #f)
@@ -26127,19 +25589,19 @@ EDITS: 2
;; edit of ind should be disallowed, but not other
(delete-sample 0 ind 0)
(if (not (= (edit-position ind 0) 0))
- (snd-display #__line__ ";edit-hook #t didn't disallow edit!"))
- (if (not e0) (snd-display #__line__ ";edit-hook #t not called?"))
- (if a0 (snd-display #__line__ ";after-edit-hook 0 called?"))
+ (snd-display ";edit-hook #t didn't disallow edit!"))
+ (if (not e0) (snd-display ";edit-hook #t not called?"))
+ (if a0 (snd-display ";after-edit-hook 0 called?"))
(undo 1 ind 0)
- (if u0 (snd-display #__line__ ";undo-hook called?"))
+ (if u0 (snd-display ";undo-hook called?"))
(delete-sample 0 other 0)
(if (not (= (edit-position other 0) 1))
- (snd-display #__line__ ";edit-hook #f didn't allow edit!"))
- (if (not e1) (snd-display #__line__ ";edit-hook #f not called?"))
- (if (not a1) (snd-display #__line__ ";after-edit-hook 1 not called?"))
+ (snd-display ";edit-hook #f didn't allow edit!"))
+ (if (not e1) (snd-display ";edit-hook #f not called?"))
+ (if (not a1) (snd-display ";after-edit-hook 1 not called?"))
(undo 1 other 0)
- (if (not u1) (snd-display #__line__ ";undo-hook not called?"))
+ (if (not u1) (snd-display ";undo-hook not called?"))
(set! (hook-functions (edit-hook ind 0)) ())
(set! (hook-functions (edit-hook other 0)) ())
@@ -26168,9 +25630,9 @@ EDITS: 2
(snd-warning "hiho")
(mus-sound-samples "/bad/baddy")
- (if (not se) (snd-display #__line__ ";snd-error-hook not called?"))
- (if (not sw) (snd-display #__line__ ";snd-warning-hook not called?"))
- (if (not me) (snd-display #__line__ ";mus-error-hook not called?"))
+ (if (not se) (snd-display ";snd-error-hook not called?"))
+ (if (not sw) (snd-display ";snd-warning-hook not called?"))
+ (if (not me) (snd-display ";mus-error-hook not called?"))
(set! (hook-functions snd-error-hook) ())
(set! (hook-functions snd-warning-hook) ())
(set! (hook-functions mus-error-hook) ())
@@ -26180,9 +25642,8 @@ EDITS: 2
(set! (hook 'result) #t)))
(snd-error "not an error")
- (if (or (not (string? se))
- (not (string=? se "not an error")))
- (snd-display #__line__ ";snd-error-hook saw: ~A" se))
+ (if (not (equal? se "not an error"))
+ (snd-display ";snd-error-hook saw: ~A" se))
(set! (hook-functions snd-error-hook) ()))
(hook-push before-exit-hook (lambda (hook) (set! (hook 'result) #t)))
@@ -26197,31 +25658,32 @@ EDITS: 2
(lambda (hook)
(let ((snd (hook 'snd))
(filename (hook 'name)))
- (if (or (not (string? filename))
- (not (string=? filename (mus-expand-filename "baddy.snd"))))
- (snd-display #__line__ ";save-hook filename: ~A?" filename))
+ (if (not (and (string? filename)
+ (string=? filename (mus-expand-filename "baddy.snd"))))
+ (snd-display ";save-hook filename: ~A?" filename))
(if (not (equal? snd ind))
- (snd-display #__line__ ";save-hook snd: ~A ~A?" snd ind))
- (set! sh #t)
- (set! (hook 'result) #t))))
+ (snd-display ";save-hook snd: ~A ~A?" snd ind)))
+ (set! sh #t)
+ (set! (hook 'result) #t)))
(save-sound-as "baddy.snd" ind)
- (if (not sh) (snd-display #__line__ ";save-hook not called?"))
+ (if (not sh) (snd-display ";save-hook not called?"))
(if (file-exists? "baddy.snd")
(begin
- (snd-display #__line__ ";save-hook didn't cancel save?")
+ (snd-display ";save-hook didn't cancel save?")
(delete-file "baddy.snd")))
(set! (hook-functions save-hook) ()))
;; after-transform-hooks require some way to force the fft to run to completion
;; property-changed hook is similar (seems to happen whenever it's good and ready)
- (hook-push close-hook
- (lambda (hook)
- (if (not (equal? (hook 'snd) ind))
- (snd-display #__line__ ";close-hook: ~A not ~A?" (hook 'snd) ind))
- (set! cl #t)))
-
- (close-sound ind)
- (if (not cl) (snd-display #__line__ ";close-hook not called?"))
+ (let ((cl #f))
+ (hook-push close-hook
+ (lambda (hook)
+ (if (not (equal? (hook 'snd) ind))
+ (snd-display ";close-hook: ~A not ~A?" (hook 'snd) ind))
+ (set! cl #t)))
+
+ (close-sound ind)
+ (if (not cl) (snd-display ";close-hook not called?")))
(set! (hook-functions close-hook) ())
(close-sound other))
@@ -26389,14 +25851,14 @@ EDITS: 2
(set! (hook 'result) #t)))
(for-each
(lambda (func-and-name)
- (let ((func (cadr func-and-name))
- (name (car func-and-name)))
- (func)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";~A: blocked edit: ~A" name (edit-position ind 0)))
- (if (not (= edit-hook-ctr 1)) (snd-display #__line__ ";~A: edit hook calls: ~A" name edit-hook-ctr))
- (if (not (= after-edit-hook-ctr 0)) (snd-display #__line__ ";~A: after edit hook calls: ~A" name after-edit-hook-ctr))
+ (let ((func (cadr func-and-name)))
+ (func))
+ (let ((name (car func-and-name)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";~A: blocked edit: ~A" name (edit-position ind 0)))
+ (if (not (= edit-hook-ctr 1)) (snd-display ";~A: edit hook calls: ~A" name edit-hook-ctr))
+ (if (not (= after-edit-hook-ctr 0)) (snd-display ";~A: after edit hook calls: ~A" name after-edit-hook-ctr))
(set! edit-hook-ctr 0)
- (if (not (null? (mixes ind 0))) (snd-display #__line__ ";[27315] ~A: mixes: ~A" name (mixes ind 0)))))
+ (if (not (null? (mixes ind 0))) (snd-display ";[27315] ~A: mixes: ~A" name (mixes ind 0)))))
all-tests)
(set! edit-hook-ctr 0)
@@ -26413,15 +25875,15 @@ EDITS: 2
(set! (hook 'result) #t)))
(for-each
(lambda (func-and-name)
- (let ((func (cadr func-and-name))
- (name (car func-and-name)))
- (func)
- (if (<= (edit-position ind 0) 0) (snd-display #__line__ ";~A: unblocked edit: ~A" name (edit-position ind 0)))
- (if (<= edit-hook-ctr 0) (snd-display #__line__ ";~A: unblocked edit hook calls: ~A" name edit-hook-ctr))
- (if (<= after-edit-hook-ctr 0) (snd-display #__line__ ";~A: unblocked after edit hook calls: ~A" name after-edit-hook-ctr))
- (set! edit-hook-ctr 0)
- (set! after-edit-hook-ctr 0)
- (revert-sound ind)))
+ (let ((func (cadr func-and-name)))
+ (func))
+ (let ((name (car func-and-name)))
+ (if (<= (edit-position ind 0) 0) (snd-display ";~A: unblocked edit: ~A" name (edit-position ind 0)))
+ (if (<= edit-hook-ctr 0) (snd-display ";~A: unblocked edit hook calls: ~A" name edit-hook-ctr))
+ (if (<= after-edit-hook-ctr 0) (snd-display ";~A: unblocked after edit hook calls: ~A" name after-edit-hook-ctr)))
+ (set! edit-hook-ctr 0)
+ (set! after-edit-hook-ctr 0)
+ (revert-sound ind))
all-tests)
(if (and (provided? 'snd-motif)
@@ -26447,39 +25909,38 @@ EDITS: 2
(scale-by 2.0)
(hook-push (edit-hook ind 0) (lambda (hook) (set! (hook 'result) #t)))
(mix-float-vector (make-float-vector 10 .1) 0)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";mix-float-vector: blocked edit: ~A" (edit-position ind 0)))
- (if (not (null? (mixes ind 0))) (snd-display #__line__ ";mix-float-vector edit-hook: mixes: ~A" (mixes ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";mix-float-vector: blocked edit: ~A" (edit-position ind 0)))
+ (if (not (null? (mixes ind 0))) (snd-display ";mix-float-vector edit-hook: mixes: ~A" (mixes ind 0)))
(mix "pistol.snd" 1000)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";mix: blocked edit: ~A" (edit-position ind 0)))
- (if (not (null? (mixes ind 0))) (snd-display #__line__ ";mix edit-hook: mixes: ~A" (mixes ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";mix: blocked edit: ~A" (edit-position ind 0)))
+ (if (not (null? (mixes ind 0))) (snd-display ";mix edit-hook: mixes: ~A" (mixes ind 0)))
(set! (hook-functions (edit-hook ind 0)) ())
(let ((mx (mix-float-vector (make-float-vector 10 .1) 1000)))
- (if (mix? mx) ; might be no-gui case
- (begin
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix-float-vector: unblocked edit: ~A" (edit-position ind 0)))
- (if (not (equal? (mixes ind 0) (list mx))) (snd-display #__line__ ";mix-float-vector un edit-hook: mixes: ~A" (mixes ind 0)))
- (hook-push (edit-hook ind 0) (lambda (hook) (set! (hook 'result) #t)))
- (set! (mix-amp mx) 2.0)
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix amp: blocked edit: ~A" (edit-position ind 0)))
- (if (fneq (mix-amp mx) 1.0) (snd-display #__line__ ";mix amp: blocked edit: ~A" (mix-amp mx)))
- (set! (mix-amp-env mx) '(0 0 1 1 2 0))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix amp env: blocked edit: ~A" (edit-position ind 0)))
- (if (pair? (mix-amp-env mx)) (snd-display #__line__ ";mix amp env: blocked edit: ~A" (mix-amp-env mx)))
- (set! (mix-speed mx) 2.0)
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix speed: blocked edit: ~A" (edit-position ind 0)))
- (if (fneq (mix-speed mx) 1.0) (snd-display #__line__ ";mix speed: blocked edit: ~A" (mix-speed mx)))
- (set! (mix-position mx) 2000)
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix position: blocked edit: ~A" (edit-position ind 0)))
- (if (not (= (mix-position mx) 1000)) (snd-display #__line__ ";mix position: blocked edit: ~A" (mix-position mx)))
- (mix-float-vector (make-float-vector 10 .2) 0)
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";mix-float-vector 1: blocked edit: ~A" (edit-position ind 0)))
- (if (not (equal? (mixes ind 0) (list mx))) (snd-display #__line__ ";mix-float-vector 1 edit-hook: mixes: ~A" (mixes ind 0)))
- )))
+ (when (mix? mx) ; might be no-gui case
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix-float-vector: unblocked edit: ~A" (edit-position ind 0)))
+ (if (not (equal? (mixes ind 0) (list mx))) (snd-display ";mix-float-vector un edit-hook: mixes: ~A" (mixes ind 0)))
+ (hook-push (edit-hook ind 0) (lambda (hook) (set! (hook 'result) #t)))
+ (set! (mix-amp mx) 2.0)
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix amp: blocked edit: ~A" (edit-position ind 0)))
+ (if (fneq (mix-amp mx) 1.0) (snd-display ";mix amp: blocked edit: ~A" (mix-amp mx)))
+ (set! (mix-amp-env mx) '(0 0 1 1 2 0))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix amp env: blocked edit: ~A" (edit-position ind 0)))
+ (if (pair? (mix-amp-env mx)) (snd-display ";mix amp env: blocked edit: ~A" (mix-amp-env mx)))
+ (set! (mix-speed mx) 2.0)
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix speed: blocked edit: ~A" (edit-position ind 0)))
+ (if (fneq (mix-speed mx) 1.0) (snd-display ";mix speed: blocked edit: ~A" (mix-speed mx)))
+ (set! (mix-position mx) 2000)
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix position: blocked edit: ~A" (edit-position ind 0)))
+ (if (not (= (mix-position mx) 1000)) (snd-display ";mix position: blocked edit: ~A" (mix-position mx)))
+ (mix-float-vector (make-float-vector 10 .2) 0)
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";mix-float-vector 1: blocked edit: ~A" (edit-position ind 0)))
+ (if (not (equal? (mixes ind 0) (list mx))) (snd-display ";mix-float-vector 1 edit-hook: mixes: ~A" (mixes ind 0)))
+ ))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
- (if (pair? (hook-functions (edit-hook ind 0))) (snd-display #__line__ ";edit-hook not cleared at close?"))
- (if (pair? (hook-functions (after-edit-hook ind 0))) (snd-display #__line__ ";after-edit-hook not cleared at close?"))
+ (if (pair? (hook-functions (edit-hook ind 0))) (snd-display ";edit-hook not cleared at close?"))
+ (if (pair? (hook-functions (after-edit-hook ind 0))) (snd-display ";after-edit-hook not cleared at close?"))
(close-sound ind))
(reset-all-hooks)
@@ -26508,11 +25969,11 @@ EDITS: 2
(set! (hook 'result) #t))))))
(let ((ind (open-sound "2.snd")))
(save-sound-as "test.snd" :srate 44100)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";before-save-as-hook undo: ~A" (edit-position ind 0)))
- (if (not hook-called) (snd-display #__line__ ";before-save-as-hook not called?"))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";before-save-as-hook undo: ~A" (edit-position ind 0)))
+ (if (not hook-called) (snd-display ";before-save-as-hook not called?"))
(close-sound ind)
(set! ind (open-sound "test.snd"))
- (if (not (= (srate ind) 44100)) (snd-display #__line__ ";before-save-as-hook src: ~A" (srate ind)))
+ (if (not (= (srate ind) 44100)) (snd-display ";before-save-as-hook src: ~A" (srate ind)))
(close-sound ind))
(set! (hook-functions before-save-as-hook) ()))
@@ -26534,16 +25995,16 @@ EDITS: 2
(set! need-save-as-undo #t))))))
(hook-push after-save-as-hook
(lambda (hook)
- (if need-save-as-undo (undo))))
- (let ((ind (open-sound "oboe.snd")))
- (save-sound-as "test.snd" :srate 44100)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";after-save-as-hook undo: ~A" (edit-position ind 0)))
- (close-sound ind)
- (set! ind (open-sound "test.snd"))
- (if (not (= (srate ind) 44100)) (snd-display #__line__ ";before|after-save-as-hook src: ~A" (srate ind)))
- (close-sound ind))
- (set! (hook-functions before-save-as-hook) ())
- (set! (hook-functions after-save-as-hook) ()))
+ (if need-save-as-undo (undo)))))
+ (let ((ind (open-sound "oboe.snd")))
+ (save-sound-as "test.snd" :srate 44100)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";after-save-as-hook undo: ~A" (edit-position ind 0)))
+ (close-sound ind)
+ (set! ind (open-sound "test.snd"))
+ (if (not (= (srate ind) 44100)) (snd-display ";before|after-save-as-hook src: ~A" (srate ind)))
+ (close-sound ind))
+ (set! (hook-functions before-save-as-hook) ())
+ (set! (hook-functions after-save-as-hook) ())
(let ((old-clip *clipping*)
(old-mus-clip (mus-clipping)))
@@ -26564,12 +26025,12 @@ EDITS: 2
(if (and (fneq val 1.0)
(fneq val 1.5)
(fneq val -1.5))
- (snd-display #__line__ ";clip-hook called upon: ~A" val))
+ (snd-display ";clip-hook called upon: ~A" val))
(set! hook-called (+ 1 hook-called))
(set! (hook 'result) 0.0))))
(save-sound index)
(set! (hook-functions clip-hook) ())
- (if (not (= hook-called 3)) (snd-display #__line__ ";clip-hook called ~A times" hook-called))
+ (if (not (= hook-called 3)) (snd-display ";clip-hook called ~A times" hook-called))
(close-sound index)
(set! index (open-sound "test.snd"))
(let ((new-vals (channel->float-vector 0 10 index))
@@ -26578,7 +26039,7 @@ EDITS: 2
(set! (fixed-vals 6) 0.0)
(set! (fixed-vals 8) 0.0)
(if (not (vequal fixed-vals new-vals))
- (snd-display #__line__ ";clip-hook results:~% ~A~% ~A~% ~A" new-vals fixed-vals vals)))
+ (snd-display ";clip-hook results:~% ~A~% ~A~% ~A" new-vals fixed-vals vals)))
(close-sound index)))
(set! *clipping* old-clip)
(set! (mus-clipping) old-mus-clip))
@@ -26590,61 +26051,55 @@ EDITS: 2
(define sfile 0) ; used globally by save-state stuff (... is this a bug?)
+
(define safe-make-selection
(let ((documentation "make-region with error checks"))
- (lambda (beg end snd) ; used in test_15 also
+ (lambda (snd) ; used in test_15 also
(let ((len (framples snd))
- (old-choice *selection-creates-region*))
+ (old-choice *selection-creates-region*)
+ (beg 1000)
+ (end 2000))
(set! *selection-creates-region* #t)
(if (> len 1)
- (if (< end len)
- (make-selection beg end snd)
- (if (< beg len)
- (make-selection beg (- len 1) snd)
- (make-selection 0 (- len 1) snd))))
+ (make-selection (if (< end len)
+ (values beg end)
+ (values (if (< beg len) beg 0) (- len 1)))
+ snd))
(set! *selection-creates-region* old-choice)))))
-
+
(define (flatten lst)
(cond ((null? lst) ())
- ((pair? lst)
- (if (pair? (car lst))
- (append (flatten (car lst)) (flatten (cdr lst)))
- (cons (car lst) (flatten (cdr lst)))))
- (#t lst)))
-
+ ((not (pair? lst)) lst)
+ ((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst))))
+ (else (cons (car lst) (flatten (cdr lst))))))
(define (snd_test_14)
(define (test-panel func name)
- (if (and (not (feql (func #t) (map func (sounds))))
- (not (feql (func #t) (map func (reverse (sounds))))))
- (snd-display #__line__ ";test-panel ~A: ~A ~A?" name (func #t) (map func (sounds)))))
-
- (define (all-chans-reversed)
- (let ((sndlist ())
- (chnlist ()))
- (for-each (lambda (snd)
- (do ((i (- (channels snd) 1) (- i 1)))
- ((< i 0))
- (set! sndlist (cons snd sndlist))
- (set! chnlist (cons i chnlist))))
- (reverse (sounds)))
- (list sndlist chnlist)))
+ (if (not (or (feql (func #t) (map func (sounds)))
+ (feql (func #t) (map func (reverse (sounds))))))
+ (snd-display ";test-panel ~A: ~A ~A?" name (func #t) (map func (sounds)))))
(define (test-channel func name)
- (if (and (not (equal? (flatten (func #t #t)) (apply map func (all-chans))))
- (not (equal? (flatten (func #t #t)) (apply map func (all-chans-reversed)))))
- (snd-display #__line__ ";test-channel ~A: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans)))))
+ (let ((val (flatten (func #t #t))))
+ (if (not (or (equal? val (apply map func (all-chans)))
+ (equal? val (apply map func
+ (let ((sndlist ())
+ (chnlist ()))
+ (for-each
+ (lambda (snd)
+ (do ((i (- (channels snd) 1) (- i 1)))
+ ((< i 0))
+ (set! sndlist (cons snd sndlist))
+ (set! chnlist (cons i chnlist))))
+ (reverse (sounds)))
+ (list sndlist chnlist))))))
+ (snd-display ";test-channel ~A: ~A ~A?" name val (apply map func (all-chans))))))
(define duration
(lambda (ind)
(/ (framples ind) (srate ind))))
-
- (define outputs (make-vector 24))
- (define delay-line #f)
- (define delay-time 0.5)
- (define rev-funcs-set #f)
-
+
(let* ((cur-dir-files (remove-if
(lambda (file)
(<= (catch #t
@@ -26669,11 +26124,11 @@ EDITS: 2
(define* (clone-sound-as new-name snd)
;; copies any edit-sounds to save-dir!
(let* ((tmpf (snd-tempnam))
- (scm (string-append (substring tmpf 0 (- (length tmpf) 3)) "scm"))
- (oldsnd (or snd (selected-sound))))
- (if (not (string? *save-dir*)) (set! *save-dir* "/tmp"))
- (save-edit-history scm oldsnd)
- (copy-file (file-name oldsnd) new-name)
+ (scm (string-append (substring tmpf 0 (- (length tmpf) 3)) "scm")))
+ (let ((oldsnd (or snd (selected-sound))))
+ (if (not (string? *save-dir*)) (set! *save-dir* "/tmp"))
+ (save-edit-history scm oldsnd)
+ (copy-file (file-name oldsnd) new-name))
(set! sfile (open-sound new-name))
(load scm)
(delete-file scm)
@@ -26689,17 +26144,14 @@ EDITS: 2
(df (mus-sound-sample-type name))
(len (mus-sound-framples name))
(chans (mus-sound-chans name)))
- (if (and (not (= ht mus-raw))
- (not (= len 0))
- (not (= df -1)))
- (if (= chans 1)
- (set! mono-files (cons name mono-files))
- (if (= chans 2)
- (set! stereo-files (cons name stereo-files))
- (if (= chans 4)
- (set! quad-files (cons name quad-files))
- (if (= chans 8)
- (set! octo-files (cons name octo-files)))))))))
+ (if (not (or (= ht mus-raw)
+ (= len 0)
+ (= df -1)))
+ (case chans
+ ((1) (set! mono-files (cons name mono-files)))
+ ((2) (set! stereo-files (cons name stereo-files)))
+ ((4) (set! quad-files (cons name quad-files)))
+ ((8) (set! octo-files (cons name octo-files)))))))
(do ((test-ctr 0 (+ 1 test-ctr)))
((= test-ctr tests))
@@ -26718,7 +26170,7 @@ EDITS: 2
(set! mxpos (+ mxpos (edit-position snd chn)))))
(if (or (> mxpos 100) (> chns 4))
(begin
- (snd-display #__line__ ";revert ~A at ~A" (file-name snd) mxpos)
+ (snd-display ";revert ~A at ~A" (file-name snd) mxpos)
(revert-sound snd)))))
(sounds))))
(log-mem test-ctr)
@@ -26741,7 +26193,7 @@ EDITS: 2
(load (string-append cwd "s61.scm")))
(lambda args args))
(if (not (= (length (sounds)) files))
- (snd-display #__line__ ";save state restart from ~A to ~A sounds?" files (length (sounds))))
+ (snd-display ";save state restart from ~A to ~A sounds?" files (length (sounds))))
(set! open-files (sounds))))
(let ()
@@ -26776,40 +26228,41 @@ EDITS: 2
(let ((xb (x-bounds curfd)))
(if (or (fneq (car xb) 0.0)
(fneq (cadr xb) (min (duration curfd) 1.0)))
- (snd-display #__line__ ";x-bounds: ~A?" xb))))))
+ (snd-display ";x-bounds: ~A?" xb))))))
(set! (y-bounds curfd) (list -0.5 0.5))
(let ((yb (y-bounds curfd)))
- (when with-gui
- (if (or (fneq (car yb) -0.5) (fneq (cadr yb) 0.5)) (snd-display #__line__ ";y-bounds: ~A?" yb))))
+ (when (and with-gui
+ (or (fneq (car yb) -0.5) (fneq (cadr yb) 0.5)))
+ (snd-display ";y-bounds: ~A?" yb)))
(set! (cursor curfd 0) curloc)
(let ((cl (cursor curfd 0)))
(if (and (not (= cl curloc))
(> (framples curfd 0) curloc))
(begin
- (snd-display #__line__ ";cursor ~A is not ~A (framples: ~A)?" cl curloc (framples curfd 0))
+ (snd-display ";cursor ~A is not ~A (framples: ~A)?" cl curloc (framples curfd 0))
(set! curloc (cursor curfd 0)))))
(if (>= curloc (framples curfd 0)) (set! curloc 0))
(let ((id (catch #t (lambda () (add-mark curloc curfd)) (lambda args -1))))
- (if (and (number? id) (not (= id -1)))
- (let ((cl (mark-sample id))
- (new-marks (length (marks curfd 0))))
- (if (not (= cl curloc)) (snd-display #__line__ ";mark ~A is not ~A?" cl curloc))
- (if (not (= new-marks (+ 1 old-marks))) (snd-display #__line__ ";marks ~A ~A?" new-marks old-marks))
- (let ((new-id (find-mark curloc curfd)))
- (if (or (not (mark? new-id))
- (not (= id new-id)))
- (snd-display #__line__ ";find-mark (by sample): ~A ~A (~A for ~A ~A)?"
- id new-id curloc (mark-sample id) (mark-sample new-id))))
- (set! (mark-name id) "hiho")
- (let ((new-id (find-mark "hiho" curfd)))
- (if (or (not (mark? new-id))
- (not (= id new-id)))
- (snd-display #__line__ ";find-mark (by name): ~A ~A?" id new-id)))
- (if (not (string=? (mark-name id) "hiho")) (snd-display #__line__ ";mark name: ~A?" (mark-name id)))
- (set! (mark-sample id) (max 0 (- curloc 100)))
- (set! cl (mark-sample id))
- (if (not (= cl (max 0 (- curloc 100)))) (snd-display #__line__ ";set mark ~A is not ~A?" cl curloc))
- (delete-mark id)))
+ (when (and (number? id) (not (= id -1)))
+ (let ((cl (mark-sample id)))
+ (let ((new-marks (length (marks curfd 0))))
+ (if (not (= cl curloc)) (snd-display ";mark ~A is not ~A?" cl curloc))
+ (if (not (= new-marks (+ 1 old-marks))) (snd-display ";marks ~A ~A?" new-marks old-marks)))
+ (let ((new-id (find-mark curloc curfd)))
+ (if (not (and (mark? new-id)
+ (= id new-id)))
+ (snd-display ";find-mark (by sample): ~A ~A (~A for ~A ~A)?"
+ id new-id curloc (mark-sample id) (mark-sample new-id))))
+ (set! (mark-name id) "hiho")
+ (let ((new-id (find-mark "hiho" curfd)))
+ (if (not (and (mark? new-id)
+ (= id new-id)))
+ (snd-display ";find-mark (by name): ~A ~A?" id new-id)))
+ (if (not (string=? (mark-name id) "hiho")) (snd-display ";mark name: ~A?" (mark-name id)))
+ (set! (mark-sample id) (max 0 (- curloc 100)))
+ (set! cl (mark-sample id))
+ (if (not (= cl (max 0 (- curloc 100)))) (snd-display ";set mark ~A is not ~A?" cl curloc))
+ (delete-mark id)))
(if (> (duration curfd) 1.2) (set! (x-bounds curfd) '(1.0 1.1)))
(if (> (framples curfd) 25)
(begin
@@ -26824,7 +26277,7 @@ EDITS: 2
(set! (y-bounds curfd) '(-1.0 1.0))
(if (or (> (length (marks curfd 0)) 0)
(not (= new-marks (+ old-marks 3))))
- (snd-display #__line__ ";delete marks: ~A ~A?" new-marks old-marks)))))
+ (snd-display ";delete marks: ~A ~A?" new-marks old-marks)))))
))
(revert-sound)
@@ -26837,7 +26290,7 @@ EDITS: 2
(let ((r1 (region-rms (car (regions))))
(r2 (selection-rms)))
(if (fneq r1 r2)
- (snd-display #__line__ ";region rms: ~A?" r1))))))
+ (snd-display ";region rms: ~A?" r1))))))
(set! *selection-creates-region* old-setting))
(without-errors (if (region? (cadr (regions))) (play (cadr (regions)) :wait #t)))
@@ -26854,23 +26307,23 @@ EDITS: 2
(without-errors
(begin
(let ((cfd (choose-fd)))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(src-selection .5)
(undo 1 cfd))
(let ((cfd (choose-fd)))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(src-selection -1.5)
(undo 1 cfd))
(let ((cfd (choose-fd)))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(scale-selection-by .5)
(undo 1 cfd))
(let ((cfd (choose-fd)))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(env-selection '(0 0 1 1 2 0))
(undo 1 cfd))
(let ((cfd (choose-fd)))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(scale-selection-to .5)
(reverse-selection)
(undo 2 cfd))
@@ -26881,28 +26334,28 @@ EDITS: 2
(let ((cfd (car open-files)))
(set! (sync cfd) 1)
(if (pair? (cdr open-files)) (set! (sync (cadr open-files)) 1))
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(src-selection .5)
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(src-selection -1.5)
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(env-selection '(0 0 1 1 2 0))
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(reverse-selection)
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(filter-selection '(0 0 .1 1 1 0) 40)
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(convolve-selection-with "oboe.snd")
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(smooth-selection)
(undo 1 cfd)
- (safe-make-selection 1000 2000 cfd)
+ (safe-make-selection cfd)
(scale-selection-by .5)
(undo 1 cfd)
(scale-selection-to .5)
@@ -26967,42 +26420,42 @@ EDITS: 2
(lambda (beg) (insert-silence beg 100)))))
(let ((ind (open-sound "z.snd")))
- (if (not (= (framples ind) 0)) (snd-display #__line__ ";framples z.snd ~A" (framples ind)))
- (if (samples) (snd-display #__line__ ";samples of empty file (z): ~A" (samples)))
- (if (channel->float-vector) (snd-display #__line__ ";channel->float-vector of empty file (z): ~A" (channel->float-vector)))
- (if (fneq (maxamp ind) 0.0) (snd-display #__line__ ";maxamp z.snd ~A" (maxamp ind)))
- (if (fneq (sample 100 ind) 0.0) (snd-display #__line__ ";sample 100 z.snd ~A" (sample 100 ind)))
+ (if (not (= (framples ind) 0)) (snd-display ";framples z.snd ~A" (framples ind)))
+ (if (samples) (snd-display ";samples of empty file (z): ~A" (samples)))
+ (if (channel->float-vector) (snd-display ";channel->float-vector of empty file (z): ~A" (channel->float-vector)))
+ (if (fneq (maxamp ind) 0.0) (snd-display ";maxamp z.snd ~A" (maxamp ind)))
+ (if (fneq (sample 100 ind) 0.0) (snd-display ";sample 100 z.snd ~A" (sample 100 ind)))
(scale-by 2.0)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";scale z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";scale z: ~A" (edit-position ind 0)))
(env-sound '(0 0 1 1))
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";env z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";env z: ~A" (edit-position ind 0)))
(smooth-sound)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";smooth z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";smooth z: ~A" (edit-position ind 0)))
(reverse-sound)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";reverse z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";reverse z: ~A" (edit-position ind 0)))
(src-sound 2.0)
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";src z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";src z: ~A" (edit-position ind 0)))
(insert-sound "z.snd")
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";insert z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";insert z: ~A" (edit-position ind 0)))
(mix "z.snd")
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";mix z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";mix z: ~A" (edit-position ind 0)))
(filter-sound (make-one-zero :a0 2.0 :a1 0.0))
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";filter z: ~A" (edit-position ind 0)))
- (if (not (= (mus-sound-duration "z.snd") 0.0)) (snd-display #__line__ ";duration z.snd: ~A" (mus-sound-duration "z.snd")))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";filter z: ~A" (edit-position ind 0)))
+ (if (not (= (mus-sound-duration "z.snd") 0.0)) (snd-display ";duration z.snd: ~A" (mus-sound-duration "z.snd")))
(catch 'IO-error
(lambda () (convolve-with "z.snd" 1.0))
(lambda args args))
- (if (not (= (edit-position ind 0) 0)) (snd-display #__line__ ";convolve z: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";convolve z: ~A" (edit-position ind 0)))
(let ((matches (count-matches (lambda (y) (> y .1)))))
- (if (and matches (> matches 0))
- (snd-display #__line__ ";count z: ~A" matches)))
+ (if (and (number? matches) (> matches 0))
+ (snd-display ";count z: ~A" matches)))
(let* ((reader (make-sampler 0))
(val (next-sample reader))
(str (format #f "~A" reader)))
- (if (fneq val 0.0) (snd-display #__line__ ";sampler z.snd: ~A" val))
- (if (not (string? str)) (snd-display #__line__ ";z.snd reader: ~A" str)))
- (if (not (equal? (cursor-position) (list 0 0))) (snd-display #__line__ ";cursor-position z: ~A" (cursor-position)))
- (if (not (= (cursor) 0)) (snd-display #__line__ ";cursor z: ~A" (cursor)))
+ (if (fneq val 0.0) (snd-display ";sampler z.snd: ~A" val))
+ (if (not (string? str)) (snd-display ";z.snd reader: ~A" str)))
+ (if (not (equal? (cursor-position) (list 0 0))) (snd-display ";cursor-position z: ~A" (cursor-position)))
+ (if (not (= (cursor) 0)) (snd-display ";cursor z: ~A" (cursor)))
(let ((outer (make-player ind 0)))
(let ((pl (make-player ind 0)))
(add-player pl)
@@ -27016,9 +26469,9 @@ EDITS: 2
(close-sound ind)
(let ((tag (catch #t (lambda () (add-player outer)) (lambda args (car args)))))
(if (not (eq? tag 'no-such-player))
- (snd-display #__line__ ";dangling player: ~A" tag)))))
+ (snd-display ";dangling player: ~A" tag)))))
(if (channel-amp-envs "z.snd" 0 100)
- (snd-display #__line__ ";channel-amp-envs of empty file: ~A" (channel-amp-envs "z.snd" 0 100)))
+ (snd-display ";channel-amp-envs of empty file: ~A" (channel-amp-envs "z.snd" 0 100)))
(let ((zz (view-sound "z.snd")))
(select-sound zz)
@@ -27031,7 +26484,7 @@ EDITS: 2
(let ((editctr (edit-position zz))
(old-selection-choice *selection-creates-region*))
(set! *selection-creates-region* #t)
- (if (not (= (edit-position) 0)) (snd-display #__line__ ";revert-sound edit-position: ~A" (edit-position)))
+ (if (not (= (edit-position) 0)) (snd-display ";revert-sound edit-position: ~A" (edit-position)))
(as-one-edit
(lambda ()
(mix s8-snd 24000)
@@ -27041,7 +26494,7 @@ EDITS: 2
(filter-selection '(0 0 .2 1 .5 0 1 0) 40)
(delete-selection)
(mix-region reg))))))
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";as-one-edit mix zz: ~A -> ~A" editctr (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";as-one-edit mix zz: ~A -> ~A" editctr (edit-position)))
(set! *selection-creates-region* old-selection-choice))
(close-sound zz))
(let ((s8 (view-sound s8-snd)))
@@ -27049,9 +26502,9 @@ EDITS: 2
(if (= (channels s8) 8)
(begin
(select-channel 5)
- (if (or (not (number? (selected-channel)))
- (not (= (selected-channel) 5)))
- (snd-display #__line__ ";select-channel: ~A?" (selected-channel)))))
+ (if (not (and (number? (selected-channel))
+ (= (selected-channel) 5)))
+ (snd-display ";select-channel: ~A?" (selected-channel)))))
(let ((editctr (edit-position)))
(as-one-edit
(lambda ()
@@ -27066,7 +26519,7 @@ EDITS: 2
(select-channel 3))
(if (region? reg)
(insert-region reg 80000)))))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display #__line__ ";as-one-edit s8: ~A -> ~A" editctr (edit-position))))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit s8: ~A -> ~A" editctr (edit-position))))
(revert-sound s8)
(close-sound s8))
@@ -27074,22 +26527,21 @@ EDITS: 2
(if (> (chans cfd) 1)
(let ((uval (random 3)))
(set! (channel-style cfd) uval)
- (if (not (= uval (channel-style cfd))) (snd-display #__line__ ";channel-style: ~A ~A?" uval (channel-style cfd)))))
- (if (< (framples cfd) 200000)
- (begin
- (src-sound 2.5 1.0 cfd)
- (src-sound -2.5 1.0 cfd)
- (src-sound .5 1.0 cfd)
- (revert-sound cfd)
- (src-sound -.5 1.0 cfd)
- (src-sound '(0 .5 1 1.5) 1.0 cfd)
- (if (> (framples cfd) 0) (src-sound (make-env '(0 .5 1 1.5) :length (framples cfd)) 1.0 cfd))
- (revert-sound cfd)
- (filter-sound '(0 1 .2 0 .5 1 1 0) 20 cfd)
- (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048 cfd)
- (env-sound '(0 0 .5 1 1 0) 0 (framples cfd) 1.0 cfd)
- (insert-sample 1200 .1 cfd)
- (if (fneq (sample 1200 cfd) .1) (snd-display #__line__ ";insert-sample(looped): ~A?" (sample 1200 cfd)))))
+ (if (not (= uval (channel-style cfd))) (snd-display ";channel-style: ~A ~A?" uval (channel-style cfd)))))
+ (when (< (framples cfd) 200000)
+ (src-sound 2.5 1.0 cfd)
+ (src-sound -2.5 1.0 cfd)
+ (src-sound .5 1.0 cfd)
+ (revert-sound cfd)
+ (src-sound -.5 1.0 cfd)
+ (src-sound '(0 .5 1 1.5) 1.0 cfd)
+ (if (> (framples cfd) 0) (src-sound (make-env '(0 .5 1 1.5) :length (framples cfd)) 1.0 cfd))
+ (revert-sound cfd)
+ (filter-sound '(0 1 .2 0 .5 1 1 0) 20 cfd)
+ (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048 cfd)
+ (env-sound '(0 0 .5 1 1 0) 0 (framples cfd) 1.0 cfd)
+ (insert-sample 1200 .1 cfd)
+ (if (fneq (sample 1200 cfd) .1) (snd-display ";insert-sample(looped): ~A?" (sample 1200 cfd))))
(revert-sound cfd))
(let ((cfd (open-sound "obtest.snd")))
@@ -27104,7 +26556,7 @@ EDITS: 2
(if (< (framples) 100000) (play :wait #t))
(if (fneq (reverb-control-decay cfd) *reverb-control-decay*)
- (snd-display #__line__ ";reverb-control-decay local: ~A, global: ~A" (reverb-control-decay cfd) *reverb-control-decay*))
+ (snd-display ";reverb-control-decay local: ~A, global: ~A" (reverb-control-decay cfd) *reverb-control-decay*))
(set! (reverb-control?) #t)
(set! (reverb-control-scale) .2)
(test-panel reverb-control-scale 'reverb-control-scale)
@@ -27141,23 +26593,23 @@ EDITS: 2
(swap-channels cfd 0 cfd2 0)
(set! (amp-control #t) .75)
(test-panel amp-control 'amp-control)
- (if (> (abs (- (amp-control cfd2) .75)) .05) (snd-display #__line__ ";set-amp .75 #t -> ~A?" (amp-control cfd2)))
+ (if (> (abs (- (amp-control cfd2) .75)) .05) (snd-display ";set-amp .75 #t -> ~A?" (amp-control cfd2)))
(set! (contrast-control-amp #t) .75)
- (if (fneq (contrast-control-amp cfd2) .75) (snd-display #__line__ ";set-contrast-control-amp .75 #t -> ~A?" (contrast-control-amp cfd2)))
+ (if (fneq (contrast-control-amp cfd2) .75) (snd-display ";set-contrast-control-amp .75 #t -> ~A?" (contrast-control-amp cfd2)))
(set! (contrast-control-bounds cfd2) (list 2.0 3.0))
(if (not (feql (contrast-control-bounds cfd2) (list 2.0 3.0)))
- (snd-display #__line__ ";cfd2 contrast-control-bounds: ~A" (contrast-control-bounds cfd2)))
+ (snd-display ";cfd2 contrast-control-bounds: ~A" (contrast-control-bounds cfd2)))
(set! (expand-control-length #t) .025)
- (if (fneq (expand-control-length cfd2) .025) (snd-display #__line__ ";set-expand-control-length .025 #t -> ~A?" (expand-control-length cfd2)))
+ (if (fneq (expand-control-length cfd2) .025) (snd-display ";set-expand-control-length .025 #t -> ~A?" (expand-control-length cfd2)))
(set! (expand-control-hop #t) .025)
- (if (fneq (expand-control-hop cfd2) .025) (snd-display #__line__ ";set-expand-control-hop .025 #t -> ~A?" (expand-control-hop cfd2)))
+ (if (fneq (expand-control-hop cfd2) .025) (snd-display ";set-expand-control-hop .025 #t -> ~A?" (expand-control-hop cfd2)))
(set! (expand-control-jitter #t) .025)
- (if (fneq (expand-control-jitter cfd2) .025) (snd-display #__line__ ";set-expand-control-jitter .025 #t -> ~A?" (expand-control-jitter cfd2)))
+ (if (fneq (expand-control-jitter cfd2) .025) (snd-display ";set-expand-control-jitter .025 #t -> ~A?" (expand-control-jitter cfd2)))
(set! (expand-control-ramp #t) .025)
- (if (fneq (expand-control-ramp cfd2) .025) (snd-display #__line__ ";set-expand-control-ramp .025 #t -> ~A?" (expand-control-ramp cfd2)))
+ (if (fneq (expand-control-ramp cfd2) .025) (snd-display ";set-expand-control-ramp .025 #t -> ~A?" (expand-control-ramp cfd2)))
(let ((clone (clone-sound-as "/tmp/cloned.snd" cfd2)))
(if (not (= (framples cfd2) (framples clone)))
- (snd-display #__line__ ";clone framples: ~A ~A" (framples cfd2) (framples clone)))
+ (snd-display ";clone framples: ~A ~A" (framples cfd2) (framples clone)))
(close-sound clone))
(delete-file "/tmp/cloned.snd")
(mus-sound-forget "/tmp/cloned.snd")
@@ -27166,9 +26618,9 @@ EDITS: 2
(hook-push (edit-hook) (lambda (hook) (set! (hook 'result) #f)))
(let ((editctr (edit-position)))
(as-one-edit (lambda () (set! (sample 200) .2) (set! (sample 300) .3)))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display #__line__ ";as-one-edit: ~A -> ~A" editctr (edit-position)))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit: ~A -> ~A" editctr (edit-position)))
(as-one-edit (lambda () #f))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display #__line__ ";as-one-edit nil: ~A -> ~A" editctr (edit-position))))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit nil: ~A -> ~A" editctr (edit-position))))
(delete-sample 250)
(hook-push (undo-hook) (lambda (hook) (set! (hook 'result) #f)))
(undo)
@@ -27183,7 +26635,7 @@ EDITS: 2
(hook-push snd-warning-hook
(lambda (hook)
(let ((msg (hook 'message)))
- (if (not (string=? msg "hiho")) (snd-display #__line__ ";snd-warning-hook: ~A?" msg))
+ (if (not (string=? msg "hiho")) (snd-display ";snd-warning-hook: ~A?" msg))
(set! (hook 'result) #t))))
(snd-warning "hiho")
(set! (hook-functions snd-error-hook) ())
@@ -27249,24 +26701,24 @@ EDITS: 2
(let ((old-y (delay buffer y)))
(set! current-sample (+ 1 current-sample))
(and (> (moving-average gen (* y y)) .01)
- (if (= current-sample chan-samples)
+ (if (not (= current-sample chan-samples))
+ old-y
;; at end return trailing samples as long as it looks like sound
(let ((temp-buffer (make-delay 128)))
(do ((i 0 (+ i 1))
(fy (delay buffer 0.0) (delay buffer 0.0)))
((= i 128)
(mus-data temp-buffer))
- (delay temp-buffer (if (> (moving-average gen 0.0) .01) fy 0.0))))
- old-y)))))
+ (delay temp-buffer (if (> (moving-average gen 0.0) .01) fy 0.0)))))))))
0 20)
(let ((maxval1 (+ (maxamp) .01)))
(if (not (every-sample? (lambda (y) (< y maxval1))))
(let ((res (scan-channel (lambda (y) (>= y maxval1)))))
- (snd-display #__line__ ";~A, every-sample: ~A ~A [~A: ~A]?" (short-file-name) maxval1 res (cursor) (sample (cursor)))
+ (snd-display ";~A, every-sample: ~A ~A [~A: ~A]?" (short-file-name) maxval1 res (cursor) (sample (cursor)))
(do ((i 0 (+ i 1)))
((= i (edit-position)))
- (snd-display #__line__ ";~D: ~A ~A" i (maxamp #f 0 i) (edit-fragment i))))))
+ (snd-display ";~D: ~A ~A" i (maxamp #f 0 i) (edit-fragment i))))))
(map-channel (echo .5 .75) 0 60000)
(set! (hook-functions after-transform-hook) ())
@@ -27280,7 +26732,7 @@ EDITS: 2
(for-each
(lambda (snd)
- (set! (sync snd) (floor (random 3)))
+ (set! (sync snd) (random 3))
(update-lisp-graph snd))
(sounds))
(hook-push graph-hook superimpose-ffts)
@@ -27303,31 +26755,30 @@ EDITS: 2
;; new variable settings
(letrec ((reset-vars
(lambda (lst)
- (if (pair? lst)
- (let* ((name ((car lst) 0))
- (index (and ((car lst) 2) (choose-fd)))
- (getfnc ((car lst) 1))
- (setfnc (lambda (val snd) (set! (getfnc snd) val)))
- (setfnc-1 (lambda (val) (set! (getfnc) val)))
- (minval ((car lst) 3))
- (maxval ((car lst) 4)))
-
- (if index
- (if (not minval)
- (setfnc #t index)
- (if (rational? minval)
- (if (eq? name #t)
- (setfnc (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2))))) index)
- (setfnc (+ minval (floor (random (- maxval minval)))) index))
- (setfnc (+ minval (random (- maxval minval))) index)))
- (if (not minval)
- (setfnc-1 #t)
- (if (rational? minval)
- (if (eq? name #t)
- (setfnc-1 (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2))))))
- (setfnc-1 (+ minval (floor (random (- maxval minval))))))
- (setfnc-1 (+ minval (random (- maxval minval)))))))
- (reset-vars (cdr lst)))))))
+ (when (pair? lst)
+ (let* ((name ((car lst) 0))
+ (index (and ((car lst) 2) (choose-fd)))
+ (getfnc ((car lst) 1))
+ (setfnc (lambda (val snd) (set! (getfnc snd) val)))
+ (setfnc-1 (lambda (val) (set! (getfnc) val)))
+ (minval ((car lst) 3))
+ (maxval ((car lst) 4)))
+ (cond (index (setfnc (or (not minval)
+ (if (rational? minval)
+ (if (eq? name #t)
+ (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))
+ (+ minval (floor (random (- maxval minval)))))
+ (+ minval (random (- maxval minval)))))
+ index))
+ ((not minval)
+ (setfnc-1 #t))
+ ((not (rational? minval))
+ (setfnc-1 (+ minval (random (- maxval minval)))))
+ ((eq? name #t)
+ (setfnc-1 (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))))
+ (else
+ (setfnc-1 (+ minval (floor (random (- maxval minval)))))))
+ (reset-vars (cdr lst)))))))
(reset-vars
(list
(list 'amp-control amp-control #t .1 1.0)
@@ -27440,23 +26891,23 @@ EDITS: 2
(set! *transform-size* (min *transform-size* 128))))
)))
(set! *sinc-width* 10)
- (if open-files (for-each close-sound open-files))
+ (if (pair? open-files) (for-each close-sound open-files))
(set! *sync-style* sync-none)
(set! open-files ())
(set! (mus-rand-seed) 1234)
- (if (not (= (mus-rand-seed) 1234)) (snd-display #__line__ ";mus-rand-seed: ~A (1234)!" (mus-rand-seed)))
+ (if (not (= (mus-rand-seed) 1234)) (snd-display ";mus-rand-seed: ~A (1234)!" (mus-rand-seed)))
(let ((val (mus-random 1.0))
(val1 (mus-random 1.0)))
(if (or (fneq val -0.7828)
(fneq val1 -0.8804))
- (snd-display #__line__ ";mus-random: ~A ~A?" val val1))
- (if (= (mus-rand-seed) 1234) (snd-display #__line__ ";mus-rand-seed: ~A!" (mus-rand-seed))))
+ (snd-display ";mus-random: ~A ~A?" val val1))
+ (if (= (mus-rand-seed) 1234) (snd-display ";mus-rand-seed: ~A!" (mus-rand-seed))))
(set! (mus-rand-seed) 1234)
(let ((val (mus-random 1.0))
(val1 (mus-random 1.0)))
(if (or (fneq val -0.7828)
(fneq val1 -0.8804))
- (snd-display #__line__ ";mus-random repeated: ~A ~A?" val val1)))
+ (snd-display ";mus-random repeated: ~A ~A?" val val1)))
(set! (hook-functions after-open-hook) ())
(set! (hook-functions close-hook) ())
(set! (hook-functions open-hook) ())
@@ -27474,14 +26925,14 @@ EDITS: 2
(require snd-rubber.scm)
(define (snd_test_15)
- (define (smoother y0 y1 num)
- (let ((v (make-float-vector (+ 1 num)))
+ (define (smoother y0 y1)
+ (let ((v (make-float-vector 11))
(angle (if (> y1 y0) pi 0.0))
(off (* .5 (+ y0 y1)))
- (incr (/ pi num))
+ (incr (/ pi 10))
(scale (* 0.5 (abs (- y1 y0)))))
(do ((i 0 (+ i 1)))
- ((= i num) v)
+ ((= i 10) v)
(set! (v i) (+ off (* scale (cos (+ angle (* i incr)))))))))
(define prefix-it
@@ -27535,34 +26986,34 @@ EDITS: 2
(equal? nv new-value))))
(define chan-equal?
(lambda (vals new-value)
- (cond ((null? vals) #t)
+ (cond ((null? vals))
((pair? vals) (and (chan-equal? (car vals) new-value)
(chan-equal? (cdr vals) new-value)))
(else (test-equal vals new-value)))))
- (if (and (not (equal? (flatten (func #t #t)) (apply map func (all-chans))))
- (not (equal? (flatten (func #t #t)) (apply map func (all-chans-reversed)))))
- (snd-display #__line__ ";test-history-channel ~A[0]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
+ (if (not (or (equal? (flatten (func #t #t)) (apply map func (all-chans)))
+ (equal? (flatten (func #t #t)) (apply map func (all-chans-reversed)))))
+ (snd-display ";test-history-channel ~A[0]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
(let ((old-value (func)))
(func snd1 0)
(set! (func snd1 0) new-value)
(let ((nv (func snd1 0)))
(if (not (test-equal nv new-value))
- (snd-display #__line__ ";test-history-channel set-~A[1]: ~A ~A?" name new-value (func snd1 0))))
+ (snd-display ";test-history-channel set-~A[1]: ~A ~A?" name new-value (func snd1 0))))
(set! (func snd3 2) new-value)
(let ((nv (func snd3 2)))
(if (not (test-equal nv new-value))
- (snd-display #__line__ ";test-history-channel set-~A[2]: ~A ~A?" name new-value (func snd3 2))))
+ (snd-display ";test-history-channel set-~A[2]: ~A ~A?" name new-value (func snd3 2))))
(if (not (test-equal old-value new-value))
(let ((nv (func snd3 1)))
(if (test-equal nv new-value)
- (snd-display #__line__ ";test-history-channel set-~A[3]: ~A ~A?" name new-value (func snd3 1)))))
+ (snd-display ";test-history-channel set-~A[3]: ~A ~A?" name new-value (func snd3 1)))))
(set! (func snd2 #t) new-value)
(let ((nv (func snd2 1)))
(if (not (test-equal nv new-value))
- (snd-display #__line__ ";test-history-channel set-~A[4]: ~A ~A?" name new-value (func snd2 1))))
+ (snd-display ";test-history-channel set-~A[4]: ~A ~A?" name new-value (func snd2 1))))
(set! (func) new-value)
(if (not (chan-equal? (flatten (func #t #t)) new-value))
- (snd-display #__line__ ";test-history-channel ~A[5]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
+ (snd-display ";test-history-channel ~A[5]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
(set! (func) old-value)
))
@@ -27613,14 +27064,14 @@ EDITS: 2
((= i len))
(one-pole incr (abs (- (* scaler (next-sample old-reader)) (next-sample new-reader)))))
(set! diff (one-pole incr 0.0))
- (if (> diff 0.0) (snd-display #__line__ ";diff (~D ~D): ~A" beg len diff))
+ (if (> diff 0.0) (snd-display ";diff (~D ~D): ~A" beg len diff))
(set! diff 0.0)
(set! incr (make-one-pole 1.0 -1.0))
(do ((i 0 (+ i 1)))
((= i 100))
(one-pole incr (abs (- (next-sample old-reader) (next-sample new-reader)))))
(set! diff (one-pole incr 0.0))
- (if (> diff 0.0) (snd-display #__line__ ";zdiff (~D ~D): ~A" beg len diff))
+ (if (> diff 0.0) (snd-display ";zdiff (~D ~D): ~A" beg len diff))
(free-sampler old-reader)
(free-sampler new-reader)))
@@ -27631,7 +27082,7 @@ EDITS: 2
(scale-selection-to maxval)
(let ((newmax (float-vector-peak (samples beg len ind 0))))
(if (fneq newmax maxval)
- (snd-display #__line__ ";scale-selection-to (~D ~D) ~A: ~A?" beg len maxval newmax))))
+ (snd-display ";scale-selection-to (~D ~D) ~A: ~A?" beg len maxval newmax))))
(define play-with-amps
(lambda (sound . amps)
@@ -27639,10 +27090,10 @@ EDITS: 2
(do ((chan 0 (+ 1 chan)))
((= chan chans))
(let ((player (make-player sound chan)))
- (if (not (player? player)) (snd-display #__line__ ";player? ~A -> #f?" player))
- (if (not (member player (players))) (snd-display #__line__ ";player: ~A, but players: ~A" player (players)))
+ (if (not (player? player)) (snd-display ";player? ~A -> #f?" player))
+ (if (not (member player (players))) (snd-display ";player: ~A, but players: ~A" player (players)))
(if (not (equal? (player-home player) (list sound chan)))
- (snd-display #__line__ ";player-home ~A ~A?" (player-home player) (list sound chan)))
+ (snd-display ";player-home ~A ~A?" (player-home player) (list sound chan)))
(set! (amp-control player) (amps chan))
(set! (speed-control player) .5)
(set! (expand-control? player) #t)
@@ -27665,1566 +27116,1539 @@ EDITS: 2
(set! *transform-type* fourier-transform)
- (if with-gui
- (begin
-
- (do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
- (log-mem clmtest)
+ (when with-gui
+ (do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
+ (log-mem clmtest)
+
+ (let ((obi (open-sound (car (match-sound-files (lambda (file)
+ (and (not (= (mus-sound-header-type file) mus-raw))
+ (= (mus-sound-chans file) 1))))))))
+
+ (if (not (equal? (all-chans) (list (list obi) (list 0)))) (snd-display ";all-chans: ~A?" (all-chans)))
+ (let ((s2i (open-sound (car (match-sound-files (lambda (file) (= (mus-sound-chans file) 2)))))))
+ (if (not (or (equal? (all-chans) (list (list obi s2i s2i) (list 0 0 1)))
+ (equal? (all-chans) (list (list s2i s2i obi) (list 0 1 0)))))
+ (snd-display ";all-chans(2): ~A?" (all-chans)))
+ (if (not (string=? (finfo "oboe.snd") "oboe.snd: chans: 1, srate: 22050, Sun/Next, big endian short (16 bits), len: 2.305"))
+ (snd-display ";finfo: ~A?" (finfo "oboe.snd")))
+ (close-sound s2i)
+ (close-sound obi)
+ (if (not (equal? (all-chans) '(() ()))) (snd-display ";all-chans(0): ~A?" (all-chans)))
+ (set! obi (open-sound "oboe.snd"))
+ (set! (cursor obi) 1000)
+ (let ((tick (locate-zero .001)))
+ (if (not (= tick 1050))
+ (snd-display ";locate-zero: ~A = ~A (second try: ~A)?" tick (sample tick) (locate-zero .001))))
+ (hook-push graph-hook auto-dot)
+ (hook-push graph-hook superimpose-ffts)
+ (set! (transform-graph? obi 0) #t)
+ ;(update-graphs)
+ (set! s2i (open-sound (car (match-sound-files (lambda (file) (= (mus-sound-chans file) 2))))))
+ (if (not (= (chans s2i) 2)) (snd-display ";match 2 got ~A with ~A chans" (short-file-name s2i) (chans s2i)))
+ ;(update-graphs)
+ (hook-remove graph-hook auto-dot)
+ (hook-remove graph-hook superimpose-ffts)
+ (set! (transform-graph? obi 0) #f)
+ (select-sound obi)
+ (let ((m1 (add-mark 100 obi 0)))
+ (first-mark-in-window-at-left)
+ (if (> (abs (- (left-sample obi 0) 100)) 1) (snd-display ";mark-in-window: ~A ~A?" (left-sample obi 0) (mark-sample m1)))
+ (delete-mark m1))
+ (close-sound s2i)
+ (safe-make-selection obi)
+ (delete-selection-and-smooth)
+ (if (not (equal? (edit-fragment 0 obi 0) '("" "init" 0 50828)))
+ (snd-display ";edit-fragment(0): ~S?" (edit-fragment 0 obi 0)))
+ (if (not (equal? (edit-fragment 1 obi 0) '("delete-samples 1000 1001" "delete" 1000 1001)))
+ (snd-display ";edit-fragment(1): ~S?" (edit-fragment 1 obi 0)))
+ (if (not (equal? (edit-fragment 2 obi 0) '("delete-selection-and-smooth" "set" 968 64)))
+ (snd-display ";edit-fragment(2): ~S?" (edit-fragment 2 obi 0)))
- (let ((obi (open-sound (car (match-sound-files (lambda (file)
- (and (not (= (mus-sound-header-type file) mus-raw))
- (= (mus-sound-chans file) 1))))))))
-
- (if (not (equal? (all-chans) (list (list obi) (list 0)))) (snd-display #__line__ ";all-chans: ~A?" (all-chans)))
- (let ((s2i (open-sound (car (match-sound-files (lambda (file) (= (mus-sound-chans file) 2)))))))
- (if (and (not (equal? (all-chans) (list (list obi s2i s2i) (list 0 0 1))))
- (not (equal? (all-chans) (list (list s2i s2i obi) (list 0 1 0)))))
- (snd-display #__line__ ";all-chans(2): ~A?" (all-chans)))
- (if (not (string=? (finfo "oboe.snd") "oboe.snd: chans: 1, srate: 22050, Sun/Next, big endian short (16 bits), len: 2.305"))
- (snd-display #__line__ ";finfo: ~A?" (finfo "oboe.snd")))
- (close-sound s2i)
- (close-sound obi)
- (if (not (equal? (all-chans) '(() ()))) (snd-display #__line__ ";all-chans(0): ~A?" (all-chans)))
- (set! obi (open-sound "oboe.snd"))
- (set! (cursor obi) 1000)
- (let ((tick (locate-zero .001)))
- (if (not (= tick 1050))
- (snd-display #__line__ ";locate-zero: ~A = ~A (second try: ~A)?" tick (sample tick) (locate-zero .001))))
- (hook-push graph-hook auto-dot)
- (hook-push graph-hook superimpose-ffts)
- (set! (transform-graph? obi 0) #t)
- ;(update-graphs)
- (set! s2i (open-sound (car (match-sound-files (lambda (file) (= (mus-sound-chans file) 2))))))
- (if (not (= (chans s2i) 2)) (snd-display #__line__ ";match 2 got ~A with ~A chans" (short-file-name s2i) (chans s2i)))
- ;(update-graphs)
- (hook-remove graph-hook auto-dot)
- (hook-remove graph-hook superimpose-ffts)
- (set! (transform-graph? obi 0) #f)
- (select-sound obi)
- (let ((m1 (add-mark 100 obi 0)))
- (first-mark-in-window-at-left)
- (if (> (abs (- (left-sample obi 0) 100)) 1) (snd-display #__line__ ";mark-in-window: ~A ~A?" (left-sample obi 0) (mark-sample m1)))
- (delete-mark m1))
- (close-sound s2i)
- (safe-make-selection 1000 2000 obi)
- (delete-selection-and-smooth)
- (if (not (equal? (edit-fragment 0 obi 0) '("" "init" 0 50828)))
- (snd-display #__line__ ";edit-fragment(0): ~S?" (edit-fragment 0 obi 0)))
- (if (not (equal? (edit-fragment 1 obi 0) '("delete-samples 1000 1001" "delete" 1000 1001)))
- (snd-display #__line__ ";edit-fragment(1): ~S?" (edit-fragment 1 obi 0)))
- (if (not (equal? (edit-fragment 2 obi 0) '("delete-selection-and-smooth" "set" 968 64)))
- (snd-display #__line__ ";edit-fragment(2): ~S?" (edit-fragment 2 obi 0)))
-
- (let ((maxa (maxamp obi)))
- (normalized-mix "pistol.snd" 1000 0 obi 0)
- (let ((nmaxa (maxamp obi)))
- (if (fneq maxa nmaxa) (snd-display #__line__ ";normalized-mix: ~A ~A?" maxa nmaxa)))
- (revert-sound obi))
- (set! s2i (open-sound (car (match-sound-files (lambda (file)
- (and (= (mus-sound-chans file) 2)
- (not (= (mus-sound-header-type file) mus-raw))
- (> (mus-sound-framples file) 1000)))))))
- (if (not (= (chans s2i) 2)) (snd-display #__line__ ";match 2+1000 got ~A with ~A chans" (short-file-name s2i) (chans s2i)))
- (let ((o1 (sample 1000 obi 0))
- (s1 (sample 1000 s2i 0))
- (s2 (sample 1000 s2i 1)))
- (do-all-chans (lambda (val) (* val 2.0)) "double all samples")
- (let ((o11 (sample 1000 obi 0))
- (s11 (sample 1000 s2i 0))
- (s21 (sample 1000 s2i 1)))
- (if (or (fneq (* 2.0 o1) o11)
- (fneq (* 2.0 s1) s11)
- (fneq (* 2.0 s2) s21))
- (snd-display #__line__ ";do-all-chans: ~A?" (list o1 s1 s2 o11 s11 s21)))))
- (update-graphs)
- (let ((m1 (maxamp obi 0))
- (m2 (maxamp s2i 0))
- (m3 (maxamp s2i 1))
- (mc (apply map maxamp (list (list obi s2i s2i) (list 0 0 1)))))
- (if (or (fneq m1 (car mc))
- (fneq m2 (cadr mc))
- (fneq m3 (caddr mc)))
- (snd-display #__line__ ";map maxamp all-chans: ~A ~A ~A ~A?" m1 m2 m3 mc))
- (set! (sync obi) 1)
- (set! (sync s2i) 1)
- (do-chans (lambda (val) (* val 2.0)) "*2")
- (let ((mc1 (apply map maxamp (list (list obi s2i s2i) (list 0 0 1)))))
- (if (or (fneq (* 2.0 m1) (car mc1))
- (fneq (* 2.0 m2) (cadr mc1))
- (fneq (* 2.0 m3) (caddr mc1)))
- (snd-display #__line__ ";do-chans: ~A ~A?" mc mc1))
- (set! (sync obi) 0)
- (set! (sync s2i) 0)
- (select-sound s2i)
- (do-sound-chans (lambda (val) (* val 0.5)) "/2")
- (let ((mc2 (apply map maxamp (list (list obi s2i s2i) (list 0 0 1)))))
- (if (or (fneq (* 2.0 m1) (car mc2))
- (fneq m2 (cadr mc2))
- (fneq m3 (caddr mc2)))
- (snd-display #__line__ ";do-sound-chans: ~A ~A ~A?" mc mc1 mc2)))
- ; (if (every-sample? (lambda (val) (> val .5))) (snd-display #__line__ ";every-sample(0)?"))
- (if (not (every-sample? (lambda (val) (< val 5.0)))) (snd-display #__line__ ";every-sample(1)?"))
- (select-sound obi)
- (let ((bins (sort-samples 32)))
- (if (not (= (vector-ref bins 1) 4504)) (snd-display #__line__ ";sort-samples: ~A?" bins)))
- ))
- (revert-sound s2i)
- (revert-sound obi)
- (set! (sync obi) 3)
- (set! (sync s2i) 3)
- (let* ((half-way (floor (* 0.5 (framples obi))))
- (o1 (sample half-way obi 0))
- (s1 (sample half-way s2i 0))
- (s2 (sample half-way s2i 1)))
- (place-sound obi s2i '(0 .5 1 .5))
- (let ((s21 (sample half-way s2i 0))
- (s22 (sample half-way s2i 1)))
- (revert-sound s2i)
- (place-sound obi s2i 45.0)
- (let ((s31 (sample half-way s2i 0))
- (s32 (sample half-way s2i 1)))
- (if (or (fneq (+ s1 (* 0.5 o1)) s21)
- (fneq (+ s2 (* 0.5 o1)) s22)
- (fneq s21 s31)
- (fneq s22 s32))
- (snd-display #__line__ ";place: ~A " (list o1 s1 s2 s21 s22 s31 s32))))))
- (revert-sound s2i)
- (revert-sound obi)
+ (let ((maxa (maxamp obi)))
+ (normalized-mix "pistol.snd" 1000 0 obi 0)
+ (let ((nmaxa (maxamp obi)))
+ (if (fneq maxa nmaxa) (snd-display ";normalized-mix: ~A ~A?" maxa nmaxa)))
+ (revert-sound obi))
+ (set! s2i (open-sound (car (match-sound-files (lambda (file)
+ (and (= (mus-sound-chans file) 2)
+ (not (= (mus-sound-header-type file) mus-raw))
+ (> (mus-sound-framples file) 1000)))))))
+ (if (not (= (chans s2i) 2)) (snd-display ";match 2+1000 got ~A with ~A chans" (short-file-name s2i) (chans s2i)))
+ (let ((o1 (sample 1000 obi 0))
+ (s1 (sample 1000 s2i 0))
+ (s2 (sample 1000 s2i 1)))
+ (do-all-chans (lambda (val) (* val 2.0)) "double all samples")
+ (let ((o11 (sample 1000 obi 0))
+ (s11 (sample 1000 s2i 0))
+ (s21 (sample 1000 s2i 1)))
+ (if (or (fneq (* 2.0 o1) o11)
+ (fneq (* 2.0 s1) s11)
+ (fneq (* 2.0 s2) s21))
+ (snd-display ";do-all-chans: ~A?" (list o1 s1 s2 o11 s11 s21)))))
+ (update-graphs)
+ (let ((m1 (maxamp obi 0))
+ (m2 (maxamp s2i 0))
+ (m3 (maxamp s2i 1))
+ (mc (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (if (or (fneq m1 (car mc))
+ (fneq m2 (cadr mc))
+ (fneq m3 (caddr mc)))
+ (snd-display ";map maxamp all-chans: ~A ~A ~A ~A?" m1 m2 m3 mc))
+ (set! (sync obi) 1)
+ (set! (sync s2i) 1)
+ (do-chans (lambda (val) (* val 2.0)) "*2")
+ (let ((mc1 (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (if (or (fneq (* 2.0 m1) (car mc1))
+ (fneq (* 2.0 m2) (cadr mc1))
+ (fneq (* 2.0 m3) (caddr mc1)))
+ (snd-display ";do-chans: ~A ~A?" mc mc1))
(set! (sync obi) 0)
(set! (sync s2i) 0)
- (if (or (fneq ((compand) 0.0) 0.0)
- (fneq ((compand) 1.0) 1.0)
- (fneq ((compand) .1) .2)
- (fneq ((compand) .99) .997)
- (fneq ((compand) .95) .984))
- (snd-display #__line__ ";compand: ~A?" (list ((compand) 0.0) ((compand) 1.0) ((compand) .1) ((compand) .99) ((compand) .95))))
-
- (close-sound obi)
- (revert-sound s2i)
- (let ((s1 (sample 1000 s2i 0))
- (s2 (sample 1000 s2i 1)))
- (set! (sync s2i) 4)
- (select-all)
- (if (not (= (selection-chans) 2))
- (begin
- (snd-display #__line__ ";selection-chans(2): ~A?" (selection-chans))
- (for-each
- (lambda (snd)
- (do ((i 0 (+ i 1)))
- ((= i (chans snd)))
- (if (selection-member? snd i)
- (snd-display #__line__ "; ~A[~A] at ~A" (short-file-name snd) i (selection-position snd i)))))
- (sounds))))
- (if (not (= (selection-srate) (srate s2i))) (snd-display #__line__ ";selection-srate: ~A ~A?" (selection-srate) (srate s2i)))
- (if (= (selection-chans) 2)
- (begin
- (swap-selection-channels)
- (if (or (fneq s1 (sample 1000 s2i 1))
- (fneq s2 (sample 1000 s2i 0)))
- (snd-display #__line__ ";swap-selection-channels: ~A?" (list s1 s2 (sample 1000 s2i 0) (sample 1000 s2i 1)))))))
+ (select-sound s2i)
+ (do-sound-chans (lambda (val) (* val 0.5)) "/2")
+ (let ((mc2 (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (if (or (fneq (* 2.0 m1) (car mc2))
+ (fneq m2 (cadr mc2))
+ (fneq m3 (caddr mc2)))
+ (snd-display ";do-sound-chans: ~A ~A ~A?" mc mc1 mc2)))
+ ; (if (every-sample? (lambda (val) (> val .5))) (snd-display ";every-sample(0)?"))
+ (if (not (every-sample? (lambda (val) (< val 5.0)))) (snd-display ";every-sample(1)?"))
+ (select-sound obi)
+ (let ((bins (sort-samples 32)))
+ (if (not (= (vector-ref bins 1) 4504)) (snd-display ";sort-samples: ~A?" bins)))
+ ))
+ (revert-sound s2i)
+ (revert-sound obi)
+ (set! (sync obi) 3)
+ (set! (sync s2i) 3)
+ (let* ((half-way (floor (* 0.5 (framples obi))))
+ (o1 (sample half-way obi 0))
+ (s1 (sample half-way s2i 0))
+ (s2 (sample half-way s2i 1)))
+ (place-sound obi s2i '(0 .5 1 .5))
+ (let ((s21 (sample half-way s2i 0))
+ (s22 (sample half-way s2i 1)))
(revert-sound s2i)
- (close-sound s2i)
-
- (set! obi (open-sound "oboe.snd"))
- (select-all)
- (for-each forget-region (regions))
- (if (not (null? (regions))) (snd-display #__line__ ";no regions? ~A" (regions)))
- (let ((id (make-region 100 200 obi 0)))
- (if (not (equal? (regions) (list id))) (snd-display #__line__ ";make-region regions: ~A?" (regions))))
-
- (revert-sound obi)
- (let ((oldlen (framples obi)))
- (env-sound-interp '(0 0 1 1 2 0) 2.0 obi 0)
- (let ((newlen (framples obi)))
- (if (> (abs (- (* 2 oldlen) newlen)) 3)
- (snd-display #__line__ ";env-sound-interp: ~A ~A?" oldlen newlen))))
-
- (revert-sound obi)
- (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0))
- (if (not (= (edit-position obi 0) 1)) (snd-display #__line__ ";granulated-sound-interp no-op 1?"))
- (if (< (maxamp obi 0) .15) (snd-display #__line__ ";granulated-sound-interp 1 maxamp: ~A" (maxamp obi 0)))
- (if (> (abs (- (framples obi 0) 50828)) 1000) (snd-display #__line__ ";granulated-sound-interp 1 framples: ~A" (framples obi 0)))
- (revert-sound obi)
- (granulated-sound-interp '(0 0 1 1) 2.0)
- (if (not (= (edit-position obi 0) 1)) (snd-display #__line__ ";granulated-sound-interp no-op 2?"))
- (if (< (maxamp obi 0) .145) (snd-display #__line__ ";granulated-sound-interp 2 maxamp: ~A" (maxamp obi 0)))
- (if (> (abs (- (framples obi 0) 101656)) 1000) (snd-display #__line__ ";granulated-sound-interp 2 framples: ~A" (framples obi 0)))
- (revert-sound obi)
- (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0) 0.02)
- (if (not (= (edit-position obi 0) 1)) (snd-display #__line__ ";granulated-sound-interp no-op 3?"))
- (if (< (maxamp obi 0) .2) (snd-display #__line__ ";granulated-sound-interp 3 maxamp: ~A" (maxamp obi 0)))
- (if (> (abs (- (framples obi 0) 50828)) 1000) (snd-display #__line__ ";granulated-sound-interp 3 framples: ~A" (framples obi 0)))
-
- (close-sound obi)
- )
-
- (let ((old-srate *clm-srate*))
- (set! *clm-srate* 22050)
- (let ((ind (new-sound "test.snd" :size 20)))
- (if (< *print-length* 20) (set! *print-length* 20))
- (offset-channel 1.0)
- (env-sound '(0 0 1 1))
- (let ((osc (make-oscil :frequency 1000.0 :initial-phase (+ pi (/ pi 2))))
- (reader (make-sound-interp 0 ind 0))
- (len (- (framples ind 0) 1)))
- (map-channel (lambda (val)
- (sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc)))))))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.020 0.079 0.172 0.291 0.427 0.569 0.706 0.825 0.919
- 0.979 1.000 0.981 0.923 0.831 0.712 0.576 0.434 0.298 0.177)))
- (snd-display #__line__ ";sound-interp: ~A" (channel->float-vector))))
- (undo)
-
- (let ((osc (make-oscil :frequency 0.5 :initial-phase (+ pi (/ pi 2))))
- (reader (make-sound-interp 0 ind 0))
- (len (- (framples ind 0) 1)))
- (map-channel (lambda (val)
- (sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc))))))))
- (undo)
-
- (env-sound-interp '(0 0 1 1))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474
- 0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
- (snd-display #__line__ ";env-sound-interp no change: ~A" (channel->float-vector)))
- (undo)
- (env-sound-interp '(0 0 1 .95 2 0) 2.0)
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.050 0.100 0.150 0.200 0.250 0.300 0.350 0.400 0.450
- 0.500 0.550 0.600 0.650 0.700 0.750 0.800 0.850 0.900 0.950
- 1.000 0.950 0.900 0.850 0.800 0.750 0.700 0.650 0.600 0.550
- 0.500 0.450 0.400 0.350 0.300 0.250 0.200 0.150 0.100 0.050)))
- (snd-display #__line__ ";env-sound-interp twice len and back: ~A" (channel->float-vector)))
- (revert-sound ind)
- (set! (sample 10) .5)
- (remove-clicks)
- (if (fneq (sample 10) 0.0) (snd-display #__line__ ";remove-clicks: ~A" (channel->float-vector)))
- (undo)
- (let ((vals (scan-channel (search-for-click))))
- (if (not (= vals 11))
- (snd-display #__line__ ";search-for-click: ~A" vals)))
- (close-sound ind))
- (set! *clm-srate* old-srate))
-
- (let ((ind1 (new-sound :size 20 :comment "new-sound for sound-via-sound"))
- (ind2 (new-sound :size 20 :comment "second new-sound for sound-via-sound")))
- (let ((val -0.05)) (map-channel (lambda (y) (set! val (+ val .05))) 0 20 ind1))
- (let ((val 1.1)) (map-channel (lambda (y) (set! val (- val .1))) 0 20 ind2))
- (select-sound ind1)
- (sound-via-sound ind1 ind2)
- (let ((vals (channel->float-vector 0 20 ind1)))
- (if (not (vequal vals (float-vector 0.95 0.90 0.85 0.80 0.75 0.70 0.65 0.60 0.55 0.50 0.45 0.40 0.35 0.30 0.25 0.20 0.15 0.10 0.05 0.00)))
- (snd-display #__line__ ";sound-via-sound: ~A" vals)))
- (let ((new-file-name (file-name ind2)))
- (close-sound ind2)
- (if (file-exists? new-file-name) (delete-file new-file-name)))
- (revert-sound ind1)
- (let ((val -.5)) (map-channel (lambda (y) (set! val (+ val .05)))))
- (let ((val (scan-channel (zero+))))
- (if (or (not val)
- (not (= val 10)))
- (snd-display #__line__ ";zero+: ~A" val)))
- (set! (sample 8) .8)
- (let ((val (scan-channel (next-peak))))
- (if (or (not val)
- (not (= val 9)))
- (snd-display #__line__ ";next-peak: ~A" val)))
- (let ((val (scan-channel (search-for-click))))
- (if (or (not val)
- (not (= val 9)))
- (snd-display #__line__ ";search-for-click: ~A" val)))
- (if (not (= (find-click 0) 8)) (snd-display #__line__ ";find-click: ~A" (find-click 0)))
- (let ((new-file-name (file-name ind1)))
- (close-sound ind1)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
-
- (let* ((id (open-sound "oboe.snd"))
- (fr (framples id 0))
- (mx (maxamp id 0)))
- (set! (framples id 0) 25000)
- (if (not (= (framples id 0) 25000)) (snd-display #__line__ ";set-framples 25000: ~A?" (framples id 0)))
- (if (not (= (edit-position id 0) 1)) (snd-display #__line__ ";set-framples 25000 edit: ~A?" (edit-position id 0)))
- (set! (framples id 0) 75000)
- (if (not (= (framples id 0) 75000)) (snd-display #__line__ ";set-framples 75000: ~A?" (framples id 0)))
- (if (not (= (edit-position id 0) 2)) (snd-display #__line__ ";set-framples 75000 edit: ~A?" (edit-position id 0)))
- (if (fneq (sample 30000 id 0) 0.0) (snd-display #__line__ ";set-framples 75000 zeros: ~A?" (sample 30000 id 0)))
- (set! (framples id 0) 0)
- (if (not (= (framples id 0) 0)) (snd-display #__line__ ";set-framples 0: ~A?" (framples id 0)))
- (set! (framples id 0) 100)
- (if (not (= (framples id 0) 100)) (snd-display #__line__ ";set-framples 100: ~A?" (framples id 0)))
- (revert-sound)
- (if (fneq (sample 30000 id 0) -0.0844) (snd-display #__line__ ";revert from set-framples: ~A?" (sample 30000 id 0)))
- (if (not (= fr (framples id 0))) (snd-display #__line__ ";revert set-framples: ~A != ~A?" (framples id 0) fr))
- (set! (maxamp id 0) .5)
- (if (fneq (maxamp id 0) .5) (snd-display #__line__ ";set-maxamp: ~A?" (maxamp id 0)))
- (if (not (= (edit-position id 0) 1)) (snd-display #__line__ ";set-maxamp edit: ~A?" (edit-position id 0)))
- (set! (maxamp id 0) .1)
- (if (fneq (maxamp id 0) .1) (snd-display #__line__ ";set-maxamp .1: ~A?" (maxamp id 0)))
- (if (not (= (edit-position id 0) 2)) (snd-display #__line__ ";set-maxamp .1 edit: ~A?" (edit-position id 0)))
- (revert-sound)
- (if (fneq (maxamp id 0) mx) (snd-display #__line__ ";maxamp after set: ~A ~A?" (maxamp id 0) mx))
- (set! (x-position-slider id 0) .1)
- (if (fneq (x-position-slider id 0) .1) (snd-display #__line__ ";set x-position-slider .1: ~A?" (x-position-slider id 0)))
- ;(if (> (abs (- (left-sample id 0) 5083)) 3) (snd-display #__line__ ";set x-position-slider sample 5083: ~A?" (left-sample id 0)))
- (set! (x-zoom-slider id 0) .5)
- (if (fneq (x-zoom-slider id 0) .5) (snd-display #__line__ ";set x-zoom-slider: ~A?" (x-zoom-slider id 0)))
- (if (> (abs (- fr (* 2 (- (right-sample id 0) (left-sample id 0))))) 10)
- (snd-display #__line__ ";set x-zoom-slider: ~A ~A -> ~A?"
- (left-sample id 0) (right-sample id 0)
- (abs (- fr (* 2 (right-sample id 0) (left-sample id 0))))))
- (set! (y-position-slider id 0) .1)
- (if (and (not (provided? 'snd-gtk)) (fneq (y-position-slider id 0) .1))
- (snd-display #__line__ ";set y-position-slider .1: ~A?" (y-position-slider id 0)))
- (set! (y-zoom-slider id 0) .5)
- (if (fneq (y-zoom-slider id 0) .5) (snd-display #__line__ ";set y-zoom-slider: ~A?" (y-zoom-slider id 0)))
- (let ((vals (channel-amp-envs "oboe.snd" 0 10)))
- (if (or (not (vequal (car vals)
- (float-vector -4.8828125e-4 -0.104156494140625 -0.125213623046875 -0.1356201171875 -0.138916015625
- -0.14093017578125 -0.14093017578125 -0.131439208984375 -0.11248779296875 -0.080047607421875)))
- (not (vequal (cadr vals)
- (float-vector 0.0 0.10955810546875 0.130706787109375 0.14068603515625 0.141204833984375 0.147247314453125
- 0.145904541015625 0.140289306640625 0.126861572265625 0.08172607421875))))
- (snd-display #__line__ ";channel-amp-envs: ~A?" vals)))
-
- (let ((len (length (channel-properties id 0))))
- (if (channel-property 'hiho id 0)
- (snd-display #__line__ ";channel-property 'hiho: ~A?" (channel-property 'hiho id 0)))
- (set! (channel-property 'hiho id 0) 123)
- (if (not (= (channel-property 'hiho id 0) 123))
- (snd-display #__line__ ";channel-property 'hiho (123): ~A?" (channel-property 'hiho id 0)))
- (if (channel-property 'hi id 0)
- (snd-display #__line__ ";channel-property 'hi: ~A?" (channel-property 'hi id 0)))
- (set! (channel-property 'hi id 0) pi)
- (if (fneq (channel-property 'hi id 0) pi)
- (snd-display #__line__ ";channel-property 'hi (pi): ~A?" (channel-property 'hi id 0)))
- (if (not (= (channel-property 'hiho id 0) 123))
- (snd-display #__line__ ";channel-property 'second hiho (123): ~A?" (channel-property 'hiho id 0)))
- (if (not (= (length (channel-properties id 0)) (+ len 2)))
- (snd-display #__line__ ";channel-properties: ~A?" (channel-properties id 0))))
-
- (let ((len (length (sound-properties id))))
- (if (sound-property 'hiho id)
- (snd-display #__line__ ";sound-property 'hiho: ~A?" (sound-property 'hiho id)))
- (set! (sound-property 'hiho id) 123)
- (if (not (= (sound-property 'hiho id) 123))
- (snd-display #__line__ ";sound-property 'hiho (123): ~A?" (sound-property 'hiho id)))
- (if (sound-property 'hi id)
- (snd-display #__line__ ";sound-property 'hi: ~A?" (sound-property 'hi id)))
- (set! (sound-property 'hi id) pi)
- (if (fneq (sound-property 'hi id) pi)
- (snd-display #__line__ ";sound-property 'hi (pi): ~A?" (sound-property 'hi id)))
- (if (not (= (sound-property 'hiho id) 123))
- (snd-display #__line__ ";sound-property 'second hiho (123): ~A?" (sound-property 'hiho id)))
- (if (not (= (length (sound-properties id)) (+ len 2)))
- (snd-display #__line__ ";sound-properties: ~A?" (sound-properties id))))
-
- (let ((tag (catch #t (lambda () (map-channel (lambda (y) "hiho"))) (lambda args args))))
- (if (not (eq? (car tag) 'wrong-type-arg)) (snd-display #__line__ ";map-channel bad val: ~A" tag)))
-
- (close-sound id))
-
- (let ((ind (open-sound "oboe.snd")))
- (if (not (null? (edit-properties ind 0 0)))
- (snd-display #__line__ ";initial edit-properties: ~A?" (edit-properties ind 0 0)))
- (let ((tag (catch #t
- (lambda () (edit-properties ind 0 123))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-edit))
- (snd-display #__line__ ";edit-properties of non-existent edit: ~A" tag)))
- (let ((tag (catch #t
- (lambda () (edit-properties ind 1 0))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-channel))
- (snd-display #__line__ ";edit-properties of non-existent channel: ~A" tag)))
- (if (edit-property 'test-key ind 0 0)
- (snd-display #__line__ ";edit-property never set: ~A?" (edit-property ind 0 0)))
- (set! (edit-property 'test-key ind 0 0) 3210)
- (let ((val (edit-property 'test-key ind 0 0)))
- (if (or (not (number? val))
- (not (= val 3210)))
- (snd-display #__line__ ";edit-property 0: ~A" val)))
- (pad-channel 0 10 ind 0)
- (let ((val (edit-property 'test-key ind 0 0)))
- (if (or (not (number? val))
- (not (= val 3210)))
- (snd-display #__line__ ";edit-property look back to 0: ~A" val)))
- (let ((val (edit-property 'test-key ind 0 1)))
- (if val (snd-display #__line__ ";edit-property current: ~A?" val)))
- (undo)
- (let ((val (edit-property 'test-key ind 0 0)))
- (if (or (not (number? val))
- (not (= val 3210)))
- (snd-display #__line__ ";edit-property go back to 0: ~A" val)))
- (close-sound ind)
- (set! ind (open-sound "oboe.snd"))
- (if (edit-property 'test-key ind 0 0)
- (snd-display #__line__ ";edit-property not cleared: ~A?" (edit-property ind 0 0)))
- (pad-channel 0 10 ind 0)
- (set! (edit-property 'test-key ind 0 1) 'hiho)
- (undo)
- (pad-channel 0 10 ind 0)
- (let ((val (edit-property 'test-key ind 0 1)))
- (if val (snd-display #__line__ ";edit-property not erased upon re-edit: ~A?" val)))
- (close-sound ind))
-
- (let ((id (open-sound "oboe.snd")))
- (prefix-it 1000 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\b) 4 id)
- (let ((left (left-sample id)))
- (if (not (= left 1000)) (snd-display #__line__ ";u1000: ~A" left)))
- (prefix-it 0 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\b) 4 id)
- (let ((left (left-sample id)))
- (if (not (= left 0)) (snd-display #__line__ ";u0: ~A" left)))
- (set! (cursor id) 1234)
- (prefix-it 0 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1234)) (snd-display #__line__ ";0f: ~A" cr)))
- (prefix-it 100 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1334)) (snd-display #__line__ ";100f: ~A" cr)))
- (prefix-it -100 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1234)) (snd-display #__line__ ";-100f: ~A" cr)))
- (prefix-it 1 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1235)) (snd-display #__line__ ";1f: ~A" cr)))
- (prefix-it 1000 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\p) 4 id)
- (let ((left (left-sample id))
- (right (right-sample id)))
- (if (> (abs (- right left 1000)) 2) (snd-display #__line__ ";1000xp: ~A:~A" left right)))
- (prefix-it 1 id)
- (key (char->integer #\.) 0 id)
- (key (char->integer #\2) 0 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\p) 4 id)
- (let ((left (left-sample id))
- (right (right-sample id)))
- (if (> (abs (- right left (* 22050 1.2))) 2) (snd-display #__line__ ";1.2xp: ~A:~A" left right)))
-
- (prefix-uit 1000 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\b) 4 id)
- (let ((left (left-sample id)))
- (if (and (not (= left 1000)) (not (= left 1001))) (snd-display #__line__ ";uu1000: ~A" left)))
- (prefix-uit 0 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\b) 4 id)
- (let ((left (left-sample id)))
- (if (not (= left 0)) (snd-display #__line__ ";uu0: ~A" left)))
- (set! (cursor id) 1234)
- (prefix-uit 0 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1234)) (snd-display #__line__ ";u0f: ~A" cr)))
- (prefix-uit 100 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1334)) (snd-display #__line__ ";u100f: ~A" cr)))
- (prefix-uit -100 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1234)) (snd-display #__line__ ";u-100f: ~A" cr)))
- (prefix-uit 1 id)
- (key (char->integer #\f) 4 id)
- (let ((cr (cursor id)))
- (if (not (= cr 1235)) (snd-display #__line__ ";u1f: ~A" cr)))
- (prefix-uit 1000 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\p) 4 id)
- (let ((left (left-sample id))
- (right (right-sample id)))
- (if (> (abs (- right left 1000)) 2) (snd-display #__line__ ";u1000xp: ~A:~A" left right)))
- (prefix-uit 1 id)
- (key (char->integer #\.) 0 id)
- (key (char->integer #\2) 0 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\p) 4 id)
- (let ((left (left-sample id))
- (right (right-sample id)))
- (if (> (abs (- right left (* 22050 1.2))) 2) (snd-display #__line__ ";u1.2xp: ~A:~A" left right)))
- (close-sound id))
- (let ((id (open-sound (car (match-sound-files (lambda (file)
- (and (>= (mus-sound-chans file) 2)
- (not (= (mus-sound-header-type file) mus-raw))
- (> (mus-sound-framples file) 1000))))))))
- (set! (sync id) 1)
- (select-sound id)
- (make-region 200 500 id)
- (select-channel 1)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\v) 0 id)
- (let ((x0 (x-bounds id 0))
- (x1 (x-bounds id 1)))
- (if (or (fneq (car x0) (car x1))
- (fneq (cadr x0) (cadr x1)))
- (snd-display #__line__ ";C-X v: ~A ~A?" x0 x1)))
- (key (char->integer #\u) 4 id)
- (key (char->integer #\1) 0 id)
- (key (char->integer #\x) 4 id)
- (key (char->integer #\q) 0 id)
- (close-sound id))
-
- (let ((snd1 (open-sound "oboe.snd"))
- (snd2 (or (open-sound "2.snd") (open-sound "4.aiff")))
- (snd3 (open-sound "4.aiff")))
- (define tests-1
- (lambda (f fn nv)
- (if (pair? f)
- (begin
- (test-history-channel (car f) (car fn) (car nv) snd1 snd2 snd3)
- (tests-1 (cdr f) (cdr fn) (cdr nv))))))
- (tests-1 funcs func-names new-values)
- (close-sound snd1)
- (close-sound snd2)
-
- (set! (time-graph-style snd3 #t) graph-filled)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (time-graph-style snd3 i) graph-filled))
- (snd-display #__line__ ";set time-graph-style ~A ~A: ~A" snd3 i (time-graph-style snd3 i))))
- (set! (time-graph-style snd3 2) graph-lines)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (and (not (= i 2))
- (not (= (time-graph-style snd3 i) graph-filled)))
- (snd-display #__line__ ";set (2) time-graph-style ~A ~A: ~A" snd3 i (time-graph-style snd3 i))))
- (if (not (= (time-graph-style snd3 2) graph-lines))
- (snd-display #__line__ ";set time-graph-style (2): ~A" (time-graph-style snd3 2)))
- (set! (time-graph-style snd3 #t) graph-dots)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (time-graph-style snd3 i) graph-dots))
- (snd-display #__line__ ";set time-graph-style (all): ~A" (time-graph-style snd3 i))))
- (set! *graph-style* graph-dots-and-lines)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
- (snd-display #__line__ ";set time-graph-style (dal): ~A" (time-graph-style snd3 i))))
-
- (set! (lisp-graph-style snd3 #t) graph-filled)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (lisp-graph-style snd3 i) graph-filled))
- (snd-display #__line__ ";set lisp-graph-style ~A ~A: ~A" snd3 i (lisp-graph-style snd3 i))))
- (set! (lisp-graph-style snd3 2) graph-lines)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (and (not (= i 2))
- (not (= (lisp-graph-style snd3 i) graph-filled)))
- (snd-display #__line__ ";set (2) lisp-graph-style ~A ~A: ~A" snd3 i (lisp-graph-style snd3 i))))
- (if (not (= (lisp-graph-style snd3 2) graph-lines))
- (snd-display #__line__ ";set lisp-graph-style (2): ~A" (lisp-graph-style snd3 2)))
- (set! (lisp-graph-style snd3 #t) graph-lines)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
- (snd-display #__line__ ";set lisp -> time-graph-style (dal): ~A" (time-graph-style snd3 i))))
-
- (set! (transform-graph-style snd3 #t) graph-filled)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (transform-graph-style snd3 i) graph-filled))
- (snd-display #__line__ ";set transform-graph-style ~A ~A: ~A" snd3 i (transform-graph-style snd3 i))))
- (set! (transform-graph-style snd3 2) graph-lines)
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (and (not (= i 2))
- (not (= (transform-graph-style snd3 i) graph-filled)))
- (snd-display #__line__ ";set (2) transform-graph-style ~A ~A: ~A" snd3 i (transform-graph-style snd3 i))))
- (if (not (= (transform-graph-style snd3 2) graph-lines))
- (snd-display #__line__ ";set transform-graph-style (2): ~A" (transform-graph-style snd3 2)))
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
- (snd-display #__line__ ";set fft and lisp -> time-graph-style (dal): ~A" (time-graph-style snd3 i))))
- (do ((i 0 (+ i 1))) ((= i 4))
- (if (not (= (lisp-graph-style snd3 i) graph-lines))
- (snd-display #__line__ ";set fft and lisp -> lisp-graph-style (dal): ~A" (lisp-graph-style snd3 i))))
-
- (close-sound snd3))
-
- (let ((snd2 (open-sound "2.snd")))
- (if (sound? snd2)
- (play-with-amps snd2 0.2 0.1))
- (close-sound snd2))
-
- (let ((old-bp *with-background-processes*))
- (set! *with-background-processes* #f)
- (let* ((ind (open-sound "1a.snd"))
- (player (make-player ind 0))
- (len (framples ind 0))
- (incr *dac-size*)
- (e (make-env '(0 0 1 1) :length (+ 1 (floor (* 1.0 (/ len incr))))))
- (samp 0))
- (add-player player 0 -1 -1
- (lambda (reason)
- (set! (hook-functions play-hook) ())
- (close-sound ind)))
- (hook-push play-hook
- (lambda (hook)
- (set! (amp-control player) (env e))
- (if (fneq (amp-control ind) 1.0) (snd-display #__line__ ";amp-control snd: ~A" (amp-control ind)))
- (if (> (abs (- (amp-control player) (* 1.0 (/ samp len)))) 1.0)
- (snd-display #__line__ ";amp-control player: ~A ~A" (amp-control player) (* 1.0 (/ samp len))))
- (set! samp (+ samp incr))))
- (start-playing 1 (srate ind)))
- (if (find-sound "1a.snd") (snd-display #__line__ ";stop proc didn't close?"))
- (set! *with-background-processes* old-bp))
-
- (let ((ind (open-sound "pistol.snd")))
- (if (selection-member? ind 0)
- (snd-display #__line__ ";initial selection-member? ~A ~A?"
- (selection-member? ind 0)
- (selection?)))
- (set! (selection-member? ind 0) #t)
- (if (or (not (selection-member? ind 0))
- (not (selection-member? ind)))
- (snd-display #__line__ ";selection-member? ~A ~A ~A?"
- (selection-member? ind 0)
- (selection-member? ind)
- (selection?)))
- (if (not (= (selection-framples) 1))
- (snd-display #__line__ ";initial selection-framples: ~A?" (selection-framples)))
- (set! (selection-framples) 1200)
- (if (not (= (selection-framples) 1200))
- (snd-display #__line__ ";selection-framples: 1200 ~A?" (selection-framples)))
- (delete-selection)
- (if (selection?) (snd-display #__line__ ";selection active after cut?"))
- (undo)
- (if (not (selection?)) (snd-display #__line__ ";selection inactive after undo?"))
- (if (or (not (selection-member? ind 0))
- (not (selection-member? ind)))
- (snd-display #__line__ ";selection-member? after undo ~A ~A ~A?"
- (selection-member? ind 0)
- (selection-member? ind)
- (selection?)))
- (if (or (not (= (selection-framples) 1200))
- (not (= (selection-position) 0)))
- (snd-display #__line__ ";selection after undo: '(0 1200) '(~A ~A)?"
- (selection-position)
- (selection-framples)))
- (set! (selection-position) 1000)
- (if (or (not (= (selection-framples) 200))
- (not (= (selection-position) 1000)))
- (snd-display #__line__ ";selection after reposition: '(1000 200) '(~A ~A)?"
- (selection-position)
- (selection-framples)))
- (reverse-selection)
- (if (or (not (= (selection-framples) 200))
- (not (= (selection-position) 1000)))
- (snd-display #__line__ ";selection after reverse: '(1000 200) '(~A ~A)?"
- (selection-position)
- (selection-framples)))
-
- (let ((old-framples (framples ind)))
- (src-selection .5)
- (if (or (> (abs (- (framples ind) (+ 200 old-framples))) 5)
- (> (abs (- (selection-framples) 400)) 5))
- (snd-display #__line__ ";selection after src .5: '(1000 400) '(~A ~A)?"
- (selection-position)
- (selection-framples)))
- (undo)
- (redo)
- (if (or (> (abs (- (framples ind) (+ 200 old-framples))) 5)
- (> (abs (- (selection-framples) 400)) 5))
- (snd-display #__line__ ";selection after src .5 with undo/redo: '(1000 400) '(~A ~A)?"
- (selection-position)
- (selection-framples)))
- (undo 3))
- (close-sound ind))
-
- (set! *clm-srate* 22050)
- (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "src-* tests" 10000))
- (osc (make-oscil 500)))
-
- (define f3neq (lambda (a b) (> (abs (- a b)) 10)))
- (define f4neq (lambda (a b) (> (abs (- a b)) 1)))
- (define f5neq (lambda (a b) (> (abs (- a b)) (* .05 (max a b)))))
-
- ;; src-duration tests
- (if (or (fneq (src-duration '(0 1 1 2)) 0.693147180559945)
- (fneq (src-duration '(0 2 1 1)) (src-duration '(0 1 1 2)))
- (fneq (src-duration '(0 1 .5 2)) (src-duration '(0 1 1 2)))
- (fneq (src-duration '(.5 1 .75 2)) (src-duration '(0 1 1 2))))
- (snd-display #__line__ ";src-duration test1 ~A ~A ~A ~A"
- (src-duration '(0 1 1 2))
- (src-duration '(0 2 1 1))
- (src-duration '(0 1 .5 2))
- (src-duration '(.5 1 .75 2))))
- (if (or (fneq (src-duration '(0 1 1 0.5)) 1.38629436111989)
- (fneq (src-duration '(0 0.5 1 1)) (src-duration '(0 1 1 0.5)))
- (fneq (src-duration '(0 1 .5 0.5)) (src-duration '(0 1 1 0.5)))
- (fneq (src-duration '(.5 1 .75 0.5)) (src-duration '(0 1 1 0.5))))
- (snd-display #__line__ ";src-duration test2 ~A ~A ~A ~A"
- (src-duration '(0 1 1 0.5))
- (src-duration '(0 0.5 1 1))
- (src-duration '(0 1 .5 0.5))
- (src-duration '(.5 1 .75 0.5))))
- (if (or (fneq (src-duration '(0 1 1 1)) 1.0)
- (fneq (src-duration '(0 2 1 2)) 0.5))
- (snd-display #__line__ ";src-duration test3: ~A ~A" (src-duration '(0 1 1 1)) (src-duration '(0 2 1 2))))
- (if (fneq (src-duration '(0 .5 .5 3 .6 1 .7 .1 .8 1.5 1 1)) 1.02474349685432)
- (snd-display #__line__ ";src-duration test4 ~A" (src-duration '(0 .5 .5 3 .6 1 .7 .1 .8 1.5 1 1))))
- (if (fneq (src-duration '(0 1 1 2 2 1)) 0.693147180559945)
- (snd-display #__line__ ";src-duration test5: ~A" (src-duration '(0 1 1 2 2 1))))
- (if (fneq (src-duration '(0 1 1 1)) 1.0)
- (snd-display #__line__ ";src-duration test6: ~A" (src-duration '(0 1 1 1))))
- (if (fneq (src-duration '(0 2 1 2)) 0.5)
- (snd-display #__line__ ";src-duration test7: ~A" (src-duration '(0 2 1 2))))
- (if (fneq (src-duration '(0 0.5 2 0.5)) 2.0)
- (snd-display #__line__ ";src-duration test8: ~A" (src-duration '(0 0.5 2 0.5))))
-
- (if (fneq (src-duration (src-fit-envelope '(0 1 1 2) 2.0)) 2.0)
- (snd-display #__line__ ";src-fit-envelope 2.0: ~A" (src-duration (src-fit-envelope '(0 1 1 2) 2.0))))
- (if (fneq (src-duration (src-fit-envelope '(0 1 1 2) 0.5)) 0.5)
- (snd-display #__line__ ";src-fit-envelope 0.5: ~A" (src-duration (src-fit-envelope '(0 1 1 2) 0.5))))
-
-
- (if (fneq (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.69287)
- (snd-display #__line__ ";fm-parallel-component 100: ~A" (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
- (if (fneq (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.17047)
- (snd-display #__line__ ";fm-parallel-component 500: ~A" (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
-
- (if (fneq (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0)) -0.0732421875)
- (snd-display #__line__ ";cheby-hka 0: ~A" (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0))))
- (if (fneq (cheby-hka 2 0.25 (float-vector 0 0 0 0 1.0 1.0)) -0.234375)
- (snd-display #__line__ ";cheby-hka 1: ~A" (cheby-hka 2 0.25 (float-vector 0 0 0 0 1.0 1.0))))
- (if (fneq (cheby-hka 1 0.25 (float-vector 0 0 0 0 1.0 1.0)) 1.025390625)
- (snd-display #__line__ ";cheby-hka 2: ~A" (cheby-hka 1 0.25 (float-vector 0 0 0 0 1.0 1.0))))
- (if (fneq (cheby-hka 0 0.25 (float-vector 0 0 0 0 1.0 1.0)) 1.5234375)
- (snd-display #__line__ ";cheby-hka 3: ~A" (cheby-hka 0 0.25 (float-vector 0 0 0 0 1.0 1.0))))
-
- (map-channel (lambda (y) (* .5 (oscil osc))))
- (let ((vals (freq-peak 0 ind 8192)))
- (if (or (f4neq (car vals) 500.0)
- (fneq (cadr vals) 1.0))
- (snd-display #__line__ ";src no-test: ~A" vals)))
- (for-each
- (lambda (sr dur)
- (src-sound sr 1.0 ind 0)
- (if (fneq (/ (framples ind 0) 10000.0) dur) (snd-display #__line__ ";src-sound ~A: ~A (~A)" sr (/ (framples ind 0) 10000.0) dur))
- (let ((vals (freq-peak 0 ind 8192)))
- (if (or (f4neq (car vals) (* 500 sr))
- (fneq (cadr vals) 1.0))
- (snd-display #__line__ ";src ~A freq: ~A" sr vals)))
- (undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
- (for-each
- (lambda (e f0 f1)
- (src-sound e 1.0 ind 0)
- (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
- (snd-display #__line__ ";src-sound (env) ~A: ~A (~A)"
- e (/ (framples ind 0) 10000.0) (src-duration e)))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) f0)
- (snd-display #__line__ ";src (env) 0 ~A freq: ~A" f0 vals)))
- (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
- (if (f5neq (car vals) f1)
- (snd-display #__line__ ";src (env) 1 ~A freq: ~A" f1 vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
- (for-each
- (lambda (e f0 f1)
- (src-sound (make-env e :length (framples)) 1.0 ind 0)
- (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
- (snd-display #__line__ ";src-sound (make-env) ~A: ~A (~A)"
- e (/ (framples ind 0) 10000.0) (src-duration e)))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) f0)
- (snd-display #__line__ ";src (make-env) 0 ~A freq: ~A" f0 vals)))
- (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
- (if (f5neq (car vals) f1)
- (snd-display #__line__ ";src (env) 1 ~A freq: ~A" f1 vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
-
- (for-each
- (lambda (sr dur)
- (src-channel sr)
- (if (fneq (/ (framples ind 0) 10000.0) dur) (snd-display #__line__ ";src-channel ~A: ~A (~A)" sr (/ (framples ind 0) 10000.0) dur))
- (let ((vals (freq-peak 0 ind 8192)))
- (if (or (f4neq (car vals) (* 500 sr))
- (fneq (cadr vals) 1.0))
- (snd-display #__line__ ";src ~A freq: ~A" sr vals)))
- (undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
- (for-each
- (lambda (e f0 f1)
- (src-channel e)
- (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
- (snd-display #__line__ ";src-channel (env) ~A: ~A (~A)"
- e (/ (framples ind 0) 10000.0) (src-duration e)))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) f0)
- (snd-display #__line__ ";src-channel (env f0) ~A: ~A" f0 vals)))
- (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
- (if (f5neq (car vals) f1)
- (snd-display #__line__ ";src-channel (env f1) ~A: ~A" f1 vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
-
- (for-each
- (lambda (sr dur)
- (src-channel sr 1000 2500)
- (if (f4neq (framples ind 0) (+ 7500 (* dur 2500)))
- (snd-display #__line__ ";src-channel section: ~A ~A" (framples) (+ 7500 (* dur 2500))))
- (let ((vals (freq-peak 0 ind 512)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-channel section 0 ~A freq: ~A" sr vals)))
- (let ((vals (freq-peak (- (+ 7500 (floor (* dur 2500))) 512) ind 512)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-channel section 8000 ~A freq: ~A" sr vals)))
- (let ((vals (freq-peak 1000 ind 512)))
- (if (f5neq (car vals) (* sr 500.0))
- (snd-display #__line__ ";src-channel section ~A freq: ~A" sr vals)))
- (undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
-
- (for-each
- (lambda (e)
- (src-channel (make-env e :length 2500) 1000 2500)
- (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
- (snd-display #__line__ ";src-channel section (make-env duration) ~A: ~A (~A ~A)"
- e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-channel section (make-env e) ~A: ~A" e vals)))
- (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-channel section (make-env e) ~A: ~A" e vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
-
- (make-selection 1000 3500 ind 0)
- (for-each
- (lambda (sr dur)
- (src-selection sr)
- (if (f3neq (framples ind 0) (+ 7500 (* dur 2500)))
- (snd-display #__line__ ";src-selection section: ~A ~A" (framples) (+ 7500 (* dur 2500))))
- (let ((vals (freq-peak 0 ind 512)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section 0 ~A freq: ~A" sr vals)))
- (let ((vals (freq-peak (- (+ 7500 (floor (* dur 2500))) 512) ind 512)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section 8000 ~A freq: ~A" sr vals)))
- (let ((vals (freq-peak 1000 ind 512)))
- (if (f5neq (car vals) (* sr 500.0))
- (snd-display #__line__ ";src-selection section ~A freq: ~A" sr vals)))
- (undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
-
- (for-each
- (lambda (e)
- (src-selection (make-env e :length 2500))
- (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
- (snd-display #__line__ ";src-selection section (make-env duration) ~A: ~A (~A ~A)"
- e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section (make-env e) ~A: ~A" e vals)))
- (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section (make-env e) ~A: ~A" e vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
-
- (for-each
- (lambda (e)
- (src-selection e)
- (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
- (snd-display #__line__ ";src-selection section (env duration) ~A: ~A (~A ~A)"
- e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
- (let ((vals (freq-peak 0 ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section (env e) ~A: ~A" e vals)))
- (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
- (if (f5neq (car vals) 500.0)
- (snd-display #__line__ ";src-selection section (env f1) ~A: ~A" e vals)))
- (undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
-
- (close-sound ind)
- )
-
- (if (< *print-length* 12) (set! *print-length* 12))
- (let ((ind (new-sound "hi.snd")))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (sample i ind) (* i .1)))
- (select-all ind)
- (set! (sample 10 ind) 1.0)
- (smooth-selection)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0 10) 0 9)))
- (snd-display #__line__ ";smooth-selection: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0 10)))
- (revert-sound)
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (sample i ind) (- 1.0 (* i .1))))
- (select-all ind)
- (set! (sample 10 ind) 0.0)
- (smooth-selection)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0 10) 0 9)))
- (snd-display #__line__ ";smooth-selection back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0 10)))
- (close-sound ind))
-
- (let ((ind (new-sound "hi.snd")))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (sample i ind) (* i .1)))
- (set! (sample 10 ind) 1.0)
- (smooth-sound 0 10 ind)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0 10) 0 9)))
- (snd-display #__line__ ";smooth-sound: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0 10)))
- (revert-sound)
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (sample i ind) (- 1.0 (* i .1))))
- (set! (sample 10 ind) 0.0)
- (smooth-sound 0 10 ind)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0 10) 0 9)))
- (snd-display #__line__ ";smooth-sound back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0 10)))
- (close-sound ind))
- (if (file-exists? "hi.snd") (delete-file "hi.snd"))
-
- (let* ((ind (open-sound "oboe.snd"))
- (len (framples ind)))
- (set! (cursor ind) 1200)
- (key (char->integer #\u) 4 ind)
- (key (char->integer #\1) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\o) 4 ind)
- (if (not (= (framples ind) (+ 100 len)))
- (snd-display #__line__ ";C-o len: ~A? " (framples)))
- (if with-gui
- (let ((data (channel->float-vector 1200 100 ind)))
- (if (fneq (float-vector-peak data) 0.0) (snd-display #__line__ ";C-o: ~A?" (float-vector-peak data)))))
- (revert-sound ind)
- (set! (cursor ind) 1200)
- (key (char->integer #\u) 4 ind)
- (key (char->integer #\1) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\z) 4 ind)
- (if (not (= (framples ind) len))
- (snd-display #__line__ ";C-z len: ~A? " (framples)))
- (if with-gui
- (let ((data (channel->float-vector 1200 100 ind)))
- (if (fneq (float-vector-peak data) 0.0) (snd-display #__line__ ";C-z: ~A?" (float-vector-peak data)))))
- (set! (cursor ind) 0)
- (key (char->integer #\u) 4 ind)
- (key (char->integer #\3) 0 ind)
- (key (char->integer #\.) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\z) 4 ind)
- (if (fneq (maxamp ind 0) 0.0) (snd-display #__line__ ";C-z full: ~A" (maxamp)))
- (revert-sound ind)
- (set! (cursor ind) 1200)
- (key (char->integer #\u) 4 ind)
- (key (char->integer #\1) 0 ind)
- (key (char->integer #\.) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\o) 4 ind)
- (if (not (= (framples ind) (+ (srate ind) len)))
- (snd-display #__line__ ";C-o 1.0 len: ~A? " (framples)))
- (if with-gui
- (let ((data (channel->float-vector 1200 (srate ind) ind)))
- (if (fneq (float-vector-peak data) 0.0) (snd-display #__line__ ";C-o 1.0: ~A?" (float-vector-peak data)))))
- (revert-sound ind)
- (set! (cursor ind) 1200)
- (key (char->integer #\u) 4 ind)
- (key (char->integer #\1) 0 ind)
- (key (char->integer #\.) 0 ind)
- (key (char->integer #\0) 0 ind)
- (key (char->integer #\z) 4 ind)
- (if (not (= (framples ind) len))
- (snd-display #__line__ ";C-z 1.0 len: ~A? " (framples)))
- (if with-gui
- (let ((data (channel->float-vector 1200 (srate ind) ind)))
- (if (fneq (float-vector-peak data) 0.0) (snd-display #__line__ ";C-z 1.0: ~A?" (float-vector-peak data)))))
- (close-sound ind))
-
- (let ((ind (open-sound "2.snd")))
- (set! (sync ind) 1)
- (key (char->integer #\>) 4)
- (key (char->integer #\space) 4)
- (key (char->integer #\<) 4)
- (if (or (not (selection-member? ind 0))
- (not (selection-member? ind 1))
- (not (= (selection-position ind 0) 0))
- (not (= (selection-position ind 1) 0))
- (not (= (selection-framples ind 0) (framples ind 0)))
- (not (= (selection-framples ind 1) (framples ind 1))))
- (snd-display #__line__ ";sync selection via <-: ~A ~A ~A ~A ~A ~A"
- (selection-member? ind 0) (selection-member? ind 1)
- (selection-position ind 0) (selection-position ind 1)
- (selection-framples ind 0) (selection-framples ind 1)))
- (key (char->integer #\space) 4)
- (key (char->integer #\>) 4)
- (if (or (not (selection-member? ind 0))
- (not (selection-member? ind 1))
- (not (= (selection-position ind 0) 0))
- (not (= (selection-position ind 1) 0))
- (not (= (selection-framples ind 0) (framples ind 0)))
- (not (= (selection-framples ind 1) (framples ind 1))))
- (snd-display #__line__ ";sync selection via ->: ~A ~A ~A ~A ~A ~A"
- (selection-member? ind 0) (selection-member? ind 1)
- (selection-position ind 0) (selection-position ind 1)
- (selection-framples ind 0) (selection-framples ind 1)))
- (set! (cursor ind 1) 0)
- (set! (cursor ind 0) 1000)
- (if (not (= (cursor ind 1) 1000)) (snd-display #__line__ ";syncd cursors: ~A ~A" (cursor ind 0) (cursor ind 1)))
- (close-sound ind))
-
- (let ((ind (open-sound "2a.snd")))
- (let ((reg (make-region 100 200 ind #t)))
- (if (not (= (region-chans reg) 2))
- (snd-display #__line__ ";make-region #t for chan in 2a.snd: ~A chans" (region-chans reg)))
- (mix-region reg 1000)
- (if (or (not (= (edit-position ind 0) 1))
- (not (= (edit-position ind 1) 0)))
- (snd-display #__line__ ";mix-region default mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
- (undo)
- (set! (sync ind) 1)
- (mix-region reg 1000)
- (if (or (not (= (edit-position ind 0) 1))
- (not (= (edit-position ind 1) 1)))
- (snd-display #__line__ ";mix-region sync mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
- (undo)
- (set! (sync ind) 0)
- (mix-region reg 1000 ind 1)
- (if (or (not (= (edit-position ind 0) 0))
- (not (= (edit-position ind 1) 1)))
- (snd-display #__line__ ";mix-region mix -> chan 1: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
- (revert-sound ind))
-
- (set! (selection-member? #t #t) #f)
- (set! (selection-member? ind 0) #t)
- (set! (selection-member? ind 1) #t)
- (set! (selection-position ind 0) 1000)
- (set! (selection-position ind 1) 1000)
- (set! (selection-framples ind 0) 100)
- (set! (selection-framples ind 1) 100)
- (if (not (= (selection-chans) 2))
- (snd-display #__line__ ";laboriously make 2 chan selection: ~A" (selection-chans)))
-
- (mix-selection 100)
- (if (or (not (= (edit-position ind 0) 1))
- (not (= (edit-position ind 1) 0)))
- (snd-display #__line__ ";mix-selection default mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
- (undo)
- (set! (sync ind) 1)
- (mix-selection 100)
- (if (or (not (= (edit-position ind 0) 1))
- (not (= (edit-position ind 1) 1)))
- (snd-display #__line__ ";mix-selection sync mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
- (undo)
- (set! (sync ind) 0)
- (mix-selection 100 ind 1)
- (if (or (not (= (edit-position ind 0) 0))
- (not (= (edit-position ind 1) 1)))
- (snd-display #__line__ ";mix-selection mix -> chan 1: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
-
- (close-sound ind))
-
- (let ((ind (open-sound "oboe.snd")))
- (test-selection ind 1200 100 2.0)
- (test-selection ind 600 1200 2.0)
- (test-selection ind 0 100 2.0)
- (test-selection ind 22500 (- 50827 22500) 0.5)
- (test-selection ind 0 50828 0.5)
-
- (test-selection-to ind 1200 100 1.0)
- (test-selection-to ind 600 1200 0.1)
- (test-selection-to ind 0 100 0.5)
- (test-selection-to ind 22500 (- 50827 22500) 2.0)
- (test-selection-to ind 0 50828 0.5)
-
- (revert-sound ind)
- (make-selection 1200 1200)
- (if (not (selection?)) (snd-display #__line__ ";no selection from 1 samp region?"))
- (if (not (= (selection-framples) 1)) (snd-display #__line__ ";1 samp selection: ~A samps?" (selection-framples)))
- (scale-selection-to 1.0)
- (if (fneq (sample 1200 ind 0) 1.0) (snd-display #__line__ ";scale 1 samp selection: ~A?" (sample 1200 ind 0)))
-
- (revert-sound ind)
- (let ((id (make-region 500 1000)))
- (src-selection .5)
- (if (> (abs (- (region-framples id) 500)) 1) (snd-display #__line__ ";region-framples after src-selection: ~A?" (region-framples id)))
- (let ((reg-mix-id (car (mix-region id 1500 ind 0))))
- (if (not (= (mix-length reg-mix-id) (region-framples id)))
- (snd-display #__line__ ";mix-region: ~A != ~A?" (region-framples id) (mix-length reg-mix-id)))
- (if (not (equal? (mix-home reg-mix-id) (list ind 0 #f 0)))
- (snd-display #__line__ ";mix-region mix-home ~A (~A 0 #f 0)?" (mix-home reg-mix-id) ind))
- (let ((sel-mix-id (car (mix-selection 2500 ind 0))))
- (if (not (= (selection-framples) (mix-length sel-mix-id)))
- (snd-display #__line__ ";mix-selection framples: ~A != ~A?" (selection-framples) (mix-length sel-mix-id)))
- (if (> (abs (- (* 2 (mix-length reg-mix-id)) (mix-length sel-mix-id))) 3)
- (snd-display #__line__ ";mix selection and region: ~A ~A (~A ~A)?"
- (mix-length reg-mix-id) (mix-length sel-mix-id) (region-framples id) (selection-framples)))
- (if (not (equal? (mix-home sel-mix-id) (list ind 0 #f 0)))
- (snd-display #__line__ ";mix-selection mix-home: ~A (~A 0 #f 0)?" (mix-home sel-mix-id) ind))
- (insert-selection 3000 ind 0)
- (insert-selection 3000 ind)
- (mix-selection 3000 ind)
- (delete-selection)
- (revert-sound ind))))
- (close-sound ind))
-
- (if (file-exists? "storm.snd")
- (let ((ind (open-sound "storm.snd")))
- (set! *sinc-width* 10)
- (time (src-sound 1.3))
- (time (env-sound '(0 0 1 1 2 0)))
- (time (filter-sound '(0 1 .2 0 .5 1 1 0) 20)) ; FIR direct form
- (time (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048)) ; convolution
- (revert-sound ind)
-
- (let ((reg (make-region 0 123000 ind 0))) ; force copy branch to execute
- (region->float-vector reg 0 10 0 (make-float-vector 10)))
- (ramp-channel 0.0 1.0)
- (ramp-channel 0.0 1.0)
- (ramp-channel 0.0 1.0)
- (ramp-channel 0.0 1.0) ; force env
- (close-sound ind)))
-
- (if (file-exists? "1a.snd")
- (let ((ind1 (open-sound "1a.snd")))
- (time (rubber-sound 1.25))
- (close-sound ind1)))
- (gc)
- (let* ((oboe (open-sound "oboe.snd"))
- (a4 (open-sound "4.aiff"))
- (sr (srate oboe))
- ;(fr (framples oboe 0))
- ;(typ (header-type oboe))
- ;(frm (sample-type oboe))
- ;(loc (data-location oboe))
- ;(com (comment oboe))
- )
- (save-sound-as "test.aif" oboe :header-type mus-aifc)
- (let ((oboe-aif (open-sound "test.aif")))
- (if (not (= (header-type oboe-aif) mus-aifc)) (snd-display #__line__ ";oboe-aif header: ~A?" (mus-header-type-name (header-type oboe-aif))))
- (set! (srate oboe-aif) (* sr 2.0))
- (if (fneq (* sr 2.0) (srate oboe-aif)) (snd-display #__line__ ";set! srate: ~A ~A" (* sr 2.0) (srate oboe-aif)))
- (set! (header-type oboe-aif) mus-next)
- (if (not (= (header-type oboe-aif) mus-next)) (snd-display #__line__ ";set! header: ~A?" (mus-header-type-name (header-type oboe-aif))))
- (set! (data-location oboe-aif) 28)
- (if (not (= (data-location oboe-aif) 28)) (snd-display #__line__ ";set! data-location: ~A?" (data-location oboe-aif)))
- (set! (sample-type oboe-aif) mus-mulaw)
- (if (not (= (sample-type oboe-aif) mus-mulaw)) (snd-display #__line__ ";set! format: ~A?" (mus-sample-type-name (sample-type oboe-aif))))
- (save-sound-as "test.aif" oboe-aif 22050 mus-bshort mus-aifc 0)
- (close-sound oboe-aif)
- (delete-file "test.aif")
- (set! (selected-sound) a4)
- (if (not (equal? (selected-sound) a4)) (snd-display #__line__ ";set! selected-sound: ~A ~A?" (selected-sound) a4))
- (set! (selected-channel) 2)
- (if (not (= (selected-channel a4) 2)) (snd-display #__line__ ";set! selected-channel: ~A?" (selected-channel a4)))
- (set! (selected-channel a4) 3)
- (if (not (= (selected-channel a4) 3)) (snd-display #__line__ ";set! selected-channel a4: ~A?" (selected-channel a4)))
- (close-sound a4)
- (close-sound oboe)))
-
- (let ((v1 (envelope-interp 1.0 '(0 0 2.0 1.0)))
- (v2 (envelope-interp 1.0 '(0 0.0 1 1.0 2 0.0)))
- (v3 (envelope-interp 2.0 '(0 0.0 1 1.0)))
- (v4 (envelope-interp 0.0 '(1 .5 2 0))))
- (if (fneq v1 0.5) (snd-display #__line__ ";envelope-interp(1): ~F (0.5)?" v1))
- (if (fneq v2 1.0) (snd-display #__line__ ";envelope-interp(2): ~F (1.0)?" v2))
- (if (fneq v3 1.0) (snd-display #__line__ ";envelope-interp(3): ~F (1.0)?" v3))
- (if (fneq v4 0.5) (snd-display #__line__ ";envelope-interp(4): ~F (0.5)?" v4)))
- (let ((v1 (envelope-interp 0.0 '(-1 0 0 1 1 -1)))
- (v2 (envelope-interp -0.5 '(-1 0 0 1 1 -1)))
- (v3 (envelope-interp -0.5 '(-1 -1 0 1 1 -1)))
- (v4 (envelope-interp -0.5 '(-1 -1 1 1)))
- (v5 (envelope-interp -1.5 '(-1 -1 1 1)))
- (v6 (envelope-interp 1.5 '(-1 -1 1 1))))
- (if (fneq v1 1.0) (snd-display #__line__ ";envelope-interp(1a): ~A" v1))
- (if (fneq v2 0.5) (snd-display #__line__ ";envelope-interp(2a): ~A" v2))
- (if (fneq v3 0.0) (snd-display #__line__ ";envelope-interp(3a): ~A" v3))
- (if (fneq v4 -0.5) (snd-display #__line__ ";envelope-interp(4a): ~A" v4))
- (if (fneq v5 -1.0) (snd-display #__line__ ";envelope-interp(5a): ~A" v5))
- (if (fneq v6 1.0) (snd-display #__line__ ";envelope-interp(6a): ~A" v6)))
- (let ((v1 (multiply-envelopes '(0.0 0.0 2.0 0.5) '(0.0 0.0 1.0 2.0 2.0 1.0)))
- (v2 (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
- (if (not (feql v1 (list 0.0 0.0 0.5 0.5 1.0 0.5))) (snd-display #__line__ ";multiply-envelopes: ~A?" v1))
- (if (not (feql v2 (list 1.0 0.2 3.0 0.6))) (snd-display #__line__ ";window-envelope: ~A?" v2)))
-
- (if (fneq (envelope-interp .1 '(0 0 1 1)) 0.1)
- (snd-display #__line__ ";envelope-interp .1 -> ~A?" (envelope-interp .1 '(0 0 1 1))))
- (if (fneq (envelope-interp .1 '(0 0 1 1) 32.0) 0.01336172)
- (snd-display #__line__ ";envelope-interp .013 -> ~A?" (envelope-interp .1 '(0 0 1 1) 32.0)))
- (if (fneq (envelope-interp .1 '(0 0 1 1) .012) 0.36177473)
- (snd-display #__line__ ";envelope-interp .361 -> ~A?" (envelope-interp .1 '(0 0 1 1) .012)))
- (if (fneq (envelope-interp .3 '(0 0 .5 1 1 0)) .6)
- (snd-display #__line__ ";envelope-interp .3 '(0 0 .5 1 1 0)) -> ~A" (envelope-interp .3 '(0 0 .5 1 1 0))))
-
- (if (fneq (envelope-interp .9 '(0 0 1 1)) 0.9)
- (snd-display #__line__ ";envelope-interp .9 -> ~A?" (envelope-interp .9 '(0 0 1 1))))
- (if (fneq (envelope-interp .9 '(0 0 1 1) 32.0) 0.698)
- (snd-display #__line__ ";envelope-interp .698 -> ~A?" (envelope-interp .9 '(0 0 1 1) 32.0)))
- (if (fneq (envelope-interp .9 '(0 0 1 1) .012) 0.993)
- (snd-display #__line__ ";envelope-interp .993 -> ~A?" (envelope-interp .9 '(0 0 1 1) .012)))
-
- (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1)) 0.1)
- (snd-display #__line__ ";envelope-interp .1 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1))))
- (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1) 32.0) 0.01336172)
- (snd-display #__line__ ";envelope-interp .013 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1) 32.0)))
- (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1) .012) 0.36177473)
- (snd-display #__line__ ";envelope-interp .361 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1) .012)))
-
- (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1)) 0.9)
- (snd-display #__line__ ";envelope-interp .9 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1))))
- (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1) 32.0) 0.698)
- (snd-display #__line__ ";envelope-interp .698 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1) 32.0)))
- (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1) .012) 0.993)
- (snd-display #__line__ ";envelope-interp .993 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1) .012)))
-
- (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1)) 0.1)
- (snd-display #__line__ ";envelope-interp .1 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1))))
- (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) 32.0) 0.01336172)
- (snd-display #__line__ ";envelope-interp .013 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) 32.0)))
- (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) .012) 0.36177473)
- (snd-display #__line__ ";envelope-interp .361 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) .012)))
-
- (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1)) 0.9)
- (snd-display #__line__ ";envelope-interp .9 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1))))
- (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) 32.0) 0.698)
- (snd-display #__line__ ";envelope-interp .698 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) 32.0)))
- (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012) 0.993)
- (snd-display #__line__ ";envelope-interp .993 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012)))
-
- (if (not (feql (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) (list 1.0 0.2 3.0 0.6)))
- (snd-display #__line__ ";window-envelope: ~A?" (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
- (if (not (feql (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0)) (list 0 0 0.5 0.5 1 0)))
- (snd-display #__line__ ";multiply-envelopes: ~A?" (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0))))
- (if (fneq (max-envelope '(0 0 1 1 2 3 4 0)) 3.0)
- (snd-display #__line__ ";max-envelope: ~A?" (max-envelope '(0 0 1 1 2 3 4 0))))
- (if (fneq (max-envelope '(0 1)) 1.0)
- (snd-display #__line__ ";1 max-envelope: ~A?" (max-envelope '(0 1))))
- (if (fneq (max-envelope '(0 1 1 1 2 2)) 2.0)
- (snd-display #__line__ ";2 max-envelope: ~A?" (max-envelope '(0 1 1 1 2 2))))
- (if (fneq (max-envelope '(0 -1 1 -2)) -1.0)
- (snd-display #__line__ ";3 max-envelope: ~A?" (max-envelope '(0 -1 1 -2))))
- (if (fneq (max-envelope '(0 -2 1 -1)) -1.0)
- (snd-display #__line__ ";4 max-envelope: ~A?" (max-envelope '(0 -2 1 -1))))
- (if (fneq (min-envelope '(0 0 1 1 2 3 4 0)) 0.0)
- (snd-display #__line__ ";min-envelope: ~A?" (min-envelope '(0 0 1 1 2 3 4 0))))
- (if (fneq (min-envelope '(0 1)) 1.0)
- (snd-display #__line__ ";1 min-envelope: ~A?" (min-envelope '(0 1))))
- (if (fneq (min-envelope '(0 1 1 1 2 2)) 1.0)
- (snd-display #__line__ ";2 min-envelope: ~A?" (min-envelope '(0 1 1 1 2 2))))
- (if (fneq (min-envelope '(0 -1 1 -2)) -2.0)
- (snd-display #__line__ ";3 min-envelope: ~A?" (min-envelope '(0 -1 1 -2))))
- (if (fneq (min-envelope '(0 -2 1 -1)) -2.0)
- (snd-display #__line__ ";4 min-envelope: ~A?" (min-envelope '(0 -2 1 -1))))
- (if (fneq (integrate-envelope '(0 0 1 1)) 0.5)
- (snd-display #__line__ ";integrate-envelope: ~A?" (integrate-envelope '(0 0 1 1))))
- (if (fneq (integrate-envelope '(0 1 1 1)) 1.0)
- (snd-display #__line__ ";integrate-envelope: ~A?" (integrate-envelope '(0 1 1 1))))
- (if (fneq (integrate-envelope '(0 0 1 1 2 .5)) 1.25)
- (snd-display #__line__ ";integrate-envelope: ~A?" (integrate-envelope '(0 0 1 1 2 .5))))
- (if (not (feql (stretch-envelope '(0 0 1 1) .1 .2) (list 0 0 0.2 0.1 1.0 1)))
- (snd-display #__line__ ";stretch-envelope att: ~A?" (stretch-envelope '(0 0 1 1) .1 .2)))
- (if (not (feql (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) (list 0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)))
- (snd-display #__line__ ";stretch-envelope dec: ~A?" (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6)))
- (if (not (feql (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1)) '(0 0 0.5 1.5 1 1)))
- (snd-display #__line__ ";add-envelopes: ~A" (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1))))
- (if (not (feql (scale-envelope '(0 0 1 1) 2) '(0 0 1 2)))
- (snd-display #__line__ ";scale-envelope: ~A" (scale-envelope '(0 0 1 1) 2)))
- (if (not (feql (scale-envelope '(0 0 1 1) 2 1) '(0 1 1 3)))
- (snd-display #__line__ ";scale-envelope off: ~A" (scale-envelope '(0 0 1 1) 2 1)))
- (if (not (feql (reverse-envelope '(0 0 1 1)) '(0 1 1 0)))
- (snd-display #__line__ ";reverse-envelope ramp: ~A" (reverse-envelope '(0 0 1 1))))
- (if (not (feql (reverse-envelope '(0 0 .5 1 2 0)) '(0 0 1.5 1 2 0)))
- (snd-display #__line__ ";reverse-envelope ramp 2: ~A" (reverse-envelope '(0 0 .5 1 2 0))))
- (if (not (feql (reverse-envelope '(0 0 .5 1 2 1)) '(0 1 1.5 1 2 0)))
- (snd-display #__line__ ";reverse-envelope ramp 2: ~A" (reverse-envelope '(0 0 .5 1 2 1))))
- (if (not (feql (concatenate-envelopes '(0 0 1 1) '(0 1 1 0)) '(0.0 0 1.0 1 2.0 0)))
- (snd-display #__line__ ";concatenate-envelopes: ~A" (concatenate-envelopes '(0 0 1 1) '(0 1 1 0))))
- (if (not (feql (concatenate-envelopes '(0 0 1 1.5) '(0 1 1 0)) '(0.0 0 1.0 1.5 1.01 1 2.01 0)))
- (snd-display #__line__ ";concatenate-envelopes: ~A" (concatenate-envelopes '(0 0 1 1.5) '(0 1 1 0))))
- (if (not (feql (repeat-envelope '(0 0 1 100) 2) '(0 0 1 100 1.01 0 2.01 100)))
- (snd-display #__line__ ";repeat-envelope 0: ~A" (repeat-envelope '(0 0 1 100) 2)))
- (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2) '(0 0 1.5 1 2.0 0 3.5 1 4.0 0)))
- (snd-display #__line__ ";repeat-envelope 1: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2)))
- (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2 #f #t) '(0.0 0 0.75 1 1.0 0 1.75 1 2.0 0)))
- (snd-display #__line__ ";repeat-envelope 2: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2 #f #t)))
- (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2 #t) '(0 0 1.5 1 2.0 0 2.5 1 4.0 0)))
- (snd-display #__line__ ";repeat-envelope 3: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2 #t)))
- (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 3) '(0 0 1.5 1 2.0 0 3.5 1 4.0 0 5.5 1 6.0 0)))
- (snd-display #__line__ ";repeat-envelope 4: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 3)))
- (if (not (feql (normalize-envelope '(0 0 1 1.5 2.0 1.0)) '(0 0.0 1 1.0 2.0 0.667)))
- (snd-display #__line__ ";normalize-envelope: ~A" (normalize-envelope '(0 0 1 1.5 2.0 1.0))))
- (if (not (feql (normalize-envelope '(0 0 1 .5 2 -.8)) '(0 0.0 1 0.625 2 -1.0)))
- (snd-display #__line__ ";normalize-envelope: ~A" (normalize-envelope '(0 0 1 .5 2 -.8))))
-
- (let ((val (envelope-exp '(0 0 1 1) 2.0 10)))
- (if (not (feql val '(0.000 0.000 0.100 0.010 0.200 0.040 0.300 0.090 0.400 0.160
- 0.500 0.250 0.600 0.360 0.700 0.490 0.800 0.640 0.900 0.810 1.000 1.000)))
- (snd-display #__line__ ";envelope-exp: ~A" val))
- (set! val (envelope-exp '(0 0 1 1 2 0) 1.0 10))
- (if (not (feql val '(0.000 0.000 0.200 0.200 0.400 0.400 0.600 0.600 0.800 0.800
- 1.000 1.000 1.200 0.800 1.400 0.600 1.600 0.400 1.800 0.200 2.000 0.000)))
- (snd-display #__line__ ";envelope exp 2: ~A" val)))
-
- (let ((ind (new-sound "fmv.snd"))
- (v (make-float-vector 20 1.0)))
- (float-vector->channel v)
- (if (selection?) (set! (selection-member? #t) #f))
- (make-selection 5 9 ind 0)
- (scale-selection-to 0.5)
- (insert-selection 15 ind)
- (if (not (= (framples ind) 25)) (snd-display #__line__ ";insert-selection 5: ~A" (framples ind)))
- (if (not (vequal (channel->float-vector 0 25) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
- 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
- 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";insert-selection: ~A" (channel->float-vector 0 25)))
- (mix-selection 1 ind 0) ; this is being confused by clipping settings
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector 1.000 1.500 1.500 1.500 1.500 1.000 0.500 0.500 0.500 0.500)))
- (snd-display #__line__ ";mix-selection vals: ~A" (channel->float-vector 0 10 ind 0)))
- (close-sound ind))
-
- (let ((ind (new-sound "fmv.snd"))
- (v (make-float-vector 2000))
- (old-size *transform-size*)
- (old-type *transform-type*)
- (old-norm *transform-normalization*)
- (old-grf *transform-graph-type*)
- (e (make-env (list 0.0 0.0 1.0 (* 2000 0.2 pi)) :length 2001)))
- (fill-float-vector v (sin (env e)))
- (float-vector->channel v 0 2000 ind 0)
- (set! *transform-size* 256)
- (set! *transform-type* fourier-transform)
- (set! *transform-normalization* normalize-by-channel)
- (set! *transform-graph-type* graph-once)
- (set! *zero-pad* 0)
- (set! (transform-graph?) #t)
- (make-selection 0 200)
- (set! *show-selection-transform* #t)
- (set! (selection-framples) 300)
- (update-transform-graph)
- (let* ((data (transform->float-vector))
- (peak (float-vector-peak data))
- (val (transform-sample 0)))
- (if (= peak 0.0) (snd-display #__line__ ";transform selection peak: ~A" peak))
- (if (fneq val (data 0)) (snd-display #__line__ ";transform-sample: ~A, data: ~A" val (data 0)))
- (if (and (>= (length data) 64)
- (> (* .5 peak) (data 51)))
- (snd-display #__line__ ";transform selection at 51: ~A, peak: ~A" (data 51) peak)))
- (for-each
- (lambda (pad)
- (set! *zero-pad* pad)
- (update-transform-graph)
- (let* ((data (transform->float-vector))
- (peak (float-vector-peak data))
- (pval (data (floor (* .1 (length data))))))
- (if (> (* .5 peak) pval)
- (snd-display #__line__ ";transform selection padded ~D: ~A, peak: ~A" pad pval peak))))
- (list 1 0 3 31))
- (set! *zero-pad* 100000)
- (if (> *zero-pad* 1000)
- (snd-display #__line__ ";zero-pad: ~A" *zero-pad*))
- (set! *zero-pad* 0)
- (set! *transform-size* old-size)
- (set! *transform-type* (if (integer? old-type) (integer->transform old-type) old-type))
- (set! *transform-normalization* old-norm)
- (set! *transform-graph-type* old-grf)
- (close-sound ind))
+ (place-sound obi s2i 45.0)
+ (let ((s31 (sample half-way s2i 0))
+ (s32 (sample half-way s2i 1)))
+ (if (or (fneq (+ s1 (* 0.5 o1)) s21)
+ (fneq (+ s2 (* 0.5 o1)) s22)
+ (fneq s21 s31)
+ (fneq s22 s32))
+ (snd-display ";place: ~A " (list o1 s1 s2 s21 s22 s31 s32))))))
+ (revert-sound s2i)
+ (revert-sound obi)
+ (set! (sync obi) 0)
+ (set! (sync s2i) 0)
+ (if (or (fneq ((compand) 0.0) 0.0)
+ (fneq ((compand) 1.0) 1.0)
+ (fneq ((compand) .1) .2)
+ (fneq ((compand) .99) .997)
+ (fneq ((compand) .95) .984))
+ (snd-display ";compand: ~A?" (list ((compand) 0.0) ((compand) 1.0) ((compand) .1) ((compand) .99) ((compand) .95))))
+
+ (close-sound obi)
+ (revert-sound s2i)
+ (let ((s1 (sample 1000 s2i 0))
+ (s2 (sample 1000 s2i 1)))
+ (set! (sync s2i) 4)
+ (select-all)
+ (if (not (= (selection-chans) 2))
+ (begin
+ (snd-display ";selection-chans(2): ~A?" (selection-chans))
+ (for-each
+ (lambda (snd)
+ (do ((i 0 (+ i 1)))
+ ((= i (chans snd)))
+ (if (selection-member? snd i)
+ (snd-display "; ~A[~A] at ~A" (short-file-name snd) i (selection-position snd i)))))
+ (sounds))))
+ (if (not (= (selection-srate) (srate s2i))) (snd-display ";selection-srate: ~A ~A?" (selection-srate) (srate s2i)))
+ (if (= (selection-chans) 2)
+ (begin
+ (swap-selection-channels)
+ (if (or (fneq s1 (sample 1000 s2i 1))
+ (fneq s2 (sample 1000 s2i 0)))
+ (snd-display ";swap-selection-channels: ~A?" (list s1 s2 (sample 1000 s2i 0) (sample 1000 s2i 1)))))))
+ (revert-sound s2i)
+ (close-sound s2i)
+
+ (set! obi (open-sound "oboe.snd"))
+ (select-all)
+ (for-each forget-region (regions))
+ (if (not (null? (regions))) (snd-display ";no regions? ~A" (regions)))
+ (let ((id (make-region 100 200 obi 0)))
+ (if (not (equal? (regions) (list id))) (snd-display ";make-region regions: ~A?" (regions))))
+
+ (revert-sound obi)
+ (let ((oldlen (framples obi)))
+ (env-sound-interp '(0 0 1 1 2 0) 2.0 obi 0)
+ (let ((newlen (framples obi)))
+ (if (> (abs (- (* 2 oldlen) newlen)) 3)
+ (snd-display ";env-sound-interp: ~A ~A?" oldlen newlen))))
+
+ (revert-sound obi)
+ (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0))
+ (if (not (= (edit-position obi 0) 1)) (snd-display ";granulated-sound-interp no-op 1?"))
+ (if (< (maxamp obi 0) .15) (snd-display ";granulated-sound-interp 1 maxamp: ~A" (maxamp obi 0)))
+ (if (> (abs (- (framples obi 0) 50828)) 1000) (snd-display ";granulated-sound-interp 1 framples: ~A" (framples obi 0)))
+ (revert-sound obi)
+ (granulated-sound-interp '(0 0 1 1) 2.0)
+ (if (not (= (edit-position obi 0) 1)) (snd-display ";granulated-sound-interp no-op 2?"))
+ (if (< (maxamp obi 0) .145) (snd-display ";granulated-sound-interp 2 maxamp: ~A" (maxamp obi 0)))
+ (if (> (abs (- (framples obi 0) 101656)) 1000) (snd-display ";granulated-sound-interp 2 framples: ~A" (framples obi 0)))
+ (revert-sound obi)
+ (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0) 0.02)
+ (if (not (= (edit-position obi 0) 1)) (snd-display ";granulated-sound-interp no-op 3?"))
+ (if (< (maxamp obi 0) .2) (snd-display ";granulated-sound-interp 3 maxamp: ~A" (maxamp obi 0)))
+ (if (> (abs (- (framples obi 0) 50828)) 1000) (snd-display ";granulated-sound-interp 3 framples: ~A" (framples obi 0)))
+
+ (close-sound obi)
+ )
+
+ (let ((old-srate *clm-srate*))
+ (set! *clm-srate* 22050)
+ (let ((ind (new-sound "test.snd" :size 20)))
+ (set! *print-length* (max *print-length* 20))
+ (offset-channel 1.0)
+ (env-sound '(0 0 1 1))
+ (let ((osc (make-oscil :frequency 1000.0 :initial-phase (+ pi (/ pi 2))))
+ (reader (make-sound-interp 0 ind 0))
+ (len (- (framples ind 0) 1)))
+ (map-channel (lambda (val)
+ (sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc)))))))
+ (if (not (vequal (channel->float-vector) (float-vector 0.000 0.020 0.079 0.172 0.291 0.427 0.569 0.706 0.825 0.919
+ 0.979 1.000 0.981 0.923 0.831 0.712 0.576 0.434 0.298 0.177)))
+ (snd-display ";sound-interp: ~A" (channel->float-vector))))
+ (undo)
- (let ((ind (open-sound "storm.snd"))
- (maxes (float-vector 0.8387 0.5169 0.3318 0.2564 0.1982 0.1532)))
- (do ((i 0 (+ i 1)))
- ((= i 5))
- (if (fneq (maxamp) (maxes i)) (snd-display #__line__ ";enving storm ~D: ~A ~A" i (maxes i) (maxamp)))
- (env-sound '(0 0 1 1 2 0))
- (if (fneq (maxamp) (maxes (+ i 1))) (snd-display #__line__ ";enving storm ~D: ~A ~A" (+ i 1) (maxes (+ i 1)) (maxamp))))
- (close-sound ind))
- ))
+ (let ((osc (make-oscil :frequency 0.5 :initial-phase (+ pi (/ pi 2))))
+ (reader (make-sound-interp 0 ind 0))
+ (len (- (framples ind 0) 1)))
+ (map-channel (lambda (val)
+ (sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc))))))))
+ (undo)
- ;; --------------------------------------------------------------------------------
- ;; length as generic function:
- ;; string-length vector-length hash-table-size length
- ;; framples mus-length framples mix-length region-framples
-
- (let ((snd (open-sound "oboe.snd"))
- (v (float-vector .1 .2 .3))
- (vc (vector .1 .2 .3 .4))
- (lst (list 1 2 3 4 5))
- (hsh (make-hash-table 100))
- (sd (make-float-vector (list 1 10) 0.0))
- (str "123456"))
- (let ((mxv (mix-float-vector v 1000))
- (reg (make-region 0 100))
- (dly (make-delay 32))
- (ply (make-player snd 0))
- )
- (if (not (= (length snd) 50828)) (snd-display #__line__ ";length of sound: ~A" (length snd)))
- (if (not (= (length v) 3)) (snd-display #__line__ ";length of float-vector: ~A" (length v)))
- (if (not (= (length vc) 4)) (snd-display #__line__ ";length of vector: ~A" (length vc)))
- (if (not (= (length lst) 5)) (snd-display #__line__ ";length of list: ~A" (length lst)))
- (if (not (= (length str) 6)) (snd-display #__line__ ";length of string: ~A" (length str)))
- (if (not (= (framples sd) 10)) (snd-display #__line__ ";length of vector2: ~A" (framples sd)))
- (if (< (length hsh) 100) (snd-display #__line__ ";length of hash-table: ~A" (length hsh)))
- (if (not (= (length mxv) 3)) (snd-display #__line__ ";length of mix: ~A" (length mxv)))
- (if (not (= (length reg) 101)) (snd-display #__line__ ";length of region: ~A" (length reg)))
- (if (not (= (length dly) 32)) (snd-display #__line__ ";length of delay: ~A" (length dly)))
- (if (not (= (length ply) 50828)) (snd-display #__line__ ";length of player: ~A" (length ply)))
- )
- (close-sound snd))
+ (env-sound-interp '(0 0 1 1))
+ (if (not (vequal (channel->float-vector) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474
+ 0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
+ (snd-display ";env-sound-interp no change: ~A" (channel->float-vector)))
+ (undo)
+ (env-sound-interp '(0 0 1 .95 2 0) 2.0)
+ (if (not (vequal (channel->float-vector) (float-vector 0.000 0.050 0.100 0.150 0.200 0.250 0.300 0.350 0.400 0.450
+ 0.500 0.550 0.600 0.650 0.700 0.750 0.800 0.850 0.900 0.950
+ 1.000 0.950 0.900 0.850 0.800 0.750 0.700 0.650 0.600 0.550
+ 0.500 0.450 0.400 0.350 0.300 0.250 0.200 0.150 0.100 0.050)))
+ (snd-display ";env-sound-interp twice len and back: ~A" (channel->float-vector)))
+ (revert-sound ind)
+ (set! (sample 10) .5)
+ (remove-clicks)
+ (if (fneq (sample 10) 0.0) (snd-display ";remove-clicks: ~A" (channel->float-vector)))
+ (undo)
+ (let ((vals (scan-channel (search-for-click))))
+ (if (not (= vals 11))
+ (snd-display ";search-for-click: ~A" vals)))
+ (close-sound ind))
+ (set! *clm-srate* old-srate))
+
+ (let ((ind1 (new-sound :size 20 :comment "new-sound for sound-via-sound"))
+ (ind2 (new-sound :size 20 :comment "second new-sound for sound-via-sound")))
+ (let ((val -0.05)) (map-channel (lambda (y) (set! val (+ val .05))) 0 20 ind1))
+ (let ((val 1.1)) (map-channel (lambda (y) (set! val (- val .1))) 0 20 ind2))
+ (select-sound ind1)
+ (sound-via-sound ind1 ind2)
+ (let ((vals (channel->float-vector 0 20 ind1)))
+ (if (not (vequal vals (float-vector 0.95 0.90 0.85 0.80 0.75 0.70 0.65 0.60 0.55 0.50 0.45 0.40 0.35 0.30 0.25 0.20 0.15 0.10 0.05 0.00)))
+ (snd-display ";sound-via-sound: ~A" vals)))
+ (let ((new-file-name (file-name ind2)))
+ (close-sound ind2)
+ (if (file-exists? new-file-name) (delete-file new-file-name)))
+ (revert-sound ind1)
+ (let ((val -.5)) (map-channel (lambda (y) (set! val (+ val .05)))))
+ (let ((val (scan-channel (zero+))))
+ (if (not (eqv? val 10))
+ (snd-display ";zero+: ~A" val)))
+ (set! (sample 8) .8)
+ (let ((val (scan-channel (next-peak))))
+ (if (not (eqv? val 9))
+ (snd-display ";next-peak: ~A" val)))
+ (let ((val (scan-channel (search-for-click))))
+ (if (not (eqv? val 9))
+ (snd-display ";search-for-click: ~A" val)))
+ (if (not (= (find-click 0) 8)) (snd-display ";find-click: ~A" (find-click 0)))
+ (let ((new-file-name (file-name ind1)))
+ (close-sound ind1)
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+
+ (let* ((id (open-sound "oboe.snd"))
+ (fr (framples id 0))
+ (mx (maxamp id 0)))
+ (set! (framples id 0) 25000)
+ (if (not (= (framples id 0) 25000)) (snd-display ";set-framples 25000: ~A?" (framples id 0)))
+ (if (not (= (edit-position id 0) 1)) (snd-display ";set-framples 25000 edit: ~A?" (edit-position id 0)))
+ (set! (framples id 0) 75000)
+ (if (not (= (framples id 0) 75000)) (snd-display ";set-framples 75000: ~A?" (framples id 0)))
+ (if (not (= (edit-position id 0) 2)) (snd-display ";set-framples 75000 edit: ~A?" (edit-position id 0)))
+ (if (fneq (sample 30000 id 0) 0.0) (snd-display ";set-framples 75000 zeros: ~A?" (sample 30000 id 0)))
+ (set! (framples id 0) 0)
+ (if (not (= (framples id 0) 0)) (snd-display ";set-framples 0: ~A?" (framples id 0)))
+ (set! (framples id 0) 100)
+ (if (not (= (framples id 0) 100)) (snd-display ";set-framples 100: ~A?" (framples id 0)))
+ (revert-sound)
+ (if (fneq (sample 30000 id 0) -0.0844) (snd-display ";revert from set-framples: ~A?" (sample 30000 id 0)))
+ (if (not (= fr (framples id 0))) (snd-display ";revert set-framples: ~A != ~A?" (framples id 0) fr))
+ (set! (maxamp id 0) .5)
+ (if (fneq (maxamp id 0) .5) (snd-display ";set-maxamp: ~A?" (maxamp id 0)))
+ (if (not (= (edit-position id 0) 1)) (snd-display ";set-maxamp edit: ~A?" (edit-position id 0)))
+ (set! (maxamp id 0) .1)
+ (if (fneq (maxamp id 0) .1) (snd-display ";set-maxamp .1: ~A?" (maxamp id 0)))
+ (if (not (= (edit-position id 0) 2)) (snd-display ";set-maxamp .1 edit: ~A?" (edit-position id 0)))
+ (revert-sound)
+ (if (fneq (maxamp id 0) mx) (snd-display ";maxamp after set: ~A ~A?" (maxamp id 0) mx))
+ (set! (x-position-slider id 0) .1)
+ (if (fneq (x-position-slider id 0) .1) (snd-display ";set x-position-slider .1: ~A?" (x-position-slider id 0)))
+
+ (set! (x-zoom-slider id 0) .5)
+ (if (fneq (x-zoom-slider id 0) .5) (snd-display ";set x-zoom-slider: ~A?" (x-zoom-slider id 0)))
+ (if (> (abs (- fr (* 2 (- (right-sample id 0) (left-sample id 0))))) 10)
+ (snd-display ";set x-zoom-slider: ~A ~A -> ~A?"
+ (left-sample id 0) (right-sample id 0)
+ (abs (- fr (* 2 (right-sample id 0) (left-sample id 0))))))
+ (set! (y-position-slider id 0) .1)
+ (if (and (not (provided? 'snd-gtk)) (fneq (y-position-slider id 0) .1))
+ (snd-display ";set y-position-slider .1: ~A?" (y-position-slider id 0)))
+ (set! (y-zoom-slider id 0) .5)
+ (if (fneq (y-zoom-slider id 0) .5) (snd-display ";set y-zoom-slider: ~A?" (y-zoom-slider id 0)))
+ (let ((vals (channel-amp-envs "oboe.snd" 0 10)))
+ (if (not (and (vequal (car vals)
+ (float-vector -4.8828125e-4 -0.104156494140625 -0.125213623046875 -0.1356201171875 -0.138916015625
+ -0.14093017578125 -0.14093017578125 -0.131439208984375 -0.11248779296875 -0.080047607421875))
+ (vequal (cadr vals)
+ (float-vector 0.0 0.10955810546875 0.130706787109375 0.14068603515625 0.141204833984375 0.147247314453125
+ 0.145904541015625 0.140289306640625 0.126861572265625 0.08172607421875))))
+ (snd-display ";channel-amp-envs: ~A?" vals)))
+
+ (let ((len (length (channel-properties id 0))))
+ (if (channel-property 'hiho id 0)
+ (snd-display ";channel-property 'hiho: ~A?" (channel-property 'hiho id 0)))
+ (set! (channel-property 'hiho id 0) 123)
+ (if (not (= (channel-property 'hiho id 0) 123))
+ (snd-display ";channel-property 'hiho (123): ~A?" (channel-property 'hiho id 0)))
+ (if (channel-property 'hi id 0)
+ (snd-display ";channel-property 'hi: ~A?" (channel-property 'hi id 0)))
+ (set! (channel-property 'hi id 0) pi)
+ (if (fneq (channel-property 'hi id 0) pi)
+ (snd-display ";channel-property 'hi (pi): ~A?" (channel-property 'hi id 0)))
+ (if (not (= (channel-property 'hiho id 0) 123))
+ (snd-display ";channel-property 'second hiho (123): ~A?" (channel-property 'hiho id 0)))
+ (if (not (= (length (channel-properties id 0)) (+ len 2)))
+ (snd-display ";channel-properties: ~A?" (channel-properties id 0))))
+
+ (let ((len (length (sound-properties id))))
+ (if (sound-property 'hiho id)
+ (snd-display ";sound-property 'hiho: ~A?" (sound-property 'hiho id)))
+ (set! (sound-property 'hiho id) 123)
+ (if (not (= (sound-property 'hiho id) 123))
+ (snd-display ";sound-property 'hiho (123): ~A?" (sound-property 'hiho id)))
+ (if (sound-property 'hi id)
+ (snd-display ";sound-property 'hi: ~A?" (sound-property 'hi id)))
+ (set! (sound-property 'hi id) pi)
+ (if (fneq (sound-property 'hi id) pi)
+ (snd-display ";sound-property 'hi (pi): ~A?" (sound-property 'hi id)))
+ (if (not (= (sound-property 'hiho id) 123))
+ (snd-display ";sound-property 'second hiho (123): ~A?" (sound-property 'hiho id)))
+ (if (not (= (length (sound-properties id)) (+ len 2)))
+ (snd-display ";sound-properties: ~A?" (sound-properties id))))
+
+ (let ((tag (catch #t (lambda () (map-channel (lambda (y) "hiho"))) (lambda args args))))
+ (if (not (eq? (car tag) 'wrong-type-arg)) (snd-display ";map-channel bad val: ~A" tag)))
+
+ (close-sound id))
- ;; srate as generic: mus-sound-srate region-srate srate
+ (let ((ind (open-sound "oboe.snd")))
+ (if (not (null? (edit-properties ind 0 0)))
+ (snd-display ";initial edit-properties: ~A?" (edit-properties ind 0 0)))
+ (let ((tag (catch #t
+ (lambda () (edit-properties ind 0 123))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-edit))
+ (snd-display ";edit-properties of non-existent edit: ~A" tag)))
+ (let ((tag (catch #t
+ (lambda () (edit-properties ind 1 0))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-channel))
+ (snd-display ";edit-properties of non-existent channel: ~A" tag)))
+ (if (edit-property 'test-key ind 0 0)
+ (snd-display ";edit-property never set: ~A?" (edit-property ind 0 0)))
+ (set! (edit-property 'test-key ind 0 0) 3210)
+ (let ((val (edit-property 'test-key ind 0 0)))
+ (if (not (eqv? val 3210))
+ (snd-display ";edit-property 0: ~A" val)))
+ (pad-channel 0 10 ind 0)
+ (let ((val (edit-property 'test-key ind 0 0)))
+ (if (not (eqv? val 3210))
+ (snd-display ";edit-property look back to 0: ~A" val)))
+ (let ((val (edit-property 'test-key ind 0 1)))
+ (if val (snd-display ";edit-property current: ~A?" val)))
+ (undo)
+ (let ((val (edit-property 'test-key ind 0 0)))
+ (if (not (eqv? val 3210))
+ (snd-display ";edit-property go back to 0: ~A" val)))
+ (close-sound ind)
+ (set! ind (open-sound "oboe.snd"))
+ (if (edit-property 'test-key ind 0 0)
+ (snd-display ";edit-property not cleared: ~A?" (edit-property ind 0 0)))
+ (pad-channel 0 10 ind 0)
+ (set! (edit-property 'test-key ind 0 1) 'hiho)
+ (undo)
+ (pad-channel 0 10 ind 0)
+ (let ((val (edit-property 'test-key ind 0 1)))
+ (if val (snd-display ";edit-property not erased upon re-edit: ~A?" val)))
+ (close-sound ind))
- (let ((snd (open-sound "oboe.snd"))
- (str "oboe.snd"))
- (let ((reg (make-region 0 100))
- (ply (make-player snd 0))
- )
- (if (not (= (srate snd) 22050)) (snd-display #__line__ ";srate of sound: ~A" (srate snd)))
- (if (not (= (srate str) 22050)) (snd-display #__line__ ";srate of string: ~A" (srate str)))
- (if (not (= (srate reg) 22050)) (snd-display #__line__ ";srate of region: ~A" (srate reg)))
- (if (not (= (srate ply) 22050)) (snd-display #__line__ ";srate of player: ~A" (srate ply)))
- )
- (close-sound snd))
+ (let ((id (open-sound "oboe.snd")))
+ (prefix-it 1000 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\b) 4 id)
+ (let ((left (left-sample id)))
+ (if (not (= left 1000)) (snd-display ";u1000: ~A" left)))
+ (prefix-it 0 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\b) 4 id)
+ (let ((left (left-sample id)))
+ (if (not (= left 0)) (snd-display ";u0: ~A" left)))
+ (set! (cursor id) 1234)
+ (prefix-it 0 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1234)) (snd-display ";0f: ~A" cr)))
+ (prefix-it 100 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1334)) (snd-display ";100f: ~A" cr)))
+ (prefix-it -100 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1234)) (snd-display ";-100f: ~A" cr)))
+ (prefix-it 1 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1235)) (snd-display ";1f: ~A" cr)))
+ (prefix-it 1000 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\p) 4 id)
+ (let ((left (left-sample id))
+ (right (right-sample id)))
+ (if (> (abs (- right left 1000)) 2) (snd-display ";1000xp: ~A:~A" left right)))
+ (prefix-it 1 id)
+ (key (char->integer #\.) 0 id)
+ (key (char->integer #\2) 0 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\p) 4 id)
+ (let ((left (left-sample id))
+ (right (right-sample id)))
+ (if (> (abs (- right left (* 22050 1.2))) 2) (snd-display ";1.2xp: ~A:~A" left right)))
+
+ (prefix-uit 1000 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\b) 4 id)
+ (let ((left (left-sample id)))
+ (if (not (member left '(1000 1001) =)) (snd-display ";uu1000: ~A" left)))
+ (prefix-uit 0 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\b) 4 id)
+ (let ((left (left-sample id)))
+ (if (not (= left 0)) (snd-display ";uu0: ~A" left)))
+ (set! (cursor id) 1234)
+ (prefix-uit 0 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1234)) (snd-display ";u0f: ~A" cr)))
+ (prefix-uit 100 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1334)) (snd-display ";u100f: ~A" cr)))
+ (prefix-uit -100 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1234)) (snd-display ";u-100f: ~A" cr)))
+ (prefix-uit 1 id)
+ (key (char->integer #\f) 4 id)
+ (let ((cr (cursor id)))
+ (if (not (= cr 1235)) (snd-display ";u1f: ~A" cr)))
+ (prefix-uit 1000 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\p) 4 id)
+ (let ((left (left-sample id))
+ (right (right-sample id)))
+ (if (> (abs (- right left 1000)) 2) (snd-display ";u1000xp: ~A:~A" left right)))
+ (prefix-uit 1 id)
+ (key (char->integer #\.) 0 id)
+ (key (char->integer #\2) 0 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\p) 4 id)
+ (let ((left (left-sample id))
+ (right (right-sample id)))
+ (if (> (abs (- right left (* 22050 1.2))) 2) (snd-display ";u1.2xp: ~A:~A" left right)))
+ (close-sound id))
+ (let ((id (open-sound (car (match-sound-files (lambda (file)
+ (and (>= (mus-sound-chans file) 2)
+ (not (= (mus-sound-header-type file) mus-raw))
+ (> (mus-sound-framples file) 1000))))))))
+ (set! (sync id) 1)
+ (select-sound id)
+ (make-region 200 500 id)
+ (select-channel 1)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\v) 0 id)
+ (let ((x0 (x-bounds id 0))
+ (x1 (x-bounds id 1)))
+ (if (or (fneq (car x0) (car x1))
+ (fneq (cadr x0) (cadr x1)))
+ (snd-display ";C-X v: ~A ~A?" x0 x1)))
+ (key (char->integer #\u) 4 id)
+ (key (char->integer #\1) 0 id)
+ (key (char->integer #\x) 4 id)
+ (key (char->integer #\q) 0 id)
+ (close-sound id))
+
+ (let ((snd1 (open-sound "oboe.snd"))
+ (snd2 (or (open-sound "2.snd") (open-sound "4.aiff")))
+ (snd3 (open-sound "4.aiff")))
+ (define tests-1
+ (lambda (f fn nv)
+ (if (pair? f)
+ (begin
+ (test-history-channel (car f) (car fn) (car nv) snd1 snd2 snd3)
+ (tests-1 (cdr f) (cdr fn) (cdr nv))))))
+ (tests-1 funcs func-names new-values)
+ (close-sound snd1)
+ (close-sound snd2)
+
+ (set! (time-graph-style snd3 #t) graph-filled)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (time-graph-style snd3 i) graph-filled))
+ (snd-display ";set time-graph-style ~A ~A: ~A" snd3 i (time-graph-style snd3 i))))
+ (set! (time-graph-style snd3 2) graph-lines)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (or (= i 2)
+ (= (time-graph-style snd3 i) graph-filled)))
+ (snd-display ";set (2) time-graph-style ~A ~A: ~A" snd3 i (time-graph-style snd3 i))))
+ (if (not (= (time-graph-style snd3 2) graph-lines))
+ (snd-display ";set time-graph-style (2): ~A" (time-graph-style snd3 2)))
+ (set! (time-graph-style snd3 #t) graph-dots)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (time-graph-style snd3 i) graph-dots))
+ (snd-display ";set time-graph-style (all): ~A" (time-graph-style snd3 i))))
+ (set! *graph-style* graph-dots-and-lines)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
+ (snd-display ";set time-graph-style (dal): ~A" (time-graph-style snd3 i))))
+
+ (set! (lisp-graph-style snd3 #t) graph-filled)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (lisp-graph-style snd3 i) graph-filled))
+ (snd-display ";set lisp-graph-style ~A ~A: ~A" snd3 i (lisp-graph-style snd3 i))))
+ (set! (lisp-graph-style snd3 2) graph-lines)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (or (= i 2)
+ (= (lisp-graph-style snd3 i) graph-filled)))
+ (snd-display ";set (2) lisp-graph-style ~A ~A: ~A" snd3 i (lisp-graph-style snd3 i))))
+ (if (not (= (lisp-graph-style snd3 2) graph-lines))
+ (snd-display ";set lisp-graph-style (2): ~A" (lisp-graph-style snd3 2)))
+ (set! (lisp-graph-style snd3 #t) graph-lines)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
+ (snd-display ";set lisp -> time-graph-style (dal): ~A" (time-graph-style snd3 i))))
+
+ (set! (transform-graph-style snd3 #t) graph-filled)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (transform-graph-style snd3 i) graph-filled))
+ (snd-display ";set transform-graph-style ~A ~A: ~A" snd3 i (transform-graph-style snd3 i))))
+ (set! (transform-graph-style snd3 2) graph-lines)
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (or (= i 2)
+ (= (transform-graph-style snd3 i) graph-filled)))
+ (snd-display ";set (2) transform-graph-style ~A ~A: ~A" snd3 i (transform-graph-style snd3 i))))
+ (if (not (= (transform-graph-style snd3 2) graph-lines))
+ (snd-display ";set transform-graph-style (2): ~A" (transform-graph-style snd3 2)))
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (time-graph-style snd3 i) graph-dots-and-lines))
+ (snd-display ";set fft and lisp -> time-graph-style (dal): ~A" (time-graph-style snd3 i))))
+ (do ((i 0 (+ i 1))) ((= i 4))
+ (if (not (= (lisp-graph-style snd3 i) graph-lines))
+ (snd-display ";set fft and lisp -> lisp-graph-style (dal): ~A" (lisp-graph-style snd3 i))))
+
+ (close-sound snd3))
+
+ (let ((snd2 (open-sound "2.snd")))
+ (if (sound? snd2)
+ (play-with-amps snd2 0.2 0.1))
+ (close-sound snd2))
+
+ (let ((old-bp *with-background-processes*))
+ (set! *with-background-processes* #f)
+ (let* ((ind (open-sound "1a.snd"))
+ (player (make-player ind 0))
+ (len (framples ind 0))
+ (incr *dac-size*)
+ (e (make-env '(0 0 1 1) :length (+ 1 (floor (* 1.0 (/ len incr))))))
+ (samp 0))
+ (add-player player 0 -1 -1
+ (lambda (reason)
+ (set! (hook-functions play-hook) ())
+ (close-sound ind)))
+ (hook-push play-hook
+ (lambda (hook)
+ (set! (amp-control player) (env e))
+ (if (fneq (amp-control ind) 1.0) (snd-display ";amp-control snd: ~A" (amp-control ind)))
+ (if (> (abs (- (amp-control player) (* 1.0 (/ samp len)))) 1.0)
+ (snd-display ";amp-control player: ~A ~A" (amp-control player) (* 1.0 (/ samp len))))
+ (set! samp (+ samp incr))))
+ (start-playing 1 (srate ind)))
+ (if (find-sound "1a.snd") (snd-display ";stop proc didn't close?"))
+ (set! *with-background-processes* old-bp))
+
+ (let ((ind (open-sound "pistol.snd")))
+ (if (selection-member? ind 0)
+ (snd-display ";initial selection-member? ~A ~A?"
+ (selection-member? ind 0)
+ (selection?)))
+ (set! (selection-member? ind 0) #t)
+ (if (not (and (selection-member? ind 0)
+ (selection-member? ind)))
+ (snd-display ";selection-member? ~A ~A ~A?"
+ (selection-member? ind 0)
+ (selection-member? ind)
+ (selection?)))
+ (if (not (= (selection-framples) 1))
+ (snd-display ";initial selection-framples: ~A?" (selection-framples)))
+ (set! (selection-framples) 1200)
+ (if (not (= (selection-framples) 1200))
+ (snd-display ";selection-framples: 1200 ~A?" (selection-framples)))
+ (delete-selection)
+ (if (selection?) (snd-display ";selection active after cut?"))
+ (undo)
+ (if (not (selection?)) (snd-display ";selection inactive after undo?"))
+ (if (not (and (selection-member? ind 0)
+ (selection-member? ind)))
+ (snd-display ";selection-member? after undo ~A ~A ~A?"
+ (selection-member? ind 0)
+ (selection-member? ind)
+ (selection?)))
+ (if (not (and (= (selection-framples) 1200)
+ (= (selection-position) 0)))
+ (snd-display ";selection after undo: '(0 1200) '(~A ~A)?"
+ (selection-position)
+ (selection-framples)))
+ (set! (selection-position) 1000)
+ (if (not (and (= (selection-framples) 200)
+ (= (selection-position) 1000)))
+ (snd-display ";selection after reposition: '(1000 200) '(~A ~A)?"
+ (selection-position)
+ (selection-framples)))
+ (reverse-selection)
+ (if (not (and (= (selection-framples) 200)
+ (= (selection-position) 1000)))
+ (snd-display ";selection after reverse: '(1000 200) '(~A ~A)?"
+ (selection-position)
+ (selection-framples)))
+
+ (let ((old-framples (framples ind)))
+ (src-selection .5)
+ (if (or (> (abs (- (framples ind) 200 old-framples)) 5)
+ (> (abs (- (selection-framples) 400)) 5))
+ (snd-display ";selection after src .5: '(1000 400) '(~A ~A)?"
+ (selection-position)
+ (selection-framples)))
+ (undo)
+ (redo)
+ (if (or (> (abs (- (framples ind) 200 old-framples)) 5)
+ (> (abs (- (selection-framples) 400)) 5))
+ (snd-display ";selection after src .5 with undo/redo: '(1000 400) '(~A ~A)?"
+ (selection-position)
+ (selection-framples)))
+ (undo 3))
+ (close-sound ind))
+ (set! *clm-srate* 22050)
+ (let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "src-* tests" 10000))
+ (osc (make-oscil 500)))
+
+ (define f3neq (lambda (a b) (> (abs (- a b)) 10)))
+ (define f4neq (lambda (a b) (> (abs (- a b)) 1)))
+ (define f5neq (lambda (a b) (> (abs (- a b)) (* .05 (max a b)))))
+
+ ;; src-duration tests
+ (if (or (fneq (src-duration '(0 1 1 2)) 0.693147180559945)
+ (fneq (src-duration '(0 2 1 1)) (src-duration '(0 1 1 2)))
+ (fneq (src-duration '(0 1 .5 2)) (src-duration '(0 1 1 2)))
+ (fneq (src-duration '(.5 1 .75 2)) (src-duration '(0 1 1 2))))
+ (snd-display ";src-duration test1 ~A ~A ~A ~A"
+ (src-duration '(0 1 1 2))
+ (src-duration '(0 2 1 1))
+ (src-duration '(0 1 .5 2))
+ (src-duration '(.5 1 .75 2))))
+ (if (or (fneq (src-duration '(0 1 1 0.5)) 1.38629436111989)
+ (fneq (src-duration '(0 0.5 1 1)) (src-duration '(0 1 1 0.5)))
+ (fneq (src-duration '(0 1 .5 0.5)) (src-duration '(0 1 1 0.5)))
+ (fneq (src-duration '(.5 1 .75 0.5)) (src-duration '(0 1 1 0.5))))
+ (snd-display ";src-duration test2 ~A ~A ~A ~A"
+ (src-duration '(0 1 1 0.5))
+ (src-duration '(0 0.5 1 1))
+ (src-duration '(0 1 .5 0.5))
+ (src-duration '(.5 1 .75 0.5))))
+ (if (or (fneq (src-duration '(0 1 1 1)) 1.0)
+ (fneq (src-duration '(0 2 1 2)) 0.5))
+ (snd-display ";src-duration test3: ~A ~A" (src-duration '(0 1 1 1)) (src-duration '(0 2 1 2))))
+ (if (fneq (src-duration '(0 .5 .5 3 .6 1 .7 .1 .8 1.5 1 1)) 1.02474349685432)
+ (snd-display ";src-duration test4 ~A" (src-duration '(0 .5 .5 3 .6 1 .7 .1 .8 1.5 1 1))))
+ (if (fneq (src-duration '(0 1 1 2 2 1)) 0.693147180559945)
+ (snd-display ";src-duration test5: ~A" (src-duration '(0 1 1 2 2 1))))
+ (if (fneq (src-duration '(0 1 1 1)) 1.0)
+ (snd-display ";src-duration test6: ~A" (src-duration '(0 1 1 1))))
+ (if (fneq (src-duration '(0 2 1 2)) 0.5)
+ (snd-display ";src-duration test7: ~A" (src-duration '(0 2 1 2))))
+ (if (fneq (src-duration '(0 0.5 2 0.5)) 2.0)
+ (snd-display ";src-duration test8: ~A" (src-duration '(0 0.5 2 0.5))))
+
+ (if (fneq (src-duration (src-fit-envelope '(0 1 1 2) 2.0)) 2.0)
+ (snd-display ";src-fit-envelope 2.0: ~A" (src-duration (src-fit-envelope '(0 1 1 2) 2.0))))
+ (if (fneq (src-duration (src-fit-envelope '(0 1 1 2) 0.5)) 0.5)
+ (snd-display ";src-fit-envelope 0.5: ~A" (src-duration (src-fit-envelope '(0 1 1 2) 0.5))))
+
+
+ (if (fneq (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.69287)
+ (snd-display ";fm-parallel-component 100: ~A" (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
+ (if (fneq (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.17047)
+ (snd-display ";fm-parallel-component 500: ~A" (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
+
+ (if (fneq (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0)) -0.0732421875)
+ (snd-display ";cheby-hka 0: ~A" (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0))))
+ (if (fneq (cheby-hka 2 0.25 (float-vector 0 0 0 0 1.0 1.0)) -0.234375)
+ (snd-display ";cheby-hka 1: ~A" (cheby-hka 2 0.25 (float-vector 0 0 0 0 1.0 1.0))))
+ (if (fneq (cheby-hka 1 0.25 (float-vector 0 0 0 0 1.0 1.0)) 1.025390625)
+ (snd-display ";cheby-hka 2: ~A" (cheby-hka 1 0.25 (float-vector 0 0 0 0 1.0 1.0))))
+ (if (fneq (cheby-hka 0 0.25 (float-vector 0 0 0 0 1.0 1.0)) 1.5234375)
+ (snd-display ";cheby-hka 3: ~A" (cheby-hka 0 0.25 (float-vector 0 0 0 0 1.0 1.0))))
+
+ (map-channel (lambda (y) (* .5 (oscil osc))))
+ (let ((vals (freq-peak 0 ind 8192)))
+ (if (or (f4neq (car vals) 500.0)
+ (fneq (cadr vals) 1.0))
+ (snd-display ";src no-test: ~A" vals)))
+ (for-each
+ (lambda (sr dur)
+ (src-sound sr 1.0 ind 0)
+ (if (fneq (/ (framples ind 0) 10000.0) dur) (snd-display ";src-sound ~A: ~A (~A)" sr (/ (framples ind 0) 10000.0) dur))
+ (let ((vals (freq-peak 0 ind 8192)))
+ (if (or (f4neq (car vals) (* 500 sr))
+ (fneq (cadr vals) 1.0))
+ (snd-display ";src ~A freq: ~A" sr vals)))
+ (undo))
+ (list 2.0 0.5 5.0 0.2)
+ (list 0.5 2.0 0.2 5.0))
+ (for-each
+ (lambda (e f0 f1)
+ (src-sound e 1.0 ind 0)
+ (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
+ (snd-display ";src-sound (env) ~A: ~A (~A)"
+ e (/ (framples ind 0) 10000.0) (src-duration e)))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) f0)
+ (snd-display ";src (env) 0 ~A freq: ~A" f0 vals)))
+ (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
+ (if (f5neq (car vals) f1)
+ (snd-display ";src (env) 1 ~A freq: ~A" f1 vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
+ (list 500.0 1000.0 500.0 250.0 250.0)
+ (list 1000.0 500.0 500.0 500.0 1000.0))
+ (for-each
+ (lambda (e f0 f1)
+ (src-sound (make-env e :length (framples)) 1.0 ind 0)
+ (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
+ (snd-display ";src-sound (make-env) ~A: ~A (~A)"
+ e (/ (framples ind 0) 10000.0) (src-duration e)))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) f0)
+ (snd-display ";src (make-env) 0 ~A freq: ~A" f0 vals)))
+ (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
+ (if (f5neq (car vals) f1)
+ (snd-display ";src (env) 1 ~A freq: ~A" f1 vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
+ (list 500.0 1000.0 500.0 250.0 250.0)
+ (list 1000.0 500.0 500.0 500.0 1000.0))
+
+ (for-each
+ (lambda (sr dur)
+ (src-channel sr)
+ (if (fneq (/ (framples ind 0) 10000.0) dur) (snd-display ";src-channel ~A: ~A (~A)" sr (/ (framples ind 0) 10000.0) dur))
+ (let ((vals (freq-peak 0 ind 8192)))
+ (if (or (f4neq (car vals) (* 500 sr))
+ (fneq (cadr vals) 1.0))
+ (snd-display ";src ~A freq: ~A" sr vals)))
+ (undo))
+ (list 2.0 0.5 5.0 0.2)
+ (list 0.5 2.0 0.2 5.0))
+ (for-each
+ (lambda (e f0 f1)
+ (src-channel e)
+ (if (fneq (/ (framples ind 0) 10000.0) (src-duration e))
+ (snd-display ";src-channel (env) ~A: ~A (~A)"
+ e (/ (framples ind 0) 10000.0) (src-duration e)))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) f0)
+ (snd-display ";src-channel (env f0) ~A: ~A" f0 vals)))
+ (let ((vals (freq-peak (- (floor (* (src-duration e) 10000.0)) 256) ind 256)))
+ (if (f5neq (car vals) f1)
+ (snd-display ";src-channel (env f1) ~A: ~A" f1 vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
+ (list 500.0 1000.0 500.0 250.0 250.0)
+ (list 1000.0 500.0 500.0 500.0 1000.0))
+
+ (for-each
+ (lambda (sr dur)
+ (src-channel sr 1000 2500)
+ (if (f4neq (framples ind 0) (+ 7500 (* dur 2500)))
+ (snd-display ";src-channel section: ~A ~A" (framples) (+ 7500 (* dur 2500))))
+ (let ((vals (freq-peak 0 ind 512)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-channel section 0 ~A freq: ~A" sr vals)))
+ (let ((vals (freq-peak (- (+ 7500 (floor (* dur 2500))) 512) ind 512)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-channel section 8000 ~A freq: ~A" sr vals)))
+ (let ((vals (freq-peak 1000 ind 512)))
+ (if (f5neq (car vals) (* sr 500.0))
+ (snd-display ";src-channel section ~A freq: ~A" sr vals)))
+ (undo))
+ (list 2.0 0.5 5.0 0.2)
+ (list 0.5 2.0 0.2 5.0))
+
+ (for-each
+ (lambda (e)
+ (src-channel (make-env e :length 2500) 1000 2500)
+ (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
+ (snd-display ";src-channel section (make-env duration) ~A: ~A (~A ~A)"
+ e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-channel section (make-env e) ~A: ~A" e vals)))
+ (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-channel section (make-env e) ~A: ~A" e vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+
+ (make-selection 1000 3500 ind 0)
+ (for-each
+ (lambda (sr dur)
+ (src-selection sr)
+ (if (f3neq (framples ind 0) (+ 7500 (* dur 2500)))
+ (snd-display ";src-selection section: ~A ~A" (framples) (+ 7500 (* dur 2500))))
+ (let ((vals (freq-peak 0 ind 512)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section 0 ~A freq: ~A" sr vals)))
+ (let ((vals (freq-peak (- (+ 7500 (floor (* dur 2500))) 512) ind 512)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section 8000 ~A freq: ~A" sr vals)))
+ (let ((vals (freq-peak 1000 ind 512)))
+ (if (f5neq (car vals) (* sr 500.0))
+ (snd-display ";src-selection section ~A freq: ~A" sr vals)))
+ (undo))
+ (list 2.0 0.5 5.0 0.2)
+ (list 0.5 2.0 0.2 5.0))
+
+ (for-each
+ (lambda (e)
+ (src-selection (make-env e :length 2500))
+ (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
+ (snd-display ";src-selection section (make-env duration) ~A: ~A (~A ~A)"
+ e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section (make-env e) ~A: ~A" e vals)))
+ (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section (make-env e) ~A: ~A" e vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+
+ (for-each
+ (lambda (e)
+ (src-selection e)
+ (if (f3neq (framples ind 0) (+ 7500 (* (src-duration e) 2500)))
+ (snd-display ";src-selection section (env duration) ~A: ~A (~A ~A)"
+ e (src-duration e) (framples) (+ 7500 (* (src-duration e) 2500))))
+ (let ((vals (freq-peak 0 ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section (env e) ~A: ~A" e vals)))
+ (let ((vals (freq-peak (- (+ 7500 (floor (* (src-duration e) 2500))) 256) ind 256)))
+ (if (f5neq (car vals) 500.0)
+ (snd-display ";src-selection section (env f1) ~A: ~A" e vals)))
+ (undo))
+ (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+
+ (close-sound ind)
+ )
- ;; channels as generic: mus-sound-chans region-chans chans mus-channels mix/etc
+ (set! *print-length* (max *print-length* 12))
+ (let ((ind (new-sound "hi.snd")))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (sample i ind) (* i .1)))
+ (select-all ind)
+ (set! (sample 10 ind) 1.0)
+ (smooth-selection)
+ (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
+ (snd-display ";smooth-selection: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0)))
+ (revert-sound)
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (sample i ind) (- 1.0 (* i .1))))
+ (select-all ind)
+ (set! (sample 10 ind) 0.0)
+ (smooth-selection)
+ (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
+ (snd-display ";smooth-selection back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0)))
+ (close-sound ind))
- (let ((snd (open-sound "oboe.snd"))
- (v (float-vector .1 .2 .3))
- (sd (make-float-vector (list 2 10) 0.0))
- (str "oboe.snd"))
- (let ((mxv (mix-float-vector v 1000))
- (reg (make-region 0 100))
- (ply (make-player snd 0))
- )
- (if (not (= (channels snd) 1)) (snd-display #__line__ ";channels of sound: ~A" (channels snd)))
- (if (not (= (channels v) 1)) (snd-display #__line__ ";channels of float-vector: ~A" (channels v)))
- (if (not (= (channels str) 1)) (snd-display #__line__ ";channels of string: ~A" (channels str)))
- (if (not (= (channels sd) 2)) (snd-display #__line__ ";channels of vector2: ~A" (channels sd)))
- (if (not (= (channels mxv) 1)) (snd-display #__line__ ";channels of mix: ~A" (channels mxv)))
- (if (not (= (channels reg) 1)) (snd-display #__line__ ";channels of region: ~A" (channels reg)))
- (if (not (= (channels ply) 1)) (snd-display #__line__ ";channels of player: ~A" (channels ply)))
- )
- (close-sound snd))
+ (let ((ind (new-sound "hi.snd")))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (sample i ind) (* i .1)))
+ (set! (sample 10 ind) 1.0)
+ (smooth-sound 0 10 ind)
+ (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
+ (snd-display ";smooth-sound: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0)))
+ (revert-sound)
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (sample i ind) (- 1.0 (* i .1))))
+ (set! (sample 10 ind) 0.0)
+ (smooth-sound 0 10 ind)
+ (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
+ (snd-display ";smooth-sound back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0)))
+ (close-sound ind))
+ (if (file-exists? "hi.snd") (delete-file "hi.snd"))
- ;; framples as generic
+ (let* ((ind (open-sound "oboe.snd"))
+ (len (framples ind)))
+ (set! (cursor ind) 1200)
+ (key (char->integer #\u) 4 ind)
+ (key (char->integer #\1) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\o) 4 ind)
+ (if (not (= (framples ind) (+ 100 len)))
+ (snd-display ";C-o len: ~A? " (framples)))
+ (let ((data (channel->float-vector 1200 100 ind)))
+ (if (fneq (float-vector-peak data) 0.0) (snd-display ";C-o: ~A?" (float-vector-peak data))))
+ (revert-sound ind)
+ (set! (cursor ind) 1200)
+ (key (char->integer #\u) 4 ind)
+ (key (char->integer #\1) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\z) 4 ind)
+ (if (not (= (framples ind) len))
+ (snd-display ";C-z len: ~A? " (framples)))
+ (let ((data (channel->float-vector 1200 100 ind)))
+ (if (fneq (float-vector-peak data) 0.0) (snd-display ";C-z: ~A?" (float-vector-peak data))))
+ (set! (cursor ind) 0)
+ (key (char->integer #\u) 4 ind)
+ (key (char->integer #\3) 0 ind)
+ (key (char->integer #\.) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\z) 4 ind)
+ (if (fneq (maxamp ind 0) 0.0) (snd-display ";C-z full: ~A" (maxamp)))
+ (revert-sound ind)
+ (set! (cursor ind) 1200)
+ (key (char->integer #\u) 4 ind)
+ (key (char->integer #\1) 0 ind)
+ (key (char->integer #\.) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\o) 4 ind)
+ (if (not (= (framples ind) (+ (srate ind) len)))
+ (snd-display ";C-o 1.0 len: ~A? " (framples)))
+ (let ((data (channel->float-vector 1200 (srate ind) ind)))
+ (if (fneq (float-vector-peak data) 0.0) (snd-display ";C-o 1.0: ~A?" (float-vector-peak data))))
+ (revert-sound ind)
+ (set! (cursor ind) 1200)
+ (key (char->integer #\u) 4 ind)
+ (key (char->integer #\1) 0 ind)
+ (key (char->integer #\.) 0 ind)
+ (key (char->integer #\0) 0 ind)
+ (key (char->integer #\z) 4 ind)
+ (if (not (= (framples ind) len))
+ (snd-display ";C-z 1.0 len: ~A? " (framples)))
+ (let ((data (channel->float-vector 1200 (srate ind) ind)))
+ (if (fneq (float-vector-peak data) 0.0) (snd-display ";C-z 1.0: ~A?" (float-vector-peak data))))
+ (close-sound ind))
- (let ((snd (open-sound "oboe.snd"))
- (v (float-vector .1 .2 .3))
- (sd (make-float-vector (list 1 10) 0.0))
- (str "oboe.snd"))
- (let ((mxv (mix-float-vector v 1000))
- (reg (make-region 0 100))
- (dly (make-delay 32))
- (ply (make-player snd 0))
- )
- (if (not (= (framples snd) 50828)) (snd-display #__line__ ";framples of sound: ~A" (framples snd)))
- (if (not (= (framples v) 3)) (snd-display #__line__ ";framples of float-vector: ~A" (framples v)))
- (if (not (= (framples str) 50828)) (snd-display #__line__ ";framples of string: ~A" (framples str)))
- (if (not (= (framples sd) 10)) (snd-display #__line__ ";framples of vector2: ~A" (framples sd)))
- (if (not (= (framples mxv) 3)) (snd-display #__line__ ";framples of mix: ~A" (framples mxv)))
- (if (not (= (framples reg) 101)) (snd-display #__line__ ";framples of region: ~A" (framples reg)))
- (if (not (= (framples dly) 32)) (snd-display #__line__ ";framples of delay: ~A" (framples dly)))
- (if (not (= (framples ply) 50828)) (snd-display #__line__ ";framples of player: ~A" (framples ply)))
- )
- (close-sound snd))
+ (let ((ind (open-sound "2.snd")))
+ (set! (sync ind) 1)
+ (key (char->integer #\>) 4)
+ (key (char->integer #\space) 4)
+ (key (char->integer #\<) 4)
+ (if (not (and (selection-member? ind 0)
+ (selection-member? ind 1)
+ (= (selection-position ind 0) 0)
+ (= (selection-position ind 1) 0)
+ (= (selection-framples ind 0) (framples ind 0))
+ (= (selection-framples ind 1) (framples ind 1))))
+ (snd-display ";sync selection via <-: ~A ~A ~A ~A ~A ~A"
+ (selection-member? ind 0) (selection-member? ind 1)
+ (selection-position ind 0) (selection-position ind 1)
+ (selection-framples ind 0) (selection-framples ind 1)))
+ (key (char->integer #\space) 4)
+ (key (char->integer #\>) 4)
+ (if (not (and (selection-member? ind 0)
+ (selection-member? ind 1)
+ (= (selection-position ind 0) 0)
+ (= (selection-position ind 1) 0)
+ (= (selection-framples ind 0) (framples ind 0))
+ (= (selection-framples ind 1) (framples ind 1))))
+ (snd-display ";sync selection via ->: ~A ~A ~A ~A ~A ~A"
+ (selection-member? ind 0) (selection-member? ind 1)
+ (selection-position ind 0) (selection-position ind 1)
+ (selection-framples ind 0) (selection-framples ind 1)))
+ (set! (cursor ind 1) 0)
+ (set! (cursor ind 0) 1000)
+ (if (not (= (cursor ind 1) 1000)) (snd-display ";syncd cursors: ~A ~A" (cursor ind 0) (cursor ind 1)))
+ (close-sound ind))
- ;; file-name as generic
+ (let ((ind (open-sound "2a.snd")))
+ (let ((reg (make-region 100 200 ind #t)))
+ (if (not (= (region-chans reg) 2))
+ (snd-display ";make-region #t for chan in 2a.snd: ~A chans" (region-chans reg)))
+ (mix-region reg 1000)
+ (if (not (and (= (edit-position ind 0) 1)
+ (= (edit-position ind 1) 0)))
+ (snd-display ";mix-region default mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+ (undo)
+ (set! (sync ind) 1)
+ (mix-region reg 1000)
+ (if (not (and (= (edit-position ind 0) 1)
+ (= (edit-position ind 1) 1)))
+ (snd-display ";mix-region sync mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+ (undo)
+ (set! (sync ind) 0)
+ (mix-region reg 1000 ind 1)
+ (if (not (and (= (edit-position ind 0) 0)
+ (= (edit-position ind 1) 1)))
+ (snd-display ";mix-region mix -> chan 1: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+ (revert-sound ind))
+
+ (set! (selection-member? #t #t) #f)
+ (set! (selection-member? ind 0) #t)
+ (set! (selection-member? ind 1) #t)
+ (set! (selection-position ind 0) 1000)
+ (set! (selection-position ind 1) 1000)
+ (set! (selection-framples ind 0) 100)
+ (set! (selection-framples ind 1) 100)
+ (if (not (= (selection-chans) 2))
+ (snd-display ";laboriously make 2 chan selection: ~A" (selection-chans)))
+
+ (mix-selection 100)
+ (if (not (and (= (edit-position ind 0) 1)
+ (= (edit-position ind 1) 0)))
+ (snd-display ";mix-selection default mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+ (undo)
+ (set! (sync ind) 1)
+ (mix-selection 100)
+ (if (not (and (= (edit-position ind 0) 1)
+ (= (edit-position ind 1) 1)))
+ (snd-display ";mix-selection sync mix: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+ (undo)
+ (set! (sync ind) 0)
+ (mix-selection 100 ind 1)
+ (if (not (and (= (edit-position ind 0) 0)
+ (= (edit-position ind 1) 1)))
+ (snd-display ";mix-selection mix -> chan 1: ~A ~A" (edit-position ind 0) (edit-position ind 1)))
+
+ (close-sound ind))
- (let ((snd (open-sound "oboe.snd"))
- (str "oboe.snd")
- (frm (make-file->sample "oboe.snd"))
- (prt (open-output-file "tst.dat")))
- (let ((mxv (car (mix "pistol.snd" 1000)))
- (reg (make-region 0 100))
- )
- (if (not (string=? (file-name snd) (string-append (getcwd) "/oboe.snd"))) (snd-display #__line__ ";file-name of sound: ~A" (file-name snd)))
- (if (not (string=? (file-name str) (string-append (getcwd) "/oboe.snd"))) (snd-display #__line__ ";file-name of string: ~A" (file-name str)))
- (if (not (string=? (file-name frm) "oboe.snd")) (snd-display #__line__ ";file-name of file->sample: ~A" (file-name frm)))
- (if (not (string=? (file-name prt) "tst.dat")) (snd-display #__line__ ";file-name of output port: ~A" (file-name prt)))
- (if (not (string=? (file-name mxv) (string-append (getcwd) "/pistol.snd"))) (snd-display #__line__ ";file-name of mix: ~A" (file-name mxv)))
- (if (not (string=? (file-name reg) "oboe.snd")) (snd-display #__line__ ";file-name of region: ~A" (file-name reg)))
- )
- (close-output-port prt)
- (mus-close frm)
- (close-sound snd))
+ (let ((ind (open-sound "oboe.snd")))
+ (test-selection ind 1200 100 2.0)
+ (test-selection ind 600 1200 2.0)
+ (test-selection ind 0 100 2.0)
+ (test-selection ind 22500 28327 0.5)
+ (test-selection ind 0 50828 0.5)
+
+ (test-selection-to ind 1200 100 1.0)
+ (test-selection-to ind 600 1200 0.1)
+ (test-selection-to ind 0 100 0.5)
+ (test-selection-to ind 22500 28327 2.0)
+ (test-selection-to ind 0 50828 0.5)
+
+ (revert-sound ind)
+ (make-selection 1200 1200)
+ (if (not (selection?)) (snd-display ";no selection from 1 samp region?"))
+ (if (not (= (selection-framples) 1)) (snd-display ";1 samp selection: ~A samps?" (selection-framples)))
+ (scale-selection-to 1.0)
+ (if (fneq (sample 1200 ind 0) 1.0) (snd-display ";scale 1 samp selection: ~A?" (sample 1200 ind 0)))
+
+ (revert-sound ind)
+ (let ((id (make-region 500 1000)))
+ (src-selection .5)
+ (if (> (abs (- (region-framples id) 500)) 1) (snd-display ";region-framples after src-selection: ~A?" (region-framples id)))
+ (let ((reg-mix-id (car (mix-region id 1500 ind 0))))
+ (if (not (= (mix-length reg-mix-id) (region-framples id)))
+ (snd-display ";mix-region: ~A != ~A?" (region-framples id) (mix-length reg-mix-id)))
+ (if (not (equal? (mix-home reg-mix-id) (list ind 0 #f 0)))
+ (snd-display ";mix-region mix-home ~A (~A 0 #f 0)?" (mix-home reg-mix-id) ind))
+ (let ((sel-mix-id (car (mix-selection 2500 ind 0))))
+ (if (not (= (selection-framples) (mix-length sel-mix-id)))
+ (snd-display ";mix-selection framples: ~A != ~A?" (selection-framples) (mix-length sel-mix-id)))
+ (if (> (abs (- (* 2 (mix-length reg-mix-id)) (mix-length sel-mix-id))) 3)
+ (snd-display ";mix selection and region: ~A ~A (~A ~A)?"
+ (mix-length reg-mix-id) (mix-length sel-mix-id) (region-framples id) (selection-framples)))
+ (if (not (equal? (mix-home sel-mix-id) (list ind 0 #f 0)))
+ (snd-display ";mix-selection mix-home: ~A (~A 0 #f 0)?" (mix-home sel-mix-id) ind)))))
+ (insert-selection 3000 ind 0)
+ (insert-selection 3000 ind)
+ (mix-selection 3000 ind)
+ (delete-selection)
+ (revert-sound ind)
+ (close-sound ind))
- ;; sync as generic: mix-sync mark-sync sync
+ (if (file-exists? "storm.snd")
+ (let ((ind (open-sound "storm.snd")))
+ (set! *sinc-width* 10)
+ (time (src-sound 1.3))
+ (time (env-sound '(0 0 1 1 2 0)))
+ (time (filter-sound '(0 1 .2 0 .5 1 1 0) 20)) ; FIR direct form
+ (time (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048)) ; convolution
+ (revert-sound ind)
+ (region->float-vector (make-region 0 123000 ind 0) 0 10 0 (make-float-vector 10)) ; force copy branch to execute
+ (do ((i 0 (+ i 1))) ((= i 4)) (ramp-channel 0.0 1.0))
+ (close-sound ind)))
- (let ((snd (open-sound "oboe.snd")))
- (let ((mrk (add-mark 123))
- (mx (mix-float-vector (float-vector .1 .2 .3)))
- )
- (if (not (= (sync snd) 0)) (snd-display #__line__ ";sync of sound (0): ~A" (sync snd)))
- (if (not (= (sync mrk) 0)) (snd-display #__line__ ";sync of mark (0): ~A" (sync mrk)))
- (if (not (= (sync mx) 0)) (snd-display #__line__ ";sync of mx (0): ~A" (sync mx)))
-
- (set! (sync snd) 12)
- (set! (sync mrk) 24)
- (set! (sync mx) 36)
-
- (if (not (= (sync snd) 12)) (snd-display #__line__ ";sync of sound (12): ~A" (sync snd)))
- (if (not (= (sync mrk) 24)) (snd-display #__line__ ";sync of mark (24): ~A" (sync mrk)))
- (if (not (= (sync mx) 36)) (snd-display #__line__ ";sync of mx (36): ~A" (sync mx)))
- )
- (close-sound snd))
+ (if (file-exists? "1a.snd")
+ (let ((ind1 (open-sound "1a.snd")))
+ (time (rubber-sound 1.25))
+ (close-sound ind1)))
+ (gc)
+ (let* ((oboe (open-sound "oboe.snd"))
+ (a4 (open-sound "4.aiff"))
+ (sr (srate oboe))
+ ;(fr (framples oboe 0))
+ ;(typ (header-type oboe))
+ ;(frm (sample-type oboe))
+ ;(loc (data-location oboe))
+ ;(com (comment oboe))
+ )
+ (save-sound-as "test.aif" oboe :header-type mus-aifc)
+ (let ((oboe-aif (open-sound "test.aif")))
+ (if (not (= (header-type oboe-aif) mus-aifc)) (snd-display ";oboe-aif header: ~A?" (mus-header-type-name (header-type oboe-aif))))
+ (set! (srate oboe-aif) (* sr 2.0))
+ (if (fneq (* sr 2.0) (srate oboe-aif)) (snd-display ";set! srate: ~A ~A" (* sr 2.0) (srate oboe-aif)))
+ (set! (header-type oboe-aif) mus-next)
+ (if (not (= (header-type oboe-aif) mus-next)) (snd-display ";set! header: ~A?" (mus-header-type-name (header-type oboe-aif))))
+ (set! (data-location oboe-aif) 28)
+ (if (not (= (data-location oboe-aif) 28)) (snd-display ";set! data-location: ~A?" (data-location oboe-aif)))
+ (set! (sample-type oboe-aif) mus-mulaw)
+ (if (not (= (sample-type oboe-aif) mus-mulaw)) (snd-display ";set! format: ~A?" (mus-sample-type-name (sample-type oboe-aif))))
+ (save-sound-as "test.aif" oboe-aif 22050 mus-bshort mus-aifc 0)
+ (close-sound oboe-aif)
+ (delete-file "test.aif")
+ (set! (selected-sound) a4)
+ (if (not (equal? (selected-sound) a4)) (snd-display ";set! selected-sound: ~A ~A?" (selected-sound) a4))
+ (set! (selected-channel) 2)
+ (if (not (= (selected-channel a4) 2)) (snd-display ";set! selected-channel: ~A?" (selected-channel a4)))
+ (set! (selected-channel a4) 3)
+ (if (not (= (selected-channel a4) 3)) (snd-display ";set! selected-channel a4: ~A?" (selected-channel a4)))
+ (close-sound a4)
+ (close-sound oboe)))
+
+ (let ((v1 (envelope-interp 1.0 '(0 0 2.0 1.0))))
+ (if (fneq v1 0.5) (snd-display ";envelope-interp(1): ~F (0.5)?" v1)))
+ (let ((v2 (envelope-interp 1.0 '(0 0.0 1 1.0 2 0.0))))
+ (if (fneq v2 1.0) (snd-display ";envelope-interp(2): ~F (1.0)?" v2)))
+ (let ((v3 (envelope-interp 2.0 '(0 0.0 1 1.0))))
+ (if (fneq v3 1.0) (snd-display ";envelope-interp(3): ~F (1.0)?" v3)))
+ (let ((v4 (envelope-interp 0.0 '(1 .5 2 0))))
+ (if (fneq v4 0.5) (snd-display ";envelope-interp(4): ~F (0.5)?" v4)))
+
+ (let ((v1 (envelope-interp 0.0 '(-1 0 0 1 1 -1))))
+ (if (fneq v1 1.0) (snd-display ";envelope-interp(1a): ~A" v1)))
+ (let ((v2 (envelope-interp -0.5 '(-1 0 0 1 1 -1))))
+ (if (fneq v2 0.5) (snd-display ";envelope-interp(2a): ~A" v2)))
+ (let ((v3 (envelope-interp -0.5 '(-1 -1 0 1 1 -1))))
+ (if (fneq v3 0.0) (snd-display ";envelope-interp(3a): ~A" v3)))
+ (let ((v4 (envelope-interp -0.5 '(-1 -1 1 1))))
+ (if (fneq v4 -0.5) (snd-display ";envelope-interp(4a): ~A" v4)))
+ (let ((v5 (envelope-interp -1.5 '(-1 -1 1 1))))
+ (if (fneq v5 -1.0) (snd-display ";envelope-interp(5a): ~A" v5)))
+ (let ((v6 (envelope-interp 1.5 '(-1 -1 1 1))))
+ (if (fneq v6 1.0) (snd-display ";envelope-interp(6a): ~A" v6)))
+
+ (let ((v1 (multiply-envelopes '(0.0 0.0 2.0 0.5) '(0.0 0.0 1.0 2.0 2.0 1.0)))
+ (v2 (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
+ (if (not (feql v1 (list 0.0 0.0 0.5 0.5 1.0 0.5))) (snd-display ";multiply-envelopes: ~A?" v1))
+ (if (not (feql v2 (list 1.0 0.2 3.0 0.6))) (snd-display ";window-envelope: ~A?" v2)))
+
+ (if (fneq (envelope-interp .1 '(0 0 1 1)) 0.1)
+ (snd-display ";envelope-interp .1 -> ~A?" (envelope-interp .1 '(0 0 1 1))))
+ (if (fneq (envelope-interp .1 '(0 0 1 1) 32.0) 0.01336172)
+ (snd-display ";envelope-interp .013 -> ~A?" (envelope-interp .1 '(0 0 1 1) 32.0)))
+ (if (fneq (envelope-interp .1 '(0 0 1 1) .012) 0.36177473)
+ (snd-display ";envelope-interp .361 -> ~A?" (envelope-interp .1 '(0 0 1 1) .012)))
+ (if (fneq (envelope-interp .3 '(0 0 .5 1 1 0)) .6)
+ (snd-display ";envelope-interp .3 '(0 0 .5 1 1 0)) -> ~A" (envelope-interp .3 '(0 0 .5 1 1 0))))
+
+ (if (fneq (envelope-interp .9 '(0 0 1 1)) 0.9)
+ (snd-display ";envelope-interp .9 -> ~A?" (envelope-interp .9 '(0 0 1 1))))
+ (if (fneq (envelope-interp .9 '(0 0 1 1) 32.0) 0.698)
+ (snd-display ";envelope-interp .698 -> ~A?" (envelope-interp .9 '(0 0 1 1) 32.0)))
+ (if (fneq (envelope-interp .9 '(0 0 1 1) .012) 0.993)
+ (snd-display ";envelope-interp .993 -> ~A?" (envelope-interp .9 '(0 0 1 1) .012)))
+
+ (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1)) 0.1)
+ (snd-display ";envelope-interp .1 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1))))
+ (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1) 32.0) 0.01336172)
+ (snd-display ";envelope-interp .013 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1) 32.0)))
+ (if (fneq (envelope-interp 1.1 '(0 0 1 0 2 1) .012) 0.36177473)
+ (snd-display ";envelope-interp .361 (2) -> ~A?" (envelope-interp 1.1 '(0 0 1 0 2 1) .012)))
+
+ (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1)) 0.9)
+ (snd-display ";envelope-interp .9 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1))))
+ (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1) 32.0) 0.698)
+ (snd-display ";envelope-interp .698 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1) 32.0)))
+ (if (fneq (envelope-interp 1.9 '(0 0 1 0 2 1) .012) 0.993)
+ (snd-display ";envelope-interp .993 (2) -> ~A?" (envelope-interp 1.9 '(0 0 1 0 2 1) .012)))
+
+ (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1)) 0.1)
+ (snd-display ";envelope-interp .1 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1))))
+ (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) 32.0) 0.01336172)
+ (snd-display ";envelope-interp .013 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) 32.0)))
+ (if (fneq (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) .012) 0.36177473)
+ (snd-display ";envelope-interp .361 (3) -> ~A?" (envelope-interp 1.1 '(0 0 0.5 1 1 0 2 1) .012)))
+
+ (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1)) 0.9)
+ (snd-display ";envelope-interp .9 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1))))
+ (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) 32.0) 0.698)
+ (snd-display ";envelope-interp .698 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) 32.0)))
+ (if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012) 0.993)
+ (snd-display ";envelope-interp .993 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012)))
+
+ (if (not (feql (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) (list 1.0 0.2 3.0 0.6)))
+ (snd-display ";window-envelope: ~A?" (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
+ (if (not (feql (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0)) (list 0 0 0.5 0.5 1 0)))
+ (snd-display ";multiply-envelopes: ~A?" (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0))))
+ (if (fneq (max-envelope '(0 0 1 1 2 3 4 0)) 3.0)
+ (snd-display ";max-envelope: ~A?" (max-envelope '(0 0 1 1 2 3 4 0))))
+ (if (fneq (max-envelope '(0 1)) 1.0)
+ (snd-display ";1 max-envelope: ~A?" (max-envelope '(0 1))))
+ (if (fneq (max-envelope '(0 1 1 1 2 2)) 2.0)
+ (snd-display ";2 max-envelope: ~A?" (max-envelope '(0 1 1 1 2 2))))
+ (if (fneq (max-envelope '(0 -1 1 -2)) -1.0)
+ (snd-display ";3 max-envelope: ~A?" (max-envelope '(0 -1 1 -2))))
+ (if (fneq (max-envelope '(0 -2 1 -1)) -1.0)
+ (snd-display ";4 max-envelope: ~A?" (max-envelope '(0 -2 1 -1))))
+ (if (fneq (min-envelope '(0 0 1 1 2 3 4 0)) 0.0)
+ (snd-display ";min-envelope: ~A?" (min-envelope '(0 0 1 1 2 3 4 0))))
+ (if (fneq (min-envelope '(0 1)) 1.0)
+ (snd-display ";1 min-envelope: ~A?" (min-envelope '(0 1))))
+ (if (fneq (min-envelope '(0 1 1 1 2 2)) 1.0)
+ (snd-display ";2 min-envelope: ~A?" (min-envelope '(0 1 1 1 2 2))))
+ (if (fneq (min-envelope '(0 -1 1 -2)) -2.0)
+ (snd-display ";3 min-envelope: ~A?" (min-envelope '(0 -1 1 -2))))
+ (if (fneq (min-envelope '(0 -2 1 -1)) -2.0)
+ (snd-display ";4 min-envelope: ~A?" (min-envelope '(0 -2 1 -1))))
+ (if (fneq (integrate-envelope '(0 0 1 1)) 0.5)
+ (snd-display ";integrate-envelope: ~A?" (integrate-envelope '(0 0 1 1))))
+ (if (fneq (integrate-envelope '(0 1 1 1)) 1.0)
+ (snd-display ";integrate-envelope: ~A?" (integrate-envelope '(0 1 1 1))))
+ (if (fneq (integrate-envelope '(0 0 1 1 2 .5)) 1.25)
+ (snd-display ";integrate-envelope: ~A?" (integrate-envelope '(0 0 1 1 2 .5))))
+ (if (not (feql (stretch-envelope '(0 0 1 1) .1 .2) (list 0 0 0.2 0.1 1.0 1)))
+ (snd-display ";stretch-envelope att: ~A?" (stretch-envelope '(0 0 1 1) .1 .2)))
+ (if (not (feql (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) (list 0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)))
+ (snd-display ";stretch-envelope dec: ~A?" (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6)))
+ (if (not (feql (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1)) '(0 0 0.5 1.5 1 1)))
+ (snd-display ";add-envelopes: ~A" (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1))))
+ (if (not (feql (scale-envelope '(0 0 1 1) 2) '(0 0 1 2)))
+ (snd-display ";scale-envelope: ~A" (scale-envelope '(0 0 1 1) 2)))
+ (if (not (feql (scale-envelope '(0 0 1 1) 2 1) '(0 1 1 3)))
+ (snd-display ";scale-envelope off: ~A" (scale-envelope '(0 0 1 1) 2 1)))
+ (if (not (feql (reverse-envelope '(0 0 1 1)) '(0 1 1 0)))
+ (snd-display ";reverse-envelope ramp: ~A" (reverse-envelope '(0 0 1 1))))
+ (if (not (feql (reverse-envelope '(0 0 .5 1 2 0)) '(0 0 1.5 1 2 0)))
+ (snd-display ";reverse-envelope ramp 2: ~A" (reverse-envelope '(0 0 .5 1 2 0))))
+ (if (not (feql (reverse-envelope '(0 0 .5 1 2 1)) '(0 1 1.5 1 2 0)))
+ (snd-display ";reverse-envelope ramp 2: ~A" (reverse-envelope '(0 0 .5 1 2 1))))
+ (if (not (feql (concatenate-envelopes '(0 0 1 1) '(0 1 1 0)) '(0.0 0 1.0 1 2.0 0)))
+ (snd-display ";concatenate-envelopes: ~A" (concatenate-envelopes '(0 0 1 1) '(0 1 1 0))))
+ (if (not (feql (concatenate-envelopes '(0 0 1 1.5) '(0 1 1 0)) '(0.0 0 1.0 1.5 1.01 1 2.01 0)))
+ (snd-display ";concatenate-envelopes: ~A" (concatenate-envelopes '(0 0 1 1.5) '(0 1 1 0))))
+ (if (not (feql (repeat-envelope '(0 0 1 100) 2) '(0 0 1 100 1.01 0 2.01 100)))
+ (snd-display ";repeat-envelope 0: ~A" (repeat-envelope '(0 0 1 100) 2)))
+ (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2) '(0 0 1.5 1 2.0 0 3.5 1 4.0 0)))
+ (snd-display ";repeat-envelope 1: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2)))
+ (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2 #f #t) '(0.0 0 0.75 1 1.0 0 1.75 1 2.0 0)))
+ (snd-display ";repeat-envelope 2: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2 #f #t)))
+ (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 2 #t) '(0 0 1.5 1 2.0 0 2.5 1 4.0 0)))
+ (snd-display ";repeat-envelope 3: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 2 #t)))
+ (if (not (feql (repeat-envelope '(0 0 1.5 1 2 0) 3) '(0 0 1.5 1 2.0 0 3.5 1 4.0 0 5.5 1 6.0 0)))
+ (snd-display ";repeat-envelope 4: ~A" (repeat-envelope '(0 0 1.5 1 2 0) 3)))
+ (if (not (feql (normalize-envelope '(0 0 1 1.5 2.0 1.0)) '(0 0.0 1 1.0 2.0 0.667)))
+ (snd-display ";normalize-envelope: ~A" (normalize-envelope '(0 0 1 1.5 2.0 1.0))))
+ (if (not (feql (normalize-envelope '(0 0 1 .5 2 -.8)) '(0 0.0 1 0.625 2 -1.0)))
+ (snd-display ";normalize-envelope: ~A" (normalize-envelope '(0 0 1 .5 2 -.8))))
+
+ (let ((val (envelope-exp '(0 0 1 1) 2.0 10)))
+ (if (not (feql val '(0.000 0.000 0.100 0.010 0.200 0.040 0.300 0.090 0.400 0.160
+ 0.500 0.250 0.600 0.360 0.700 0.490 0.800 0.640 0.900 0.810 1.000 1.000)))
+ (snd-display ";envelope-exp: ~A" val))
+ (set! val (envelope-exp '(0 0 1 1 2 0) 1.0 10))
+ (if (not (feql val '(0.000 0.000 0.200 0.200 0.400 0.400 0.600 0.600 0.800 0.800
+ 1.000 1.000 1.200 0.800 1.400 0.600 1.600 0.400 1.800 0.200 2.000 0.000)))
+ (snd-display ";envelope exp 2: ~A" val)))
+
+ (let ((ind (new-sound "fmv.snd")))
+ (float-vector->channel (make-float-vector 20 1.0))
+ (if (selection?) (set! (selection-member? #t) #f))
+ (make-selection 5 9 ind 0)
+ (scale-selection-to 0.5)
+ (insert-selection 15 ind)
+ (if (not (= (framples ind) 25)) (snd-display ";insert-selection 5: ~A" (framples ind)))
+ (if (not (vequal (channel->float-vector 0 25) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
+ 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
+ 1.0 1.0 1.0 1.0 1.0)))
+ (snd-display ";insert-selection: ~A" (channel->float-vector 0 25)))
+ (mix-selection 1 ind 0) ; this is being confused by clipping settings
+ (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector 1.000 1.500 1.500 1.500 1.500 1.000 0.500 0.500 0.500 0.500)))
+ (snd-display ";mix-selection vals: ~A" (channel->float-vector 0 10 ind 0)))
+ (close-sound ind))
- ;; maxamp as generic
+ (let ((ind (new-sound "fmv.snd"))
+ (old-size *transform-size*)
+ (old-type *transform-type*)
+ (old-norm *transform-normalization*)
+ (old-grf *transform-graph-type*))
+ (let ((v (make-float-vector 2000)))
+ (let ((e (make-env (list 0.0 0.0 1.0 (* 2000 0.2 pi)) :length 2001)))
+ (fill-float-vector v (sin (env e))))
+ (float-vector->channel v 0 2000 ind 0))
+ (set! *transform-size* 256)
+ (set! *transform-type* fourier-transform)
+ (set! *transform-normalization* normalize-by-channel)
+ (set! *transform-graph-type* graph-once)
+ (set! *zero-pad* 0)
+ (set! (transform-graph?) #t)
+ (make-selection 0 200)
+ (set! *show-selection-transform* #t)
+ (set! (selection-framples) 300)
+ (update-transform-graph)
+ (let* ((data (transform->float-vector))
+ (peak (float-vector-peak data))
+ (val (transform-sample 0)))
+ (if (= peak 0.0) (snd-display ";transform selection peak: ~A" peak))
+ (if (fneq val (data 0)) (snd-display ";transform-sample: ~A, data: ~A" val (data 0)))
+ (if (and (>= (length data) 64)
+ (> (* .5 peak) (data 51)))
+ (snd-display ";transform selection at 51: ~A, peak: ~A" (data 51) peak)))
+ (for-each
+ (lambda (pad)
+ (set! *zero-pad* pad)
+ (update-transform-graph)
+ (let* ((data (transform->float-vector))
+ (peak (float-vector-peak data))
+ (pval (data (floor (* .1 (length data))))))
+ (if (> (* .5 peak) pval)
+ (snd-display ";transform selection padded ~D: ~A, peak: ~A" pad pval peak))))
+ (list 1 0 3 31))
+ (set! *zero-pad* 100000)
+ (if (> *zero-pad* 1000)
+ (snd-display ";zero-pad: ~A" *zero-pad*))
+ (set! *zero-pad* 0)
+ (set! *transform-size* old-size)
+ (set! *transform-type* (if (integer? old-type) (integer->transform old-type) old-type))
+ (set! *transform-normalization* old-norm)
+ (set! *transform-graph-type* old-grf)
+ (close-sound ind))
- (let ((snd (open-sound "oboe.snd"))
- (v (float-vector .1 .2 .3))
- (vc (vector .1 .2 .3 .4))
- (sd (make-float-vector (list 1 10) 0.0))
- (str "pistol.snd")) ; can't use oboe.snd since we messed with mus-sound-maxamp above
- (let ((mxv (mix-float-vector v 1000))
- (reg (make-region 0 900))
- (dly (make-delay 32))
- )
- (set! (sd 0 1) .1)
- (delay dly .1)
- (delay dly .2)
-
- (if (fneq (maxamp snd) .334) (snd-display #__line__ ";maxamp of sound: ~A" (maxamp snd)))
- (if (fneq (maxamp snd 0) .334) (snd-display #__line__ ";maxamp of sound (0): ~A" (maxamp snd)))
- (if (fneq (maxamp snd 0 0) .14724) (snd-display #__line__ ";maxamp of sound (0 0): ~A" (maxamp snd)))
- (if (fneq (maxamp v) .3) (snd-display #__line__ ";maxamp of float-vector: ~A" (maxamp v)))
- (if (fneq (maxamp vc) .4) (snd-display #__line__ ";maxamp of vector: ~A" (maxamp vc)))
- (if (fneq (maxamp str) .49267) (snd-display #__line__ ";maxamp of string: ~A" (maxamp str)))
- (if (fneq (maxamp sd) 0.1) (snd-display #__line__ ";maxamp of vector2: ~A" (maxamp sd)))
- (if (fneq (maxamp mxv) .3) (snd-display #__line__ ";maxamp of mix: ~A" (maxamp mxv)))
- (if (fneq (maxamp reg) .02139) (snd-display #__line__ ";maxamp of region: ~A" (maxamp reg)))
- (if (fneq (maxamp dly) .2) (snd-display #__line__ ";maxamp of delay: ~A" (maxamp dly)))
+ (let ((ind (open-sound "storm.snd"))
+ (maxes (float-vector 0.8387 0.5169 0.3318 0.2564 0.1982 0.1532)))
+ (do ((i 0 (+ i 1)))
+ ((= i 5))
+ (if (fneq (maxamp) (maxes i)) (snd-display ";enving storm ~D: ~A ~A" i (maxes i) (maxamp)))
+ (env-sound '(0 0 1 1 2 0))
+ (if (fneq (maxamp) (maxes (+ i 1))) (snd-display ";enving storm ~D: ~A ~A" (+ i 1) (maxes (+ i 1)) (maxamp))))
+ (close-sound ind))
+ ))
+
+ ;; --------------------------------------------------------------------------------
+ ;; length as generic function:
+ ;; string-length vector-length length
+ ;; framples mus-length framples mix-length region-framples
+
+ (let ((snd (open-sound "oboe.snd"))
+ (v (float-vector .1 .2 .3))
+ (vc (vector .1 .2 .3 .4))
+ (lst (list 1 2 3 4 5))
+ (hsh (make-hash-table 100))
+ (sd (make-float-vector (list 1 10) 0.0))
+ (str "123456"))
+ (let ((mxv (mix-float-vector v 1000))
+ (reg (make-region 0 100))
+ (dly (make-delay 32))
+ (ply (make-player snd 0))
)
- (close-sound snd))
+ (if (not (= (length snd) 50828)) (snd-display ";length of sound: ~A" (length snd)))
+ (if (not (= (length v) 3)) (snd-display ";length of float-vector: ~A" (length v)))
+ (if (not (= (length vc) 4)) (snd-display ";length of vector: ~A" (length vc)))
+ (if (not (= (length lst) 5)) (snd-display ";length of list: ~A" (length lst)))
+ (if (not (= (length str) 6)) (snd-display ";length of string: ~A" (length str)))
+ (if (not (= (framples sd) 10)) (snd-display ";length of vector2: ~A" (framples sd)))
+ (if (< (length hsh) 100) (snd-display ";length of hash-table: ~A" (length hsh)))
+ (if (not (= (length mxv) 3)) (snd-display ";length of mix: ~A" (length mxv)))
+ (if (not (= (length reg) 101)) (snd-display ";length of region: ~A" (length reg)))
+ (if (not (= (length dly) 32)) (snd-display ";length of delay: ~A" (length dly)))
+ (if (not (= (length ply) 50828)) (snd-display ";length of player: ~A" (length ply)))
+ )
+ (close-sound snd))
+
+ ;; srate as generic: mus-sound-srate region-srate srate
+
+ (let ((snd (open-sound "oboe.snd")))
+ (let ((reg (make-region 0 100))
+ (ply (make-player snd 0)))
+ (if (not (= (srate snd) 22050)) (snd-display ";srate of sound: ~A" (srate snd)))
+ (let ((str "oboe.snd"))
+ (if (not (= (srate str) 22050)) (snd-display ";srate of string: ~A" (srate str))))
+ (if (not (= (srate reg) 22050)) (snd-display ";srate of region: ~A" (srate reg)))
+ (if (not (= (srate ply) 22050)) (snd-display ";srate of player: ~A" (srate ply))))
+ (close-sound snd))
+
+
+ ;; channels as generic: mus-sound-chans region-chans chans mus-channels mix/etc
+
+ (let ((snd (open-sound "oboe.snd"))
+ (v (float-vector .1 .2 .3))
+ (sd (make-float-vector (list 2 10) 0.0)))
+ (let ((mxv (mix-float-vector v 1000))
+ (reg (make-region 0 100))
+ (ply (make-player snd 0))
+ )
+ (if (not (= (channels snd) 1)) (snd-display ";channels of sound: ~A" (channels snd)))
+ (if (not (= (channels v) 1)) (snd-display ";channels of float-vector: ~A" (channels v)))
+ (let ((str "oboe.snd"))
+ (if (not (= (channels str) 1)) (snd-display ";channels of string: ~A" (channels str))))
+ (if (not (= (channels sd) 2)) (snd-display ";channels of vector2: ~A" (channels sd)))
+ (if (not (= (channels mxv) 1)) (snd-display ";channels of mix: ~A" (channels mxv)))
+ (if (not (= (channels reg) 1)) (snd-display ";channels of region: ~A" (channels reg)))
+ (if (not (= (channels ply) 1)) (snd-display ";channels of player: ~A" (channels ply)))
+ )
+ (close-sound snd))
+
+ ;; framples as generic
+
+ (let ((snd (open-sound "oboe.snd"))
+ (v (float-vector .1 .2 .3))
+ (sd (make-float-vector (list 1 10) 0.0)))
+ (let ((mxv (mix-float-vector v 1000))
+ (reg (make-region 0 100))
+ (dly (make-delay 32))
+ (ply (make-player snd 0)))
+ (if (not (= (framples snd) 50828)) (snd-display ";framples of sound: ~A" (framples snd)))
+ (if (not (= (framples v) 3)) (snd-display ";framples of float-vector: ~A" (framples v)))
+ (let ((str "oboe.snd"))
+ (if (not (= (framples str) 50828)) (snd-display ";framples of string: ~A" (framples str))))
+ (if (not (= (framples sd) 10)) (snd-display ";framples of vector2: ~A" (framples sd)))
+ (if (not (= (framples mxv) 3)) (snd-display ";framples of mix: ~A" (framples mxv)))
+ (if (not (= (framples reg) 101)) (snd-display ";framples of region: ~A" (framples reg)))
+ (if (not (= (framples dly) 32)) (snd-display ";framples of delay: ~A" (framples dly)))
+ (if (not (= (framples ply) 50828)) (snd-display ";framples of player: ~A" (framples ply))))
+ (close-sound snd))
+
+ ;; file-name as generic
+
+ (let ((snd (open-sound "oboe.snd"))
+ (frm (make-file->sample "oboe.snd"))
+ (prt (open-output-file "tst.dat")))
+ (let ((mxv (car (mix "pistol.snd" 1000)))
+ (reg (make-region 0 100)))
+ (if (not (string=? (file-name snd) (string-append (getcwd) "/oboe.snd"))) (snd-display ";file-name of sound: ~A" (file-name snd)))
+ (let ((str "oboe.snd"))
+ (if (not (string=? (file-name str) (string-append (getcwd) "/oboe.snd"))) (snd-display ";file-name of string: ~A" (file-name str))))
+ (if (not (string=? (file-name frm) "oboe.snd")) (snd-display ";file-name of file->sample: ~A" (file-name frm)))
+ (if (not (string=? (file-name prt) "tst.dat")) (snd-display ";file-name of output port: ~A" (file-name prt)))
+ (if (not (string=? (file-name mxv) (string-append (getcwd) "/pistol.snd"))) (snd-display ";file-name of mix: ~A" (file-name mxv)))
+ (if (not (string=? (file-name reg) "oboe.snd")) (snd-display ";file-name of region: ~A" (file-name reg))))
+ (close-output-port prt)
+ (mus-close frm)
+ (close-sound snd))
+
+ ;; sync as generic: mix-sync mark-sync sync
+
+ (let ((snd (open-sound "oboe.snd")))
+ (let ((mrk (add-mark 123))
+ (mx (mix-float-vector (float-vector .1 .2 .3))))
+ (if (not (= (sync snd) 0)) (snd-display ";sync of sound (0): ~A" (sync snd)))
+ (if (not (= (sync mrk) 0)) (snd-display ";sync of mark (0): ~A" (sync mrk)))
+ (if (not (= (sync mx) 0)) (snd-display ";sync of mx (0): ~A" (sync mx)))
- )))
+ (set! (sync snd) 12)
+ (set! (sync mrk) 24)
+ (set! (sync mx) 36)
+
+ (if (not (= (sync snd) 12)) (snd-display ";sync of sound (12): ~A" (sync snd)))
+ (if (not (= (sync mrk) 24)) (snd-display ";sync of mark (24): ~A" (sync mrk)))
+ (if (not (= (sync mx) 36)) (snd-display ";sync of mx (36): ~A" (sync mx))))
+ (close-sound snd))
+
+ ;; maxamp as generic
+
+ (let ((snd (open-sound "oboe.snd"))
+ (v (float-vector .1 .2 .3)))
+ (let ((mxv (mix-float-vector v 1000))
+ (reg (make-region 0 900)))
+ (if (fneq (maxamp snd) .334) (snd-display ";maxamp of sound: ~A" (maxamp snd)))
+ (if (fneq (maxamp snd 0) .334) (snd-display ";maxamp of sound (0): ~A" (maxamp snd)))
+ (if (fneq (maxamp snd 0 0) .14724) (snd-display ";maxamp of sound (0 0): ~A" (maxamp snd)))
+ (if (fneq (maxamp v) .3) (snd-display ";maxamp of float-vector: ~A" (maxamp v)))
+ (let ((vc (vector .1 .2 .3 .4)))
+ (if (fneq (maxamp vc) .4) (snd-display ";maxamp of vector: ~A" (maxamp vc))))
+ (let ((str "pistol.snd")) ; can't use oboe.snd since we messed with mus-sound-maxamp above
+ (if (fneq (maxamp str) .49267) (snd-display ";maxamp of string: ~A" (maxamp str))))
+ (let ((sd (make-float-vector (list 1 10) 0.0)))
+ (set! (sd 0 1) .1)
+ (if (fneq (maxamp sd) 0.1) (snd-display ";maxamp of vector2: ~A" (maxamp sd))))
+ (if (fneq (maxamp mxv) .3) (snd-display ";maxamp of mix: ~A" (maxamp mxv)))
+ (if (fneq (maxamp reg) .02139) (snd-display ";maxamp of region: ~A" (maxamp reg)))
+ (let ((dly (make-delay 32)))
+ (delay dly .1)
+ (delay dly .2)
+ (if (fneq (maxamp dly) .2) (snd-display ";maxamp of delay: ~A" (maxamp dly)))))
+ (close-sound snd))
+
+ ))
;;; ---------------- test 16: regularized funcs ----------------
(define (snd_test_16)
- (define (undo-env s c)
- (let ((len (car (edits s c))))
- (and (> len 0)
- (let ((unhappy #f))
- (do ((i 1 (+ i 1)))
- ((or unhappy (> i len))
- unhappy)
- (let ((ed (edit-fragment i s c)))
- (if (and ed
- (string=? (cadr ed) "env"))
- (begin
- (set! (edit-position s c) (- i 1))
- (set! unhappy #t)))))))))
-
(define (opt-test choice)
+ (define (undo-env s c)
+ (let ((len (car (edits s c))))
+ (and (> len 0)
+ (let ((unhappy #f))
+ (do ((i 1 (+ i 1)))
+ ((or unhappy (> i len))
+ unhappy)
+ (let ((ed (edit-fragment i s c)))
+ (if (and ed
+ (string=? (cadr ed) "env"))
+ (begin
+ (set! (edit-position s c) (- i 1))
+ (set! unhappy #t)))))))))
+
(let* ((snds (sounds))
(cursnd (snds (random (length snds))))
(curchn (random (chans cursnd)))
@@ -29242,29 +28666,29 @@ EDITS: 2
(cur-loc (random cur-frame))
(cur-samp (sample cur-loc cursnd curchn)))
(scale-channel scaler 0 (framples cursnd curchn) cursnd curchn)
- (if (and (not (= (edit-position cursnd curchn) (+ 1 cur-edit)))
- (not (= (edit-position cursnd curchn) cur-edit)))
- (snd-display #__line__ ";scale-channel ~A[~A] edit pos: ~A ~A" (short-file-name cursnd) curchn (edit-position cursnd curchn) cur-edit))
+ (if (not (or (= (edit-position cursnd curchn) (+ 1 cur-edit))
+ (= (edit-position cursnd curchn) cur-edit)))
+ (snd-display ";scale-channel ~A[~A] edit pos: ~A ~A" (short-file-name cursnd) curchn (edit-position cursnd curchn) cur-edit))
(if (not (= (framples cursnd curchn) cur-frame))
- (snd-display #__line__ ";scale-channel ~A[~A] framples: ~A ~A" (short-file-name cursnd) curchn (framples cursnd curchn) cur-frame))
+ (snd-display ";scale-channel ~A[~A] framples: ~A ~A" (short-file-name cursnd) curchn (framples cursnd curchn) cur-frame))
(if (fneq (maxamp cursnd curchn) (* scaler cur-amp))
- (snd-display #__line__ ";scale-channel ~A[~A] maxamp: ~A ~A (~A, scaler: ~A)"
+ (snd-display ";scale-channel ~A[~A] maxamp: ~A ~A (~A, scaler: ~A)"
(short-file-name cursnd) curchn (maxamp cursnd curchn) (* scaler cur-amp)
(abs (- (maxamp cursnd curchn) (* scaler cur-amp)))
scaler))
(if (fneq (sample cur-loc cursnd curchn) (* scaler cur-samp))
- (snd-display #__line__ ";scale-channel ~A[~A] cur-samp: ~A ~A" (short-file-name cursnd) curchn (sample cur-loc cursnd curchn) (* scaler cur-samp)))
+ (snd-display ";scale-channel ~A[~A] cur-samp: ~A ~A" (short-file-name cursnd) curchn (sample cur-loc cursnd curchn) (* scaler cur-samp)))
(for-each
(lambda (s c amp ed fr)
(if (not (and (equal? s cursnd)
(= c curchn)))
(begin
(if (not (= (edit-position s c) ed))
- (snd-display #__line__ ";scale-channel ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (snd-display ";scale-channel ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";scale-channel ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (snd-display ";scale-channel ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
(if (fneq (maxamp s c) amp)
- (snd-display #__line__ ";scale-channel ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))))
+ (snd-display ";scale-channel ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))))
(car chan-list)
(cadr chan-list)
cur-maxamps
@@ -29278,24 +28702,24 @@ EDITS: 2
(for-each
(lambda (s c amp ed fr)
(if (or (and (= (sync cursnd) 0)
- (or (not (equal? s cursnd))
- (not (= c curchn))))
+ (not (and (equal? s cursnd)
+ (= c curchn))))
(not (= (sync s) (sync cursnd))))
(begin
(if (not (= (edit-position s c) ed))
- (snd-display #__line__ ";scale-by ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (snd-display ";scale-by ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";scale-by ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (snd-display ";scale-by ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
(if (fneq (maxamp s c) amp)
- (snd-display #__line__ ";scale-by ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))
+ (snd-display ";scale-by ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))
(begin
- (if (and (not (= (edit-position s c) (+ 1 ed)))
- (not (= (edit-position s c) ed)))
- (snd-display #__line__ ";scale-by ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (if (not (or (= (edit-position s c) (+ 1 ed))
+ (= (edit-position s c) ed)))
+ (snd-display ";scale-by ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";scale-by ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (snd-display ";scale-by ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr))
(if (fneq (maxamp s c) (* scaler amp))
- (snd-display #__line__ ";scale-by ~A[~A] maxamp: ~A ~A" (short-file-name s) c (maxamp s c) (* scaler amp))))))
+ (snd-display ";scale-by ~A[~A] maxamp: ~A ~A" (short-file-name s) c (maxamp s c) (* scaler amp))))))
(car chan-list)
(cadr chan-list)
cur-maxamps
@@ -29308,20 +28732,20 @@ EDITS: 2
(scale-sound-by scaler 1000 1000 cursnd)
(for-each
(lambda (s c amp ed fr)
- (if (not (equal? s cursnd))
+ (if (equal? s cursnd)
(begin
- (if (not (= (edit-position s c) ed))
- (snd-display #__line__ ";scale-sound-by ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (if (not (or (= (edit-position s c) (+ 1 ed))
+ (= (edit-position s c) ed)))
+ (snd-display ";scale-sound-by ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";scale-sound-by ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
- (if (fneq (maxamp s c) amp)
- (snd-display #__line__ ";scale-sound-by ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))
+ (snd-display ";scale-sound-by ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr)))
(begin
- (if (and (not (= (edit-position s c) (+ 1 ed)))
- (not (= (edit-position s c) ed)))
- (snd-display #__line__ ";scale-sound-by ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (if (not (= (edit-position s c) ed))
+ (snd-display ";scale-sound-by ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";scale-sound-by ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr)))))
+ (snd-display ";scale-sound-by ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (if (fneq (maxamp s c) amp)
+ (snd-display ";scale-sound-by ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))))
(car chan-list)
(cadr chan-list)
cur-maxamps
@@ -29330,8 +28754,7 @@ EDITS: 2
((5) (let ((pos (edit-position cursnd curchn)))
(if (> pos 0)
- (let ((r (random pos)))
- (undo r cursnd curchn)))))
+ (undo (random pos) cursnd curchn))))
((6) (let ((len (framples cursnd curchn)))
(if (> len 10000)
@@ -29412,7 +28835,7 @@ EDITS: 2
(begin
(if (file-exists? "baddy.scm") (delete-file "baddy.scm"))
(save-state "baddy.scm")
- (snd-display #__line__ ";read env off by ~A: ~% (~A) at ~A: ~% ~A ~A (~A ~A) [~A ~A]:~% ~A"
+ (snd-display ";read env off by ~A: ~% (~A) at ~A: ~% ~A ~A (~A ~A) [~A ~A]:~% ~A"
(abs (- val0 val1))
e i val0 val1
reader0 reader1 e0 val00
@@ -29420,48 +28843,49 @@ EDITS: 2
(error 'mus-error))))))))
;; env-channel
- ((2) (let* ((pts (+ 1 (random 6)))
- (e (let ((e1 ())
- (x 0.0)
- (y 0.0))
- (do ((i 0 (+ i 1)))
- ((= i pts))
- (set! e1 (cons x e1))
- (if (> (random 3) 0)
- (set! y (mus-random 1.0)))
- (set! e1 (cons y e1))
- (set! x (+ x .01 (random 1.0))))
- (reverse e1))))
- (if (undo-env cursnd curchn)
- (begin
- (set! cur-maxamps (apply map maxamp chan-list))
- (set! cur-edits (apply map edit-position chan-list))
- (set! cur-framples (apply map framples chan-list))
- (set! cur-amp (maxamp cursnd curchn))
- (set! cur-edit (edit-position cursnd curchn))
- (set! cur-frame (framples cursnd curchn))))
- (env-channel e 0 (framples cursnd curchn) cursnd curchn) ; can be a no-op
- (if (and (not (= (edit-position cursnd curchn) (+ 1 cur-edit)))
- (not (= (edit-position cursnd curchn) cur-edit)))
- (snd-display #__line__ ";env-channel ~A[~A] edit pos: ~A ~A" (short-file-name cursnd) curchn (edit-position cursnd curchn) cur-edit))
- (if (not (= (framples cursnd curchn) cur-frame))
- (snd-display #__line__ ";env-channel ~A[~A] framples: ~A ~A" (short-file-name cursnd) curchn (framples cursnd curchn) cur-frame))
- (for-each
- (lambda (s c amp ed fr)
- (if (not (and (equal? s cursnd)
- (= c curchn)))
- (begin
- (if (not (= (edit-position s c) ed))
- (snd-display #__line__ ";env-channel ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
- (if (not (= (framples s c) fr))
- (snd-display #__line__ ";env-channel ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
- (if (fneq (maxamp s c) amp)
- (snd-display #__line__ ";env-channel ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))))
- (car chan-list)
- (cadr chan-list)
- cur-maxamps
- cur-edits
- cur-framples)))
+ ((2)
+ (let ((pts (+ 1 (random 6))))
+ (if (undo-env cursnd curchn)
+ (begin
+ (set! cur-maxamps (apply map maxamp chan-list))
+ (set! cur-edits (apply map edit-position chan-list))
+ (set! cur-framples (apply map framples chan-list))
+ (set! cur-amp (maxamp cursnd curchn))
+ (set! cur-edit (edit-position cursnd curchn))
+ (set! cur-frame (framples cursnd curchn))))
+ (let ((e (let ((e1 ())
+ (x 0.0)
+ (y 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i pts))
+ (set! e1 (cons x e1))
+ (if (> (random 3) 0)
+ (set! y (mus-random 1.0)))
+ (set! e1 (cons y e1))
+ (set! x (+ x .01 (random 1.0))))
+ (reverse e1))))
+ (env-channel e 0 (framples cursnd curchn) cursnd curchn))) ; can be a no-op
+ (if (not (or (= (edit-position cursnd curchn) (+ 1 cur-edit))
+ (= (edit-position cursnd curchn) cur-edit)))
+ (snd-display ";env-channel ~A[~A] edit pos: ~A ~A" (short-file-name cursnd) curchn (edit-position cursnd curchn) cur-edit))
+ (if (not (= (framples cursnd curchn) cur-frame))
+ (snd-display ";env-channel ~A[~A] framples: ~A ~A" (short-file-name cursnd) curchn (framples cursnd curchn) cur-frame))
+ (for-each
+ (lambda (s c amp ed fr)
+ (if (not (and (equal? s cursnd)
+ (= c curchn)))
+ (begin
+ (if (not (= (edit-position s c) ed))
+ (snd-display ";env-channel ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (if (not (= (framples s c) fr))
+ (snd-display ";env-channel ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (if (fneq (maxamp s c) amp)
+ (snd-display ";env-channel ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))))
+ (car chan-list)
+ (cadr chan-list)
+ cur-maxamps
+ cur-edits
+ cur-framples))
;; env-sound
((3) (let* ((pts (+ 1 (random 6)))
@@ -29481,10 +28905,9 @@ EDITS: 2
(beg (random (floor (/ end 2)))))
(for-each
(lambda (s c)
- (if (not (or (and (= (sync cursnd) 0)
- (or (not (equal? s cursnd))
- (not (= c curchn))))
- (not (= (sync s) (sync cursnd)))))
+ (if (and (or (not (= (sync cursnd) 0))
+ (and (equal? s cursnd) (= c curchn)))
+ (= (sync s) (sync cursnd)))
(let ((val (undo-env s c)))
(set! recalc (or recalc val)))))
(car chan-list)
@@ -29501,22 +28924,22 @@ EDITS: 2
(for-each
(lambda (s c amp ed fr)
(if (or (and (= (sync cursnd) 0)
- (or (not (equal? s cursnd))
- (not (= c curchn))))
+ (not (and (equal? s cursnd)
+ (= c curchn))))
(not (= (sync s) (sync cursnd))))
(begin
(if (not (= (edit-position s c) ed))
- (snd-display #__line__ ";env-sound ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (snd-display ";env-sound ~A[~A] wrong edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";env-sound ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
+ (snd-display ";env-sound ~A[~A] wrong framples: ~A ~A" (short-file-name s) c (framples s c) fr))
(if (fneq (maxamp s c) amp)
- (snd-display #__line__ ";env-sound ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))
+ (snd-display ";env-sound ~A[~A] wrong maxamp: ~A ~A" (short-file-name s) c (maxamp s c) amp)))
(begin
- (if (and (not (= (edit-position s c) (+ 1 ed)))
- (not (= (edit-position s c) ed)))
- (snd-display #__line__ ";env-sound ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
+ (if (not (or (= (edit-position s c) (+ 1 ed))
+ (= (edit-position s c) ed)))
+ (snd-display ";env-sound ~A[~A] edit pos: ~A ~A" (short-file-name s) c (edit-position s c) ed))
(if (not (= (framples s c) fr))
- (snd-display #__line__ ";env-sound ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr)))))
+ (snd-display ";env-sound ~A[~A] framples: ~A ~A" (short-file-name s) c (framples s c) fr)))))
(car chan-list)
(cadr chan-list)
cur-maxamps
@@ -29537,8 +28960,11 @@ EDITS: 2
(inc1 (/ len1 minlen))
(e0 (cadr env0))
(e1 (cadr env1)))
- (if (and (integer? inc0)
- (integer? inc1))
+ (if (not (and (integer? inc0)
+ (integer? inc1)))
+ (begin
+ (snd-display ";lens: ~A ~A" len0 len1)
+ #f)
(do ((i 0 (+ i 1)))
((or (not happy) (= i minlen1))
happy)
@@ -29549,22 +28975,17 @@ EDITS: 2
(do ((j 0 (+ j 1))
(j1 (* inc0 i) (+ j1 1)))
((= j inc0))
- (if (> (e0 j1) max0)
- (set! max0 (e0 j1)))))
+ (set! max0 (max max0 (e0 j1)))))
(if (= inc1 1)
(set! max1 (e1 i))
(do ((j 0 (+ j 1))
(j1 (* inc1 i) (+ j1 1)))
((= j inc1))
- (if (> (e1 j1) max1)
- (set! max1 (e1 j1)))))
+ (set! max1 (max max1 (e1 j1)))))
(if (> (abs (- max0 max1)) df)
(begin
- (snd-display #__line__ ";amp-env ~A: ~A ~A" i max0 max1)
- (set! happy #f)))))
- (begin
- (snd-display #__line__ ";lens: ~A ~A" len0 len1)
- #f))))))
+ (snd-display ";amp-env ~A: ~A ~A" i max0 max1)
+ (set! happy #f))))))))))
(define* (edit-difference s1 c1 e1 e2 (offset 0))
(let* ((N (framples s1 c1 e1))
@@ -29589,8 +29010,7 @@ EDITS: 2
(one-pole incr (float-vector-ref d1 i)))
(sqrt (one-pole incr 0.0))))
-
- (define (check-edit-tree expected-tree expected-vals name line)
+ (define (check-edit-tree-1 expected-tree expected-vals name line)
(define (vequal-at v0 v1)
(call-with-exit
(lambda (return)
@@ -29605,26 +29025,25 @@ EDITS: 2
(list pos tl0 #f))
(let ((t0 (car tl0))
(t1 (car tl1)))
- (if (or (not (= (car t0) (car t1)))
- (not (= (cadr t0) (cadr t1)))
- (not (= (caddr t0) (caddr t1)))
- (not (= (cadddr t0) (cadddr t1)))
- (> (abs (- (t0 4) (t1 4))) .0001)
- (> (abs (- (t0 5) (t1 5))) .0001) ; rmp0
- (> (abs (- (t0 6) (t1 6))) .0001)) ; rmp1
+ (if (not (and (= (car t0) (car t1))
+ (= (cadr t0) (cadr t1))
+ (= (caddr t0) (caddr t1))
+ (= (cadddr t0) (cadddr t1))
+ (<= (abs (- (t0 4) (t1 4))) 0.0001)
+ (<= (abs (- (t0 5) (t1 5))) 0.0001)
+ (<= (abs (- (t0 6) (t1 6))) 0.0001)))
(list pos t0 t1)
(edits-not-equal? (cdr tl0) (cdr tl1) (+ 1 pos))))))
(let* ((current-vals (channel->float-vector))
(len (length current-vals)))
(if (and expected-vals (not (= len (length expected-vals))))
- (snd-display #__line__ ";~A (from ~A): lengths differ: ~A ~A" name line len (length expected-vals))
+ (snd-display ";~A (from ~A): lengths differ: ~A ~A" name line len (length expected-vals))
(if (and expected-vals (not (vequal current-vals expected-vals)))
- (let ((bad-data (vequal-at current-vals expected-vals)))
- (snd-display #__line__ ";checking ~A (from ~A), vals disagree (loc cur expect): ~A" name line bad-data))
+ (snd-display ";checking ~A (from ~A), vals disagree (loc cur expect): ~A" name line (vequal-at current-vals expected-vals))
(let* ((tree (edit-tree))
(bad-data (edits-not-equal? tree expected-tree 0)))
(if bad-data
- (snd-display #__line__ ";checking ~A (from ~A), trees disagree (loc cur expect): ~A~% in~%~A" name line bad-data (edit-tree)))
+ (snd-display ";checking ~A (from ~A), trees disagree (loc cur expect): ~A~% in~%~A" name line bad-data (edit-tree)))
(if (> len 5)
(let* ((split-loc (+ 2 (random (- len 3))))
(fread (make-sampler split-loc))
@@ -29637,35 +29056,12 @@ EDITS: 2
((< i 0))
(float-vector-set! split-vals i (read-sample bread)))
(if (and expected-vals (not (vequal split-vals expected-vals)))
- (let ((bad-data (vequal-at split-vals expected-vals)))
- (snd-display #__line__ ";checking ~A (from ~A), split vals disagree (loc cur expect): ~A" name line bad-data)
- ; (error 'uhoh1)
- )))))))))
-
- (define (reversed-read snd chn)
- (let* ((len (framples snd chn))
- (data (make-float-vector len))
- (sf (make-sampler (- len 1) snd chn -1)))
- (do ((i (- len 1) (- i 1)))
- ((< i 0))
- (set! (data i) (read-sample sf)))
- data))
-
- (define (zigzag-read snd chn)
- (let* ((len (framples snd chn))
- (data (make-float-vector len))
- (sf (make-sampler 3 snd chn 1)))
- (do ((i 3 (+ i 1)))
- ((= i 6))
- (set! (data i) (next-sample sf)))
- (do ((i 6 (- i 1)))
- ((= i 0))
- (set! (data i) (previous-sample sf)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (set! (data i) (next-sample sf)))
- data))
+ (snd-display ";checking ~A (from ~A), split vals disagree (loc cur expect): ~A"
+ name line (vequal-at split-vals expected-vals))))))))))
+ (define-expansion (check-edit-tree tree vals name)
+ `(check-edit-tree-1 ,tree ,vals ,name ,(port-line-number)))
+
(define (zigzag-check name snd chn)
(let ((data (channel->float-vector))
(sf (make-sampler 3 snd chn)))
@@ -29673,12 +29069,12 @@ EDITS: 2
((= i 8))
(let ((val (next-sample sf)))
(if (fneq (data i) val)
- (snd-display #__line__ ";~A: forward data[~D]: ~A ~A" name i val (data i)))))
+ (snd-display ";~A: forward data[~D]: ~A ~A" name i val (data i)))))
(do ((i 7 (- i 1)))
((= i 0))
(let ((val (previous-sample sf)))
(if (fneq (data i) val)
- (snd-display #__line__ ";~A: backward data[~D]: ~A ~A" name i val (data i)))))))
+ (snd-display ";~A: backward data[~D]: ~A ~A" name i val (data i)))))))
(define (init-sound val dur chans)
(let ((ind (new-sound "test.snd" chans 22050 mus-ldouble mus-next)))
@@ -29689,26 +29085,32 @@ EDITS: 2
ind))
(define (check-back-and-forth ind name v)
+ (define (reversed-read snd chn)
+ (let* ((len (framples snd chn))
+ (data (make-float-vector len))
+ (sf (make-sampler (- len 1) snd chn -1)))
+ (do ((i (- len 1) (- i 1)))
+ ((< i 0))
+ (set! (data i) (read-sample sf)))
+ data))
+
(let ((happy #t))
(if (not (vequal v (channel->float-vector 0 (framples) ind 0)))
(begin
(set! happy #f)
- (snd-display #__line__ ";~A forth:~% current: ~A~% expected: ~A" name (channel->float-vector 0 (framples) ind 0) v)))
+ (snd-display ";~A forth:~% current: ~A~% expected: ~A" name (channel->float-vector 0 (framples) ind 0) v)))
(if (not (vequal v (reversed-read ind 0)))
(begin
(set! happy #f)
- (snd-display #__line__ ";~A back: ~A ~A" name (reversed-read ind 0) v)))
+ (snd-display ";~A back: ~A ~A" name (reversed-read ind 0) v)))
happy))
- (define (rampx-channel r0 r1)
- (xramp-channel r0 r1 3.0 0 (framples)))
-
(define (check-both-chans ind name f0 f1)
(let ((c0 (scan-channel f0 0 (framples) ind 0))
(c1 (scan-channel f1 0 (framples) ind 1)))
- (if c0 (snd-display #__line__ ";~A swap c0: ~A" name c0))
- (if c1 (snd-display #__line__ ";~A swap c1: ~A" name c1))))
+ (if c0 (snd-display ";~A swap c0: ~A" name c0))
+ (if c1 (snd-display ";~A swap c1: ~A" name c1))))
(define (convolve-coeffs v1 v2)
@@ -29734,7 +29136,7 @@ EDITS: 2
(lambda (func name)
(func)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";dur:0 ~A? ~A ~A" name (edit-position oboe) (edit-fragment))))
+ (snd-display ";dur:0 ~A? ~A ~A" name (edit-position oboe) (edit-fragment))))
(list
(lambda () (scale-channel 2.0 0 0 oboe))
(lambda () (env-channel (make-env '(0 0 1 1) :length 124) 0 0 oboe))
@@ -29763,9 +29165,9 @@ EDITS: 2
func
(lambda args (car args)))))
(if (not (eq? tag 'no-such-sample))
- (snd-display #__line__ ";~A beg -1->~A" name tag))
+ (snd-display ";~A beg -1->~A" name tag))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:-1 ~A? ~A ~A" name (edit-position oboe) (edit-fragment)))))
+ (snd-display ";beg:-1 ~A? ~A ~A" name (edit-position oboe) (edit-fragment)))))
(list
(lambda () (scale-channel 2.0 -1 123 oboe))
(lambda () (env-channel (make-env '(0 0 1 1) :length 124) -1 123 oboe))
@@ -29789,115 +29191,115 @@ EDITS: 2
(scale-channel 2.0 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:12345678 scale-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";beg:12345678 scale-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(env-channel (make-env '(0 0 1 1) :length 124) 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:12345678 env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";beg:12345678 env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(smooth-channel 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:12345678 smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";beg:12345678 smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(src-channel 2.0 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:12345678 src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";beg:12345678 src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(reverse-channel 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";beg:12345678 reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
- (play oboe :start 12345678 :end (+ 12345678 123))
+ (snd-display ";beg:12345678 reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (play oboe :start 12345678 :end 12345801) ;(+ 12345678 123)
(scale-channel 2.0 0 123 oboe 0)
(if (not (= (edit-position oboe) 1))
- (snd-display #__line__ ";oboe scale-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe scale-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(env-channel (make-env '(0 0 1 1) :length 124) 0 123 oboe 0)
(if (not (= (edit-position oboe) 2))
- (snd-display #__line__ ";oboe env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(clm-channel (make-oscil) 0 123 oboe 0)
(if (not (= (edit-position oboe) 3))
- (snd-display #__line__ ";oboe clm-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe clm-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(float-vector->channel (make-float-vector 3) 0 123 oboe 0)
(if (not (= (edit-position oboe) 4))
- (snd-display #__line__ ";oboe float-vector->channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe float-vector->channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(smooth-channel 0 123 oboe 0)
(if (not (= (edit-position oboe) 5))
- (snd-display #__line__ ";oboe smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(pad-channel 0 123 oboe 0)
(if (not (= (edit-position oboe) 6))
- (snd-display #__line__ ";oboe pad-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe pad-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(src-channel 2.0 0 123 oboe 0)
(if (not (= (edit-position oboe) 7))
- (snd-display #__line__ ";oboe src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(mix-channel "pistol.snd" 0 123 oboe 0)
(if (not (= (edit-position oboe) 8))
- (snd-display #__line__ ";oboe mix-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe mix-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(insert-channel "pistol.snd" 0 123 oboe 0)
(if (not (= (edit-position oboe) 9))
- (snd-display #__line__ ";oboe insert-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe insert-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(reverse-channel 0 123 oboe 0)
(if (not (= (edit-position oboe) 10))
- (snd-display #__line__ ";oboe reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";oboe reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(let* ((rd (make-sampler 0))
(sr (make-src :srate 2.0 :input (lambda (dir) (read-sample rd)))))
(clm-channel sr 0 12345 oboe 0)
(if (not (= (edit-position oboe) 11))
- (snd-display #__line__ ";oboe clm-channel src? ~A ~A" (edit-position oboe) (edit-fragment))))
+ (snd-display ";oboe clm-channel src? ~A ~A" (edit-position oboe) (edit-fragment))))
(let* ((rd (make-sampler 0))
(sr (make-granulate :expansion 2.0 :input (lambda (dir) (read-sample rd)))))
(clm-channel sr 0 12345 oboe 0)
(if (not (= (edit-position oboe) 12))
- (snd-display #__line__ ";oboe clm-channel granulate? ~A ~A" (edit-position oboe) (edit-fragment))))
+ (snd-display ";oboe clm-channel granulate? ~A ~A" (edit-position oboe) (edit-fragment))))
(let* ((rd (make-sampler 0))
(flt (float-vector 1.0 0.0 0.0 0.0))
(sr (make-convolve :input (lambda (dir) (read-sample rd)) :filter flt)))
(clm-channel sr 0 12345 oboe 0)
(if (not (= (edit-position oboe) 13))
- (snd-display #__line__ ";oboe clm-channel convolve? ~A ~A" (edit-position oboe) (edit-fragment))))
+ (snd-display ";oboe clm-channel convolve? ~A ~A" (edit-position oboe) (edit-fragment))))
(let* ((rd (make-sampler 0))
(sr (make-phase-vocoder :input (lambda (dir) (read-sample rd)))))
(clm-channel sr 0 12345 oboe 0)
(if (not (= (edit-position oboe) 14))
- (snd-display #__line__ ";oboe clm-channel phase-vocoder? ~A ~A" (edit-position oboe) (edit-fragment))))
+ (snd-display ";oboe clm-channel phase-vocoder? ~A ~A" (edit-position oboe) (edit-fragment))))
(revert-sound)
(catch #t (lambda () (env-channel (make-env '(0 0 1 1) :length 124) 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 env-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (clm-channel (make-oscil) 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 clm-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 clm-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (float-vector->channel (make-float-vector 3) 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 float-vector->channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 float-vector->channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (smooth-channel 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 smooth-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (pad-channel 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 pad-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 pad-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (src-channel 2.0 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 src-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (mix-channel "pistol.snd" 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 mix-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 mix-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (insert-channel "pistol.snd" 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 insert-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 insert-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(catch #t (lambda () (reverse-channel 0 123 oboe 0 123)) (lambda args (car args)))
(if (not (= (edit-position oboe) 0))
- (snd-display #__line__ ";edpos 123 reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
+ (snd-display ";edpos 123 reverse-channel? ~A ~A" (edit-position oboe) (edit-fragment)))
(revert-sound oboe)
(let ((oldv (channel->float-vector 1000 10 oboe)))
(mix-channel "oboe.snd" 0)
(float-vector-scale! oldv 2.0)
(if (not (vequal oldv (channel->float-vector 1000 10 oboe)))
- (snd-display #__line__ ";mix-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
+ (snd-display ";mix-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
(revert-sound oboe)
(float-vector-scale! oldv 0.5)
(insert-channel "oboe.snd" 0)
(if (not (vequal oldv (channel->float-vector 1000 10 oboe)))
- (snd-display #__line__ ";insert-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
+ (snd-display ";insert-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
(if (not (= (framples oboe 0) (* 2 (framples oboe 0 0))))
- (snd-display #__line__ ";insert-channel framples: ~A ~A" (framples oboe 0) (framples oboe 0 0)))
+ (snd-display ";insert-channel framples: ~A ~A" (framples oboe 0) (framples oboe 0 0)))
(revert-sound oboe))
(close-sound oboe)
@@ -29908,93 +29310,92 @@ EDITS: 2
(revert-sound ind)
(let ((val (mix-channel "fmv.snd")))
(if (mix? val)
- (snd-display #__line__ ";mix-channel returned a mix: ~A?" val)))
+ (snd-display ";mix-channel returned a mix: ~A?" val)))
(if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";mix-channel mixed channel 1: ~A?" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel mixed channel 1: ~A?" (channel->float-vector 0 #f ind 1)))
(if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel chan 0: ~A" (channel->float-vector 0 #f ind 0)))
+ (snd-display ";mix-channel chan 0: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (mix-channel (list "fmv.snd" 2 1) 0 #f ind 0)))
(if (mix? val)
- (snd-display #__line__ ";mix-channel 2 returned a mix: ~A?" val)))
+ (snd-display ";mix-channel 2 returned a mix: ~A?" val)))
(if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";mix-channel mixed channel 1a: ~A?" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel mixed channel 1a: ~A?" (channel->float-vector 0 #f ind 1)))
(if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel chan 0a: ~A" (channel->float-vector 0 #f ind 0)))
+ (snd-display ";mix-channel chan 0a: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(set! (sample 2 ind 1) -.4)
(let ((val (mix-channel (list ind 2 1) 0 #f ind 0 -1 #t)))
(if (not (mix? val))
- (snd-display #__line__ ";mix-channel with-tag: ~A" val)))
+ (snd-display ";mix-channel with-tag: ~A" val)))
(if (not (vequal (channel->float-vector 0 #f ind 1) (float-vector 0 0 -.4 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel mixed channel 1b: ~A?" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel mixed channel 1b: ~A?" (channel->float-vector 0 #f ind 1)))
(if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel chan 0b: ~A" (channel->float-vector 0 #f ind 0)))
+ (snd-display ";mix-channel chan 0b: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (car (mix-channel (list "fmv.snd" 2 1) 0 #f ind 0 -1 #t))))
(if (not (mix? val))
- (snd-display #__line__ ";mix-channel file with-tag: ~A" val)))
+ (snd-display ";mix-channel file with-tag: ~A" val)))
(if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";mix-channel mixed channel 1c: ~A?" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel mixed channel 1c: ~A?" (channel->float-vector 0 #f ind 1)))
(if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel chan 0c: ~A" (channel->float-vector 0 #f ind 0)))
+ (snd-display ";mix-channel chan 0c: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (car (mix-channel (list "fmv.snd") 0 #f ind 1 -1 #t))))
(if (not (mix? val))
- (snd-display #__line__ ";mix-channel file 1 with-tag: ~A" val)))
+ (snd-display ";mix-channel file 1 with-tag: ~A" val)))
(if (not (vequal (channel->float-vector 0 #f ind 0) (make-float-vector 10 0.0)))
- (snd-display #__line__ ";mix-channel mixed channel 0d: ~A?" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel mixed channel 0d: ~A?" (channel->float-vector 0 #f ind 1)))
(if (not (vequal (channel->float-vector 0 #f ind 1) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
- (snd-display #__line__ ";mix-channel chan 1d: ~A" (channel->float-vector 0 #f ind 1)))
+ (snd-display ";mix-channel chan 1d: ~A" (channel->float-vector 0 #f ind 1)))
(revert-sound ind)
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
(close-sound ind))
(if (not (= *default-output-chans* 1)) (set! *default-output-chans* 1))
- (let ((ind (new-sound "fmv.snd"))
- (v0 (make-float-vector 20 1.0)))
- (float-vector->channel v0)
- (if (not (= (framples) 20)) (snd-display #__line__ ";float-vector->channel new 20: ~A" (framples)))
- (if (fneq (maxamp) 1.0) (snd-display #__line__ ";float-vector 1->new: ~A" (maxamp)))
+ (let ((ind (new-sound "fmv.snd")))
+ (float-vector->channel (make-float-vector 20 1.0))
+ (if (not (= (framples) 20)) (snd-display ";float-vector->channel new 20: ~A" (framples)))
+ (if (fneq (maxamp) 1.0) (snd-display ";float-vector 1->new: ~A" (maxamp)))
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 20))
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";env-channel step 1: ~A" v1)))
+ (snd-display ";env-channel step 1: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 20) 8)
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1)))
- (snd-display #__line__ ";env-channel step 1 at 8: ~A" v1)))
+ (snd-display ";env-channel step 1 at 8: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12))
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";env-channel step 1 at 0: ~A" v1)))
+ (snd-display ";env-channel step 1 at 0: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12) 4)
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";env-channel step 1 at 4: ~A" v1)))
+ (snd-display ";env-channel step 1 at 4: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12) 4 3)
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";env-channel step 1 at 4 by 3: ~A" v1)))
+ (snd-display ";env-channel step 1 at 4 by 3: ~A" v1)))
(undo)
(env-channel (make-env '(0 1 1 0 2 0) :base 0 :length 8) 0 12)
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";env-channel step 1 at 0 for 7: ~A" v1)))
+ (snd-display ";env-channel step 1 at 0 for 7: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1 3 0 4 0) :base 0 :length 20))
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0)))
- (snd-display #__line__ ";env-channel step 1: ~A" v1)))
+ (snd-display ";env-channel step 1: ~A" v1)))
(env-channel (make-env '(0 0 1 .5 2 .25 3 0 4 0) :base 0 :length 21))
(let ((v1 (channel->float-vector)))
(if (not (vequal v1 (float-vector 0 0 0 0 0 0 .5 .5 .5 .5 .5 .25 .25 .25 .25 0 0 0 0 0)))
- (snd-display #__line__ ";env-channel step 1 (.5): ~A" v1)))
+ (snd-display ";env-channel step 1 (.5): ~A" v1)))
(close-sound ind))
(set! *x-axis-style* x-axis-as-percentage)
@@ -30005,17 +29406,17 @@ EDITS: 2
(set! (sync ind) 64)
(insert-sound "2.snd")
(insert-sound "2.snd")
- (if (not (= (framples) (* 3 fr))) (snd-display #__line__ ";2.snd 3x = ~A ~A" fr (framples)))
- (if (not (= (framples ind 0) (framples ind 1))) (snd-display #__line__ ";insert sync'd: ~A ~A" (framples ind 0) (framples ind 1)))
+ (if (not (= (framples) (* 3 fr))) (snd-display ";2.snd 3x = ~A ~A" fr (framples)))
+ (if (not (= (framples ind 0) (framples ind 1))) (snd-display ";insert sync'd: ~A ~A" (framples ind 0) (framples ind 1)))
(swap-channels)
(if (or (fneq m0 (maxamp ind 1)) (fneq m1 (maxamp ind 0)))
- (snd-display #__line__ ";swapped: ~A ~A -> ~A ~A" m0 m1 (maxamp ind 0) (maxamp ind 1)))
+ (snd-display ";swapped: ~A ~A -> ~A ~A" m0 m1 (maxamp ind 0) (maxamp ind 1)))
(close-sound ind))
(set! *x-axis-style* x-axis-in-seconds)
(let ((new-snd (mono-files->stereo "test.snd" "oboe.snd" "pistol.snd")))
- (if (not (= (channels new-snd) 2)) (snd-display #__line__ ";mono-files->stereo not stereo? ~A" (channels new-snd)))
- (if (not (string=? (short-file-name new-snd) "test.snd")) (snd-display #__line__ ";mono-files->stereo filename: ~A" (short-file-name new-snd)))
- (if (not (= (framples new-snd) 50828)) (snd-display #__line__ ";mono-files->stereo framples: ~A" (framples new-snd)))
+ (if (not (= (channels new-snd) 2)) (snd-display ";mono-files->stereo not stereo? ~A" (channels new-snd)))
+ (if (not (string=? (short-file-name new-snd) "test.snd")) (snd-display ";mono-files->stereo filename: ~A" (short-file-name new-snd)))
+ (if (not (= (framples new-snd) 50828)) (snd-display ";mono-files->stereo framples: ~A" (framples new-snd)))
(close-sound new-snd))
(let ((oboe0 (open-sound "oboe.snd"))
@@ -30025,7 +29426,7 @@ EDITS: 2
(func0 #f #f oboe0)
(func1 #f #f oboe1)
(if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
- (snd-display #__line__ ";~A via #f: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (snd-display ";~A via #f: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1)
(select-sound oboe0)
@@ -30033,50 +29434,50 @@ EDITS: 2
(select-sound oboe1)
(func1)
(if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
- (snd-display #__line__ ";~A via none: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (snd-display ";~A via none: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1)
(func0 0 (framples oboe0) oboe0)
(func1 0 (framples oboe1) oboe1)
(if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
- (snd-display #__line__ ";~A via framples: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (snd-display ";~A via framples: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1))
(funcs-equal? "scale-sound-by"
- (lambda args (apply scale-sound-by (cons 2.0 args)))
- (lambda args (apply scale-channel (cons 2.0 args))))
+ (lambda args (apply scale-sound-by 2.0 args))
+ (lambda args (apply scale-channel 2.0 args)))
(funcs-equal? "scale-and-ramp"
- (lambda args (apply scale-sound-by (cons 0.0 args)))
- (lambda args (apply ramp-channel (cons 0.0 (cons 0.0 args)))))
+ (lambda args (apply scale-sound-by 0.0 args))
+ (lambda args (apply ramp-channel 0.0 0.0 args)))
(funcs-equal? "scale-and-ramp"
- (lambda args (apply scale-sound-by (cons 2.0 args)))
- (lambda args (apply ramp-channel (cons 2.0 (cons 2.0 args)))))
+ (lambda args (apply scale-sound-by 2.0 args))
+ (lambda args (apply ramp-channel 2.0 2.0 args)))
(funcs-equal? "smooth-sound"
smooth-sound
smooth-channel)
(funcs-equal? "env-sound"
- (lambda args (apply env-sound (list (list 0 0 1 1)
- (if (> (length args) 0) (car args) 0)
- (and (> (length args) 1)
- (number? (cadr args))
- (- (cadr args) 1))
- 1.0
- (if (> (length args) 2)
- (caddr args)
- (selected-sound)))))
+ (lambda args (env-sound (list 0 0 1 1)
+ (if (> (length args) 0) (car args) 0)
+ (and (> (length args) 1)
+ (number? (cadr args))
+ (- (cadr args) 1))
+ 1.0
+ (if (> (length args) 2)
+ (caddr args)
+ (selected-sound))))
(lambda args (apply env-channel
- (cons (make-env :envelope (list 0 0 1 1)
- :length (if (and (> (length args) 1)
- (number? (cadr args)))
- (cadr args)
- (framples (if (> (length args) 2)
- (caddr args)
- (selected-sound)))))
- args))))
+ (make-env :envelope (list 0 0 1 1)
+ :length (if (and (> (length args) 1)
+ (number? (cadr args)))
+ (cadr args)
+ (framples (if (> (length args) 2)
+ (caddr args)
+ (selected-sound)))))
+ args)))
(funcs-equal? "src-sound"
(lambda args (src-sound 2.0 1.0 (and (> (length args) 2) (caddr args))))
- (lambda args (apply src-channel (cons 2.0 args))))
+ (lambda args (apply src-channel 2.0 args)))
(funcs-equal? "reverse-sound"
(lambda args (reverse-sound (and (> (length args) 2) (caddr args))))
reverse-channel)
@@ -30097,7 +29498,7 @@ EDITS: 2
(save-sound ind1)
(close-sound ind1)
(insert-sound "test.snd" 12345)
- (let ((vals (channel->float-vector (- 12345 50) 200 ind 0)))
+ (let ((vals (channel->float-vector 12295 200 ind 0)))
(if (file-exists? "hiho.scm") (delete-file "hiho.scm"))
(save-state "hiho.scm")
(close-sound ind)
@@ -30105,10 +29506,10 @@ EDITS: 2
(load (string-append cwd "hiho.scm"))
(set! ind (find-sound "oboe.snd"))
(if (not (sound? ind))
- (snd-display #__line__ ";save hiho failed?")
- (let ((new-vals (channel->float-vector (- 12345 50) 200 ind 0)))
+ (snd-display ";save hiho failed?")
+ (let ((new-vals (channel->float-vector 12295 200 ind 0)))
(if (not (vequal vals new-vals))
- (snd-display #__line__ ";save state hiho vals: ~A ~A" vals new-vals))))
+ (snd-display ";save state hiho vals: ~A ~A" vals new-vals))))
(close-sound ind))
(set! *save-dir* old-save-dir))
@@ -30125,7 +29526,7 @@ EDITS: 2
(reverse-channel 500000 1000000)
(set! (sample 0 ind 0 current-edit-position) .1)
(if (fneq (sample 0 ind 0 current-edit-position) .1)
- (snd-display #__line__ ";set sample + edpos: ~A" (sample 0 ind 0 current-edit-position)))
+ (snd-display ";set sample + edpos: ~A" (sample 0 ind 0 current-edit-position)))
(close-sound ind))
(set! *x-axis-style* x-axis-in-seconds)
@@ -30150,10 +29551,10 @@ EDITS: 2
(lambda (posfunc)
(let ((chn (min (random (+ 1 out-chans)) (- out-chans 1))))
(if (not (vequal (channel->float-vector 0 (framples ind chn) ind chn 0) (float-vector 0.0)))
- (snd-display #__line__ ";start bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn 0)))
+ (snd-display ";start bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn 0)))
(set! (sample 0 ind chn) .1)
(if (not (vequal (channel->float-vector 0 (framples ind chn) ind chn) (float-vector 0.1)))
- (snd-display #__line__ ";set bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn)))
+ (snd-display ";set bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn)))
(pad-channel 0 1 ind chn (posfunc))
(let ((pos (posfunc)))
(if (procedure? pos)
@@ -30166,7 +29567,7 @@ EDITS: 2
(not (vequal data (float-vector 0.0 0.1))))
(and (= pos (- (edit-position ind chn) 1))
(not (vequal data (float-vector 0.0 0.0)))))
- (snd-display #__line__ ";pos[~A]: edpos ~A of ~A, pad result[~A, ~A]: ~A"
+ (snd-display ";pos[~A]: edpos ~A of ~A, pad result[~A, ~A]: ~A"
chn pos (edit-position ind chn) (framples ind chn pos) (framples ind chn) data))
(if (> (chans ind) 1)
(do ((i 0 (+ i 1)))
@@ -30174,7 +29575,7 @@ EDITS: 2
(if (not (= i chn))
(let ((data (channel->float-vector 0 (framples ind i) ind i)))
(if (not (vequal data (float-vector 0.0)))
- (snd-display #__line__ ";pad[~A / ~A] empty: ~A" i chn data))))))))))
+ (snd-display ";pad[~A / ~A] empty: ~A" i chn data))))))))))
(lambda (posfunc)
(let ((chn (min (random (+ 1 out-chans)) (- out-chans 1))))
(set! (sample 0 ind chn) .1)
@@ -30189,7 +29590,7 @@ EDITS: 2
(not (vequal data (float-vector 0.2))))
(and (= pos (- (edit-position ind chn) 1))
(not (vequal data (float-vector 0.0)))))
- (snd-display #__line__ ";pos[~A]: edpos ~A of ~A, set *2 result[~A, ~A]: ~A"
+ (snd-display ";pos[~A]: edpos ~A of ~A, set *2 result[~A, ~A]: ~A"
chn pos (edit-position ind chn) (framples ind chn pos) (framples ind chn) data))
(if (> (chans ind) 1)
(do ((i 0 (+ i 1)))
@@ -30197,37 +29598,35 @@ EDITS: 2
(if (not (= i chn))
(let ((data (channel->float-vector 0 (framples ind i) ind i)))
(if (not (vequal data (float-vector 0.0)))
- (snd-display #__line__ ";scale[~A / ~A] empty: ~A" i chn data)))))))))))))
+ (snd-display ";scale[~A / ~A] empty: ~A" i chn data)))))))))))))
(list "2a.snd" "1a.snd" "4a.snd"))
(close-sound ind)))
(list 1 2 4))
(let ((ind (open-sound "oboe.snd")))
(map-channel (lambda (y) #f))
- (if (not (= (framples ind) 0)) (snd-display #__line__ ";map-channel #f framples: ~A" (framples ind)))
- (if (equal? (edits ind) (list 0 0)) (snd-display #__line__ ";map-channel #f edits backed up"))
+ (if (not (= (framples ind) 0)) (snd-display ";map-channel #f framples: ~A" (framples ind)))
+ (if (equal? (edits ind) (list 0 0)) (snd-display ";map-channel #f edits backed up"))
(undo 1 ind)
- (if (= (framples ind) 0) (snd-display #__line__ ";map-channel #f framples after undo: ~A" (framples ind)))
+ (if (= (framples ind) 0) (snd-display ";map-channel #f framples after undo: ~A" (framples ind)))
(let ((tag (catch #t (lambda () (map-channel (lambda (y) "hiho"))) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";map-channel bad-type: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";map-channel bad-type: ~A" tag)))
(let* ((ctr 0)
(tag (catch #t (lambda () (scan-channel (lambda (y) (set! ctr (+ ctr 1)) (asdf)))) (lambda args (car args)))))
- (if (not (= ctr 1)) (snd-display #__line__ ";scan-channel error exit: ~A" ctr))
- (if (and (not (eq? tag 'unbound-variable))
- (not (eq? tag 'syntax-error))
- (not (eq? tag 'error)))
- (snd-display #__line__ ";scan-channel unbound: ~A" tag)))
- (let ((val (scan-channel (lambda (y) #f)))) (if val (snd-display #__line__ ";scan-channel func #f: ~A" val)))
- (let ((val (scan-channel (lambda (y) #f) 1234))) (if val (snd-display #__line__ ";scan-channel func #f with beg: ~A" val)))
- (let ((val (scan-channel (lambda (y) #f) 1234 4321))) (if val (snd-display #__line__ ";scan-channel func #f with beg+dur: ~A" val)))
+ (if (not (= ctr 1)) (snd-display ";scan-channel error exit: ~A" ctr))
+ (if (not (memq tag '(unbound-variable syntax-error error)))
+ (snd-display ";scan-channel unbound: ~A" tag)))
+ (let ((val (scan-channel (lambda (y) #f)))) (if val (snd-display ";scan-channel func #f: ~A" val)))
+ (let ((val (scan-channel (lambda (y) #f) 1234))) (if val (snd-display ";scan-channel func #f with beg: ~A" val)))
+ (let ((val (scan-channel (lambda (y) #f) 1234 4321))) (if val (snd-display ";scan-channel func #f with beg+dur: ~A" val)))
(revert-sound ind)
- (let ((del (make-delay 1000))
- (len (framples)))
- (clm-channel del 0 (framples) ind 0 0 2000)
+ (let ((del (make-delay 1000)))
+ (clm-channel del 0 (framples) ind 0 0 2000))
+ (let ((len (framples)))
(if (not (= (framples ind) (+ 2000 len)))
- (snd-display #__line__ ";clm-channel overlap length: ~A ~A" len (framples)))
+ (snd-display ";clm-channel overlap length: ~A ~A" len (framples)))
(if (not (equal? (edit-tree) '((0 1 0 52827 1.0 0.0 0.0 0) (52828 -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";clm-channel overlaps: ~A" (edit-tree)))
+ (snd-display ";clm-channel overlaps: ~A" (edit-tree)))
(let ((reader (make-sampler 0))
(preader (make-sampler 0 ind 0 1 0))
(happy #t))
@@ -30236,7 +29635,7 @@ EDITS: 2
(let ((val (reader)))
(if (fneq val 0.0)
(begin
- (snd-display #__line__ ";clm-channel overlap delayed: ~A: ~A" i val)
+ (snd-display ";clm-channel overlap delayed: ~A: ~A" i val)
(set! happy #f)))))
(let ((v0 (make-float-vector len))
(v1 (make-float-vector len)))
@@ -30247,12 +29646,12 @@ EDITS: 2
((= i len))
(float-vector-set! v1 i (read-sample reader)))
(if (not (vequal v0 v1))
- (snd-display #__line__ ";clm-channel overlap main: ~A ~A" v0 v1)))
+ (snd-display ";clm-channel overlap main: ~A ~A" v0 v1)))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1000)))
(if (fneq (reader) 0.0)
(begin
- (snd-display #__line__ ";clm-channel overlap trailing garbage")
+ (snd-display ";clm-channel overlap trailing garbage")
(set! happy #f))))))
(close-sound ind))
@@ -30283,7 +29682,7 @@ EDITS: 2
;; can't use maxamp here because it may be set by scaling process
(if (or (fneq oldamp (* .1 amp))
(not (= loc oldloc)))
- (snd-display #__line__ ";reverse edpos screwup: ~A at ~A, ~A at ~A" oldamp oldloc amp loc)))
+ (snd-display ";reverse edpos screwup: ~A at ~A, ~A at ~A" oldamp oldloc amp loc)))
(undo)
(reverse-channel 0 #f ind 0 2)
(let ((amp 0.0)
@@ -30299,7 +29698,7 @@ EDITS: 2
;; can't use maxamp here because it may be set by scaling process
(if (or (fneq oldamp amp)
(not (= loc oldloc)))
- (snd-display #__line__ ";reverse unscaled edpos screwup: ~A at ~A, ~A at ~A" oldamp oldloc amp loc)))
+ (snd-display ";reverse unscaled edpos screwup: ~A at ~A, ~A at ~A" oldamp oldloc amp loc)))
(close-sound ind))
@@ -30309,16 +29708,16 @@ EDITS: 2
(vals (make-float-vector 100)))
(select-sound ind)
(select-channel 0)
- (check-edit-tree '((0 0 0 0 0.0 0.0 0.0 1) (1 -2 0 0 0.0 0.0 0.0 0)) (make-float-vector 1) "initial new-sound" #__line__)
+ (check-edit-tree '((0 0 0 0 0.0 0.0 0.0 1) (1 -2 0 0 0.0 0.0 0.0 0)) (make-float-vector 1) "initial new-sound")
(fill! vals 1.0)
(set! (samples 0 100) vals)
- (check-edit-tree '((0 1 0 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0)) vals "set first samps to one" #__line__)
+ (check-edit-tree '((0 1 0 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0)) vals "set first samps to one")
(scale-channel 0.5 10 20)
(do ((i 10 (+ i 1)))
((= i 30))
(set! (vals i) 0.5))
(check-edit-tree '((0 1 0 9 1.0 0.0 0.0 0) (10 1 10 29 0.5 0.0 0.0 0) (30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "scale-channel 0.5 10 20" #__line__)
+ vals "scale-channel 0.5 10 20")
(env-channel (make-env '(0 0 1 1) :length 11) 15 10)
(let ((e (make-env '(0 0 1 1) :length 11)))
(do ((i 15 (+ i 1)))
@@ -30326,18 +29725,18 @@ EDITS: 2
(set! (vals i) (* (vals i) (env e)))))
(check-edit-tree '((0 1 0 9 1.0 0.0 0.0 0) (10 1 10 14 0.5 0.0 0.0 0) (15 1 15 24 0.5 0.0 0.1 1)
(25 1 25 29 0.5 0.0 0.0 0) (30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env-channel 15 10" #__line__)
+ vals "env-channel 15 10")
(normalize-channel 1.0)
(check-edit-tree '((0 1 0 9 1.0 0.0 0.0 0) (10 1 10 14 0.5 0.0 0.0 0) (15 1 15 24 0.5 0.0 0.1 1)
(25 1 25 29 0.5 0.0 0.0 0) (30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env-channel 15 10 a" #__line__)
+ vals "env-channel 15 10 a")
(select-all)
(if (fneq (selection-maxamp) 1.0)
- (snd-display #__line__ ";selection-maxamp in checker: ~A" (selection-maxamp)))
+ (snd-display ";selection-maxamp in checker: ~A" (selection-maxamp)))
(scale-selection-to 1.0)
(check-edit-tree '((0 1 0 9 1.0 0.0 0.0 0) (10 1 10 14 0.5 0.0 0.0 0) (15 1 15 24 0.5 0.0 0.1 1)
(25 1 25 29 0.5 0.0 0.0 0) (30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env-channel 15 10 b" #__line__)
+ vals "env-channel 15 10 b")
(set! (selection-position) 5)
(set! (selection-framples) 10)
(scale-selection-to .5)
@@ -30346,14 +29745,14 @@ EDITS: 2
(set! (vals i) (* (vals i) 0.5)))
(check-edit-tree '((0 1 0 4 1.0 0.0 0.0 0) (5 1 5 9 0.5 0.0 0.0 0) (10 1 10 14 0.25 0.0 0.0 0) (15 1 15 24 0.5 0.0 0.1 1)
(25 1 25 29 0.5 0.0 0.0 0) (30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "scale-selection-to .5" #__line__)
+ vals "scale-selection-to .5")
(set! (sample 20) .1)
(set! (vals 20) .1)
(check-edit-tree '((0 1 0 4 1.0 0.0 0.0 0) (5 1 5 9 0.5 0.0 0.0 0) (10 1 10 14 0.25 0.0 0.0 0)
(15 1 15 19 0.5 0.0 0.1 1) (20 2 0 0 1.0 0.0 0.0 0)
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 29 0.5 0.0 0.0 0)
(30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "set 20 .1" #__line__)
+ vals "set 20 .1")
(reverse-channel 5 10)
(do ((i 5 (+ i 1))
(j 14 (- j 1)))
@@ -30365,8 +29764,8 @@ EDITS: 2
(15 1 15 19 0.5 0.0 0.1 1) (20 2 0 0 1.0 0.0 0.0 0)
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 29 0.5 0.0 0.0 0)
(30 1 30 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "reverse-channel 5 10" #__line__)
- (if (fneq (selection-maxamp) .5) (snd-display #__line__ ";selection-maxamp before: ~A" (selection-maxamp)))
+ vals "reverse-channel 5 10")
+ (if (fneq (selection-maxamp) .5) (snd-display ";selection-maxamp before: ~A" (selection-maxamp)))
(let ((mixvals (make-float-vector 10))
(old-sample4 (sample 4))
(old-sample5 (sample 5)))
@@ -30384,7 +29783,7 @@ EDITS: 2
id ind
old-sample4 old-sample5
(sample 4) (sample 5)
- (vals 4) (vals 5)) #__line__)))
+ (vals 4) (vals 5)))))
; (list global-position data-number local-position local-end scaler ramp0 ramp1 type)
@@ -30399,12 +29798,12 @@ EDITS: 2
(20 2 0 0 1.0 0.0 0.0 0) (21 1 21 24 0.5 0.6 0.1 4)
(25 1 25 27 0.5 0.0 0.0 0) (28 -1 0 11 0.0 0.0 0.0 2)
(40 1 40 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "delete/insert" #__line__)
- (if (fneq (selection-maxamp) .6) (snd-display #__line__ ";selection-maxamp after: ~A" (selection-maxamp)))
+ vals "delete/insert")
+ (if (fneq (selection-maxamp) .6) (snd-display ";selection-maxamp after: ~A" (selection-maxamp)))
(set! (selection-position) 50)
(set! (selection-framples) 10)
(scale-selection-by .1)
- (if (fneq (selection-maxamp) .1) (snd-display #__line__ ";re-selection-maxamp: ~A" (selection-maxamp)))
+ (if (fneq (selection-maxamp) .1) (snd-display ";re-selection-maxamp: ~A" (selection-maxamp)))
(do ((i 50 (+ i 1)))
((= i 60))
(set! (vals i) .1))
@@ -30412,7 +29811,7 @@ EDITS: 2
(15 1 15 19 0.5 0.0 0.1 4) (20 2 0 0 1.0 0.0 0.0 0)
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 27 0.5 0.0 0.0 0) (28 -1 0 11 0.0 0.0 0.0 2)
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.100000001490116 0.0 0.0 0) (60 1 60 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "scale-selection-by .1" #__line__)
+ vals "scale-selection-by .1")
(env-channel (make-env '(0 0 1 1 2 0 3 0) :length 31 :base 0) 50 30)
(let ((e (make-env '(0 0 1 1 2 0 3 0) :length 31 :base 0)))
(do ((i 50 (+ i 1)))
@@ -30423,20 +29822,20 @@ EDITS: 2
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 27 0.5 0.0 0.0 0) (28 -1 0 11 0.0 0.0 0.0 2)
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.0 0.0 0.0 2) (60 1 60 60 0.0 0.0 0.0 2)
(61 1 61 70 1.0 0.0 0.0 0) (71 1 71 79 0.0 0.0 0.0 2) (80 1 80 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "step env 30" #__line__)
+ vals "step env 30")
(undo-channel 2)
(check-edit-tree '((0 1 0 3 1.0 0.0 0.0 0) (4 1 4 4 1.0 0.0 0.0 1) (5 3 0 8 1.0 0.0 0.0 1)
(14 3 9 9 1.0 0.0 0.0 0) (15 1 15 19 0.5 0.0 0.1 4)
(20 2 0 0 1.0 0.0 0.0 0) (21 1 21 24 0.5 0.6 0.1 4) (25 1 25 27 0.5 0.0 0.0 0)
(28 -1 0 11 0.0 0.0 0.0 2) (40 1 40 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- old-vals "undo to delete/insert (over step env)" #__line__))
+ old-vals "undo to delete/insert (over step env)"))
(redo-channel 2)
(check-edit-tree '((0 1 0 3 1.0 0.0 0.0 0) (4 1 4 4 1.0 0.0 0.0 1) (5 3 0 8 1.0 0.0 0.0 1) (14 3 9 9 1.0 0.0 0.0 0)
(15 1 15 19 0.5 0.0 0.1 4) (20 2 0 0 1.0 0.0 0.0 0)
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 27 0.5 0.0 0.0 0) (28 -1 0 11 0.0 0.0 0.0 2)
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.0 0.0 0.0 2) (60 1 60 60 0.0 0.0 0.0 2)
(61 1 61 70 1.0 0.0 0.0 0) (71 1 71 79 0.0 0.0 0.0 2) (80 1 80 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "redo past step env 30" #__line__)
+ vals "redo past step env 30")
(set! (sample 75) -.5)
(set! (vals 75) -.5)
(let ((flt (make-one-zero 0.5 0.5))
@@ -30450,7 +29849,7 @@ EDITS: 2
(21 1 21 24 0.5 0.6 0.1 4) (25 1 25 27 0.5 0.0 0.0 0) (28 -1 0 11 0.0 0.0 0.0 2)
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.0 0.0 0.0 2) (60 1 60 60 0.0 0.0 0.0 2)
(61 1 61 70 1.0 0.0 0.0 0) (71 1 71 74 0.0 0.0 0.0 2) (75 6 0 9 1.0 0.0 0.0 0) (85 1 85 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "clm-channel 75 10" #__line__))
+ vals "clm-channel 75 10"))
(map-channel (lambda (y) (* y 1 .5)) 3 11) ; extra "1" is needed for the tree expectation
(do ((i 3 (+ i 1)))
((= i 14))
@@ -30461,7 +29860,7 @@ EDITS: 2
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.0 0.0 0.0 2) (60 1 60 60 0.0 0.0 0.0 2)
(61 1 61 70 1.0 0.0 0.0 0) (71 1 71 74 0.0 0.0 0.0 2) (75 6 0 9 1.0 0.0 0.0 0)
(85 1 85 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "map-channel 3 14" #__line__)
+ vals "map-channel 3 14")
(map-channel (let ((reader (make-sampler 50)))
(lambda (y)
(- y (next-sample reader))))
@@ -30474,11 +29873,11 @@ EDITS: 2
(40 1 40 49 1.0 0.0 0.0 0) (50 1 50 59 0.0 0.0 0.0 2) (60 1 60 60 0.0 0.0 0.0 2)
(61 1 61 70 1.0 0.0 0.0 0) (71 1 71 74 0.0 0.0 0.0 2) (75 6 0 9 1.0 0.0 0.0 0)
(85 1 85 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "back set via map-channel" #__line__)
+ vals "back set via map-channel")
(set! (selection-position) 20)
(set! (selection-framples) 70)
(env-selection '(0 0 1 1))
- (if (fneq (selection-maxamp ind 0) 1.0) (snd-display #__line__ ";selection-maxamp after env-selection: ~A" (selection-maxamp ind 0)))
+ (if (fneq (selection-maxamp ind 0) 1.0) (snd-display ";selection-maxamp after env-selection: ~A" (selection-maxamp ind 0)))
(do ((i 20 (+ i 1))
(x 0.0)
(incr (/ 1.0 69.0)))
@@ -30491,7 +29890,7 @@ EDITS: 2
(60 1 60 60 0.0 0.0 0.0 2) (61 1 61 70 1.0 0.594202876091003 0.014492753893137 4)
(71 1 71 74 0.0 0.0 0.0 2) (75 6 0 9 1.0 0.797101438045502 0.014492753893137 4)
(85 1 85 89 1.0 0.942028999328613 0.014492753893137 4) (90 1 90 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env-selection" #__line__)
+ vals "env-selection")
(normalize-channel .5)
(float-vector-scale! vals .5)
(check-edit-tree '((0 9 0 19 0.5 0.0 0.0 0) (20 9 20 24 0.5 0.0 0.014492753893137 4)
@@ -30500,31 +29899,31 @@ EDITS: 2
(60 1 60 60 0.0 0.0 0.0 2) (61 1 61 70 0.5 0.594202876091003 0.014492753893137 4)
(71 1 71 74 0.0 0.0 0.0 2) (75 6 0 9 0.5 0.797101438045502 0.014492753893137 4)
(85 1 85 89 0.5 0.942028999328613 0.014492753893137 4) (90 1 90 99 0.5 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "scale-to" #__line__)
- (if (fneq (selection-maxamp) .5) (snd-display #__line__ ";selection-maxamp after scale: ~A" (selection-maxamp)))
+ vals "scale-to")
+ (if (fneq (selection-maxamp) .5) (snd-display ";selection-maxamp after scale: ~A" (selection-maxamp)))
(delete-samples 0 100)
(insert-silence 0 100)
(fill! vals 0.0)
(check-edit-tree '((0 -1 0 99 0.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "second set..." #__line__)
+ vals "second set...")
(set! (sample 50) .5)
(set! (vals 50) .5)
(check-edit-tree '((0 -1 0 49 0.0 0.0 0.0 2) (50 10 0 0 1.0 0.0 0.0 0) (51 -1 51 99 0.0 0.0 0.0 2) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "split silence" #__line__)
+ vals "split silence")
(map-channel (lambda (y) 1.0) 0 25)
(fill! vals 1.0 0 25)
(check-edit-tree '((0 11 0 24 1.0 0.0 0.0 0) (25 -1 25 49 0.0 0.0 0.0 2) (50 10 0 0 1.0 0.0 0.0 0) (51 -1 51 99 0.0 0.0 0.0 2) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "clobber silence start" #__line__)
+ vals "clobber silence start")
(map-channel (lambda (y) 1.0) 75 25)
(fill! vals 1.0 75 100)
(check-edit-tree '((0 11 0 24 1.0 0.0 0.0 0) (25 -1 25 49 0.0 0.0 0.0 2) (50 10 0 0 1.0 0.0 0.0 0)
(51 -1 51 74 0.0 0.0 0.0 2) (75 12 0 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "clobber silence end" #__line__)
+ vals "clobber silence end")
(scale-channel 0.0 0 100)
(fill! vals 0.0)
(check-edit-tree '((0 0 0 99 0.0 0.0 0.0 1) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "scale all to 0.0" #__line__)
+ vals "scale all to 0.0")
(let ((e (make-env '(0 0 1 1) :length 101))
(e1 (make-env '(0 0 1 1) :length 101)))
(map-channel (lambda (y) (env e)))
@@ -30532,28 +29931,28 @@ EDITS: 2
((= i 100))
(set! (vals i) (env e1))))
(check-edit-tree '((0 13 0 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env start" #__line__)
+ vals "env start")
(set! (sample 50) -.5)
(set! (vals 50) -.5)
(check-edit-tree '((0 13 0 49 1.0 0.0 0.0 0) (50 14 0 0 1.0 0.0 0.0 0) (51 13 51 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "split env segment" #__line__)
+ vals "split env segment")
(map-channel (lambda (y) 1.0) 0 25)
(fill! vals 1.0 0 25)
(check-edit-tree '((0 15 0 24 1.0 0.0 0.0 0) (25 13 25 49 1.0 0.0 0.0 0) (50 14 0 0 1.0 0.0 0.0 0) (51 13 51 99 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "clobber env start" #__line__)
+ vals "clobber env start")
(map-channel (lambda (y) 1.0) 75 25)
(fill! vals 1.0 75 100)
(check-edit-tree '((0 15 0 24 1.0 0.0 0.0 0) (25 13 25 49 1.0 0.0 0.0 0) (50 14 0 0 1.0 0.0 0.0 0)
(51 13 51 74 1.0 0.0 0.0 0) (75 16 0 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "clobber env end" #__line__)
+ vals "clobber env end")
;; this can't be expected to work anymore -- internal backup can change edit tree bounds
; (save-edit-history "hiho.scm")
; (revert-sound ind)
; (set! sfile ind)
; (load (string-append cwd "hiho.scm"))
; (check-edit-tree '((0 14 0 24 1.0 0.0 0.0 0) (25 12 25 49 1.0 0.0 0.0 0) (50 13 0 0 1.0 0.0 0.0 0) (51 12 51 74 1.0 0.0 0.0 0) (75 15 0 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- ; vals "reload edits" #__line__)
- ; (if (not (equal? (edits) (list 27 0))) (snd-display #__line__ ";edits after reload: ~A" (edits)))
+ ; vals "reload edits")
+ ; (if (not (equal? (edits) (list 27 0))) (snd-display ";edits after reload: ~A" (edits)))
; (delete-file "hiho.scm")
(env-channel (make-env '(0 1 1 0 2 1) :length 20) 50 20)
@@ -30564,7 +29963,7 @@ EDITS: 2
(check-edit-tree '((0 15 0 24 1.0 0.0 0.0 0) (25 13 25 49 1.0 0.0 0.0 0) (50 14 0 0 1.0 1.0 -0.100000001490116 4)
(51 13 51 59 1.0 0.899999976158142 -0.100000001490116 4) (60 13 60 69 1.0 0.0 0.111111111938953 4)
(70 13 70 74 1.0 0.0 0.0 0) (75 16 0 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env on env" #__line__)
+ vals "env on env")
(env-channel (make-env '(0 1 1 0 2 1) :length 80) 10 80)
(let ((e (make-env '(0 1 1 0 2 1) :length 80)))
(do ((i 10 (+ i 1)))
@@ -30574,7 +29973,7 @@ EDITS: 2
(50 14 0 0 1.0 1.0 -0.100000001490116 6) (51 13 51 59 1.0 0.899999976158142 -0.100000001490116 6)
(60 13 60 69 1.0 0.0 0.111111111938953 6) (70 13 70 74 1.0 0.512820541858673 0.0256410259753466 4)
(75 16 0 14 1.0 0.64102566242218 0.0256410259753466 4) (90 16 15 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env on env 2" #__line__)
+ vals "env on env 2")
(env-channel (make-env '(0 1 1 0 2 1) :length 20) 50 20)
(let ((e (make-env '(0 1 1 0 2 1) :length 20)))
(do ((i 50 (+ i 1)))
@@ -30584,7 +29983,7 @@ EDITS: 2
(50 14 0 0 1.0 1.0 -0.100000001490116 10) (51 13 51 59 1.0 0.899999976158142 -0.100000001490116 10)
(60 13 60 69 1.0 0.0 0.111111111938953 10) (70 13 70 74 1.0 0.512820541858673 0.0256410259753466 4)
(75 16 0 14 1.0 0.64102566242218 0.0256410259753466 4) (90 16 15 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env on env 3" #__line__)
+ vals "env on env 3")
(delete-samples 10 20)
(insert-silence 10 20)
(fill! vals 0.0 10 30)
@@ -30592,7 +29991,7 @@ EDITS: 2
(50 14 0 0 1.0 1.0 -0.100000001490116 10) (51 13 51 59 1.0 0.899999976158142 -0.100000001490116 10)
(60 13 60 69 1.0 0.0 0.111111111938953 10) (70 13 70 74 1.0 0.512820541858673 0.0256410259753466 4)
(75 16 0 14 1.0 0.64102566242218 0.0256410259753466 4) (90 16 15 24 1.0 0.0 0.0 0) (100 -2 0 0 0.0 0.0 0.0 0))
- vals "env preclobbered" #__line__)
+ vals "env preclobbered")
(close-sound ind))
(for-each
@@ -30617,7 +30016,7 @@ EDITS: 2
((= i dur))
(float-vector-set! v1 i (e)))))
(if (not (vequal v0 v1))
- (snd-display #__line__ ";~A env check [~A]: ~A ~A" name r rv ev))))
+ (snd-display ";~A env check [~A]: ~A ~A" name r rv ev))))
(float-vector->channel v)
(env-sound '(0 0 1 1))
@@ -30629,15 +30028,13 @@ EDITS: 2
(check-env 'ramp (make-sampler 0) (make-env '(0 0 1 1 2 0) :length dur))
(let ((cur-read (make-sampler 0)))
(reverse-channel)
- (let ((rev-read (make-sampler (- dur 1) i1 0 -1)))
- (check-env 'rev-pyr cur-read rev-read)))
+ (check-env 'rev-pyr cur-read (make-sampler (- dur 1) i1 0 -1)))
(undo 2)
(env-sound '(0 0 1 1 2 0 3 1))
(check-env '3-ramp (make-sampler 0) (make-env '(0 0 1 1 2 0 3 1) :length dur))
(let ((cur-read (make-sampler 0)))
(reverse-channel)
- (let ((rev-read (make-sampler (- dur 1) i1 0 -1)))
- (check-env 'rev-pyr cur-read rev-read)))
+ (check-env 'rev-pyr cur-read (make-sampler (- dur 1) i1 0 -1)))
(undo 2)
(env-sound '(0 0 1 1 2 1 3 0))
(check-env 'sqoff (make-sampler 0) (make-env '(0 0 1 1 2 1 3 0) :length dur))
@@ -30655,8 +30052,7 @@ EDITS: 2
(check-env 'scl-3-ramp (make-sampler 0) (make-env '(0 0 1 1 2 0) :length dur :scaler .5))
(let ((cur-read (make-sampler 0)))
(reverse-channel)
- (let ((rev-read (make-sampler (- dur 1) i1 0 -1)))
- (check-env 'scl-rev-pyr cur-read rev-read)))
+ (check-env 'scl-rev-pyr cur-read (make-sampler (- dur 1) i1 0 -1)))
(undo 3)
(when (= dur 10000)
(for-each
@@ -30677,30 +30073,30 @@ EDITS: 2
(undo 2)))
(list 0 0 1000 1000 4000 5000 6000 5000)
(list 1000 6000 1000 4000 2000 1000 1000 5000)))
- (if (= dur 10000)
- (for-each
- (lambda (env-beg env-dur scl-beg scl-dur)
- (let ((eend (+ env-beg env-dur 1))
- (send (+ scl-beg scl-dur 1)))
- (env-channel '(0 0 1 1 2 1 3 0) env-beg env-dur)
- (scale-channel .5 scl-beg scl-dur)
- (check-env 'env+scl-partial
- (make-sampler 0)
- (let ((e (make-env '(0 0 1 1 2 1 3 0) :length env-dur))
- (ctr 0))
- (lambda ()
- (let ((val 1.0))
- (set! ctr (+ ctr 1))
- (if (< env-beg ctr eend)
- (set! val (env e)))
- (if (< scl-beg ctr send)
- (set! val (* val 0.5)))
- val))))
- (undo 2)))
- (list 0 0 1000 1000 4000 5000 6000 5000)
- (list 1000 6000 1000 4000 2000 1000 1000 5000)
- (list 500 0 0 2000 5000 4000 0 8000)
- (list 200 10000 1500 1000 500 2000 2000 2000)))
+ (when (= dur 10000)
+ (for-each
+ (lambda (env-beg env-dur scl-beg scl-dur)
+ (let ((eend (+ env-beg env-dur 1))
+ (send (+ scl-beg scl-dur 1)))
+ (env-channel '(0 0 1 1 2 1 3 0) env-beg env-dur)
+ (scale-channel .5 scl-beg scl-dur)
+ (check-env 'env+scl-partial
+ (make-sampler 0)
+ (let ((e (make-env '(0 0 1 1 2 1 3 0) :length env-dur))
+ (ctr 0))
+ (lambda ()
+ (let ((val 1.0))
+ (set! ctr (+ ctr 1))
+ (if (< env-beg ctr eend)
+ (set! val (env e)))
+ (if (< scl-beg ctr send)
+ (set! val (* val 0.5)))
+ val))))
+ (undo 2)))
+ (list 0 0 1000 1000 4000 5000 6000 5000)
+ (list 1000 6000 1000 4000 2000 1000 1000 5000)
+ (list 500 0 0 2000 5000 4000 0 8000)
+ (list 200 10000 1500 1000 500 2000 2000 2000)))
(env-sound '(0 0 1 1))
(env-sound '(0 0 1 1))
(check-env 'unenv-ramp
@@ -30715,7 +30111,7 @@ EDITS: 2
(float-vector->channel v1 3 3)
(let ((vals (channel->float-vector 0 10)))
(if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
- (snd-display #__line__ "; 1 vals: ~A" vals))))
+ (snd-display "; 1 vals: ~A" vals))))
(undo 2)
(env-sound '(0 0 1 1))
(let ((v1 (make-float-vector 3 1.0)))
@@ -30723,7 +30119,7 @@ EDITS: 2
(insert-samples 3 3 v1)
(let ((vals (channel->float-vector 0 10)))
(if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
- (snd-display #__line__ "; 2 vals: ~A" vals))))
+ (snd-display "; 2 vals: ~A" vals))))
(undo 3)
(env-sound '(0 0 1 1))
(let ((v1 (make-float-vector 3 1.0)))
@@ -30738,38 +30134,37 @@ EDITS: 2
(float-vector->channel v1 3 3)
(let ((vals (channel->float-vector 0 10)))
(if (not (vequal vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
- (snd-display #__line__ "; 4 vals (~A): ~A" dur vals))))
+ (snd-display "; 4 vals (~A): ~A" dur vals))))
(begin
(fill! v1 0.0)
(float-vector->channel v1 4998 3)
(let ((vals (channel->float-vector 4995 10)))
(if (not (vequal vals (float-vector 0.999 0.999 1.000 0.000 0.000 0.000 1.000 0.999 0.999 0.999)))
- (snd-display #__line__ "; 4 vals big: ~A" vals))))))
+ (snd-display "; 4 vals big: ~A" vals))))))
(undo 2)
- (if (= dur 10)
- (begin
- (env-sound '(0 0 1 1 2 0))
- (let ((v1 (make-float-vector 3 1.0)))
- (delete-samples 3 3)
- (insert-samples 3 3 v1)
- (let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
- (snd-display #__line__ "; 2 vals: ~A" vals))))
- (undo 3)
- (env-sound '(0 0 1 1 2 0))
- (let ((v1 (make-float-vector 3 1.0)))
- (float-vector->channel v1 0 3)
- (let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 1.000 1.000 1.000 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
- (snd-display #__line__ "; 4 vals: ~A" vals))))
- (undo 2)
- (env-sound '(0 0 1 1 2 0))
- (let ((v1 (make-float-vector 3 1.0)))
- (float-vector->channel v1 7 3)
- (let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 1.000 1.000 1.000)))
- (snd-display #__line__ "; 5 vals: ~A" vals))))
- (undo 2)))
+ (when (= dur 10)
+ (env-sound '(0 0 1 1 2 0))
+ (let ((v1 (make-float-vector 3 1.0)))
+ (delete-samples 3 3)
+ (insert-samples 3 3 v1)
+ (let ((vals (channel->float-vector 0 10)))
+ (if (not (vequal vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
+ (snd-display "; 2 vals: ~A" vals))))
+ (undo 3)
+ (env-sound '(0 0 1 1 2 0))
+ (let ((v1 (make-float-vector 3 1.0)))
+ (float-vector->channel v1 0 3)
+ (let ((vals (channel->float-vector 0 10)))
+ (if (not (vequal vals (float-vector 1.000 1.000 1.000 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (snd-display "; 4 vals: ~A" vals))))
+ (undo 2)
+ (env-sound '(0 0 1 1 2 0))
+ (let ((v1 (make-float-vector 3 1.0)))
+ (float-vector->channel v1 7 3)
+ (let ((vals (channel->float-vector 0 10)))
+ (if (not (vequal vals (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 1.000 1.000 1.000)))
+ (snd-display "; 5 vals: ~A" vals))))
+ (undo 2))
(let ((file (file-name i1)))
(close-sound i1)
(if (file-exists? file) (delete-file file)))
@@ -30780,15 +30175,15 @@ EDITS: 2
(vals (make-float-vector 10000)))
(select-sound ind)
(select-channel 0)
- (check-edit-tree '((0 0 0 0 0.0 0.0 0.0 1) (1 -2 0 0 0.0 0.0 0.0 0)) (make-float-vector 1) "initial new-sound" #__line__)
+ (check-edit-tree '((0 0 0 0 0.0 0.0 0.0 1) (1 -2 0 0 0.0 0.0 0.0 0)) (make-float-vector 1) "initial new-sound")
(fill! vals 1.0)
(set! (samples 0 10000) vals)
- (check-edit-tree '((0 1 0 9999 1.0 0.0 0.0 0) (10000 -2 0 0 0.0 0.0 0.0 0)) vals "envd set first samps to one" #__line__)
+ (check-edit-tree '((0 1 0 9999 1.0 0.0 0.0 0) (10000 -2 0 0 0.0 0.0 0.0 0)) vals "envd set first samps to one")
(env-sound '(0 0 1 1))
(let ((e (make-env '(0 0 1 1) :length 10000)))
(fill-float-vector vals (env e)))
(check-edit-tree '((0 1 0 9999 1.0 0.0 1.00010001915507e-4 4) (10000 -2 0 0 0.0 0.0 0.0 0))
- vals "env frag '(0 0 1 1)" #__line__)
+ vals "env frag '(0 0 1 1)")
(delete-samples 1000 1000)
(let ((v1 (make-float-vector 9000)))
(do ((i 0 (+ i 1)))
@@ -30799,7 +30194,7 @@ EDITS: 2
((= i 9000))
(set! (v1 i) (vals j)))
(check-edit-tree '((0 1 0 999 1.0 0.0 1.00010001915507e-4 4) (1000 1 2000 9999 1.0 0.200020000338554 1.00010001915507e-4 4) (9000 -2 0 0 0.0 0.0 0.0 0))
- v1 "env frag del" #__line__))
+ v1 "env frag del"))
(undo 1)
(delete-samples 9000 1000)
(insert-samples 3000 1000 (make-float-vector 1000))
@@ -30809,18 +30204,18 @@ EDITS: 2
(fill! vals 0.0 3000 4000)
(check-edit-tree '((0 1 0 2999 1.0 0.0 1.00010001915507e-4 4) (3000 2 0 999 1.0 0.0 0.0 0)
(4000 1 3000 8999 1.0 0.300029993057251 1.00010001915507e-4 4) (10000 -2 0 0 0.0 0.0 0.0 0))
- vals "envd ins/del" #__line__)
+ vals "envd ins/del")
(delete-samples 0 1000)
(insert-samples 0 1000 (make-float-vector 1000))
(fill! vals 0.0 0 1000)
(check-edit-tree '((0 3 0 999 1.0 0.0 0.0 0) (1000 1 1000 2999 1.0 0.100010000169277 1.00010001915507e-4 4)
(3000 2 0 999 1.0 0.0 0.0 0) (4000 1 3000 8999 1.0 0.300029993057251 1.00010001915507e-4 4) (10000 -2 0 0 0.0 0.0 0.0 0))
- vals "envd predel" #__line__)
+ vals "envd predel")
(scale-by 0.5)
(float-vector-scale! vals 0.5)
(check-edit-tree '((0 3 0 999 0.5 0.0 0.0 0) (1000 1 1000 2999 0.5 0.100010000169277 1.00010001915507e-4 4)
(3000 2 0 999 0.5 0.0 0.0 0) (4000 1 3000 8999 0.5 0.300029993057251 1.00010001915507e-4 4) (10000 -2 0 0 0.0 0.0 0.0 0))
- vals "envd scl" #__line__)
+ vals "envd scl")
(reverse-channel)
(do ((i 0 (+ i 1))
(j 9999 (- j 1)))
@@ -30829,7 +30224,7 @@ EDITS: 2
(set! (vals i) (vals j))
(set! (vals j) temp)))
(check-edit-tree '((0 4 0 9999 1.0 0.0 0.0 0) (10000 -2 0 0 0.0 0.0 0.0 0))
- vals "envd rev" #__line__)
+ vals "envd rev")
(revert-sound ind)
(set! vals (make-float-vector 100000))
@@ -30842,7 +30237,7 @@ EDITS: 2
(float-vector-set! vals i (env e))))
(check-edit-tree '((0 1 0 29999 1.0 0.0 0.0 0) (30000 1 30000 34999 1.0 0.0 1.99999994947575e-4 4)
(35000 1 35000 39999 1.0 1.0 -2.00040012714453e-4 4) (40000 1 40000 99999 1.0 0.0 0.0 0) (100000 -2 0 0 0.0 0.0 0.0 0))
- vals "partial env" #__line__)
+ vals "partial env")
(scale-channel .5 10000 10000)
(env-channel (make-env '(0 0 1 1 2 0) :length 10000) 30000 10000) ; env over env
(let ((e (make-env '(0 0 1 1 2 0) :length 10000)))
@@ -30853,31 +30248,31 @@ EDITS: 2
((= i 20000))
(float-vector-set! vals i (* (float-vector-ref vals i) 0.5)))
(check-edit-tree '((0 1 0 9999 1.0 0.0 0.0 0) (10000 1 10000 19999 0.5 0.0 0.0 0) (20000 1 20000 29999 1.0 0.0 0.0 0) (30000 1 30000 34999 1.0 0.0 1.99999994947575e-4 6) (35000 1 35000 39999 1.0 1.0 -2.00040012714453e-4 6) (40000 1 40000 99999 1.0 0.0 0.0 0) (100000 -2 0 0 0.0 0.0 0.0 0))
- vals "env over env" #__line__)
+ vals "env over env")
(env-channel (make-env '(0 0 1 1 2 0) :length 10000) 5000 10000) ; env over scl
(let ((e (make-env '(0 0 1 1 2 0) :length 10000)))
(do ((i 5000 (+ i 1)))
((= i 15000))
(float-vector-set! vals i (* (float-vector-ref vals i) (env e)))))
(check-edit-tree '((0 1 0 4999 1.0 0.0 0.0 0) (5000 1 5000 9999 1.0 0.0 1.99999994947575e-4 4) (10000 1 10000 14999 0.5 1.0 -2.00040012714453e-4 4) (15000 1 15000 19999 0.5 0.0 0.0 0) (20000 1 20000 29999 1.0 0.0 0.0 0) (30000 1 30000 34999 1.0 0.0 1.99999994947575e-4 6) (35000 1 35000 39999 1.0 1.0 -2.00040012714453e-4 6) (40000 1 40000 99999 1.0 0.0 0.0 0) (100000 -2 0 0 0.0 0.0 0.0 0))
- vals "env over scl" #__line__)
+ vals "env over scl")
(ramp-channel .5 -.5 25000 1000)
(let ((e (make-env '(0 .5 1 -.5) :length 1000)))
(do ((i 25000 (+ i 1)))
((= i 26000))
(float-vector-set! vals i (* (float-vector-ref vals i) (env e)))))
(check-edit-tree '((0 1 0 4999 1.0 0.0 0.0 0) (5000 1 5000 9999 1.0 0.0 1.99999994947575e-4 4) (10000 1 10000 14999 0.5 1.0 -2.00040012714453e-4 4) (15000 1 15000 19999 0.5 0.0 0.0 0) (20000 1 20000 24999 1.0 0.0 0.0 0) (25000 1 25000 25999 1.0 0.5 -0.00100100098643452 4) (26000 1 26000 29999 1.0 0.0 0.0 0) (30000 1 30000 34999 1.0 0.0 1.99999994947575e-4 6) (35000 1 35000 39999 1.0 1.0 -2.00040012714453e-4 6) (40000 1 40000 99999 1.0 0.0 0.0 0) (100000 -2 0 0 0.0 0.0 0.0 0))
- vals "ramp" #__line__)
+ vals "ramp")
(scale-by -1.0)
(float-vector-scale! vals -1.0)
(check-edit-tree '((0 1 0 4999 -1.0 0.0 0.0 0) (5000 1 5000 9999 -1.0 0.0 1.99999994947575e-4 4) (10000 1 10000 14999 -0.5 1.0 -2.00040012714453e-4 4) (15000 1 15000 19999 -0.5 0.0 0.0 0) (20000 1 20000 24999 -1.0 0.0 0.0 0) (25000 1 25000 25999 -1.0 0.5 -0.00100100098643452 4) (26000 1 26000 29999 -1.0 0.0 0.0 0) (30000 1 30000 34999 -1.0 0.0 1.99999994947575e-4 6) (35000 1 35000 39999 -1.0 1.0 -2.00040012714453e-4 6) (40000 1 40000 99999 -1.0 0.0 0.0 0) (100000 -2 0 0 -0.0 0.0 0.0 0))
- vals "invert" #__line__)
+ vals "invert")
(let ((reader (make-sampler 0 ind 0 1 (- (edit-position) 1))))
(map-channel (lambda (y)
(+ (next-sample reader) y)))
(check-edit-tree '((0 2 0 99999 1.0 0.0 0.0 0) (100000 -2 0 0 0.0 0.0 0.0 0))
- (make-float-vector 100000) "invert and add" #__line__)
- (if (fneq (maxamp) 0.0) (snd-display #__line__ ";invert-and-add maxamp: ~A" (maxamp))))
+ (make-float-vector 100000) "invert and add")
+ (if (fneq (maxamp) 0.0) (snd-display ";invert-and-add maxamp: ~A" (maxamp))))
(undo 1)
(ramp-channel -1.0 1.0 50000 30000)
@@ -30886,14 +30281,14 @@ EDITS: 2
((= i 80000))
(float-vector-set! vals i (* (float-vector-ref vals i) (env e)))))
(check-edit-tree '((0 1 0 4999 -1.0 0.0 0.0 0) (5000 1 5000 9999 -1.0 0.0 1.99999994947575e-4 4) (10000 1 10000 14999 -0.5 1.0 -2.00040012714453e-4 4) (15000 1 15000 19999 -0.5 0.0 0.0 0) (20000 1 20000 24999 -1.0 0.0 0.0 0) (25000 1 25000 25999 -1.0 0.5 -0.00100100098643452 4) (26000 1 26000 29999 -1.0 0.0 0.0 0) (30000 1 30000 34999 -1.0 0.0 1.99999994947575e-4 6) (35000 1 35000 39999 -1.0 1.0 -2.00040012714453e-4 6) (40000 1 40000 49999 -1.0 0.0 0.0 0) (50000 1 50000 79999 -1.0 -1.0 6.66688865749165e-5 4) (80000 1 80000 99999 -1.0 0.0 0.0 0) (100000 -2 0 0 -0.0 0.0 0.0 0))
- vals "ramp" #__line__)
+ vals "ramp")
(env-sound '(0 0 1 1))
(reverse-channel)
(delete-samples 1 99999)
- (if (fneq (sample 0) -1.0) (snd-display #__line__ ";sample at end: ~A" (sample 0)))
- (if (not (= (framples) 1)) (snd-display #__line__ ";length at end: ~A" (framples)))
+ (if (fneq (sample 0) -1.0) (snd-display ";sample at end: ~A" (sample 0)))
+ (if (not (= (framples) 1)) (snd-display ";length at end: ~A" (framples)))
(check-edit-tree '((0 2 0 0 1.0 0.0 0.0 0) (1 -2 0 0 0.0 0.0 0.0 0))
- (make-float-vector 1 -1.0) "at end" #__line__)
+ (make-float-vector 1 -1.0) "at end")
(close-sound ind))
;; a special case that catches the round-off problem
@@ -30903,18 +30298,18 @@ EDITS: 2
(let ((val (sample 50827)))
(if (or (not (number? val))
(fneq val 0.0))
- (snd-display #__line__ ";round-off env: ~A" val)))
+ (snd-display ";round-off env: ~A" val)))
(check-edit-tree '((0 0 0 15111 1.0 0.984011590480804 -5.77709688514005e-5 4) (15112 0 15112 27516 1.0 0.110976688563824 2.20663678192068e-5 4) (27517 0 27517 29482 1.0 0.384709984064102 8.4813182184007e-5 4) (29483 0 29483 33763 1.0 0.551452696323395 6.82959798723459e-5 4) (33764 0 33764 50827 1.0 0.843827784061432 -3.61598467861768e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "round-off test" #__line__)
+ #f "round-off test")
(revert-sound ind)
(map-channel (lambda (y) 1.0))
(env-channel '(0 0 1 1 2 0))
(scale-channel .5 1000 1000)
(let ((val (sample 800)))
(if (fneq val .0314)
- (snd-display #__line__ ";scl on env trouble: ~A" val)))
+ (snd-display ";scl on env trouble: ~A" val)))
(check-edit-tree '((0 1 0 999 1.0 0.0 3.93483896914404e-5 4) (1000 1 1000 1999 0.5 0.0393483899533749 3.93483896914404e-5 4) (2000 1 2000 25413 1.0 0.0786967799067497 3.93483896914404e-5 4) (25414 1 25414 50827 1.0 1.0 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "scl on env" #__line__)
+ #f "scl on env")
(revert-sound ind)
(map-channel (lambda (y) 1.0))
(ramp-channel 0.0 1.0)
@@ -30922,9 +30317,9 @@ EDITS: 2
(ramp-channel 0.0 1.0)
(let ((val (sample 20000)))
(if (fneq val (expt (/ 20000.0 50828) 3))
- (snd-display #__line__ ";ramp-channels piled up: ~A" val)))
+ (snd-display ";ramp-channels piled up: ~A" val)))
(check-edit-tree '((0 1 0 50827 1.0 0.0 1.96745822904631e-5 10) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "ramp upon ramp" #__line__)
+ #f "ramp upon ramp")
(revert-sound ind)
(map-channel (lambda (y) 1.0))
@@ -30937,39 +30332,39 @@ EDITS: 2
(val2 (* val1 0.5 ratio))
(val3 (* val2 (+ 0.1 (* ratio 0.3)))))
(if (fneq val val3)
- (snd-display #__line__ ";ramp-channels piled up (2): ~A ~A" val val3)))
+ (snd-display ";ramp-channels piled up (2): ~A ~A" val val3)))
(revert-sound ind)
(env-channel '(0 0 1 1 2 0))
(check-edit-tree '((0 0 0 25413 1.0 0.0 3.93483896914404e-5 4) (25414 0 25414 50827 1.0 1.0 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 0" #__line__)
+ #f "env+scl 0")
(scale-channel .5 0 1000)
(check-edit-tree '((0 0 0 999 0.5 0.0 3.93483896914404e-5 4) (1000 0 1000 25413 1.0 0.0393483899533749 3.93483896914404e-5 4) (25414 0 25414 50827 1.0 1.0 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 1" #__line__)
+ #f "env+scl 1")
(undo)
(scale-channel .5 1000 1000)
(check-edit-tree '((0 0 0 999 1.0 0.0 3.93483896914404e-5 4) (1000 0 1000 1999 0.5 0.0393483899533749 3.93483896914404e-5 4) (2000 0 2000 25413 1.0 0.0786967799067497 3.93483896914404e-5 4) (25414 0 25414 50827 1.0 1.0 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 2" #__line__)
+ #f "env+scl 2")
(undo)
(scale-channel .5 0 25415)
(check-edit-tree '((0 0 0 25413 0.5 0.0 3.93483896914404e-5 4) (25414 0 25414 25414 0.5 1.0 -3.93499394704122e-5 4) (25415 0 25415 50827 1.0 0.999960660934448 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 3" #__line__)
+ #f "env+scl 3")
(undo)
(scale-channel .5 20000 10000)
(check-edit-tree '((0 0 0 19999 1.0 0.0 3.93483896914404e-5 4) (20000 0 20000 25413 0.5 0.786967813968658 3.93483896914404e-5 4) (25414 0 25414 29999 0.5 1.0 -3.93499394704122e-5 4) (30000 0 30000 50827 1.0 0.819541156291962 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 4" #__line__)
+ #f "env+scl 4")
(undo)
(scale-channel .5 30000 1000)
(check-edit-tree '((0 0 0 25413 1.0 0.0 3.93483896914404e-5 4) (25414 0 25414 29999 1.0 1.0 -3.93499394704122e-5 4) (30000 0 30000 30999 0.5 0.819541156291962 -3.93499394704122e-5 4) (31000 0 31000 50827 1.0 0.780191242694855 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 5" #__line__)
+ #f "env+scl 5")
(undo)
(scale-channel .5 25415 1000)
(check-edit-tree '((0 0 0 25413 1.0 0.0 3.93483896914404e-5 4) (25414 0 25414 25414 1.0 1.0 -3.93499394704122e-5 4) (25415 0 25415 26414 0.5 0.999960660934448 -3.93499394704122e-5 4) (26415 0 26415 50827 1.0 0.960610687732697 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 6" #__line__)
+ #f "env+scl 6")
(undo)
(scale-channel .5 40000 10828)
(check-edit-tree '((0 0 0 25413 1.0 0.0 3.93483896914404e-5 4) (25414 0 25414 39999 1.0 1.0 -3.93499394704122e-5 4) (40000 0 40000 50827 0.5 0.426041781902313 -3.93499394704122e-5 4) (50828 -2 0 0 0.0 0.0 0.0 0))
- #f "env+scl 7" #__line__)
+ #f "env+scl 7")
(close-sound ind))
@@ -30978,26 +30373,26 @@ EDITS: 2
(let ((i1 (new-sound))
(i2 (new-sound "fmv1.snd" 2 44100 mus-ldouble mus-next))
(v (make-float-vector dur 1.0)))
- (define (check-env name r e)
- (let ((v0 (make-float-vector dur))
- (v1 (make-float-vector dur)))
- (if (env? e)
- (do ((i 0 (+ i 1)))
- ((= i dur))
- (set! (v0 i) (env e)))
- (do ((i 0 (+ i 1)))
- ((= i dur))
- (set! (v0 i) (e))))
- (if (sampler? r)
- (do ((i 0 (+ i 1)))
- ((= i dur))
- (float-vector-set! v1 i (read-sample r)))
- (do ((i 0 (+ i 1)))
- ((= i dur))
- (float-vector-set! v1 i (r))))
- (if (not (vequal v0 v1))
- (snd-display #__line__ ";~A env check: ~A ~A" name v0 v1))))
(define (check-envs name r-maker e-maker)
+ (define (check-env name r e)
+ (let ((v0 (make-float-vector dur))
+ (v1 (make-float-vector dur)))
+ (if (env? e)
+ (do ((i 0 (+ i 1)))
+ ((= i dur))
+ (set! (v0 i) (env e)))
+ (do ((i 0 (+ i 1)))
+ ((= i dur))
+ (set! (v0 i) (e))))
+ (if (sampler? r)
+ (do ((i 0 (+ i 1)))
+ ((= i dur))
+ (float-vector-set! v1 i (read-sample r)))
+ (do ((i 0 (+ i 1)))
+ ((= i dur))
+ (float-vector-set! v1 i (r))))
+ (if (not (vequal v0 v1))
+ (snd-display ";~A env check: ~A ~A" name v0 v1))))
(check-env (format #f "~A-1-0" name) (r-maker i1 0) (e-maker i1 0))
(check-env (format #f "~A-2-0" name) (r-maker i2 0) (e-maker i2 0))
(check-env (format #f "~A-2-1" name) (r-maker i2 1) (e-maker i2 1)))
@@ -31038,13 +30433,13 @@ EDITS: 2
(float-vector->channel v1 3 3 i2 1)
(let ((vals (channel->float-vector 0 10 i1 0)))
(if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
- (snd-display #__line__ "; 1 0 vals: ~A" vals))
+ (snd-display "; 1 0 vals: ~A" vals))
(set! vals (channel->float-vector 0 10 i2 0))
(if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
- (snd-display #__line__ "; 2 0 vals: ~A" vals))
+ (snd-display "; 2 0 vals: ~A" vals))
(set! vals (channel->float-vector 0 10 i2 1))
(if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
- (snd-display #__line__ "; 2 1 vals: ~A" vals))))
+ (snd-display "; 2 1 vals: ~A" vals))))
(let ((file (file-name i1)))
(close-sound i1)
(if (file-exists? file) (delete-file file)))
@@ -31085,245 +30480,240 @@ EDITS: 2
(close-sound ind)
times))))
(let ((away (string-append home-dir "/test/sound/away.snd")))
- (if (file-exists? away)
- (list "1a.snd" "oboe.snd" "storm.snd" away)
- (list "1a.snd" "oboe.snd" "storm.snd" "lola.snd"))))))
-
- (snd-display #__line__ "; scl rev env map scn pad wrt clm mix src del")
- (snd-display #__line__ ";1a: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (car data)))
- (snd-display #__line__ ";oboe: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cdar data)))
- (snd-display #__line__ ";storm:~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (caddr data)))
+ (list "1a.snd" "oboe.snd" "storm.snd" (if (file-exists? away) away "lola.snd"))))))
+
+ (snd-display "; scl rev env map scn pad wrt clm mix src del")
+ (snd-display ";1a: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (car data)))
+ (snd-display ";oboe: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cdar data)))
+ (snd-display ";storm:~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (caddr data)))
(if (pair? (cadddr data))
- (snd-display #__line__ ";away: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cadddr data))))
+ (snd-display ";away: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cadddr data))))
)
- (if (and all-args with-big-file)
- (let ((ind (view-sound big-file-name)))
- (catch #t
- (lambda ()
- (set! (squelch-update ind) #t)
- (set! *selection-creates-region* #f)
- (let ((times (map
- (lambda (function)
- (let ((start (real-time)))
- (function)
- (update-time-graph)
- (revert-sound)
- (- (real-time) start)))
- (list (lambda ()
- (let ((ma (maxamp)))
- (scale-channel 2.0)
- (if (fneq (maxamp) (* 2 ma)) (snd-display #__line__ ";bigger scale max: ~A ~A" ma (maxamp)))))
- (lambda ()
- (let ((ma (maxamp)))
- (env-channel '(0 0 1 1))
- (if (fneq (maxamp) ma) (snd-display #__line__ ";bigger env max: ~A ~A" ma (maxamp)))))
- (lambda () (pad-channel 0 2000))
- (lambda () (pad-channel 1336909605 297671280))
- (lambda () (insert-silence (+ (framples ind) 100) 100))
- (lambda () (float-vector->channel (make-float-vector 1000 .1) 0 1000))
- (lambda () (float-vector->channel (make-float-vector 1000 .1) (/ (framples ind) 2) 1000))
- (lambda () (float-vector->channel (make-float-vector 1000 .1) (- (framples ind) 2000) 1000))
- (lambda () (mix "pistol.snd" 12345))
- (lambda () (delete-samples 10 200))
- (lambda () (delete-samples 1336909605 297671280))
- (lambda () (delete-samples (- (framples ind) 100) 10))
- ))))
- (set! (squelch-update ind) #f)
- (snd-display #__line__ ";big: ~{~6,2F~}" times)
- ))
- (lambda args (set! (squelch-update) #f)))
- (close-sound ind)))
+ (when (and all-args with-big-file)
+ (let ((ind (view-sound big-file-name)))
+ (catch #t
+ (lambda ()
+ (set! (squelch-update ind) #t)
+ (set! *selection-creates-region* #f)
+ (let ((times (map
+ (lambda (function)
+ (let ((start (real-time)))
+ (function)
+ (update-time-graph)
+ (revert-sound)
+ (- (real-time) start)))
+ (list (lambda ()
+ (let ((ma (maxamp)))
+ (scale-channel 2.0)
+ (if (fneq (maxamp) (* 2 ma)) (snd-display ";bigger scale max: ~A ~A" ma (maxamp)))))
+ (lambda ()
+ (let ((ma (maxamp)))
+ (env-channel '(0 0 1 1))
+ (if (fneq (maxamp) ma) (snd-display ";bigger env max: ~A ~A" ma (maxamp)))))
+ (lambda () (pad-channel 0 2000))
+ (lambda () (pad-channel 1336909605 297671280))
+ (lambda () (insert-silence (+ (framples ind) 100) 100))
+ (lambda () (float-vector->channel (make-float-vector 1000 .1) 0 1000))
+ (lambda () (float-vector->channel (make-float-vector 1000 .1) (/ (framples ind) 2) 1000))
+ (lambda () (float-vector->channel (make-float-vector 1000 .1) (- (framples ind) 2000) 1000))
+ (lambda () (mix "pistol.snd" 12345))
+ (lambda () (delete-samples 10 200))
+ (lambda () (delete-samples 1336909605 297671280))
+ (lambda () (delete-samples (- (framples ind) 100) 10))
+ ))))
+ (set! (squelch-update ind) #f)
+ (snd-display ";big: ~{~6,2F~}" times)
+ ))
+ (lambda args (set! (squelch-update) #f)))
+ (close-sound ind)))
- (if with-big-file
- (letrec ((fieql
- (lambda (a b)
- (if (null? a)
- (null? b)
- (and (not (null? b))
- (if (and (integer? (car a))
- (not (= (car a) (car b))))
- #f
- (if (and (number? (car a))
- (fneq (car a) (car b)))
- #f
- (fieql (cdr a) (cdr b)))))))))
-
- (set! (hook-functions after-graph-hook) ())
- (set! (hook-functions mouse-click-hook) ())
-
- (let ((ind (open-sound big-file-name))
- (vals (make-float-vector 100))
- (old-vals #f)
- (new-vals #f)
- (maxa 0.0))
- (if (= big-file-framples 0)
- (set! big-file-framples (framples ind)))
- (select-sound ind)
- (select-channel 0)
- (set! (squelch-update) #t)
- (if (not (fieql (edit-tree) (list (list 0 0 0 (- big-file-framples 1) 1.0 0.0 0.0 0) (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger initial tree: ~A" (edit-tree)))
- (fill! vals 1.0)
- (set! maxa (maxamp))
- (scale-channel 0.5)
- (set! old-vals (channel->float-vector (- (* (floor *clm-srate*) 50000) 50) 200))
- (if (fneq (maxamp) (* 0.5 maxa)) (snd-display #__line__ ";bigger scale: ~A ~A" maxa (maxamp)))
+ (when with-big-file
+ (letrec ((fieql
+ (lambda (a b)
+ (if (null? a)
+ (null? b)
+ (and (not (null? b))
+ (not (or (and (integer? (car a))
+ (not (= (car a) (car b))))
+ (and (number? (car a))
+ (fneq (car a) (car b)))))
+ (fieql (cdr a) (cdr b)))))))
+
+ (set! (hook-functions after-graph-hook) ())
+ (set! (hook-functions mouse-click-hook) ())
+
+ (let ((ind (open-sound big-file-name)))
+ (let ((old-vals #f))
+ (let ((maxa 0.0)
+ (vals (make-float-vector 100)))
+ (if (= big-file-framples 0)
+ (set! big-file-framples (framples ind)))
+ (select-sound ind)
+ (select-channel 0)
+ (set! (squelch-update) #t)
+ (if (not (fieql (edit-tree) (list (list 0 0 0 (- big-file-framples 1) 1.0 0.0 0.0 0) (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger initial tree: ~A" (edit-tree)))
+ (fill! vals 1.0)
+ (set! maxa (maxamp))
+ (scale-channel 0.5)
+ (set! old-vals (channel->float-vector (- (* (floor *clm-srate*) 50000) 50) 200))
+ (if (fneq (maxamp) (* 0.5 maxa)) (snd-display ";bigger scale: ~A ~A" maxa (maxamp))))
(set! (samples (* (floor *clm-srate*) 50000) 100) vals)
(if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 0.5 0.0 0.0 0)
(list 2205000000 1 0 99 1.0 0.0 0.0 0)
(list 2205000100 0 2205000100 (- big-file-framples 1) 0.5 0.0 0.0 0)
(list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger set tree: ~A" (edit-tree)))
- (set! new-vals (channel->float-vector (- (* (floor *clm-srate*) 50000) 50) 200))
- (do ((i 50 (+ i 1))) ((= i 150)) (set! (old-vals i) 1.0))
- (if (not (vequal new-vals old-vals)) (snd-display #__line__ ";bigger set ~A ~A" old-vals new-vals))
- (env-channel (make-env '(0 0 1 1) :length (* (floor *clm-srate*) 60000)) 1000 (* (floor *clm-srate*) 60000))
- (if (not (fieql (edit-tree) (list (list 0 0 0 999 0.5 0.0 0.0 0)
- (list 1000 0 1000 2204999999 0.5 1.12130420080871e-17 0.83333295583725 1)
- (list 2205000000 1 0 99 1.0 0.83333295583725 0.833333015441895 1)
- (list 2205000100 0 2205000100 2646000999 0.5 0.833333015441895 1.0 1)
- (list 2646001000 0 2646001000 (- big-file-framples 1) 0.5 0.0 0.0 0)
- (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger with env: ~A" (edit-tree)))
- (revert-sound ind)
- (env-channel (make-env '(0 0 1 1 2 0) :length 101) (* (floor *clm-srate*) 50000) 100)
- (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
- (list 2205000000 0 2205000000 2205000050 1.0 4.47034825823422e-10 1.0 2)
- (list 2205000051 0 2205000051 2205000099 1.0 0.979591846466064 -5.55111512312578e-17 2)
- (list 2205000100 0 2205000100 (- big-file-framples 1) 1.0 0.0 0.0 0)
- (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger short env: ~A" (edit-tree)))
- (let ((r (make-sampler (+ 75 (* (floor *clm-srate*) 50000))))
- (v (make-float-vector 10)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (read-sample r)))
- (if (not (vequal v (float-vector -0.021 -0.020 -0.020 -0.019 -0.018 -0.017 -0.016 -0.016 -0.015 -0.014)))
- (snd-display #__line__ ";bigger short env vals: ~A" v)))
- (revert-sound)
-
- (let ((v (channel->float-vector (+ 75 (* (floor *clm-srate*) 50000)) 10)))
- (if (not (vequal v (float-vector -0.042 -0.043 -0.044 -0.045 -0.045 -0.045 -0.045 -0.045 -0.045 -0.046)))
- (snd-display #__line__ ";bigger no env vals: ~A" v)))
- (scale-to 1.0)
- (if (fneq (maxamp) 1.0) (snd-display #__line__ ";bigger scale-to 1.0 maxamp: ~A" (maxamp)))
- (set! (sample (* (floor *clm-srate*) 51000)) 0.0)
- (if (not (fieql (edit-tree) (list (list 0 0 0 2249099999 1.18574941158295 0.0 0.0 0)
- (list 2249100000 1 0 0 1.0 0.0 0.0 0)
- (list 2249100001 0 2249100001 (- big-file-framples 1) 1.18574941158295 0.0 0.0 0)
- (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger set 0 samp: ~A" (edit-tree)))
- (if (fneq (sample (* (floor *clm-srate*) 51000)) 0.0) (snd-display #__line__ ";bigger 0 samp: ~A" (sample (* (floor *clm-srate*) 51000))))
- (delete-samples (* (floor *clm-srate*) 52000) 100)
- (if (not (= (framples) (- big-file-framples 100)))
- (snd-display #__line__ ";bigger deletion framples: ~A (~A)" (framples) (- big-file-framples 100)))
- (if (not (= (framples ind 0 0) big-file-framples))
- (snd-display #__line__ ";bigger edpos deletion framples: ~A (~A)" (framples ind 0 0) big-file-framples))
- (if (not (= (framples ind 0 (edit-position)) (- big-file-framples 100)))
- (snd-display #__line__ ";bigger ed deletion framples: ~A (~A)" (framples ind 0 (edit-position)) (- big-file-framples 100)))
- (if (not (fieql (edit-tree) (list (list 0 0 0 2249099999 1.18574941158295 0.0 0.0 0)
- (list 2249100000 1 0 0 1.0 0.0 0.0 0)
- (list 2249100001 0 2249100001 2293199999 1.18574941158295 0.0 0.0 0)
- (list 2293200000 0 2293200100 (- big-file-framples 1) 1.18574941158295 0.0 0.0 0)
- (list (- big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger deletion: ~A" (edit-tree)))
- (delete-samples 954624868 67)
- (revert-sound)
-
- (delete-samples 1000 (* (floor *clm-srate*) 50000))
- (if (not (= (framples) (- big-file-framples (* (floor *clm-srate*) 50000)))) (snd-display #__line__ ";bigger big deletion: ~A" (framples)))
- (if (not (fieql (edit-tree) (list (list 0 0 0 999 1.0 0.0 0.0 0)
- (list 1000 0 1085232704 (- big-file-framples 1) 1.0 0.0 0.0 0)
- (list 970200000 -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger big delete: ~A" (edit-tree)))
- (insert-silence 0 (* (floor *clm-srate*) 50000))
- (if (not (= (framples) big-file-framples)) (snd-display #__line__ ";bigger silence: ~A (~A)" (framples) big-file-framples))
- (if (not (fieql (edit-tree) (list (list 0 -1 0 2204999999 0.0 0.0 0.0 0)
- (list 2205000000 0 0 999 1.0 0.0 0.0 0)
- (list 2205001000 0 1085232704 (- big-file-framples 1) 1.0 0.0 0.0 0)
- (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger pad: ~A" (edit-tree)))
- (revert-sound)
-
- (pad-channel (* (floor *clm-srate*) 50000) 100)
- (if (fneq (sample (+ (* (floor *clm-srate*) 50000) 10)) 0.0)
- (snd-display #__line__ ";bigger pad samp: ~A" (sample (+ (* (floor *clm-srate*) 50000) 10))))
- (if (not (= (framples) (+ big-file-framples 100)))
- (snd-display #__line__ ";bigger pad framples: ~A (~A)" (framples) (+ big-file-framples 100)))
- (map-channel (lambda (y) (+ y .2)) (* (floor *clm-srate*) 50000) 10)
- (if (fneq (sample (+ (* (floor *clm-srate*) 50000) 1)) 0.2) (snd-display #__line__ ";bigger map samp: ~A" (sample (+ (* (floor *clm-srate*) 50000) 1))))
- (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
- (list 2205000000 1 0 9 1.0 0.0 0.0 0)
- (list 2205000010 -1 10 99 0.0 0.0 0.0 0)
- (list 2205000100 0 2205000000 (- big-file-framples 1) 1.0 0.0 0.0 0)
- (list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger map: ~A" (edit-tree)))
- (save-edit-history "hiho.scm")
- (revert-sound)
-
- (set! sfile ind)
- (load (string-append cwd "hiho.scm"))
+ (snd-display ";bigger set tree: ~A" (edit-tree)))
+ (let ((new-vals (channel->float-vector (- (* (floor *clm-srate*) 50000) 50) 200)))
+ (do ((i 50 (+ i 1))) ((= i 150)) (set! (old-vals i) 1.0))
+ (if (not (vequal new-vals old-vals)) (snd-display ";bigger set ~A ~A" old-vals new-vals))))
+ (env-channel (make-env '(0 0 1 1) :length (* (floor *clm-srate*) 60000)) 1000 (* (floor *clm-srate*) 60000))
+ (if (not (fieql (edit-tree) (list (list 0 0 0 999 0.5 0.0 0.0 0)
+ (list 1000 0 1000 2204999999 0.5 1.12130420080871e-17 0.83333295583725 1)
+ (list 2205000000 1 0 99 1.0 0.83333295583725 0.833333015441895 1)
+ (list 2205000100 0 2205000100 2646000999 0.5 0.833333015441895 1.0 1)
+ (list 2646001000 0 2646001000 (- big-file-framples 1) 0.5 0.0 0.0 0)
+ (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger with env: ~A" (edit-tree)))
+ (revert-sound ind)
+ (env-channel (make-env '(0 0 1 1 2 0) :length 101) (* (floor *clm-srate*) 50000) 100)
+ (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
+ (list 2205000000 0 2205000000 2205000050 1.0 4.47034825823422e-10 1.0 2)
+ (list 2205000051 0 2205000051 2205000099 1.0 0.979591846466064 -5.55111512312578e-17 2)
+ (list 2205000100 0 2205000100 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger short env: ~A" (edit-tree)))
+ (let ((r (make-sampler (+ 75 (* (floor *clm-srate*) 50000))))
+ (v (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (read-sample r)))
+ (if (not (vequal v (float-vector -0.021 -0.020 -0.020 -0.019 -0.018 -0.017 -0.016 -0.016 -0.015 -0.014)))
+ (snd-display ";bigger short env vals: ~A" v)))
+ (revert-sound)
+
+ (let ((v (channel->float-vector (+ 75 (* (floor *clm-srate*) 50000)) 10)))
+ (if (not (vequal v (float-vector -0.042 -0.043 -0.044 -0.045 -0.045 -0.045 -0.045 -0.045 -0.045 -0.046)))
+ (snd-display ";bigger no env vals: ~A" v)))
+ (scale-to 1.0)
+ (if (fneq (maxamp) 1.0) (snd-display ";bigger scale-to 1.0 maxamp: ~A" (maxamp)))
+ (set! (sample (* (floor *clm-srate*) 51000)) 0.0)
+ (if (not (fieql (edit-tree) (list (list 0 0 0 2249099999 1.18574941158295 0.0 0.0 0)
+ (list 2249100000 1 0 0 1.0 0.0 0.0 0)
+ (list 2249100001 0 2249100001 (- big-file-framples 1) 1.18574941158295 0.0 0.0 0)
+ (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger set 0 samp: ~A" (edit-tree)))
+ (if (fneq (sample (* (floor *clm-srate*) 51000)) 0.0) (snd-display ";bigger 0 samp: ~A" (sample (* (floor *clm-srate*) 51000))))
+ (delete-samples (* (floor *clm-srate*) 52000) 100)
+ (if (not (= (framples) (- big-file-framples 100)))
+ (snd-display ";bigger deletion framples: ~A (~A)" (framples) (- big-file-framples 100)))
+ (if (not (= (framples ind 0 0) big-file-framples))
+ (snd-display ";bigger edpos deletion framples: ~A (~A)" (framples ind 0 0) big-file-framples))
+ (if (not (= (framples ind 0 (edit-position)) (- big-file-framples 100)))
+ (snd-display ";bigger ed deletion framples: ~A (~A)" (framples ind 0 (edit-position)) (- big-file-framples 100)))
+ (if (not (fieql (edit-tree) (list (list 0 0 0 2249099999 1.18574941158295 0.0 0.0 0)
+ (list 2249100000 1 0 0 1.0 0.0 0.0 0)
+ (list 2249100001 0 2249100001 2293199999 1.18574941158295 0.0 0.0 0)
+ (list 2293200000 0 2293200100 (- big-file-framples 1) 1.18574941158295 0.0 0.0 0)
+ (list (- big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger deletion: ~A" (edit-tree)))
+ (delete-samples 954624868 67)
+ (revert-sound)
+
+ (delete-samples 1000 (* (floor *clm-srate*) 50000))
+ (if (not (= (framples) (- big-file-framples (* (floor *clm-srate*) 50000)))) (snd-display ";bigger big deletion: ~A" (framples)))
+ (if (not (fieql (edit-tree) (list (list 0 0 0 999 1.0 0.0 0.0 0)
+ (list 1000 0 1085232704 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list 970200000 -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger big delete: ~A" (edit-tree)))
+ (insert-silence 0 (* (floor *clm-srate*) 50000))
+ (if (not (= (framples) big-file-framples)) (snd-display ";bigger silence: ~A (~A)" (framples) big-file-framples))
+ (if (not (fieql (edit-tree) (list (list 0 -1 0 2204999999 0.0 0.0 0.0 0)
+ (list 2205000000 0 0 999 1.0 0.0 0.0 0)
+ (list 2205001000 0 1085232704 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list big-file-framples -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger pad: ~A" (edit-tree)))
+ (revert-sound)
+
+ (pad-channel (* (floor *clm-srate*) 50000) 100)
+ (if (fneq (sample (+ (* (floor *clm-srate*) 50000) 10)) 0.0)
+ (snd-display ";bigger pad samp: ~A" (sample (+ (* (floor *clm-srate*) 50000) 10))))
+ (if (not (= (framples) (+ big-file-framples 100)))
+ (snd-display ";bigger pad framples: ~A (~A)" (framples) (+ big-file-framples 100)))
+ (map-channel (lambda (y) (+ y .2)) (* (floor *clm-srate*) 50000) 10)
+ (if (fneq (sample (+ (* (floor *clm-srate*) 50000) 1)) 0.2) (snd-display ";bigger map samp: ~A" (sample (+ (* (floor *clm-srate*) 50000) 1))))
+ (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
+ (list 2205000000 1 0 9 1.0 0.0 0.0 0)
+ (list 2205000010 -1 10 99 0.0 0.0 0.0 0)
+ (list 2205000100 0 2205000000 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger map: ~A" (edit-tree)))
+ (save-edit-history "hiho.scm")
+ (revert-sound)
+
+ (set! sfile ind)
+ (load (string-append cwd "hiho.scm"))
+ (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
+ (list 2205000000 1 0 9 1.0 0.0 0.0 0)
+ (list 2205000010 -1 10 99 0.0 0.0 0.0 0)
+ (list 2205000100 0 2205000000 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
+ (snd-display ";bigger reload: ~A" (edit-tree)))
+ (delete-file "hiho.scm")
+
+ (let* ((flt (make-one-zero 0.5 0.5))
+ (lvals (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10 ind 0 0)))
+ (if (not (vequal lvals (float-vector -0.006 0.052 0.103 0.146 0.182 0.210 0.232 0.249 0.262 0.272)))
+ (snd-display ";bigger (orig) vals: ~A" lvals))
+ (clm-channel flt (+ (* (floor *clm-srate*) 65000) 1000) 10)
(if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
(list 2205000000 1 0 9 1.0 0.0 0.0 0)
(list 2205000010 -1 10 99 0.0 0.0 0.0 0)
- (list 2205000100 0 2205000000 (- big-file-framples 1) 1.0 0.0 0.0 0)
+ (list 2205000100 0 2205000000 2866499899 1.0 0.0 0.0 0)
+ (list 2866500000 2 0 9 1.0 0.0 0.0 0)
+ (list 2866500010 0 2866499910 (- big-file-framples 1) 1.0 0.0 0.0 0)
(list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger reload: ~A" (edit-tree)))
- (delete-file "hiho.scm")
+ (snd-display ";bigger clm: ~A" (edit-tree)))
+ (if (not (vequal (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)
+ (float-vector -0.006 0.015 0.065 0.107 0.142 0.169 0.190 0.205 0.216 0.222)))
+ (snd-display ";bigger clm vals: ~A" (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)))
- (let ((flt (make-one-zero 0.5 0.5)))
- (let ((lvals (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10 ind 0 0)))
- (if (not (vequal lvals (float-vector -0.006 0.052 0.103 0.146 0.182 0.210 0.232 0.249 0.262 0.272)))
- (snd-display #__line__ ";bigger (orig) vals: ~A" lvals))
- (clm-channel flt (+ (* (floor *clm-srate*) 65000) 1000) 10)
- (if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
- (list 2205000000 1 0 9 1.0 0.0 0.0 0)
- (list 2205000010 -1 10 99 0.0 0.0 0.0 0)
- (list 2205000100 0 2205000000 2866499899 1.0 0.0 0.0 0)
- (list 2866500000 2 0 9 1.0 0.0 0.0 0)
- (list 2866500010 0 2866499910 (- big-file-framples 1) 1.0 0.0 0.0 0)
- (list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";bigger clm: ~A" (edit-tree)))
- (if (not (vequal (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)
- (float-vector -0.006 0.015 0.065 0.107 0.142 0.169 0.190 0.205 0.216 0.222)))
- (snd-display #__line__ ";bigger clm vals: ~A" (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)))
-
- (let ((r (make-readin big-file-name :start (+ 1000 (* (floor *clm-srate*) 65000))))
- (v (make-float-vector 10)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (v i) (readin r)))
- (if (not (vequal v lvals))
- (snd-display #__line__ ";bigger (orig) readin vals: ~A (~A)" v lvals)))))
- (revert-sound)
- (let ((found (scan-channel (lambda (y) (> y .5)) (* (floor *clm-srate*) 50000))))
- (if (not (equal? found (list #t 2205000925)))
- (snd-display #__line__ ";bigger scan: ~A" found)))
- (set! (squelch-update) #f)
- (close-sound ind))))
+ (let ((r (make-readin big-file-name :start (+ 1000 (* (floor *clm-srate*) 65000))))
+ (v (make-float-vector 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (readin r)))
+ (if (not (vequal v lvals))
+ (snd-display ";bigger (orig) readin vals: ~A (~A)" v lvals))))
+ (revert-sound)
+ (let ((found (scan-channel (lambda (y) (> y .5)) (* (floor *clm-srate*) 50000))))
+ (if (not (equal? found (list #t 2205000925)))
+ (snd-display ";bigger scan: ~A" found)))
+ (set! (squelch-update) #f)
+ (close-sound ind))))
(let ((ind (new-sound "fmv.snd" :header-type mus-next :sample-type mus-ldouble)))
(set! *sinc-width* 10)
(pad-channel 0 1000 ind)
(set! (sample 100) 0.5)
- (if (fneq (sample 100 ind 0 2) 0.5) (snd-display #__line__ ";sample 100 (2): ~A" (sample 100 ind 0 2)))
- (if (fneq (sample 100 ind 0 1) 0.0) (snd-display #__line__ ";sample 100 (1): ~A" (sample 100 ind 0 1)))
+ (if (fneq (sample 100 ind 0 2) 0.5) (snd-display ";sample 100 (2): ~A" (sample 100 ind 0 2)))
+ (if (fneq (sample 100 ind 0 1) 0.0) (snd-display ";sample 100 (1): ~A" (sample 100 ind 0 1)))
(src-channel 0.5)
(let ((mx (maxamp ind 0)))
- (if (fneq mx 0.5) (snd-display #__line__ ";src-channel max .5: ~A" mx)))
- (if (fneq (sample 200) 0.5) (snd-display #__line__ ";src-channel 0.5 200: ~A" (sample 200)))
+ (if (fneq mx 0.5) (snd-display ";src-channel max .5: ~A" mx)))
+ (if (fneq (sample 200) 0.5) (snd-display ";src-channel 0.5 200: ~A" (sample 200)))
(if (not (vequal (channel->float-vector 180 40 ind 0)
(float-vector 0.000 -0.000 0.000 0.001 -0.000 -0.003 0.000 0.007 -0.000 -0.012
0.000 0.020 -0.000 -0.033 0.000 0.054 -0.000 -0.100 -0.000 0.316
0.500 0.316 -0.000 -0.100 -0.000 0.054 0.000 -0.033 -0.000 0.020
0.000 -0.012 -0.000 0.007 0.000 -0.003 -0.000 0.001 0.000 -0.000)))
- (snd-display #__line__ ";src-channel 0.5 -> ~A" (channel->float-vector 180 40 ind 0)))
+ (snd-display ";src-channel 0.5 -> ~A" (channel->float-vector 180 40 ind 0)))
(undo 1 ind 0)
(src-channel 0.25)
(let ((mx (maxamp ind 0)))
- (if (fneq mx 0.5) (snd-display #__line__ ";src-channel max .25: ~A" mx)))
- (if (fneq (sample 400) 0.5) (snd-display #__line__ ";src-channel 0.25 400: ~A" (sample 400)))
+ (if (fneq mx 0.5) (snd-display ";src-channel max .25: ~A" mx)))
+ (if (fneq (sample 400) 0.5) (snd-display ";src-channel 0.25 400: ~A" (sample 400)))
(if (not (vequal (channel->float-vector 360 80 ind 0)
(float-vector 0.000 -0.000 -0.000 -0.000 0.000 0.000 0.001 0.001 -0.000 -0.002
-0.003 -0.003 0.000 0.004 0.007 0.006 -0.000 -0.008 -0.012 -0.010
@@ -31333,7 +30723,7 @@ EDITS: 2
0.054 0.034 0.000 -0.026 -0.033 -0.021 -0.000 0.016 0.020 0.013
0.000 -0.010 -0.012 -0.008 -0.000 0.006 0.007 0.004 0.000 -0.003
-0.003 -0.002 -0.000 0.001 0.001 0.000 0.000 -0.000 -0.000 -0.000)))
- (snd-display #__line__ ";src-channel 0.25 -> ~A" (channel->float-vector 360 80 ind 0)))
+ (snd-display ";src-channel 0.25 -> ~A" (channel->float-vector 360 80 ind 0)))
(undo 2 ind 0)
;(map-channel (let ((i 0)) (lambda (y) (let ((val (sin (* i (/ pi 100))))) (set! i (+ i 1)) (* .5 val)))))
(let ((e (make-env (list 0.0 0.0 1.0 1.0) :scaler (* .01 pi (- (framples) 1.0)) :length (framples))))
@@ -31341,7 +30731,7 @@ EDITS: 2
(for-each
(lambda (sr df)
(src-channel sr)
- (if (> (abs (- (maxamp ind 0) .5)) df) (snd-display #__line__ ";src-channel sine ~A: ~A" sr (maxamp ind 0)))
+ (if (> (abs (- (maxamp ind 0) .5)) df) (snd-display ";src-channel sine ~A: ~A" sr (maxamp ind 0)))
(if (integer? sr)
(let ((r0 (make-sampler 0))
(r1 (make-sampler 0 ind 0 1 (- (edit-position) 1)))
@@ -31349,7 +30739,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 500))
(let ((diff (abs (- (r0) (r1)))))
- (if (> diff df) (snd-display #__line__ ";src-channel ~A diff ~D: ~A" sr i diff))
+ (if (> diff df) (snd-display ";src-channel ~A diff ~D: ~A" sr i diff))
(do ((j 1 (+ j 1)))
((= j sri))
(r1))))))
@@ -31358,8 +30748,8 @@ EDITS: 2
(let ((s1 (sample i ind 0 (edit-position)))
(s2 (sample (round (* sr i)) ind 0 (- (edit-position) 1)))
(s3 (sample i ind 0 1)))
- (if (> (abs (- s1 s2)) df) (snd-display #__line__ ";sample ~D src(~A): ~A ~A" i sr s1 s2))
- (if (fneq s3 0.0) (snd-display #__line__ ";sample ~D (1): ~A" i s3))))
+ (if (> (abs (- s1 s2)) df) (snd-display ";sample ~D src(~A): ~A ~A" i sr s1 s2))
+ (if (fneq s3 0.0) (snd-display ";sample ~D (1): ~A" i s3))))
(undo 1 ind 0))
(list 2.0 1.5 3.0 3.14)
(list 0.008 0.01 0.015 0.025))
@@ -31369,7 +30759,7 @@ EDITS: 2
(for-each
(lambda (sr df)
(src-channel sr)
- (if (> (abs (- (maxamp ind 0) orig-max)) df) (snd-display #__line__ ";src-channel oboe ~A: ~A ~A" sr orig-max (maxamp ind 0)))
+ (if (> (abs (- (maxamp ind 0) orig-max)) df) (snd-display ";src-channel oboe ~A: ~A ~A" sr orig-max (maxamp ind 0)))
(if (integer? sr)
(let ((r0 (make-sampler 0))
(r1 (make-sampler 0 ind 0 1 (- (edit-position) 1)))
@@ -31377,7 +30767,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 5000))
(let ((diff (abs (- (r0) (r1)))))
- (if (> diff df) (snd-display #__line__ ";src-channel oboe ~A diff ~D: ~A" sr i diff))
+ (if (> diff df) (snd-display ";src-channel oboe ~A diff ~D: ~A" sr i diff))
(do ((j 1 (+ j 1)))
((= j sri))
(r1))))))
@@ -31388,13 +30778,13 @@ EDITS: 2
(for-each
(lambda (sr df)
(src-channel sr)
- (if (> (abs (- (maxamp ind 0) orig-max)) df) (snd-display #__line__ ";src-channel oboe ~A: ~A ~A" sr orig-max (maxamp ind 0)))
+ (if (> (abs (- (maxamp ind 0) orig-max)) df) (snd-display ";src-channel oboe ~A: ~A ~A" sr orig-max (maxamp ind 0)))
(do ((i 0 (+ i 1)))
((= i 50))
(let* ((samp (* i 100))
(s1 (sample samp ind 0 (edit-position)))
(s2 (sample (floor (* sr samp)) ind 0 (- (edit-position) 1))))
- (if (> (abs (- s1 s2)) df) (snd-display #__line__ ";sample ~D oboe src(~A): ~A ~A" i sr s1 s2))))
+ (if (> (abs (- s1 s2)) df) (snd-display ";sample ~D oboe src(~A): ~A ~A" i sr s1 s2))))
(undo 1 ind 0)
(amp-envs-equal? ind 0 (edit-position) (+ 1 (edit-position)) .01))
(list 0.5 0.25 0.9 0.1)
@@ -31410,25 +30800,22 @@ EDITS: 2
(let ((ind (open-sound "oboe.snd")))
(for-each
(lambda (n)
- (let ((val (scan-channel (lambda (y)
- (let ((bigger (scan-channel (lambda (n5) (> n5 .1)))))
- bigger)))))
+ (let ((val (scan-channel (lambda (y) (scan-channel (lambda (n5) (> n5 .1)))))))
(if (not (eqv? val 0))
- (snd-display #__line__ ";scan-channel in scan-channel (opt ~A): ~A" n val)))
- (let ((hi (make-float-vector 3))
- (ho (make-float-vector 3)))
+ (snd-display ";scan-channel in scan-channel (opt ~A): ~A" n val)))
+ (let ((hi (make-float-vector 3)))
(fill-float-vector hi (if (scan-channel (lambda (y) (> y .1)))
1.0 0.0))
- (if (not (vequal hi (float-vector 1.0 1.0 1.0))) (snd-display #__line__ ";fill-float-vector with scan-channel (opt ~A): ~A" n hi)))
+ (if (not (vequal hi (float-vector 1.0 1.0 1.0))) (snd-display ";fill-float-vector with scan-channel (opt ~A): ~A" n hi)))
(let ((val (scan-channel (lambda (y) (scan-channel (lambda (n6) (> n6 .1)))))))
- (if (not (= val 0)) (snd-display #__line__ ";find with find: ~A" val)))
+ (if (not (= val 0)) (snd-display ";find with find: ~A" val)))
(let ((val (scan-channel (lambda (y) (scan-channel (lambda (n7) (> n7 .1)))))))
- (if (not (= val 0)) (snd-display #__line__ ";find with scan-channel: ~A" val)))
- (let ((mx (maxamp ind 0))
- (val (scan-channel (lambda (y) (map-channel (lambda (n) (* n 2.0))) #t))))
- (if (not (eqv? val 0)) (snd-display #__line__ ";scan-channel with map-channel: ~A" val))
- (if (fneq mx (/ (maxamp ind 0) 2)) (snd-display #__line__ ";scan+map max: ~A ~A" mx (maxamp ind 0)))
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";scan+map edit-pos: ~A" (edit-position ind 0)))
+ (if (not (= val 0)) (snd-display ";find with scan-channel: ~A" val)))
+ (let ((mx (maxamp ind 0)))
+ (let ((val (scan-channel (lambda (y) (map-channel (lambda (n) (* n 2.0))) #t))))
+ (if (not (eqv? val 0)) (snd-display ";scan-channel with map-channel: ~A" val)))
+ (if (fneq mx (/ (maxamp ind 0) 2)) (snd-display ";scan+map max: ~A ~A" mx (maxamp ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";scan+map edit-pos: ~A" (edit-position ind 0)))
(revert-sound ind)
(map-channel (let ((ctr 0))
(lambda (y)
@@ -31436,11 +30823,10 @@ EDITS: 2
(set! ctr 1)
y))
0 3)
- (if (fneq mx (maxamp ind 0)) (snd-display #__line__ ";map+map max 2: ~A ~A" mx (maxamp ind 0)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";map+map edit-pos: ~A" (edit-position ind 0)))
- (if (fneq mx (/ (maxamp ind 0 1) 2)) (snd-display #__line__ ";map+map max 1: ~A ~A" mx (maxamp ind 0 1)))
- (revert-sound ind))
- )
+ (if (fneq mx (maxamp ind 0)) (snd-display ";map+map max 2: ~A ~A" mx (maxamp ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";map+map edit-pos: ~A" (edit-position ind 0)))
+ (if (fneq mx (/ (maxamp ind 0 1) 2)) (snd-display ";map+map max 1: ~A ~A" mx (maxamp ind 0 1))))
+ (revert-sound ind))
(list 0 5))
(close-sound ind))
@@ -31450,7 +30836,7 @@ EDITS: 2
(let ((old-len (framples ind)))
(func beg dur)
(if (not (= (framples ind) len))
- (snd-display #__line__ ";(~A ~A ~A) with ~A -> ~A (~A)?" func beg dur old-len (framples ind) len))))
+ (snd-display ";(~A ~A ~A) with ~A -> ~A (~A)?" func beg dur old-len (framples ind) len))))
(list (lambda (beg dur) (env-channel '(0 0 1 1) beg dur))
(lambda (beg dur) (map-channel (lambda (y) (* y .5)) beg dur))
reverse-channel
@@ -31471,7 +30857,7 @@ EDITS: 2
(let ((old-len (framples ind)))
(pad-channel beg dur)
(if (not (= (framples ind) len))
- (snd-display #__line__ ";(pad-channel ~A ~A) with ~A -> ~A (~A)?" beg dur old-len (framples ind) len))))
+ (snd-display ";(pad-channel ~A ~A) with ~A -> ~A (~A)?" beg dur old-len (framples ind) len))))
(list 1000 60000 0 62000 62000 62004)
(list 1000 1000 1000 1 2 1)
(list 51828 61000 62000 62001 62003 62005))
@@ -31483,7 +30869,7 @@ EDITS: 2
(let ((old-len (framples ind)))
(func (+ old-len 100) dur)
(if (not (= (framples ind) len))
- (snd-display #__line__ ";(~A ~A) with ~A -> ~A (~A)?" func dur old-len (framples ind) len))))
+ (snd-display ";(~A ~A) with ~A -> ~A (~A)?" func dur old-len (framples ind) len))))
(list (lambda (beg dur) (env-channel '(0 0 1 1) beg dur))
reverse-channel
(lambda (beg dur) (scale-channel 2.0 beg dur))
@@ -31503,7 +30889,7 @@ EDITS: 2
(let ((len (floor (* 1.25 (framples)))))
(do ((i 0 (+ i 1)))
((= i 100))
- (case (if (zero? test-16) 3 (floor (random 10)))
+ (case (if (zero? test-16) 3 (random 10))
((0) (pad-channel (random len) (random 1000)))
((1) (env-channel '(0 0 1 1 2 0) (random len) (random 1000)))
((2) (env-sound '(0 0 1 1 2 0) (random len) (random 1000)))
@@ -31512,347 +30898,347 @@ EDITS: 2
((5) (src-channel (+ .9 (random .2)) (random len) (random 1000)))
((6) (ramp-channel (random 1.0) (random 1.0) (random len) (random 1000)))
((7) (reverse-channel (random len) (random 1000)))
- ((8) (let ((dur (max 2 (floor (random 100))))) (float-vector->channel (make-float-vector dur) (random len) dur)))
+ ((8) (let ((dur (max 2 (random 100)))) (float-vector->channel (make-float-vector dur) (random len) dur)))
((9) (map-channel (lambda (y) (* y 2.0)) (random (floor (/ (framples) 2))) (random 1000))))))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; insert zeros
(pad-channel 0 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe pad 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe pad 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25071))
- (snd-display #__line__ ";oboe pad 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
+ (snd-display ";oboe pad 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(pad-channel 25000 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe pad 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe pad 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe pad 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe pad 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(pad-channel 24971 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe pad 24971 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe pad 24971 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25071))
- (snd-display #__line__ ";oboe pad 24971 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
+ (snd-display ";oboe pad 24971 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(pad-channel 24972 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe pad 24972 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe pad 24972 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe pad 24972 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe pad 24972 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(pad-channel 65000 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe pad 65000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe pad 65000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe pad 65000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe pad 65000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; set sample
(revert-sound)
(set-sample 100 .1)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe set 100 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe set 100 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe set 100 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe set 100 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 100 .2)
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe set 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe set 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 100))
- (snd-display #__line__ ";oboe set 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 100))
+ (snd-display ";oboe set 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 100))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 25000 .1)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe set 25000 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe set 25000 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe set 25000 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe set 25000 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 25000 .2)
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe set 25000 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe set 25000 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 25000))
- (snd-display #__line__ ";oboe set 25000 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
+ (snd-display ";oboe set 25000 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 24971 .1)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe set 24971 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe set 24971 .1 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25368))
- (snd-display #__line__ ";oboe set 24971 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
+ (snd-display ";oboe set 24971 .1 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 24971 .2)
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe set 24971 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe set 24971 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe set 24971 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe set 24971 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-sample 24971 -.2)
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe set 24971 -.2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe set 24971 -.2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe set 24971 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe set 24971 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; delete-samples
(revert-sound)
(delete-samples 0 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe delete 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe delete 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24871))
- (snd-display #__line__ ";oboe delete 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24871))
+ (snd-display ";oboe delete 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24871))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(delete-samples 25000 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe delete 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe delete 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe delete 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe delete 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(delete-samples 24900 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe delete 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe delete 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25268))
- (snd-display #__line__ ";oboe delete 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25268))
+ (snd-display ";oboe delete 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25268))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; insert samples
(revert-sound)
(insert-samples 0 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe insert 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe insert 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25071))
- (snd-display #__line__ ";oboe insert 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
+ (snd-display ";oboe insert 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25071))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(insert-samples 25000 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe insert 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe insert 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe insert 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe insert 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(insert-samples 24971 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe insert 24971 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe insert 24971 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25071))
- (snd-display #__line__ ";oboe insert 24971 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25971))
+ (snd-display ";oboe insert 24971 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(insert-samples 0 100 (make-float-vector 100 0.2))
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe insert 0 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe insert 0 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 0))
- (snd-display #__line__ ";oboe insert 0 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
+ (snd-display ";oboe insert 0 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(insert-samples 25000 100 (make-float-vector 100 0.2))
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe insert 25000 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe insert 25000 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 25000))
- (snd-display #__line__ ";oboe insert 25000 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
+ (snd-display ";oboe insert 25000 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; set samples
(revert-sound)
(set-samples 0 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe change 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe change 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe change 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe change 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-samples 25000 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe change 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe change 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe change 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe change 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-samples 24900 100 (make-float-vector 100 0.1))
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe change 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe change 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25368))
- (snd-display #__line__ ";oboe change 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
+ (snd-display ";oboe change 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-samples 0 100 (make-float-vector 100 0.2))
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe change 0 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe change 0 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 0))
- (snd-display #__line__ ";oboe change 0 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
+ (snd-display ";oboe change 0 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(set-samples 25000 100 (make-float-vector 100 0.2))
(if (fneq (maxamp) 0.2)
- (snd-display #__line__ ";oboe change 25000 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
+ (snd-display ";oboe change 25000 100 .2 max: ~A (should be ~A)~%" (maxamp) 0.2))
(if (not (= (maxamp-position) 25000))
- (snd-display #__line__ ";oboe change 25000 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
+ (snd-display ";oboe change 25000 100 .2 max pos: ~A (should be ~A)~%" (maxamp-position) 25000))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; scale samples
(revert-sound)
(scale-channel 2.0)
(if (fneq (maxamp) 0.29449462890625)
- (snd-display #__line__ ";oboe scale 2 0 max: ~A (should be ~A)~%" (maxamp) 0.29449462890625))
+ (snd-display ";oboe scale 2 0 max: ~A (should be ~A)~%" (maxamp) 0.29449462890625))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe scale 2 0 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe scale 2 0 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel 0.0)
(if (fneq (maxamp) 0.0)
- (snd-display #__line__ ";oboe scale 0 0 max: ~A (should be ~A)~%" (maxamp) 0.0))
+ (snd-display ";oboe scale 0 0 max: ~A (should be ~A)~%" (maxamp) 0.0))
(if (not (= (maxamp-position) 0))
- (snd-display #__line__ ";oboe scale 0 0 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
+ (snd-display ";oboe scale 0 0 max pos: ~A (should be ~A)~%" (maxamp-position) 0))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel 0.1 0 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe scale .1 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe scale .1 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe scale .1 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe scale .1 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel -0.9 0 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe scale -.9 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe scale -.9 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe scale -.9 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe scale -.9 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel 0.1 25000 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe scale .1 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe scale .1 25000 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe scale .1 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe scale .1 25000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel -2.0 24900 100)
(if (fneq (maxamp) 0.29449462890625)
- (snd-display #__line__ ";oboe scale -2 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.29449462890625))
+ (snd-display ";oboe scale -2 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.29449462890625))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe scale -2 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe scale -2 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(scale-channel 0.1 24900 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe scale 0.1 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe scale 0.1 24900 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 25368))
- (snd-display #__line__ ";oboe scale 0.1 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
+ (snd-display ";oboe scale 0.1 24900 100 max pos: ~A (should be ~A)~%" (maxamp-position) 25368))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
;; ramp/xramp samples
(revert-sound)
(ramp-channel 0.0 1.0)
(if (fneq (maxamp) 0.091239139496063)
- (snd-display #__line__ ";oboe ramp 0 1 max: ~A (should be ~A)~%" (maxamp) 0.091239139496063))
+ (snd-display ";oboe ramp 0 1 max: ~A (should be ~A)~%" (maxamp) 0.091239139496063))
(if (not (= (maxamp-position) 35062))
- (snd-display #__line__ ";oboe ramp 0 1 max pos: ~A (should be ~A)~%" (maxamp-position) 35062))
+ (snd-display ";oboe ramp 0 1 max pos: ~A (should be ~A)~%" (maxamp-position) 35062))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(xramp-channel 0.0 1.0 3.0)
(if (fneq (maxamp) 0.074973157321056)
- (snd-display #__line__ ";oboe xramp 0 1 max: ~A (should be ~A)~%" (maxamp) 0.074973157321056))
+ (snd-display ";oboe xramp 0 1 max: ~A (should be ~A)~%" (maxamp) 0.074973157321056))
(if (not (= (maxamp-position) 35062))
- (snd-display #__line__ ";oboe xramp 0 1 max pos: ~A (should be ~A)~%" (maxamp-position) 35062))
+ (snd-display ";oboe xramp 0 1 max pos: ~A (should be ~A)~%" (maxamp-position) 35062))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(ramp-channel 0.0 -1.0 0 100)
(if (fneq (maxamp) 0.14724731445312)
- (snd-display #__line__ ";oboe ramp 0 -1 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
+ (snd-display ";oboe ramp 0 -1 0 100 max: ~A (should be ~A)~%" (maxamp) 0.14724731445312))
(if (not (= (maxamp-position) 24971))
- (snd-display #__line__ ";oboe ramp 0 -1 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
+ (snd-display ";oboe ramp 0 -1 0 100 max pos: ~A (should be ~A)~%" (maxamp-position) 24971))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(revert-sound)
(ramp-channel 1.0 9.0 10000 100)
(if (fneq (maxamp) 1.057239571003)
- (snd-display #__line__ ";oboe ramp 1 9 10000 100 max: ~A (should be ~A)~%" (maxamp) 1.057239571003))
+ (snd-display ";oboe ramp 1 9 10000 100 max: ~A (should be ~A)~%" (maxamp) 1.057239571003))
(if (not (= (maxamp-position) 10089))
- (snd-display #__line__ ";oboe ramp 1 9 10000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 10089))
+ (snd-display ";oboe ramp 1 9 10000 100 max pos: ~A (should be ~A)~%" (maxamp-position) 10089))
(if (fneq (abs (sample (maxamp-position))) (maxamp))
- (snd-display #__line__ ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
+ (snd-display ";oboe maxes: ~A ~A~%" (maxamp) (abs (sample (maxamp-position)))))
(close-sound ind))
@@ -31871,7 +31257,7 @@ EDITS: 2
(set! (sync ind2) (random 3))
(opt-test (random 22))))
(lambda args
- (snd-display #__line__ ";caught mus-error")
+ (snd-display ";caught mus-error")
#f))
(set! (squelch-update ind0 #t) #f)
(set! (squelch-update ind1 #t) #f)
@@ -31888,11 +31274,11 @@ EDITS: 2
(swap-channels)
(update-time-graph)
(let ((tm (- (real-time) start)))
- (if (> tm .1) (snd-display #__line__ ";swap-channels not optimized? ~A" tm)))
+ (if (> tm .1) (snd-display ";swap-channels not optimized? ~A" tm)))
(let ((new-mxs (maxamp ind #t)))
(if (or (fneq (car mxs) (cadr new-mxs))
(fneq (cadr mxs) (car new-mxs)))
- (snd-display #__line__ ";swap-channels amps: ~A -> ~A" mxs new-mxs)))
+ (snd-display ";swap-channels amps: ~A -> ~A" mxs new-mxs)))
(revert-sound ind)
(close-sound ind)))
(lambda args args)) ; away.snd may not exist
@@ -31923,20 +31309,20 @@ EDITS: 2
(m2 (add-mark 5 ind 1)))
(scale-channel 0.5)
(swap-channels)
- (if (not (= (mark-sample m0) 3)) (snd-display #__line__ ";swapped m0: ~A" (mark-sample m0)))
- (if (not (= (mark-sample m1) 4)) (snd-display #__line__ ";swapped m1: ~A" (mark-sample m1)))
- (if (not (= (mark-sample m2) 5)) (snd-display #__line__ ";swapped m2: ~A" (mark-sample m2)))
- (if (not (equal? (mark-home m0) (list ind 1))) (snd-display #__line__ ";mark-home m0: ~A" (mark-home m0)))
- (if (not (equal? (mark-home m1) (list ind 0))) (snd-display #__line__ ";mark-home m1: ~A" (mark-home m1)))
- (if (not (equal? (mark-home m2) (list ind 0))) (snd-display #__line__ ";mark-home m2: ~A" (mark-home m2)))
+ (if (not (= (mark-sample m0) 3)) (snd-display ";swapped m0: ~A" (mark-sample m0)))
+ (if (not (= (mark-sample m1) 4)) (snd-display ";swapped m1: ~A" (mark-sample m1)))
+ (if (not (= (mark-sample m2) 5)) (snd-display ";swapped m2: ~A" (mark-sample m2)))
+ (if (not (equal? (mark-home m0) (list ind 1))) (snd-display ";mark-home m0: ~A" (mark-home m0)))
+ (if (not (equal? (mark-home m1) (list ind 0))) (snd-display ";mark-home m1: ~A" (mark-home m1)))
+ (if (not (equal? (mark-home m2) (list ind 0))) (snd-display ";mark-home m2: ~A" (mark-home m2)))
(undo 1 ind 0)
(undo 1 ind 1)
- (if (not (= (mark-sample m0) 3)) (snd-display #__line__ ";swapped m0 2: ~A" (mark-sample m0)))
- (if (not (= (mark-sample m1) 4)) (snd-display #__line__ ";swapped m1 2: ~A" (mark-sample m1)))
- (if (not (= (mark-sample m2) 5)) (snd-display #__line__ ";swapped m2 2: ~A" (mark-sample m2)))
- (if (not (equal? (mark-home m0) (list ind 0))) (snd-display #__line__ ";mark-home m0 2: ~A" (mark-home m0)))
- (if (not (equal? (mark-home m1) (list ind 1))) (snd-display #__line__ ";mark-home m1 2: ~A" (mark-home m1)))
- (if (not (equal? (mark-home m2) (list ind 1))) (snd-display #__line__ ";mark-home m2 2: ~A" (mark-home m2))))
+ (if (not (= (mark-sample m0) 3)) (snd-display ";swapped m0 2: ~A" (mark-sample m0)))
+ (if (not (= (mark-sample m1) 4)) (snd-display ";swapped m1 2: ~A" (mark-sample m1)))
+ (if (not (= (mark-sample m2) 5)) (snd-display ";swapped m2 2: ~A" (mark-sample m2)))
+ (if (not (equal? (mark-home m0) (list ind 0))) (snd-display ";mark-home m0 2: ~A" (mark-home m0)))
+ (if (not (equal? (mark-home m1) (list ind 1))) (snd-display ";mark-home m1 2: ~A" (mark-home m1)))
+ (if (not (equal? (mark-home m2) (list ind 1))) (snd-display ";mark-home m2 2: ~A" (mark-home m2))))
(close-sound ind)
(delete-file "test.snd"))
@@ -31947,16 +31333,16 @@ EDITS: 2
(swap-channels ind 1 ind 2)
(let ((maxs (maxamp ind #t)))
(if (or (fneq (maxs 0) 0.5) (fneq (maxs 1) 0.125) (fneq (maxs 2) 0.25) (fneq (maxs 3) 0.0625))
- (snd-display #__line__ ";swap midchans: ~A" maxs))
+ (snd-display ";swap midchans: ~A" maxs))
(close-sound ind)))
- (let* ((ind0 (open-sound "oboe.snd"))
- (ind1 (open-sound "pistol.snd"))
- (mx0 (maxamp ind0 0))
- (mx1 (maxamp ind1 0)))
- (swap-channels ind0 0 ind1 0)
- (if (fneq (maxamp ind0 0) mx1) (snd-display #__line__ ";maxamp cross swap 0: ~A" (maxamp ind0 0)))
- (if (fneq (maxamp ind1 0) mx0) (snd-display #__line__ ";maxamp cross swap 1: ~A" (maxamp ind1 0)))
+ (let ((ind0 (open-sound "oboe.snd"))
+ (ind1 (open-sound "pistol.snd")))
+ (let ((mx0 (maxamp ind0 0))
+ (mx1 (maxamp ind1 0)))
+ (swap-channels ind0 0 ind1 0)
+ (if (fneq (maxamp ind0 0) mx1) (snd-display ";maxamp cross swap 0: ~A" (maxamp ind0 0)))
+ (if (fneq (maxamp ind1 0) mx0) (snd-display ";maxamp cross swap 1: ~A" (maxamp ind1 0))))
(close-sound ind1)
(if (not (string=? (display-edits) (string-append "
EDITS: 1
@@ -31969,7 +31355,7 @@ EDITS: 1
(at 0, cp->sounds[1][0:41622, 1.000]) [file: " cwd "pistol.snd[0]]
(at 41623, end_mark)
")))
- (snd-display #__line__ ";cross swap state: ~A" (display-edits)))
+ (snd-display ";cross swap state: ~A" (display-edits)))
(close-sound ind0))
(let ((ind (init-sound 1.0 10 1)))
@@ -32119,113 +31505,113 @@ EDITS: 1
(close-sound ind)
)
- (if (and all-args (= test-16 0))
- (let ((tries 256))
- (snd-display #__line__ ";framples: ~,2F ~,2F"
- (* 1.0 (/ (mus-sound-framples "1.snd") (mus-sound-framples "oboe.snd")))
- (* 1.0 (/ (mus-sound-framples "1.snd") (mus-sound-framples "1a.snd"))))
- (snd-display #__line__ ";~12T~A~28T~A~44T~A~56T(1/oboe, 1/1a)" "1.snd" "oboe.snd" "1a.snd")
- (for-each
- (lambda (name func)
- (let ((ind (open-sound "1.snd"))
- (start-time-1 (real-time)))
- (set! (squelch-update ind 0) #t)
- (do ((i 0 (+ i 1)))
- ((= i tries))
- (if (= (modulo i 10) 0) (revert-sound ind))
- (func ind i))
- (let ((mid-time-1 (real-time)))
- (revert-sound ind)
- (set! (squelch-update ind 0) #f)
- (close-sound ind)
- (let ((end-time-1 (real-time)))
- (let ((ind (open-sound "oboe.snd"))
- (start-time-2 (real-time)))
- (set! (squelch-update ind 0) #t)
- (do ((i 0 (+ i 1)))
- ((= i tries))
- (if (= (modulo i 10) 0) (revert-sound ind))
- (func ind i))
- (let ((mid-time-2 (real-time)))
- (revert-sound ind)
- (set! (squelch-update ind 0) #f)
- (close-sound ind)
- (let ((end-time-2 (real-time)))
- (let ((ind (open-sound "1a.snd"))
- (start-time (real-time)))
- (set! (squelch-update ind 0) #t)
- (do ((i 0 (+ i 1)))
- ((= i tries))
- (if (= (modulo i 10) 0) (revert-sound ind))
- (func ind i))
- (let ((mid-time (real-time)))
- (revert-sound ind)
- (set! (squelch-update ind 0) #f)
- (close-sound ind)
- (let ((end-time (real-time)))
- (snd-display #__line__ ";~A:~12T~A~18T~A~28T~A~34T~A~44T~A~50T~A~56T(~,2F, ~,2F)"
- name
-
- (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1))
- (hundred (- mid-time-2 start-time-2)) (hundred (- end-time-2 mid-time-2))
- (hundred (- mid-time start-time)) (hundred (- end-time mid-time))
-
- (* 1.0 (/ (+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1)))
- (max 1 (+ (hundred (- mid-time-2 start-time-2)) (hundred (- end-time-2 mid-time-2))))))
- (* 1.0 (/ (+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1)))
- (max 1 (+ (hundred (- mid-time start-time)) (hundred (- end-time mid-time)))))))))))))))))
-
- (list "scale" "set!" "env" "env-exp" "env-step" "delete" "insert" "pad"
- "mix-no-tag" "mix-tag" "mix-amp" "mix-scale" "src-2" "src"
- "filter" "filter-sym" "f10" "f10sym" "clm"
- "reverse"
- )
- (list
- (lambda (snd i)
- (scale-channel (* i .01)))
- (lambda (snd i)
- (set! (sample i) .5))
- (lambda (snd i)
- (env-channel '(0 0 1 1)))
- (lambda (snd i)
- (env-channel-with-base '(0 0 1 1) 32.0))
- (lambda (snd i)
- (env-channel-with-base '(0 0 1 1) 0.0))
- (lambda (snd i)
- (delete-sample (* 10 i)))
- (lambda (snd i)
- (insert-sample (* 10 i) .5))
- (lambda (snd i)
- (pad-channel (* 10 i) (* 10 i)))
- (lambda (snd i)
- (mix "pistol.snd" (* i 10) 0 snd 0 #f))
- (lambda (snd i)
- (mix "pistol.snd" (* i 10) 0 snd 0 #t))
- (lambda (snd i)
- (let ((mx (car (mix "pistol.snd" (* i 100)))))
- (set! (mix-amp mx) .01)))
- (lambda (snd i)
- (mix "pistol.snd" (* i 100))
- (scale-by .5)) ; scale-to before but that forces channel-maxamp which forces a full read which skews everything
- (lambda (snd i)
- (src-sound 2.0)
- (undo))
- (lambda (snd i)
- (src-sound 2.01)
- (undo))
- (lambda (snd i)
- (filter-channel (float-vector .25 .5 .25 .1) 4))
- (lambda (snd i)
- (filter-channel (float-vector .25 .5 .5 .25) 4))
- (lambda (snd i)
- (filter-channel (float-vector .1 .2 .1 .1 .1 .1 .1 .2 .1 .1) 10))
- (lambda (snd i)
- (filter-channel (float-vector .1 .1 .1 .1 .1 .1 .1 .1 .1 .1) 10))
- (lambda (snd i)
- (clm-channel (make-two-zero .5 .5)))
- (lambda (snd i)
- (reverse-channel (* i 10) (* i 100)))
- ))))
+ (when (and all-args (= test-16 0))
+ (let ((tries 256))
+ (snd-display ";framples: ~,2F ~,2F"
+ (* 1.0 (/ (mus-sound-framples "1.snd") (mus-sound-framples "oboe.snd")))
+ (* 1.0 (/ (mus-sound-framples "1.snd") (mus-sound-framples "1a.snd"))))
+ (snd-display ";~12T~A~28T~A~44T~A~56T(1/oboe, 1/1a)" "1.snd" "oboe.snd" "1a.snd")
+ (for-each
+ (lambda (name func)
+ (let ((ind (open-sound "1.snd"))
+ (start-time-1 (real-time)))
+ (set! (squelch-update ind 0) #t)
+ (do ((i 0 (+ i 1)))
+ ((= i tries))
+ (if (= (modulo i 10) 0) (revert-sound ind))
+ (func ind i))
+ (let ((mid-time-1 (real-time)))
+ (revert-sound ind)
+ (set! (squelch-update ind 0) #f)
+ (close-sound ind)
+ (let ((end-time-1 (real-time)))
+ (let ((ind (open-sound "oboe.snd"))
+ (start-time-2 (real-time)))
+ (set! (squelch-update ind 0) #t)
+ (do ((i 0 (+ i 1)))
+ ((= i tries))
+ (if (= (modulo i 10) 0) (revert-sound ind))
+ (func ind i))
+ (let ((mid-time-2 (real-time)))
+ (revert-sound ind)
+ (set! (squelch-update ind 0) #f)
+ (close-sound ind)
+ (let ((end-time-2 (real-time)))
+ (let ((ind (open-sound "1a.snd"))
+ (start-time (real-time)))
+ (set! (squelch-update ind 0) #t)
+ (do ((i 0 (+ i 1)))
+ ((= i tries))
+ (if (= (modulo i 10) 0) (revert-sound ind))
+ (func ind i))
+ (let ((mid-time (real-time)))
+ (revert-sound ind)
+ (set! (squelch-update ind 0) #f)
+ (close-sound ind)
+ (let ((end-time (real-time)))
+ (snd-display ";~A:~12T~A~18T~A~28T~A~34T~A~44T~A~50T~A~56T(~,2F, ~,2F)"
+ name
+
+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1))
+ (hundred (- mid-time-2 start-time-2)) (hundred (- end-time-2 mid-time-2))
+ (hundred (- mid-time start-time)) (hundred (- end-time mid-time))
+
+ (* 1.0 (/ (+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1)))
+ (max 1 (+ (hundred (- mid-time-2 start-time-2)) (hundred (- end-time-2 mid-time-2))))))
+ (* 1.0 (/ (+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1)))
+ (max 1 (+ (hundred (- mid-time start-time)) (hundred (- end-time mid-time)))))))))))))))))
+
+ (list "scale" "set!" "env" "env-exp" "env-step" "delete" "insert" "pad"
+ "mix-no-tag" "mix-tag" "mix-amp" "mix-scale" "src-2" "src"
+ "filter" "filter-sym" "f10" "f10sym" "clm"
+ "reverse"
+ )
+ (list
+ (lambda (snd i)
+ (scale-channel (* i .01)))
+ (lambda (snd i)
+ (set! (sample i) .5))
+ (lambda (snd i)
+ (env-channel '(0 0 1 1)))
+ (lambda (snd i)
+ (env-channel-with-base '(0 0 1 1) 32.0))
+ (lambda (snd i)
+ (env-channel-with-base '(0 0 1 1) 0.0))
+ (lambda (snd i)
+ (delete-sample (* 10 i)))
+ (lambda (snd i)
+ (insert-sample (* 10 i) .5))
+ (lambda (snd i)
+ (pad-channel (* 10 i) (* 10 i)))
+ (lambda (snd i)
+ (mix "pistol.snd" (* i 10) 0 snd 0 #f))
+ (lambda (snd i)
+ (mix "pistol.snd" (* i 10) 0 snd 0 #t))
+ (lambda (snd i)
+ (let ((mx (car (mix "pistol.snd" (* i 100)))))
+ (set! (mix-amp mx) .01)))
+ (lambda (snd i)
+ (mix "pistol.snd" (* i 100))
+ (scale-by .5)) ; scale-to before but that forces channel-maxamp which forces a full read which skews everything
+ (lambda (snd i)
+ (src-sound 2.0)
+ (undo))
+ (lambda (snd i)
+ (src-sound 2.01)
+ (undo))
+ (lambda (snd i)
+ (filter-channel (float-vector .25 .5 .25 .1) 4))
+ (lambda (snd i)
+ (filter-channel (float-vector .25 .5 .5 .25) 4))
+ (lambda (snd i)
+ (filter-channel (float-vector .1 .2 .1 .1 .1 .1 .1 .2 .1 .1) 10))
+ (lambda (snd i)
+ (filter-channel (float-vector .1 .1 .1 .1 .1 .1 .1 .1 .1 .1) 10))
+ (lambda (snd i)
+ (clm-channel (make-two-zero .5 .5)))
+ (lambda (snd i)
+ (reverse-channel (* i 10) (* i 100)))
+ ))))
(let ((ind (new-sound "fmv.snd" :size 50)))
(set! *sinc-width* 10)
@@ -32234,70 +31620,70 @@ EDITS: 1
;; -------- no-ops
(src-channel 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";src-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";src-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(src-sound 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";src-sound 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";src-sound 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(select-all)
(src-selection 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";src-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";src-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(filter-channel (float-vector 1.0))
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";filter-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";filter-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(env-channel '(0 1 1 1))
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";env-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";env-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(env-sound '(0 1 1 1))
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";env-sound 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";env-sound 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(env-selection '(0 1 1 1))
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";env-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";env-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(scale-channel 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";scale-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";scale-channel 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(scale-by 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";scale-by 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";scale-by 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
(scale-selection-by 1)
- (if (not (= (edit-position ind 0) edpos)) (snd-display #__line__ ";scale-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) edpos)) (snd-display ";scale-selection 1 as no-op: ~A ~A" edpos (edit-position ind 0)))
;; -------- other special cases
(src-channel -1)
(reverse-channel)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";src -1 and reverse diff: ~A" diff)))
+ (if diff (snd-display ";src -1 and reverse diff: ~A" diff)))
(set! (edit-position ind 0) edpos)
(scale-by 2)
(filter-channel (float-vector 2) 1 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 (+ 1 edpos) (+ edpos 2))))
- (if diff (snd-display #__line__ ";scale and filter 2 diff: ~A" diff)))
+ (if diff (snd-display ";scale and filter 2 diff: ~A" diff)))
;; -------- not no-ops!
(scale-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";edpos scale 1 diff: ~A" diff)))
- (if (fneq (maxamp ind 0) 0.5) (snd-display #__line__ ";scale 1 of original: ~A" (maxamp ind 0)))
+ (if diff (snd-display ";edpos scale 1 diff: ~A" diff)))
+ (if (fneq (maxamp ind 0) 0.5) (snd-display ";scale 1 of original: ~A" (maxamp ind 0)))
(if (= (edit-position ind 0) (+ edpos 2))
- (snd-display #__line__ ";edpos scl copy opted out?")
+ (snd-display ";edpos scl copy opted out?")
(undo))
(filter-channel (float-vector 1) 1 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";edpos flt 1 diff: ~A" diff)))
+ (if diff (snd-display ";edpos flt 1 diff: ~A" diff)))
(if (= (edit-position ind 0) (+ edpos 2))
- (snd-display #__line__ ";edpos flt copy opted out?")
+ (snd-display ";edpos flt copy opted out?")
(undo))
(env-channel '(0 1 1 1) 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";edpos env 1 diff: ~A" diff)))
+ (if diff (snd-display ";edpos env 1 diff: ~A" diff)))
(if (= (edit-position ind 0) (+ edpos 2))
- (snd-display #__line__ ";edpos env copy opted out?")
+ (snd-display ";edpos env copy opted out?")
(undo))
(src-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if (and diff (> (car diff) .0001)) (snd-display #__line__ ";edpos src 1 diff: ~A" diff)))
+ (if (and diff (> (car diff) .0001)) (snd-display ";edpos src 1 diff: ~A" diff)))
(if (= (edit-position ind 0) (+ edpos 2))
- (snd-display #__line__ ";edpos src copy opted out?")
+ (snd-display ";edpos src copy opted out?")
(undo))
(set! edpos (edit-position ind 0))
@@ -32306,50 +31692,50 @@ EDITS: 1
(scale-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";1 edpos scale 1 diff: ~A" diff)))
+ (if diff (snd-display ";1 edpos scale 1 diff: ~A" diff)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";scl len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";scl len edpos: ~A ~A" len (framples ind 0)))
(undo)
(filter-channel (float-vector 1) 1 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";1 edpos flt 1 diff: ~A" diff)))
+ (if diff (snd-display ";1 edpos flt 1 diff: ~A" diff)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";flt len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";flt len edpos: ~A ~A" len (framples ind 0)))
(undo)
(env-channel '(0 1 1 1) 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";1 edpos env 1 diff: ~A" diff)))
+ (if diff (snd-display ";1 edpos env 1 diff: ~A" diff)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";env len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";env len edpos: ~A ~A" len (framples ind 0)))
(undo)
(reverse-channel 0 #f ind 0 edpos)
(reverse-channel 0 #f ind 0)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";1 edpos rev 1 diff: ~A" diff)))
+ (if diff (snd-display ";1 edpos rev 1 diff: ~A" diff)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";rev len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";rev len edpos: ~A ~A" len (framples ind 0)))
(undo 2)
(src-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if (and diff (> (car diff) .0001)) (snd-display #__line__ ";1 edpos src 1 diff: ~A" diff)))
+ (if (and diff (> (car diff) .0001)) (snd-display ";1 edpos src 1 diff: ~A" diff)))
(if (> (abs (- (framples ind 0) len)) 2)
- (snd-display #__line__ ";src len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";src len edpos: ~A ~A" len (framples ind 0)))
(undo)
(smooth-channel 0 len ind 0 edpos)
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";smooth len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";smooth len edpos: ~A ~A" len (framples ind 0)))
(undo)
(clm-channel (make-one-zero 1.0 0.0) 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if diff (snd-display #__line__ ";1 edpos clm 1 diff: ~A" diff)))
+ (if diff (snd-display ";1 edpos clm 1 diff: ~A" diff)))
(if (not (= (framples ind 0) len))
- (snd-display #__line__ ";clm len edpos: ~A ~A" len (framples ind 0)))
+ (snd-display ";clm len edpos: ~A ~A" len (framples ind 0)))
(undo))
;; dur of 0 is ignored no matter what -- else I have a million special cases
@@ -32373,58 +31759,58 @@ EDITS: 1
(set! (samples 20 10 ind 0) (make-float-vector 10 -.75))
(pad-channel 0 10 ind 0 edpos)
- (if (not (= (framples ind 0) 20)) (snd-display #__line__ ";pad edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";pad edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 20)) (snd-display ";pad edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";pad edpos max: ~A" (maxamp ind 0)))
(undo)
(delete-samples 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 5)) (snd-display #__line__ ";del edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";del edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 5)) (snd-display ";del edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";del edpos max: ~A" (maxamp ind 0)))
(undo)
(set! (samples 5 5 ind 0 #f "set" 0 edpos) (make-float-vector 5 0.0))
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";set edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .04) (snd-display #__line__ ";set edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";set edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .04) (snd-display ";set edpos max: ~A" (maxamp ind 0)))
(undo)
(ramp-channel 0.0 1.0 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";rmp edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";rmp edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";rmp edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";rmp edpos max: ~A" (maxamp ind 0)))
(undo)
(xramp-channel 0.0 1.0 32.0 5 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";xrmp edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";xrmp edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";xrmp edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";xrmp edpos max: ~A" (maxamp ind 0)))
(undo)
(env-channel '(0 0 1 1) 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";env edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";env edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";env edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";env edpos max: ~A" (maxamp ind 0)))
(undo)
(smooth-channel 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";smooth edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";smooth edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";smooth edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";smooth edpos max: ~A" (maxamp ind 0)))
(undo)
(src-channel 0.5 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 16)) (snd-display #__line__ ";src edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";src edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 16)) (snd-display ";src edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";src edpos max: ~A" (maxamp ind 0)))
(undo)
(reverse-channel 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";rev edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";rev edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";rev edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";rev edpos max: ~A" (maxamp ind 0)))
(undo)
(filter-channel (float-vector .1 .2 .1) 3 0 5 ind 0 edpos #t) ; truncate
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";flt edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";flt edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";flt edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";flt edpos max: ~A" (maxamp ind 0)))
(undo)
(scale-channel 1.5 0 5 ind 0 edpos)
- (if (not (= (framples ind 0) 10)) (snd-display #__line__ ";scl edpos len: ~A" (framples ind 0)))
- (if (fneq (maxamp ind 0) .09) (snd-display #__line__ ";scl edpos max: ~A" (maxamp ind 0)))
+ (if (not (= (framples ind 0) 10)) (snd-display ";scl edpos len: ~A" (framples ind 0)))
+ (if (fneq (maxamp ind 0) .09) (snd-display ";scl edpos max: ~A" (maxamp ind 0)))
(undo)
(close-sound ind)))
@@ -32434,17 +31820,17 @@ EDITS: 1
(let ((edpos (edit-position ind 0)))
(delete-samples 5 10)
(delete-samples 15 5 ind 0 edpos)
- (if (not (= (framples ind 0) 15)) (snd-display #__line__ ";delete-samples edpos len: ~A" (framples ind 0)))
+ (if (not (= (framples ind 0) 15)) (snd-display ";delete-samples edpos len: ~A" (framples ind 0)))
(undo)
(float-vector->channel (make-float-vector 5 0.5) 15 5 ind 0 edpos)
- (if (not (= (framples ind 0) 20)) (snd-display #__line__ ";delete-samples edpos len: ~A" (framples ind 0)))
+ (if (not (= (framples ind 0) 20)) (snd-display ";delete-samples edpos len: ~A" (framples ind 0)))
(if (not (vequal (channel->float-vector 10 10) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5)))
- (snd-display #__line__ ";set samples edpos: ~A" (channel->float-vector 10 10)))
+ (snd-display ";set samples edpos: ~A" (channel->float-vector 10 10)))
(undo)
(env-channel '(0 0 1 1) 0 #f ind 0 edpos)
- (if (not (= (framples ind 0) 20)) (snd-display #__line__ ";env edpos len: ~A" (framples ind 0)))
+ (if (not (= (framples ind 0) 20)) (snd-display ";env edpos len: ~A" (framples ind 0)))
(if (not (vequal (channel->float-vector 0 20) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474 0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
- (snd-display #__line__ ";env edpos: ~A" (channel->float-vector 0 20)))
+ (snd-display ";env edpos: ~A" (channel->float-vector 0 20)))
(undo)
(close-sound ind)))
@@ -32459,7 +31845,7 @@ EDITS: 1
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
(if (not (vequal data vdata))
- (snd-display #__line__ ";filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
+ (snd-display ";filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo)))
(let ((v1 (make-float-vector 8))
(v2 (make-float-vector 5)))
@@ -32473,7 +31859,7 @@ EDITS: 1
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
(if (not (vequal data vdata))
- (snd-display #__line__ ";random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
+ (snd-display ";random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo))))
(let ((v1 (make-float-vector 18))
(v2 (make-float-vector 15)))
@@ -32487,7 +31873,7 @@ EDITS: 1
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
(if (not (vequal data vdata))
- (snd-display #__line__ ";big random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
+ (snd-display ";big random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo))))
(close-sound ind))
@@ -32498,13 +31884,13 @@ EDITS: 1
(src-channel -1.001)
(src-channel '(0 -1.0 1 -1.0) 0 #f ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-channel -1, distance: ~A" dis)))
+ (if (> dis .2) (snd-display ";src-channel -1, distance: ~A" dis)))
(undo 2)
(src-channel 1.001)
(src-channel '(0 1.0 1 1.0) 0 #f ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-channel 1, distance: ~A" dis)))
+ (if (> dis .2) (snd-display ";src-channel 1, distance: ~A" dis)))
(undo 2)
(for-each
@@ -32512,7 +31898,7 @@ EDITS: 1
(src-channel rate)
(src-channel (list 0 rate 1 rate) 0 #f ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-channel ~A, distance: ~A" rate dis)))
+ (if (> dis .2) (snd-display ";src-channel ~A, distance: ~A" rate dis)))
(undo 2))
(list 2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
@@ -32520,13 +31906,13 @@ EDITS: 1
(src-sound -1.001)
(src-sound '(0 -1.0 1 -1.0) 1.0 ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-sound -1, distance: ~A" dis)))
+ (if (> dis .2) (snd-display ";src-sound -1, distance: ~A" dis)))
(undo 2)
(src-sound 1.001)
(src-sound '(0 1.0 1 1.0) 1.0 ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-sound 1, distance: ~A" dis)))
+ (if (> dis .2) (snd-display ";src-sound 1, distance: ~A" dis)))
(undo 2)
(for-each
@@ -32534,7 +31920,7 @@ EDITS: 1
(src-sound rate)
(src-sound (list 0 rate 1 rate) 1.0 ind 0 2)
(let ((dis (edit-distance ind 0 3 4)))
- (if (> dis .2) (snd-display #__line__ ";src-sound ~A, distance: ~A" rate dis)))
+ (if (> dis .2) (snd-display ";src-sound ~A, distance: ~A" rate dis)))
(undo 2))
(list 2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
@@ -32549,57 +31935,56 @@ EDITS: 1
(env-selection '(0 0.5 1 0.5))
(let ((data (channel->float-vector)))
(if (not (vequal data (float-vector .4 .4 .4 .2 .2 .2 .2 .2 .4 .4)))
- (snd-display #__line__ ";env-selection constant: ~A" data)))
+ (snd-display ";env-selection constant: ~A" data)))
(undo)
(let ((edpos (edit-position ind 0)))
(smooth-channel 10 10 ind 0)
(if (not (= (edit-position ind 0) edpos))
- (snd-display #__line__ ";smooth past end: ~A ~A" (edit-position ind 0) edpos))
-
- (let ((ctr 0))
- (map-channel (lambda (y) (set! ctr (+ ctr 1)) (or (> ctr 3) (* y 2)))))
- (if (not (= (framples ind 0) 3))
- (snd-display #__line__ ";map-channel -> #t at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.8 0.8 0.8)))
- (snd-display #__line__ ";map-channel #t result: ~A" (channel->float-vector))))
-
- (undo)
- (let ((ctr 0))
- (map-channel (lambda (y) (set! ctr (+ ctr 1)) (if (= ctr 3) (make-float-vector 5 .1) (* y .5)))))
- (if (not (= (framples ind 0) 14))
- (snd-display #__line__ ";map-channel -> float-vector at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.200 0.200 0.200)))
- (snd-display #__line__ ";map-channel float-vector result: ~A" (channel->float-vector))))
-
- (undo)
- (let ((data (make-float-vector 2 0.0)))
- (map-channel (lambda (y) (float-vector-set! data 0 y) data)))
- (if (not (= (framples ind 0) 20))
- (snd-display #__line__ ";map-channel -> float-vector: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000)))
- (snd-display #__line__ ";map-channel float-vector result: ~A" (channel->float-vector))))
+ (snd-display ";smooth past end: ~A ~A" (edit-position ind 0) edpos)))
- (undo))
+ (let ((ctr 0))
+ (map-channel (lambda (y) (set! ctr (+ ctr 1)) (or (> ctr 3) (* y 2)))))
+ (if (not (= (framples ind 0) 3))
+ (snd-display ";map-channel -> #t at 3: ~A" (framples ind 0))
+ (if (not (vequal (channel->float-vector) (float-vector 0.8 0.8 0.8)))
+ (snd-display ";map-channel #t result: ~A" (channel->float-vector))))
+
+ (undo)
+ (let ((ctr 0))
+ (map-channel (lambda (y) (set! ctr (+ ctr 1)) (if (= ctr 3) (make-float-vector 5 .1) (* y .5)))))
+ (if (not (= (framples ind 0) 14))
+ (snd-display ";map-channel -> float-vector at 3: ~A" (framples ind 0))
+ (if (not (vequal (channel->float-vector) (float-vector 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.200 0.200 0.200)))
+ (snd-display ";map-channel float-vector result: ~A" (channel->float-vector))))
+
+ (undo)
+ (let ((data (make-float-vector 2 0.0)))
+ (map-channel (lambda (y) (float-vector-set! data 0 y) data)))
+ (if (not (= (framples ind 0) 20))
+ (snd-display ";map-channel -> float-vector: ~A" (framples ind 0))
+ (if (not (vequal (channel->float-vector) (float-vector 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000)))
+ (snd-display ";map-channel float-vector result: ~A" (channel->float-vector))))
+ (undo)
(set! (amp-control ind) 2.0)
(apply-controls ind 1 0)
- (if (> (abs (- (maxamp ind 0) .8)) .01) (snd-display #__line__ ";apply-controls 10: ~A" (channel->float-vector)))
+ (if (> (abs (- (maxamp ind 0) .8)) .01) (snd-display ";apply-controls 10: ~A" (channel->float-vector)))
(undo)
(set! (amp-control ind) 2.0)
(apply-controls ind 1 5)
(if (not (vequal (channel->float-vector 0 5) (float-vector 0.4 0.4 0.4 0.4 0.4)))
- (snd-display #__line__ ";apply controls from 5: ~A" (channel->float-vector)))
- (if (ffneq (sample 5) .8) (snd-display #__line__ ";apply-controls at 5: ~A" (sample 5)))
+ (snd-display ";apply controls from 5: ~A" (channel->float-vector)))
+ (if (ffneq (sample 5) .8) (snd-display ";apply-controls at 5: ~A" (sample 5)))
(let ((tag (catch 'no-such-edit
(lambda ()
(save-sound-as "nope.snd" :edit-position 21))
(lambda args (car args)))))
- (if (not (eq? tag 'no-such-edit)) (snd-display #__line__ ";save-sound-as at bad edpos: ~A" tag)))
+ (if (not (eq? tag 'no-such-edit)) (snd-display ";save-sound-as at bad edpos: ~A" tag)))
(let ((tag (catch 'no-such-file
(lambda ()
(channel-amp-envs "/baddy/hiho"))
(lambda args (car args)))))
- (if (not (eq? tag 'no-such-file)) (snd-display #__line__ ";channel-amp-envs bad file: ~A" tag)))
+ (if (not (eq? tag 'no-such-file)) (snd-display ";channel-amp-envs bad file: ~A" tag)))
(close-sound ind))
@@ -32608,25 +31993,25 @@ EDITS: 1
(let ((ctr 0))
(map-channel (lambda (y) (or (> (set! ctr (+ ctr 1)) 3) (* y 2)))))
(if (not (= (framples ind 0) 3))
- (snd-display #__line__ ";map-channel oboe -> #t at 3: ~A" (framples ind 0))
+ (snd-display ";map-channel oboe -> #t at 3: ~A" (framples ind 0))
(if (not (vequal (channel->float-vector) (float-vector 0.0 -.001 -.001)))
- (snd-display #__line__ ";map-channel #t oboe result: ~A" (channel->float-vector))))
+ (snd-display ";map-channel #t oboe result: ~A" (channel->float-vector))))
(undo)
(let ((ctr 0))
(map-channel (lambda (y) (if (= (set! ctr (+ ctr 1)) 3) (make-float-vector 5 .1) (* y .5)))))
- (if (not (= (framples ind 0) (+ 50828 4)))
- (snd-display #__line__ ";map-channel oboe -> float-vector at 3: ~A" (framples ind 0))
+ (if (not (= (framples ind 0) 50832))
+ (snd-display ";map-channel oboe -> float-vector at 3: ~A" (framples ind 0))
(if (not (vequal (channel->float-vector 0 10) (float-vector 0.000 -0.000 0.100 0.100 0.100 0.100 0.100 -0.000 -0.000 -0.000)))
- (snd-display #__line__ ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
+ (snd-display ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
(undo)
(let ((data (make-float-vector 2 0.0)))
(map-channel (lambda (y) (set! (data 0) y) data)))
- (if (not (= (framples ind 0) (* 2 50828)))
- (snd-display #__line__ ";map-channel oboe -> float-vector: ~A" (framples ind 0))
+ (if (not (= (framples ind 0) 101656))
+ (snd-display ";map-channel oboe -> float-vector: ~A" (framples ind 0))
(if (not (vequal (channel->float-vector 0 10) (float-vector 0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.0)))
- (snd-display #__line__ ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
+ (snd-display ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
(revert-sound)
(close-sound ind))
@@ -32642,7 +32027,7 @@ EDITS: 1
(let ((mxs1 (maxamp ind #t)))
(if (or (fneq (car mxs) (* 2.0 (car mxs1)))
(fneq (cadr mxs) (* 2.0 (cadr mxs1))))
- (snd-display #__line__ ";env-sound sync'd maxes: ~A -> ~A" mxs mxs1)))
+ (snd-display ";env-sound sync'd maxes: ~A -> ~A" mxs mxs1)))
(undo 1))
(close-sound ind))
@@ -32660,15 +32045,15 @@ EDITS: 1
(let ((mxs1 (maxamp ind #t)))
(if (or (fneq (car mxs) (* 2.0 (car mxs1)))
(fneq (cadr mxs) (* 2.0 (cadr mxs1))))
- (snd-display #__line__ ";env-sound sync'd maxes buf: ~A -> ~A" mxs mxs1)))
+ (snd-display ";env-sound sync'd maxes buf: ~A -> ~A" mxs mxs1)))
(undo 1))
(let ((name (file-name ind)))
(if (not (= (srate ind) *default-output-srate*))
- (snd-display #__line__ ";new-sound default srate: ~A ~A" (srate ind) *default-output-srate*))
+ (snd-display ";new-sound default srate: ~A ~A" (srate ind) *default-output-srate*))
(close-sound ind)
- (if (not (file-exists? name))
- (snd-display #__line__ ";new-sound temp? ~A" name)
- (delete-file name))))
+ (if (file-exists? name)
+ (delete-file name)
+ (snd-display ";new-sound temp? ~A" name))))
(let ((ind (new-sound "test.snd" :size 40000)))
(let ((gen (make-triangle-wave 10.0 0.5)))
@@ -32682,7 +32067,7 @@ EDITS: 1
(let ((dist (channel-distance ind 0 ind1 0)))
(if (> dist 0.5)
- (snd-display #__line__ ";src 2/2.0001: ~A" dist)))
+ (snd-display ";src 2/2.0001: ~A" dist)))
(close-sound ind)
(close-sound ind1)))
@@ -32696,7 +32081,7 @@ EDITS: 1
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
-0.05016523320247118 0.02716944826115516 -0.01652926966015632)))
- (snd-display #__line__ ";src 2, 10 3 10: ~A" v)))
+ (snd-display ";src 2, 10 3 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 10)))
@@ -32704,7 +32089,7 @@ EDITS: 1
(src-channel 2.0)
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";src 2, 10 2 10: ~A" v)))
+ (snd-display ";src 2, 10 2 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 10)))
@@ -32712,7 +32097,7 @@ EDITS: 1
(src-channel 2.0)
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";src 2, 10 0 10: ~A" v)))
+ (snd-display ";src 2, 10 0 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 11)))
@@ -32721,7 +32106,7 @@ EDITS: 1
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
-0.05016523320247118 0.02716944826115516 -0.01652926966015632 0.01022512563738671)))
- (snd-display #__line__ ";src 2, 11 3 10: ~A" v)))
+ (snd-display ";src 2, 11 3 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 11)))
@@ -32729,7 +32114,7 @@ EDITS: 1
(src-channel 2.0)
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";src 2, 11 2 10: ~A" v)))
+ (snd-display ";src 2, 11 2 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 11)))
@@ -32737,7 +32122,7 @@ EDITS: 1
(src-channel 2.0)
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";src 2, 11 0 10: ~A" v)))
+ (snd-display ";src 2, 11 0 10: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 40)))
@@ -32762,7 +32147,7 @@ EDITS: 1
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector -0.05103248958541851 0.1584755057631961 0.1584755057631961
-0.05103248958541851 0.02854464095499105 -0.01828991864619797 0.01222560572178551 -0.008180460967128276 0.0)))
- (snd-display #__line__ ";src 2, 15 3 11: ~A" v)))
+ (snd-display ";src 2, 15 3 11: ~A" v)))
(close-sound res))
(let ((res (new-sound :size 15)))
@@ -32770,7 +32155,7 @@ EDITS: 1
(src-channel 2.0)
(let ((v (channel->float-vector)))
(if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";src 2, 15 0 11: ~A" v)))
+ (snd-display ";src 2, 15 0 11: ~A" v)))
(close-sound res))
(set! *sinc-width* old-width))
@@ -32939,7 +32324,7 @@ EDITS: 1
(let ((dist (channel-distance ind 0 ind1 0)))
(if (> dist 0.5)
- (snd-display #__line__ ";src 0.5/0.5001: ~A" dist)))
+ (snd-display ";src 0.5/0.5001: ~A" dist)))
(close-sound ind)
(close-sound ind1)))
@@ -32960,103 +32345,98 @@ EDITS: 1
(let ((documentation "draw an arrow pointing (from the left) at the point (x0 y0)"))
(lambda (x0 y0 size snd chn cr)
(let ((points (make-vector 8)))
- (define (point i x y)
- (set! (points (* i 2)) x)
- (set! (points (+ (* i 2) 1)) y))
- (define (arrow-head x y)
+
+ (let ((x x0) (y y0))
+ (define (point i x y)
+ (set! (points (* i 2)) x)
+ (set! (points (+ (* i 2) 1)) y))
(point 0 x y)
(point 1 (- x (* 2 size)) (- y size))
(point 2 (- x (* 2 size)) (+ y size))
(point 3 x y)
(fill-polygon points snd chn time-graph cr))
- (arrow-head x0 y0)
+
(fill-rectangle (- x0 (* 4 size))
(floor (- y0 (* .4 size)))
(* 2 size)
(floor (* .8 size))
snd chn time-graph #f cr)))))
- (if with-gui
- (begin
-
- (require snd-musglyphs.scm)
- (hook-push after-graph-hook (lambda (hook) (display-previous-edits (hook 'snd) (hook 'chn))))
- (hook-push lisp-graph-hook
- (lambda (hook)
- (let ((snd (hook 'snd))
- (chn (hook 'chn)))
- (set! (hook 'result)
- (lambda ()
- (let ((cr (make-cairo (car (channel-widgets snd chn)))))
- (draw-string "hi"
- (x->position .5 snd chn lisp-graph)
- (y->position .5 snd chn lisp-graph)
- snd chn lisp-graph cr)
- (free-cairo cr)))))))
- (let ((ind (open-sound "oboe.snd"))
- (wids (channel-widgets))
- (wids1 (channel-widgets (selected-sound)))
- (wids2 (channel-widgets (selected-sound) (selected-channel))))
- (do ((i 1 (+ i 1)))
- ((= i 4))
- (scale-by 0.5)
- (set! (x-bounds) (list 0 (* i .3))))
- (revert-sound ind)
- (draw-bass-clef 100 100 100 0 ind 0)
- (update-time-graph ind 0)
- (draw-fermata 200 100 60 0 ind 0)
- (let ((cr (make-cairo (car (channel-widgets ind 0)))))
- (draw-line 100 100 200 200 ind 0 time-graph cr)
- (draw-dot 300 300 10 ind 0 time-graph cr)
- (draw-string "hiho" 20 20 ind 0 time-graph cr)
- (draw-dots #(25 25 50 50 100 100) 10 ind 0 time-graph cr)
- (-> 100 50 10 ind 0 cr)
- (fill-rectangle 20 20 100 100 ind 0 time-graph #f cr)
- (free-cairo cr))
- (make-bezier 0 0 20 20 40 30 60 10 10)
- (update-time-graph ind 0)
- ;(fill-rectangle 20 20 100 100 ind 0 time-graph #t)
- (set! (hook-functions after-graph-hook) ())
- (set! (hook-functions lisp-graph-hook) ())
-
- (set! (hook-functions lisp-graph-hook) ())
- (let ((ind (open-sound "oboe.snd")))
- (set! (time-graph? ind 0) #f)
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
- (update-lisp-graph)
- (hook-push lisp-graph-hook (lambda (hook)
- (set! (hook 'result) (list *basic-color* *zoom-color* *data-color* *selected-data-color* *mix-color*))))
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
- (update-lisp-graph)
- (set! (hook-functions lisp-graph-hook) ())
- (close-sound ind))
-
- (let* ((ind1 (open-sound "2.snd"))
- (wids3 (channel-widgets ind1 0))
- (wids4 (channel-widgets ind1 1)))
- (if (or (not (pair? wids))
- (not (pair? wids3))
- (and (provided? 'snd-motif)
- (not (= (length wids1) 11 (length wids2)))))
- (snd-display #__line__ ";channel-widgets confused: ~A ~A ~A ~A ~A" wids wids1 wids2 wids3 wids4))
- (hide-widget (car (channel-widgets)))
- (show-widget (car (channel-widgets)))
- (close-sound ind1))
- (close-sound ind))))
-
- (if with-gui
- (begin
- (start-enveloping)
- (let ((nind (open-sound "oboe.snd")))
- (if (not (equal? (channel-envelope nind 0) (list 0.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";channel-envelope: ~A?" (channel-envelope nind 0)))
- (set! (channel-envelope nind 0) (list 0 0 1 1 2 0))
- (if (not (equal? (channel-envelope nind 0) (list 0 0 1 1 2 0)))
- (snd-display #__line__ ";set channel-envelope: ~A?" (channel-envelope nind 0)))
- (close-sound nind)
- (stop-enveloping))
- ))
- (reset-all-hooks)
- )
+ (when with-gui
+ (require snd-musglyphs.scm)
+ (hook-push after-graph-hook (lambda (hook) (display-previous-edits (hook 'snd) (hook 'chn))))
+ (hook-push lisp-graph-hook
+ (lambda (hook)
+ (let ((snd (hook 'snd))
+ (chn (hook 'chn)))
+ (set! (hook 'result)
+ (lambda ()
+ (let ((cr (make-cairo (car (channel-widgets snd chn)))))
+ (draw-string "hi"
+ (x->position .5 snd chn lisp-graph)
+ (y->position .5 snd chn lisp-graph)
+ snd chn lisp-graph cr)
+ (free-cairo cr)))))))
+ (let ((ind (open-sound "oboe.snd"))
+ (wids (channel-widgets))
+ (wids1 (channel-widgets (selected-sound)))
+ (wids2 (channel-widgets (selected-sound) (selected-channel))))
+ (do ((i 1 (+ i 1)))
+ ((= i 4))
+ (scale-by 0.5)
+ (set! (x-bounds) (list 0 (* i .3))))
+ (revert-sound ind)
+ (draw-bass-clef 100 100 100 0 ind 0)
+ (update-time-graph ind 0)
+ (draw-fermata 200 100 60 0 ind 0)
+ (let ((cr (make-cairo (car (channel-widgets ind 0)))))
+ (draw-line 100 100 200 200 ind 0 time-graph cr)
+ (draw-dot 300 300 10 ind 0 time-graph cr)
+ (draw-string "hiho" 20 20 ind 0 time-graph cr)
+ (draw-dots #(25 25 50 50 100 100) 10 ind 0 time-graph cr)
+ (-> 100 50 10 ind 0 cr)
+ (fill-rectangle 20 20 100 100 ind 0 time-graph #f cr)
+ (free-cairo cr))
+ (make-bezier 0 0 20 20 40 30 60 10 10)
+ (update-time-graph ind 0)
+ ;(fill-rectangle 20 20 100 100 ind 0 time-graph #t)
+ (set! (hook-functions after-graph-hook) ())
+ (set! (hook-functions lisp-graph-hook) ())
+
+ (set! (hook-functions lisp-graph-hook) ())
+ (let ((ind (open-sound "oboe.snd")))
+ (set! (time-graph? ind 0) #f)
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
+ (update-lisp-graph)
+ (hook-push lisp-graph-hook (lambda (hook)
+ (set! (hook 'result) (list *basic-color* *zoom-color* *data-color* *selected-data-color* *mix-color*))))
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
+ (update-lisp-graph)
+ (set! (hook-functions lisp-graph-hook) ())
+ (close-sound ind))
+
+ (let ((ind1 (open-sound "2.snd")))
+ (let ((wids3 (channel-widgets ind1 0))
+ (wids4 (channel-widgets ind1 1)))
+ (if (or (not (pair? wids))
+ (not (pair? wids3))
+ (and (provided? 'snd-motif)
+ (not (= (length wids1) 11 (length wids2)))))
+ (snd-display ";channel-widgets confused: ~A ~A ~A ~A ~A" wids wids1 wids2 wids3 wids4)))
+ (hide-widget (car (channel-widgets)))
+ (show-widget (car (channel-widgets)))
+ (close-sound ind1))
+ (close-sound ind))
+
+ (start-enveloping)
+ (let ((nind (open-sound "oboe.snd")))
+ (if (not (equal? (channel-envelope nind 0) (list 0.0 1.0 1.0 1.0)))
+ (snd-display ";channel-envelope: ~A?" (channel-envelope nind 0)))
+ (set! (channel-envelope nind 0) (list 0 0 1 1 2 0))
+ (if (not (equal? (channel-envelope nind 0) (list 0 0 1 1 2 0)))
+ (snd-display ";set channel-envelope: ~A?" (channel-envelope nind 0)))
+ (close-sound nind)
+ (stop-enveloping)))
+ (reset-all-hooks))
;;; ---------------- test 18: save and restore ----------------
@@ -33066,9 +32446,6 @@ EDITS: 1
(define* (clm-channel-test snd chn) ; edit-list->function wants this to be global??
(clm-channel (make-two-zero 1 -1) 0 #f snd chn #f #f "clm-channel-test"))
-(define* (make-v-mix snd chn)
- (mix-float-vector (float-vector .1 .2 .3) 100 snd chn #t "mix-float-vector (float-vector .1 .2 .3)"))
-
(define* (insert-float-vector v (beg 0) dur snd chn edpos)
(if (not (float-vector? v))
(error 'wrong-type-arg "insert-float-vector: ~A" v)
@@ -33129,47 +32506,45 @@ EDITS: 1
(bandpass (vector-ref bands i)
input)))))))
- (define (make-fdelay len pitch scaler)
- (let ((dly (make-delay len))
- (ssb (make-ssb-transposer 440.0 (* 440.0 pitch) 10)))
- (lambda (input)
- (delay dly (+ input (* scaler (ssb-transpose ssb (tap dly))))))))
-
(define (transposed-echo pitch scaler secs)
+ (define (make-fdelay len pitch scaler)
+ (let ((dly (make-delay len))
+ (ssb (make-ssb-transposer 440.0 (* 440.0 pitch) 10)))
+ (lambda (input)
+ (delay dly (+ input (* scaler (ssb-transpose ssb (tap dly))))))))
(map-channel (make-fdelay (round (* secs (srate))) pitch scaler)))
|#
- (define-macro (make-fdelay len pitch scaler)
- `(let ((body ())
- (closure (list (list 'dly (list 'make-delay ,len))))
- (old-freq 440.0)
- (new-freq (* 440.0 ,pitch))
- (pairs 10)
- (order 40)
- (bw 50.0))
- (let ((factor (/ (- new-freq old-freq) old-freq)))
- (do ((i 1 (+ i 4)))
- ((> i pairs))
- (let ((inner-body ())
- (n (+ 1 (min 3 (- pairs i)))))
- (do ((k 0 (+ k 1))) ; the inner loop is dividing up large sums for the optimizer's benefit (it can handle 4 at a time currently)
- ((= k n))
- (let ((aff (* (+ i k) old-freq))
- (bwf (* bw (+ 1.0 (/ (+ i k) (* 2 pairs)))))
- (ssb (string->symbol (format #f "s~D" (+ i k))))
- (flt (string->symbol (format #f "g~D" (+ i k)))))
- (set! closure (cons (list ssb (list 'make-ssb-am (* (+ i k) old-freq factor)))
- (cons (list flt (list 'make-bandpass (hz->radians (- aff bw)) (hz->radians (+ aff bw)) order))
- closure)))
- (set! inner-body (cons (list 'ssb-am ssb (list 'bandpass flt 'y)) inner-body))))
- (set! body (cons (append (list '+) inner-body) body))))
- (apply let closure
+ (define (transposed-echo pitch scaler secs)
+ (define-macro (make-fdelay len pitch scaler)
+ `(let ((body ())
+ (closure (list (list 'dly (list 'make-delay ,len))))
+ (old-freq 440.0)
+ (new-freq (* 440.0 ,pitch))
+ (pairs 10)
+ (order 40)
+ (bw 50.0))
+ (let ((factor (/ (- new-freq old-freq) old-freq)))
+ (do ((i 1 (+ i 4)))
+ ((> i pairs))
+ (let ((inner-body ())
+ (n (+ 1 (min 3 (- pairs i)))))
+ (do ((k 0 (+ k 1))) ; the inner loop is dividing up large sums for the optimizer's benefit (it can handle 4 at a time currently)
+ ((= k n))
+ (let ((aff (* (+ i k) old-freq))
+ (bwf (* bw (+ 1.0 (/ (+ i k) (* 2 pairs)))))
+ (ssb (string->symbol (format #f "s~D" (+ i k))))
+ (flt (string->symbol (format #f "g~D" (+ i k)))))
+ (set! closure (cons (list ssb (list 'make-ssb-am (* (+ i k) old-freq factor)))
+ (cons (list flt (list 'make-bandpass (hz->radians (- aff bw)) (hz->radians (+ aff bw)) order))
+ closure)))
+ (set! inner-body (cons (list 'ssb-am ssb (list 'bandpass flt 'y)) inner-body))))
+ (set! body (cons (append (list '+) inner-body) body))))
+ (apply let closure
`((lambda (y)
(+ y (delay dly (* ,,scaler (+ , at body))))))))))
-
- (define (transposed-echo pitch scaler secs)
(map-channel (make-fdelay (round (* secs (srate))) pitch scaler)))
-
+
(define (local-eq? a b)
(if (number? a)
(if (rational? a)
@@ -33205,7 +32580,7 @@ EDITS: 1
(lambda (hook)
(with-output-to-file (hook 'name)
(lambda ()
- (format #t ";this comment will be at the top of the saved state file.~%~%")
+ (format () ";this comment will be at the top of the saved state file.~%~%")
(set! (hook 'result) #t)))))
(if (file-exists? *save-state-file*) (delete-file *save-state-file*))
(save-state *save-state-file*)
@@ -33214,48 +32589,48 @@ EDITS: 1
(load (string-append cwd *save-state-file*))
(let ((ind (find-sound "oboe.snd")))
(if (not (sound? ind))
- (snd-display #__line__ ";can't restore oboe.snd from ~A?" *save-state-file*)
+ (snd-display ";can't restore oboe.snd from ~A?" *save-state-file*)
(begin
(if (or (> (abs (- (car old-bounds) (car (x-bounds ind 0)))) .05)
(> (abs (- (cadr old-bounds) (cadr (x-bounds ind 0)))) .05))
- (snd-display #__line__ ";save bounds: ~A" (x-bounds ind 0)))
+ (snd-display ";save bounds: ~A" (x-bounds ind 0)))
(if (not (= (length (marks ind 0)) 1))
- (snd-display #__line__ ";save marks: ~A (~A)?" (marks ind 0) *save-state-file*)
+ (snd-display ";save marks: ~A (~A)?" (marks ind 0) *save-state-file*)
(begin
(if (not (= (mark-sample (car (marks ind 0))) 122))
- (snd-display #__line__ ";save mark: ~A?" (mark-sample (car (marks ind 0)))))
+ (snd-display ";save mark: ~A?" (mark-sample (car (marks ind 0)))))
(if (not (= (edit-position ind 0) 1))
- (snd-display #__line__ ";save edit-position: ~A" (edit-position ind 0)))))
+ (snd-display ";save edit-position: ~A" (edit-position ind 0)))))
(if (not (equal? (edit-fragment 1 ind 0) (list "delete-samples 12 1" "delete" 12 1)))
- (snd-display #__line__ ";save edits: ~A" (edit-fragment 1 ind 0)))
+ (snd-display ";save edits: ~A" (edit-fragment 1 ind 0)))
(if (not (equal? (edit-tree ind 0)
(list (list 0 0 0 11 1.0 0.0 0.0 0) (list 12 0 13 50827 1.0 0.0 0.0 0) (list 50827 -2 0 0 0.0 0.0 0.0 0))))
- (snd-display #__line__ ";save edit tree: ~A" (edit-tree ind 0)))
- (if (or (not (number? (sound-property 'ho ind)))
- (not (= (sound-property 'ho ind) 1234)))
- (snd-display #__line__ ";sound-property saved: 1234 -> ~A" (sound-property 'ho ind)))
- (if (or (not (string? (sound-property :hi ind)))
- (not (string=? (sound-property :hi ind) "hi")))
- (snd-display #__line__ ";sound-property saved: hi -> ~A" (sound-property :hi ind)))
+ (snd-display ";save edit tree: ~A" (edit-tree ind 0)))
+ (if (not (and (number? (sound-property 'ho ind))
+ (= (sound-property 'ho ind) 1234)))
+ (snd-display ";sound-property saved: 1234 -> ~A" (sound-property 'ho ind)))
+ (if (not (and (string? (sound-property :hi ind))
+ (string=? (sound-property :hi ind) "hi")))
+ (snd-display ";sound-property saved: hi -> ~A" (sound-property :hi ind)))
(if (or (not (number? (channel-property :ha ind 0)))
(fneq (channel-property :ha ind 0) 3.14))
- (snd-display #__line__ ";channel-property saved: 3.14 -> ~A" (channel-property :ha ind 0)))
- (close-sound ind)))
- (set! (hook-functions after-save-state-hook) ())
- (set! (hook-functions before-save-state-hook) ())
-
- (let ((err (catch 'cannot-save
- (lambda ()
- (save-state "/bad/bad.save"))
- (lambda args 12345))))
- (if (not (= err 12345)) (snd-display #__line__ ";save-state err: ~A?" err)))
+ (snd-display ";channel-property saved: 3.14 -> ~A" (channel-property :ha ind 0)))
+ (close-sound ind))))
+ (set! (hook-functions after-save-state-hook) ())
+ (set! (hook-functions before-save-state-hook) ())
- (let ((err (catch 'cannot-save
- (lambda ()
- (save-listener "/bad/bad.save"))
- (lambda args 12345))))
- (if (not (= err 12345)) (snd-display #__line__ ";save-listener err: ~A?" err)))
- ))
+ (let ((err (catch 'cannot-save
+ (lambda ()
+ (save-state "/bad/bad.save"))
+ (lambda args 12345))))
+ (if (not (= err 12345)) (snd-display ";save-state err: ~A?" err)))
+
+ (let ((err (catch 'cannot-save
+ (lambda ()
+ (save-listener "/bad/bad.save"))
+ (lambda args 12345))))
+ (if (not (= err 12345)) (snd-display ";save-listener err: ~A?" err)))
+ )
(set! nind (open-sound "oboe.snd"))
(set! (sample 1) .5)
(delete-sample 100)
@@ -33266,21 +32641,21 @@ EDITS: 1
(revert-sound nind)
(set! sfile nind)
(load (string-append cwd "hiho.scm"))
- (if (not (equal? (edit-fragment 1) '("set-sample 1 0.5000" "set" 1 1))) (snd-display #__line__ ";save-edit-history 1: ~A?" (edit-fragment 1)))
- (if (not (equal? (edit-fragment 2) '("delete-samples 100 1" "delete" 100 1))) (snd-display #__line__ ";save-edit-history 2: ~A?" (edit-fragment 2)))
- (if (not (equal? (edit-fragment 3) '("insert-sample 10 0.5000" "insert" 10 1))) (snd-display #__line__ ";save-edit-history 3: ~A?" (edit-fragment 3)))
- (if (not (equal? (edit-fragment 4) '("scale-channel 2.000 0 #f" "scale" 0 50828))) (snd-display #__line__ ";save-edit-history 4: ~A?" (edit-fragment 4)))
- (if (not (equal? (edit-fragment 5) '("pad-channel" "zero" 100 20))) (snd-display #__line__ ";save-edit-history 5: ~A?" (edit-fragment 5)))
+ (if (not (equal? (edit-fragment 1) '("set-sample 1 0.5000" "set" 1 1))) (snd-display ";save-edit-history 1: ~A?" (edit-fragment 1)))
+ (if (not (equal? (edit-fragment 2) '("delete-samples 100 1" "delete" 100 1))) (snd-display ";save-edit-history 2: ~A?" (edit-fragment 2)))
+ (if (not (equal? (edit-fragment 3) '("insert-sample 10 0.5000" "insert" 10 1))) (snd-display ";save-edit-history 3: ~A?" (edit-fragment 3)))
+ (if (not (equal? (edit-fragment 4) '("scale-channel 2.000 0 #f" "scale" 0 50828))) (snd-display ";save-edit-history 4: ~A?" (edit-fragment 4)))
+ (if (not (equal? (edit-fragment 5) '("pad-channel" "zero" 100 20))) (snd-display ";save-edit-history 5: ~A?" (edit-fragment 5)))
(save-edit-history "hiho.scm" nind 0)
(scale-sound-to 1.0 0 (framples nind 0) nind 0)
(let ((eds (edit-position nind 0))
(val (insert-sound "zero.snd")))
- (if (or (not (= 0 val))
- (not (= eds (edit-position nind 0))))
- (snd-display #__line__ ";insert-sound zero.snd was an edit? ~A ~A ~A" val eds (edit-position nind 0))))
+ (if (not (and (= 0 val)
+ (= eds (edit-position nind 0))))
+ (snd-display ";insert-sound zero.snd was an edit? ~A ~A ~A" val eds (edit-position nind 0))))
(revert-sound nind)
(scale-sound-to 0.5 0 (framples nind 0) nind 0)
- (if (fneq (maxamp nind 0) 0.5) (snd-display #__line__ ";scale-sound-to 0.5: ~A" (maxamp nind)))
+ (if (fneq (maxamp nind 0) 0.5) (snd-display ";scale-sound-to 0.5: ~A" (maxamp nind)))
(close-sound nind)
(let ((nind (open-sound "oboe.snd")))
@@ -33291,39 +32666,19 @@ EDITS: 1
(set! sfile nind)
(load (string-append cwd "hiho.scm"))
(if (not (equal? (edit-fragment 1) '("ramp-channel 0.000 1.000 0 #f" "env" 0 50828)))
- (snd-display #__line__ ";save-edit-history ramp 1: ~A?" (edit-fragment 1)))
+ (snd-display ";save-edit-history ramp 1: ~A?" (edit-fragment 1)))
(if (not (equal? (edit-fragment 2) '("xramp-channel 0.000 1.000 32.000 0 #f" "env" 0 50828)))
- (snd-display #__line__ ";save-edit-history xramp 2: ~A?" (edit-fragment 2)))
+ (snd-display ";save-edit-history xramp 2: ~A?" (edit-fragment 2)))
(revert-sound nind)
(let ((str (file->string "hiho.scm")))
(if (not (string=? str " (ramp-channel 0.000 1.000 0 #f sfile 0 #f)
(xramp-channel 0.000 1.000 32.000 0 #f sfile 0 #f)
"))
- (snd-display #__line__ ";file->string: ~A" str)))
+ (snd-display ";file->string: ~A" str)))
(close-sound nind))
- (add-sound-file-extension "ogg")
- (add-sound-file-extension "OGG")
- (add-sound-file-extension "sf")
- (add-sound-file-extension "SF2")
- (add-sound-file-extension "mp3")
- (add-sound-file-extension "MP3")
- (add-sound-file-extension "W01")
- (add-sound-file-extension "W02")
- (add-sound-file-extension "W03")
- (add-sound-file-extension "W04")
- (add-sound-file-extension "W05")
- (add-sound-file-extension "W06")
- (add-sound-file-extension "W07")
- (add-sound-file-extension "W08")
- (add-sound-file-extension "W09")
- (add-sound-file-extension "W10")
- (add-sound-file-extension "w01")
- (add-sound-file-extension "w02")
- (add-sound-file-extension "w03")
- (add-sound-file-extension "w04")
- (add-sound-file-extension "w05")
- (add-source-file-extension "gad")
+ (for-each add-sound-file-extension '("ogg" "OGG" "sf" "SF2" "mp3" "MP3" "W01" "W02" "W03" "W04" "W05" "W06" "W07"
+ "W08" "W09" "W10" "w01" "w02" "w03" "w04" "w05" "gad"))
(let ((ind (new-sound "fmv.snd")))
(set! (sample 10) .1)
@@ -33338,7 +32693,7 @@ EDITS: 1
(load (string-append cwd "t1.scm"))
(set! ind (find-sound "fmv.snd"))
(if (not (sound? ind))
- (snd-display #__line__ ";save-state restored but no sound?"))
+ (snd-display ";save-state restored but no sound?"))
(do ((i 3 (+ i 1)))
((= i 6))
(set! (sample i) (* i .1))
@@ -33350,7 +32705,7 @@ EDITS: 1
(load (string-append cwd "t1.scm"))
(set! ind (find-sound "fmv.snd"))
(if (not (sound? ind))
- (snd-display #__line__ ";save-state ~A restored but no sound?" i))))
+ (snd-display ";save-state ~A restored but no sound?" i))))
(close-sound ind)
(delete-file "t1.scm"))
@@ -33380,9 +32735,9 @@ EDITS: 1
(load (string-append cwd "t1.scm"))
(set! ind (find-sound "fmv.snd"))
(set! ind1 (find-sound "fmv1.snd"))
- (if (or (not (sound? ind))
- (not (sound? ind1)))
- (snd-display #__line__ ";save-state(2) restored but no sound? ~A ~A" ind ind1))
+ (if (not (and (sound? ind)
+ (sound? ind1)))
+ (snd-display ";save-state(2) restored but no sound? ~A ~A" ind ind1))
(close-sound ind)
(close-sound ind1)
(delete-file "t1.scm"))
@@ -33424,41 +32779,41 @@ EDITS: 1
(close-sound ind)
(for-each forget-region (regions))
(load (string-append cwd "s61.scm"))
- (if (fneq *clm-srate* 48000.0) (snd-display #__line__ ";save/restore mus-srate: ~A" *clm-srate*))
- (if (not (= *clm-file-buffer-size* 4096)) (snd-display #__line__ ";save/restore mus-file-buffer-size: ~A" *clm-file-buffer-size*))
- (if (not (= *mus-array-print-length* 24)) (snd-display #__line__ ";save/restore mus-array-print-length: ~A" *mus-array-print-length*))
- (if (not (= *clm-table-size* 256)) (snd-display #__line__ ";save/restore clm-table-size: ~A" *clm-table-size*))
+ (if (fneq *clm-srate* 48000.0) (snd-display ";save/restore mus-srate: ~A" *clm-srate*))
+ (if (not (= *clm-file-buffer-size* 4096)) (snd-display ";save/restore mus-file-buffer-size: ~A" *clm-file-buffer-size*))
+ (if (not (= *mus-array-print-length* 24)) (snd-display ";save/restore mus-array-print-length: ~A" *mus-array-print-length*))
+ (if (not (= *clm-table-size* 256)) (snd-display ";save/restore clm-table-size: ~A" *clm-table-size*))
(set! *clm-srate* old-srate)
(set! *mus-array-print-length* old-array-print-length)
(set! *clm-file-buffer-size* old-file-buffer-size)
(set! *clm-table-size* old-clm-table-size))
(set! *save-dir* old-save-dir)
(set! ind (find-sound "oboe.snd"))
- (if (not (= (show-axes ind 0) show-no-axes)) (snd-display #__line__ ";save show-no-axes: ~A" (show-axes ind 0)))
- (if (not (= *zoom-focus-style* zoom-focus-middle)) (snd-display #__line__ ";save zoom-focus-middle: ~A" *zoom-focus-style*))
- (if (not (= (transform-normalization ind 0) dont-normalize)) (snd-display #__line__ ";save dont-normalize: ~A" (transform-normalization ind 0)))
- (if (not (= (graph-style ind 0) graph-filled)) (snd-display #__line__ ";save graph-filled: ~A" (graph-style ind 0)))
- (if (not (= (transform-graph-type ind 0) graph-as-spectrogram)) (snd-display #__line__ ";save graph-as-spectrogram: ~A" (transform-graph-type ind 0)))
- (if (not (= (time-graph-type ind 0) graph-as-wavogram)) (snd-display #__line__ ";save graph-as-wavogram: ~A" (time-graph-type ind 0)))
- (if (not (= (x-axis-style ind 0) x-axis-as-percentage)) (snd-display #__line__ ";save x-axis-as-percentage: ~A" (x-axis-style ind 0)))
- (if (not (= (speed-control-style ind) speed-control-as-semitone)) (snd-display #__line__ ";save speed-control-style: ~A" (speed-control-style ind)))
- (if (not (= (cursor ind 0) 1234)) (snd-display #__line__ ";save cursor 1234: ~A" (cursor ind 0)))
- (if (not (string=? *eps-file* "hiho.eps")) (snd-display #__line__ ";save eps-file: ~A" *eps-file*))
+ (if (not (= (show-axes ind 0) show-no-axes)) (snd-display ";save show-no-axes: ~A" (show-axes ind 0)))
+ (if (not (= *zoom-focus-style* zoom-focus-middle)) (snd-display ";save zoom-focus-middle: ~A" *zoom-focus-style*))
+ (if (not (= (transform-normalization ind 0) dont-normalize)) (snd-display ";save dont-normalize: ~A" (transform-normalization ind 0)))
+ (if (not (= (graph-style ind 0) graph-filled)) (snd-display ";save graph-filled: ~A" (graph-style ind 0)))
+ (if (not (= (transform-graph-type ind 0) graph-as-spectrogram)) (snd-display ";save graph-as-spectrogram: ~A" (transform-graph-type ind 0)))
+ (if (not (= (time-graph-type ind 0) graph-as-wavogram)) (snd-display ";save graph-as-wavogram: ~A" (time-graph-type ind 0)))
+ (if (not (= (x-axis-style ind 0) x-axis-as-percentage)) (snd-display ";save x-axis-as-percentage: ~A" (x-axis-style ind 0)))
+ (if (not (= (speed-control-style ind) speed-control-as-semitone)) (snd-display ";save speed-control-style: ~A" (speed-control-style ind)))
+ (if (not (= (cursor ind 0) 1234)) (snd-display ";save cursor 1234: ~A" (cursor ind 0)))
+ (if (not (string=? *eps-file* "hiho.eps")) (snd-display ";save eps-file: ~A" *eps-file*))
(when with-gui
(if (not (string=? (x-axis-label ind 0 time-graph) "time-x"))
- (snd-display #__line__ ";save x-axis-label: ~A" (x-axis-label ind 0 time-graph)))
+ (snd-display ";save x-axis-label: ~A" (x-axis-label ind 0 time-graph)))
(if (not (string=? (y-axis-label ind 0 time-graph) "amp-y"))
- (snd-display #__line__ ";save y-axis-label: ~A" (y-axis-label ind 0 time-graph))))
+ (snd-display ";save y-axis-label: ~A" (y-axis-label ind 0 time-graph))))
(if (not (feql (amp-control-bounds ind) (list 0 2.5)))
- (snd-display #__line__ ";save amp-control-bounds: ~A" (amp-control-bounds ind)))
+ (snd-display ";save amp-control-bounds: ~A" (amp-control-bounds ind)))
(if (not (feql (speed-control-bounds ind) (list 1.0 2.5)))
- (snd-display #__line__ ";save speed-control-bounds: ~A" (speed-control-bounds ind)))
+ (snd-display ";save speed-control-bounds: ~A" (speed-control-bounds ind)))
(if (not (feql (contrast-control-bounds ind) (list 0 2.5)))
- (snd-display #__line__ ";save contrast-control-bounds: ~A" (contrast-control-bounds ind)))
+ (snd-display ";save contrast-control-bounds: ~A" (contrast-control-bounds ind)))
(if (not (feql (reverb-control-scale-bounds ind) (list 0 2.5)))
- (snd-display #__line__ ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds ind)))
+ (snd-display ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds ind)))
(if (not (feql (reverb-control-length-bounds ind) (list 0 2.5)))
- (snd-display #__line__ ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds ind)))
+ (snd-display ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds ind)))
(set! *eps-file* old-eps-file)
(delete-file "s61.scm")
(close-sound ind))
@@ -33484,19 +32839,19 @@ EDITS: 1
(close-sound ind)
(for-each forget-region (regions))
(load (string-append cwd "s61.scm"))
- (if (not (string=? *tiny-font* "8x13")) (snd-display #__line__ ";save tiny-font: ~A" *tiny-font*))
- (if (not (string=? *peaks-font* "8x13")) (snd-display #__line__ ";save peaks-font: ~A" *peaks-font*))
- (if (not (string=? *bold-peaks-font* "8x13")) (snd-display #__line__ ";save bold-peaks-font: ~A" *bold-peaks-font*))
+ (if (not (string=? *tiny-font* "8x13")) (snd-display ";save tiny-font: ~A" *tiny-font*))
+ (if (not (string=? *peaks-font* "8x13")) (snd-display ";save peaks-font: ~A" *peaks-font*))
+ (if (not (string=? *bold-peaks-font* "8x13")) (snd-display ";save bold-peaks-font: ~A" *bold-peaks-font*))
(if (not (feql (amp-control-bounds) (list 0 2.5)))
- (snd-display #__line__ ";save amp-control-bounds: ~A" (amp-control-bounds)))
+ (snd-display ";save amp-control-bounds: ~A" (amp-control-bounds)))
(if (not (feql (speed-control-bounds) (list 1.0 2.5)))
- (snd-display #__line__ ";save speed-control-bounds: ~A" (speed-control-bounds)))
+ (snd-display ";save speed-control-bounds: ~A" (speed-control-bounds)))
(if (not (feql (contrast-control-bounds) (list 0 2.5)))
- (snd-display #__line__ ";save contrast-control-bounds: ~A" (contrast-control-bounds)))
+ (snd-display ";save contrast-control-bounds: ~A" (contrast-control-bounds)))
(if (not (feql (reverb-control-scale-bounds) (list 0 2.5)))
- (snd-display #__line__ ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
+ (snd-display ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
(if (not (feql (reverb-control-length-bounds) (list 0 2.5)))
- (snd-display #__line__ ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
+ (snd-display ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
(set! *tiny-font* old-tiny-font)
(set! *peaks-font* old-peaks-font)
(set! *bold-peaks-font* old-bold-peaks-font)
@@ -33539,13 +32894,13 @@ EDITS: 1
(set! ind (find-sound "oboe.snd"))
(when with-gui
(for-each (lambda (func func-name global local)
- (if (or (not (local-eq? (func) global))
- (not (local-eq? (func ind 0) local)))
- (snd-display #__line__ "; save ~A reversed: ~A [~A] ~A [~A]"
+ (if (not (and (local-eq? (func) global)
+ (local-eq? (func ind 0) local)))
+ (snd-display "; save ~A reversed: ~A [~A] ~A [~A]"
func-name (func) global (func ind 0) local)))
funcs func-names new-globals new-locals))
(if (not (= (channel-style ind) channels-separate))
- (snd-display #__line__ ";save channel-style reversed: ~A ~A" *channel-style* (channel-style ind)))
+ (snd-display ";save channel-style reversed: ~A ~A" *channel-style* (channel-style ind)))
(for-each (lambda (func val) (set! (func) val)) funcs old-globals)
(close-sound ind)
(set! *zoom-focus-style* zoom-focus-active)
@@ -33555,9 +32910,9 @@ EDITS: 1
(let ((ind0 (open-sound "oboe.snd"))
(ind1 (open-sound "oboe.snd")))
(if (not (member (find-sound "oboe.snd" 0) (list ind0 ind1)))
- (snd-display #__line__ ";find-sound 0: ~A ~A" (list ind0 ind1) (find-sound "oboe.snd" 0)))
+ (snd-display ";find-sound 0: ~A ~A" (list ind0 ind1) (find-sound "oboe.snd" 0)))
(if (not (member (find-sound "oboe.snd" 1) (list ind0 ind1)))
- (snd-display #__line__ ";find-sound 1: ~A ~A" (list ind0 ind1) (find-sound "oboe.snd" 1)))
+ (snd-display ";find-sound 1: ~A ~A" (list ind0 ind1) (find-sound "oboe.snd" 1)))
(add-mark 123 ind0)
(add-mark 321 ind1)
(if (file-exists? "s61.scm") (delete-file "s61.scm"))
@@ -33567,11 +32922,11 @@ EDITS: 1
(load (string-append cwd "s61.scm"))
(set! ind0 (find-sound "oboe.snd" 0))
(set! ind1 (find-sound "oboe.snd" 1))
- (if (or (not ind0) (not ind1)) (snd-display #__line__ ";saved 2oboes, found: ~A" (map short-file-name (sounds))))
- (if (not (find-mark 123 ind0)) (snd-display #__line__ ";saved 2oboes mark 0?"))
- (if (find-mark 123 ind1) (snd-display #__line__ ";saved 2oboes mark 1->0?"))
- (if (not (find-mark 321 ind1)) (snd-display #__line__ ";saved 2oboes mark 1?"))
- (if (find-mark 321 ind0) (snd-display #__line__ ";saved 2oboes mark 0->1?"))
+ (if (not (and ind0 ind1)) (snd-display ";saved 2oboes, found: ~A" (map short-file-name (sounds))))
+ (if (not (find-mark 123 ind0)) (snd-display ";saved 2oboes mark 0?"))
+ (if (find-mark 123 ind1) (snd-display ";saved 2oboes mark 1->0?"))
+ (if (not (find-mark 321 ind1)) (snd-display ";saved 2oboes mark 1?"))
+ (if (find-mark 321 ind0) (snd-display ";saved 2oboes mark 0->1?"))
(close-sound ind0)
(close-sound ind1))
@@ -33586,7 +32941,7 @@ EDITS: 1
(load (string-append cwd "s61.scm"))
(set! ind (find-sound "test.snd"))
(if (not (sound? ind))
- (snd-display #__line__ ";save-state test ~D no test.snd?" ctr)
+ (snd-display ";save-state test ~D no test.snd?" ctr)
(begin
(test ind)
(close-sound ind)))
@@ -33641,1043 +32996,1041 @@ EDITS: 1
(list
;; basic cases
(lambda (ind)
- (if (fneq (sample 10) .5) (snd-display #__line__ ";insert-sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
- (if (not (= (framples ind 0) 101)) (snd-display #__line__ ";insert-sample save-state len: ~A" (framples ind 0))))
+ (if (fneq (sample 10) .5) (snd-display ";insert-sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
+ (if (not (= (framples ind 0) 101)) (snd-display ";insert-sample save-state len: ~A" (framples ind 0))))
(lambda (ind)
- (if (fneq (sample 10) 0.0) (snd-display #__line__ ";delete-sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
- (if (not (= (framples ind 0) 99)) (snd-display #__line__ ";delete-sample save-state len: ~A" (framples ind 0))))
+ (if (fneq (sample 10) 0.0) (snd-display ";delete-sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
+ (if (not (= (framples ind 0) 99)) (snd-display ";delete-sample save-state len: ~A" (framples ind 0))))
(lambda (ind)
- (if (fneq (sample 10) .5) (snd-display #__line__ ";set sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
- (if (not (= (framples ind 0) 100)) (snd-display #__line__ ";set sample save-state len: ~A" (framples ind 0))))
+ (if (fneq (sample 10) .5) (snd-display ";set sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
+ (if (not (= (framples ind 0) 100)) (snd-display ";set sample save-state len: ~A" (framples ind 0))))
(lambda (ind)
- (if (fneq (sample 10) .25) (snd-display #__line__ ";scl sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
- (if (not (= (framples ind 0) 100)) (snd-display #__line__ ";scl sample save-state len: ~A" (framples ind 0)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";scl sample save-state edpos: ~A" (edit-position ind 0))))
+ (if (fneq (sample 10) .25) (snd-display ";scl sample save-state: ~A" (channel->float-vector 5 10 ind 0)))
+ (if (not (= (framples ind 0) 100)) (snd-display ";scl sample save-state len: ~A" (framples ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";scl sample save-state edpos: ~A" (edit-position ind 0))))
(lambda (ind)
- (if (not (= (framples ind 0) 105)) (snd-display #__line__ ";pad sample save-state len: ~A" (framples ind 0)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";pad sample save-state edpos: ~A" (edit-position ind 0)))
+ (if (not (= (framples ind 0) 105)) (snd-display ";pad sample save-state len: ~A" (framples ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";pad sample save-state edpos: ~A" (edit-position ind 0)))
(if (not (vequal (float-vector .5 .5 0 0 0 0 0 .5 .5 .5) (channel->float-vector 10 10 ind 0)))
- (snd-display #__line__ ";pad sample save-state: ~A" (channel->float-vector 10 10 ind 0))))
+ (snd-display ";pad sample save-state: ~A" (channel->float-vector 10 10 ind 0))))
(lambda (ind)
- (if (not (= (framples ind 0) 100)) (snd-display #__line__ ";env sample save-state len: ~A" (framples ind 0)))
- (if (not (= (edit-position ind 0) 2)) (snd-display #__line__ ";env sample save-state edpos: ~A" (edit-position ind 0)))
+ (if (not (= (framples ind 0) 100)) (snd-display ";env sample save-state len: ~A" (framples ind 0)))
+ (if (not (= (edit-position ind 0) 2)) (snd-display ";env sample save-state edpos: ~A" (edit-position ind 0)))
(if (not (vequal (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 1.0 1.0 1.0 1.0) (channel->float-vector 0 15 ind 0)))
- (snd-display #__line__ ";env sample save-state: ~A" (channel->float-vector 0 15 ind 0))))
+ (snd-display ";env sample save-state: ~A" (channel->float-vector 0 15 ind 0))))
(lambda (ind)
- (if (not (= (framples ind 0) 100)) (snd-display #__line__ "; sample save-state len: ~A" (framples ind 0)))
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ "; sample save-state edpos: ~A" (edit-position ind 0)))
- (if (fneq (maxamp ind 0) .1) (snd-display #__line__ "; save-state max: ~A" (maxamp ind 0)))
- (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display #__line__ "; save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
+ (if (not (= (framples ind 0) 100)) (snd-display "; sample save-state len: ~A" (framples ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display "; sample save-state edpos: ~A" (edit-position ind 0)))
+ (if (fneq (maxamp ind 0) .1) (snd-display "; save-state max: ~A" (maxamp ind 0)))
+ (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display "; save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
;; map-channel as backup
(lambda (ind)
- (if (not (= (framples ind 0) 50)) (snd-display #__line__ ";map #f save-state len: ~A" (framples ind 0)))
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";map #f save-state edpos: ~A" (edit-position ind 0)))
- (if (fneq (maxamp ind 0) .1) (snd-display #__line__ ";map #f save-state max: ~A" (maxamp ind 0)))
- (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display #__line__ ";map #f save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
+ (if (not (= (framples ind 0) 50)) (snd-display ";map #f save-state len: ~A" (framples ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";map #f save-state edpos: ~A" (edit-position ind 0)))
+ (if (fneq (maxamp ind 0) .1) (snd-display ";map #f save-state max: ~A" (maxamp ind 0)))
+ (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display ";map #f save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
;; as-one-edit
(lambda (ind)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";save-state backup 2 float-vectors edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup 2 float-vectors edpos: ~A" (edit-position ind 0)))
(if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
- (snd-display #__line__ ";as-one-edit save-state 1: ~A" (channel->float-vector 0 10 ind 0)))
+ (snd-display ";as-one-edit save-state 1: ~A" (channel->float-vector 0 10 ind 0)))
(if (not (vequal (channel->float-vector 20 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
- (snd-display #__line__ ";as-one-edit save-state 2: ~A" (channel->float-vector 0 10 ind 0))))
+ (snd-display ";as-one-edit save-state 2: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";save-state backup float-vector+scl edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup float-vector+scl edpos: ~A" (edit-position ind 0)))
(if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector-scale! (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0) .5)))
- (snd-display #__line__ ";as-one-edit save-state 3: ~A" (channel->float-vector 0 10 ind 0))))
+ (snd-display ";as-one-edit save-state 3: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";save-state backup float-vector+del edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup float-vector+del edpos: ~A" (edit-position ind 0)))
(if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 0 0 0 0 0)))
- (snd-display #__line__ ";as-one-edit save-state 4: ~A" (channel->float-vector 0 10 ind 0))))
+ (snd-display ";as-one-edit save-state 4: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";save-state backup del+insert edpos: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup del+insert edpos: ~A" (edit-position ind 0)))
(if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector 0 0 0 0 0 .1 .2 0 0 0)))
- (snd-display #__line__ ";as-one-edit save-state 5: ~A" (channel->float-vector 0 10 ind 0)))
- (if (not (= (framples ind 0) 97)) (snd-display #__line__ ";save-state backup del+insert len: ~A" (framples ind 0))))
+ (snd-display ";as-one-edit save-state 5: ~A" (channel->float-vector 0 10 ind 0)))
+ (if (not (= (framples ind 0) 97)) (snd-display ";save-state backup del+insert len: ~A" (framples ind 0))))
)))
;; ---------------- edit-list->function ----------------
- (let ((ind (open-sound "oboe.snd")))
- (let ((mx0 (maxamp))
- (frs (framples)))
+ (let* ((ind (open-sound "oboe.snd"))
+ (frs (framples)))
- ;; ---- simple scale
+ ;; ---- simple scale
+ (let ((mx0 (maxamp)))
(scale-channel 2.0)
- (if (fneq (* 2 mx0) (maxamp)) (snd-display #__line__ ";edit-list->function off to a bad start: ~A" (maxamp)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 1: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 1: ~A" (procedure-source func)))
- (func ind 0)
- (let ((mx (maxamp)))
- (if (fneq (* 4 mx0) mx) (snd-display #__line__ ";edit-list->function called (1): ~A ~A" mx mx0))))
- (revert-sound ind)
-
- (scale-by 2.0)
+ (if (fneq (* 2 mx0) (maxamp)) (snd-display ";edit-list->function off to a bad start: ~A" (maxamp)))
(let ((func (edit-list->function)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 1a: ~A" func))
+ (snd-display ";edit-list->function 1: ~A" func))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 1a: ~A" (procedure-source func))))
- (revert-sound ind)
- (normalize-channel 1.0)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 1c: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (normalize-channel 1.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 1c: ~A" (procedure-source func))))
- (revert-sound ind)
-
- ;; ---- simple delete
- (delete-samples 10 100)
- (if (not (= (framples) (- frs 100))) (snd-display #__line__ ";edit-list->function delete: ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 2: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 10 100 snd chn))))
- (snd-display #__line__ ";edit-list->function 2: ~A" (procedure-source func)))
- (func ind 0)
- (if (not (= (framples) (- frs 200))) (snd-display #__line__ ";edit-list->function called (2): ~A ~A" frs (framples))))
- (revert-sound ind)
-
- ;; ---- simple delete (a)
- (delete-sample 100)
- (if (not (= (framples) (- frs 1))) (snd-display #__line__ ";edit-list->function delete (2a): ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 2a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 100 1 snd chn))))
- (snd-display #__line__ ";edit-list->function 2a: ~A" (procedure-source func)))
- (func ind 0)
- (if (not (= (framples) (- frs 2))) (snd-display #__line__ ";edit-list->function called (2a): ~A ~A" frs (framples))))
- (revert-sound ind)
-
- ;; ---- simple zero pad
- (pad-channel 10 100)
- (if (not (= (framples) (+ frs 100))) (snd-display #__line__ ";edit-list->function pad: ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 3: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (pad-channel 10 100 snd chn))))
- (snd-display #__line__ ";edit-list->function 3: ~A" (procedure-source func)))
- (func ind 0)
- (if (not (= (framples) (+ frs 200))) (snd-display #__line__ ";edit-list->function called (3): ~A ~A" frs (framples))))
- (revert-sound ind)
-
- ;; ---- simple zero pad (a)
- (insert-silence 10 100)
- (if (not (= (framples) (+ frs 100))) (snd-display #__line__ ";edit-list->function pad (3a): ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 3a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (pad-channel 10 100 snd chn))))
- (snd-display #__line__ ";edit-list->function 3a: ~A" (procedure-source func)))
- (func ind 0)
- (if (not (= (framples) (+ frs 200))) (snd-display #__line__ ";edit-list->function called (3a): ~A ~A" frs (framples))))
- (revert-sound ind)
-
- ;; --- simple ramp
- (ramp-channel 0.2 0.9)
- (if (fneq (maxamp) 0.0899) (snd-display #__line__ ";edit-list ramp: ~A" (maxamp)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 4: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (ramp-channel 0.2 0.9 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 4: ~A" (procedure-source func)))
- (func ind 0)
- (let ((mx (maxamp)))
- (if (fneq mx 0.061) (snd-display #__line__ ";edit-list->function called (4): ~A" mx))))
- (revert-sound ind)
-
- ;; --- simple xramp
- (xramp-channel 0.2 0.9 32.0)
- (if (and (fneq (maxamp) 0.055) (fneq (maxamp) .056)) (snd-display #__line__ ";edit-list xramp: ~A" (maxamp)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 5: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (xramp-channel 0.2 0.9 32.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 5: ~A" (procedure-source func)))
- (func ind 0)
- (let ((mx (maxamp)))
- (if (fneq mx 0.0266) (snd-display #__line__ ";edit-list->function called (5): ~A" mx))))
- (revert-sound ind)
-
-
- ;; ---- simple env
- (env-sound '(0 0 1 1))
- (if (fneq (maxamp) 0.0906) (snd-display #__line__ ";edit-list env: ~A" (maxamp)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 6: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 1.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 6: ~A" (procedure-source func)))
- (func ind 0)
- (let ((mx (maxamp)))
- (if (fneq mx 0.0634) (snd-display #__line__ ";edit-list->function called (6): ~A" mx))))
- (revert-sound ind)
-
- ;; ---- less simple env
- (env-sound '(0 0 1 .3 2 .8 3 0))
- (if (fneq (maxamp) 0.107) (snd-display #__line__ ";edit-list env: ~A" (maxamp)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 7: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function 1: ~A" (procedure-source func)))
(func ind 0)
(let ((mx (maxamp)))
- (if (fneq mx 0.0857) (snd-display #__line__ ";edit-list->function called (7): ~A" mx))))
- (revert-sound ind)
-
- (env-channel '(0 0 1 .3 2 .8 3 0))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7a: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 7a: ~A" (procedure-source func))))
- (revert-sound ind)
-
- (env-channel '(0 0 1 .3 2 .8 3 0) 1000 2000)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7b: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 1.0 :end 1999) 1000 2000 snd chn))))
- (snd-display #__line__ ";edit-list->function 7b: ~A" (procedure-source func))))
+ (if (fneq (* 4 mx0) mx) (snd-display ";edit-list->function called (1): ~A ~A" mx mx0)))))
+ (revert-sound ind)
+
+ (scale-by 2.0)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 1a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 1a: ~A" (procedure-source func))))
+ (revert-sound ind)
+ (normalize-channel 1.0)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 1c: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (normalize-channel 1.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 1c: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ ;; ---- simple delete
+ (delete-samples 10 100)
+ (if (not (= (framples) (- frs 100))) (snd-display ";edit-list->function delete: ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 2: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 10 100 snd chn))))
+ (snd-display ";edit-list->function 2: ~A" (procedure-source func)))
+ (func ind 0)
+ (if (not (= (framples) (- frs 200))) (snd-display ";edit-list->function called (2): ~A ~A" frs (framples))))
+ (revert-sound ind)
+
+ ;; ---- simple delete (a)
+ (delete-sample 100)
+ (if (not (= (framples) (- frs 1))) (snd-display ";edit-list->function delete (2a): ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 2a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 100 1 snd chn))))
+ (snd-display ";edit-list->function 2a: ~A" (procedure-source func)))
+ (func ind 0)
+ (if (not (= (framples) (- frs 2))) (snd-display ";edit-list->function called (2a): ~A ~A" frs (framples))))
+ (revert-sound ind)
+
+ ;; ---- simple zero pad
+ (pad-channel 10 100)
+ (if (not (= (framples) (+ frs 100))) (snd-display ";edit-list->function pad: ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 3: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (pad-channel 10 100 snd chn))))
+ (snd-display ";edit-list->function 3: ~A" (procedure-source func)))
+ (func ind 0)
+ (if (not (= (framples) (+ frs 200))) (snd-display ";edit-list->function called (3): ~A ~A" frs (framples))))
+ (revert-sound ind)
+
+ ;; ---- simple zero pad (a)
+ (insert-silence 10 100)
+ (if (not (= (framples) (+ frs 100))) (snd-display ";edit-list->function pad (3a): ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 3a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (pad-channel 10 100 snd chn))))
+ (snd-display ";edit-list->function 3a: ~A" (procedure-source func)))
+ (func ind 0)
+ (if (not (= (framples) (+ frs 200))) (snd-display ";edit-list->function called (3a): ~A ~A" frs (framples))))
+ (revert-sound ind)
+
+ ;; --- simple ramp
+ (ramp-channel 0.2 0.9)
+ (if (fneq (maxamp) 0.0899) (snd-display ";edit-list ramp: ~A" (maxamp)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 4: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (ramp-channel 0.2 0.9 0 #f snd chn))))
+ (snd-display ";edit-list->function 4: ~A" (procedure-source func)))
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.061) (snd-display ";edit-list->function called (4): ~A" mx))))
+ (revert-sound ind)
+
+ ;; --- simple xramp
+ (xramp-channel 0.2 0.9 32.0)
+ (if (and (fneq (maxamp) 0.055) (fneq (maxamp) .056)) (snd-display ";edit-list xramp: ~A" (maxamp)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 5: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (xramp-channel 0.2 0.9 32.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 5: ~A" (procedure-source func)))
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.0266) (snd-display ";edit-list->function called (5): ~A" mx))))
+ (revert-sound ind)
+
+
+ ;; ---- simple env
+ (env-sound '(0 0 1 1))
+ (if (fneq (maxamp) 0.0906) (snd-display ";edit-list env: ~A" (maxamp)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 6: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 1.0) 0 #f snd chn))))
+ (snd-display ";edit-list->function 6: ~A" (procedure-source func)))
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.0634) (snd-display ";edit-list->function called (6): ~A" mx))))
+ (revert-sound ind)
+
+ ;; ---- less simple env
+ (env-sound '(0 0 1 .3 2 .8 3 0))
+ (if (fneq (maxamp) 0.107) (snd-display ";edit-list env: ~A" (maxamp)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) 0 #f snd chn))))
+ (snd-display ";edit-list->function 7: ~A" (procedure-source func)))
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.0857) (snd-display ";edit-list->function called (7): ~A" mx))))
+ (revert-sound ind)
+
+ (env-channel '(0 0 1 .3 2 .8 3 0))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7a: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) 0 #f snd chn))))
+ (snd-display ";edit-list->function 7a: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ (env-channel '(0 0 1 .3 2 .8 3 0) 1000 2000)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7b: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 1.0 :end 1999) 1000 2000 snd chn))))
+ (snd-display ";edit-list->function 7b: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 32.0 :length 2000) 1000 2000)
+ (let ((func (edit-list->function))
+ (mxenv0 (maxamp)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7c: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 32.0 :end 1999) 1000 2000 snd chn))))
+ (snd-display ";edit-list->function 7c: ~A" (procedure-source func)))
(revert-sound ind)
- (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 32.0 :length 2000) 1000 2000)
+ (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :length 2000 :offset 2.0 :scaler 3.0) 1000 2000)
(let ((func (edit-list->function))
- (mxenv0 (maxamp)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7c: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :base 32.0 :end 1999) 1000 2000 snd chn))))
- (snd-display #__line__ ";edit-list->function 7c: ~A" (procedure-source func)))
- (revert-sound ind)
-
- (env-channel (make-env '(0.0 0.0 1.0 0.3 2.0 0.8 3.0 0.0) :length 2000 :offset 2.0 :scaler 3.0) 1000 2000)
- (let ((func (edit-list->function))
- (mxenv1 (maxamp)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7d: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel (make-env '(0.0 2.0 1.0 2.9 2.0 4.4 3.0 2.0) :base 1.0 :end 1999) 1000 2000 snd chn))))
- (snd-display #__line__ ";edit-list->function 7d: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (let ((nmx (maxamp)))
- (if (fneq nmx mxenv1) (snd-display #__line__ ";edit-list->function 7d max: ~A ~A ~A" nmx mxenv1 mxenv0)))))
- (revert-sound ind)
-
- (do ((i 0 (+ i 1)))
- ((= i 5)) ; get to unrampable case
- (env-channel '(0 0 1 1 2 0)))
- (let ((func (edit-list->function)))
+ (mxenv1 (maxamp)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7e: ~A" func))
+ (snd-display ";edit-list->function 7d: ~A" func))
(if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 7e: ~A" (procedure-source func)))
+ '(lambda (snd chn) (env-channel (make-env '(0.0 2.0 1.0 2.9 2.0 4.4 3.0 2.0) :base 1.0 :end 1999) 1000 2000 snd chn))))
+ (snd-display ";edit-list->function 7d: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
- (if (fneq (maxamp) 0.1459) (snd-display #__line__ ";edit-list->function 7e max: ~A" (maxamp)))
- (if (not (= (edit-position) 5)) (snd-display #__line__ ";edit-list->function 7e edpos: ~A" (edit-position))))
+ (let ((nmx (maxamp)))
+ (if (fneq nmx mxenv1) (snd-display ";edit-list->function 7d max: ~A ~A ~A" nmx mxenv1 mxenv0)))))
+ (revert-sound ind)
+
+ (do ((i 0 (+ i 1)))
+ ((= i 5)) ; get to unrampable case
+ (env-channel '(0 0 1 1 2 0)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7e: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn) (env-channel '(0.0 0.0 1.0 1.0 2.0 0.0) 0 #f snd chn))))
+ (snd-display ";edit-list->function 7e: ~A" (procedure-source func)))
+ (revert-sound ind)
+ (func ind 0)
+ (if (fneq (maxamp) 0.1459) (snd-display ";edit-list->function 7e max: ~A" (maxamp)))
+ (if (not (= (edit-position) 5)) (snd-display ";edit-list->function 7e edpos: ~A" (edit-position))))
+ (revert-sound ind)
+
+ (env-sound '(0 0 1 1 2 0) 0 (framples) 32.0)
+ (if (fneq (maxamp) 0.146) (snd-display ";edit-list env 7f: ~A" (maxamp)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7f: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel-with-base '(0.0 0.0 1.0 1.0 2.0 0.0) 32.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 7f: ~A" (procedure-source func)))
+ (revert-sound ind)
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx 0.146) (snd-display ";edit-list->function called (7f): ~A" mx))))
+ (revert-sound ind)
+
+ (env-sound '(0 0 1 1 2 1 3 0) 0 (framples) 0.0)
+ (if (fneq (sample 4000) 0.0) (snd-display ";edit-list env 7g: ~A" (sample 4000)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 7g: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel-with-base '(0.0 0.0 1.0 1.0 2.0 1.0 3.0 0.0) 0.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 7g: ~A" (procedure-source func)))
(revert-sound ind)
-
- (env-sound '(0 0 1 1 2 0) 0 (framples) 32.0)
- (if (fneq (maxamp) 0.146) (snd-display #__line__ ";edit-list env 7f: ~A" (maxamp)))
+ (func ind 0)
+ (if (fneq (sample 4000) 0.0) (snd-display ";edit-list function 7g: ~A" (sample 4000))))
+ (revert-sound ind)
+
+ ;; ---- simple 1 sample insert
+ (insert-sample 100 .1)
+ (if (not (= (framples) (+ frs 1))) (snd-display ";edit-list->function insert-sample: ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 9: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (insert-sample 100 0.1 snd chn))))
+ (snd-display ";edit-list->function 9: ~A" (procedure-source func)))
+ (func ind 0)
+ (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.1 0.0)))
+ (snd-display ";edit-list->function func 9: ~A" (channel->float-vector 99 4)))
+ (if (not (= (framples) (+ frs 2))) (snd-display ";edit-list->function called (9): ~A ~A" frs (framples))))
+ (revert-sound ind)
+
+ ;; ---- insert-samples with data
+ (insert-samples 0 100 (make-float-vector 100 .1))
+ (if (not (= (framples) (+ frs 100))) (snd-display ";edit-list->function insert-samples (100): ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 9a: ~A" func))
+ (func ind 0))
+ (if (not (= (framples) (+ frs 200))) (snd-display ";edit-list->function insert-samples (200): ~A ~A" frs (framples)))
+ (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
+ (snd-display ";edit-list->function func 9a: ~A" (channel->float-vector 0 5)))
+ (revert-sound ind)
+
+ ;; ---- set-samples with data
+ (set! (samples 0 100) (make-float-vector 100 .1))
+ (if (not (= (framples) frs)) (snd-display ";edit-list->function set-samples (1): ~A ~A" frs (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 9b: ~A" func))
+ (func ind 0))
+ (if (not (= (framples) frs)) (snd-display ";edit-list->function set-samples (2): ~A ~A" frs (framples)))
+ (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
+ (snd-display ";edit-list->function func 9b: ~A" (channel->float-vector 0 5)))
+ (revert-sound ind)
+
+ ;; ---- simple 1 sample set
+ (let ((val (sample 100)))
+ (set! (sample 100) .1)
+ (if (not (= (framples) frs)) (snd-display ";edit-list->function set-sample framples: ~A ~A" frs (framples)))
+ (if (fneq (sample 100) .1) (snd-display ";edit-list->function set-sample val: ~A ~A" val (sample 100)))
(let ((func (edit-list->function)))
+ (revert-sound)
+ (if (fneq val (sample 100)) (snd-display ";edit-list->function unset-sample val: ~A ~A" val (sample 100)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7f: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel-with-base '(0.0 0.0 1.0 1.0 2.0 0.0) 32.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 7f: ~A" (procedure-source func)))
- (revert-sound ind)
+ (snd-display ";edit-list->function 10: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (set-sample 100 0.1 snd chn))))
+ (snd-display ";edit-list->function 10: ~A" (procedure-source func)))
(func ind 0)
- (let ((mx (maxamp)))
- (if (fneq mx 0.146) (snd-display #__line__ ";edit-list->function called (7f): ~A" mx))))
- (revert-sound ind)
-
- (env-sound '(0 0 1 1 2 1 3 0) 0 (framples) 0.0)
- (if (fneq (sample 4000) 0.0) (snd-display #__line__ ";edit-list env 7g: ~A" (sample 4000)))
+ (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.0 0.0)))
+ (snd-display ";edit-list->function func 10: ~A" (channel->float-vector 99 4)))))
+ (revert-sound ind)
+
+
+ (let ((pfrs (mus-sound-framples "pistol.snd")))
+ (insert-sound "pistol.snd" 1000)
+ (if (not (= (framples) (+ frs pfrs))) (snd-display ";edit-list->function insert-sound: ~A ~A" frs (framples)))
(let ((func (edit-list->function)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 7g: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel-with-base '(0.0 0.0 1.0 1.0 2.0 1.0 3.0 0.0) 0.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 7g: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function 10a: ~A" func))
+ (if (not (member (procedure-source func)
+ '((lambda (snd chn) (insert-sound "/home/bil/cl/pistol.snd" 1000 0 snd chn))
+ (lambda (snd chn) (insert-sound "/home/bil/snd-16/pistol.snd" 1000 0 snd chn)))))
+ (snd-display ";edit-list->function 10a: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
- (if (fneq (sample 4000) 0.0) (snd-display #__line__ ";edit-list function 7g: ~A" (sample 4000))))
- (revert-sound ind)
-
- ;; ---- simple 1 sample insert
- (insert-sample 100 .1)
- (if (not (= (framples) (+ frs 1))) (snd-display #__line__ ";edit-list->function insert-sample: ~A ~A" frs (framples)))
+ (if (not (= (framples) (+ frs pfrs))) (snd-display ";edit-list->function called (10): ~A ~A" frs (framples)))))
+ (revert-sound ind)
+
+ (let ((pfrs (mus-sound-framples "pistol.snd")))
+ (insert-samples 1000 pfrs "pistol.snd")
+ (if (not (= (framples) (+ frs pfrs))) (snd-display ";edit-list->function insert-samples: ~A ~A" frs (framples)))
(let ((func (edit-list->function)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 9: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (insert-sample 100 0.1 snd chn))))
- (snd-display #__line__ ";edit-list->function 9: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function 11: ~A" func))
+ (if (not (member (procedure-source func)
+ '((lambda (snd chn) (insert-samples 1000 41623 "/home/bil/cl/pistol.snd" snd chn))
+ (lambda (snd chn) (insert-samples 1000 41623 "/home/bil/snd-16/pistol.snd" snd chn)))))
+ (snd-display ";edit-list->function 11: ~A" (procedure-source func)))
+ (revert-sound ind)
(func ind 0)
- (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.1 0.0)))
- (snd-display #__line__ ";edit-list->function func 9: ~A" (channel->float-vector 99 4)))
- (if (not (= (framples) (+ frs 2))) (snd-display #__line__ ";edit-list->function called (9): ~A ~A" frs (framples))))
+ (if (not (= (framples) (+ frs pfrs))) (snd-display ";edit-list->function called (11): ~A ~A" frs (framples)))))
+ (revert-sound ind)
+
+ (smooth-channel 1000 100)
+ (let ((func (edit-list->function))
+ (val (sample 1050)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 12: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 100 snd chn))))
+ (snd-display ";edit-list->function 12: ~A" (procedure-source func)))
(revert-sound ind)
-
- ;; ---- insert-samples with data
- (insert-samples 0 100 (make-float-vector 100 .1))
- (if (not (= (framples) (+ frs 100))) (snd-display #__line__ ";edit-list->function insert-samples (100): ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 9a: ~A" func))
- (func ind 0)
- (if (not (= (framples) (+ frs 200))) (snd-display #__line__ ";edit-list->function insert-samples (200): ~A ~A" frs (framples)))
- (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
- (snd-display #__line__ ";edit-list->function func 9a: ~A" (channel->float-vector 0 5))))
+ (func ind 0)
+ (if (fneq (sample 1050) val) (snd-display ";edit-list->function 12: ~A ~A" (sample 1050) val)))
+ (revert-sound ind)
+
+ (smooth-sound 1000 100)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 12a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 100 snd chn))))
+ (snd-display ";edit-list->function 12a: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ ;; ---- selection stuff
+ (make-selection 1000 11000)
+ (scale-selection-by 2.0)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 13: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 1000 10001 snd chn))))
+ (snd-display ";edit-list->function 13: ~A" (procedure-source func)))
(revert-sound ind)
-
- ;; ---- set-samples with data
- (set! (samples 0 100) (make-float-vector 100 .1))
- (if (not (= (framples) frs)) (snd-display #__line__ ";edit-list->function set-samples (1): ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 9b: ~A" func))
- (func ind 0)
- (if (not (= (framples) frs)) (snd-display #__line__ ";edit-list->function set-samples (2): ~A ~A" frs (framples)))
- (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
- (snd-display #__line__ ";edit-list->function func 9b: ~A" (channel->float-vector 0 5))))
+ (func ind 0)
+ (let ((mx (maxamp)))
+ (if (fneq mx .269) (snd-display ";edit-list->function called (13): ~A" mx))))
+ (revert-sound ind)
+
+ (scale-selection-to 1.0)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 13a: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (normalize-channel 1.0 1000 10001 snd chn))))
+ (snd-display ";edit-list->function 13a: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ (env-selection '(0 0 1 1 2 0))
+ (let ((func (edit-list->function)))
+ (if (fneq (sample 4000) 0.0173) (snd-display ";edit-list->function 14 samp: ~A" (sample 4000)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 14: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 1.0 2.0 0.0) :base 1.0 :end 10000) 1000 10001 snd chn))))
+ (snd-display ";edit-list->function 14: ~A" (procedure-source func)))
(revert-sound ind)
-
- ;; ---- simple 1 sample set
- (let ((val (sample 100)))
- (set! (sample 100) .1)
- (if (not (= (framples) frs)) (snd-display #__line__ ";edit-list->function set-sample framples: ~A ~A" frs (framples)))
- (if (fneq (sample 100) .1) (snd-display #__line__ ";edit-list->function set-sample val: ~A ~A" val (sample 100)))
- (let ((func (edit-list->function)))
- (revert-sound)
- (if (fneq val (sample 100)) (snd-display #__line__ ";edit-list->function unset-sample val: ~A ~A" val (sample 100)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 10: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (set-sample 100 0.1 snd chn))))
- (snd-display #__line__ ";edit-list->function 10: ~A" (procedure-source func)))
- (func ind 0)
- (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.0 0.0)))
- (snd-display #__line__ ";edit-list->function func 10: ~A" (channel->float-vector 99 4)))))
+ (func ind 0)
+ (if (fneq (sample 4000) 0.0173) (snd-display ";edit-list->function 14 re-samp: ~A" (sample 4000))))
+ (revert-sound ind)
+
+ (make-selection 1000 1100)
+ (smooth-selection)
+ (let ((func (edit-list->function))
+ (val (sample 1050)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 14a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 101 snd chn))))
+ (snd-display ";edit-list->function 14a: ~A" (procedure-source func)))
(revert-sound ind)
-
-
- (let ((pfrs (mus-sound-framples "pistol.snd")))
- (insert-sound "pistol.snd" 1000)
- (if (not (= (framples) (+ frs pfrs))) (snd-display #__line__ ";edit-list->function insert-sound: ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 10a: ~A" func))
- (if (and (not (equal? (procedure-source func)
- '(lambda (snd chn) (insert-sound "/home/bil/cl/pistol.snd" 1000 0 snd chn))))
- (not (equal? (procedure-source func)
- '(lambda (snd chn) (insert-sound "/home/bil/snd-16/pistol.snd" 1000 0 snd chn)))))
- (snd-display #__line__ ";edit-list->function 10a: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (not (= (framples) (+ frs pfrs))) (snd-display #__line__ ";edit-list->function called (10): ~A ~A" frs (framples)))))
+ (func ind 0)
+ (if (fneq (sample 1050) val) (snd-display ";edit-list->function 14a: ~A ~A" (sample 1050) val)))
+ (revert-sound ind)
+
+ (reverse-selection)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 14b: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 1000 101 snd chn))))
+ (snd-display ";edit-list->function 14b: ~A" (procedure-source func)))
(revert-sound ind)
-
- (let ((pfrs (mus-sound-framples "pistol.snd")))
- (insert-samples 1000 pfrs "pistol.snd")
- (if (not (= (framples) (+ frs pfrs))) (snd-display #__line__ ";edit-list->function insert-samples: ~A ~A" frs (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 11: ~A" func))
- (if (and (not (equal? (procedure-source func)
- '(lambda (snd chn) (insert-samples 1000 41623 "/home/bil/cl/pistol.snd" snd chn))))
- (not (equal? (procedure-source func)
- '(lambda (snd chn) (insert-samples 1000 41623 "/home/bil/snd-16/pistol.snd" snd chn)))))
- (snd-display #__line__ ";edit-list->function 11: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (not (= (framples) (+ frs pfrs))) (snd-display #__line__ ";edit-list->function called (11): ~A ~A" frs (framples)))))
+ (func ind 0))
+ (revert-sound ind)
+
+ (delete-selection)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 14c: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 1000 101 snd chn))))
+ (snd-display ";edit-list->function 14c: ~A" (procedure-source func)))
(revert-sound ind)
-
- (smooth-channel 1000 100)
+ (func ind 0))
+ (revert-sound ind)
+
+ ;; ---- simple reapply
+ (env-channel '(0 0 1 1 2 0))
+ (let ((func (edit-list->function)))
+ (close-sound ind)
+ (set! ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 20 :comment #f))
+ (map-channel (lambda (y) 1.0))
+ (func ind 0)
+ (let ((data (channel->float-vector)))
+ (if (not (vequal data (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.0)))
+ (snd-display ";edit-list->function env reapply: ~A" data)))
+ (close-sound ind)
+ (set! ind (open-sound "oboe.snd")))
+
+ ;; ---- insert-region
+ (let ((reg (make-region 1000 1100)))
+ (insert-region reg 2000)
(let ((func (edit-list->function))
- (val (sample 1050)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 12: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 100 snd chn))))
- (snd-display #__line__ ";edit-list->function 12: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (fneq (sample 1050) val) (snd-display #__line__ ";edit-list->function 12: ~A ~A" (sample 1050) val)))
- (revert-sound ind)
-
- (smooth-sound 1000 100)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 12a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 100 snd chn))))
- (snd-display #__line__ ";edit-list->function 12a: ~A" (procedure-source func))))
- (revert-sound ind)
-
- ;; ---- selection stuff
- (make-selection 1000 11000)
- (scale-selection-by 2.0)
- (let ((func (edit-list->function)))
+ (val (sample 2050)))
(if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 13: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 1000 10001 snd chn))))
- (snd-display #__line__ ";edit-list->function 13: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function 16: ~A" func))
(revert-sound ind)
(func ind 0)
- (let ((mx (maxamp)))
- (if (fneq mx .269) (snd-display #__line__ ";edit-list->function called (13): ~A" mx))))
+ (if (fneq (sample 2050) val) (snd-display ";edit-list->function 16: ~A ~A" (sample 2050) val))))
+ (revert-sound ind)
+
+ ;; ---- reverse
+ (reverse-channel)
+ (let ((func (edit-list->function))
+ (val (sample 2000)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 17: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 0 #f snd chn))))
+ (snd-display ";edit-list->function 17: ~A" (procedure-source func)))
+ (if (fneq val -.002) (snd-display ";edit-list->function val: ~A" val))
(revert-sound ind)
-
- (scale-selection-to 1.0)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 13a: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (normalize-channel 1.0 1000 10001 snd chn))))
- (snd-display #__line__ ";edit-list->function 13a: ~A" (procedure-source func))))
+ (func ind 0)
+ (if (fneq val -.002) (snd-display ";edit-list->function 17 re-val: ~A" val)))
+ (revert-sound ind)
+
+ (reverse-sound)
+ (let ((func (edit-list->function))
+ (val (sample 2000)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 17a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 0 #f snd chn))))
+ (snd-display ";edit-list->function 17a: ~A" (procedure-source func)))
+ (if (fneq val -.002) (snd-display ";edit-list->function 17a val: ~A" val)))
+ (revert-sound ind)
+
+ (reverse-channel 1000 500)
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 17b: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 1000 500 snd chn))))
+ (snd-display ";edit-list->function 17b: ~A" (procedure-source func))))
+ (revert-sound ind)
+
+ ;; ---- src
+ (src-sound 2.0)
+ (if (> (abs (- (framples) 25415)) 2) (snd-display ";edit-list->function 18 len: ~A" (framples)))
+ (let ((func (edit-list->function)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 18: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (src-channel 2.0 0 #f snd chn))))
+ (snd-display ";edit-list->function 18: ~A" (procedure-source func)))
(revert-sound ind)
-
- (env-selection '(0 0 1 1 2 0))
- (let ((func (edit-list->function)))
- (if (fneq (sample 4000) 0.0173) (snd-display #__line__ ";edit-list->function 14 samp: ~A" (sample 4000)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 14: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (env-channel (make-env '(0.0 0.0 1.0 1.0 2.0 0.0) :base 1.0 :end 10000) 1000 10001 snd chn))))
- (snd-display #__line__ ";edit-list->function 14: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (fneq (sample 4000) 0.0173) (snd-display #__line__ ";edit-list->function 14 re-samp: ~A" (sample 4000))))
+ (func ind 0)
+ (if (> (abs (- (framples) 25415)) 2) (snd-display ";edit-list->function 18 re-len: ~A" (framples))))
+ (revert-sound ind)
+
+ (src-channel 2.0 1000 500)
+ (let ((func (edit-list->function))
+ (frs (framples)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 18a: ~A" func))
+ (if (not (equal? (procedure-source func) '(lambda (snd chn) (src-channel 2.0 1000 500 snd chn))))
+ (snd-display ";edit-list->function 18a: ~A" (procedure-source func)))
(revert-sound ind)
-
- (make-selection 1000 1100)
- (smooth-selection)
- (let ((func (edit-list->function))
- (val (sample 1050)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 14a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (smooth-channel 1000 101 snd chn))))
- (snd-display #__line__ ";edit-list->function 14a: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (fneq (sample 1050) val) (snd-display #__line__ ";edit-list->function 14a: ~A ~A" (sample 1050) val)))
+ (func ind 0)
+ (if (not (= frs (framples))) (snd-display ";edit-list->function 18a re-len: ~A ~A" frs (framples))))
+ (revert-sound)
+
+ (src-sound '(0 1 1 2 2 1))
+ (let ((func (edit-list->function))
+ (frs (framples)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 18b: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (src-channel '(0.0 1.0 1.0 2.0 2.0 1.0) 0 #f snd chn))))
+ (snd-display ";edit-list->function 18b: ~A" (procedure-source func)))
(revert-sound ind)
-
- (reverse-selection)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 14b: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 1000 101 snd chn))))
- (snd-display #__line__ ";edit-list->function 14b: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0))
+ (func ind 0)
+ (if (not (= frs (framples))) (snd-display ";edit-list->function 18b re-len: ~A ~A" frs (framples))))
+ (revert-sound)
+
+ (src-channel '(0 1 1 2) 1000 500)
+ (let ((func (edit-list->function))
+ (frs (framples)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 18c: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (src-channel '(0.0 1.0 1.0 2.0) 1000 500 snd chn))))
+ (snd-display ";edit-list->function 18c: ~A" (procedure-source func)))
(revert-sound ind)
-
- (delete-selection)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 14c: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (delete-samples 1000 101 snd chn))))
- (snd-display #__line__ ";edit-list->function 14c: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0))
+ (func ind 0)
+ (if (not (= frs (framples))) (snd-display ";edit-list->function 18c re-len: ~A ~A" frs (framples))))
+ (revert-sound)
+
+ ;; ---- filter-channel
+ (filter-channel '(0 1 1 0) 10)
+ (let ((func (edit-list->function))
+ (mx (maxamp)))
+ (if (not (procedure? func))
+ (snd-display ";edit-list->function 19: ~A" func))
+ (if (not (equal? (procedure-source func)
+ '(lambda (snd chn) (filter-channel '(0.0 1.0 1.0 0.0) 10 0 #f snd chn))))
+ (snd-display ";edit-list->function 19: ~A" (procedure-source func)))
(revert-sound ind)
-
- ;; ---- simple reapply
- (env-channel '(0 0 1 1 2 0))
- (let ((func (edit-list->function)))
- (close-sound ind)
- (set! ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 20 :comment #f))
- (map-channel (lambda (y) 1.0))
- (func ind 0)
- (let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.0)))
- (snd-display #__line__ ";edit-list->function env reapply: ~A" data)))
- (close-sound ind)
- (set! ind (open-sound "oboe.snd")))
-
- ;; ---- insert-region
- (let ((reg (make-region 1000 1100)))
- (insert-region reg 2000)
- (let ((func (edit-list->function))
- (val (sample 2050)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 16: ~A" func))
- (revert-sound ind)
- (func ind 0)
- (if (fneq (sample 2050) val) (snd-display #__line__ ";edit-list->function 16: ~A ~A" (sample 2050) val))))
+ (func ind 0)
+ (if (fneq mx (maxamp)) (snd-display ";edit-list->function 19 re-filter: ~A ~A" mx (maxamp))))
+ (revert-sound)
+
+ (filter-fft (make-one-zero .5 .5))
+ (float-vector->channel (fft-smoother .1 (cursor) 400) (cursor) 400)
+ (revert-sound)
+
+ (let ((ind (new-sound :size 32)))
+ (select-sound ind)
+ (let ((ang 0.0))
+ (map-channel (lambda (y)
+ (let ((val (* .5 (+ (sin ang) (sin (* ang 4))))))
+ (set! ang (+ ang (/ (* 2 pi) 16.0)))
+ val))))
+ (let ((vals (fft-env-data '(0 0 .3 0 .4 1 1 1))))
+ (float-vector->channel vals)
+ (if (not (vequal vals (float-vector -0.000 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500 -0.000
+ -0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 0.000 -0.500 0.000 0.500
+ 0.000 -0.500 0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500)))
+ (snd-display ";fft-env-data: ~A" vals)))
+ (hilbert-transform-via-fft)
+ (let ((vals (channel->float-vector))
+ (nvals (float-vector -0.500 -0.000 0.500 -0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500
+ 0.000 -0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500 0.000
+ 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 -0.000 0.500 -0.000)))
+ (if (not (vequal vals nvals))
+ (snd-display ";hilbert via dft: ~A" vals)))
(revert-sound ind)
+ (map-channel (lambda (y) 1.0))
- ;; ---- reverse
- (reverse-channel)
- (let ((func (edit-list->function))
- (val (sample 2000)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 17: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 17: ~A" (procedure-source func)))
- (if (fneq val -.002) (snd-display #__line__ ";edit-list->function val: ~A" val))
- (revert-sound ind)
- (func ind 0)
- (if (fneq val -.002) (snd-display #__line__ ";edit-list->function 17 re-val: ~A" val)))
+ (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0.000 0.107 0.206 0.298 0.384 0.463 0.536 0.605 0.668 0.727 0.781 0.832 0.879
+ 0.922 0.963 1.000 1.000 0.787 0.618 0.484 0.377 0.293 0.226 0.173 0.130 0.097
+ 0.070 0.049 0.032 0.019 0.008 0.000)))
+ (snd-display ";powenv-channel: ~A" vals)))
+ (undo)
(revert-sound ind)
-
- (reverse-sound)
- (let ((func (edit-list->function))
- (val (sample 2000)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 17a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 17a: ~A" (procedure-source func)))
- (if (fneq val -.002) (snd-display #__line__ ";edit-list->function 17a val: ~A" val)))
+ (map-channel (lambda (y) 1.0))
+ (env-sound '(0 0 1 1))
+ (set! (cursor ind 0) 10)
+ (make-selection 0 7 ind 0)
+ (if (not (selection?))
+ (snd-display ";make-selection failed??")
+ (begin
+ (replace-with-selection)
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.000 0.032 0.065
+ 0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
+ 0.839 0.871 0.903 0.935 0.968 1.000)))
+ (snd-display ";replace-with-selection: ~A" vals)))))
+ (set! (cursor ind 0) 2)
+ (replace-with-selection)
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0.000 0.032 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.000 0.032 0.065
+ 0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
+ 0.839 0.871 0.903 0.935 0.968 1.000)))
+ (snd-display ";replace-with-selection (at 2): ~A" vals)))
(revert-sound ind)
+ (map-channel (lambda (y) 1.0))
+ (env-sound '(0 0 1 1))
- (reverse-channel 1000 500)
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 17b: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (reverse-channel 1000 500 snd chn))))
- (snd-display #__line__ ";edit-list->function 17b: ~A" (procedure-source func))))
- (revert-sound ind)
+ (let ((m1 (add-mark 10))
+ (m2 (add-mark 20)))
+ (make-selection 0 9)
+ (fit-selection-between-marks m1 m2)
+ (let ((vals (channel->float-vector)))
+ (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.323 0.387 0.452
+ 0.516 0.581 0.645 0.710 0.774 0.839 0.903 0.645 0.677 0.710 0.742 0.774 0.806
+ 0.839 0.871 0.903 0.935 0.968 1.000)))
+ (snd-display ";fit-selection-between-marks: ~A" vals))))
- ;; ---- src
- (src-sound 2.0)
- (if (> (abs (- (framples) 25415)) 2) (snd-display #__line__ ";edit-list->function 18 len: ~A" (framples)))
- (let ((func (edit-list->function)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 18: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (src-channel 2.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 18: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (> (abs (- (framples) 25415)) 2) (snd-display #__line__ ";edit-list->function 18 re-len: ~A" (framples))))
(revert-sound ind)
-
- (src-channel 2.0 1000 500)
- (let ((func (edit-list->function))
- (frs (framples)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 18a: ~A" func))
- (if (not (equal? (procedure-source func) '(lambda (snd chn) (src-channel 2.0 1000 500 snd chn))))
- (snd-display #__line__ ";edit-list->function 18a: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (not (= frs (framples))) (snd-display #__line__ ";edit-list->function 18a re-len: ~A ~A" frs (framples))))
- (revert-sound)
-
- (src-sound '(0 1 1 2 2 1))
- (let ((func (edit-list->function))
- (frs (framples)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 18b: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (src-channel '(0.0 1.0 1.0 2.0 2.0 1.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 18b: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (not (= frs (framples))) (snd-display #__line__ ";edit-list->function 18b re-len: ~A ~A" frs (framples))))
- (revert-sound)
-
- (src-channel '(0 1 1 2) 1000 500)
- (let ((func (edit-list->function))
- (frs (framples)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 18c: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (src-channel '(0.0 1.0 1.0 2.0) 1000 500 snd chn))))
- (snd-display #__line__ ";edit-list->function 18c: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (not (= frs (framples))) (snd-display #__line__ ";edit-list->function 18c re-len: ~A ~A" frs (framples))))
- (revert-sound)
-
- ;; ---- filter-channel
- (filter-channel '(0 1 1 0) 10)
- (let ((func (edit-list->function))
- (mx (maxamp)))
- (if (not (procedure? func))
- (snd-display #__line__ ";edit-list->function 19: ~A" func))
- (if (not (equal? (procedure-source func)
- '(lambda (snd chn) (filter-channel '(0.0 1.0 1.0 0.0) 10 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function 19: ~A" (procedure-source func)))
- (revert-sound ind)
- (func ind 0)
- (if (fneq mx (maxamp)) (snd-display #__line__ ";edit-list->function 19 re-filter: ~A ~A" mx (maxamp))))
- (revert-sound)
-
- (let ((op (make-one-zero .5 .5))) (filter-fft op))
- (float-vector->channel (fft-smoother .1 (cursor) 400) (cursor) 400)
- (revert-sound)
-
- (let ((ind (new-sound :size 32)))
- (select-sound ind)
- (let ((ang 0.0))
- (map-channel (lambda (y)
- (let ((val (+ (* .5 (sin ang)) (* .5 (sin (* ang 4))))))
- (set! ang (+ ang (/ (* 2 pi) 16.0)))
- val))))
- (let ((vals (fft-env-data '(0 0 .3 0 .4 1 1 1))))
- (float-vector->channel vals)
- (if (not (vequal vals (float-vector -0.000 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500 -0.000
- -0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 0.000 -0.500 0.000 0.500
- 0.000 -0.500 0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500)))
- (snd-display #__line__ ";fft-env-data: ~A" vals)))
- (hilbert-transform-via-fft)
- (let ((vals (channel->float-vector)))
- (let ((nvals (float-vector -0.500 -0.000 0.500 -0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500
- 0.000 -0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500 0.000
- 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 -0.000 0.500 -0.000)))
- (if (not (vequal vals nvals))
- (snd-display #__line__ ";hilbert via dft: ~A" vals))))
- (revert-sound ind)
- (map-channel (lambda (y) 1.0))
-
- (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.107 0.206 0.298 0.384 0.463 0.536 0.605 0.668 0.727 0.781 0.832 0.879
- 0.922 0.963 1.000 1.000 0.787 0.618 0.484 0.377 0.293 0.226 0.173 0.130 0.097
- 0.070 0.049 0.032 0.019 0.008 0.000)))
- (snd-display #__line__ ";powenv-channel: ~A" vals)))
- (undo)
- (revert-sound ind)
- (map-channel (lambda (y) 1.0))
- (env-sound '(0 0 1 1))
- (set! (cursor ind 0) 10)
- (make-selection 0 7 ind 0)
- (if (not (selection?))
- (snd-display #__line__ ";make-selection failed??")
- (begin
- (replace-with-selection)
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.000 0.032 0.065
- 0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
- 0.839 0.871 0.903 0.935 0.968 1.000)))
- (snd-display #__line__ ";replace-with-selection: ~A" vals)))))
- (set! (cursor ind 0) 2)
- (replace-with-selection)
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.000 0.032 0.065
- 0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
- 0.839 0.871 0.903 0.935 0.968 1.000)))
- (snd-display #__line__ ";replace-with-selection (at 2): ~A" vals)))
- (revert-sound ind)
- (map-channel (lambda (y) 1.0))
- (env-sound '(0 0 1 1))
-
- (let ((m1 (add-mark 10))
- (m2 (add-mark 20)))
- (make-selection 0 9)
- (fit-selection-between-marks m1 m2)
- (let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.323 0.387 0.452
- 0.516 0.581 0.645 0.710 0.774 0.839 0.903 0.645 0.677 0.710 0.742 0.774 0.806
- 0.839 0.871 0.903 0.935 0.968 1.000)))
- (snd-display #__line__ ";fit-selection-between-marks: ~A" vals))))
-
- (revert-sound ind)
- (map-channel (lambda (y) 1.0))
-
- (let ((ramper (make-ramp 10)))
- (map-channel (lambda (y) (ramp ramper y)))
- (let ((vals (channel->float-vector 0 20)))
- (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000 1.0
- 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
- (snd-display #__line__ ";make-ramp: ~A" vals))))
- (revert-sound ind)
- (float-vector->channel (with-sound ((make-float-vector 44100)) (cross-fade 0 2 1.0 "oboe.snd" "trumpet.snd" 0.5 1.0 0 .1 256 2)))
- (if (and (ffneq (maxamp) .142) (ffneq (maxamp) .155)) (snd-display #__line__ ";cross fade maxamp: ~A" (maxamp)))
- (revert-sound)
- (float-vector->channel (with-sound ((make-float-vector 44100)) (dissolve-fade 0 2 1.0 "oboe.snd" "trumpet.snd" 512 2 2 #f)))
-
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
-
- (let ((vals (apply float-vector (rms-envelope "oboe.snd" :rfreq 4))))
- (if (not (vequal vals (float-vector 0.0 0.0430 0.25 0.0642 0.5 0.0695 0.75 0.0722 1.0 0.0738 1.25 0.0713
- 1.5 0.065 1.75 0.0439 2.0 0.01275 2.25 0.007)))
- (snd-display #__line__ ";rms-envelope: ~A" vals)))
-
- (let ((ind (open-sound "2a.snd")))
- (hook-push graph-hook display-correlation)
- (update-time-graph)
- (set! (hook-functions graph-hook) ())
- (stereo->mono ind "hi1.snd" "hi2.snd")
- (let ((hi1 (find-sound "hi1.snd"))
- (hi2 (find-sound "hi2.snd")))
- (if (or (not hi1) (not hi2) (not (= (chans hi1) 1)) (not (= (chans hi2) 1)))
- (snd-display #__line__ ";stereo->mono: ~A ~A" (map file-name (sounds)) (map chans (sounds)))
- (let ((dist1 (channel-distance ind 0 hi1 0))
- (dist2 (channel-distance ind 1 hi2 0)))
- (if (or (fneq dist1 0.0) (fneq dist2 0.0))
- (snd-display #__line__ ";stereo->mono distances: ~A ~A" dist1 dist2))
- (mono->stereo "ho2.snd" hi1 0 hi2 0)
- (let ((ho2 (find-sound "ho2.snd")))
- (if (or (not ho2) (not (= (chans ho2) 2)))
- (snd-display #__line__ ";mono->stereo: ~A" (map file-name (sounds)))
- (let ((dist1 (channel-distance ho2 0 ind 0))
- (dist2 (channel-distance ho2 1 ind 1)))
- (if (or (fneq dist1 0.0) (fneq dist2 0.0))
- (snd-display #__line__ ";stereo->mono->stereo distances: ~A ~A" dist1 dist2))))
- (close-sound ho2))))
- (close-sound hi1)
- (close-sound hi2))
- (close-sound ind))
-
- (if (file-exists? "hi1.snd") (delete-file "hi1.snd"))
- (if (file-exists? "hi2.snd") (delete-file "hi2.snd"))
- (if (file-exists? "ho2.snd") (delete-file "ho2.snd"))
-
- (let ((ind (new-sound :size 1000)))
- (map-channel (lambda (y) 0.5))
- (map-channel (vibro 1000.0 .5))
- (let ((vals (channel->float-vector 0 20)))
- (if (and (not (vequal vals (float-vector 0.375 0.410 0.442 0.469 0.489 0.499 0.499 0.489 0.470 0.443 0.411 0.376
- 0.341 0.308 0.281 0.262 0.251 0.251 0.261 0.280)))
- (not (vequal vals (float-vector 0.375 0.393 0.410 0.427 0.442 0.457 0.469 0.480 0.489 0.495 0.499 0.500
- 0.499 0.495 0.489 0.480 0.470 0.457 0.443 0.428))))
- (snd-display #__line__ ";no vibro? ~A" vals)))
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
+ (map-channel (lambda (y) 1.0))
- (let ((ind (open-sound "pistol.snd")))
- (transposed-echo 1.1 .95 .25)
- (play :wait #t)
- (set! (channel-property 'colored-samples ind 0) (list (list *cursor-color* 0 100)))
- (hook-push after-graph-hook display-samples-in-color)
- (update-time-graph)
- (repitch-sound 220.0 440.0)
- (uncolor-samples)
- (retime-sound 1.0)
- (close-sound ind))
- (hook-remove after-graph-hook display-samples-in-color)
-
- (let ((val 0))
- (tree-for-each (lambda (n) (set! val (+ val n))) (list (list 1 0) (list 2) 3))
- (if (not (= val 6)) (snd-display #__line__ ";tree-for-each: ~A" val)))
-
- (let ((ind (new-sound :channels 4 :size 32)))
- (set! (sample 0 ind 0) 0.5)
- (set! (sample 10 ind 1) 0.25)
- (set! (sample 20 ind 2) 0.125)
- (set! (sample 30 ind 3) 0.0625)
- (scramble-channels 3 2 0 1) ; 3->0, 2->1, 0->2 1->3
- (if (or (fneq (sample 0 ind 2) .5) ; chan 0 is 2 after swaps
- (fneq (sample 10 ind 3) .25)
- (fneq (sample 20 ind 1) .125)
- (fneq (sample 30 ind 0) .0625))
- (snd-display #__line__ ";scramble-channels: ~A ~A ~A ~A (~A ~A ~A ~A)"
- (sample 0 ind 2) (sample 10 ind 3) (sample 20 ind 1) (sample 30 ind 2)
- (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
- (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
- (scramble-channels 3 0 1 2)
- (if (or (fneq (sample 0 ind 1) .5)
- (fneq (sample 10 ind 2) .25)
- (fneq (sample 20 ind 3) .125)
- (fneq (sample 30 ind 0) .0625))
- (snd-display #__line__ ";scramble-channels (1): ~A ~A ~A ~A (~A ~A ~A ~A)"
- (sample 0 ind 1) (sample 10 ind 2) (sample 20 ind 3) (sample 30 ind 0)
- (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
- (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
- (scramble-channels 0 1 3 2)
- (if (or (fneq (sample 0 ind 0) .5)
- (fneq (sample 10 ind 1) .25)
- (fneq (sample 20 ind 3) .125)
- (fneq (sample 30 ind 2) .0625))
- (snd-display #__line__ ";scramble-channels (2): ~A ~A ~A ~A (~A ~A ~A ~A)"
- (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 3) (sample 30 ind 2)
- (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
- (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
- (scramble-channels 1 2 3 0)
- (if (or (fneq (sample 0 ind 3) .5)
- (fneq (sample 10 ind 0) .25)
- (fneq (sample 20 ind 1) .125)
- (fneq (sample 30 ind 2) .0625))
- (snd-display #__line__ ";scramble-channels (3): ~A ~A ~A ~A (~A ~A ~A ~A)"
- (sample 0 ind 3) (sample 10 ind 0) (sample 20 ind 1) (sample 30 ind 2)
- (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
- (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
+ (let ((ramper (make-ramp 10)))
+ (map-channel (lambda (y) (ramp ramper y)))
+ (let ((vals (channel->float-vector 0 20)))
+ (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000 1.0
+ 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
+ (snd-display ";make-ramp: ~A" vals))))
+ (revert-sound ind)
+ (float-vector->channel (with-sound ((make-float-vector 44100)) (cross-fade 0 2 1.0 "oboe.snd" "trumpet.snd" 0.5 1.0 0 .1 256 2)))
+ (if (and (ffneq (maxamp) .142) (ffneq (maxamp) .155)) (snd-display ";cross fade maxamp: ~A" (maxamp)))
+ (revert-sound)
+ (float-vector->channel (with-sound ((make-float-vector 44100)) (dissolve-fade 0 2 1.0 "oboe.snd" "trumpet.snd" 512 2 2 #f)))
- (let ((ind (new-sound :channels 8 :size 10 :comment "new-sound for scramble-channels")))
- (do ((i 0 (+ i 1))) ((= i 8)) (set! (sample i ind i) .5))
- (scramble-channels 1 2 3 4 7 6 5 0)
- (if (or (fneq (sample 1 ind 0) .5)
- (fneq (sample 2 ind 1) .5)
- (fneq (sample 3 ind 2) .5)
- (fneq (sample 4 ind 3) .5)
- (fneq (sample 7 ind 4) .5)
- (fneq (sample 6 ind 5) .5)
- (fneq (sample 5 ind 6) .5)
- (fneq (sample 0 ind 7) .5))
- (snd-display #__line__ ";scramble-channels 8 ways: ~A"
- (list (sample 1 ind 0) (sample 2 ind 1) (sample 3 ind 2) (sample 4 ind 3)
- (sample 7 ind 4) (sample 6 ind 5) (sample 5 ind 6) (sample 0 ind 7))))
- (let ((new-file-name (file-name ind)))
- (close-sound ind)
- (if (file-exists? new-file-name) (delete-file new-file-name))))
-
- ;; ---- *.scm
- (if (and (defined? 'effects-squelch-channel)
+ (let ((new-file-name (file-name ind)))
+ (close-sound ind)
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+
+ (let ((vals (apply float-vector (rms-envelope "oboe.snd" :rfreq 4))))
+ (if (not (vequal vals (float-vector 0.0 0.0430 0.25 0.0642 0.5 0.0695 0.75 0.0722 1.0 0.0738 1.25 0.0713
+ 1.5 0.065 1.75 0.0439 2.0 0.01275 2.25 0.007)))
+ (snd-display ";rms-envelope: ~A" vals)))
+
+ (let ((ind (open-sound "2a.snd")))
+ (hook-push graph-hook display-correlation)
+ (update-time-graph)
+ (set! (hook-functions graph-hook) ())
+ (stereo->mono ind "hi1.snd" "hi2.snd")
+ (let ((hi1 (find-sound "hi1.snd"))
+ (hi2 (find-sound "hi2.snd")))
+ (if (not (and hi1 hi2 (= (chans hi1) 1) (= (chans hi2) 1)))
+ (snd-display ";stereo->mono: ~A ~A" (map file-name (sounds)) (map chans (sounds)))
+ (let ((dist1 (channel-distance ind 0 hi1 0))
+ (dist2 (channel-distance ind 1 hi2 0)))
+ (if (or (fneq dist1 0.0) (fneq dist2 0.0))
+ (snd-display ";stereo->mono distances: ~A ~A" dist1 dist2))
+ (mono->stereo "ho2.snd" hi1 0 hi2 0)
+ (let ((ho2 (find-sound "ho2.snd")))
+ (if (not (and ho2 (= (chans ho2) 2)))
+ (snd-display ";mono->stereo: ~A" (map file-name (sounds)))
+ (let ((dist1 (channel-distance ho2 0 ind 0))
+ (dist2 (channel-distance ho2 1 ind 1)))
+ (if (or (fneq dist1 0.0) (fneq dist2 0.0))
+ (snd-display ";stereo->mono->stereo distances: ~A ~A" dist1 dist2))))
+ (close-sound ho2))))
+ (close-sound hi1)
+ (close-sound hi2))
+ (close-sound ind))
+
+ (if (file-exists? "hi1.snd") (delete-file "hi1.snd"))
+ (if (file-exists? "hi2.snd") (delete-file "hi2.snd"))
+ (if (file-exists? "ho2.snd") (delete-file "ho2.snd"))
+
+ (let ((ind (new-sound :size 1000)))
+ (map-channel (lambda (y) 0.5))
+ (map-channel (vibro 1000.0 .5))
+ (let ((vals (channel->float-vector 0 20)))
+ (if (not (or (vequal vals (float-vector 0.375 0.410 0.442 0.469 0.489 0.499 0.499 0.489 0.470 0.443 0.411 0.376
+ 0.341 0.308 0.281 0.262 0.251 0.251 0.261 0.280))
+ (vequal vals (float-vector 0.375 0.393 0.410 0.427 0.442 0.457 0.469 0.480 0.489 0.495 0.499 0.500
+ 0.499 0.495 0.489 0.480 0.470 0.457 0.443 0.428))))
+ (snd-display ";no vibro? ~A" vals)))
+ (let ((new-file-name (file-name ind)))
+ (close-sound ind)
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+
+ (let ((ind (open-sound "pistol.snd")))
+ (transposed-echo 1.1 .95 .25)
+ (play :wait #t)
+ (set! (channel-property 'colored-samples ind 0) (list (list *cursor-color* 0 100)))
+ (hook-push after-graph-hook display-samples-in-color)
+ (update-time-graph)
+ (repitch-sound 220.0 440.0)
+ (uncolor-samples)
+ (retime-sound 1.0)
+ (close-sound ind))
+ (hook-remove after-graph-hook display-samples-in-color)
+
+ (let ((val 0))
+ (tree-for-each (lambda (n) (set! val (+ val n))) (list (list 1 0) (list 2) 3))
+ (if (not (= val 6)) (snd-display ";tree-for-each: ~A" val)))
+
+ (let ((ind (new-sound :channels 4 :size 32)))
+ (set! (sample 0 ind 0) 0.5)
+ (set! (sample 10 ind 1) 0.25)
+ (set! (sample 20 ind 2) 0.125)
+ (set! (sample 30 ind 3) 0.0625)
+ (scramble-channels 3 2 0 1) ; 3->0, 2->1, 0->2 1->3
+ (if (or (fneq (sample 0 ind 2) .5) ; chan 0 is 2 after swaps
+ (fneq (sample 10 ind 3) .25)
+ (fneq (sample 20 ind 1) .125)
+ (fneq (sample 30 ind 0) .0625))
+ (snd-display ";scramble-channels: ~A ~A ~A ~A (~A ~A ~A ~A)"
+ (sample 0 ind 2) (sample 10 ind 3) (sample 20 ind 1) (sample 30 ind 2)
+ (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
+ (scramble-channels 3 0 1 2)
+ (if (or (fneq (sample 0 ind 1) .5)
+ (fneq (sample 10 ind 2) .25)
+ (fneq (sample 20 ind 3) .125)
+ (fneq (sample 30 ind 0) .0625))
+ (snd-display ";scramble-channels (1): ~A ~A ~A ~A (~A ~A ~A ~A)"
+ (sample 0 ind 1) (sample 10 ind 2) (sample 20 ind 3) (sample 30 ind 0)
+ (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
+ (scramble-channels 0 1 3 2)
+ (if (or (fneq (sample 0 ind 0) .5)
+ (fneq (sample 10 ind 1) .25)
+ (fneq (sample 20 ind 3) .125)
+ (fneq (sample 30 ind 2) .0625))
+ (snd-display ";scramble-channels (2): ~A ~A ~A ~A (~A ~A ~A ~A)"
+ (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 3) (sample 30 ind 2)
+ (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
+ (scramble-channels 1 2 3 0)
+ (if (or (fneq (sample 0 ind 3) .5)
+ (fneq (sample 10 ind 0) .25)
+ (fneq (sample 20 ind 1) .125)
+ (fneq (sample 30 ind 2) .0625))
+ (snd-display ";scramble-channels (3): ~A ~A ~A ~A (~A ~A ~A ~A)"
+ (sample 0 ind 3) (sample 10 ind 0) (sample 20 ind 1) (sample 30 ind 2)
+ (sample 0 ind 0) (sample 10 ind 1) (sample 20 ind 2) (sample 30 ind 3)))
+ (do ((i 0 (+ i 1))) ((= i 4)) (set! (edit-position ind i) 1))
+ (let ((new-file-name (file-name ind)))
+ (close-sound ind)
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+
+ (let ((ind (new-sound :channels 8 :size 10 :comment "new-sound for scramble-channels")))
+ (do ((i 0 (+ i 1))) ((= i 8)) (set! (sample i ind i) .5))
+ (scramble-channels 1 2 3 4 7 6 5 0)
+ (if (or (fneq (sample 1 ind 0) .5)
+ (fneq (sample 2 ind 1) .5)
+ (fneq (sample 3 ind 2) .5)
+ (fneq (sample 4 ind 3) .5)
+ (fneq (sample 7 ind 4) .5)
+ (fneq (sample 6 ind 5) .5)
+ (fneq (sample 5 ind 6) .5)
+ (fneq (sample 0 ind 7) .5))
+ (snd-display ";scramble-channels 8 ways: ~A"
+ (list (sample 1 ind 0) (sample 2 ind 1) (sample 3 ind 2) (sample 4 ind 3)
+ (sample 7 ind 4) (sample 6 ind 5) (sample 5 ind 6) (sample 0 ind 7))))
+ (let ((new-file-name (file-name ind)))
+ (close-sound ind)
+ (if (file-exists? new-file-name) (delete-file new-file-name))))
+
+ ;; ---- *.scm
+ (when (and (defined? 'effects-squelch-channel)
(or (provided? 'xm) (provided? 'xg)))
- (let ((ctr 1))
- (for-each
- (lambda (func1 descr)
- (func1)
- (let ((func (edit-list->function)))
- (if (not (equal? (procedure-source func) descr))
- (snd-display #__line__ ";edit-list->function 20[~D]:~%; [~A]~%; [~A]" ctr descr (procedure-source func)))
- (revert-sound ind)
- (func ind 0))
- (set! ctr (+ ctr 1))
- (revert-sound ind))
- (list
- (lambda () (insert-float-vector (float-vector 1.0 0.5) 0 2))
- clm-channel-test
-
- ;; examp.scm
- (lambda () (fft-edit 1000 3000))
- (lambda () (fft-squelch .01))
- (lambda () (fft-cancel 1000 3000))
- squelch-vowels
- (lambda () (fft-env-edit '(0 0 1 1 2 0)))
- (lambda () (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1)))
- (lambda () (hello-dentist 10.0 .1))
- (lambda () (fp 1.0 0.3 20.0))
- (lambda () (expsnd '(0 1 1 2)))
- (lambda () (env-sound-interp '(0 0 1 1 2 0) 2.0))
- (lambda () (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0))))
- (lambda () (filtered-env '(0 0 1 1 2 0)))
- (lambda () (reverse-by-blocks .1))
- (lambda () (reverse-within-blocks .1))
-
- ;; extensions.scm
- (lambda () (mix-channel "1a.snd" 1200))
- (lambda () (insert-channel "1a.snd" 1200))
- (lambda () (sine-ramp 0.5 0.9))
- (lambda () (sine-env-channel '(0 0 1 1 2 -0.5 3 1)))
- (lambda () (blackman4-ramp 0.0 1.0))
- (lambda () (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1)))
- (lambda () (ramp-squared 0.2 0.8 #t))
- (lambda () (env-squared-channel '(0.0 0.0 1.0 1.0) #t))
- (lambda () (ramp-expt 0.2 0.8 32.0 #t))
- (lambda () (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t))
- (lambda () (offset-channel .1))
- (lambda () (dither-channel .1))
- (lambda () (contrast-channel .1))
-
- ;; dsp.scm
- (lambda () (ssb-bank 550 600 10))
- (lambda () (ssb-bank-env 550 600 '(0 1 1 2) 10))
- (lambda () (down-oct 1))
- spike
- zero-phase
- (lambda () (rotate-phase (lambda (x) (random pi))))
- (lambda () (brighten-slightly .5))
- (lambda () (shift-channel-pitch 100))
- (lambda () (channel-polynomial (float-vector 0.0 0.5)))
- (lambda () (spectral-polynomial (float-vector 0.0 1.0)))
- (lambda () (notch-channel (list 60.0 120.0 240.0) #f #f #f))
-
- ;; ---- new-effects.scm
- (lambda () (effects-squelch-channel .1 128))
- (lambda () (effects-echo #f 0.5 0.1 0 #f))
- (lambda () (effects-flecho-1 0.5 0.1 #f 0 #f))
- (lambda () (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f))
- ;; (lambda () (effects-comb-filter 0.1 50 0 #f))
- (lambda () (effects-moog 10000 0.5 0 #f))
- effects-remove-dc
- effects-compand
- (lambda () (effects-am 100.0 #f))
- (lambda () (effects-rm 100.0 #f))
- (lambda () (effects-bbp 1000.0 100.0 0 #f))
- (lambda () (effects-bbr 1000.0 100.0 0 #f))
- (lambda () (effects-bhp 1000.0 0 #f))
- (lambda () (effects-blp 1000.0 0 #f))
- (lambda () (effects-hello-dentist 50.0 0.5 0 #f))
- (lambda () (effects-fp 1.0 0.3 20.0 0 #f))
- (lambda () (effects-flange 5.0 2.0 0.001 0 #f))
- (lambda () (effects-jc-reverb-1 0.1 0 #f))
-
- )
- (list
- '(lambda (snd chn) (insert-float-vector (float-vector 1.0 0.5) 0 2 snd chn))
- '(lambda (snd chn) (clm-channel-test snd chn))
-
- '(lambda (snd chn) (fft-edit 1000 3000 snd chn))
- '(lambda (snd chn) (fft-squelch 0.01 snd chn))
- '(lambda (snd chn) (fft-cancel 1000 3000 snd chn))
- '(lambda (snd chn) (squelch-vowels snd chn))
- '(lambda (snd chn) (fft-env-edit '(0 0 1 1 2 0) snd chn))
- '(lambda (snd chn) (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1) snd chn))
- '(lambda (snd chn) (hello-dentist 10.0 0.1 snd chn))
- '(lambda (snd chn) (fp 1.0 0.3 20.0 snd chn))
- '(lambda (snd chn) (expsnd '(0 1 1 2) snd chn))
- '(lambda (snd chn) (env-sound-interp '(0 0 1 1 2 0) 2.0 snd chn))
- '(lambda (snd chn) (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0)) snd chn))
- '(lambda (snd chn) (filtered-env '(0 0 1 1 2 0) snd chn))
- '(lambda (snd chn) (reverse-by-blocks 0.1 snd chn))
- '(lambda (snd chn) (reverse-within-blocks 0.1 snd chn))
-
- '(lambda (snd chn) (mix-channel "1a.snd" 1200 #f snd chn))
- '(lambda (snd chn) (insert-channel "1a.snd" 1200 #f snd chn))
- '(lambda (snd chn) (sine-ramp 0.5 0.9 0 #f snd chn))
- '(lambda (snd chn) (sine-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
- '(lambda (snd chn) (blackman4-ramp 0.0 1.0 0 #f snd chn))
- '(lambda (snd chn) (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
- '(lambda (snd chn) (ramp-squared 0.2 0.8 #t 0 #f snd chn))
- '(lambda (snd chn) (env-squared-channel '(0.0 0.0 1.0 1.0) #t 0 #f snd chn))
- '(lambda (snd chn) (ramp-expt 0.2 0.8 32.0 #t 0 #f snd chn))
- '(lambda (snd chn) (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t 0 #f snd chn))
- '(lambda (snd chn) (offset-channel 0.1 0 #f snd chn))
- '(lambda (snd chn) (dither-channel 0.1 0 #f snd chn))
- '(lambda (snd chn) (contrast-channel 0.1 0 #f snd chn))
-
- '(lambda (snd chn) (ssb-bank 550 600 10 40 50.0 0 #f snd chn))
- '(lambda (snd chn) (ssb-bank-env 550 600 '(0 1 1 2) 10 40 50.0 0 #f snd chn))
- '(lambda (snd chn) (down-oct 1 snd chn))
- '(lambda (snd chn) (spike snd chn))
- '(lambda (snd chn) (zero-phase snd chn))
- '(lambda (snd chn) (rotate-phase (lambda (x) (random pi)) snd chn))
- '(lambda (snd chn) (brighten-slightly 0.5 snd chn))
- '(lambda (snd chn) (shift-channel-pitch 100 40 0 #f snd chn))
- '(lambda (snd chn) (channel-polynomial (float-vector 0.0 0.5) snd chn))
- '(lambda (snd chn) (spectral-polynomial (float-vector 0.0 1.0) snd chn))
- '(lambda (snd chn) (notch-channel '(60.0 120.0 240.0) #f #f #f snd chn))
-
- '(lambda (snd chn) (effects-squelch-channel 0.1 128 snd chn))
- '(lambda (snd chn) (effects-echo #f 0.5 0.1 0 #f snd chn))
- '(lambda (snd chn) (effects-flecho-1 0.5 0.1 #f 0 #f snd chn))
- '(lambda (snd chn) (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f snd chn))
- ;; '(lambda (snd chn) (effects-comb-filter 0.1 50 0 #f snd chn))
- '(lambda (snd chn) (effects-moog 10000 0.5 0 #f snd chn))
- '(lambda (snd chn) (effects-remove-dc snd chn))
- '(lambda (snd chn) (effects-compand snd chn))
- '(lambda (snd chn) (effects-am 100.0 #f #f #f snd chn))
- '(lambda (snd chn) (effects-rm 100.0 #f #f #f snd chn))
- '(lambda (snd chn) (effects-bbp 1000.0 100.0 0 #f snd chn))
- '(lambda (snd chn) (effects-bbr 1000.0 100.0 0 #f snd chn))
- '(lambda (snd chn) (effects-bhp 1000.0 0 #f snd chn))
- '(lambda (snd chn) (effects-blp 1000.0 0 #f snd chn))
- '(lambda (snd chn) (effects-hello-dentist 50.0 0.5 0 #f snd chn))
- '(lambda (snd chn) (effects-fp 1.0 0.3 20.0 0 #f snd chn))
- '(lambda (snd chn) (effects-flange 5.0 2.0 0.001 0 #f snd chn))
- '(lambda (snd chn) (effects-jc-reverb-1 0.1 0 #f snd chn))
- ))))
- (close-sound ind)
- ))
+ (let ((ctr 1))
+ (for-each
+ (lambda (func1 descr)
+ (func1)
+ (let ((func (edit-list->function)))
+ (if (not (equal? (procedure-source func) descr))
+ (snd-display ";edit-list->function 20[~D]:~%; [~A]~%; [~A]" ctr descr (procedure-source func)))
+ (revert-sound ind)
+ (func ind 0))
+ (set! ctr (+ ctr 1))
+ (revert-sound ind))
+ (list
+ (lambda () (insert-float-vector (float-vector 1.0 0.5) 0 2))
+ clm-channel-test
+
+ ;; examp.scm
+ (lambda () (fft-edit 1000 3000))
+ (lambda () (fft-squelch .01))
+ (lambda () (fft-cancel 1000 3000))
+ squelch-vowels
+ (lambda () (fft-env-edit '(0 0 1 1 2 0)))
+ (lambda () (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1)))
+ (lambda () (hello-dentist 10.0 .1))
+ (lambda () (fp 1.0 0.3 20.0))
+ (lambda () (expsnd '(0 1 1 2)))
+ (lambda () (env-sound-interp '(0 0 1 1 2 0) 2.0))
+ (lambda () (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0))))
+ (lambda () (filtered-env '(0 0 1 1 2 0)))
+ (lambda () (reverse-by-blocks .1))
+ (lambda () (reverse-within-blocks .1))
+
+ ;; extensions.scm
+ (lambda () (mix-channel "1a.snd" 1200))
+ (lambda () (insert-channel "1a.snd" 1200))
+ (lambda () (sine-ramp 0.5 0.9))
+ (lambda () (sine-env-channel '(0 0 1 1 2 -0.5 3 1)))
+ (lambda () (blackman4-ramp 0.0 1.0))
+ (lambda () (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1)))
+ (lambda () (ramp-squared 0.2 0.8 #t))
+ (lambda () (env-squared-channel '(0.0 0.0 1.0 1.0) #t))
+ (lambda () (ramp-expt 0.2 0.8 32.0 #t))
+ (lambda () (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t))
+ (lambda () (offset-channel .1))
+ (lambda () (dither-channel .1))
+ (lambda () (contrast-channel .1))
+
+ ;; dsp.scm
+ (lambda () (ssb-bank 550 600 10))
+ (lambda () (ssb-bank-env 550 600 '(0 1 1 2) 10))
+ (lambda () (down-oct 1))
+ spike
+ zero-phase
+ (lambda () (rotate-phase (lambda (x) (random pi))))
+ (lambda () (brighten-slightly .5))
+ (lambda () (shift-channel-pitch 100))
+ (lambda () (channel-polynomial (float-vector 0.0 0.5)))
+ (lambda () (spectral-polynomial (float-vector 0.0 1.0)))
+ (lambda () (notch-channel (list 60.0 120.0 240.0) #f #f #f))
+
+ ;; ---- new-effects.scm
+ (lambda () (effects-squelch-channel .1 128))
+ (lambda () (effects-echo #f 0.5 0.1 0 #f))
+ (lambda () (effects-flecho-1 0.5 0.1 #f 0 #f))
+ (lambda () (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f))
+ ;; (lambda () (effects-comb-filter 0.1 50 0 #f))
+ (lambda () (effects-moog 10000 0.5 0 #f))
+ effects-remove-dc
+ effects-compand
+ (lambda () (effects-am 100.0 #f))
+ (lambda () (effects-rm 100.0 #f))
+ (lambda () (effects-bbp 1000.0 100.0 0 #f))
+ (lambda () (effects-bbr 1000.0 100.0 0 #f))
+ (lambda () (effects-bhp 1000.0 0 #f))
+ (lambda () (effects-blp 1000.0 0 #f))
+ (lambda () (effects-hello-dentist 50.0 0.5 0 #f))
+ (lambda () (effects-fp 1.0 0.3 20.0 0 #f))
+ (lambda () (effects-flange 5.0 2.0 0.001 0 #f))
+ (lambda () (effects-jc-reverb-1 0.1 0 #f))
+
+ )
+ (list
+ '(lambda (snd chn) (insert-float-vector (float-vector 1.0 0.5) 0 2 snd chn))
+ '(lambda (snd chn) (clm-channel-test snd chn))
+
+ '(lambda (snd chn) (fft-edit 1000 3000 snd chn))
+ '(lambda (snd chn) (fft-squelch 0.01 snd chn))
+ '(lambda (snd chn) (fft-cancel 1000 3000 snd chn))
+ '(lambda (snd chn) (squelch-vowels snd chn))
+ '(lambda (snd chn) (fft-env-edit '(0 0 1 1 2 0) snd chn))
+ '(lambda (snd chn) (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1) snd chn))
+ '(lambda (snd chn) (hello-dentist 10.0 0.1 snd chn))
+ '(lambda (snd chn) (fp 1.0 0.3 20.0 snd chn))
+ '(lambda (snd chn) (expsnd '(0 1 1 2) snd chn))
+ '(lambda (snd chn) (env-sound-interp '(0 0 1 1 2 0) 2.0 snd chn))
+ '(lambda (snd chn) (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0)) snd chn))
+ '(lambda (snd chn) (filtered-env '(0 0 1 1 2 0) snd chn))
+ '(lambda (snd chn) (reverse-by-blocks 0.1 snd chn))
+ '(lambda (snd chn) (reverse-within-blocks 0.1 snd chn))
+
+ '(lambda (snd chn) (mix-channel "1a.snd" 1200 #f snd chn))
+ '(lambda (snd chn) (insert-channel "1a.snd" 1200 #f snd chn))
+ '(lambda (snd chn) (sine-ramp 0.5 0.9 0 #f snd chn))
+ '(lambda (snd chn) (sine-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
+ '(lambda (snd chn) (blackman4-ramp 0.0 1.0 0 #f snd chn))
+ '(lambda (snd chn) (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
+ '(lambda (snd chn) (ramp-squared 0.2 0.8 #t 0 #f snd chn))
+ '(lambda (snd chn) (env-squared-channel '(0.0 0.0 1.0 1.0) #t 0 #f snd chn))
+ '(lambda (snd chn) (ramp-expt 0.2 0.8 32.0 #t 0 #f snd chn))
+ '(lambda (snd chn) (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t 0 #f snd chn))
+ '(lambda (snd chn) (offset-channel 0.1 0 #f snd chn))
+ '(lambda (snd chn) (dither-channel 0.1 0 #f snd chn))
+ '(lambda (snd chn) (contrast-channel 0.1 0 #f snd chn))
+
+ '(lambda (snd chn) (ssb-bank 550 600 10 40 50.0 0 #f snd chn))
+ '(lambda (snd chn) (ssb-bank-env 550 600 '(0 1 1 2) 10 40 50.0 0 #f snd chn))
+ '(lambda (snd chn) (down-oct 1 snd chn))
+ '(lambda (snd chn) (spike snd chn))
+ '(lambda (snd chn) (zero-phase snd chn))
+ '(lambda (snd chn) (rotate-phase (lambda (x) (random pi)) snd chn))
+ '(lambda (snd chn) (brighten-slightly 0.5 snd chn))
+ '(lambda (snd chn) (shift-channel-pitch 100 40 0 #f snd chn))
+ '(lambda (snd chn) (channel-polynomial (float-vector 0.0 0.5) snd chn))
+ '(lambda (snd chn) (spectral-polynomial (float-vector 0.0 1.0) snd chn))
+ '(lambda (snd chn) (notch-channel '(60.0 120.0 240.0) #f #f #f snd chn))
+
+ '(lambda (snd chn) (effects-squelch-channel 0.1 128 snd chn))
+ '(lambda (snd chn) (effects-echo #f 0.5 0.1 0 #f snd chn))
+ '(lambda (snd chn) (effects-flecho-1 0.5 0.1 #f 0 #f snd chn))
+ '(lambda (snd chn) (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f snd chn))
+ ;; '(lambda (snd chn) (effects-comb-filter 0.1 50 0 #f snd chn))
+ '(lambda (snd chn) (effects-moog 10000 0.5 0 #f snd chn))
+ '(lambda (snd chn) (effects-remove-dc snd chn))
+ '(lambda (snd chn) (effects-compand snd chn))
+ '(lambda (snd chn) (effects-am 100.0 #f #f #f snd chn))
+ '(lambda (snd chn) (effects-rm 100.0 #f #f #f snd chn))
+ '(lambda (snd chn) (effects-bbp 1000.0 100.0 0 #f snd chn))
+ '(lambda (snd chn) (effects-bbr 1000.0 100.0 0 #f snd chn))
+ '(lambda (snd chn) (effects-bhp 1000.0 0 #f snd chn))
+ '(lambda (snd chn) (effects-blp 1000.0 0 #f snd chn))
+ '(lambda (snd chn) (effects-hello-dentist 50.0 0.5 0 #f snd chn))
+ '(lambda (snd chn) (effects-fp 1.0 0.3 20.0 0 #f snd chn))
+ '(lambda (snd chn) (effects-flange 5.0 2.0 0.001 0 #f snd chn))
+ '(lambda (snd chn) (effects-jc-reverb-1 0.1 0 #f snd chn))
+ ))))
+ (close-sound ind)
+ )
;; ---- apply controls edit lists
- (let ((ind (open-sound "oboe.snd"))
- (original-maxamp (maxamp)))
- (reset-controls)
- (controls->channel (list 2.0))
- (if (fneq (amp-control ind) 1.0) (snd-display #__line__ ";controls->channel amp: ~A" (amp-control ind)))
- (if (fneq (maxamp) (* 2 original-maxamp)) (snd-display #__line__ ";controls->channel maxamp: ~A" (maxamp)))
+ (let ((ind (open-sound "oboe.snd")))
+ (let ((original-maxamp (maxamp)))
+ (reset-controls)
+ (controls->channel (list 2.0))
+ (if (fneq (amp-control ind) 1.0) (snd-display ";controls->channel amp: ~A" (amp-control ind)))
+ (if (fneq (maxamp) (* 2 original-maxamp)) (snd-display ";controls->channel maxamp: ~A" (maxamp))))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (scale-channel 2.0 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 1: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 1: ~A" (procedure-source func)))
(func ind 0)
(revert-sound ind))
(controls->channel (list #f 2.0))
(let ((pk (float-vector-peak (channel->float-vector 22000 22100))))
- (if (fneq pk 0.0479) (snd-display #__line__ ";dp->end screwed up again!?!: ~A" pk)))
+ (if (fneq pk 0.0479) (snd-display ";dp->end screwed up again!?!: ~A" pk)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (controls->channel '(#f 2.0) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 2: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 2: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (fneq (speed-control ind) 1.0) (snd-display #__line__ ";controls->channel speed: ~A" (speed-control ind))))
+ (if (fneq (speed-control ind) 1.0) (snd-display ";controls->channel speed: ~A" (speed-control ind))))
(controls->channel (list #f #f (list 0.5)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (controls->channel '(#f #f (0.5)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 3: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 3: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (fneq (contrast-control ind) 0.0) (snd-display #__line__ ";controls->channel contrast: ~A" (contrast-control ind))))
+ (if (fneq (contrast-control ind) 0.0) (snd-display ";controls->channel contrast: ~A" (contrast-control ind))))
(controls->channel (list #f #f (list 0.5 2.0)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (controls->channel '(#f #f (0.5 2.0)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 3a: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 3a: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (fneq (contrast-control ind) 0.0) (snd-display #__line__ ";controls->channel contrast 3a: ~A" (contrast-control ind))))
+ (if (fneq (contrast-control ind) 0.0) (snd-display ";controls->channel contrast 3a: ~A" (contrast-control ind))))
(controls->channel (list #f #f #f (list 0.5)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (controls->channel '(#f #f #f (0.5)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 4: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 4: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (ffneq (expand-control ind) 1.0) (snd-display #__line__ ";controls->channel expand: ~A" (expand-control ind))))
+ (if (ffneq (expand-control ind) 1.0) (snd-display ";controls->channel expand: ~A" (expand-control ind))))
(controls->channel (list #f #f #f (list 0.5 .1 .2 .06 0.0)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func)
'(lambda (snd chn) (controls->channel '(#f #f #f (0.5 0.1 0.2 0.06 0.0)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 4a: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 4a: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (ffneq (expand-control ind) 1.0) (snd-display #__line__ ";controls->channel expand 4a: ~A" (expand-control ind))))
+ (if (ffneq (expand-control ind) 1.0) (snd-display ";controls->channel expand 4a: ~A" (expand-control ind))))
(controls->channel (list #f #f #f #f (list 0.1)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func) '(lambda (snd chn) (controls->channel '(#f #f #f #f (0.1)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 5: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 5: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (fneq (reverb-control-scale ind) 0.0) (snd-display #__line__ ";controls->channel reverb: ~A" (reverb-control-scale ind))))
+ (if (fneq (reverb-control-scale ind) 0.0) (snd-display ";controls->channel reverb: ~A" (reverb-control-scale ind))))
(controls->channel (list #f #f #f #f (list 0.1 1.2 0.9 0.9 2.0)))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func)
'(lambda (snd chn) (controls->channel '(#f #f #f #f (0.1 1.2 0.9 0.9 2.0)) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 5a: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 5a: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (fneq (reverb-control-scale ind) 0.0) (snd-display #__line__ ";controls->channel reverb 5a: ~A" (reverb-control-scale ind))))
+ (if (fneq (reverb-control-scale ind) 0.0) (snd-display ";controls->channel reverb 5a: ~A" (reverb-control-scale ind))))
(let ((order (filter-control-order ind)))
(controls->channel (list #f #f #f #f #f (list 10 '(0 0 1 1))))
(let ((func (edit-list->function)))
(if (not (equal? (procedure-source func)
'(lambda (snd chn) (controls->channel '(#f #f #f #f #f (10 (0 0 1 1))) 0 #f snd chn))))
- (snd-display #__line__ ";edit-list->function controls->channel 6: ~A" (procedure-source func)))
+ (snd-display ";edit-list->function controls->channel 6: ~A" (procedure-source func)))
(revert-sound ind)
(func ind 0)
(revert-sound ind)
- (if (not (= (filter-control-order ind) order)) (snd-display #__line__ ";controls->channel filter: ~A" (filter-control-order ind)))))
+ (if (not (= (filter-control-order ind) order)) (snd-display ";controls->channel filter: ~A" (filter-control-order ind)))))
(close-sound ind))
@@ -34686,25 +34039,25 @@ EDITS: 1
(save-sound-as "test.snd")
(close-sound ind)
(set! ind (open-sound "test.snd"))
- (if (not (= (chans ind) 2)) (snd-display #__line__ ";src-sound/save-sound-as-> ~D chans" (chans ind)))
+ (if (not (= (chans ind) 2)) (snd-display ";src-sound/save-sound-as-> ~D chans" (chans ind)))
(let ((tag (scan-channel (lambda (y) (> (abs y) 0.0)) 8000 #f)))
- (if tag (snd-display #__line__ ";src-sound/save-sound-as not zeros: ~A ~A" tag (sample (cadr tag) ind 0))))
+ (if tag (snd-display ";src-sound/save-sound-as not zeros: ~A ~A" tag (sample (cadr tag) ind 0))))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
(let ((tag (catch #t (lambda () (save-sound-as "test.snd" :edit-position 1)) (lambda args args))))
- (if (or (not tag)
- (not (eq? (car tag) 'no-such-edit)))
- (snd-display #__line__ ";save-sound-as bad edpos: ~A" tag)))
+ (if (not (and tag
+ (eq? (car tag) 'no-such-edit)))
+ (snd-display ";save-sound-as bad edpos: ~A" tag)))
(let ((tag (catch #t (lambda () (save-sound-as "test.snd" :channel 1 :edit-position 1)) (lambda args args))))
- (if (or (not tag)
- (not (eq? (car tag) 'no-such-channel)))
- (snd-display #__line__ ";save-sound-as bad chan: ~A" tag)))
+ (if (not (and tag
+ (eq? (car tag) 'no-such-channel)))
+ (snd-display ";save-sound-as bad chan: ~A" tag)))
(save-sound-as "test.snd" :comment "this is a comment")
(close-sound ind)
(set! ind (open-sound "test.snd"))
(if (not (string=? (comment ind) "this is a comment"))
- (snd-display #__line__ ";save-sound-as with comment: ~A" (comment ind)))
+ (snd-display ";save-sound-as with comment: ~A" (comment ind)))
(close-sound ind))
(mus-sound-prune)
@@ -34717,12 +34070,7 @@ EDITS: 1
(define (bes-j0-1 x) ;returns J0(x) for any real x
(if (< (abs x) 8.0) ;direct rational function fit
(let* ((y (* x x))
- (ans1 (+ 57568490574.0
- (* y (+ -13362590354.0
- (* y (+ 651619640.7
- (* y (+ -11214424.18
- (* y (+ 77392.33017
- (* y -184.9052456)))))))))))
+ (ans1 (+ 57568490574.0000 (* y (- (* y (+ 651619640.7 (* y (- (* y (+ 77392.33017 (* y -184.9052456))) 11214424.18)))) 13362590354.0))))
(ans2 (+ 57568490411.0
(* y (+ 1029532985.0
(* y (+ 9494680.718
@@ -34733,16 +34081,8 @@ EDITS: 1
(z (/ 8.0 ax))
(y (* z z))
(xx (- ax 0.785398164))
- (ans1 (+ 1.0
- (* y (+ -0.1098628627e-2
- (* y (+ 0.2734510407e-4
- (* y (+ -0.2073370639e-5
- (* y 0.2093887211e-6)))))))))
- (ans2 (+ -0.1562499995e-1
- (* y (+ 0.1430488765e-3
- (* y (+ -0.6911147651e-5
- (* y (+ 0.7621095161e-6
- (* y -0.934945152e-7))))))))))
+ (ans1 (+ 1.0 (* y (- (* y (+ 2.734510407e-05 (* y (- (* y 2.093887211e-07) 2.073370639e-06)))) 0.001098628627))))
+ (ans2 (- (* y (+ 0.0001 (* y (- (* y (+ 7.621095160999999e-07 (* y -9.34945152e-08))) 6.911147651000001e-06)))) 0.0156)))
(* (sqrt (/ 0.636619772 ax))
(- (* ans1 (cos xx))
(* z (sin xx) ans2))))))
@@ -34751,26 +34091,20 @@ EDITS: 1
(for-each
(lambda (x)
(if (fneq (bes-j0 x) (bes-j0-1 x))
- (snd-display #__line__ ";(bes-j0 ~A) -> ~A ~A" x (bes-j0 x) (bes-j0-1 x))))
+ (snd-display ";(bes-j0 ~A) -> ~A ~A" x (bes-j0 x) (bes-j0-1 x))))
(list 0.0 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (bes-j0 x) (bes-j0-1 x))
- (snd-display #__line__ ";(bes-j0 ~A) -> ~A ~A" x (bes-j0 x) (bes-j0-1 x))))))
+ (snd-display ";(bes-j0 ~A) -> ~A ~A" x (bes-j0 x) (bes-j0-1 x))))))
(define (bes-j1-1 x) ;returns J1(x) for any real x
(define (signum x) (if (= x 0.0) 0 (if (< x 0.0) -1 1)))
(if (< (abs x) 8.0)
(let* ((y (* x x))
- (ans1 (* x
- (+ 72362614232.0
- (* y (+ -7895059235.0
- (* y (+ 242396853.1
- (* y (+ -2972611.439
- (* y (+ 15704.48260
- (* y -30.16036606))))))))))))
+ (ans1 (* x (+ 72362614232.0000 (* y (- (* y (+ 242396853.1 (* y (- (* y (+ 15704.4826 (* y -30.16036606))) 2972611.439)))) 7895059235.0)))))
(ans2 (+ 144725228442.0
(* y (+ 2300535178.0
(* y (+ 18583304.74
@@ -34781,16 +34115,8 @@ EDITS: 1
(z (/ 8.0 ax))
(y (* z z))
(xx (- ax 2.356194491))
- (ans1 (+ 1.0
- (* y (+ 0.183105e-2
- (* y (+ -0.3516396496e-4
- (* y (+ 0.2457520174e-5
- (* y -0.240337019e-6)))))))))
- (ans2 (+ 0.04687499995
- (* y (+ -0.2002690873e-3
- (* y (+ 0.8449199096e-5
- (* y (+ -0.88228987e-6
- (* y 0.105787412e-6))))))))))
+ (ans1 (+ 1.0 (* y (+ 0.00183105 (* y (- (* y (+ 2.457520174e-06 (* y -2.40337019e-07))) 3.516396496e-05))))))
+ (ans2 (+ 0.0469 (* y (- (* y (+ 8.449199096000001e-06 (* y (- (* y 1.05787412e-07) 8.8228987e-07)))) 0.0002002690873)))))
(* (signum x)
(sqrt (/ 0.636619772 ax))
(- (* ans1 (cos xx))
@@ -34800,84 +34126,80 @@ EDITS: 1
(for-each
(lambda (x)
(if (fneq (bes-j1 x) (bes-j1-1 x))
- (snd-display #__line__ ";(bes-j1 ~A) -> ~A ~A" x (bes-j1 x) (bes-j1-1 x))))
+ (snd-display ";(bes-j1 ~A) -> ~A ~A" x (bes-j1 x) (bes-j1-1 x))))
(list 0.0 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (bes-j1 x) (bes-j1-1 x))
- (snd-display #__line__ ";(bes-j1 ~A) -> ~A ~A" x (bes-j1 x) (bes-j1-1 x))))))
-
- (define (bes-jn-1 nn x) ;return Jn(x) for any integer n, real x
- (let* ((n (abs nn))
- (besn (if (= n 0)
- (bes-j0-1 x)
- (if (= n 1)
- (bes-j1-1 x)
- (if (= x 0.0)
- 0.0
- (let ((iacc 40) ;make iacc larger to increase accuracy
- (ans 0.0)
- (bigno 1.0e10)
- (bigni 1.0e-10))
- (if (> (abs x) n) ;can use upward recurrence from J0 and J1
- (do ((tox (/ 2.0 (abs x)))
- (bjm (bes-j0-1 (abs x)))
- (bj (bes-j1-1 (abs x)))
- (j 1 (+ j 1))
- (bjp 0.0))
- ((= j n) (set! ans bj))
- (set! bjp (- (* j tox bj) bjm))
- (set! bjm bj)
- (set! bj bjp))
- (let ((tox (/ 2.0 (abs x))) ;else use downward recurrence from even value (m)
- (m (* 2 (floor (/ (+ n (sqrt (* iacc n))) 2))))
- (jsum 0) ;alternate 0 and 1 -- when 1, accumulate even terms in sum
- (bjm 0.0)
- (sum 0.0)
- (bjp 0.0)
- (bj 1.0))
- (do ((j m (- j 1))) ;the downward recurrence
- ((= j 0))
- (set! bjm (- (* j tox bj) bjp))
- (set! bjp bj)
- (set! bj bjm)
- (if (> (abs bj) bigno) ;renormalize (may not be necessary in common lisp)
- (begin
- (set! bj (* bj bigni))
- (set! bjp (* bjp bigni))
- (set! ans (* ans bigni))
- (set! sum (* sum bigni))))
- (if (not (= 0 jsum)) (set! sum (+ sum bj)))
- (set! jsum (- 1 jsum))
- (if (= j n) (set! ans bjp)))
- (set! sum (- (* 2.0 sum) bj))
- (set! ans (/ ans sum))))
- (if (and (< x 0.0) (odd? n)) (- ans) ans)))))))
- (if (and (< nn 0)
- (odd? nn))
- (- besn)
- besn)))
+ (snd-display ";(bes-j1 ~A) -> ~A ~A" x (bes-j1 x) (bes-j1-1 x))))))
(define (test-jn)
+ (define (bes-jn-1 nn x) ;return Jn(x) for any integer n, real x
+ (let* ((n (abs nn))
+ (besn (cond ((= n 0) (bes-j0-1 x))
+ ((= n 1) (bes-j1-1 x))
+ ((= x 0.0) 0.0)
+ (else
+ (let ((iacc 40)
+ (ans 0.0000)
+ (bigno 1.0e10)
+ (bigni 1.0e-10))
+ (if (> (abs x) n)
+ (do ((tox (/ 2.0 (abs x)))
+ (bjm (bes-j0-1 (abs x)))
+ (bj (bes-j1-1 (abs x)))
+ (j 1 (+ j 1))
+ (bjp 0.0))
+ ((= j n) (set! ans bj))
+ (set! bjp (- (* j tox bj) bjm))
+ (set! bjm bj)
+ (set! bj bjp))
+ (let ((tox (/ 2.0 (abs x)))
+ (m (* 2 (floor (/ (+ n (sqrt (* iacc n))) 2))))
+ (jsum 0)
+ (bjm 0.0000)
+ (sum 0.0000)
+ (bjp 0.0000)
+ (bj 1.0000))
+ (do ((j m (- j 1)))
+ ((= j 0))
+ (set! bjm (- (* j tox bj) bjp))
+ (set! bjp bj)
+ (set! bj bjm)
+ (if (> (abs bj) bigno)
+ (begin
+ (set! bj (* bj bigni))
+ (set! bjp (* bjp bigni))
+ (set! ans (* ans bigni))
+ (set! sum (* sum bigni))))
+ (if (not (= 0 jsum))
+ (set! sum (+ sum bj)))
+ (set! jsum (- 1 jsum))
+ (if (= j n) (set! ans bjp)))
+ (set! sum (- (* 2.0 sum) bj))
+ (set! ans (/ ans sum))))
+ (if (and (< x 0.0) (odd? n))
+ (- ans)
+ ans))))))
+ (if (and (< nn 0)
+ (odd? nn))
+ (- besn)
+ besn)))
+
(do ((k 0 (+ k 1)))
((= k 10))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (bes-jn k x) (bes-jn-1 k x))
- (snd-display #__line__ ";(bes-jn ~A ~A) -> ~A ~A" k x (bes-jn k x) (bes-jn-1 k x)))))))
+ (snd-display ";(bes-jn ~A ~A) -> ~A ~A" k x (bes-jn k x) (bes-jn-1 k x)))))))
(define (bes-y0-1 x) ;Bessel function Y0(x)
(if (< x 8.0)
(let* ((y (* x x))
- (ans1 (+ -2957821389.0
- (* y (+ 7062834065.0
- (* y (+ -512359803.6
- (* y (+ 10879881.29
- (* y (+ -86327.92757
- (* y 228.4622733)))))))))))
+ (ans1 (- (* y (+ 7062834065.0 (* y (- (* y (+ 10879881.29 (* y (- (* y 228.4622733) 86327.92757)))) 512359803.6)))) 2957821389.0000))
(ans2 (+ 40076544269.0
(* y (+ 745249964.8
(* y (+ 7189466.438
@@ -34887,16 +34209,8 @@ EDITS: 1
(let* ((z (/ 8.0 x))
(y (* z z))
(xx (- x 0.785398164))
- (ans1 (+ 1.0
- (* y (+ -0.1098628627e-2
- (* y (+ 0.2734510407e-4
- (* y (+ -0.2073370639e-5
- (* y 0.2093887211e-6)))))))))
- (ans2 (+ -0.1562499995e-1
- (* y (+ 0.1430488765e-3
- (* y (+ -0.6911147651e-5
- (* y (+ 0.7621095161e-6
- (* y -0.934945152e-7)))))))))
+ (ans1 (+ 1.0 (* y (- (* y (+ 2.734510407e-05 (* y (- (* y 2.093887211e-07) 2.073370639e-06)))) 0.001098628627))))
+ (ans2 (- (* y (+ 0.0001 (* y (- (* y (+ 7.621095160999999e-07 (* y -9.34945152e-08))) 6.911147651000001e-06)))) 0.0156))
(ans (+ (* ans1 (sin xx)) (* z (cos xx) ans2))))
(* (sqrt (/ 0.636619772 x)) ans))))
@@ -34904,25 +34218,20 @@ EDITS: 1
(for-each
(lambda (x)
(if (fneq (bes-y0 x) (bes-y0-1 x))
- (snd-display #__line__ ";(bes-y0 ~A) -> ~A ~A" x (bes-y0 x) (bes-y0-1 x))))
+ (snd-display ";(bes-y0 ~A) -> ~A ~A" x (bes-y0 x) (bes-y0-1 x))))
(list 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (bes-y0 x) (bes-y0-1 x))
- (snd-display #__line__ ";(bes-y0 ~A) -> ~A ~A" x (bes-y0 x) (bes-y0-1 x))))))
+ (snd-display ";(bes-y0 ~A) -> ~A ~A" x (bes-y0 x) (bes-y0-1 x))))))
(define (bes-y1-1 x) ;Bessel function Y1(x)
(if (= x 0.0)
(real-part (log 0.0)) ; -inf.0
(if (< x 8.0)
(let* ((y (* x x))
- (ans1 (* x (+ -0.4900604943e13
- (* y (+ 0.1275274390e13
- (* y (+ -0.5153438139e11
- (* y (+ 0.7349264551e9
- (* y (+ -0.4237922726e7
- (* y 0.8511937935e4))))))))))))
+ (ans1 (* x (- (* y (+ 1275274390000.0000 (* y (- (* y (+ 734926455.1 (* y (- (* y 8511.937935) 4237922.726)))) 51534381390.0)))) 4900604943000.0000)))
(ans2 (+ 0.2499580570e14
(* y (+ 0.4244419664e12
(* y (+ 0.3733650367e10
@@ -34933,89 +34242,74 @@ EDITS: 1
(let* ((z (/ 8.0 x))
(y (* z z))
(xx (- x 2.356194491))
- (ans1 (+ 1.0
- (* y (+ 0.183105e-2
- (* y (+ -0.3516396496e-4
- (* y (+ 0.2457520174e-5
- (* y -0.240337019e-6)))))))))
- (ans2 (+ 0.04687499995
- (* y (+ -0.200269087e-3
- (* y (+ 0.8449199096e-5
- (* y (+ -0.88228987e-6
- (* y 0.105787412e-6))))))))))
+ (ans1 (+ 1.0 (* y (+ 0.00183105 (* y (- (* y (+ 2.457520174e-06 (* y -2.40337019e-07))) 3.516396496e-05))))))
+ (ans2 (+ 0.0469 (* y (- (* y (+ 8.449199096000001e-06 (* y (- (* y 1.05787412e-07) 8.8228987e-07)))) 0.000200269087)))))
(* (sqrt (/ 0.636619772 x)) (+ (* ans1 (sin xx)) (* z (cos xx) ans2)))))))
-
+
(define (test-y1)
(for-each
(lambda (x)
(if (fneq (bes-y1 x) (bes-y1-1 x))
- (snd-display #__line__ ";(bes-y1 ~A) -> ~A ~A" x (bes-y1 x) (bes-y1-1 x))))
+ (snd-display ";(bes-y1 ~A) -> ~A ~A" x (bes-y1 x) (bes-y1-1 x))))
(list 0.01 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
- (if (fneq (bes-y1 x) (bes-y1-1 x))
- (snd-display #__line__ ";(bes-y1 ~A) -> ~A ~A" x (bes-y1 x) (bes-y1-1 x))))))
-
- (define (bes-yn-1 n x) ;return Yn(x) for any integer n, real x
- (if (= n 0)
- (bes-y0-1 x)
- (if (= n 1)
- (bes-y1-1 x)
- (do ((tox (/ 2.0 x))
- (byp 0.0)
- (by (bes-y1-1 x))
- (bym (bes-y0-1 x))
- (j 1 (+ j 1)))
- ((= j n) by)
- (set! byp (- (* j tox by) bym))
- (set! bym by)
- (set! by byp)))))
+ (if (ffneq (bes-y1 x) (bes-y1-1 x))
+ (snd-display ";(bes-y1 ~A) -> ~A ~A" x (bes-y1 x) (bes-y1-1 x))))))
(define (test-yn)
+ (define (bes-yn-1 n x) ;return Yn(x) for any integer n, real x
+ (if (= n 0)
+ (bes-y0-1 x)
+ (if (= n 1)
+ (bes-y1-1 x)
+ (do ((tox (/ 2.0 x))
+ (byp 0.0)
+ (by (bes-y1-1 x))
+ (bym (bes-y0-1 x))
+ (j 1 (+ j 1)))
+ ((= j n) by)
+ (set! byp (- (* j tox by) bym))
+ (set! bym by)
+ (set! by byp)))))
+
(do ((k 0 (+ k 1)))
((= k 10))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (/ (bes-yn k x) (bes-yn-1 k x)) 1.0)
- (snd-display #__line__ ";(bes-yn ~A ~A) -> ~A ~A" k x (bes-yn k x) (bes-yn-1 k x)))))))
+ (snd-display ";(bes-yn ~A ~A) -> ~A ~A" k x (bes-yn k x) (bes-yn-1 k x)))))))
- (define (bes-i0-1 x) ;I0(x)
- (if (< (abs x) 3.75)
- (let ((y (expt (/ x 3.75) 2)))
- (+ 1.0
- (* y (+ 3.5156229
- (* y (+ 3.0899424
- (* y (+ 1.2067492
- (* y (+ 0.2659732
- (* y (+ 0.360768e-1
- (* y 0.45813e-2)))))))))))))
- (let* ((ax (abs x))
- (y (/ 3.75 ax)))
- (* (/ (exp ax) (sqrt ax))
- (+ 0.39894228
- (* y (+ 0.1328592e-1
- (* y (+ 0.225319e-2
- (* y (+ -0.157565e-2
- (* y (+ 0.916281e-2
- (* y (+ -0.2057706e-1
- (* y (+ 0.2635537e-1
- (* y (+ -0.1647633e-1
- (* y 0.392377e-2))))))))))))))))))))
-
(define (test-i0)
+ (define (bes-i0-1 x) ;I0(x)
+ (if (< (abs x) 3.75)
+ (let ((y (expt (/ x 3.75) 2)))
+ (+ 1.0
+ (* y (+ 3.5156229
+ (* y (+ 3.0899424
+ (* y (+ 1.2067492
+ (* y (+ 0.2659732
+ (* y (+ 0.360768e-1
+ (* y 0.45813e-2)))))))))))))
+ (let* ((ax (abs x))
+ (y (/ 3.75 ax)))
+ (* (/ (exp ax) (sqrt ax))
+ (+ 0.3989 (* y (+ 0.0133
+ (* y (+ 0.0023 (* y (- (* y (+ 0.0092 (* y (- (* y (+ 0.02635537 (* y (- (* y 0.00392377) 0.01647633)))) 0.02057706)))) 0.0016)))))))))))
+
(for-each
(lambda (x)
(if (fneq (bes-i0 x) (bes-i0-1 x))
- (snd-display #__line__ ";(bes-i0 ~A) -> ~A ~A" x (bes-i0 x) (bes-i0-1 x))))
+ (snd-display ";(bes-i0 ~A) -> ~A ~A" x (bes-i0 x) (bes-i0-1 x))))
(list 0.0 0.5 1.0 2.0 0.01))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 1.0)))
(if (fneq (bes-i0 x) (bes-i0-1 x))
- (snd-display #__line__ ";(bes-i0 ~A) -> ~A ~A" x (bes-i0 x) (bes-i0-1 x))))))
+ (snd-display ";(bes-i0 ~A) -> ~A ~A" x (bes-i0 x) (bes-i0-1 x))))))
(define (bes-i1 x) ;I1(x)
(if (< (abs x) 3.75)
@@ -35029,72 +34323,64 @@ EDITS: 1
(* y 0.32411e-3))))))))))))))
(let* ((ax (abs x))
(y (/ 3.75 ax))
- (ans1 (+ 0.2282967e-1
- (* y (+ -0.2895312e-1
- (* y (+ 0.1787654e-1
- (* y -0.420059e-2)))))))
- (ans2 (+ 0.39894228
- (* y (+ -0.3988024e-1
- (* y (+ -0.362018e-2
- (* y (+ 0.163801e-2
- (* y (+ -0.1031555e-1 (* y ans1)))))))))))
+ (ans1 (+ 0.02282967 (* y (- (* y (+ 0.01787654 (* y -0.00420059))) 0.02895312))))
+ (ans2 (+ 0.39894228 (* y (- (* y (- (* y (+ 0.00163801 (* y (- (* y ans1) 0.01031555)))) 0.00362018)) 0.03988024))))
(sign (if (< x 0.0) -1.0 1.0)))
(* (/ (exp ax) (sqrt ax)) ans2 sign))))
(define (test-i1)
- (if (fneq (bes-i1 1.0) 0.565159) (snd-display #__line__ ";bes-i1 1.0: ~A" (bes-i1 1.0)))
- (if (fneq (bes-i1 2.0) 1.59063685) (snd-display #__line__ ";bes-i1 2.0: ~A" (bes-i1 2.0)))
- (if (fneq (bes-i1 5.0) 24.33564) (snd-display #__line__ ";bes-i1 5.0: ~A" (bes-i1 5.0)))
- (if (fneq (bes-i1 10.0) 2670.9883) (snd-display #__line__ ";bes-i1 10.0: ~A" (bes-i1 10.0))))
-
- (define (bes-in n x) ;return In(x) for any integer n, real x
- (if (= n 0)
- (bes-i0 x)
- (if (= n 1)
- (bes-i1 x)
- (if (= x 0.0)
- 0.0
- (let* ((iacc 40)
- (bigno 1.0e10)
- (bigni 1.0e-10)
- (ans 0.0)
- (tox (/ 2.0 (abs x)))
- (bip 0.0)
- (bi 1.0)
- (m (* 2 (+ n (truncate (sqrt (* iacc n))))))
- (bim 0.0))
- (do ((j m (- j 1)))
- ((= j 0))
- (set! bim (+ bip (* j tox bi)))
- (set! bip bi)
- (set! bi bim)
- (if (> (abs bi) bigno)
- (begin
- (set! ans (* ans bigni))
- (set! bi (* bi bigni))
- (set! bip (* bip bigni))))
- (if (= j n) (set! ans bip)))
- (if (and (< x 0.0) (odd? n)) (set! ans (- ans)))
- (* ans (/ (bes-i0 x) bi)))))))
+ (if (fneq (bes-i1 1.0) 0.565159) (snd-display ";bes-i1 1.0: ~A" (bes-i1 1.0)))
+ (if (fneq (bes-i1 2.0) 1.59063685) (snd-display ";bes-i1 2.0: ~A" (bes-i1 2.0)))
+ (if (fneq (bes-i1 5.0) 24.33564) (snd-display ";bes-i1 5.0: ~A" (bes-i1 5.0)))
+ (if (fneq (bes-i1 10.0) 2670.9883) (snd-display ";bes-i1 10.0: ~A" (bes-i1 10.0))))
(define (test-in)
- (if (fneq (bes-in 1 1.0) 0.565159) (snd-display #__line__ ";bes-in 1 1.0: ~A" (bes-in 1 1.0)))
- (if (fneq (bes-in 2 1.0) 0.13574767) (snd-display #__line__ ";bes-in 2 1.0: ~A" (bes-in 2 1.0)))
- (if (fneq (bes-in 3 1.0) 0.02216842) (snd-display #__line__ ";bes-in 3 1.0: ~A" (bes-in 3 1.0)))
- (if (fneq (bes-in 5 1.0) 2.71463e-4) (snd-display #__line__ ";bes-in 5 1.0: ~A" (bes-in 5 1.0)))
- (if (fneq (bes-in 10 1.0) 2.752948e-10) (snd-display #__line__ ";bes-in 10 1.0: ~A" (bes-in 10 1.0)))
-
- (if (fneq (bes-in 1 2.0) 1.5906368) (snd-display #__line__ ";bes-in 1 2.0: ~A" (bes-in 1 2.0)))
- (if (fneq (bes-in 2 2.0) 0.6889484) (snd-display #__line__ ";bes-in 2 2.0: ~A" (bes-in 2 2.0)))
- (if (fneq (bes-in 3 2.0) 0.21273995) (snd-display #__line__ ";bes-in 3 2.0: ~A" (bes-in 3 2.0)))
- (if (fneq (bes-in 5 2.0) 0.009825679) (snd-display #__line__ ";bes-in 5 2.0: ~A" (bes-in 5 2.0)))
- (if (fneq (bes-in 10 2.0) 3.016963e-7) (snd-display #__line__ ";bes-in 10 2.0: ~A" (bes-in 10 2.0)))
-
- (if (fneq (bes-in 1 5.0) 24.33564) (snd-display #__line__ ";bes-in 1 5.0: ~A" (bes-in 1 5.0)))
- (if (fneq (bes-in 2 5.0) 17.505615) (snd-display #__line__ ";bes-in 2 5.0: ~A" (bes-in 2 5.0)))
- (if (fneq (bes-in 3 5.0) 10.331150) (snd-display #__line__ ";bes-in 3 5.0: ~A" (bes-in 3 5.0)))
- (if (fneq (bes-in 5 5.0) 2.157974) (snd-display #__line__ ";bes-in 5 5.0: ~A" (bes-in 5 5.0)))
- (if (fneq (bes-in 10 5.0) 0.004580044) (snd-display #__line__ ";bes-in 10 5.0: ~A" (bes-in 10 5.0))))
+ (define (bes-in n x) ;return In(x) for any integer n, real x
+ (cond ((= n 0) (bes-i0 x))
+ ((= n 1) (bes-i1 x))
+ ((= x 0.0) 0.0)
+ (else
+ (let* ((iacc 40)
+ (bigno 10000000000.0000)
+ (bigni 0.0000)
+ (ans 0.0000)
+ (tox (/ 2.0 (abs x)))
+ (bip 0.0000)
+ (bi 1.0000)
+ (m (* 2 (+ n (truncate (sqrt (* iacc n))))))
+ (bim 0.0000))
+ (do ((j m (- j 1)))
+ ((= j 0))
+ (set! bim (+ bip (* j tox bi)))
+ (set! bip bi)
+ (set! bi bim)
+ (if (> (abs bi) bigno)
+ (begin
+ (set! ans (* ans bigni))
+ (set! bi (* bi bigni))
+ (set! bip (* bip bigni))))
+ (if (= j n) (set! ans bip)))
+ (if (and (< x 0.0) (odd? n))
+ (set! ans (- ans)))
+ (* ans (/ (bes-i0 x) bi))))))
+
+ (if (fneq (bes-in 1 1.0) 0.565159) (snd-display ";bes-in 1 1.0: ~A" (bes-in 1 1.0)))
+ (if (fneq (bes-in 2 1.0) 0.13574767) (snd-display ";bes-in 2 1.0: ~A" (bes-in 2 1.0)))
+ (if (fneq (bes-in 3 1.0) 0.02216842) (snd-display ";bes-in 3 1.0: ~A" (bes-in 3 1.0)))
+ (if (fneq (bes-in 5 1.0) 2.71463e-4) (snd-display ";bes-in 5 1.0: ~A" (bes-in 5 1.0)))
+ (if (fneq (bes-in 10 1.0) 2.752948e-10) (snd-display ";bes-in 10 1.0: ~A" (bes-in 10 1.0)))
+
+ (if (fneq (bes-in 1 2.0) 1.5906368) (snd-display ";bes-in 1 2.0: ~A" (bes-in 1 2.0)))
+ (if (fneq (bes-in 2 2.0) 0.6889484) (snd-display ";bes-in 2 2.0: ~A" (bes-in 2 2.0)))
+ (if (fneq (bes-in 3 2.0) 0.21273995) (snd-display ";bes-in 3 2.0: ~A" (bes-in 3 2.0)))
+ (if (fneq (bes-in 5 2.0) 0.009825679) (snd-display ";bes-in 5 2.0: ~A" (bes-in 5 2.0)))
+ (if (fneq (bes-in 10 2.0) 3.016963e-7) (snd-display ";bes-in 10 2.0: ~A" (bes-in 10 2.0)))
+
+ (if (fneq (bes-in 1 5.0) 24.33564) (snd-display ";bes-in 1 5.0: ~A" (bes-in 1 5.0)))
+ (if (fneq (bes-in 2 5.0) 17.505615) (snd-display ";bes-in 2 5.0: ~A" (bes-in 2 5.0)))
+ (if (fneq (bes-in 3 5.0) 10.331150) (snd-display ";bes-in 3 5.0: ~A" (bes-in 3 5.0)))
+ (if (fneq (bes-in 5 5.0) 2.157974) (snd-display ";bes-in 5 5.0: ~A" (bes-in 5 5.0)))
+ (if (fneq (bes-in 10 5.0) 0.004580044) (snd-display ";bes-in 10 5.0: ~A" (bes-in 10 5.0))))
(define (bes-k0 x) ;K0(x)
(if (<= x 2.0)
@@ -35107,110 +34393,96 @@ EDITS: 1
(* y (+ 0.10750e-3
(* y 0.74e-5)))))))))))))
(let ((y (/ 2.0 x)))
- (* (/ (exp (- x)) (sqrt x))
- (+ 1.25331414
- (* y (+ -0.7832358e-1
- (* y (+ 0.2189568e-1
- (* y (+ -0.1062446e-1
- (* y (+ 0.587872e-2
- (* y (+ -0.251540e-2
- (* y -0.53208e-3))))))))))))))))
-
+ (* (/ (exp (- x)) (sqrt x))
+ (+ 1.2533
+ (* y (- (* y (+ 0.02189568 (* y (- (* y (+ 0.00587872 (* y (- (* y -0.00053208) 0.0025154)))) 0.01062446)))) 0.0783)))))))
+
(define (test-k0)
- (if (fneq (bes-k0 1.0) 0.4210244) (snd-display #__line__ ";bes-k0 1.0: ~A" (bes-k0 1.0)))
- (if (fneq (bes-k0 2.0) 0.1138938) (snd-display #__line__ ";bes-k0 2.0: ~A" (bes-k0 2.0)))
- (if (fneq (bes-k0 10.0) 1.7780e-5) (snd-display #__line__ ";bes-k0 10.0: ~A" (bes-k0 10.0))))
+ (if (fneq (bes-k0 1.0) 0.4210244) (snd-display ";bes-k0 1.0: ~A" (bes-k0 1.0)))
+ (if (fneq (bes-k0 2.0) 0.1138938) (snd-display ";bes-k0 2.0: ~A" (bes-k0 2.0)))
+ (if (fneq (bes-k0 10.0) 1.7780e-5) (snd-display ";bes-k0 10.0: ~A" (bes-k0 10.0))))
(define (bes-k1 x) ;K1(x)
(if (<= x 2.0)
(let ((y (* x (/ x 4.0))))
- (+ (* (log (/ x 2)) (bes-i1 x))
+ (+ (* (log (/ x 2)) (bes-i1 x))
(* (/ 1.0 x)
- (+ 1.0
+ (+ 1.0000
(* y (+ 0.15443144
- (* y (+ -0.67278579
- (* y (+ -0.18156897
- (* y (+ -0.1919402e-1
- (* y (+ -0.110404e-2
- (* y -0.4686e-4)))))))))))))))
+ (* y (- (* y (- (* y (- (* y (- (* y -4.686e-05) 0.00110404)) 0.01919402)) 0.18156897)) 0.6728))))))))
(let ((y (/ 2.0 x)))
- (* (/ (exp (- x)) (sqrt x))
- (+ 1.25331414
- (* y (+ 0.23498619
- (* y (+ -0.3655620e-1
- (* y (+ 0.1504268e-1
- (* y (+ -0.780353e-2
- (* y (+ 0.325614e-2
- (* y -0.68245e-3))))))))))))))))
+ (* (/ (exp (- x)) (sqrt x))
+ (+ 1.2533
+ (* y (+ 0.2350
+ (* y (- (* y (+ 0.01504268 (* y (- (* y (+ 0.00325614 (* y -0.00068245))) 0.00780353)))) 0.0365562)))))))))
(define (test-k1)
- (if (fneq (bes-k1 1.0) 0.60190723) (snd-display #__line__ ";bes-k1 1.0: ~A" (bes-k1 1.0)))
- (if (fneq (bes-k1 2.0) 0.1398658) (snd-display #__line__ ";bes-k1 2.0: ~A" (bes-k1 2.0)))
- (if (fneq (bes-k1 10.0) 1.86487e-5) (snd-display #__line__ ";bes-k1 10.0: ~A" (bes-k1 10.0))))
-
-
- (define (bes-kn n x) ;return Kn(x) for any integer n, real x
- (if (= n 0)
- (bes-k0 x)
- (if (= n 1)
- (bes-k1 x)
- (do ((tox (/ 2.0 x))
- (bkm (bes-k0 x))
- (bk (bes-k1 x))
- (bkp 0.0)
- (j 1 (+ j 1)))
- ((= j n) bk)
- (set! bkp (+ bkm (* j tox bk)))
- (set! bkm bk)
- (set! bk bkp)))))
+ (if (fneq (bes-k1 1.0) 0.60190723) (snd-display ";bes-k1 1.0: ~A" (bes-k1 1.0)))
+ (if (fneq (bes-k1 2.0) 0.1398658) (snd-display ";bes-k1 2.0: ~A" (bes-k1 2.0)))
+ (if (fneq (bes-k1 10.0) 1.86487e-5) (snd-display ";bes-k1 10.0: ~A" (bes-k1 10.0))))
+
(define (test-kn)
- (if (fneq (bes-kn 1 1.0) 0.6019072) (snd-display #__line__ ";bes-kn 1 1.0: ~A" (bes-kn 1 1.0)))
- (if (fneq (bes-kn 2 1.0) 1.6248389) (snd-display #__line__ ";bes-kn 2 1.0: ~A" (bes-kn 2 1.0)))
- (if (fneq (bes-kn 3 1.0) 7.1012629) (snd-display #__line__ ";bes-kn 3 1.0: ~A" (bes-kn 3 1.0)))
- (if (fneq (bes-kn 5 1.0) 360.96059) (snd-display #__line__ ";bes-kn 5 1.0: ~A" (bes-kn 5 1.0)))
-
- (if (fneq (bes-kn 1 2.0) 0.139865) (snd-display #__line__ ";bes-kn 1 2.0: ~A" (bes-kn 1 2.0)))
- (if (fneq (bes-kn 2 2.0) 0.2537597) (snd-display #__line__ ";bes-kn 2 2.0: ~A" (bes-kn 2 2.0)))
- (if (fneq (bes-kn 3 2.0) 0.6473854) (snd-display #__line__ ";bes-kn 3 2.0: ~A" (bes-kn 3 2.0)))
- (if (fneq (bes-kn 5 2.0) 9.431049) (snd-display #__line__ ";bes-kn 5 2.0: ~A" (bes-kn 5 2.0)))
-
- (if (fneq (bes-kn 1 5.0) 0.00404461) (snd-display #__line__ ";bes-kn 1 5.0: ~A" (bes-kn 1 5.0)))
- (if (fneq (bes-kn 2 5.0) 0.0053089) (snd-display #__line__ ";bes-kn 2 5.0: ~A" (bes-kn 2 5.0)))
- (if (fneq (bes-kn 3 5.0) 0.0082917) (snd-display #__line__ ";bes-kn 3 5.0: ~A" (bes-kn 3 5.0)))
- (if (fneq (bes-kn 5 5.0) 0.0327062) (snd-display #__line__ ";bes-kn 5 5.0: ~A" (bes-kn 5 5.0))))
-
-
- (define (gammln xx) ;Ln(gamma(xx)), xx>0
- (let* ((stp 2.5066282746310005e0)
- (x xx)
- (tmp (+ x 5.5))
- (tmp1 (- tmp (* (+ x 0.5) (log tmp))))
- (ser (+ 1.000000000190015
- (/ 76.18009172947146 (+ x 1.0))
- (/ -86.50532032941677 (+ x 2.0))
- (/ 24.01409824083091 (+ x 3.0))
- (/ -1.231739572450155 (+ x 4))
- (/ 0.1208650973866179e-2 (+ x 5.0))
- (/ -0.5395239384953e-5 (+ x 6.0)))))
- (- (log (/ (* stp ser) x)) tmp1)))
+ (define (bes-kn n x) ;return Kn(x) for any integer n, real x
+ (if (= n 0)
+ (bes-k0 x)
+ (if (= n 1)
+ (bes-k1 x)
+ (do ((tox (/ 2.0 x))
+ (bkm (bes-k0 x))
+ (bk (bes-k1 x))
+ (bkp 0.0)
+ (j 1 (+ j 1)))
+ ((= j n) bk)
+ (set! bkp (+ bkm (* j tox bk)))
+ (set! bkm bk)
+ (set! bk bkp)))))
+
+ (if (fneq (bes-kn 1 1.0) 0.6019072) (snd-display ";bes-kn 1 1.0: ~A" (bes-kn 1 1.0)))
+ (if (fneq (bes-kn 2 1.0) 1.6248389) (snd-display ";bes-kn 2 1.0: ~A" (bes-kn 2 1.0)))
+ (if (fneq (bes-kn 3 1.0) 7.1012629) (snd-display ";bes-kn 3 1.0: ~A" (bes-kn 3 1.0)))
+ (if (fneq (bes-kn 5 1.0) 360.96059) (snd-display ";bes-kn 5 1.0: ~A" (bes-kn 5 1.0)))
+
+ (if (fneq (bes-kn 1 2.0) 0.139865) (snd-display ";bes-kn 1 2.0: ~A" (bes-kn 1 2.0)))
+ (if (fneq (bes-kn 2 2.0) 0.2537597) (snd-display ";bes-kn 2 2.0: ~A" (bes-kn 2 2.0)))
+ (if (fneq (bes-kn 3 2.0) 0.6473854) (snd-display ";bes-kn 3 2.0: ~A" (bes-kn 3 2.0)))
+ (if (fneq (bes-kn 5 2.0) 9.431049) (snd-display ";bes-kn 5 2.0: ~A" (bes-kn 5 2.0)))
+
+ (if (fneq (bes-kn 1 5.0) 0.00404461) (snd-display ";bes-kn 1 5.0: ~A" (bes-kn 1 5.0)))
+ (if (fneq (bes-kn 2 5.0) 0.0053089) (snd-display ";bes-kn 2 5.0: ~A" (bes-kn 2 5.0)))
+ (if (fneq (bes-kn 3 5.0) 0.0082917) (snd-display ";bes-kn 3 5.0: ~A" (bes-kn 3 5.0)))
+ (if (fneq (bes-kn 5 5.0) 0.0327062) (snd-display ";bes-kn 5 5.0: ~A" (bes-kn 5 5.0))))
+
(define (test-lgamma)
+ (define (gammln xx) ;Ln(gamma(xx)), xx>0
+ (let* ((stp 2.5066282746310005e0)
+ (x xx)
+ (tmp (+ x 5.5))
+ (tmp1 (- tmp (* (+ x 0.5) (log tmp))))
+ (ser (+ 1.000000000190015
+ (/ 76.18009172947146 (+ x 1.0))
+ (/ -86.50532032941677 (+ x 2.0))
+ (/ 24.01409824083091 (+ x 3.0))
+ (/ -1.231739572450155 (+ x 4))
+ (/ 0.1208650973866179e-2 (+ x 5.0))
+ (/ -0.5395239384953e-5 (+ x 6.0)))))
+ (- (log (/ (* stp ser) x)) tmp1)))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
(if (fneq (lgamma x) (gammln x))
- (snd-display #__line__ ";(lgamma ~A) -> ~A ~A" x (lgamma x) (gammln x))))))
+ (snd-display ";(lgamma ~A) -> ~A ~A" x (lgamma x) (gammln x))))))
(define (test-erf)
- (if (fneq (erf 0.0) 0.0) (snd-display #__line__ ";erf 0.0: ~A" (erf 0.0)))
- (if (fneq (erf 0.5) 0.5204998) (snd-display #__line__ ";erf 0.5: ~A" (erf 0.5)))
- (if (fneq (erf 1.0) 0.8427007) (snd-display #__line__ ";erf 0.0: ~A" (erf 1.0)))
+ (if (fneq (erf 0.0) 0.0) (snd-display ";erf 0.0: ~A" (erf 0.0)))
+ (if (fneq (erf 0.5) 0.5204998) (snd-display ";erf 0.5: ~A" (erf 0.5)))
+ (if (fneq (erf 1.0) 0.8427007) (snd-display ";erf 0.0: ~A" (erf 1.0)))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((val (random 2.0)))
(if (fneq (+ (erf val) (erfc val)) 1.0)
- (snd-display #__line__ ";erf+erfc: ~A (~A + ~A)"
+ (snd-display ";erf+erfc: ~A (~A + ~A)"
(+ (erf val) (erfc val))
(erf val)
(erfc val))))))
@@ -35223,18 +34495,18 @@ EDITS: 1
(set! (f 0) (* (f 0) v))
(do ((m 2 (* m 2)))
((> m n))
- (let ((mh (/ m 2)))
- (do ((j 0 (+ j 2))
- (k 0 (+ k 1)))
- ((= j m))
- (let ((x (f k))
- (y (* (f (+ mh k)) v)))
- (set! (g j) (+ x y))
- (set! (g (+ j 1)) (- x y))))
- (do ((i (- m 1) (- i 1)))
- ((< i 0))
- (set! (f i) (g i)))
- (set! v (* v s2))))
+ (do ((mh (/ m 2))
+ (j 0 (+ j 2))
+ (k 0 (+ k 1)))
+ ((= j m)
+ (do ((i (- m 1) (- i 1)))
+ ((< i 0))
+ (set! (f i) (g i)))
+ (set! v (* v s2)))
+ (let ((x (f k))
+ (y (* (f (+ mh k)) v)))
+ (set! (g j) (+ x y))
+ (set! (g (+ j 1)) (- x y)))))
f))
(define (wavelet data n isign wf cc)
@@ -35295,8 +34567,7 @@ EDITS: 1
(* ai (cc (- k 1)))))
(set! (data1 jr) (+ (data1 jr)
(* ai1 (cr (- k 1))))))))))
- (copy data1 data)
- data))
+ (copy data1 data)))
(define (corr x y N M)
;; correlation from Orfanidis
@@ -35421,6 +34692,7 @@ EDITS: 1
0.003606553567 -0.010733175483 0.001395351747 0.001992405295 -0.000685856695 -0.000116466855
0.000093588670 -0.000013264203))
(SQRT2 1.41421356237309504880168872420969808)
+ (SQRT2*3 (* SQRT2 3))
(Battle-Lemarie (float-vector (* SQRT2 -0.002) (* SQRT2 -0.003) (* SQRT2 0.006) (* SQRT2 0.006) (* SQRT2 -0.013)
(* SQRT2 -0.012) (* SQRT2 0.030) (* SQRT2 0.023) (* SQRT2 -0.078) (* SQRT2 -0.035)
(* SQRT2 0.307) (* SQRT2 0.542) (* SQRT2 0.307) (* SQRT2 -0.035) (* SQRT2 -0.078)
@@ -35444,12 +34716,12 @@ EDITS: 1
-0.056514193868065 0.036409962612716 0.0087601307091635 -0.011194759273835 -0.0019213354141368
0.0020413809772660 0.00044583039753204 -0.00021625727664696))
(sym2 (float-vector (* SQRT2 -0.125) (* SQRT2 0.25) (* SQRT2 0.75) (* SQRT2 0.25) (* SQRT2 -0.125)))
- (sym3 (float-vector (/ (* SQRT2 1.0) 8.0) (/ (* SQRT2 3.0) 8.0) (/ (* SQRT2 3.0) 8.0) (/ (* SQRT2 1.0) 8.0)))
- (sym4 (float-vector (/ (* SQRT2 3.0) 128.0) (/ (* SQRT2 -6.0) 128.0) (/ (* SQRT2 -16.0) 128.0)
+ (sym3 (float-vector (/ (* SQRT2 1.0) 8.0) (/ SQRT2*3 8.0) (/ SQRT2*3 8.0) (/ (* SQRT2 1.0) 8.0)))
+ (sym4 (float-vector (/ SQRT2*3 128.0) (/ (* SQRT2 -6.0) 128.0) (/ (* SQRT2 -16.0) 128.0)
(/ (* SQRT2 38.0) 128.0) (/ (* SQRT2 90.0) 128.0) (/ (* SQRT2 38.0) 128.0)
- (/ (* SQRT2 -16.0) 128.0) (/ (* SQRT2 -6.0) 128.0) (/ (* SQRT2 3.0) 128.0) 0.0))
- (sym5 (float-vector (/ (* SQRT2 3.0) 64.0) (/ (* SQRT2 -9.0) 64.0) (/ (* SQRT2 -7.0) 64.0) (/ (* SQRT2 45.0) 64.0)
- (/ (* SQRT2 45.0) 64.0) (/ (* SQRT2 -7.0) 64.0) (/ (* SQRT2 -9.0) 64.0) (/ (* SQRT2 3.0) 64.0)))
+ (/ (* SQRT2 -16.0) 128.0) (/ (* SQRT2 -6.0) 128.0) (/ SQRT2*3 128.0) 0.0))
+ (sym5 (float-vector (/ SQRT2*3 64.0) (/ (* SQRT2 -9.0) 64.0) (/ (* SQRT2 -7.0) 64.0) (/ (* SQRT2 45.0) 64.0)
+ (/ (* SQRT2 45.0) 64.0) (/ (* SQRT2 -7.0) 64.0) (/ (* SQRT2 -9.0) 64.0) (/ SQRT2*3 64.0)))
(sym6 (float-vector (/ (* SQRT2 -35.0) 16384.0) (/ (* SQRT2 -105.0) 16384.0) (/ (* SQRT2 -195.0) 16384.0)
(/ (* SQRT2 865.0) 16384.0) (/ (* SQRT2 363.0) 16384.0) (/ (* SQRT2 -3489.0) 16384.0)
(/ (* SQRT2 -307.0) 16384.0) (/ (* SQRT2 11025.0) 16384.0) (/ (* SQRT2 11025.0) 16384.0)
@@ -35508,7 +34780,7 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (d0 i) 1.0)
- (snd-display #__line__ ";fourier (1.0) [~D]: ~A?" i (d0 i))))
+ (snd-display ";fourier (1.0) [~D]: ~A?" i (d0 i))))
(set! d0 (make-float-vector 19))
(set! (d0 0) 1.0)
@@ -35518,19 +34790,19 @@ EDITS: 1
((or (not happy) (= i 16)))
(if (fneq (d0 i) 1.0)
(begin
- (snd-display #__line__ ";fourier (1.0) [~D]: ~A?" i (d0 i))
+ (snd-display ";fourier (1.0) [~D]: ~A?" i (d0 i))
(set! happy #f)))))
(snd-transform fourier-transform d0 0)
(if (and (fneq (d0 0) 256.0)
(fneq (d0 0) 361.0)) ; fftw funny length
- (snd-display #__line__ ";fourier (256.0): ~A?" (d0 0)))
+ (snd-display ";fourier (256.0): ~A?" (d0 0)))
(let ((happy #t))
(do ((i 1 (+ i 1)))
((or (not happy) (= i 16)))
(if (fneq (d0 i) 0.0)
(begin
- (snd-display #__line__ ";fourier (0.0) [~D]: ~A?" i (d0 i))
+ (snd-display ";fourier (0.0) [~D]: ~A?" i (d0 i))
(set! happy #f)))))
(let ((r0 (make-float-vector 8))
@@ -35552,32 +34824,32 @@ EDITS: 1
(float-vector-scale! i1 .3333)
(float-vector-add! r0 r1)
(float-vector-add! i0 i1)
- (if (or (not (vequal r0 r2))
- (not (vequal i0 i2)))
- (snd-display #__line__ ";fft additions/scaling: ~A ~A: ~A ~A" r2 i2 r0 i0)))
+ (if (not (and (vequal r0 r2)
+ (vequal i0 i2)))
+ (snd-display ";fft additions/scaling: ~A ~A: ~A ~A" r2 i2 r0 i0)))
(set! d0 (make-float-vector 8))
(set! d1 (make-float-vector 8))
(set! (d0 2) 1.0)
(mus-fft d0 d1 8 1)
- (if (or (not (vequal d0 (float-vector 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000 0.000)))
- (not (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
- (snd-display #__line__ ";mus-fft 1: ~A ~A?" d0 d1))
+ (if (not (and (vequal d0 (float-vector 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000 0.000))
+ (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (snd-display ";mus-fft 1: ~A ~A?" d0 d1))
(mus-fft d0 d1 8 -1)
- (if (or (not (vequal d0 (float-vector 0.000 0.000 8.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";mus-fft -1: ~A ~A?" d0 d1))
+ (if (not (and (vequal d0 (float-vector 0.000 0.000 8.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";mus-fft -1: ~A ~A?" d0 d1))
(fill! d0 1.0)
(fill! d1 0.0)
(mus-fft d0 d1 8)
- (if (or (not (vequal d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (not (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";mus-fft 2: ~A ~A?" d0 d1))
+ (if (not (and (vequal d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";mus-fft 2: ~A ~A?" d0 d1))
(mus-fft d0 d1 8 -1)
- (if (or (not (vequal d0 (float-vector 8.000 8.000 8.000 8.000 8.000 8.000 8.000 8.000)))
- (not (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
- (snd-display #__line__ ";mus-fft -2: ~A ~A?" d0 d1))
+ (if (not (and (vequal d0 (float-vector 8.000 8.000 8.000 8.000 8.000 8.000 8.000 8.000))
+ (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (snd-display ";mus-fft -2: ~A ~A?" d0 d1))
(fill! d1 0.0)
(fill-float-vector d0 (random 1.0))
@@ -35586,7 +34858,7 @@ EDITS: 1
(mus-fft d0 d1 8 -1)
(float-vector-scale! d0 (/ 1.0 8.0))
(if (not (vequal d0 fn))
- (snd-display #__line__ ";mus-fft 3: ~A ~A?" d0 fn))
+ (snd-display ";mus-fft 3: ~A ~A?" d0 fn))
(let ((d0 (make-float-vector 8))
(d1 (make-float-vector 8)))
@@ -35609,17 +34881,17 @@ EDITS: 1
(do ((i 0 (+ i 1))) ; one sample rotation here
((= i 7))
(if (fneq (d0 (+ i 1)) (reversed-d0 i))
- (snd-display #__line__ ";mus-fft d0 reversed: ~A ~A" d0 reversed-d0))
+ (snd-display ";mus-fft d0 reversed: ~A ~A" d0 reversed-d0))
(if (fneq (d1 (+ i 1)) (reversed-d1 i))
- (snd-display #__line__ ";mus-fft d1 reversed: ~A ~A" d1 reversed-d1)))
+ (snd-display ";mus-fft d1 reversed: ~A ~A" d1 reversed-d1)))
(mus-fft d0 d1 8)
(mus-fft d0 d1 8)
(float-vector-scale! d0 .125)
(float-vector-scale! d1 .125)
(if (not (vequal d0 save-d0))
- (snd-display #__line__ ";mus-fft d0 saved: ~A ~A" d0 save-d0))
+ (snd-display ";mus-fft d0 saved: ~A ~A" d0 save-d0))
(if (not (vequal d1 save-d1))
- (snd-display #__line__ ";mus-fft d1 saved: ~A ~A" d1 save-d1))))
+ (snd-display ";mus-fft d1 saved: ~A ~A" d1 save-d1))))
(for-each
(lambda (size)
@@ -35628,25 +34900,25 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size))
- (if (not (vequal d0 dcopy)) (snd-display #__line__ ";snd-spectrum not in-place? ~A ~A" d0 dcopy)))
+ (if (not (vequal d0 dcopy)) (snd-display ";snd-spectrum not in-place? ~A ~A" d0 dcopy)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 1.0)
(begin
- (snd-display #__line__ ";snd-spectrum (1.0) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum (1.0) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 rectangular-window))
(if (fneq (d1 0) 1.0)
- (snd-display #__line__ ";snd-spectrum back (1.0 ~D): ~A?" size (d1 0)))
+ (snd-display ";snd-spectrum back (1.0 ~D): ~A?" size (d1 0)))
(let ((happy #t))
(do ((i 1 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 0.0)
(begin
- (snd-display #__line__ ";snd-spectrum (0.0) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum (0.0) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(set! d0 (make-float-vector size))
@@ -35657,19 +34929,19 @@ EDITS: 1
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 0.0)
(begin
- (snd-display #__line__ ";snd-spectrum dB (0.0) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum dB (0.0) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 rectangular-window size #f))
(if (fneq (d1 0) 0.0)
- (snd-display #__line__ ";snd-spectrum dB back (0.0 ~D): ~A?" size (d1 0)))
+ (snd-display ";snd-spectrum dB back (0.0 ~D): ~A?" size (d1 0)))
(let ((happy #t))
(do ((i 1 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) -90.0) ; currently ignores min-dB (snd-sig.c 5023)
(begin
- (snd-display #__line__ ";snd-spectrum dB (1.0) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum dB (1.0) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(let ((dcopy #f))
@@ -35677,14 +34949,14 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size #t 1.0 #t)) ; in-place
- (if (vequal d0 dcopy) (snd-display #__line__ ";snd-spectrum in-place? ~A ~A" d0 dcopy))
- (if (not (vequal d0 d1)) (snd-display #__line__ ";snd-spectrum returns in-place? ~A ~A" d0 d1)))
+ (if (vequal d0 dcopy) (snd-display ";snd-spectrum in-place? ~A ~A" d0 dcopy))
+ (if (not (vequal d0 d1)) (snd-display ";snd-spectrum returns in-place? ~A ~A" d0 d1)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 1.0)
(begin
- (snd-display #__line__ ";snd-spectrum (1.0 #t) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum (1.0 #t) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(let ((dcopy #f))
@@ -35692,44 +34964,44 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size #f 1.0 #t)) ; in-place dB
- (if (vequal d0 dcopy) (snd-display #__line__ ";snd-spectrum dB in-place? ~A ~A" d0 dcopy))
- (if (not (vequal d0 d1)) (snd-display #__line__ ";snd-spectrum dB returns in-place? ~A ~A" d0 d1)))
+ (if (vequal d0 dcopy) (snd-display ";snd-spectrum dB in-place? ~A ~A" d0 dcopy))
+ (if (not (vequal d0 d1)) (snd-display ";snd-spectrum dB returns in-place? ~A ~A" d0 d1)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 0.0)
(begin
- (snd-display #__line__ ";snd-spectrum dB (1.0 #t) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum dB (1.0 #t) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 rectangular-window size #t 0.0 #f #f)) ; linear (in-place) not normalized
- (if (fneq (d1 0) size) (snd-display #__line__ ";snd-spectrum no norm 0: ~A" d1))
+ (if (fneq (d1 0) size) (snd-display ";snd-spectrum no norm 0: ~A" d1))
(let ((happy #t))
(do ((i 1 (+ i 1)))
((or (not happy) (= i (/ size 2))))
(if (fneq (d1 i) 0.0)
(begin
- (snd-display #__line__ ";snd-spectrum no norm (0.0) [~D: ~D]: ~A?" i size (d1 i))
+ (snd-display ";snd-spectrum no norm (0.0) [~D: ~D]: ~A?" i size (d1 i))
(set! happy #f)))))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 blackman2-window size))
- (if (and (not (vequal d1 (float-vector 1.000 0.721 0.293 0.091)))
- (not (vequal d1 (float-vector 1.000 0.647 0.173 0.037 0.024 0.016 0.011 0.005))))
- (snd-display #__line__ ";blackman2 snd-spectrum: ~A~%" d1))
+ (if (not (or (vequal d1 (float-vector 1.000 0.721 0.293 0.091))
+ (vequal d1 (float-vector 1.000 0.647 0.173 0.037 0.024 0.016 0.011 0.005))))
+ (snd-display ";blackman2 snd-spectrum: ~A~%" d1))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 gaussian-window size #t 0.5))
- (if (and (not (vequal d1 (float-vector 1.000 0.900 0.646 0.328)))
- (not (vequal d1 (float-vector 1.000 0.870 0.585 0.329 0.177 0.101 0.059 0.028))))
- (snd-display #__line__ ";gaussian 0.5 snd-spectrum: ~A~%" d1))
+ (if (not (or (vequal d1 (float-vector 1.000 0.900 0.646 0.328))
+ (vequal d1 (float-vector 1.000 0.870 0.585 0.329 0.177 0.101 0.059 0.028))))
+ (snd-display ";gaussian 0.5 snd-spectrum: ~A~%" d1))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 gaussian-window size #t 0.85))
- (if (and (not (vequal d1 (float-vector 1.000 0.924 0.707 0.383)))
- (not (vequal d1 (float-vector 1.000 0.964 0.865 0.725 0.566 0.409 0.263 0.128))))
- (snd-display #__line__ ";gaussian 0.85 snd-spectrum: ~A~%" d1))
+ (if (not (or (vequal d1 (float-vector 1.000 0.924 0.707 0.383))
+ (vequal d1 (float-vector 1.000 0.964 0.865 0.725 0.566 0.409 0.263 0.128))))
+ (snd-display ";gaussian 0.85 snd-spectrum: ~A~%" d1))
)
@@ -35749,11 +35021,11 @@ EDITS: 1
((or (not happy) (= i len2)))
(if (fneq (rl i) (xrl i))
(begin
- (snd-display #__line__ ";flat fft: ~A at ~A: ~A ~A" len i (rl i) (xrl i))
+ (snd-display ";flat fft: ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))
- (if (fneq (rl 0) (* len len)) (snd-display #__line__ ";snd-transform ~A at 0: ~A" len (rl 0)))
+ (if (fneq (rl 0) (* len len)) (snd-display ";snd-transform ~A at 0: ~A" len (rl 0)))
(set! (rl 0) 0.0)
- (if (> (float-vector-peak rl) .001) (snd-display #__line__ ";snd-transform ~A impulse: ~A" len (float-vector-peak rl)))))
+ (if (> (float-vector-peak rl) .001) (snd-display ";snd-transform ~A impulse: ~A" len (float-vector-peak rl)))))
(list 16 128 512 1024))
(for-each
@@ -35770,9 +35042,9 @@ EDITS: 1
((or (not happy) (= i len2)))
(if (fneq (rl i) (xrl i))
(begin
- (snd-display #__line__ ";impulse fft: ~A at ~A: ~A ~A" len i (rl i) (xrl i))
+ (snd-display ";impulse fft: ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))
- (if (fneq (rl 0) 1.0) (snd-display #__line__ ";flat ~A at 0: ~A" len (rl 0)))))
+ (if (fneq (rl 0) 1.0) (snd-display ";flat ~A at 0: ~A" len (rl 0)))))
(list 16 128 512 1024))
(for-each
@@ -35788,24 +35060,24 @@ EDITS: 1
(snd-transform fourier-transform xrl #t)
(float-vector-scale! xrl (/ 1.0 len))
(if (not (vequal rl xrl))
- (snd-display #__line__ ";random fft: ~A: ~A ~A" len rl xrl))))
+ (snd-display ";random fft: ~A: ~A ~A" len rl xrl))))
(list 16 128 512 1024 4096))
(for-each
(lambda (len)
(let ((rl (make-float-vector len))
- (xrl (make-float-vector len))
- (g (make-oscil (/ 220500.0 len))))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (float-vector-set! rl i (oscil g)))
+ (xrl (make-float-vector len)))
+ (let ((g (make-oscil (/ 220500.0 len))))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (float-vector-set! rl i (oscil g))))
(copy rl xrl)
(snd-transform fourier-transform rl)
(float-vector-scale! rl (/ 1.0 len))
(snd-transform fourier-transform xrl #t)
(float-vector-scale! xrl (/ 1.0 len))
(if (not (vequal rl xrl))
- (snd-display #__line__ ";random fft: ~A: ~A ~A" len rl xrl))))
+ (snd-display ";random fft: ~A: ~A ~A" len rl xrl))))
(list 16 128 512 1024 4096))
;; -------- autocorrelation
@@ -35814,21 +35086,21 @@ EDITS: 1
(set! (rl 0) 1.0)
(autocorrelate rl)
(if (not (vequal rl (float-vector 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";autocorrelate 1: ~A" rl)))
+ (snd-display ";autocorrelate 1: ~A" rl)))
(let ((rl (make-float-vector 16 0.0)))
(set! (rl 0) 1.0)
(set! (rl 1) -1.0)
(autocorrelate rl)
(if (not (vequal rl (float-vector 2 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";autocorrelate 1 -1: ~A" rl)))
+ (snd-display ";autocorrelate 1 -1: ~A" rl)))
(let ((rl (make-float-vector 16 0.0)))
(set! (rl 0) 1.0)
(set! (rl 4) -1.0)
(autocorrelate rl)
(if (not (vequal rl (float-vector 2 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0)))
- (snd-display #__line__ ";autocorrelate 1 0 0 0 -1: ~A" rl)))
+ (snd-display ";autocorrelate 1 0 0 0 -1: ~A" rl)))
(let ((rl (make-float-vector 16))
(rl1 (make-float-vector 16)))
@@ -35839,7 +35111,7 @@ EDITS: 1
(let ((nr (float-vector-subseq (corr rl rl 16 16) 0 15)))
(autocorrelate rl1)
(if (not (vequal rl1 nr))
- (snd-display #__line__ ";autocorrelate/corr (ramp):~%; ~A~%; ~A" rl1 nr))))
+ (snd-display ";autocorrelate/corr (ramp):~%; ~A~%; ~A" rl1 nr))))
(let ((rl (make-float-vector 16))
(rl1 (make-float-vector 16)))
@@ -35850,7 +35122,7 @@ EDITS: 1
(let ((nr (float-vector-subseq (corr rl rl 16 16) 0 15)))
(autocorrelate rl1)
(if (not (vequal rl1 nr))
- (snd-display #__line__ ";autocorrelate/corr:~%; ~A~%; ~A" rl1 nr))))
+ (snd-display ";autocorrelate/corr:~%; ~A~%; ~A" rl1 nr))))
(let ((ind0 (new-sound "test.snd" :size 16))
(ind1 (new-sound "fmv.snd" :size 16)))
@@ -35859,13 +35131,13 @@ EDITS: 1
(let ((data0 (cross-correlate-1 ind0 0 ind1 0))
(data1 (cross-correlate-2 ind0 0 ind1 0)))
(if (not (vequal data0 data1))
- (snd-display #__line__ ";cross-correlate: ~A ~A" data0 data1)))
+ (snd-display ";cross-correlate: ~A ~A" data0 data1)))
(set! (sample 3 ind0 0) 0.0)
(set! (sample 8 ind0 0) 1.0)
(let ((data0 (cross-correlate-1 ind0 0 ind1 0))
(data1 (cross-correlate-2 ind0 0 ind1 0)))
(if (not (vequal data0 data1))
- (snd-display #__line__ ";cross-correlate 1: ~A ~A" data0 data1)))
+ (snd-display ";cross-correlate 1: ~A ~A" data0 data1)))
(close-sound ind0)
(close-sound ind1))
@@ -35880,7 +35152,7 @@ EDITS: 1
(set! v1 (cross-correlate-3 v1 v2 16))
(set! v3 (correlate v3 v4))
(if (not (vequal v1 v3))
- (snd-display #__line__ ";correlate 16:~%; ~A~%; ~A" v1 v3)))
+ (snd-display ";correlate 16:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 128))
(v2 (make-float-vector 128))
@@ -35893,7 +35165,7 @@ EDITS: 1
(set! v1 (cross-correlate-3 v1 v2 128))
(set! v3 (correlate v3 v4))
(if (not (vequal v1 v3))
- (snd-display #__line__ ";correlate 128:~%; ~A~%; ~A" v1 v3)))
+ (snd-display ";correlate 128:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 128))
(v2 (make-float-vector 128))
@@ -35908,7 +35180,7 @@ EDITS: 1
(set! v1 (cross-correlate-3 v1 v2 128))
(set! v3 (correlate v3 v4))
(if (not (vequal v1 v3))
- (snd-display #__line__ ";correlate 128 at random:~%; ~A~%; ~A" v1 v3)))
+ (snd-display ";correlate 128 at random:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 16))
(v2 (make-float-vector 16)))
@@ -35917,7 +35189,7 @@ EDITS: 1
(set! v1 (correlate v1 (copy v1)))
(set! v2 (autocorrelate v2))
(if (not (vequal v1 v2))
- (snd-display #__line__ ";auto/correlate 16:~%; ~A~%; ~A" v1 v2)))
+ (snd-display ";auto/correlate 16:~%; ~A~%; ~A" v1 v2)))
(for-each
(lambda (len)
@@ -35929,14 +35201,14 @@ EDITS: 1
(set! (rl 0) 1.0)
(set! (rl 4) 1.0)
(snd-transform autocorrelation rl 0) ; this is exactly the same as (autocorrelate rl)
- (if (fneq (rl 0) 2.0) (snd-display #__line__ ";autocorrelation ~A 0: ~A" len (rl 0)))
- (if (fneq (rl 4) 1.0) (snd-display #__line__ ";autocorrelation ~A 4: ~A" len (rl 4)))
+ (if (fneq (rl 0) 2.0) (snd-display ";autocorrelation ~A 0: ~A" len (rl 0)))
+ (if (fneq (rl 4) 1.0) (snd-display ";autocorrelation ~A 4: ~A" len (rl 4)))
(set! (rla 0) 1.0)
(set! (rla 4) 1.0)
(autocorrelate rla)
- (if (fneq (rla 0) 2.0) (snd-display #__line__ ";autocorrelate ~A 0: ~A" len (rla 0)))
- (if (fneq (rla 4) 1.0) (snd-display #__line__ ";autocorrelate ~A 4: ~A" len (rla 4)))
+ (if (fneq (rla 0) 2.0) (snd-display ";autocorrelate ~A 0: ~A" len (rla 0)))
+ (if (fneq (rla 4) 1.0) (snd-display ";autocorrelate ~A 4: ~A" len (rla 4)))
(set! (xrl 0) 1.0)
(set! (xrl 4) 1.0)
@@ -35953,27 +35225,27 @@ EDITS: 1
((or (not happy) (= i len2)))
(if (fneq (rl i) (xrl i))
(begin
- (snd-display #__line__ ";mus-fft? ~A at ~A: ~A ~A" len i (rl i) (xrl i))
+ (snd-display ";mus-fft? ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))
(set! (rl 0) 0.0)
(set! (rl 4) 0.0)
- (fill! rl 0.0 (/ len 2) len)
- (if (> (float-vector-peak rl) .001) (snd-display #__line__ ";autocorrelate peak: ~A" (float-vector-peak rl)))))
+ (fill! rl 0.0 len2 len)
+ (if (> (float-vector-peak rl) .001) (snd-display ";autocorrelate peak: ~A" (float-vector-peak rl)))))
(list 16 64 256 512))
(for-each
(lambda (len)
- (let* ((rl (make-float-vector len))
- (xim (make-float-vector len))
- (xrl (make-float-vector len))
- (len2 (/ len 2))
- (ones (max 2 (random len2))))
- (do ((i 0 (+ i 1)))
- ((= i ones))
- (let ((val (random 1.0))
- (ind (random len)))
- (set! (rl ind) val)
- (set! (xrl ind) val)))
+ (let ((rl (make-float-vector len))
+ (xim (make-float-vector len))
+ (xrl (make-float-vector len))
+ (len2 (/ len 2)))
+ (let ((ones (max 2 (random len2))))
+ (do ((i 0 (+ i 1)))
+ ((= i ones))
+ (let ((val (random 1.0))
+ (ind (random len)))
+ (set! (rl ind) val)
+ (set! (xrl ind) val))))
(snd-transform autocorrelation rl 0)
(mus-fft xrl xim len 1)
(set! (xrl 0) (* (xrl 0) (xrl 0)))
@@ -35991,7 +35263,7 @@ EDITS: 1
((or (not happy) (= i len2)))
(if (fneq (rl i) (xrl i))
(begin
- (snd-display #__line__ ";random ~A at ~A: ~A ~A" len i (rl i) (xrl i))
+ (snd-display ";random ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))))
(list 16 64 256 512))
@@ -36006,13 +35278,13 @@ EDITS: 1
(if (not (vequal nrl (float-vector 1.3994950 0.1416877 0.0952407 0.0052814 -0.0613192 0.0082986 -0.0233993
-0.0476585 0.0259498 -0.0476585 -0.0233993 0.0082986 -0.0613192 0.0052814
0.0952407 0.1416877)))
- (snd-display #__line__ ";cepstrum 16: ~A" nrl))))
+ (snd-display ";cepstrum 16: ~A" nrl))))
(let ((rl (make-float-vector 16)))
(do ((i 0 (+ i 1))) ((= i 16)) (set! (rl i) i))
(let ((nrl (float-vector-scale! (snd-transform cepstrum rl 0) 2.72)))
(if (not (vequal nrl (float-vector 2.720 0.452 0.203 0.122 0.082 0.061 0.048 0.041 0.039 0.041 0.048 0.061 0.082 0.122 0.203 0.452)))
- (snd-display #__line__ ";cepstrum 16 by ones: ~A" nrl))))
+ (snd-display ";cepstrum 16 by ones: ~A" nrl))))
(for-each
(lambda (len)
@@ -36028,16 +35300,13 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i len))
(let ((val (+ (* (xrl i) (xrl i)) (* (xim i) (xim i)))))
- (if (> val .0000001)
- (set! val (log (sqrt val)))
- (set! val -10.0))
+ (set! val (if (> val .0000001) (log (sqrt val)) -10.0))
(set! (xrl i) val)))
(float-vector-scale! xim 0.0)
(mus-fft xrl xim len -1)
- (let ((fscl (float-vector-peak xrl)))
- (float-vector-scale! xrl (/ 1.0 fscl)))
+ (float-vector-scale! xrl (/ 1.0 (float-vector-peak xrl)))
(if (not (vequal rl xrl))
- (snd-display #__line__ ";mus-fft?? ~A: ~A ~A" len rl xrl))))
+ (snd-display ";mus-fft?? ~A: ~A ~A" len rl xrl))))
(list 16 64 256 512))
@@ -36047,29 +35316,29 @@ EDITS: 1
(set! (d0 0) 1.0)
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
- (snd-display #__line__ ";walsh 1: ~A" d0))
+ (snd-display ";walsh 1: ~A" d0))
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";walsh -1: ~A" d0))
+ (snd-display ";walsh -1: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 1) 1.0)
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 1.000 -1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
- (snd-display #__line__ ";walsh 2: ~A" d0))
+ (snd-display ";walsh 2: ~A" d0))
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 0.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";walsh -2: ~A" d0))
+ (snd-display ";walsh -2: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 1) 1.0)
(set! (d0 0) 0.5)
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 1.500 -0.500 1.500 -0.500 1.500 -0.500 1.500 -0.500)))
- (snd-display #__line__ ";walsh 3: ~A" d0))
+ (snd-display ";walsh 3: ~A" d0))
(snd-transform walsh-transform d0)
(if (not (vequal d0 (float-vector 4.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";walsh -3: ~A" d0))
+ (snd-display ";walsh -3: ~A" d0))
(set! d0 (make-float-vector 8))
(fill-float-vector d0 (random 1.0))
@@ -36078,22 +35347,22 @@ EDITS: 1
(snd-transform walsh-transform d0)
(float-vector-scale! d0 (/ 1.0 8.0))
(if (not (vequal d0 d1))
- (snd-display #__line__ ";walsh 4: ~A ~A" d0 d1))
+ (snd-display ";walsh 4: ~A ~A" d0 d1))
(set! d0 (float-vector 1 1 1 -1 1 1 1 -1 1 1 1 -1 -1 -1 -1 1))
(set! d1 (snd-transform walsh-transform d0))
(if (not (vequal d1 (float-vector 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 -4.00 -4.00 -4.00 4.00)))
- (snd-display #__line__ ";walsh 5: ~A" d1))
+ (snd-display ";walsh 5: ~A" d1))
(set! d0 (float-vector 1 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0))
(set! d1 (snd-transform walsh-transform d0))
(if (not (vequal d1 (float-vector 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000)))
- (snd-display #__line__ ";walsh 6: ~A" d1))
+ (snd-display ";walsh 6: ~A" d1))
(set! d0 (float-vector 0.174 -0.880 -0.555 -0.879 0.038 0.696 -0.612 0.006 -0.613 0.334 -0.111 -0.821 0.130 0.030 -0.229 0.170))
(set! d1 (snd-transform walsh-transform d0))
(if (not (vequal d1 (float-vector -3.122 -0.434 2.940 -0.468 -3.580 2.716 -0.178 -1.386 -0.902 0.638 1.196 1.848 -0.956 2.592 -1.046 2.926)))
- (snd-display #__line__ ";walsh 7: ~A" d1))
+ (snd-display ";walsh 7: ~A" d1))
;; -------- haar
@@ -36102,33 +35371,33 @@ EDITS: 1
(set! (d0 2) 1.0)
(snd-transform haar-transform d0)
(if (not (vequal d0 (float-vector 0.354 0.354 -0.500 0.000 0.000 0.707 0.000 0.000)))
- (snd-display #__line__ ";haar 1: ~A" d0))
+ (snd-display ";haar 1: ~A" d0))
(inverse-haar d0)
(if (not (vequal d0 (float-vector 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";inverse haar 1: ~A" d0))
+ (snd-display ";inverse haar 1: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 0) 1.0)
(snd-transform haar-transform d0)
(if (not (vequal d0 (float-vector 0.354 0.354 0.500 0.000 0.707 0.000 0.000 0.000)))
- (snd-display #__line__ ";haar 2: ~A" d0))
+ (snd-display ";haar 2: ~A" d0))
(inverse-haar d0)
(if (not (vequal d0 (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";inverse haar 2: ~A" d0))
+ (snd-display ";inverse haar 2: ~A" d0))
(set! d0 (snd-transform haar-transform (float-vector -0.483 0.174 -0.880 -0.555 -0.879 0.038 0.696 -0.612)))
(if (not (vequal d0 (float-vector -0.884 -0.349 0.563 -0.462 -0.465 -0.230 -0.648 0.925)))
- (snd-display #__line__ ";haar 3: ~A" d0))
+ (snd-display ";haar 3: ~A" d0))
;; from "A Primer on Wavelets"
(let ((sq2 (sqrt 2.0)))
(set! d0 (snd-transform haar-transform (float-vector 4 6 10 12 8 6 5 5)))
(if (not (vequal d0 (float-vector (* 14 sq2) (* 2 sq2) -6 2 (- sq2) (- sq2) sq2 0)))
- (snd-display #__line__ ";haar 4: ~A" d0))
+ (snd-display ";haar 4: ~A" d0))
(set! d0 (snd-transform haar-transform (float-vector 2 4 6 8 10 12 14 16)))
(if (not (vequal d0 (float-vector (* 18 sq2) (* -8 sq2) -4 -4 (- sq2) (- sq2) (- sq2) (- sq2))))
- (snd-display #__line__ ";haar 5: ~A" d0)))
+ (snd-display ";haar 5: ~A" d0)))
(set! d0 (make-float-vector 8))
(set! d1 (make-float-vector 8))
@@ -36139,7 +35408,7 @@ EDITS: 1
(snd-transform haar-transform d0)
(inverse-haar d0)
(if (not (vequal d0 d1))
- (snd-display #__line__ ";inverse haar 6: ~A ~A" d0 d1))
+ (snd-display ";inverse haar 6: ~A ~A" d0 d1))
;; --------- wavelet
@@ -36147,7 +35416,7 @@ EDITS: 1
;; test against fxt output
(set! d0 (snd-transform wavelet-transform (float-vector 1 1 0 0 0 0 0 0) 0)) ;"daub4"
(if (not (vequal d0 (float-vector 0.625 0.375 -0.217 1.083 -0.354 0.000 0.000 0.354)))
- (snd-display #__line__ ";fxt wavelet 1: ~A" d0))
+ (snd-display ";fxt wavelet 1: ~A" d0))
(for-each
(lambda (size)
@@ -36160,22 +35429,22 @@ EDITS: 1
(wavelet d1 size 0 pwt (wts i))
(snd-transform wavelet-transform d2 i)
(if (not (vequal d1 d2))
- (snd-display #__line__ ";wavelet ~D: ~A ~A" i d1 d2))
+ (snd-display ";wavelet ~D: ~A ~A" i d1 d2))
(wavelet d2 size -1 pwt (wts i))
(fill! d1 0.0)
(set! (d1 2) 1.0)
(if (not (vequal d1 d2))
- (if (or (= i 9) (= i 10))
+ (if (memv i '(9 10))
(begin
(set! (d2 2) 0.0)
(if (> (float-vector-peak d2) .1)
- (snd-display #__line__ ";inverse wavelet ~D: ~A ~A" i d1 d2)))
+ (snd-display ";inverse wavelet ~D: ~A ~A" i d1 d2)))
(if (> i 14)
(let ((pk (d2 2)))
(set! (d2 2) 0.0)
(if (> (float-vector-peak d2) pk)
- (snd-display #__line__ ";inverse wavelet ~D: ~A ~A" i d1 d2)))
- (snd-display #__line__ ";inverse wavelet ~D: ~A ~A" i d1 d2))))))
+ (snd-display ";inverse wavelet ~D: ~A ~A" i d1 d2)))
+ (snd-display ";inverse wavelet ~D: ~A ~A" i d1 d2))))))
(do ((i 0 (+ i 1)))
((= i 9))
(let ((d1 #f)
@@ -36185,22 +35454,22 @@ EDITS: 1
(snd-transform wavelet-transform d2 i)
(wavelet d2 size -1 pwt (wts i))
(if (not (vequal d1 d2))
- (snd-display #__line__ ";random wavelet ~D: ~A ~A" i d1 d2)))))
+ (snd-display ";random wavelet ~D: ~A ~A" i d1 d2)))))
(list 16 64))
(set! *max-transform-peaks* 100)
- (let ((ind (open-sound "oboe.snd"))
- (ftype (add-transform "low-pass" "filtered" 0.0 1.0
- (lambda (len fd)
- (let ((flt (make-fir-filter :order 8
- :xcoeffs (let ((v1 (make-float-vector 8)))
- (fill! v1 .0125)
- v1)))
- (v (make-float-vector len)))
- (fill-float-vector v (fir-filter flt (read-sample fd))))))))
- (if (not (transform? ftype)) (snd-display #__line__ ";transform added: ~A?" ftype))
- (set! *transform-normalization* dont-normalize)
- (set! (transform-type ind 0) ftype)
+ (let ((ind (open-sound "oboe.snd")))
+ (let ((ftype (add-transform "low-pass" "filtered" 0.0 1.0
+ (lambda (len fd)
+ (let ((flt (make-fir-filter :order 8
+ :xcoeffs (let ((v1 (make-float-vector 8)))
+ (fill! v1 .0125)
+ v1)))
+ (v (make-float-vector len)))
+ (fill-float-vector v (fir-filter flt (read-sample fd))))))))
+ (if (not (transform? ftype)) (snd-display ";transform added: ~A?" ftype))
+ (set! *transform-normalization* dont-normalize)
+ (set! (transform-type ind 0) ftype))
(set! (transform-size ind 0) 16)
(set! (transform-graph-type ind 0) graph-once)
(set! (transform-graph? ind 0) #t)
@@ -36228,164 +35497,158 @@ EDITS: 1
((or (not happy) (= i 256)))
(if (fneq (samps i) (orig i))
(begin
- (snd-display #__line__ ";add-transform same (~A): ~D ~A ~A" ftype i (samps i) (orig i))
+ (snd-display ";add-transform same (~A): ~D ~A ~A" ftype i (samps i) (orig i))
(set! happy #f)))))
(set! (dot-size ind 0) 60)
(set! (graph-style ind 0) graph-lollipops)
(set! (x-bounds) (list 2.579 2.580))
(update-time-graph)
(delete-transform ftype)
- (if (transform? ftype) (snd-display #__line__ ";transform deleted: ~A" ftype))
- (if (transform? -1) (snd-display #__line__ ";transform? -1"))
- (if (transform? (integer->transform 123)) (snd-display #__line__ ";transform? 123"))
+ (if (transform? ftype) (snd-display ";transform deleted: ~A" ftype))
+ (if (transform? -1) (snd-display ";transform? -1"))
+ (if (transform? (integer->transform 123)) (snd-display ";transform? 123"))
(if (not (equal? (transform-type ind 0) fourier-transform))
- (snd-display #__line__ ";after delete-transform ~A -> ~A" ftype (transform-type ind 0)))
+ (snd-display ";after delete-transform ~A -> ~A" ftype (transform-type ind 0)))
(close-sound ind))
- (if (defined? 'bignum-fft)
- (let ()
-
- (define* (vectors-equal? v1 v2 (error 1e-30))
- (let ((len (length v1)))
- (and (= (length v2) len)
- (let ((happy #t))
- (do ((i 0 (+ i 1)))
- ((or (= i len) (not happy)) happy)
- (set! happy (< (magnitude (- (vector-ref v1 i) (vector-ref v2 i))) error)))))))
-
- (define* (bignum-vector :rest args)
- (let* ((len (length args))
- (v (make-vector len)))
- (do ((i 0 (+ i 1))
- (arg args (cdr arg)))
- ((= i len) v)
- (if (bignum? (car arg))
- (vector-set! v i (car arg))
- (vector-set! v i (bignum (number->string (car arg))))))))
-
- ;; -------- -1 -1 at 1
- (let ((rl (make-vector 8))
- (im (make-vector 8)))
- (do ((i 0 (+ i 1)))
- ((= i 8))
- (set! (rl i) (bignum "0.0"))
- (set! (im i) (bignum "0.0")))
- (set! (rl 1) (bignum "-1.0"))
- (set! (im 1) (bignum "-1.0"))
- (bignum-fft rl im 8) ; third arg is size
- (let ((crl (bignum-vector -1.000 0.000 1.000 (sqrt (bignum "2")) 1.000 0.000 -1.000 (- (sqrt (bignum "2")))))
- (cim (bignum-vector -1.000 (- (sqrt (bignum "2"))) -1.000 0.000 1.000 (sqrt (bignum "2")) 1.000 0.000)))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft -1 -1 at 1:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim)))
- (bignum-fft rl im 8 -1)
- (let ((crl (bignum-vector 0.0 -8.0 0.0 0.0 0.0 0.0 0.0 0.0))
- (cim (bignum-vector 0.0 -8.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft -1 -1 at 1 inverse:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))
- (set! (rl 1) (bignum "-1.0"))
- (set! (im 1) (bignum "-1.0"))
- (do ((i 0 (+ i 1)))
- ((= i 4))
- (bignum-fft rl im 8))
- (set! (crl 1) (bignum "-64.0"))
- (set! (cim 1) (bignum "-64.0"))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft -1 -1 at 1 rotate:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
-
- ;; -------- -1 1 at 3
- (let ((rl (make-vector 8))
- (im (make-vector 8)))
- (do ((i 0 (+ i 1)))
- ((= i 8))
- (set! (rl i) (bignum "0.0"))
- (set! (im i) (bignum "0.0")))
- (set! (rl 3) (bignum "-1.0"))
- (set! (im 3) (bignum "1.0"))
- (bignum-fft rl im 8)
- (let ((crl (bignum-vector -1.000 0.000 1.000 (- (sqrt (bignum "2"))) 1.000 0.000 -1.000 (sqrt (bignum "2"))))
- (cim (bignum-vector 1.000 (- (sqrt (bignum "2"))) 1.000 0.000 -1.000 (sqrt (bignum "2")) -1.000 0.000)))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft -1 1 at 3:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
-
- ;; -------- 1 0 at 0 with bignum arg to make-vector (so it should copy)
- (let ((rl (make-vector 8 (bignum "0.0")))
- (im (make-vector 8 (bignum "0.0"))))
- (set! (rl 0) (bignum "1.0"))
- (bignum-fft rl im 8)
- (let ((crl (bignum-vector 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0))
- (cim (bignum-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft 1 0 at 0 (and copied fill):~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
-
- ;; -------- cos/sin
- (let ((rl (make-vector 64))
- (im (make-vector 64)))
- (do ((i 0 (+ i 1)))
- ((= i 64))
- (set! (rl i) (bignum "0.0"))
- (set! (im i) (bignum "0.0")))
- (set! (rl 1) (bignum "1.0"))
-
- (bignum-fft rl im 64 -1)
- (let ((happy #t))
- (do ((i 0 (+ i 1)))
- ((or (= i 64) (not happy)))
- (let ((cerr (magnitude (- (vector-ref rl i) (cos (/ (* 2 pi i) 64)))))
- (serr (magnitude (- (vector-ref im i) (sin (/ (* -2 pi i) 64))))))
- (set! happy (and (< cerr 1e-30)
- (< serr 1e-30)))
- (if (not happy)
- (snd-display #__line__ ";big fft 1 at 0 (sin/cos) differs by ~A in ~A at ~A (~A ~A)~%"
- (max cerr serr)
- (if (> cerr serr) "cos" "sin")
- i
- (if (> cerr serr)
- (cos (/ (* 2 pi i) 64))
- (sin (/ (* -2 pi i) 64)))
- (if (> cerr serr)
- (vector-ref rl i)
- (vector-ref im i)))))))
-
- (bignum-fft rl im 64)
- (let ((crl (make-vector 64 (bignum "0.0")))
- (cim (make-vector 64 (bignum "0.0"))))
- (set! (crl 1) (bignum "64"))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft 1 at 0 fill cos/sin inverse:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
-
- ;; -------- random
- (let ((rl (make-vector 64))
- (im (make-vector 64))
- (crl (make-vector 64))
- (cim (make-vector 64))
- (rs (random-state (bignum "12345678"))))
- (do ((i 0 (+ i 1)))
- ((= i 64))
- (set! (rl i) (random (bignum "1.0") rs))
- (set! (crl i) (+ (vector-ref rl i) 0.0)) ; try to force a copy
- (set! (im i) (random (bignum "1.0") rs))
- (set! (cim i) (+ (vector-ref im i) 0.0)))
-
- (bignum-fft rl im 64 1)
- (if (or (vectors-equal? rl crl)
- (vectors-equal? im cim))
- (snd-display #__line__ ";big-fft random not copied?:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))
-
- (bignum-fft rl im 64 -1)
- (do ((i 0 (+ i 1)))
- ((= i 64))
- (set! (rl i) (/ (vector-ref rl i) 64.0))
- (set! (im i) (/ (vector-ref im i) 64.0)))
- (if (or (not (vectors-equal? rl crl))
- (not (vectors-equal? im cim)))
- (snd-display #__line__ ";big-fft random:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim)))
- ))
+ (when (defined? 'bignum-fft)
+
+ (define* (vectors-equal? v1 v2 (error 1e-30))
+ (let ((len (length v1)))
+ (and (= (length v2) len)
+ (let ((happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (= i len) (not happy)) happy)
+ (set! happy (< (magnitude (- (vector-ref v1 i) (vector-ref v2 i))) error)))))))
+
+ (define* (bignum-vector :rest args)
+ (let* ((len (length args))
+ (v (make-vector len)))
+ (do ((i 0 (+ i 1))
+ (arg args (cdr arg)))
+ ((= i len) v)
+ (vector-set! v i (if (bignum? (car arg)) (car arg) (bignum (number->string (car arg))))))))
+
+ ;; -------- -1 -1 at 1
+ (let ((rl (make-vector 8))
+ (im (make-vector 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 8))
+ (set! (rl i) (bignum "0.0"))
+ (set! (im i) (bignum "0.0")))
+ (set! (rl 1) (bignum "-1.0"))
+ (set! (im 1) (bignum "-1.0"))
+ (bignum-fft rl im 8) ; third arg is size
+ (let ((crl (bignum-vector -1.000 0.000 1.000 (sqrt (bignum "2")) 1.000 0.000 -1.000 (- (sqrt (bignum "2")))))
+ (cim (bignum-vector -1.000 (- (sqrt (bignum "2"))) -1.000 0.000 1.000 (sqrt (bignum "2")) 1.000 0.000)))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft -1 -1 at 1:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim)))
+ (bignum-fft rl im 8 -1)
+ (let ((crl (bignum-vector 0.0 -8.0 0.0 0.0 0.0 0.0 0.0 0.0))
+ (cim (bignum-vector 0.0 -8.0 0.0 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft -1 -1 at 1 inverse:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))
+ (set! (rl 1) (bignum "-1.0"))
+ (set! (im 1) (bignum "-1.0"))
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (bignum-fft rl im 8))
+ (set! (crl 1) (bignum "-64.0"))
+ (set! (cim 1) (bignum "-64.0"))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft -1 -1 at 1 rotate:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
+
+ ;; -------- -1 1 at 3
+ (let ((rl (make-vector 8))
+ (im (make-vector 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 8))
+ (set! (rl i) (bignum "0.0"))
+ (set! (im i) (bignum "0.0")))
+ (set! (rl 3) (bignum "-1.0"))
+ (set! (im 3) (bignum "1.0"))
+ (bignum-fft rl im 8)
+ (let ((crl (bignum-vector -1.000 0.000 1.000 (- (sqrt (bignum "2"))) 1.000 0.000 -1.000 (sqrt (bignum "2"))))
+ (cim (bignum-vector 1.000 (- (sqrt (bignum "2"))) 1.000 0.000 -1.000 (sqrt (bignum "2")) -1.000 0.000)))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft -1 1 at 3:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
+
+ ;; -------- 1 0 at 0 with bignum arg to make-vector (so it should copy)
+ (let ((rl (make-vector 8 (bignum "0.0")))
+ (im (make-vector 8 (bignum "0.0"))))
+ (set! (rl 0) (bignum "1.0"))
+ (bignum-fft rl im 8)
+ (let ((crl (bignum-vector 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0))
+ (cim (bignum-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft 1 0 at 0 (and copied fill):~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
+
+ ;; -------- cos/sin
+ (let ((rl (make-vector 64))
+ (im (make-vector 64)))
+ (do ((i 0 (+ i 1)))
+ ((= i 64))
+ (set! (rl i) (bignum "0.0"))
+ (set! (im i) (bignum "0.0")))
+ (set! (rl 1) (bignum "1.0"))
+
+ (bignum-fft rl im 64 -1)
+ (let ((happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (= i 64) (not happy)))
+ (let ((cerr (magnitude (- (vector-ref rl i) (cos (/ (* 2 pi i) 64)))))
+ (serr (magnitude (- (vector-ref im i) (sin (/ (* -2 pi i) 64))))))
+ (set! happy (and (< cerr 1e-30)
+ (< serr 1e-30)))
+ (if (not happy)
+ (snd-display ";big fft 1 at 0 (sin/cos) differs by ~A in ~A at ~A (~A ~A)~%"
+ (max cerr serr)
+ (if (> cerr serr) "cos" "sin")
+ i
+ (if (> cerr serr)
+ (cos (/ (* 2 pi i) 64))
+ (sin (/ (* -2 pi i) 64)))
+ (vector-ref (if (> cerr serr) rl im) i))))))
+
+ (bignum-fft rl im 64)
+ (let ((crl (make-vector 64 (bignum "0.0")))
+ (cim (make-vector 64 (bignum "0.0"))))
+ (set! (crl 1) (bignum "64"))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft 1 at 0 fill cos/sin inverse:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
+
+ ;; -------- random
+ (let ((rl (make-vector 64))
+ (im (make-vector 64))
+ (crl (make-vector 64))
+ (cim (make-vector 64)))
+ (let ((rs (random-state (bignum "12345678"))))
+ (do ((i 0 (+ i 1)))
+ ((= i 64))
+ (set! (rl i) (random (bignum "1.0") rs))
+ (set! (crl i) (+ (vector-ref rl i) 0.0)) ; try to force a copy
+ (set! (im i) (random (bignum "1.0") rs))
+ (set! (cim i) (+ (vector-ref im i) 0.0))))
+
+ (bignum-fft rl im 64 1)
+ (if (or (vectors-equal? rl crl)
+ (vectors-equal? im cim))
+ (snd-display ";big-fft random not copied?:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))
+
+ (bignum-fft rl im 64 -1)
+ (do ((i 0 (+ i 1)))
+ ((= i 64))
+ (set! (rl i) (/ (vector-ref rl i) 64.0))
+ (set! (im i) (/ (vector-ref im i) 64.0)))
+ (if (not (and (vectors-equal? rl crl)
+ (vectors-equal? im cim)))
+ (snd-display ";big-fft random:~%rl: ~A~% ~A~%im: ~A~% ~A~%" rl crl im cim))))
(let ((ind1 (open-sound "oboe.snd")))
@@ -36399,7 +35662,7 @@ EDITS: 1
(let ((size (transform-framples ind1 0)))
(if (or (number? size)
(not (= (length size) 3)))
- (snd-display #__line__ ";transform-framples of sonogram: ~A" size))))
+ (snd-display ";transform-framples of sonogram: ~A" size))))
(graph->ps "aaa.eps")
(let ((old-colormap *colormap*))
(if (and (defined? 'integer->colormap)
@@ -36425,13 +35688,11 @@ EDITS: 1
(update-transform-graph)
(close-sound ind))
- (let* ((ind (open-sound "oboe.snd"))
- (size 8192)
- (v (channel->float-vector 1000 size ind 0)))
+ (let ((ind (open-sound "oboe.snd")))
(set! (show-listener) #f)
(set! (window-height) 800)
(set! (lisp-graph? ind 0) #t)
- (graph v "biggy" 0.0 1.0 0.0 1.0 ind 0)
+ (graph (channel->float-vector 1000 8192 ind 0) "biggy" 0.0 1.0 0.0 1.0 ind 0)
(set! (transform-graph-type ind 0) graph-once)
(set! (show-transform-peaks ind 0) #t)
(set! (fft-log-magnitude ind 0) #t)
@@ -36462,40 +35723,39 @@ EDITS: 1
(let ((v (dolph 16 2.5)))
(if (not (vequal v (float-vector 0.097 0.113 0.221 0.366 0.536 0.709 0.860 0.963 1.000 0.963 0.860 0.709 0.536 0.366 0.221 0.113)))
- (snd-display #__line__ ";dolph 16 2.5 (dsp.scm): ~A" v)))
+ (snd-display ";dolph 16 2.5 (dsp.scm): ~A" v)))
- (let ((v (make-float-vector 8))
- (v0 (make-float-vector 8)))
- (do ((i 0 (+ i 1)))
- ((= i 8))
- (set! (v i) (mus-random 1.0))
- (set! (v0 i) (float-vector-ref v i)))
- (set! v (float-vector-scale! (dht (dht v)) (/ 1.0 8.0)))
- (if (not (vvequal v v0))
- (snd-display #__line__ ";dht twice: ~A ~A" v v0))
+ (let ((v (make-float-vector 8)))
+ (let ((v0 (make-float-vector 8)))
+ (do ((i 0 (+ i 1)))
+ ((= i 8))
+ (set! (v i) (mus-random 1.0))
+ (set! (v0 i) (float-vector-ref v i)))
+ (set! v (float-vector-scale! (dht (dht v)) (/ 1.0 8.0)))
+ (if (not (vvequal v v0))
+ (snd-display ";dht twice: ~A ~A" v v0)))
(fill! v 0.0)
(set! (v 1) 1.0)
(set! v (dht v))
(if (not (vequal v (float-vector 1.000 1.414 1.000 0.000 -1.000 -1.414 -1.000 0.000)))
- (snd-display #__line__ ";dht of pulse: ~A" v)))
+ (snd-display ";dht of pulse: ~A" v)))
- (let* ((ind (open-sound "oboe.snd"))
- (val1 (car (find-sine 553.0 2000 3000 ind)))
- (val2 (car (find-sine 620.0 2000 3000 ind))))
- (if (or (fneq val1 .03835)
- (fneq val2 .0012))
- (snd-display #__line__ ";find-sine: ~A ~A" val1 val2))
+ (let ((ind (open-sound "oboe.snd")))
+ (let ((val1 (car (find-sine 553.0 2000 3000 ind)))
+ (val2 (car (find-sine 620.0 2000 3000 ind))))
+ (if (or (fneq val1 .03835)
+ (fneq val2 .0012))
+ (snd-display ";find-sine: ~A ~A" val1 val2)))
(let ((frq (spot-freq 2000 ind 0)))
(if (not (= (round frq) 553))
- (snd-display #__line__ ";spot-freq: ~A" frq)))
+ (snd-display ";spot-freq: ~A" frq)))
(down-oct 2)
(let ((frq (spot-freq 2000 ind 0)))
- (if (and (not (= (round frq) 276))
- (not (= (round frq) 277)))
- (snd-display #__line__ ";spot-freq down oct: ~A" frq)))
+ (if (not (member (round frq) '(276 277) =))
+ (snd-display ";spot-freq down oct: ~A" frq)))
(undo)
(zero-phase)
- (if (fneq (sample 0) .1472) (snd-display #__line__ ";zero-phase: ~A" (sample 0)))
+ (if (fneq (sample 0) .1472) (snd-display ";zero-phase: ~A" (sample 0)))
(undo)
(rotate-phase (lambda (x) x))
(undo)
@@ -36513,68 +35773,68 @@ EDITS: 1
(valg2 (* 2 (/ (goertzel 440.0 0 (framples) ind) (framples))))
(valf3 (car (find-sine 437.0 0 (framples) ind)))
(valg3 (* 2 (/ (goertzel 437.0 0 (framples) ind) (framples)))))
- (if (fneq valf valg) (snd-display #__line__ ";goertzel 0: ~A ~A" valf valg))
- (if (fneq valf1 valg1) (snd-display #__line__ ";goertzel 1: ~A ~A" valf1 valg1))
- (if (fneq valf2 valg2) (snd-display #__line__ ";goertzel 2: ~A ~A" valf2 valg2))
- (if (fneq valf3 valg3) (snd-display #__line__ ";goertzel 3: ~A ~A" valf3 valg3))
+ (if (fneq valf valg) (snd-display ";goertzel 0: ~A ~A" valf valg))
+ (if (fneq valf1 valg1) (snd-display ";goertzel 1: ~A ~A" valf1 valg1))
+ (if (fneq valf2 valg2) (snd-display ";goertzel 2: ~A ~A" valf2 valg2))
+ (if (fneq valf3 valg3) (snd-display ";goertzel 3: ~A ~A" valf3 valg3))
(close-sound ind))
(let ((v (float-vector-polynomial (float-vector 0.0 2.0) (float-vector 1.0 2.0))))
(if (not (vequal v (float-vector 1.0 5.0)))
- (snd-display #__line__ ";float-vector-polynomial 0: ~A" v)))
+ (snd-display ";float-vector-polynomial 0: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 0 2 1))))
(if (not (vequal v (float-vector 0.000 3.000 8.000)))
- (snd-display #__line__ ";float-vector-polynomial 1: ~A" v)))
+ (snd-display ";float-vector-polynomial 1: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 0 2 1 .5))))
(if (not (vequal v (float-vector 0.000 3.500 12.000)))
- (snd-display #__line__ ";float-vector-polynomial 2: ~A" v)))
+ (snd-display ";float-vector-polynomial 2: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 1))))
(if (not (vequal v (float-vector 1 1 1)))
- (snd-display #__line__ ";float-vector-polynomial 3: ~A" v)))
- (let* ((ind (open-sound "pistol.snd"))
- (mx (maxamp ind 0)))
- (channel-polynomial (float-vector 0.0 2.0) ind 0)
- (if (fneq (maxamp) (* mx 2))
- (snd-display #__line__ ";channel-polynomial 2: ~A" (maxamp)))
+ (snd-display ";float-vector-polynomial 3: ~A" v)))
+ (let ((ind (open-sound "pistol.snd")))
+ (let ((mx (maxamp ind 0)))
+ (channel-polynomial (float-vector 0.0 2.0) ind 0)
+ (if (fneq (maxamp) (* mx 2))
+ (snd-display ";channel-polynomial 2: ~A" (maxamp))))
(undo)
(channel-polynomial (float-vector 0.0 0.5 0.25 0.25) ind 0)
(if (fneq (maxamp) .222)
- (snd-display #__line__ ";channel-polynomial 3: ~A" (maxamp)))
+ (snd-display ";channel-polynomial 3: ~A" (maxamp)))
(undo)
(channel-polynomial (float-vector 0.0 0.0 1.0) ind 0)
(let ((pos (scan-channel (lambda (y) (< y 0.0)))))
(if pos
- (snd-display #__line__ ";channel-polynomial squares: ~A" pos)))
+ (snd-display ";channel-polynomial squares: ~A" pos)))
(undo)
(channel-polynomial (float-vector 0.5 1.0) ind 0)
(let ((pos (scan-channel (lambda (y) (< y 0.0)))))
(if pos
- (snd-display #__line__ ";channel-polynomial offset: ~A" pos)))
+ (snd-display ";channel-polynomial offset: ~A" pos)))
(if (fneq (maxamp) .8575)
- (snd-display #__line__ ";channel-polynomial off mx: ~A" (maxamp)))
+ (snd-display ";channel-polynomial off mx: ~A" (maxamp)))
(undo)
(spectral-polynomial (float-vector 0.0 1.0) ind 0)
(if (fneq (maxamp) .493)
- (snd-display #__line__ ";spectral-polynomial 0 mx: ~A" (maxamp)))
+ (snd-display ";spectral-polynomial 0 mx: ~A" (maxamp)))
(if (not (= (framples ind 0) 41623))
- (snd-display #__line__ ";spectral-polynomial 0 len: ~A" (framples)))
+ (snd-display ";spectral-polynomial 0 len: ~A" (framples)))
(undo)
(spectral-polynomial (float-vector 0.0 0.5 0.5) ind 0)
(if (fneq (maxamp) .493)
- (snd-display #__line__ ";spectral-polynomial 1: ~A" (maxamp)))
- (if (not (= (framples ind 0) (* 2 41623)))
- (snd-display #__line__ ";spectral-polynomial 1 len: ~A" (framples)))
+ (snd-display ";spectral-polynomial 1: ~A" (maxamp)))
+ (if (not (= (framples ind 0) 83246)) ;(* 2 41623)
+ (snd-display ";spectral-polynomial 1 len: ~A" (framples)))
(undo)
(spectral-polynomial (float-vector 0.0 0.0 0.0 1.0) ind 0)
(if (fneq (maxamp) .493)
- (snd-display #__line__ ";spectral-polynomial 2: ~A" (maxamp)))
- (if (not (= (framples ind 0) (* 3 41623)))
- (snd-display #__line__ ";spectral-polynomial 1 len: ~A" (framples)))
+ (snd-display ";spectral-polynomial 2: ~A" (maxamp)))
+ (if (not (= (framples ind 0) 124869)) ;(* 3 41623)
+ (snd-display ";spectral-polynomial 1 len: ~A" (framples)))
(close-sound ind))
(let ((vals (scentroid "oboe.snd")))
(if (or (fneq (vals 0) 1876.085) (fneq (vals 1) 1447.004))
- (snd-display #__line__ ";scentroid: ~A" vals)))
+ (snd-display ";scentroid: ~A" vals)))
(let ((flt (make-fir-filter 3 (float-vector 0.5 0.25 0.125)))
(data (make-float-vector 10))
@@ -36589,7 +35849,7 @@ EDITS: 1
((= i 10))
(set! (undata i) (fir-filter flt (undata i))))
(if (not (vequal undata data))
- (snd-display #__line__ ";invert-filter: ~A" undata))))
+ (snd-display ";invert-filter: ~A" undata))))
(let ((coeffs (make-float-vector 6)))
(do ((i 0 (+ i 1))
@@ -36609,7 +35869,7 @@ EDITS: 1
((= i 20))
(set! (undata i) (fir-filter flt (undata i))))
(if (not (vequal undata data))
- (snd-display #__line__ ";invert-filter (6): ~A" undata)))))
+ (snd-display ";invert-filter (6): ~A" undata)))))
(let ((flt (make-volterra-filter (float-vector 1.0 .4) (float-vector .3 .2 .1)))
(data (make-float-vector 10))
@@ -36617,9 +35877,9 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (volterra-filter flt x))
- (if (= i 0) (set! x 0.5) (set! x 0.0)))
+ (set! x (if (= i 0) 0.5 0.0)))
(if (not (vequal data (float-vector 0.000 0.575 0.250 0.025 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";volterra-filter: ~A" data)))
+ (snd-display ";volterra-filter: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0) (float-vector 1.0)))
(data (make-float-vector 10)))
@@ -36628,7 +35888,7 @@ EDITS: 1
((= i 10))
(set! (data i) (volterra-filter flt x)))
(if (not (vequal data (float-vector 2.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";volterra-filter x + x^2: ~A" data)))
+ (snd-display ";volterra-filter x + x^2: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0) (float-vector 1.0)))
(data (make-float-vector 10)))
@@ -36637,7 +35897,7 @@ EDITS: 1
((= i 10))
(set! (data i) (volterra-filter flt x)))
(if (not (vequal data (float-vector 2.000 1.710 1.440 1.190 0.960 0.750 0.560 0.390 0.240 0.110)))
- (snd-display #__line__ ";volterra-filter x + x^2 by -0.1: ~A" data)))
+ (snd-display ";volterra-filter x + x^2 by -0.1: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0 0.5) (float-vector 1.0)))
(data (make-float-vector 10)))
@@ -36646,7 +35906,7 @@ EDITS: 1
((= i 10))
(set! (data i) (volterra-filter flt x)))
(if (not (vequal data (float-vector 2.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";volterra-filter x + .5x(n-1) + x^2: ~A" data)))
+ (snd-display ";volterra-filter x + .5x(n-1) + x^2: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0 0.5) (float-vector 1.0 0.6)))
(data (make-float-vector 10)))
@@ -36655,14 +35915,14 @@ EDITS: 1
((= i 10))
(set! (data i) (volterra-filter flt x)))
(if (not (vequal data (float-vector 1.710 0.936 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";volterra-filter x + .5x(n-1) + x^2 + 0.6: ~A" data)))
+ (snd-display ";volterra-filter x + .5x(n-1) + x^2 + 0.6: ~A" data)))
- (let ((ind (new-sound "test.snd" :size 100))
- (gen (make-oscil 440.0)))
- (map-channel (lambda (y) (oscil gen)))
+ (let ((ind (new-sound "test.snd" :size 100)))
+ (let ((gen (make-oscil 440.0)))
+ (map-channel (lambda (y) (oscil gen))))
(down-oct 2)
- (if (not (= (framples) 200)) (snd-display #__line__ ";down-oct new len: ~A" (framples)))
+ (if (not (= (framples) 200)) (snd-display ";down-oct new len: ~A" (framples)))
(let ((r1 (make-sampler 0 ind 0 1 1))
(r2 (make-sampler 0 ind 0 1 2)))
(do ((i 0 (+ i 2)))
@@ -36672,7 +35932,7 @@ EDITS: 1
(val3 (r2)))
(if (and (fneq val1 val2)
(fneq val1 val3))
- (snd-display #__line__ ";down-oct: ~A ~A ~A ~A" i val1 val2 val3)))))
+ (snd-display ";down-oct: ~A ~A ~A ~A" i val1 val2 val3)))))
(kalman-filter-channel) ; just make sure it runs
@@ -36682,9 +35942,9 @@ EDITS: 1
(d1 (make-float-vector 8)))
(set! (d0 2) 1.0)
(let ((vals (fractional-fourier-transform d0 d1 8 1.0)))
- (if (or (not (vequal (car vals) (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000)))
- (not (vequal (cadr vals) (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
- (snd-display #__line__ ";fractional-fft: ~A?" vals))))
+ (if (not (and (vequal (car vals) (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
+ (vequal (cadr vals) (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (snd-display ";fractional-fft: ~A?" vals))))
(let ((d0 (make-float-vector 8))
(d1 (make-float-vector 8)))
@@ -36693,57 +35953,142 @@ EDITS: 1
((= i 8))
(set! (d0 i) (real-part (vector-ref val i)))
(set! (d1 i) (imag-part (vector-ref val i))))
- (if (or (not (vequal d0 (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000)))
- (not (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
- (snd-display #__line__ ";z-transform: ~A ~A?" d0 d1))))
+ (if (not (and (vequal d0 (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
+ (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (snd-display ";z-transform: ~A ~A?" d0 d1))))
(let ((v1 (make-float-vector 16)))
(set! (v1 0) 1.0)
(let ((res (z-transform v1 16 0.5)))
(if (not (vequal res (make-float-vector 16 1.0)))
- (snd-display #__line__ ";z 0.5 0=1: ~A" res)))
+ (snd-display ";z 0.5 0=1: ~A" res)))
(let ((res (z-transform v1 16 -1.0)))
(if (not (vequal res (make-float-vector 16 1.0)))
- (snd-display #__line__ ";z -1.0 0=1: ~A" res)))
+ (snd-display ";z -1.0 0=1: ~A" res)))
(set! (v1 0) 0.0)
(set! (v1 1) 1.0)
(let ((res (z-transform v1 16 0.5)))
(if (not (vequal res (float-vector 1.000 0.500 0.250 0.125 0.062 0.031 0.016 0.008 0.004 0.002 0.001 0.0 0.0 0.0 0.0 0.0)))
- (snd-display #__line__ ";z 0.5 1=1: ~A" res)))
+ (snd-display ";z 0.5 1=1: ~A" res)))
(let ((res (z-transform v1 16 2.0)))
(if (not (vequal res (float-vector 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0
2048.0 4096.0 8192.0 16384.0 32768.0)))
- (snd-display #__line__ ";z 2.0 1=1: ~A" res)))
+ (snd-display ";z 2.0 1=1: ~A" res)))
(set! (v1 2) 1.0)
(let ((res (z-transform v1 16 0.5)))
(if (not (vequal res (float-vector 2.0 0.75 0.3125 0.140 0.0664 0.0322 0.0158 0.00787 0.0039 0.0019 0 0 0 0 0 0)))
- (snd-display #__line__ ";z 0.5 1=1 2=1: ~A" res)))
+ (snd-display ";z 0.5 1=1 2=1: ~A" res)))
(let ((res (z-transform v1 16 2.0)))
(if (not (vequal res (float-vector 2.0 6.0 20.0 72.0 272.0 1056.0 4160.0 16512.0 65792.0
262656.0 1049600.0 4196352.0 16781312.0 67117056.0 268451840.0 1073774592.0)))
- (snd-display #__line__ ";z 2.0 1=1 2=1: ~A" res)))
+ (snd-display ";z 2.0 1=1 2=1: ~A" res)))
(do ((i 0 (+ i 1))
(j 1.0 (* j 0.4)))
((= i 16))
(float-vector-set! v1 i j))
(let ((res (z-transform v1 16 1.0)))
(if (not (vequal res (make-float-vector 16 (/ 1.0 (- 1.0 0.4))))) ; this is confusing
- (snd-display #__line__ ";z 1 0.4g: ~A" res))))
+ (snd-display ";z 1 0.4g: ~A" res))))
(let ((ind (open-sound "oboe.snd")))
- (automorph 0.0+1.0i 0 0 1)
- (automorph 0.0+1.0i 0 0 1)
- (automorph 0.0+1.0i 0 0 1)
- (automorph 0.0+1.0i 0 0 1)
+ (do ((i 0 (+ i 1))) ((= i 4)) (automorph 0.0+1.0i 0 0 1))
(let ((mxdiff (float-vector-peak (float-vector-subtract! (channel->float-vector 0 #f ind 0 0) (channel->float-vector 0 #f ind 0) ))))
- (if (> mxdiff .003) (snd-display #__line__ ";automorph rotation: ~A" mxdiff)))
+ (if (> mxdiff .003) (snd-display ";automorph rotation: ~A" mxdiff)))
(revert-sound ind)
(periodogram 256)
- (if (not (lisp-graph? ind)) (snd-display #__line__ ";periodogram not graphed?"))
+ (if (not (lisp-graph? ind)) (snd-display ";periodogram not graphed?"))
(close-sound ind))
))
+ (define* (cfft! data n (dir 1))
+ (if (not n) (set! n (length data)))
+ (let ((t0 (complex 0.0 (* pi dir))))
+ (do ((i 0 (+ i 1))
+ (j 0))
+ ((= i n))
+ (if (> j i)
+ (let ((temp (data j)))
+ (set! (data j) (data i))
+ (set! (data i) temp)))
+ (let ((m (/ n 2)))
+ (do ()
+ ((or (< m 2) (< j m)))
+ (set! j (- j m))
+ (set! m (/ m 2)))
+ (set! j (+ j m))))
+ (do ((ipow (floor (log n 2)))
+ (prev 1)
+ (lg 0 (+ lg 1))
+ (mmax 2 (* mmax 2))
+ (pow (/ n 2) (/ pow 2))
+ (theta t0 (* theta 0.5)))
+ ((= lg ipow))
+ (let ((wpc (exp theta))
+ (wc 1.0))
+ (do ((ii 0 (+ ii 1)))
+ ((= ii prev))
+ (do ((jj 0 (+ jj 1))
+ (i ii (+ i mmax))
+ (j (+ ii prev) (+ j mmax)))
+ ((>= jj pow))
+ (let ((tc (* wc (data j))))
+ (set! (data j) (- (data i) tc))
+ (set! (data i) (+ (data i) tc))))
+ (set! wc (* wc wpc)))
+ (set! prev mmax)))
+ data))
+
+ (define* (fft! rl im n (dir 1))
+ (if (not im)
+ (set! im (make-float-vector (length rl))))
+ (if (not n)
+ (set! n (length rl)))
+ (do ((i 0 (+ i 1))
+ (j 0))
+ ((= i n))
+ (if (> j i)
+ (let ((tempr (rl j))
+ (tempi (im j)))
+ (set! (rl j) (rl i))
+ (set! (im j) (im i))
+ (set! (rl i) tempr)
+ (set! (im i) tempi)))
+ (do ((m (/ n 2)))
+ ((or (< m 2)
+ (< j m))
+ (set! j (+ j m)))
+ (set! j (- j m))
+ (set! m (/ m 2))))
+ (do ((ipow (floor (log n 2)))
+ (prev 1)
+ (lg 0 (+ lg 1))
+ (mmax 2 (* mmax 2))
+ (pow (/ n 2) (/ pow 2))
+ (theta (* pi dir) (* theta 0.5)))
+ ((= lg ipow))
+ (let ((wpr (cos theta))
+ (wpi (sin theta))
+ (wr 1.0)
+ (wi 0.0))
+ (do ((ii 0 (+ ii 1)))
+ ((= ii prev))
+ (do ((jj 0 (+ jj 1))
+ (i ii (+ i mmax))
+ (j (+ ii prev) (+ j mmax)))
+ ((>= jj pow))
+ (let ((tempr (- (* wr (rl j)) (* wi (im j))))
+ (tempi (+ (* wr (im j)) (* wi (rl j)))))
+ (set! (rl j) (- (rl i) tempr))
+ (set! (im j) (- (im i) tempi))
+ (set! (rl i) (+ (rl i) tempr))
+ (set! (im i) (+ (im i) tempi))))
+ (let ((wtemp wr))
+ (set! wr (- (* wr wpr) (* wi wpi)))
+ (set! wi (+ (* wi wpr) (* wtemp wpi)))))
+ (set! prev mmax)))
+ rl)
+
(do ((i 0 (+ i 1)))
((= i 10))
(let* ((len (expt 2 (+ 2 (random 8))))
@@ -36764,11 +36109,10 @@ EDITS: 1
(let ((diffr (abs (- (v0 m) (real-part (v2 m)))))
(diffi (abs (- (v1 m) (imag-part (v2 m))))))
(set! sum (+ sum diffr diffi))
- (if (> (max diffr diffi) mx)
- (set! mx (max diffr diffi)))))
+ (set! mx (max mx diffr diffi))))
(if (or (> mx 1e-6)
(> sum 1e-6))
- (snd-display #__line__ ";cfft! ~A: ~A ~A~%" len mx sum)))))
+ (snd-display ";cfft! ~A: ~A ~A~%" len mx sum)))))
(let ((val (cfft! (cfft! (cfft! (cfft! (vector 0.0 1+i 0.0 0.0)))))))
(if (or (> (magnitude (val 0)) 1e-12)
@@ -36776,7 +36120,7 @@ EDITS: 1
(> (magnitude (val 3)) 1e-12)
(fneq 16.0 (real-part (val 1)))
(fneq 16.0 (imag-part (val 1))))
- (snd-display #__line__ ";cfft! 4x: ~A" val)))
+ (snd-display ";cfft! 4x: ~A" val)))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -36791,21 +36135,19 @@ EDITS: 1
(float-vector-set! v1 k (mus-random 0.5))
(set! (v2 k) (v0 k))
(set! (v3 k) (v1 k)))
- (let ()
- (mus-fft v0 v1 len 1)
- (fft! v2 v3 len 1)
- (let ((sum 0.0)
- (mx 0.0))
- (do ((m 0 (+ m 1)))
- ((= m len))
- (let ((diffr (abs (- (v0 m) (v2 m))))
- (diffi (abs (- (v1 m) (v3 m)))))
- (set! sum (+ sum diffr diffi))
- (if (> (max diffr diffi) mx)
- (set! mx (max diffr diffi)))))
- (if (or (> mx 1e-6)
- (> sum 1e-6))
- (snd-display #__line__ ";fft! ~A: ~A ~A~%" len mx sum))))))
+ (mus-fft v0 v1 len 1)
+ (fft! v2 v3 len 1)
+ (let ((sum 0.0)
+ (mx 0.0))
+ (do ((m 0 (+ m 1)))
+ ((= m len))
+ (let ((diffr (abs (- (v0 m) (v2 m))))
+ (diffi (abs (- (v1 m) (v3 m)))))
+ (set! sum (+ sum diffr diffi))
+ (set! mx (max mx diffr diffi))))
+ (if (or (> mx 1e-6)
+ (> sum 1e-6))
+ (snd-display ";fft! ~A: ~A ~A~%" len mx sum)))))
))
@@ -36846,7 +36188,7 @@ EDITS: 1
(draw-string text (- xpos (/ text-width 2)) 18 snd chn time-graph cr)
(free-cairo cr)))
(lambda args
- (snd-display #__line__ ";draw error: ~A" args)))))))
+ (snd-display ";draw error: ~A" args)))))))
comments)))
(define display-samps-in-red
@@ -36858,41 +36200,41 @@ EDITS: 1
(right (right-sample snd chn))
(old-color (foreground-color snd chn))
(red (make-color-with-catch 1 0 0)))
- (if (and (< left 2000)
- (> right 1000))
- (let ((data (make-graph-data snd chn)))
- (if data
- (if (float-vector? data) ;the simple, one-sided graph case
- (let* ((samps (- (min right 2000)
- (max left 1000)))
- (offset (max 0 (- 1000 left)))
- (new-data (float-vector-subseq data offset (+ offset samps)))
- (cr (make-cairo (car (channel-widgets snd chn)))))
- (set! (foreground-color snd chn) red)
- (graph-data new-data snd chn copy-context (max 1000 left) (min 2000 right) graph-lines cr)
- (free-cairo cr)
- (set! (foreground-color snd chn) old-color))
- (let* ((low-data (car data)) ;the two-sided envelope graph case
- (high-data (cadr data))
- ;; we need to place the red portion correctly in the current graph
- ;; so the following is getting the "bin" numbers associated with
- ;; samples 1000 and 2000
- (size (length low-data))
- (samps (- right left))
- (left-offset (max 0 (- 1000 left)))
- (left-bin (round (/ (* size left-offset) samps)))
- (right-offset (- (min 2000 right) left))
- (right-bin (round (/ (* size right-offset) samps)))
- (new-low-data (float-vector-subseq low-data left-bin right-bin))
- (new-high-data (float-vector-subseq high-data left-bin right-bin))
- (cr (make-cairo (car (channel-widgets snd chn)))))
- (set! (foreground-color snd chn) red)
- (graph-data
- (list new-low-data new-high-data) snd chn copy-context left-bin right-bin graph-lines cr)
- (free-cairo cr)
- (set! (foreground-color snd chn) old-color))))))))
+ (when (and (< left 2000)
+ (> right 1000))
+ (let ((data (make-graph-data snd chn)))
+ (when data
+ (if (float-vector? data) ;the simple, one-sided graph case
+ (let* ((samps (- (min right 2000)
+ (max left 1000)))
+ (offset (max 0 (- 1000 left)))
+ (new-data (float-vector-subseq data offset (+ offset samps)))
+ (cr (make-cairo (car (channel-widgets snd chn)))))
+ (set! (foreground-color snd chn) red)
+ (graph-data new-data snd chn copy-context (max 1000 left) (min 2000 right) graph-lines cr)
+ (free-cairo cr)
+ (set! (foreground-color snd chn) old-color))
+ (let* ((low-data (car data)) ;the two-sided envelope graph case
+ (high-data (cadr data))
+ ;; we need to place the red portion correctly in the current graph
+ ;; so the following is getting the "bin" numbers associated with
+ ;; samples 1000 and 2000
+ (size (length low-data))
+ (samps (- right left))
+ (left-offset (max 0 (- 1000 left)))
+ (left-bin (round (/ (* size left-offset) samps)))
+ (right-offset (- (min 2000 right) left))
+ (right-bin (round (/ (* size right-offset) samps)))
+ (new-low-data (float-vector-subseq low-data left-bin right-bin))
+ (new-high-data (float-vector-subseq high-data left-bin right-bin))
+ (cr (make-cairo (car (channel-widgets snd chn)))))
+ (set! (foreground-color snd chn) red)
+ (graph-data
+ (list new-low-data new-high-data) snd chn copy-context left-bin right-bin graph-lines cr)
+ (free-cairo cr)
+ (set! (foreground-color snd chn) old-color))))))))
(lambda args
- (snd-display #__line__ ";draw error: ~A" args))))))
+ (snd-display ";draw error: ~A" args))))))
(define* (show-greeting (snd 0) (chn 0))
(let ((ls (left-sample snd chn))
@@ -36911,62 +36253,62 @@ EDITS: 1
(do ((test-ctr 0 (+ 1 test-ctr))) ((= test-ctr tests))
(log-mem test-ctr)
- (if (not (sound-file? "oboe.snd")) (snd-display #__line__ ";oboe.snd not a sound file?"))
- (if (not (sound-file? "4.aiff")) (snd-display #__line__ ";4.aiff not a sound file?"))
- (if (sound-file? "snd.h") (snd-display #__line__ ";snd.h is a sound-file?"))
+ (if (not (sound-file? "oboe.snd")) (snd-display ";oboe.snd not a sound file?"))
+ (if (not (sound-file? "4.aiff")) (snd-display ";4.aiff not a sound file?"))
+ (if (sound-file? "snd.h") (snd-display ";snd.h is a sound-file?"))
(let ((ind1 (open-sound "oboe.snd")))
(save-sound-as "test.snd" ind1)
(let ((ind2 (open-sound "test.snd")))
(if (not (channels-equal? ind1 0 ind2 0))
- (snd-display #__line__ ";channels-equal? of copy"))
+ (snd-display ";channels-equal? of copy"))
(if (not (channels=? ind1 0 ind2 0))
- (snd-display #__line__ ";channels=? of copy"))
+ (snd-display ";channels=? of copy"))
(pad-channel (framples ind2 0) 100)
(if (channels-equal? ind1 0 ind2 0)
- (snd-display #__line__ ";channels-equal? of pad"))
+ (snd-display ";channels-equal? of pad"))
(if (not (channels=? ind1 0 ind2 0))
- (snd-display #__line__ ";channels=? of pad"))
+ (snd-display ";channels=? of pad"))
(set! (sample 50900 ind2 0) .1)
(if (channels-equal? ind1 0 ind2 0)
- (snd-display #__line__ ";channels-equal? of pad+set"))
+ (snd-display ";channels-equal? of pad+set"))
(if (channels=? ind1 0 ind2 0)
- (snd-display #__line__ ";channels=? of pad+set 0 err"))
+ (snd-display ";channels=? of pad+set 0 err"))
(if (not (channels=? ind1 0 ind2 0 .2))
- (snd-display #__line__ ";channels=? of pad+set .2 err"))
- (if with-gui
- (begin
- (add-comment 1234 "sample 1234" ind1 0)
- (let ((comments (show-comments ind1 0)))
- (update-time-graph)
- (if (null? comments) (snd-display #__line__ ";add-comment failed?")))
- (display-samps-in-red ind1 0)
- (update-time-graph)
- (catch #t (lambda () (show-greeting ind1 0)) (lambda args args))
- (update-time-graph)
- (color-samples *highlight-color* 0 100 ind1 0)
- (update-time-graph)
- (power-env-channel (make-power-env '(0 0 .325 1 1 32.0 2 0 32.0) :duration 2.0))
- (update-time-graph)
- (revert-sound ind1)
- (make-selection 10000 20000 ind1 0)
- (if (not (selection?))
- (snd-display #__line__ ";make-selection for show failed?")
- (begin
- (show-selection)
- (let ((vals (x-bounds ind1 0)))
- (if (and (pair? vals)
- (or (fneq (car vals) (/ 10000.0 (srate ind1)))
- (fneq (cadr vals) (/ 20000.0 (srate ind1)))))
- (snd-display #__line__ ";show-selection: ~A (~A)" vals (list (/ 10000.0 (srate ind1)) (/ 20000.0 (srate ind1))))))))
- (hook-push graph-hook zoom-spectrum)
- (set! (transform-graph? ind1 0) #t)
- (let ((ind3 (open-sound "pistol.snd")))
- (overlay-sounds ind2 ind1 ind3)
- (update-time-graph ind2 0)
- (set! (hook-functions after-graph-hook) ())
- (close-sound ind3))
- (samples-via-colormap ind1 0)))
+ (snd-display ";channels=? of pad+set .2 err"))
+ (when with-gui
+ (add-comment 1234 "sample 1234" ind1 0)
+ (let ((comments (show-comments ind1 0)))
+ (update-time-graph)
+ (if (null? comments) (snd-display ";add-comment failed?")))
+ (display-samps-in-red ind1 0)
+ (update-time-graph)
+ (catch #t (lambda () (show-greeting ind1 0)) (lambda args args))
+ (update-time-graph)
+ (color-samples *highlight-color* 0 100 ind1 0)
+ (update-time-graph)
+ (power-env-channel (make-power-env '(0 0 .325 1 1 32.0 2 0 32.0) :duration 2.0))
+ (update-time-graph)
+ (revert-sound ind1)
+ (make-selection 10000 20000 ind1 0)
+ (if (not (selection?))
+ (snd-display ";make-selection for show failed?")
+ (begin
+ (show-selection)
+ (let ((vals (x-bounds ind1 0)))
+ (if (and (pair? vals)
+ (pair? (cdr vals))
+ (or (fneq (car vals) (/ 10000.0 (srate ind1)))
+ (fneq (cadr vals) (/ 20000.0 (srate ind1)))))
+ (snd-display ";show-selection: ~A (~A)" vals (list (/ 10000.0 (srate ind1)) (/ 20000.0 (srate ind1))))))))
+ (hook-push graph-hook zoom-spectrum)
+ (set! (transform-graph? ind1 0) #t)
+ (let ((ind3 (open-sound "pistol.snd")))
+ (overlay-sounds ind2 ind1 ind3)
+ (update-time-graph ind2 0)
+ (set! (hook-functions after-graph-hook) ())
+ (close-sound ind3))
+ (samples-via-colormap ind1 0))
(close-sound ind1)
(hook-remove graph-hook zoom-spectrum)
(close-sound ind2)))
@@ -36978,7 +36320,7 @@ EDITS: 1
(set! (selection-framples ns 0) 3000)
(show-selection)
(if (not (equal? (list (left-sample ns 0) (right-sample ns 0)) '(1000 3999)))
- (snd-display #__line__ ";show-selection 1.snd: ~A ~A" (left-sample ns 0) (right-sample ns 0)))
+ (snd-display ";show-selection 1.snd: ~A ~A" (left-sample ns 0) (right-sample ns 0)))
(unselect-all)
(let ((ns1 (open-sound "1234.snd")))
(set! (sync ns1) 0)
@@ -36992,23 +36334,23 @@ EDITS: 1
(set! (selection-position ns1 1) 10000)
(set! (selection-framples ns1 1) 30000)
(show-selection)
- (if (or (not (eqv? (left-sample ns 0) 10000))
- (not (member (right-sample ns 0) '(39999 39998)))
- (not (eqv? (left-sample ns1 0) 10000))
- (not (member (right-sample ns1 0) '(39999 39998)))
- (not (eqv? (left-sample ns1 1) 10000))
- (not (member (right-sample ns1 1) '(39999 39998))))
- (snd-display #__line__ ";show-selection 1234.snd: ~A" (list (left-sample ns 0) (right-sample ns 0)
+ (if (not (and (eqv? (left-sample ns 0) 10000)
+ (member (right-sample ns 0) '(39999 39998))
+ (eqv? (left-sample ns1 0) 10000)
+ (member (right-sample ns1 0) '(39999 39998))
+ (eqv? (left-sample ns1 1) 10000)
+ (member (right-sample ns1 1) '(39999 39998))))
+ (snd-display ";show-selection 1234.snd: ~A" (list (left-sample ns 0) (right-sample ns 0)
(left-sample ns1 0) (right-sample ns1 0)
(left-sample ns1 1) (right-sample ns1 1))))
(close-sound ns1)
(close-sound ns)))
(let ((pe (make-power-env '(0 0 32.0 1 1 32.0 2 0 0.0) :duration .1)))
- (if (not (penv? pe)) (snd-display #__line__ ";penv? ~A" pe))
- (let ((x (power-env pe))) (if (fneq x 0.0) (snd-display #__line__ ";power-env start: ~A" x)))
- (if (> (abs (- (pe 'current-pass) 2203)) 2) (snd-display #__line__ ";power-env pass: ~A" (pe 'current-pass))) ; 4410/2 - 1 because x1=2
- (if (not (= (pe 'current-env) 0)) (snd-display #__line__ ";power-env seg: ~A" (pe 'current-env)))
+ (if (not (penv? pe)) (snd-display ";penv? ~A" pe))
+ (let ((x (power-env pe))) (if (fneq x 0.0) (snd-display ";power-env start: ~A" x)))
+ (if (> (abs (- (pe 'current-pass) 2203)) 2) (snd-display ";power-env pass: ~A" (pe 'current-pass))) ; 4410/2 - 1 because x1=2
+ (if (not (= (pe 'current-env) 0)) (snd-display ";power-env seg: ~A" (pe 'current-env)))
)
(let ((old-srate *clm-srate*))
@@ -37018,15 +36360,15 @@ EDITS: 1
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 32.0 1 1 0.0312 2 0 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
- (if (and (not (vequal1 (channel->float-vector)
+ (if (not (or (vequal1 (channel->float-vector)
(float-vector 0.000 0.008 0.017 0.030 0.044 0.063 0.086 0.115 0.150 0.194 0.249
0.317 0.402 0.507 0.637 0.799 1.000 0.992 0.983 0.971 0.956 0.937
- 0.914 0.885 0.850 0.806 0.751 0.683 0.598 0.493 0.363 0.201 0.000)))
- (not (vequal1 (channel->float-vector)
+ 0.914 0.885 0.850 0.806 0.751 0.683 0.598 0.493 0.363 0.201 0.000))
+ (vequal1 (channel->float-vector)
(float-vector 0.000 0.008 0.019 0.032 0.049 0.070 0.097 0.130 0.173 0.226 0.293
0.377 0.484 0.618 0.787 1.000 0.992 0.981 0.968 0.951 0.930 0.903
0.870 0.828 0.774 0.707 0.623 0.516 0.382 0.213 0.000 0.000 0.000))))
- (snd-display #__line__ ";power-env: ~A" (channel->float-vector))))
+ (snd-display ";power-env: ~A" (channel->float-vector))))
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 1.0 1 1 0.0 2 0 1 3 0 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
@@ -37034,19 +36376,19 @@ EDITS: 1
(float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000
1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";power-env 0 and 1: ~A" (channel->float-vector))))
+ (snd-display ";power-env 0 and 1: ~A" (channel->float-vector))))
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 .01 1 1 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
- (if (and (not (vequal1 (channel->float-vector)
+ (if (not (or (vequal1 (channel->float-vector)
(float-vector 0.000 0.132 0.246 0.346 0.432 0.507 0.573 0.630 0.679 0.722 0.760
0.792 0.821 0.845 0.867 0.886 0.902 0.916 0.928 0.939 0.948 0.956
- 0.963 0.969 0.975 0.979 0.983 0.987 0.990 0.992 0.995 0.997 0.998)))
- (not (vequal1 (channel->float-vector)
+ 0.963 0.969 0.975 0.979 0.983 0.987 0.990 0.992 0.995 0.997 0.998))
+ (vequal1 (channel->float-vector)
(float-vector 0.000 0.135 0.253 0.354 0.442 0.518 0.584 0.641 0.691 0.733 0.771
0.803 0.830 0.855 0.875 0.893 0.909 0.923 0.934 0.945 0.953 0.961
0.968 0.973 0.978 0.982 0.986 0.987 0.990 0.992 0.995 0.997 0.998))))
- (snd-display #__line__ ";power-env .01: ~A" (channel->float-vector))))
+ (snd-display ";power-env .01: ~A" (channel->float-vector))))
(let ((name (file-name ind)))
(close-sound ind)
(if (file-exists? name) (delete-file name))))
@@ -37057,97 +36399,96 @@ EDITS: 1
(filter-channel (float-vector .5 1.0 .5) 3)
(let ((data (channel->float-vector 0 10)))
(if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter (sym 3): ~A" data)))
+ (snd-display ";filter (sym 3): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 .25) 3)
(let ((data (channel->float-vector 0 10)))
(if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 0.250 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter (3): ~A" data)))
+ (snd-display ";filter (3): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 1.0 .5) 4)
(let ((data (channel->float-vector 0 10)))
(if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.500 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter (sym 4): ~A" data)))
+ (snd-display ";filter (sym 4): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 1.0 .25) 4)
(let ((data (channel->float-vector 0 10)))
(if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.250 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter (4): ~A" data)))
+ (snd-display ";filter (4): ~A" data)))
(undo)
(close-sound ind))
- (let ()
- (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next #f 100)
- (set! (sample 10) 0.5)
- (filter-sound (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
- (undo)
- (filter-channel (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";filter-channel (v) 1 0 1: ~A" (channel->float-vector 5 10)))
- (undo)
- (filter-sound '(0 1 1 1) 100)
- (let ((coeffs (make-fir-coeffs 100 (make-float-vector 100 0.5)))
- (data (channel->float-vector 10 100))
- (happy #t))
- (do ((i 0 (+ i 1)))
- ((or (not happy) (= i 100)))
- (if (fneq (data i) (coeffs i))
- (begin
- (snd-display #__line__ ";coeffs '(0 1 1 1): ~A ~A ~A" i (coeffs i) (data i))
- (set! happy #f)))))
- (undo)
- (filter-sound '(0 1 1 1) 1000)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
- (undo)
- (make-selection 5 15)
- (filter-selection '(0 1 1 1) 100)
- (if (and (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 11)))
- (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111))))
- (snd-display #__line__ ";filter-selection truncated: ~S" (edit-fragment 2)))
- (undo)
- (filter-selection '(0 1 1 1) 100 #f)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111)))
- (snd-display #__line__ ";filter-selection not truncated: ~S" (edit-fragment 2)))
- (if (not (vequal (channel->float-vector 50 10) (float-vector -0.016 0.018 -0.021 0.024 -0.029 0.035 -0.045 0.064 -0.106 0.318)))
- (snd-display #__line__ ";filter-selection no trunc: ~A" (channel->float-vector 50 10)))
- (undo)
- (filter-selection '(0 1 1 1) 1024 #t)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 11)))
- (snd-display #__line__ ";filter-selection truncated (1000): ~S" (edit-fragment 2)))
- (if (fneq (maxamp) 0.0) (snd-display #__line__ ";filter-selection 1000 untrunc? ~A" (maxamp)))
- (undo)
- (filter-selection '(0 1 1 1) 1024 #f)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 1035)))
- (snd-display #__line__ ";filter-selection not truncated (1000): ~S" (edit-fragment 2)))
- (if (fneq (maxamp) 0.318) (snd-display #__line__ ";filter-selection 1000 no trunc? ~A" (maxamp)))
- (if (not (vequal (channel->float-vector 517 10) (float-vector 0.035 -0.045 0.064 -0.106 0.318 0.318 -0.106 0.064 -0.045 0.035)))
- (snd-display #__line__ ";filter-selection 1000 no trunc: ~A" (channel->float-vector 505 10)))
-
- (undo)
- (filter-channel '(0 1 1 1) 10)
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0.008 -0.025 0.050 -0.098 0.316 0.316 -0.098 0.050 -0.025 0.008)))
- (snd-display #__line__ ";filter-channel 10: ~A" (channel->float-vector 10 10)))
- (undo)
- (filter-channel '(0 1 1 1) 1000)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter-channel 1 (1000): ~A" (channel->float-vector 5 10)))
- (undo)
- (filter-channel '(0 1 1 0) 10)
- (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter-channel lp: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
- (undo)
- (filter-channel '(0 1 1 0) 10 0 20 #f #f #f #f)
- (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
- 0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
- 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";filter-channel lp no trunc: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
- (undo)
- (close-sound))
+ (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next #f 100)
+ (set! (sample 10) 0.5)
+ (filter-sound (float-vector 1.0 0.0 1.0) 3)
+ (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (snd-display ";filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
+ (undo)
+ (filter-channel (float-vector 1.0 0.0 1.0) 3)
+ (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (snd-display ";filter-channel (v) 1 0 1: ~A" (channel->float-vector 5 10)))
+ (undo)
+ (filter-sound '(0 1 1 1) 100)
+ (let ((coeffs (make-fir-coeffs 100 (make-float-vector 100 0.5)))
+ (data (channel->float-vector 10 100))
+ (happy #t))
+ (do ((i 0 (+ i 1)))
+ ((or (not happy) (= i 100)))
+ (if (fneq (data i) (coeffs i))
+ (begin
+ (snd-display ";coeffs '(0 1 1 1): ~A ~A ~A" i (coeffs i) (data i))
+ (set! happy #f)))))
+ (undo)
+ (filter-sound '(0 1 1 1) 1000)
+ (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
+ (snd-display ";filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
+ (undo)
+ (make-selection 5 15)
+ (filter-selection '(0 1 1 1) 100)
+ (if (not (or (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 11))
+ (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111))))
+ (snd-display ";filter-selection truncated: ~S" (edit-fragment 2)))
+ (undo)
+ (filter-selection '(0 1 1 1) 100 #f)
+ (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111)))
+ (snd-display ";filter-selection not truncated: ~S" (edit-fragment 2)))
+ (if (not (vequal (channel->float-vector 50 10) (float-vector -0.016 0.018 -0.021 0.024 -0.029 0.035 -0.045 0.064 -0.106 0.318)))
+ (snd-display ";filter-selection no trunc: ~A" (channel->float-vector 50 10)))
+ (undo)
+ (filter-selection '(0 1 1 1) 1024 #t)
+ (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 11)))
+ (snd-display ";filter-selection truncated (1000): ~S" (edit-fragment 2)))
+ (if (fneq (maxamp) 0.0) (snd-display ";filter-selection 1000 untrunc? ~A" (maxamp)))
+ (undo)
+ (filter-selection '(0 1 1 1) 1024 #f)
+ (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 1035)))
+ (snd-display ";filter-selection not truncated (1000): ~S" (edit-fragment 2)))
+ (if (fneq (maxamp) 0.318) (snd-display ";filter-selection 1000 no trunc? ~A" (maxamp)))
+ (if (not (vequal (channel->float-vector 517 10) (float-vector 0.035 -0.045 0.064 -0.106 0.318 0.318 -0.106 0.064 -0.045 0.035)))
+ (snd-display ";filter-selection 1000 no trunc: ~A" (channel->float-vector 505 10)))
+
+ (undo)
+ (filter-channel '(0 1 1 1) 10)
+ (if (not (vequal (channel->float-vector 10 10) (float-vector 0.008 -0.025 0.050 -0.098 0.316 0.316 -0.098 0.050 -0.025 0.008)))
+ (snd-display ";filter-channel 10: ~A" (channel->float-vector 10 10)))
+ (undo)
+ (filter-channel '(0 1 1 1) 1000)
+ (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
+ (snd-display ";filter-channel 1 (1000): ~A" (channel->float-vector 5 10)))
+ (undo)
+ (filter-channel '(0 1 1 0) 10)
+ (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";filter-channel lp: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
+ (undo)
+ (filter-channel '(0 1 1 0) 10 0 20 #f #f #f #f)
+ (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ 0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
+ 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (snd-display ";filter-channel lp no trunc: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
+ (undo)
+ (close-sound)
(let ((ind (new-sound "tmp.snd" 2 22050 mus-ldouble mus-next #f 100)))
(set! (sample 10) 0.5)
@@ -37155,45 +36496,45 @@ EDITS: 1
(set! (sync ind) 1)
(filter-sound (float-vector 1.0 0.0 1.0) 3)
(if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
+ (snd-display ";(2) filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
(if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
+ (snd-display ";(2) filter-sound 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
(undo)
(filter-sound '(0 1 1 1) 1000)
(if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
+ (snd-display ";(2) filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
(if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 2 (1000): ~A" (channel->float-vector 0 10)))
+ (snd-display ";(2) filter-sound 2 (1000): ~A" (channel->float-vector 0 10)))
(undo)
(make-selection 0 20)
(filter-selection (float-vector 1.0 0.0 1.0) 3)
(if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-selection 1 0 1: ~A" (channel->float-vector 5 10)))
+ (snd-display ";(2) filter-selection 1 0 1: ~A" (channel->float-vector 5 10)))
(if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-selection 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
+ (snd-display ";(2) filter-selection 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
(undo)
(set! (sync ind) 0)
(filter-selection (float-vector 1.0 0.0 1.0) 3)
(if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-selection 1 0 1 (no sync): ~A" (channel->float-vector 5 10)))
+ (snd-display ";(2) filter-selection 1 0 1 (no sync): ~A" (channel->float-vector 5 10)))
(if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-selection 1 0 2 (no sync): ~A" (channel->float-vector 0 10 ind 1)))
+ (snd-display ";(2) filter-selection 1 0 2 (no sync): ~A" (channel->float-vector 0 10 ind 1)))
(undo 1 ind 0)
(undo 1 ind 1)
- (if (not (= (edit-position ind 0) 1)) (snd-display #__line__ ";edpos filter-sel undo: ~A" (edit-position ind 0)))
- (if (not (= (edit-position ind 1) 1)) (snd-display #__line__ ";edpos filter-sel undo 1: ~A" (edit-position ind 1)))
+ (if (not (= (edit-position ind 0) 1)) (snd-display ";edpos filter-sel undo: ~A" (edit-position ind 0)))
+ (if (not (= (edit-position ind 1) 1)) (snd-display ";edpos filter-sel undo 1: ~A" (edit-position ind 1)))
(filter-sound (float-vector 1.0 0.0 1.0) 3)
(if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 1 0 1 no sync: ~A" (channel->float-vector 5 10)))
+ (snd-display ";(2) filter-sound 1 0 1 no sync: ~A" (channel->float-vector 5 10)))
(if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
- (snd-display #__line__ ";(2) filter-sound 1 0 2 no sync: ~A" (channel->float-vector 0 10 ind 1)))
+ (snd-display ";(2) filter-sound 1 0 2 no sync: ~A" (channel->float-vector 0 10 ind 1)))
(undo 1 ind 0)
(filter-channel '(0 1 1 0) 10 #f #f ind 1)
(if (not (vequal (channel->float-vector 0 30 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000; 0.000 0.000 0.000 0.000 0.000
-0.005 -0.010 -0.006 -0.038 -0.192 -0.192 -0.038 -0.006 -0.010 -0.005
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0 0 0 0 0)))
- (snd-display #__line__ ";filter-channel lp: ~A ~A ~A" (channel->float-vector 0 10 ind 1) (channel->float-vector 10 10 ind 1) (channel->float-vector 20 10 ind 1)))
+ (snd-display ";filter-channel lp: ~A ~A ~A" (channel->float-vector 0 10 ind 1) (channel->float-vector 10 10 ind 1) (channel->float-vector 20 10 ind 1)))
(undo 1 ind 1)
(close-sound ind))
@@ -37201,15 +36542,15 @@ EDITS: 1
(set! (sample 10) 0.5)
(set! (sample 20) -0.5)
(scale-to 1.0)
- (if (fneq (sample 10) .999) (snd-display #__line__ ";scale-to 1.0 short (10): ~A" (sample 10)))
- (if (fneq (sample 20) -.999) (snd-display #__line__ ";scale-to 1.0 short (20): ~A" (sample 10)))
+ (if (fneq (sample 10) .999) (snd-display ";scale-to 1.0 short (10): ~A" (sample 10)))
+ (if (fneq (sample 20) -.999) (snd-display ";scale-to 1.0 short (20): ~A" (sample 10)))
(close-sound ind))
(let ((ind (new-sound "tmp.snd" 1 22050 mus-byte mus-next :size 100)))
(set! (sample 10) 0.5)
(set! (sample 20) -0.5)
(scale-to 1.0)
- (if (fneq (sample 10) .992) (snd-display #__line__ ";scale-to 1.0 byte (10): ~A" (sample 10)))
- (if (fneq (sample 20) -.992) (snd-display #__line__ ";scale-to 1.0 byte (20): ~A" (sample 10)))
+ (if (fneq (sample 10) .992) (snd-display ";scale-to 1.0 byte (10): ~A" (sample 10)))
+ (if (fneq (sample 20) -.992) (snd-display ";scale-to 1.0 byte (20): ~A" (sample 10)))
(close-sound ind))
(when with-gui
@@ -37241,50 +36582,48 @@ EDITS: 1
(old-default (func #f))
(old-1 (func ind-1))
(old-2 (func ind-2))
- (sel-snd (selected-sound))
- (unsel-snd (if (equal? sel-snd ind-1) ind-2 ind-1))
(caller (if channel "channel" "sound")))
(if (not (eq-func old-val old-default))
- (snd-display #__line__ ";~A sound-func: no arg: ~A, #f: ~A" name old-val old-default))
+ (snd-display ";~A sound-func: no arg: ~A, #f: ~A" name old-val old-default))
(if (not (or (leq-func old-vals (list old-1 old-2))
(leq-func old-vals (list old-2 old-1))))
- (snd-display #__line__ ";~A sound-func #t: ~A, sep: ~A" name old-vals (list old-1 old-2)))
- (if settable
- (begin
- (set! (func) new-val)
- (if (not (eq-func (func) new-val))
- (snd-display #__line__ ";~A set no arg: ~A ~A" name (func) new-val))
- (if (not (eq-func (func) (func sel-snd)))
- (snd-display #__line__ ";~A set no arg sel: ~A ~A" name (func) (func sel-snd)))
- (if (or (and global (not (eq-func (func) (func unsel-snd))))
- (and (not global) (eq-func (func) (func unsel-snd))))
- (snd-display #__line__ ";~A set no arg unsel: ~A ~A (sel: ~A)" name (func) (func unsel-snd) (func sel-snd)))
- (if (not (or (leq-func (func #t) (list (func sel-snd) (func unsel-snd)))
- (leq-func (func #t) (list (func unsel-snd) (func sel-snd)))))
- (snd-display #__line__ ";~A ~A-func #t set: ~A, sep: ~A" name caller (func #t) (list (func sel-snd) (func unsel-snd))))
- (set! (func) old-val)
- (set! (func ind-1) new-val)
- (if (not (eq-func (func ind-1) new-val))
- (snd-display #__line__ ";~A set arg: ~A ~A" name (func ind-1) new-val))
- (if (eq-func (func ind-2) new-val)
- (snd-display #__line__ ";~A set arg (2): ~A ~A" name (func ind-2) new-val))
- (if (not (or (leq-func (func #t) (list (func ind-1) (func ind-2)))
- (leq-func (func #t) (list (func ind-2) (func ind-1)))))
- (snd-display #__line__ ";~A ~A-func arg set: ~A, sep: ~A" name caller (func #t) (list (func ind-1) (func ind-2))))
- (set! (func ind-1) old-1)
- (set! (func #t) new-val)
- (if (not (leq-func (func #t) (list new-val new-val)))
- (snd-display #__line__ ";~A ~A-func arg set #t: ~A, sep: ~A" name caller (func #t) (list new-val new-val)))
- (if (not (eq-func (func ind-1) new-val))
- (snd-display #__line__ ";~A set arg #t: ~A ~A" name (func ind-1) new-val))
- (if (not (eq-func (func ind-2) new-val))
- (snd-display #__line__ ";~A set arg #t (2): ~A ~A" name (func ind-2) new-val))
- (set! (func ind-1) old-1)
- (set! (func ind-2) old-2)
- (if (not (eq-func (func ind-1) old-1))
- (snd-display #__line__ ";~A set arg #t old: ~A ~A" name (func ind-1) old-1))
- (if (not (eq-func (func ind-2) old-2))
- (snd-display #__line__ ";~A set arg #t (2): ~A ~A" name (func ind-2) old-2)))))))
+ (snd-display ";~A sound-func #t: ~A, sep: ~A" name old-vals (list old-1 old-2)))
+ (when settable
+ (let* ((sel-snd (selected-sound))
+ (unsel-snd (if (equal? sel-snd ind-1) ind-2 ind-1)))
+ (set! (func) new-val)
+ (if (not (eq-func (func) new-val))
+ (snd-display ";~A set no arg: ~A ~A" name (func) new-val))
+ (if (not (eq-func (func) (func sel-snd)))
+ (snd-display ";~A set no arg sel: ~A ~A" name (func) (func sel-snd)))
+ (if (not (eq? (not global) (not (eq-func (func) (func unsel-snd)))))
+ (snd-display ";~A set no arg unsel: ~A ~A (sel: ~A)" name (func) (func unsel-snd) (func sel-snd)))
+ (if (not (or (leq-func (func #t) (list (func sel-snd) (func unsel-snd)))
+ (leq-func (func #t) (list (func unsel-snd) (func sel-snd)))))
+ (snd-display ";~A ~A-func #t set: ~A, sep: ~A" name caller (func #t) (list (func sel-snd) (func unsel-snd)))))
+ (set! (func) old-val)
+ (set! (func ind-1) new-val)
+ (if (not (eq-func (func ind-1) new-val))
+ (snd-display ";~A set arg: ~A ~A" name (func ind-1) new-val))
+ (if (eq-func (func ind-2) new-val)
+ (snd-display ";~A set arg (2): ~A ~A" name (func ind-2) new-val))
+ (if (not (or (leq-func (func #t) (list (func ind-1) (func ind-2)))
+ (leq-func (func #t) (list (func ind-2) (func ind-1)))))
+ (snd-display ";~A ~A-func arg set: ~A, sep: ~A" name caller (func #t) (list (func ind-1) (func ind-2))))
+ (set! (func ind-1) old-1)
+ (set! (func #t) new-val)
+ (if (not (leq-func (func #t) (list new-val new-val)))
+ (snd-display ";~A ~A-func arg set #t: ~A, sep: ~A" name caller (func #t) (list new-val new-val)))
+ (if (not (eq-func (func ind-1) new-val))
+ (snd-display ";~A set arg #t: ~A ~A" name (func ind-1) new-val))
+ (if (not (eq-func (func ind-2) new-val))
+ (snd-display ";~A set arg #t (2): ~A ~A" name (func ind-2) new-val))
+ (set! (func ind-1) old-1)
+ (set! (func ind-2) old-2)
+ (if (not (eq-func (func ind-1) old-1))
+ (snd-display ";~A set arg #t old: ~A ~A" name (func ind-1) old-1))
+ (if (not (eq-func (func ind-2) old-2))
+ (snd-display ";~A set arg #t (2): ~A ~A" name (func ind-2) old-2))))))
(test-sound-func (lambda (func name ind-1 ind-2 new-val eq-func leq-func settable)
(test-sound-func-1 func name ind-1 ind-2 new-val eq-func leq-func settable #f #f))))
@@ -37307,12 +36646,12 @@ EDITS: 1
(list header-type 'header-type ind-1 ind-2 0 = equal? #f)
(reader-cond (with-gui
- (list amp-control 'amp-control ind-1 ind-2 .5 within-.01? feql #t)
- (list contrast-control 'contrast-control ind-1 ind-2 .5 within-.01? feql #t)
- (list expand-control 'expand-control ind-1 ind-2 .5 within-.01? ffeql #t)
- (list speed-control 'speed-control ind-1 ind-2 .5 within-.01? feql #t)
- (list reverb-control-length 'reverb-control-length ind-1 ind-2 .5 within-.01? feql #t)
- (list reverb-control-scale 'reverb-control-scale ind-1 ind-2 .5 within-.01? feql #t)
+ (list amp-control 'amp-control ind-1 ind-2 .5 very-close? feql #t)
+ (list contrast-control 'contrast-control ind-1 ind-2 .5 very-close? feql #t)
+ (list expand-control 'expand-control ind-1 ind-2 .5 very-close? ffeql #t)
+ (list speed-control 'speed-control ind-1 ind-2 .5 very-close? feql #t)
+ (list reverb-control-length 'reverb-control-length ind-1 ind-2 .5 very-close? feql #t)
+ (list reverb-control-scale 'reverb-control-scale ind-1 ind-2 .5 very-close? feql #t)
(list contrast-control? 'contrast-control? ind-1 ind-2 #t equal? equal? #t)
(list expand-control? 'expand-control? ind-1 ind-2 #t equal? equal? #t)
@@ -37328,7 +36667,7 @@ EDITS: 1
(restore-controls #t)
(reset-controls #t)
(close-sound #t)
- (if (not (null? (sounds))) (snd-display #__line__ ";sounds after close-sound #t: ~A" (sounds)))
+ (if (not (null? (sounds))) (snd-display ";sounds after close-sound #t: ~A" (sounds)))
;; snd chn cases
(letrec ((test-channel-func-1
@@ -37339,32 +36678,31 @@ EDITS: 1
(old-1-all (func ind-1 #t))
(old-2-all (func ind-2 #t))
(old-all-all (func #t #t)))
- (if (not (eq-func old-1-0 (car old-1-all))) (snd-display #__line__ ";~A channel-func old 1/#t: ~A ~A" name old-1-0 old-1-all))
- (if (not (eq-func old-2-0 (car old-2-all))) (snd-display #__line__ ";~A channel-func old 2/#t: ~A ~A" name old-2-0 old-2-all))
- (if (not (eq-func old-2-1 (cadr old-2-all))) (snd-display #__line__ ";~A channel-func old 2-2/#t: ~A ~A" name old-2-1 old-2-all))
- (if (not (leq-func old-1-all (list old-1-0))) (snd-display #__line__ ";~A channel-func #t list: ~A ~A" name old-1-all old-1-0))
+ (if (not (eq-func old-1-0 (car old-1-all))) (snd-display ";~A channel-func old 1/#t: ~A ~A" name old-1-0 old-1-all))
+ (if (not (eq-func old-2-0 (car old-2-all))) (snd-display ";~A channel-func old 2/#t: ~A ~A" name old-2-0 old-2-all))
+ (if (not (eq-func old-2-1 (cadr old-2-all))) (snd-display ";~A channel-func old 2-2/#t: ~A ~A" name old-2-1 old-2-all))
+ (if (not (leq-func old-1-all (list old-1-0))) (snd-display ";~A channel-func #t list: ~A ~A" name old-1-all old-1-0))
(if (not (leq-func old-2-all (list old-2-0 old-2-1)))
- (snd-display #__line__ ";~A channel-func (2) #t list: ~A ~A ~A" name old-2-all old-2-0 old-2-1))
+ (snd-display ";~A channel-func (2) #t list: ~A ~A ~A" name old-2-all old-2-0 old-2-1))
(if (not (and (or (leq-func (car old-all-all) old-1-all)
(leq-func (car old-all-all) old-2-all))
(or (leq-func (cadr old-all-all) old-1-all)
(leq-func (cadr old-all-all) old-2-all))))
- (snd-display #__line__ ";~A channel-func #t #t: ~A ~A ~A" name old-all-all old-1-all old-2-all))
- (if settable
- (begin
- (set! (func ind-1 0) new-val)
- (if (not (eq-func (func ind-1 0) new-val)) (snd-display #__line__ ";~A set channel-func: ~A ~A" name (func ind-1 0) new-val))
- (if (eq-func (func ind-2 0) new-val) (snd-display #__line__ ";~A set 2 channel-func: ~A ~A" name (func ind-2 0) new-val))
- (set! (func ind-1 0) old-1-0)
- (set! (func ind-2 1) new-val)
- (if (eq-func (func ind-1 0) new-val) (snd-display #__line__ ";~A set (2) channel-func: ~A ~A" name (func ind-1 0) new-val))
- (if (not (eq-func (func ind-2 1) new-val)) (snd-display #__line__ ";~A set (2) 2 channel-func: ~A ~A" name (func ind-2 0) new-val))
- (set! (func ind-2 0) new-val)
- (set! (func ind-2 #t) old-2-0)
- (if (not (eq-func (func ind-2 0) old-2-0)) (snd-display #__line__ ";~A set (#t 0) 2 channel-func: ~A ~A" name (func ind-2 0) old-2-0))
- (if (not (eq-func (func ind-2 1) old-2-0)) (snd-display #__line__ ";~A set (#t 1) 2 channel-func: ~A ~A" name (func ind-2 1) old-2-0))
- (set! (func ind-2 0) old-2-0)
- (set! (func ind-2 1) old-2-1)))
+ (snd-display ";~A channel-func #t #t: ~A ~A ~A" name old-all-all old-1-all old-2-all))
+ (when settable
+ (set! (func ind-1 0) new-val)
+ (if (not (eq-func (func ind-1 0) new-val)) (snd-display ";~A set channel-func: ~A ~A" name (func ind-1 0) new-val))
+ (if (eq-func (func ind-2 0) new-val) (snd-display ";~A set 2 channel-func: ~A ~A" name (func ind-2 0) new-val))
+ (set! (func ind-1 0) old-1-0)
+ (set! (func ind-2 1) new-val)
+ (if (eq-func (func ind-1 0) new-val) (snd-display ";~A set (2) channel-func: ~A ~A" name (func ind-1 0) new-val))
+ (if (not (eq-func (func ind-2 1) new-val)) (snd-display ";~A set (2) 2 channel-func: ~A ~A" name (func ind-2 0) new-val))
+ (set! (func ind-2 0) new-val)
+ (set! (func ind-2 #t) old-2-0)
+ (if (not (eq-func (func ind-2 0) old-2-0)) (snd-display ";~A set (#t 0) 2 channel-func: ~A ~A" name (func ind-2 0) old-2-0))
+ (if (not (eq-func (func ind-2 1) old-2-0)) (snd-display ";~A set (#t 1) 2 channel-func: ~A ~A" name (func ind-2 1) old-2-0))
+ (set! (func ind-2 0) old-2-0)
+ (set! (func ind-2 1) old-2-1))
)))
(test-channel-func
(lambda (func name ind-1 ind-2 new-val eq-func leq-func settable global)
@@ -37380,23 +36718,23 @@ EDITS: 1
(lambda (data)
(apply test-channel-func data))
(list
- (list min-dB 'min-dB ind-1 ind-2 -100.0 within-.01? feql #t #t)
+ (list min-dB 'min-dB ind-1 ind-2 -100.0 very-close? feql #t #t)
- (list x-position-slider 'x-position-slider ind-1 ind-2 .1 within-.01? feql #t #f)
- ;; (list y-position-slider 'y-position-slider ind-1 ind-2 0.5 within-.01? feql #t #f)
- (list x-zoom-slider 'x-zoom-slider ind-1 ind-2 0.2 within-.01? feql #t #f)
- (list y-zoom-slider 'y-zoom-slider ind-1 ind-2 0.2 within-.01? feql #t #f)
+ (list x-position-slider 'x-position-slider ind-1 ind-2 .1 very-close? feql #t #f)
+ ;; (list y-position-slider 'y-position-slider ind-1 ind-2 0.5 very-close? feql #t #f)
+ (list x-zoom-slider 'x-zoom-slider ind-1 ind-2 0.2 very-close? feql #t #f)
+ (list y-zoom-slider 'y-zoom-slider ind-1 ind-2 0.2 very-close? feql #t #f)
(list fft-window-alpha 'fft-window-alpha ind-1 ind-2 0.5 (lambda (a b) (< (abs (- a b)) .02)) feql #t #t)
(list fft-window-beta 'fft-window-beta ind-1 ind-2 0.5 (lambda (a b) (< (abs (- a b)) .02)) feql #t #t)
- (list spectrum-end 'spectrum-end ind-1 ind-2 0.2 within-.01? feql #t #t)
- (list spectrum-start 'spectrum-start ind-1 ind-2 0.1 within-.01? feql #t #t)
- (list spectro-x-angle 'spectro-x-angle ind-1 ind-2 10.0 within-.01? feql #t #t)
- (list spectro-x-scale 'spectro-x-scale ind-1 ind-2 0.2 within-.01? feql #t #t)
- (list spectro-y-angle 'spectro-y-angle ind-1 ind-2 10.0 within-.01? feql #t #t)
- (list spectro-y-scale 'spectro-y-scale ind-1 ind-2 0.1 within-.01? feql #t #t)
- (list spectro-z-angle 'spectro-z-angle ind-1 ind-2 10.0 within-.01? feql #t #t)
- (list spectro-z-scale 'spectro-z-scale ind-1 ind-2 0.3 within-.01? feql #t #t)
- (list beats-per-minute 'beats-per-minute ind-1 ind-2 100.0 within-.01? feql #t #t)
+ (list spectrum-end 'spectrum-end ind-1 ind-2 0.2 very-close? feql #t #t)
+ (list spectrum-start 'spectrum-start ind-1 ind-2 0.1 very-close? feql #t #t)
+ (list spectro-x-angle 'spectro-x-angle ind-1 ind-2 10.0 very-close? feql #t #t)
+ (list spectro-x-scale 'spectro-x-scale ind-1 ind-2 0.2 very-close? feql #t #t)
+ (list spectro-y-angle 'spectro-y-angle ind-1 ind-2 10.0 very-close? feql #t #t)
+ (list spectro-y-scale 'spectro-y-scale ind-1 ind-2 0.1 very-close? feql #t #t)
+ (list spectro-z-angle 'spectro-z-angle ind-1 ind-2 10.0 very-close? feql #t #t)
+ (list spectro-z-scale 'spectro-z-scale ind-1 ind-2 0.3 very-close? feql #t #t)
+ (list beats-per-minute 'beats-per-minute ind-1 ind-2 100.0 very-close? feql #t #t)
(list dot-size 'dot-size ind-1 ind-2 10 = equal? #t #t)
(list x-axis-style 'x-axis-style ind-1 ind-2 1 = equal? #t #t)
@@ -37410,7 +36748,7 @@ EDITS: 1
(list squelch-update 'squelch-update ind-1 ind-2 #t equal? equal? #t #f)
(list show-y-zero 'show-y-zero ind-1 ind-2 #t equal? equal? #t #t)
(list show-grid 'show-grid ind-1 ind-2 #t equal? equal? #t #t)
- (list grid-density 'grid-density ind-1 ind-2 0.5 within-.01? feql #t #t)
+ (list grid-density 'grid-density ind-1 ind-2 0.5 very-close? feql #t #t)
(list show-sonogram-cursor 'show-sonogram-cursor ind-1 ind-2 #t equal? equal? #t #t)
(list show-marks 'show-marks ind-1 ind-2 #f equal? equal? #t #t)
(list show-transform-peaks 'show-transform-peaks ind-1 ind-2 #t equal? equal? #t #t)
@@ -37443,54 +36781,55 @@ EDITS: 1
(close-sound #f)
(close-sound #f)
- (if (not (null? (sounds))) (snd-display #__line__ ";sounds after close-sound #t: ~A" (sounds)))))
-
- (letrec ((test-sound-func-2
- (lambda (func name ind-1 ind-2 new-val eq-func leq-func)
- (let* ((old-global-val (func))
- (old-vals (func #t))
- (old-1 (func ind-1))
- (old-2 (func ind-2))
- (sel-snd (selected-sound))
- (unsel-snd (if (equal? sel-snd ind-1) ind-2 ind-1)))
- (if (not (or (leq-func old-vals (list old-1 old-2))
- (leq-func old-vals (list old-2 old-1))))
- (snd-display #__line__ ";~A sound-func #t: ~A, sep: ~A" name old-vals (list old-1 old-2)))
- (set! (func) new-val)
- (if (not (eq-func (func) new-val))
- (snd-display #__line__ ";~A global set no arg: ~A ~A" name (func) new-val))
- (if (not (eq-func (func) (func sel-snd)))
- (snd-display #__line__ ";~A global set no arg sel: ~A ~A" name (func) (func sel-snd)))
- (if (not (eq-func (func) (func unsel-snd)))
- (snd-display #__line__ ";~A set global no arg unsel: ~A ~A (sel: ~A)" name (func) (func unsel-snd) (func sel-snd)))
- (if (not (or (leq-func (func #t) (list (func sel-snd) (func unsel-snd)))
- (leq-func (func #t) (list (func unsel-snd) (func sel-snd)))))
- (snd-display #__line__ ";~A func #t set: ~A, sep: ~A" name (func #t) (list (func sel-snd) (func unsel-snd))))
- (set! (func) old-global-val)
- (set! (func ind-1) new-val)
- (if (not (eq-func (func ind-1) new-val))
- (snd-display #__line__ ";~A set arg: ~A ~A" name (func ind-1) new-val))
- (if (eq-func (func ind-2) new-val)
- (snd-display #__line__ ";~A set arg (2): ~A ~A" name (func ind-2) new-val))
- (if (not (or (leq-func (func #t) (list (func ind-1) (func ind-2)))
- (leq-func (func #t) (list (func ind-2) (func ind-1)))))
- (snd-display #__line__ ";~A func arg set: ~A, sep: ~A" name (func #t) (list (func ind-1) (func ind-2))))
- (set! (func ind-1) old-1)
- (set! (func #t) new-val)
- (if (not (leq-func (func #t) (list new-val new-val)))
- (snd-display #__line__ ";~A func arg set #t: ~A, sep: ~A" name (func #t) (list new-val new-val)))
- (if (not (eq-func (func ind-1) new-val))
- (snd-display #__line__ ";~A set arg #t: ~A ~A" name (func ind-1) new-val))
- (if (not (eq-func (func ind-2) new-val))
- (snd-display #__line__ ";~A set arg #t (2): ~A ~A" name (func ind-2) new-val))
- (if (eq-func (func) new-val)
- (snd-display #__line__ ";~A overwrote global: ~A ~A" name (func) new-val))
- (set! (func ind-1) old-1)
- (set! (func ind-2) old-2)
- (if (not (eq-func (func ind-1) old-1))
- (snd-display #__line__ ";~A set arg #t old: ~A ~A" name (func ind-1) old-1))
- (if (not (eq-func (func ind-2) old-2))
- (snd-display #__line__ ";~A set arg #t (2): ~A ~A" name (func ind-2) old-2))))))
+ (if (not (null? (sounds))) (snd-display ";sounds after close-sound #t: ~A" (sounds)))))
+
+ (let ((test-sound-func-2
+ (lambda (func name ind-1 ind-2 new-val eq-func leq-func)
+ (let* ((old-global-val (func))
+ (old-vals (func #t))
+ (old-1 (func ind-1))
+ (old-2 (func ind-2)))
+ (let* ((sel-snd (selected-sound))
+ (unsel-snd (if (equal? sel-snd ind-1) ind-2 ind-1)))
+ (if (not (or (leq-func old-vals (list old-1 old-2))
+ (leq-func old-vals (list old-2 old-1))))
+ (snd-display ";~A sound-func #t: ~A, sep: ~A" name old-vals (list old-1 old-2)))
+ (set! (func) new-val)
+ (if (not (eq-func (func) new-val))
+ (snd-display ";~A global set no arg: ~A ~A" name (func) new-val))
+ (if (not (eq-func (func) (func sel-snd)))
+ (snd-display ";~A global set no arg sel: ~A ~A" name (func) (func sel-snd)))
+ (if (not (eq-func (func) (func unsel-snd)))
+ (snd-display ";~A set global no arg unsel: ~A ~A (sel: ~A)" name (func) (func unsel-snd) (func sel-snd)))
+ (if (not (or (leq-func (func #t) (list (func sel-snd) (func unsel-snd)))
+ (leq-func (func #t) (list (func unsel-snd) (func sel-snd)))))
+ (snd-display ";~A func #t set: ~A, sep: ~A" name (func #t) (list (func sel-snd) (func unsel-snd)))))
+
+ (set! (func) old-global-val)
+ (set! (func ind-1) new-val)
+ (if (not (eq-func (func ind-1) new-val))
+ (snd-display ";~A set arg: ~A ~A" name (func ind-1) new-val))
+ (if (eq-func (func ind-2) new-val)
+ (snd-display ";~A set arg (2): ~A ~A" name (func ind-2) new-val))
+ (if (not (or (leq-func (func #t) (list (func ind-1) (func ind-2)))
+ (leq-func (func #t) (list (func ind-2) (func ind-1)))))
+ (snd-display ";~A func arg set: ~A, sep: ~A" name (func #t) (list (func ind-1) (func ind-2))))
+ (set! (func ind-1) old-1)
+ (set! (func #t) new-val)
+ (if (not (leq-func (func #t) (list new-val new-val)))
+ (snd-display ";~A func arg set #t: ~A, sep: ~A" name (func #t) (list new-val new-val)))
+ (if (not (eq-func (func ind-1) new-val))
+ (snd-display ";~A set arg #t: ~A ~A" name (func ind-1) new-val))
+ (if (not (eq-func (func ind-2) new-val))
+ (snd-display ";~A set arg #t (2): ~A ~A" name (func ind-2) new-val))
+ (if (eq-func (func) new-val)
+ (snd-display ";~A overwrote global: ~A ~A" name (func) new-val))
+ (set! (func ind-1) old-1)
+ (set! (func ind-2) old-2)
+ (if (not (eq-func (func ind-1) old-1))
+ (snd-display ";~A set arg #t old: ~A ~A" name (func ind-1) old-1))
+ (if (not (eq-func (func ind-2) old-2))
+ (snd-display ";~A set arg #t (2): ~A ~A" name (func ind-2) old-2))))))
(let ((ind-1 (new-sound "test-1.snd" 1 22050 mus-ldouble mus-next "mono testing" 100))
(ind-2 (new-sound "test-2.snd" 2 44100 mus-bshort mus-aifc "stereo testing" 300)))
@@ -37507,14 +36846,14 @@ EDITS: 1
(list speed-control-style 'speed-control-style ind-1 ind-2 speed-control-as-semitone = equal?)
(list filter-control-order 'filter-control-order ind-1 ind-2 14 = equal?)
- (list expand-control-length 'expand-control-length ind-1 ind-2 .25 within-.01? feql)
- (list expand-control-ramp 'expand-control-ramp ind-1 ind-2 .25 within-.01? feql)
- (list expand-control-hop 'expand-control-hop ind-1 ind-2 .25 within-.01? feql)
- (list expand-control-jitter 'expand-control-jitter ind-1 ind-2 .25 within-.01? feql)
- (list contrast-control-amp 'contrast-control-amp ind-1 ind-2 .25 within-.01? feql)
- (list reverb-control-feedback 'reverb-control-feedback ind-1 ind-2 .25 within-.01? feql)
- (list reverb-control-lowpass 'reverb-control-lowpass ind-1 ind-2 .25 within-.01? feql)
- (list reverb-control-decay 'reverb-control-decay ind-1 ind-2 .25 within-.01? feql)
+ (list expand-control-length 'expand-control-length ind-1 ind-2 .25 very-close? feql)
+ (list expand-control-ramp 'expand-control-ramp ind-1 ind-2 .25 very-close? feql)
+ (list expand-control-hop 'expand-control-hop ind-1 ind-2 .25 very-close? feql)
+ (list expand-control-jitter 'expand-control-jitter ind-1 ind-2 .25 very-close? feql)
+ (list contrast-control-amp 'contrast-control-amp ind-1 ind-2 .25 very-close? feql)
+ (list reverb-control-feedback 'reverb-control-feedback ind-1 ind-2 .25 very-close? feql)
+ (list reverb-control-lowpass 'reverb-control-lowpass ind-1 ind-2 .25 very-close? feql)
+ (list reverb-control-decay 'reverb-control-decay ind-1 ind-2 .25 very-close? feql)
(list amp-control-bounds 'amp-control-bounds ind-1 ind-2 (list 0.0 2.0) feql
(lambda (a b) (and (feql (car a) (car b)) (feql (cadr a) (cadr b)))))
@@ -37538,24 +36877,24 @@ EDITS: 1
(set! (show-y-zero ind 0) #t)
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
- (if (or (not (transform-graph? ind 0))
- (not (show-transform-peaks ind 0))
- (not (show-y-zero ind 0)))
- (snd-display #__line__ ";remember-sound-state: ~A ~A ~A" (transform-graph? ind 0) (show-transform-peaks ind 0) (show-y-zero ind 0)))
+ (if (not (and (transform-graph? ind 0)
+ (show-transform-peaks ind 0)
+ (show-y-zero ind 0)))
+ (snd-display ";remember-sound-state: ~A ~A ~A" (transform-graph? ind 0) (show-transform-peaks ind 0) (show-y-zero ind 0)))
(close-sound ind))
(reset-all-hooks)
(set! *remember-sound-state* #f)
(if (file-exists? "remembered-oboe.snd.scm")
(delete-file "remembered-oboe.snd.scm"))
- (map-sound-files (lambda (n) (if (> (mus-sound-duration n) 1000.0) (snd-display #__line__ ";~A is pretty long! ~A" n (mus-sound-duration n)))))
+ (map-sound-files (lambda (n) (if (> (mus-sound-duration n) 1000.0) (snd-display ";~A is pretty long! ~A" n (mus-sound-duration n)))))
(if (string? sf-dir)
(map-sound-files
(lambda (n)
(catch #t
(lambda ()
(if (> (mus-sound-duration (string-append sf-dir n)) 1000.0)
- (snd-display #__line__ ";~A is pretty long! ~A"
+ (snd-display ";~A is pretty long! ~A"
n
(mus-sound-duration (string-append sf-dir n)))))
(lambda args #f))
@@ -37568,77 +36907,77 @@ EDITS: 1
(env-channel-with-base '(0 0 1 1) 1.0)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 0.0 0.05 0.10 0.15 0.20 0.25 0.30 0.35 0.40 0.45 0.50 0.55 0.60 0.65 0.70 0.75 0.80 0.85 0.90 0.95)))
- (snd-display #__line__ ";env-chan 1.0: ~A" data)))
+ (snd-display ";env-chan 1.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1 2 1 3 0) 0.0)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";env-chan 0.0: ~A" data)))
+ (snd-display ";env-chan 0.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 100.0)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 0.0 0.003 0.006 0.010 0.015 0.022 0.030 0.041 0.054 0.070 0.091 0.117 0.150 0.191 0.244 0.309 0.392 0.496 0.627 0.792)))
- (snd-display #__line__ ";env-chan 100.0: ~A" data)))
+ (snd-display ";env-chan 100.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 0.01)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 0.0 0.208 0.373 0.504 0.608 0.691 0.756 0.809 0.850 0.883 0.909 0.930 0.946 0.959 0.970 0.978 0.985 0.990 0.994 0.997)))
- (snd-display #__line__ ";env-chan 0.01: ~A" data)))
+ (snd-display ";env-chan 0.01: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 1.0 5 10)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.0 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";env-chan 1.0 seg: ~A" data)))
+ (snd-display ";env-chan 1.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1 2 1 3 0) 0.0 5 10)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";env-chan 0.0 seg: ~A" data)))
+ (snd-display ";env-chan 0.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 100.0 5 10)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.007 0.018 0.037 0.068 0.120 0.208 0.353 0.595 1.0 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";env-chan 100.0 seg: ~A" data)))
+ (snd-display ";env-chan 100.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 0.01 5 10)
(let ((data (channel->float-vector 0 20)))
(if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.405 0.647 0.792 0.880 0.932 0.963 0.982 0.993 1.0 1.0 1.0 1.0 1.0 1.0)))
- (snd-display #__line__ ";env-chan 0.01 seg: ~A" data)))
+ (snd-display ";env-chan 0.01 seg: ~A" data)))
(undo)
(close-sound snd))
(let ((ind1 (open-sound "now.snd"))
(ind2 (open-sound "oboe.snd")))
(let ((val (channel-mean ind1 0)))
- (if (fneq val 5.02560673308833e-5) (snd-display #__line__ ";channel-mean: ~A" val)))
+ (if (fneq val 5.02560673308833e-5) (snd-display ";channel-mean: ~A" val)))
(let ((val (channel-total-energy ind1 0)))
- (if (fneq val 50.7153476262465) (snd-display #__line__ ";channel-total-energy: ~A" val)))
+ (if (fneq val 50.7153476262465) (snd-display ";channel-total-energy: ~A" val)))
(let ((val (channel-average-power ind1 0)))
- (if (fneq val 0.00155078578803922) (snd-display #__line__ ";channel-average-power: ~A" val)))
+ (if (fneq val 0.00155078578803922) (snd-display ";channel-average-power: ~A" val)))
(let ((val (channel-rms ind1 0)))
- (if (fneq val 0.039380017623653) (snd-display #__line__ ";channel-rms: ~A" val)))
+ (if (fneq val 0.039380017623653) (snd-display ";channel-rms: ~A" val)))
(let ((val (channel-norm ind1 0)))
- (if (fneq val 7.12147088923675) (snd-display #__line__ ";channel-norm: ~A" val)))
+ (if (fneq val 7.12147088923675) (snd-display ";channel-norm: ~A" val)))
(let ((val (channel-variance ind1 0)))
- (if (fneq val 50.7153476237207) (snd-display #__line__ ";channel-variance: ~A" val)))
+ (if (fneq val 50.7153476237207) (snd-display ";channel-variance: ~A" val)))
(let ((val (channel-lp 2 ind1 0)))
- (if (fneq val 7.12147088923675) (snd-display #__line__ ";channel-lp 2: ~A" val)))
+ (if (fneq val 7.12147088923675) (snd-display ";channel-lp 2: ~A" val)))
(let ((val (channel-lp 1 ind1 0)))
- (if (fneq val 775.966033935547) (snd-display #__line__ ";channel-lp 1: ~A" val)))
+ (if (fneq val 775.966033935547) (snd-display ";channel-lp 1: ~A" val)))
(let ((val (channel2-inner-product ind1 0 ind2 0)))
- (if (fneq val 1.52892031334341) (snd-display #__line__ ";channel2-inner-product: ~A" val)))
+ (if (fneq val 1.52892031334341) (snd-display ";channel2-inner-product: ~A" val)))
(let ((val (channel2-angle ind1 0 ind2 0)))
- (if (fneq val 1.55485084385627) (snd-display #__line__ ";channel2-angle: ~A" val)))
+ (if (fneq val 1.55485084385627) (snd-display ";channel2-angle: ~A" val)))
(let ((val (channel2-orthogonal? ind1 0 ind2 0)))
- (if val (snd-display #__line__ ";channel2-orthogonal: ~A" val)))
+ (if val (snd-display ";channel2-orthogonal: ~A" val)))
(let ((val (channel2-coefficient-of-projection ind1 0 ind2 0)))
- (if (fneq val 0.0301470932351876) (snd-display #__line__ ";channel2-coefficient-of-projection: ~A" val)))
+ (if (fneq val 0.0301470932351876) (snd-display ";channel2-coefficient-of-projection: ~A" val)))
(close-sound ind1)
(set! ind1 (open-sound "oboe.snd"))
(scale-by .99 ind1 0)
(let ((dist (channel-distance ind1 0 ind2 0)))
- (if (fneq dist .1346) (snd-display #__line__ ";channel-distance: ~A" dist)))
+ (if (fneq dist .1346) (snd-display ";channel-distance: ~A" dist)))
(close-sound ind1)
(close-sound ind2))
@@ -37652,10 +36991,10 @@ EDITS: 1
(chns (chans ind))
(sr (srate ind))
(fr (framples ind 0)))
- (if (or (not (= (chans ind) (mus-sound-chans loboe)))
- (not (= (srate ind) (mus-sound-srate loboe)))
- (not (= (framples ind) (mus-sound-framples loboe))))
- (snd-display #__line__ ";copy oboe -> test seems to have failed? ~A ~A ~A"
+ (if (not (and (= (chans ind) (mus-sound-chans loboe))
+ (= (srate ind) (mus-sound-srate loboe))
+ (= (framples ind) (mus-sound-framples loboe))))
+ (snd-display ";copy oboe -> test seems to have failed? ~A ~A ~A"
(chans ind) (srate ind) (framples ind))
(with-local-hook
update-hook
@@ -37667,35 +37006,35 @@ EDITS: 1
((= i 10))
(let ((v (channel->float-vector)))
(if (not (float-vector? v))
- (snd-display #__line__ ";channel->float-vector of oboe copy is null??")
- (array->file ltest v fr sr chns))
- (update-sound ind)
- (let ((mx1 (maxamp ind 0)))
- (if (fneq mx mx1)
- (snd-display #__line__ ";update-sound looped maxamp: ~A ~A ~A ~A ~A (~A)" i ind (framples ind) mx1 mx (/ mx1 mx))))
- (if (not (= (chans ind) chns)) (snd-display #__line__ ";update-sound looped chans: ~A ~A" chns (chans ind)))
- (if (not (= (srate ind) sr)) (snd-display #__line__ ";update-sound looped srate: ~A ~A" sr (srate ind)))
- (if (not (= (framples ind) fr)) (snd-display #__line__ ";update-sound looped framples: ~A ~A" fr (framples ind 0)))))
+ (snd-display ";channel->float-vector of oboe copy is null??")
+ (array->file ltest v fr sr chns)))
+ (update-sound ind)
+ (let ((mx1 (maxamp ind 0)))
+ (if (fneq mx mx1)
+ (snd-display ";update-sound looped maxamp: ~A ~A ~A ~A ~A (~A)" i ind (framples ind) mx1 mx (/ mx1 mx))))
+ (if (not (= (chans ind) chns)) (snd-display ";update-sound looped chans: ~A ~A" chns (chans ind)))
+ (if (not (= (srate ind) sr)) (snd-display ";update-sound looped srate: ~A ~A" sr (srate ind)))
+ (if (not (= (framples ind) fr)) (snd-display ";update-sound looped framples: ~A ~A" fr (framples ind 0))))
(let ((old-ind (open-sound "oboe.snd")))
(let ((mxdiff (float-vector-peak (float-vector-subtract! (channel->float-vector 0 #f ind 0 0) (channel->float-vector 0 #f old-ind 0)))))
(if (fneq mxdiff 0.0)
- (snd-display #__line__ ";update-sound looped overall max diff: ~A, sounds: ~A, ind: ~A, old-ind: ~A, rd: ~A"
+ (snd-display ";update-sound looped overall max diff: ~A, sounds: ~A, ind: ~A, old-ind: ~A, rd: ~A"
mxdiff (sounds) ind old-ind home)))
(close-sound old-ind)))))
(close-sound ind)))
(if (file-exists? "test.snd") (delete-file "test.snd"))
- (let* ((ind (open-sound "oboe.snd"))
- (data (channel->float-vector))
- (len (framples ind)))
- (do ((i 0 (+ i 1)))
- ((= i 5))
- (array->file "test.snd" data len 22050 1)
- (file->array "test.snd" 0 0 len data)
- (let ((d2 (samples 0 len ind 0)))
- (float-vector-subtract! d2 data)
- (let ((diff (float-vector-peak d2)))
- (if (fneq diff 0.0) (snd-display #__line__ ";arr->file->array overall max diff: ~A" diff)))))
+ (let ((ind (open-sound "oboe.snd")))
+ (let ((data (channel->float-vector))
+ (len (framples ind)))
+ (do ((i 0 (+ i 1)))
+ ((= i 5))
+ (array->file "test.snd" data len 22050 1)
+ (file->array "test.snd" 0 0 len data)
+ (let ((d2 (samples 0 len ind 0)))
+ (float-vector-subtract! d2 data)
+ (let ((diff (float-vector-peak d2)))
+ (if (fneq diff 0.0) (snd-display ";arr->file->array overall max diff: ~A" diff))))))
;; now clear sono bins if possible
(set! *colormap-size* 16)
@@ -37709,10 +37048,10 @@ EDITS: 1
(set! *zoom-focus-style* (lambda (s c z x0 x1 range)
0))
(if (not (procedure? *zoom-focus-style*))
- (snd-display #__line__ ";zoom-focus-style as func: ~A" *zoom-focus-style*))
+ (snd-display ";zoom-focus-style as func: ~A" *zoom-focus-style*))
(set! *zoom-focus-style* zoom-focus-right)
(if (not (= *zoom-focus-style* zoom-focus-right))
- (snd-display #__line__ ";unset zoom-focus-style as func: ~A" *zoom-focus-style*))
+ (snd-display ";unset zoom-focus-style as func: ~A" *zoom-focus-style*))
(close-sound ind))
(if (file-exists? "test.snd") (delete-file "test.snd"))
@@ -37745,7 +37084,7 @@ EDITS: 1
(set! ctr (+ ctr 1))
;; if this happens it is almost certainly a problem with mus-sound-forget above
#f))
- (if (fneq diff 0.0) (snd-display #__line__ ";file->sample->file overall max diff: ~A" diff))
+ (if (fneq diff 0.0) (snd-display ";file->sample->file overall max diff: ~A" diff))
(close-sound ind1)))
(let ((ind (open-sound "1a.snd"))
@@ -37758,7 +37097,7 @@ EDITS: 1
(if (and (fneq (/ (maxamp) mx) 2.0)
(not (eq? name 'set-samples))
(not (eq? name 'coroutines)))
- (snd-display #__line__ ";silly scalers: ~A ~A" name (/ (maxamp) mx)))
+ (snd-display ";silly scalers: ~A ~A" name (/ (maxamp) mx)))
(revert-sound)))
(list
(list 'scale-by (lambda () (scale-by 2.0)))
@@ -37789,10 +37128,7 @@ EDITS: 1
(fsize (expt 2 (ceiling (log len 2))))
(rl (channel->float-vector 0 fsize))
(im (make-float-vector fsize)))
- (mus-fft rl im fsize)
- (mus-fft rl im fsize)
- (mus-fft rl im fsize)
- (mus-fft rl im fsize)
+ (do ((i 0 (+ i 1))) ((= i 4)) (mus-fft rl im fsize))
(float-vector->channel (float-vector-scale! rl (/ 2.0 (* fsize fsize))) 0 len))))
(list 'set-samples (lambda () ; too slow for some reason, so cut it short at 100
(set! (squelch-update) #t)
@@ -37818,47 +37154,47 @@ EDITS: 1
))
(close-sound ind))
- (let ((ind1 (open-sound "1a.snd"))
- (data1 (file->floats "1a.snd"))
- (ind2 (open-sound "2a.snd"))
+ (let ((data1 (file->floats "1a.snd"))
(data2 (file->floats "2a.snd")))
- (if (not (equal? data1 (channel->float-vector 0 #f ind1 0)))
- (snd-display #__line__ ";file->floats 1a.snd"))
- (if (not (equal? data2 (channel->float-vector 0 #f ind2 0)))
- (snd-display #__line__ ";file->floats 2a.snd"))
+ (let ((ind1 (open-sound "1a.snd")))
+ (if (not (equal? data1 (channel->float-vector 0 #f ind1 0)))
+ (snd-display ";file->floats 1a.snd")))
+ (let ((ind2 (open-sound "2a.snd")))
+ (if (not (equal? data2 (channel->float-vector 0 #f ind2 0)))
+ (snd-display ";file->floats 2a.snd")))
(floats->file data1 "tmp.snd")
(let ((ind3 (open-sound "tmp.snd")))
(if (not (equal? data1 (channel->float-vector 0 #f ind3 0)))
- (snd-display #__line__ ";floats->file 1a"))
+ (snd-display ";floats->file 1a"))
(close-sound ind3))
(mus-sound-forget "tmp.snd")
- (floats->file data2 "tmp.snd" 44100 "this is a comment")
- (let ((ind3 (open-sound "tmp.snd")))
- (if (not (= (srate ind3) 44100))
- (snd-display #__line__ ";floats->file srate: ~A" (srate ind3)))
- (close-sound ind3))
- (mus-sound-forget "tmp.snd")
- (let ((tag (catch #t (lambda () (floats->file 32 "tmp.snd")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";floats->file bad arg: ~A" tag))))
+ (floats->file data2 "tmp.snd" 44100 "this is a comment"))
+ (let ((ind3 (open-sound "tmp.snd")))
+ (if (not (= (srate ind3) 44100))
+ (snd-display ";floats->file srate: ~A" (srate ind3)))
+ (close-sound ind3))
+ (mus-sound-forget "tmp.snd")
+ (let ((tag (catch #t (lambda () (floats->file 32 "tmp.snd")) (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";floats->file bad arg: ~A" tag)))
(for-each close-sound (sounds))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "insert-* tests" 10)))
(map-channel (lambda (y) 1.0) 0 10 ind 0)
(insert-float-vector (make-float-vector 5 .1) 2)
- (if (not (= (framples ind) 15)) (snd-display #__line__ ";insert-float-vector len: ~A" (framples ind)))
+ (if (not (= (framples ind) 15)) (snd-display ";insert-float-vector len: ~A" (framples ind)))
(let ((vals (channel->float-vector 0 #f ind 0)))
(if (not (vequal vals (float-vector 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";insert-float-vector vals: ~A" vals)))
+ (snd-display ";insert-float-vector vals: ~A" vals)))
(let ((tag (catch #t (lambda () (insert-float-vector 32)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";insert-float-vector bad arg: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";insert-float-vector bad arg: ~A" tag)))
(insert-float-vector (make-float-vector 1 1.5) 0 1 ind 0)
- (if (not (= (framples ind) 16)) (snd-display #__line__ ";insert-float-vector 1 len: ~A" (framples ind)))
+ (if (not (= (framples ind) 16)) (snd-display ";insert-float-vector 1 len: ~A" (framples ind)))
(let ((vals (channel->float-vector 0 #f ind 0)))
(if (not (vequal vals (float-vector 1.5 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
- (snd-display #__line__ ";insert-float-vector 1 vals: ~A" vals)))
+ (snd-display ";insert-float-vector 1 vals: ~A" vals)))
(close-sound ind))
(let ((ind (new-sound "test.snd" 4 22050 mus-ldouble mus-next "insert-* tests" 5)))
@@ -37868,29 +37204,29 @@ EDITS: 1
(map-channel (lambda (y) 0.7) 0 5 ind 3)
(insert-float-vector (make-float-vector 20 .1) 2 2 ind 2)
- (if (not (= (framples ind 0) 5)) (snd-display #__line__ ";4chn insert-float-vector (0) len: ~A" (framples ind 0)))
- (if (not (= (framples ind 2) 7)) (snd-display #__line__ ";4chn insert-float-vector (2) len: ~A" (framples ind 2)))
+ (if (not (= (framples ind 0) 5)) (snd-display ";4chn insert-float-vector (0) len: ~A" (framples ind 0)))
+ (if (not (= (framples ind 2) 7)) (snd-display ";4chn insert-float-vector (2) len: ~A" (framples ind 2)))
(if (not (vequal (channel->float-vector 0 7 ind 0) (float-vector .4 .4 .4 .4 .4 0 0)))
- (snd-display #__line__ ";4chn insert-float-vector 0: ~A" (channel->float-vector 0 7 ind 0)))
+ (snd-display ";4chn insert-float-vector 0: ~A" (channel->float-vector 0 7 ind 0)))
(if (not (vequal (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
- (snd-display #__line__ ";4chn insert-float-vector 1: ~A" (channel->float-vector 0 7 ind 1)))
+ (snd-display ";4chn insert-float-vector 1: ~A" (channel->float-vector 0 7 ind 1)))
(if (not (vequal (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
- (snd-display #__line__ ";4chn insert-float-vector 2: ~A" (channel->float-vector 0 7 ind 2)))
+ (snd-display ";4chn insert-float-vector 2: ~A" (channel->float-vector 0 7 ind 2)))
(if (not (vequal (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
- (snd-display #__line__ ";4chn insert-float-vector 3: ~A" (channel->float-vector 0 7 ind 3)))
+ (snd-display ";4chn insert-float-vector 3: ~A" (channel->float-vector 0 7 ind 3)))
(insert-float-vector (make-float-vector 20 .2) 0 2 ind 0)
- (if (not (= (framples ind 0) 7)) (snd-display #__line__ ";4chn insert-float-vector (0 0) len: ~A" (framples ind 0)))
- (if (not (= (framples ind 1) 5)) (snd-display #__line__ ";4chn insert-float-vector (0 1) len: ~A" (framples ind 1)))
- (if (not (= (framples ind 2) 7)) (snd-display #__line__ ";4chn insert-float-vector (2 2) len: ~A" (framples ind 2)))
+ (if (not (= (framples ind 0) 7)) (snd-display ";4chn insert-float-vector (0 0) len: ~A" (framples ind 0)))
+ (if (not (= (framples ind 1) 5)) (snd-display ";4chn insert-float-vector (0 1) len: ~A" (framples ind 1)))
+ (if (not (= (framples ind 2) 7)) (snd-display ";4chn insert-float-vector (2 2) len: ~A" (framples ind 2)))
(if (not (vequal (channel->float-vector 0 7 ind 0) (float-vector .2 .2 .4 .4 .4 .4 .4)))
- (snd-display #__line__ ";4chn insert-float-vector 1 0: ~A" (channel->float-vector 0 7 ind 0)))
+ (snd-display ";4chn insert-float-vector 1 0: ~A" (channel->float-vector 0 7 ind 0)))
(if (not (vequal (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
- (snd-display #__line__ ";4chn insert-float-vector 1 1: ~A" (channel->float-vector 0 7 ind 1)))
+ (snd-display ";4chn insert-float-vector 1 1: ~A" (channel->float-vector 0 7 ind 1)))
(if (not (vequal (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
- (snd-display #__line__ ";4chn insert-float-vector 1 2: ~A" (channel->float-vector 0 7 ind 2)))
+ (snd-display ";4chn insert-float-vector 1 2: ~A" (channel->float-vector 0 7 ind 2)))
(if (not (vequal (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
- (snd-display #__line__ ";4chn insert-float-vector 1 3: ~A" (channel->float-vector 0 7 ind 3)))
+ (snd-display ";4chn insert-float-vector 1 3: ~A" (channel->float-vector 0 7 ind 3)))
(revert-sound ind)
(map-channel (lambda (y) 0.4) 0 5 ind 0)
@@ -37923,22 +37259,22 @@ EDITS: 1
;; check 0 cases
(let ((ind (open-sound "oboe.snd")))
(scale-by 0.0)
- (if (fneq (maxamp) 0.0) (snd-display #__line__ ";scale-by 0 amp: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.0) (snd-display ";scale-by 0 amp: ~A" (maxamp)))
(scale-by 3.0)
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";scale-by over 0: ~A" (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";scale-by over 0: ~A" (edit-position)))
(scale-to 1.0)
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";scale-to 1.0 over 0: ~A" (edit-position)))
- (if (fneq (maxamp) 0.0) (snd-display #__line__ ";scale-to 1.0 over 0 amp: ~A" (maxamp)))
+ (if (not (= (edit-position) 1)) (snd-display ";scale-to 1.0 over 0: ~A" (edit-position)))
+ (if (fneq (maxamp) 0.0) (snd-display ";scale-to 1.0 over 0 amp: ~A" (maxamp)))
(ramp-channel 0 1)
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";ramp over 0: ~A" (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";ramp over 0: ~A" (edit-position)))
(env-channel '(0 0 1 1 2 0))
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";ramp over 0: ~A" (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";ramp over 0: ~A" (edit-position)))
(if (not (string=? (car (edit-fragment 1)) "scale-channel 0.000 0 #f"))
- (snd-display #__line__ ";ramp over 0 clobbered origin: ~A" (edit-fragment 1)))
+ (snd-display ";ramp over 0 clobbered origin: ~A" (edit-fragment 1)))
(xramp-channel 0 1 32.0)
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";ramp over 0: ~A" (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";ramp over 0: ~A" (edit-position)))
(env-channel-with-base '(0 0 1 1 2 0 3 1) 0.0)
- (if (not (= (edit-position) 1)) (snd-display #__line__ ";ramp over 0: ~A" (edit-position)))
+ (if (not (= (edit-position) 1)) (snd-display ";ramp over 0: ~A" (edit-position)))
(close-sound ind))
;; snddiff.scm
@@ -37946,22 +37282,22 @@ EDITS: 1
(ind1 (open-sound "oboe.snd")))
(let ((diff (snddiff ind0 0 ind1 0)))
(if (not (eq? diff 'no-difference))
- (snd-display #__line__ ";snddiff of same sound: ~A" diff)))
+ (snd-display ";snddiff of same sound: ~A" diff)))
(scale-channel 2.0 0 #f ind1)
(let ((diff (snddiff ind0 0 ind1 0)))
(if (or (not (eq? (car diff) 'scale))
(fneq (cadr diff) 2.0))
- (snd-display #__line__ ";snddiff scale by 2: ~A" diff)))
+ (snd-display ";snddiff scale by 2: ~A" diff)))
(revert-sound ind1)
(set! (sample 100 ind0 0) 1.0)
(let* ((diff (snddiff ind0 0 ind1 0))
- (info (and diff (list? diff) (= (length diff) 2) (= (length (car (cadr diff))) 3) (car (cadr diff)))))
+ (info (and diff (list? diff) (= (length diff) 2) (= (length (caadr diff)) 3) (caadr diff))))
(if (or (not (eq? (car diff) 'differences))
(not info)
(not (= (car info) 100))
(fneq (cadr info) 1.0)
(fneq (caddr info) -3.051e-4))
- (snd-display #__line__ ";snddiff change sample 100: ~A" diff)))
+ (snd-display ";snddiff change sample 100: ~A" diff)))
(revert-sound ind0)
(pad-channel 0 100 ind0 0)
(let ((diff (snddiff ind0 0 ind1 0)))
@@ -37972,7 +37308,7 @@ EDITS: 1
(diff 4)
(diff 5)
(diff 6))
- (snd-display #__line__ ";snddiff + lag: ~A" diff)))
+ (snd-display ";snddiff + lag: ~A" diff)))
(revert-sound ind0)
(filter-channel (float-vector 1.0 0.5 0.25) 3 0 #f ind1 0)
(let* ((diff (snddiff ind0 0 ind1 0))
@@ -37986,7 +37322,7 @@ EDITS: 1
(not (= (cadar info) 0))
(not (= (cadadr info) 1))
(not (= (cadr (caddr info)) 1)))
- (snd-display #__line__ ";snddiff filter: ~A ~A" diff info)))
+ (snd-display ";snddiff filter: ~A ~A" diff info)))
(revert-sound ind1)
(close-sound ind0)
@@ -37995,7 +37331,7 @@ EDITS: 1
(let ((ind (open-sound "oboe.snd")))
(let ((g550 (goertzel-channel 550.0))
(g1700 (goertzel-channel 1700.0)))
- (if (> (* 1000 g1700) g550) (snd-display #__line__ ";goertzel-channel oboe: ~A ~A" g550 g1700))
+ (if (> (* 1000 g1700) g550) (snd-display ";goertzel-channel oboe: ~A ~A" g550 g1700))
(close-sound ind)))
))
@@ -38007,11 +37343,9 @@ EDITS: 1
(let ()
(define (for-each-permutation func vals) ; for-each-combination -- use for-each-subset below
- "(for-each-permutation func vals) applies func to every permutation of vals"
- ;; (for-each-permutation (lambda args (format-logged #t "~{~A~^ ~}~%" args)) '(1 2 3))
(define (pinner cur nvals len)
(if (= len 1)
- (apply func (cons (car nvals) cur))
+ (apply func (car nvals) cur)
(do ((i 0 (+ i 1))) ; I suppose a named let would be more Schemish
((= i len))
(let ((start nvals))
@@ -38026,14 +37360,15 @@ EDITS: 1
(set-cdr! (list-tail vals (- len 1)) ()))) ; restore its original shape
(define (for-each-subset func args)
- (define (subset source dest len)
- (if (null? source)
- (if (aritable? func len)
- (apply func dest))
- (begin
- (subset (cdr source) (cons (car source) dest) (+ len 1))
- (subset (cdr source) dest len))))
- (subset args () 0))
+ (let subset ((source args)
+ (dest ())
+ (len 0))
+ (if (null? source)
+ (if (aritable? func len)
+ (apply func dest))
+ (begin
+ (subset (cdr source) (cons (car source) dest) (+ len 1))
+ (subset (cdr source) dest len)))))
(define-macro (test tst expected)
`(let ((val ,tst))
@@ -38104,17 +37439,17 @@ EDITS: 1
(lambda args
(apply format #f (cadr args)))) ; float-vector-set! argument 3, 3+1i, is a complex number but should be a real
"float-vector-set! argument 3, 3+1i, is a complex number but should be a real")
-
- (define (fv2 s1 s2 s3)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 1.0 (+ x 0+i)))
- ((= i 4) fv)
- (float-vector-set! fv i (+ (* x s2) (* (- 1.0 x) s3))))))
+
+ (define (fv2 s2 s3)
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 1.0 (+ x 0+i)))
+ ((= i 4) fv)
+ (float-vector-set! fv i (+ (* x s2) (* (- 1.0 x) s3)))))
(test
(catch #t
(lambda ()
- (fv2 1 2 3)) ; 'error again #(2.0 2-1i 2-2i 2-3i)
+ (fv2 2 3)) ; 'error again #(2.0 2-1i 2-2i 2-3i)
(lambda args (car args))) 'wrong-type-arg)
(set! (*s7* 'print-length) 123)
@@ -38410,16 +37745,6 @@ EDITS: 1
(float-vector-set! fv i (oscil g1 x))))))
(test (fv31a) (float-vector 0.0 0.1419943179576268 0.4140929109323406 0.7516320715399403))
- (define (fv32a)
- (let ((g0 (make-oscil 1000))
- (fv (make-float-vector 4))
- (g1 (make-oscil 1000)))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (let ((x (oscil g0)))
- (float-vector-set! fv i (oscil g1 x))))))
- (test (fv32a) (float-vector 0.0 0.1419943179576268 0.4140929109323406 0.7516320715399403))
-
(define (fv33)
(let ((g0 (make-oscil 1000))
(fv (make-float-vector 4))
@@ -38459,7 +37784,7 @@ EDITS: 1
(g1 (make-oscil 1000))
(x 1.0))
(do ((i 0 (+ i 1)))
- ((= i 4) fv)
+ ((= i 4) (and (positive? x) fv))
(let ((x (oscil g0))
(y x))
(float-vector-set! fv i (+ y (oscil g1)))))))
@@ -38516,31 +37841,29 @@ EDITS: 1
(test (fv42) (float-vector -0.5 -0.5 -0.5 0.0))
(define (fv43)
- (let ((g0 (make-float-vector 3 0.5))
- (fv (make-float-vector 4)))
+ (let ((fv (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 4) fv)
(float-vector-set! fv i (- i)))))
(test (fv43) (float-vector 0 -1 -2 -3))
(define (permute op . args)
- (let ((body (copy `(let ()
- (define (t1)
- (let ((x 1.5) (y 3.5) (g0 (make-oscil 1000)) (g1 (make-oscil 2000)) (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (float-vector-set! fv i (,op , at args)))))
- (define (t2)
- (let ((x 1.5) (y 3.5) (g0 (make-oscil 1000)) (g1 (make-oscil 2000)) (v (make-vector 4)))
- (do ((i 0 (+ i 1)))
- ((= i 4) v)
- (vector-set! v i (,op , at args)))))
- (let ((v1 (t1))
- (v2 (copy (t2) (make-float-vector 4))))
- (if (not (morally-equal? v1 v2))
- (format *stderr* "~D: ~A -> ~A ~A~%" #__line__ args v1 v2))))
- :readable)))
- (eval body)))
+ (eval (copy `(let ()
+ (define (t1)
+ (let ((x 1.5) (y 3.5) (g0 (make-oscil 1000)) (g1 (make-oscil 2000)) (fv (make-float-vector 4)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4) fv)
+ (float-vector-set! fv i (,op , at args)))))
+ (define (t2)
+ (let ((x 1.5) (y 3.5) (g0 (make-oscil 1000)) (g1 (make-oscil 2000)) (v (make-vector 4)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4) v)
+ (vector-set! v i (,op , at args)))))
+ (let ((v1 (t1))
+ (v2 (copy (t2) (make-float-vector 4))))
+ (if (not (morally-equal? v1 v2))
+ (format *stderr* "~D: ~A -> ~A ~A~%" args v1 v2))))
+ :readable)))
(set! (*s7* 'morally-equal-float-epsilon) 1e-12)
(for-each
@@ -38598,7 +37921,7 @@ EDITS: 1
(fv (make-float-vector 4))
(x 1.0))
(do ((i 0 (+ i 1)))
- ((= i 4) fv)
+ ((= i 4) (and (zero? (log x)) fv))
(float-vector-set! fv i (remainder (* 10 (oscil g0)) 1.0)))))
(test (fv48) (float-vector 0.0 0.4199431795762676 0.8111111333165493 0.1453117669029531))
@@ -38610,7 +37933,7 @@ EDITS: 1
(float-vector-set! fv i (float-vector-ref g0 (+ i 2))))))
(test (fv49) (float-vector 3 4 5 6))
- (define (fv49)
+ (define (fv49a)
(let ((fv (make-float-vector 4))
(g0 (make-oscil 1000))
(g1 (make-oscil 1000))
@@ -38619,7 +37942,7 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i 4) fv)
(float-vector-set! fv i (+ (oscil g0) (oscil g1) (oscil g2) (oscil g3))))))
- (test (fv49) (float-vector 0.0 0.5679772718305071 1.12444445332662 1.658124706761181))
+ (test (fv49a) (float-vector 0.0 0.5679772718305071 1.12444445332662 1.658124706761181))
(define (fv50)
(let ((iv (int-vector 0 1 2 3 4 5 6))
@@ -38659,7 +37982,7 @@ EDITS: 1
(g (make-oscil 1000)))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.1)))
- ((> i 4) fv)
+ ((> i 4) (and (positive? x) fv))
(float-vector-set! fv i (oscil g)))))
(test (catch #t fv54 (lambda args (car args))) 'out-of-range)
@@ -38668,7 +37991,7 @@ EDITS: 1
(g (make-oscil 1000)))
(do ((i 0 (+ i 1.1))
(x 0.0 (+ x 0.1)))
- ((= i 4) fv)
+ ((= i 4) (and (positive? x) fv))
(float-vector-set! fv i (oscil g)))))
(test (catch #t fv55 (lambda args (car args))) 'wrong-type-arg)
@@ -38677,7 +38000,7 @@ EDITS: 1
(g (make-oscil 1000)))
(do ((i 0 (+ i 2))
(x 0.0 (+ x 0.1)))
- ((= i 3) fv)
+ ((= i 3) (and (positive? x) fv))
(float-vector-set! fv i (oscil g)))))
(test (catch #t fv56 (lambda args (car args))) 'out-of-range)
@@ -38721,17 +38044,6 @@ EDITS: 1
(test (fv60) (float-vector 0.0 0.5679772718305071 1.12444445332662 1.658124706761181))
- (define (fv60a)
- (let ((xv (float-vector 0 1 2 3 4))
- (fv (make-float-vector 4))
- (g (make-oscil 1000))
- (len 5))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (float-vector-set! fv i (array-interp xv (* 4 (abs (oscil g))) len)))))
-
- (test (fv60a) (float-vector 0.0 0.5679772718305071 1.12444445332662 1.658124706761181))
-
(define (fv61)
(let ((fv (make-float-vector 4))
(g (make-oscil 1000)))
@@ -38868,7 +38180,6 @@ EDITS: 1
(define (fv72)
(let ((fv (make-float-vector 10))
(ls (make-list 10))
- (g (make-square-wave 2205))
(x 0.0))
(let ((g (make-square-wave 2205)))
(do ((i 0 (+ i 1)))
@@ -38886,7 +38197,6 @@ EDITS: 1
(define (fv73)
(let ((fv (make-float-vector 10))
(ls (make-list 10))
- (g (make-square-wave 2205))
(x 0.5))
(let ((g (make-square-wave 2205)))
(do ((i 0 (+ i 1)))
@@ -38937,7 +38247,7 @@ EDITS: 1
(test (fv77) (float-vector 0.008 0.01517028252035849 0.03244495213443228 0.07802652038780451))
(define (fv80) (let ((x 0.0)) (do ((i 0 (+ i 1))) ((= i 4) x) (set! x .1)))) (test (fv80) .1)
- (define (fv81) (let ((x 0.0)) (do ((i 0 (+ i 1)) (y .1 .1)) ((= i 4) x) (set! x y)))) (test (fv81) .1)
+ (define (fv81) (do ((x 0.0) (i 0 (+ i 1)) (y .1 .1)) ((= i 4) x) (set! x y))) (test (fv81) .1)
(define (fv82) (let ((x 0.0) (y 0.1)) (do ((i 0 (+ i 1))) ((= i 4) x) (set! x y)))) (test (fv82) .1)
(define (fv83) (let ((x 0.0) (y 0.1)) (do ((i 0 (+ i 1))) ((= i 4) x) (set! x (+ x y))))) (test (fv83) .4)
(define (fv84) (let ((x 1.0)) (do ((i 0 (+ i 1))) ((= i 10) x) (set! x (+ x (* i 2.0)))))) (test (fv84) 91.0)
@@ -38959,13 +38269,13 @@ EDITS: 1
(test (fv86) (float-vector 1.0 1.0 1.0 1.0))
(define (fv87)
- (let ((fv1 (make-float-vector 4 1.5))
- (fv2 (make-float-vector 4 0.0)))
- (do ((i 0 (+ i 1))
- (j 0 (+ j 1)))
- ((= i 4) fv2)
- (float-vector-add! fv2 fv1)
- (float-vector-set! fv1 j 2.5))))
+ (do ((fv1 (make-float-vector 4 1.5))
+ (fv2 (make-float-vector 4 0.0))
+ (i 0 (+ i 1))
+ (j 0 (+ j 1)))
+ ((= i 4) fv2)
+ (float-vector-add! fv2 fv1)
+ (float-vector-set! fv1 j 2.5)))
(test (fv87) (float-vector 9 8 7 6))
(define (fv88)
@@ -38994,32 +38304,31 @@ EDITS: 1
(float-vector 0.004425048828125 0.012664794921875 0.015777587890625 0.014556884765625)))
(define (fv90)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 1.0 (+ x 0.5)))
- ((= i 4) fv)
- (set! (fv i) x))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 1.0 (+ x 0.5)))
+ ((= i 4) fv)
+ (set! (fv i) x)))
(test (fv90) (float-vector 1.0 1.5 2.0 2.5))
-
+
(define (fv91)
- (let ((f1 (float-vector 1.0 2.0 3.0))
- (f2 (float-vector 0.0 0.0 0.0))
- (m1 (float-vector 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0))
- (f1-len 3)
- (f2-len 3))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 2))) ; currently needed to trigger optimizer
- ((= i 1) f2)
- (frample->frample m1 f1 f1-len f2 f2-len))))
+ (do ((f1 (float-vector 1.0 2.0 3.0))
+ (f2 (float-vector 0.0 0.0 0.0))
+ (m1 (float-vector 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0))
+ (f1-len 3)
+ (f2-len 3)
+ (i 0 (+ i 1))
+ (x 0 (+ x 2))) ; currently needed to trigger optimizer
+ ((= i 1) (and (positive? x) f2))
+ (frample->frample m1 f1 f1-len f2 f2-len)))
(test (fv91) (float-vector 30.0 36.0 42.0))
-
+
(define (fv92)
(let ((sf (make-frample->file "fmv.snd" 2 mus-lfloat mus-riff "this is a comment"))
(fv (float-vector .1 .2))
(fv1 (make-float-vector 4))
(fv2 (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 2)))
+ (do ((i 0 (+ i 1)))
((= i 4))
(frample->file sf i fv))
(mus-close sf)
@@ -39035,8 +38344,7 @@ EDITS: 1
(fv (float-vector .01 .02))
(fv1 (make-float-vector 4))
(fv2 (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 2)))
+ (do ((i 0 (+ i 1)))
((= i 4))
(frample->file sf i (float-vector-add! fv fv)))
(mus-close sf)
@@ -39049,117 +38357,116 @@ EDITS: 1
(set! (*s7* 'morally-equal-float-epsilon) old-fudge))
(define (fv94)
- (let ((fv0 (float-vector 0 1 2 3 4 5))
- (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.4 (+ x 0.7)))
- ((= i 4) fv)
- (float-vector-set! fv i (float-vector-ref fv0 (floor x))))))
+ (do ((fv0 (float-vector 0 1 2 3 4 5))
+ (fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0.4 (+ x 0.7)))
+ ((= i 4) fv)
+ (float-vector-set! fv i (float-vector-ref fv0 (floor x)))))
(test (fv94) (float-vector 0.0 1.0 1.0 2.0))
(define (fv94a)
- (let ((fv0 (float-vector 0 1 2 3 4 5))
- (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.4 (+ x 0.7)))
- ((= i 4) fv)
- (float-vector-set! fv i (float-vector-ref fv0 (ceiling x))))))
+ (do ((fv0 (float-vector 0 1 2 3 4 5))
+ (fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0.4 (+ x 0.7)))
+ ((= i 4) fv)
+ (float-vector-set! fv i (float-vector-ref fv0 (ceiling x)))))
(test (fv94a) (float-vector 1.0 2.0 2.0 3.0))
(define (fv95)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (even? i)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (even? i)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv95) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv95a)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (odd? i)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (odd? i)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv95a) (float-vector -10.0 11.0 -8.0 13.0))
(define (fv95b)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (not (odd? i))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) fv)
+ (float-vector-set! fv i (if (not (odd? i))
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv95b) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv96)
- (let ((fv (make-float-vector 4))
- (fv1 (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) (list fv fv1))
- (float-vector-set! fv1 i 3.0)
- (if (even? i)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0)))
- (float-vector-set! fv1 i (+ (float-vector-ref fv1 i) 1.0)))))
+ (do ((fv (make-float-vector 4))
+ (fv1 (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) (list fv fv1)))
+ (float-vector-set! fv1 i 3.0)
+ (float-vector-set! fv i (if (even? i)
+ (+ i 10.0)
+ (- i 10.0)))
+ (float-vector-set! fv1 i (+ (float-vector-ref fv1 i) 1.0))))
(test (fv96) (list (float-vector 10.0 -9.0 12.0 -7.0)
(float-vector 4.0 4.0 4.0 4.0)))
(define (fv97)
- (let ((fv (make-float-vector 4))
- (j 0))
- (do ((i 0 (+ i 1))
- (x 0.4 (+ x 0.7)))
- ((= i 4) fv)
- (set! j (floor x))
- (float-vector-set! fv i (* j 2.0)))))
+ (do ((fv (make-float-vector 4))
+ (j 0)
+ (i 0 (+ i 1))
+ (x 0.4 (+ x 0.7)))
+ ((= i 4) fv)
+ (set! j (floor x))
+ (float-vector-set! fv i (* j 2.0))))
(test (fv97) (float-vector 0.0 2.0 2.0 4.0))
(define (fv98)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.1)))
- ((not (= i 0)) fv)
- (set! i (* i 0.5))
- (set! (fv i) x))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.1)))
+ ((not (= i 0)) fv)
+ (set! i (* i 0.5))
+ (set! (fv i) x)))
(test (catch #t
fv98
(lambda args
(apply format #f (cadr args)))) "vector-set!: index must be an integer: ((fv i) x)")
(define (fv99)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (zero? i)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (zero? i)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv99) (float-vector 10.0 -9.0 -8.0 -7.0))
(define (fv100)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (zero? (modulo i 2))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (zero? (modulo i 2))
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv100) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv101)
- (let ((fv (make-float-vector 4))
- (ctr 0))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) ctr)
- (if (zero? (modulo i 2))
- (set! ctr (+ ctr 1))))))
+ (do ((ctr 0)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and x ctr))
+ (if (zero? (modulo i 2))
+ (set! ctr (+ ctr 1)))))
(test (fv101) 2)
(define (fv103)
@@ -39180,36 +38487,28 @@ EDITS: 1
(float-vector-set! fv i (+ (float-vector-ref fv j) 1.0))))))
(test (fv104) (float-vector 0 1 2 3 4 5 6 7 8 9))
- (define (fv104)
- (let ((fv (make-float-vector 10)))
- (do ((i 0 (+ i 1))) ((= i 10) fv)
- (do ((j 0 (+ j 1))) ((= j i))
- (float-vector-set! fv i (+ (float-vector-ref fv j) 1.0))))))
- (test (fv104) (float-vector 0 1 2 3 4 5 6 7 8 9))
-
(when all-args
(define (do-permute init step end)
- (let ((body (copy `(let ()
- (define (t1)
- (let ((fv (make-float-vector 4)))
- (if (<= ,step 0) (error 'out-of-range "step > 0"))
- (do ((i ,init (+ i ,step))
- (x 1.0 (+ x 1.0)))
- ((>= i ,end) fv)
- (float-vector-set! fv i x))))
- (define (t2)
- (let ((fv (make-float-vector 4)))
- (if (<= ,step 0) (error 'out-of-range "step > 0"))
- (do ((i ,init (+ i ,step))
- (x 1.0 (+ x 1.0)))
- ((>= i ,end) fv)
- (float-vector-set! fv i x))))
- (let ((v1 (catch #t t1 (lambda args 'error)))
- (v2 (catch #t (lambda () (copy (t2) (make-float-vector 4))) (lambda args 'error))))
- (if (not (morally-equal? v1 v2))
- (format *stderr* "~D: permute ~A, ~A -> ~A ~A, ~A~%" #__line__ op args v1 v2 (float-vector-peak (float-vector-subtract! v1 v2))))))
- :readable)))
- (eval body)))
+ (eval (copy `(let ()
+ (define (t1)
+ (let ((fv (make-float-vector 4)))
+ (if (<= ,step 0) (error 'out-of-range "step > 0"))
+ (do ((i ,init (+ i ,step))
+ (x 1.0 (+ x 1.0)))
+ ((>= i ,end) fv)
+ (float-vector-set! fv i x))))
+ (define (t2)
+ (let ((fv (make-float-vector 4)))
+ (if (<= ,step 0) (error 'out-of-range "step > 0"))
+ (do ((i ,init (+ i ,step))
+ (x 1.0 (+ x 1.0)))
+ ((>= i ,end) fv)
+ (float-vector-set! fv i x))))
+ (let ((v1 (catch #t t1 (lambda args 'error)))
+ (v2 (catch #t (lambda () (copy (t2) (make-float-vector 4))) (lambda args 'error))))
+ (if (not (morally-equal? v1 v2))
+ (format *stderr* "~D: permute ~A, ~A -> ~A ~A, ~A~%" op args v1 v2 (float-vector-peak (float-vector-subtract! v1 v2))))))
+ :readable)))
(set! (*s7* 'morally-equal-float-epsilon) 1e-12)
@@ -39221,11 +38520,11 @@ EDITS: 1
(list 0 4 1 2 0.0 4.0 1.0 2.0 1/2 1+i 2/3 #\a "hi" #f)))
(define (fv107)
- (let ((g0 (make-hash-table)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 10.0)))
- ((= i 4) g0)
- (hash-table-set! g0 i x))))
+ (do ((g0 (make-hash-table))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 10.0)))
+ ((= i 4) g0)
+ (hash-table-set! g0 i x)))
(test (fv107) (hash-table* 0 0.0 1 10.0 2 20.0 3 30.0))
(define (fv108)
@@ -39315,99 +38614,99 @@ EDITS: 1
(g (make-oscil 100)))
(do ((i 0 (+ i 1))
(x 0 (+ x 1)))
- ((= i 4) fv)
- (if (oscil? g)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (oscil? g)
+ (+ i 10.0)
+ (- i 10.0))))))
(test (fv116) (float-vector 10.0 11.0 12.0 13.0))
(define (fv117)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (even? (round i))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (even? (round i))
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv117) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv118)
- (let ((fv (make-float-vector 4))
- (lst '(1 2 3)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (even? (car lst))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (lst '(1 2 3))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (even? (car lst))
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv118) (float-vector -10.0 -9.0 -8.0 -7.0))
(define (fv119)
- (let ((fv (make-float-vector 4))
- (lst '(1 2 3)))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (eqv? i (car lst))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (lst '(1 2 3))
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (eqv? i (car lst))
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv119) (float-vector -10.0 11.0 -8.0 -7.0))
(define (fv120)
- (let ((fv (make-float-vector 4))
- (j 2))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (= i j)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (j 2)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (= i j)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv120) (float-vector -10.0 -9.0 12.0 -7.0))
(define (fv121)
- (let ((fv (make-float-vector 4))
- (j 2))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (< i j)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (j 2)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (< i j)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv121) (float-vector 10.0 11.0 -8.0 -7.0))
(define (fv122)
- (let ((fv (make-float-vector 4))
- (j 2))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (<= i j)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (j 2)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (<= i j)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv122) (float-vector 10.0 11.0 12.0 -7.0))
(define (fv123)
- (let ((fv (make-float-vector 4))
- (j 2))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (>= i j)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (j 2)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (>= i j)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv123) (float-vector -10.0 -9.0 12.0 13.0))
(define (fv124)
- (let ((fv (make-float-vector 4))
- (j 2))
- (do ((i 0 (+ i 1))
- (x 0 (+ x 1)))
- ((= i 4) fv)
- (if (> i j)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (do ((fv (make-float-vector 4))
+ (j 2)
+ (i 0 (+ i 1))
+ (x 0 (+ x 1)))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i (if (> i j)
+ (+ i 10.0)
+ (- i 10.0)))))
(test (fv124) (float-vector -10.0 -9.0 -8.0 13.0))
-
+
(define (fv125)
(let ((gen (make-delay 5)))
(do ((i 0 (+ i 1)))
@@ -39428,19 +38727,19 @@ EDITS: 1
(im (make-float-vector 8)))
(set! (rl 2) 1.0)
(mus-fft rl im 8 1)
- (if (or (not (morally-equal? d0 rl))
- (not (morally-equal? d1 im)))
+ (if (not (and (morally-equal? d0 rl)
+ (morally-equal? d1 im)))
(format *stderr* ";fv126 mus-fft 0: ~A ~A~%" rl im))
(mus-fft rl im 8 -1)
- (if (or (not (morally-equal? e0 rl))
- (not (morally-equal? e1 im)))
+ (if (not (and (morally-equal? e0 rl)
+ (morally-equal? e1 im)))
(format *stderr* ";fv126 mus-fft 1: ~A ~A~%" rl im))
(set! (rl 2) 1.0)
(do ((i 0 (+ i 1)))
((= i 1))
(mus-fft rl im))
- (if (or (not (morally-equal? d0 rl))
- (not (morally-equal? d1 im)))
+ (if (not (and (morally-equal? d0 rl)
+ (morally-equal? d1 im)))
(format *stderr* ";fv126 mus-fft 2: ~A ~A~%" rl im))
(let ((loc 2)
(val 1.0))
@@ -39449,8 +38748,8 @@ EDITS: 1
(mus-fft rl im 8 -1)
(float-vector-set! rl loc val)
(mus-fft rl im 8))
- (if (or (not (morally-equal? d0 rl))
- (not (morally-equal? d1 im)))
+ (if (not (and (morally-equal? d0 rl)
+ (morally-equal? d1 im)))
(format *stderr* ";fv126 mus-fft 2: ~A ~A~%" rl im)))))
(fv126)
@@ -39459,20 +38758,22 @@ EDITS: 1
(j 2))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (if (or (> i j)
- (= i 3))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (float-vector-set! fv i
+ (if (or (> i j)
+ (= i 3))
+ (+ i 10.0)
+ (- i 10.0))))))
(test (fv127) (float-vector -10.0 -9.0 -8.0 13.0))
(define (fv128)
(let ((fv (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (if (or (= i 1)
- (= i 3))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (float-vector-set! fv i
+ (if (or (= i 1)
+ (= i 3))
+ (+ i 10.0)
+ (- i 10.0))))))
(test (fv128) (float-vector -10.0 11.0 -8.0 13.0))
(define (fv129)
@@ -39480,10 +38781,11 @@ EDITS: 1
(j 2))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (if (and (= i j)
- (< i 3))
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (float-vector-set! fv i
+ (if (and (= i j)
+ (< i 3))
+ (+ i 10.0)
+ (- i 10.0))))))
(test (fv129) (float-vector -10.0 -9.0 12.0 -7.0))
(define (fv130)
@@ -39491,35 +38793,35 @@ EDITS: 1
(j #\a))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (if (char=? j #\a)
- (float-vector-set! fv i (+ i 10.0))
- (float-vector-set! fv i (- i 10.0))))))
+ (float-vector-set! fv i
+ (if (char=? j #\a)
+ (+ i 10.0)
+ (- i 10.0))))))
(test (fv130) (float-vector 10.0 11.0 12.0 13.0))
(define (char-permute op . args)
- (let ((body (copy `(let ()
- (define (t1)
- (let ((x #\a) (y #\A) (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x1 1.0 (+ x1 1.0)))
- ((= i 4) fv)
- (if (,op , at args)
- (float-vector-set! fv i x1)
- (float-vector-set! fv i 0.0)))))
- (define (t2)
- (let ((x #\a) (y #\A) (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x1 1.0 (+ x1 1.0)))
- ((= i 4) fv)
- (if (apply ,op (list , at args))
- (float-vector-set! fv i x1)
- (float-vector-set! fv i 0.0)))))
- (let ((v1 (t1))
- (v2 (t2)))
- (if (not (morally-equal? v1 v2))
- (format *stderr* "char-permute ~A, ~A -> ~A ~A~%" op args v1 v2))))
- :readable)))
- (eval body)))
+ (eval (copy `(let ()
+ (define (t1)
+ (let ((x #\a) (y #\A) (fv (make-float-vector 4)))
+ (do ((i 0 (+ i 1))
+ (x1 1.0 (+ x1 1.0)))
+ ((= i 4) fv)
+ (if (,op , at args)
+ (float-vector-set! fv i x1)
+ (float-vector-set! fv i 0.0)))))
+ (define (t2)
+ (let ((x #\a) (y #\A) (fv (make-float-vector 4)))
+ (do ((i 0 (+ i 1))
+ (x1 1.0 (+ x1 1.0)))
+ ((= i 4) fv)
+ (if (apply ,op (list , at args))
+ (float-vector-set! fv i x1)
+ (float-vector-set! fv i 0.0)))))
+ (let ((v1 (t1))
+ (v2 (t2)))
+ (if (not (morally-equal? v1 v2))
+ (format *stderr* "char-permute ~A, ~A -> ~A ~A~%" op args v1 v2))))
+ :readable)))
(for-each
(lambda (op)
@@ -39536,29 +38838,28 @@ EDITS: 1
(list 'char=? 'char<? 'char<=? 'char>? 'char>=? 'char-ci=? 'char-ci<? 'char-ci<=? 'char-ci>? 'char-ci>=?)))
(define (string-permute op . args)
- (let ((body (copy `(let ()
- (define (t1)
- (let ((x "a") (y "A") (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x1 1.0 (+ x1 1.0)))
- ((= i 4) fv)
- (if (,op , at args)
- (float-vector-set! fv i x1)
- (float-vector-set! fv i 0.0)))))
- (define (t2)
- (let ((x "a") (y "A") (fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x1 1.0 (+ x1 1.0)))
- ((= i 4) fv)
- (if (apply ,op (list , at args))
- (float-vector-set! fv i x1)
- (float-vector-set! fv i 0.0)))))
- (let ((v1 (t1))
- (v2 (t2)))
- (if (not (morally-equal? v1 v2))
- (format *stderr* "string-permute ~A, ~A -> ~A ~A~%" op args v1 v2))))
- :readable)))
- (eval body)))
+ (eval (copy `(let ()
+ (define (t1)
+ (let ((x "a") (y "A") (fv (make-float-vector 4)))
+ (do ((i 0 (+ i 1))
+ (x1 1.0 (+ x1 1.0)))
+ ((= i 4) fv)
+ (if (,op , at args)
+ (float-vector-set! fv i x1)
+ (float-vector-set! fv i 0.0)))))
+ (define (t2)
+ (let ((x "a") (y "A") (fv (make-float-vector 4)))
+ (do ((i 0 (+ i 1))
+ (x1 1.0 (+ x1 1.0)))
+ ((= i 4) fv)
+ (if (apply ,op (list , at args))
+ (float-vector-set! fv i x1)
+ (float-vector-set! fv i 0.0)))))
+ (let ((v1 (t1))
+ (v2 (t2)))
+ (if (not (morally-equal? v1 v2))
+ (format *stderr* "string-permute ~A, ~A -> ~A ~A~%" op args v1 v2))))
+ :readable)))
(for-each
(lambda (op)
@@ -39632,21 +38933,13 @@ EDITS: 1
(if (even? i)
(+ (oscil o1)
(* (triangle-wave t1)
- (if (zero? (modulo i 2))
- (polywave p1)
- (polywave p2)))
- (if (odd? i)
- (sawtooth-wave s1)
- (sawtooth-wave s2)))
+ (polywave (if (zero? (modulo i 2)) p1 p2)))
+ (sawtooth-wave (if (odd? i) s1 s2)))
(+ (oscil o2)
(* (triangle-wave t2)
- (if (zero? (modulo i 2))
- (polywave p3)
- (polywave p4)))
- (if (odd? i)
- (sawtooth-wave s3)
- (sawtooth-wave s4)))))))))
-
+ (polywave (if (zero? (modulo i 2)) p3 p4)))
+ (sawtooth-wave (if (odd? i) s3 s4)))))))))
+
(test (fv132a) (float-vector 0.0 0.0 0.2754865742400099 0.2754865742400099 0.5330915108442034 0.5330915108442034
0.7567925994733748 0.7567925994733748 0.9340879688376413 0.9340879688376413))
@@ -39659,65 +38952,63 @@ EDITS: 1
(test (fv133) (float-vector 0.0 1.0 2.0 3.0))
(define (fv134)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (let ((y 1.0))
- ((lambda ()
- (set! (fv i) i)))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1)))
+ ((= i 4) fv)
+ (let ((y 1.0))
+ ((lambda ()
+ (set! (fv i) i))))))
(test (fv134) (float-vector 0.0 1.0 2.0 3.0))
(define (fv135)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 1.0)))
- ((= i 4) fv)
- ((lambda ()
- (set! (fv i) i))))))
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 1.0)))
+ ((= i 4) (and (positive? x) fv))
+ ((lambda ()
+ (set! (fv i) i)))))
(test (fv135) (float-vector 0.0 1.0 2.0 3.0))
(define (fv136)
- (let ((fv (make-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 1.0)))
- ((= i 4) fv)
- (vector-set! fv i (cons i x)))))
+ (do ((fv (make-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 1.0)))
+ ((= i 4) fv)
+ (vector-set! fv i (cons i x))))
(test (fv136) (vector '(0 . 0.0) '(1 . 1.0) '(2 . 2.0) '(3 . 3.0)))
(define (fv137)
- (let ((fv (make-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.6)))
- ((= i 4) fv)
- (vector-set! fv i (asin x)))))
- (test (fv137) (vector (asin 0.0) (asin 0.6) (asin 1.2) (asin 1.8)))
+ (do ((fv (make-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.6)))
+ ((= i 4) fv)
+ (vector-set! fv i (asin x))))
+ (test (fv137) (vector 0.0 (asin 0.6) (asin 1.2) (asin 1.8)))
(define (fv138)
- (let ((fv (make-vector 4))
- (fv1 (vector 0.0 0.6 1.2 1.8)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.6)))
- ((= i 4) fv)
- (vector-set! fv i (asin (vector-ref fv1 i))))))
- (test (fv138) (vector (asin 0.0) (asin 0.6) (asin 1.2) (asin 1.8)))
+ (do ((fv (make-vector 4))
+ (fv1 (vector 0.0 0.6 1.2 1.8))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.6)))
+ ((= i 4) (and (positive? x) fv))
+ (vector-set! fv i (asin (vector-ref fv1 i)))))
+ (test (fv138) (vector 0.0 (asin 0.6) (asin 1.2) (asin 1.8)))
(define (fv138a)
- (let ((fv (make-vector 4))
- (fv1 (vector 0.0 0.6 1.2 1.8)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.6)))
- ((= i 4) fv)
- (vector-set! fv i (asin (floor i))))))
- (test (fv138a) (vector (asin 0) (asin 1) (asin 2) (asin 3)))
+ (do ((fv (make-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.6)))
+ ((= i 4) (and (positive? x) fv))
+ (vector-set! fv i (asin (floor i)))))
+ (test (fv138a) (vector 0 (asin 1) (asin 2) (asin 3)))
(define (fv138b)
- (let ((fv (make-vector 4))
- (fv1 (vector 0.0 0.6 1.2 1.8)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.6)))
- ((= i 4) fv)
- (vector-set! fv i (asin (complex x i))))))
- (test (fv138b) (vector (asin 0.0) (asin 0.6+i) (asin 1.2+2i) (asin 1.8+3i)))
+ (do ((fv (make-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.6)))
+ ((= i 4) fv)
+ (vector-set! fv i (asin (complex x i)))))
+ (test (fv138b) (vector 0.0 (asin 0.6+i) (asin 1.2+2i) (asin 1.8+3i)))
(define (fv139)
(with-output-to-string
@@ -39736,29 +39027,29 @@ EDITS: 1
(test (fv140) "PQRS")
(define (fv141)
- (let ((g0 (make-hash-table))
- (v (vector 0 1 2 3 4 5)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 10.0)))
- ((= i 4) g0)
- (hash-table-set! g0 (vector-ref v i) x))))
+ (do ((g0 (make-hash-table))
+ (v (vector 0 1 2 3 4 5))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 10.0)))
+ ((= i 4) g0)
+ (hash-table-set! g0 (vector-ref v i) x)))
(test (fv141) (hash-table* 0 0.0 1 10.0 2 20.0 3 30.0))
(define (fv142)
- (let ((g0 (make-hash-table)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 10.0)))
- ((= i 4) g0)
- (hash-table-set! g0 i (list x)))))
+ (do ((g0 (make-hash-table))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 10.0)))
+ ((= i 4) g0)
+ (hash-table-set! g0 i (list x))))
(test (fv142) (hash-table* 0 '(0.0) 1 '(10.0) 2 '(20.0) 3 '(30.0)))
(define (fv143)
- (let ((g0 (make-hash-table))
- (v (vector 0 1 2 3 4 5)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 10.0)))
- ((= i 4) g0)
- (hash-table-set! g0 (vector-ref v i) (list x)))))
+ (do ((g0 (make-hash-table))
+ (v (vector 0 1 2 3 4 5))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 10.0)))
+ ((= i 4) g0)
+ (hash-table-set! g0 (vector-ref v i) (list x))))
(test (fv143) (hash-table* 0 '(0.0) 1 '(10.0) 2 '(20.0) 3 '(30.0)))
(define (fv144)
@@ -39917,18 +39208,18 @@ EDITS: 1
(set! (v1 i) (+ (oscil (vector-ref oscs k)) (oscil o 1.5)))))
(set! o (make-oscil 1000))
(set! oscs (vector (make-oscil 400) (make-oscil 500) (make-oscil 600)))
- (set! (v2 0) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 1) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 2) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 3) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 4) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 5) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 6) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 7) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 8) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (set! (v2 9) ((lambda () (let ((x (oscil o))) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))))
- (if (or (not (morally-equal? v1 v2))
- (not (morally-equal? v1 v3)))
+ (set! (v2 0) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 1) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 2) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 3) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 4) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 5) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 6) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 7) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 8) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (set! (v2 9) (begin (oscil o) (+ (oscil (vector-ref oscs k)) (oscil o 1.5))))
+ (if (not (and (morally-equal? v1 v2)
+ (morally-equal? v1 v3)))
(format *stderr* "~A~%~A~%~A~%" v1 v2 v3))))
(fv159)
@@ -39941,15 +39232,7 @@ EDITS: 1
(float-vector-set! fv i (oscil g x)))))
(test (fv160) (let ((g (make-oscil 1000))) (float-vector (oscil g 0.1) (oscil g) (oscil g) (oscil g))))
-#|
- (define (fv161)
- (let ((log2 (*libm* 'log2)))
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (set! (fv i) (log2 2.5))))))
- (test (fv161) (float-vector (log 2.5 2) (log 2.5 2) (log 2.5 2) (log 2.5 2)))
-|#
+
(define (fv162)
(let ((fv (make-int-vector 4))
(iter (make-iterator (list 1 2 3 4))))
@@ -39959,12 +39242,11 @@ EDITS: 1
(test (fv162) (int-vector 1 2 3 4))
(define (fv163)
- (let ((fv (make-float-vector 4)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x 0.25)))
- ((= i 4) fv)
- (set! (fv i) (sin x)))))
-
+ (do ((fv (make-float-vector 4))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x 0.25)))
+ ((= i 4) fv)
+ (set! (fv i) (sin x))))
(test (fv163) (float-vector (sin 0.0) (sin 0.25) (sin 0.5) (sin 0.75)))
(define (fv164) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ 1.0 2.0 3.0)))))
@@ -39976,7 +39258,7 @@ EDITS: 1
(define (fv166) (let ((x 1/2) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ 1 x)))))
(test (fv166) (float-vector 1.5 1.5 1.5 1.5))
- (define (fv167) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ 6.0)))))
+ (define (fv167) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) 6.0))))
(test (fv167) (float-vector 6.0 6.0 6.0 6.0))
(define (fv168) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ x 5.0)))))
@@ -40012,8 +39294,8 @@ EDITS: 1
(define (fv178) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x (abs x))))))
(test (fv178) (float-vector 6.0 6.0 6.0 6.0))
- (define (fv178) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x y)))))
- (test (fv178) (float-vector 6.0 6.0 6.0 6.0))
+ (define (fv178c) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x y)))))
+ (test (fv178c) (float-vector 6.0 6.0 6.0 6.0))
(define (fv179) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 1.0 2.0 3.0)))))
@@ -40046,18 +39328,15 @@ EDITS: 1
(define (fv188) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x (abs x))))))
(test (fv188) (float-vector 8.0 8.0 8.0 8.0))
- (define (fv188) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x y)))))
- (test (fv188) (float-vector 8.0 8.0 8.0 8.0))
+ (define (fv188c) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x y)))))
+ (test (fv188c) (float-vector 8.0 8.0 8.0 8.0))
(define (fv189) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 4.5 3/2)))))
(test (fv189) (float-vector 6.75 6.75 6.75 6.75))
- (define (fv190) (let ((x 1/2) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 1 x)))))
+ (define (fv190) (let ((x 1/2) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) x))))
(test (fv190) (float-vector 0.5 0.5 0.5 0.5))
- (define (fv191) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 6.0)))))
- (test (fv191) (float-vector 6.0 6.0 6.0 6.0))
-
(define (fv192) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* x 5.0)))))
(test (fv192) (float-vector 5.0 5.0 5.0 5.0))
@@ -40073,7 +39352,7 @@ EDITS: 1
(define (fvi166) (let ((x 1/2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ 1 x)))))
(test (catch #t fvi166 (lambda args 'error))'error)
- (define (fvi167) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ 6)))))
+ (define (fvi167) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) 6))))
(test (fvi167) (int-vector 6 6 6 6))
(define (fvi168) (let ((x 1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ x 5)))))
@@ -40109,8 +39388,8 @@ EDITS: 1
(define (fvi178) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x (abs x))))))
(test (fvi178) (int-vector 6 6 6 6))
- (define (fvi178) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x y)))))
- (test (fvi178) (int-vector 6 6 6 6))
+ (define (fvk178) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ (abs x) x y)))))
+ (test (fvk178) (int-vector 6 6 6 6))
(define (fvi179) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 1 2 3)))))
@@ -40143,8 +39422,8 @@ EDITS: 1
(define (fvi188) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x (abs x))))))
(test (fvi188) (int-vector 8 8 8 8))
- (define (fvi188) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x y)))))
- (test (fvi188) (int-vector 8 8 8 8))
+ (define (fvk188) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* (abs x) x y)))))
+ (test (fvk188) (int-vector 8 8 8 8))
(define (fvi191) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (* 6)))))
(test (fvi191) (int-vector 6 6 6 6))
@@ -40170,517 +39449,514 @@ EDITS: 1
(define (fv198) (let ((fv (make-float-vector 4))
(a 1.0) (b 2.0) (c 4.0))
- (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ a b 3.0 c (+ a c) (+ b c) (+ a b c) (+ a b c a b c a b c) a b c)))))
+ (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (+ a b 3.0 c a c b c a b c a b c a b c a b c a b c)))))
(test (fv198) (float-vector 56.0 56.0 56.0 56.0))
- (define (fv164) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1.0 2.0 3.0)))))
- (test (fv164) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv164b) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1.0 2.0 3.0)))))
+ (test (fv164b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv165) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 4.5 3/2)))))
- (test (fv165) (float-vector 3.0 3.0 3.0 3.0))
+ (define (fv165b) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 4.5 3/2)))))
+ (test (fv165b) (float-vector 3.0 3.0 3.0 3.0))
- (define (fv166) (let ((x 1/2) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 x)))))
- (test (fv166) (float-vector .5 .5 .5 .5))
+ (define (fv166b) (let ((x 1/2) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 x)))))
+ (test (fv166b) (float-vector .5 .5 .5 .5))
- (define (fv167) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 6.0)))))
- (test (fv167) (float-vector -6.0 -6.0 -6.0 -6.0))
+ (define (fv167b) (let ((fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 6.0)))))
+ (test (fv167b) (float-vector -6.0 -6.0 -6.0 -6.0))
- (define (fv168) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 5.0)))))
- (test (fv168) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv168b) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 5.0)))))
+ (test (fv168b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv169) (let ((x 1.0) (y 5.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y)))))
- (test (fv169) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv169b) (let ((x 1.0) (y 5.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y)))))
+ (test (fv169b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv170) (let ((x 1.0) (y 6.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y -1.0)))))
- (test (fv170) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv170b) (let ((x 1.0) (y 6.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y -1.0)))))
+ (test (fv170b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv171) (let ((x 1.0) (y 6.0) (z -1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y z)))))
- (test (fv171) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv171b) (let ((x 1.0) (y 6.0) (z -1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y z)))))
+ (test (fv171b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv172) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x -1.0 6.0)))))
- (test (fv172) (float-vector -4.0 -4.0 -4.0 -4.0))
+ (define (fv172b) (let ((x 1.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x -1.0 6.0)))))
+ (test (fv172b) (float-vector -4.0 -4.0 -4.0 -4.0))
- (define (fv173) (let ((x 3.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x (abs x))))))
- (test (fv173) (float-vector 0.0 0.0 0.0 0.0))
+ (define (fv173b) (let ((x 3.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x (abs x))))))
+ (test (fv173b) (float-vector 0.0 0.0 0.0 0.0))
- (define (fv174) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 2 (abs x))))))
- (test (fv174) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv174b) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 2 (abs x))))))
+ (test (fv174b) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fv175) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2.0 2 (abs x))))))
- (test (fv175) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv175b) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2.0 2 (abs x))))))
+ (test (fv175b) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fv176) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2.0 (abs x) (abs x))))))
- (test (fv176) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv176b) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2.0 (abs x) (abs x))))))
+ (test (fv176b) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fv177) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) (abs x) (abs x))))))
- (test (fv177) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv177b) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) (abs x) (abs x))))))
+ (test (fv177b) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fv178) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x (abs x))))))
- (test (fv178) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv178b) (let ((x 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x (abs x))))))
+ (test (fv178b) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fv178) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x y)))))
- (test (fv178) (float-vector -2.0 -2.0 -2.0 -2.0))
+ (define (fv178bb) (let ((x 2.0) (y 2.0) (fv (make-float-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x y)))))
+ (test (fv178bb) (float-vector -2.0 -2.0 -2.0 -2.0))
- (define (fvi164) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 2 3)))))
- (test (fvi164) (int-vector -4 -4 -4 -4))
-
- (define (fvi165) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 4.5 3/2)))))
- (test (catch #t fvi165 (lambda args 'error)) 'error)
+ (define (fvi164a) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 2 3)))))
+ (test (fvi164a) (int-vector -4 -4 -4 -4))
- (define (fvi166) (let ((x 1/2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 x)))))
- (test (catch #t fvi166 (lambda args 'error))'error)
+ (define (fvi165a) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 4.5 3/2)))))
+ (test (catch #t fvi165a (lambda args 'error)) 'error)
- (define (fvi167) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 6)))))
- (test (fvi167) (int-vector -6 -6 -6 -6))
+ (define (fvi166a) (let ((x 1/2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 1 x)))))
+ (test (catch #t fvi166a (lambda args 'error))'error)
- (define (fvi168) (let ((x 1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 5)))))
- (test (fvi168) (int-vector -4 -4 -4 -4))
+ (define (fvi167a) (let ((fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) -6))))
+ (test (fvi167a) (int-vector -6 -6 -6 -6))
- (define (fvi169) (let ((x 1) (y 5) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y)))))
- (test (fvi169) (int-vector -4 -4 -4 -4))
+ (define (fvi168a) (let ((x 1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 5)))))
+ (test (fvi168a) (int-vector -4 -4 -4 -4))
- (define (fvi170) (let ((x 1) (y 6) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y -1)))))
- (test (fvi170) (int-vector -4 -4 -4 -4))
+ (define (fvi169a) (let ((x 1) (y 5) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y)))))
+ (test (fvi169a) (int-vector -4 -4 -4 -4))
- (define (fvi171) (let ((x 1) (y 6) (z -1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y z)))))
- (test (fvi171) (int-vector -4 -4 -4 -4))
+ (define (fvi170a) (let ((x 1) (y 6) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y -1)))))
+ (test (fvi170a) (int-vector -4 -4 -4 -4))
- (define (fvi172) (let ((x 1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x -1 6)))))
- (test (fvi172) (int-vector -4 -4 -4 -4))
+ (define (fvi171a) (let ((x 1) (y 6) (z -1) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x y z)))))
+ (test (fvi171a) (int-vector -4 -4 -4 -4))
- (define (fvi173) (let ((x 3) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x (abs x))))))
- (test (fvi173) (int-vector 0 0 0 0))
+ (define (fvi173a) (let ((x 3) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x (abs x))))))
+ (test (fvi173a) (int-vector 0 0 0 0))
- (define (fvi174) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 2 (abs x))))))
- (test (fvi174) (int-vector -2 -2 -2 -2))
+ (define (fvi174a) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- x 2 (abs x))))))
+ (test (fvi174a) (int-vector -2 -2 -2 -2))
- (define (fvi175) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2 2 (abs x))))))
- (test (fvi175) (int-vector -2 -2 -2 -2))
+ (define (fvi175a) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2 2 (abs x))))))
+ (test (fvi175a) (int-vector -2 -2 -2 -2))
- (define (fvi176) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2 (abs x) (abs x))))))
- (test (fvi176) (int-vector -2 -2 -2 -2))
+ (define (fvi176a) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- 2 (abs x) (abs x))))))
+ (test (fvi176a) (int-vector -2 -2 -2 -2))
- (define (fvi177) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) (abs x) (abs x))))))
- (test (fvi177) (int-vector -2 -2 -2 -2))
+ (define (fvi177a) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) (abs x) (abs x))))))
+ (test (fvi177a) (int-vector -2 -2 -2 -2))
- (define (fvi178) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x (abs x))))))
- (test (fvi178) (int-vector -2 -2 -2 -2))
+ (define (fvi178a) (let ((x 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x (abs x))))))
+ (test (fvi178a) (int-vector -2 -2 -2 -2))
- (define (fvi178) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x y)))))
- (test (fvi178) (int-vector -2 -2 -2 -2))
+ (define (fvi178aa) (let ((x 2) (y 2) (fv (make-int-vector 4))) (do ((i 0 (+ i 1))) ((= i 4) fv) (set! (fv i) (- (abs x) x y)))))
+ (test (fvi178aa) (int-vector -2 -2 -2 -2))
)
- (if all-args
- (let ((old-size *clm-file-buffer-size*))
- (set! *clm-file-buffer-size* 100)
- (set! *mus-float-equal-fudge-factor* 1e-4)
- (define v-1 (make-float-vector 100 .25))
- (do ((i 0 (+ i 1)) (x 0.0 (+ x .01))) ((= i 100)) (float-vector-set! v-1 i x))
- (define v0 (make-float-vector 10))
-
- (define args1 (list 1.5 '(oscil o1) '(env e1) 'x 'i '(oscil o) '(- 1.0 x) '(oscil (vector-ref oscs k))))
- (define args2 (list 1.5 '(oscil o2) '(env e2) 'y 'i '(float-vector-ref v-1 i)))
- (define args3 (list 1.5 '(oscil o3) '(env e3) 'z 'i '(cos x)))
- ;(define args4 (list 1.5 '(oscil o4) '(env e4) 'x 'i))
-
- (define (try str)
- (eval-string
- (call-with-output-string
- (lambda (p)
- (format p "(let ()~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (i 0)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (set! (v0 0) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 1) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 2) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 3) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 4) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 5) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 6) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 7) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 8) ~A) (set! i (+ i 1))~%" str)
- (format p " (set! (v0 9) ~A))~%" str)
- (format p "(define (tester-1)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (set! (v i) ~A))))~%~%" str)
- (format p "(define (tester-2)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (outa i ~A)))~%" str)
- (format p " v))~%~%")
- (format p "(define (tester-3)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (outa i ~A)))~%" str)
- (format p " ;(file->array \"try-test.snd\" 0 0 10 v)~%")
- (format p " v))~%~%")
- (format p "(define (tester-4)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (v (make-float-vector 10))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (k 1)~%")
- (format p " (z 0.1))~%")
- (format p " (do ((i 0 (+ i 1))~%")
- (format p " (lst (make-list 10)))~%")
- (format p " ((= i 10) (apply float-vector lst))~%")
- (format p " (set! (lst i) ~A))))~%~%" str)
- (format p "(define (tester-5)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (y -0.5)~%")
- (format p " (k 1)~%")
- (format p " (z 0.1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1))~%")
- (format p " (x 0.0 (+ x 0.1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (outa i ~A)))~%" str)
- (format p " ;(file->array \"try-test.snd\" 0 0 10 v)~%")
- (format p " v))~%~%")
- (format p "(define (tester-6)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (do ((i 0 (+ i 1))~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (x 0.0 (+ x 0.1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (set! (v i) ~A))))~%~%" str)
-
- (format p "(define (tester-7)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (k 1)~%")
- (format p " (z 0.1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((zz ~A))~%" str)
- (format p " (set! (v i) (oscil o zz))))))~%")
- (format p "(define (tester-8)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((zz ~A))~%" str)
- (format p " (outa i (oscil o zz)))))~%")
- (format p " v))~%~%")
-
- (format p "(define (tester-9)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((zz ~A))~%" str)
- (format p " (set! (v i) (* (env e1) (oscil o zz)))))))~%")
- (format p "(define (tester-10)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (x 3.14)~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((zz ~A))~%" str)
- (format p " (outa i (* (env e1) (oscil o zz))))))~%")
- (format p " v))~%~%")
-
- (format p "(define (tester-11)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((x (oscil o)))~%")
- (format p " (set! (v i) ~A)))))~%" str)
- (format p "(define (tester-12)~%")
- (format p " (let ((o (make-oscil 1000.0))~%")
- (format p " (o1 (make-oscil 1000.0))~%")
- (format p " (o2 (make-oscil 1000.0))~%")
- (format p " (o3 (make-oscil 1000.0))~%")
- (format p " (o4 (make-oscil 1000.0))~%")
- (format p " (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
- (format p " (e1 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e2 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e3 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (e4 (make-env '(0 .1 1 1) :length 100))~%")
- (format p " (y -0.5)~%")
- (format p " (z 0.1)~%")
- (format p " (k 1)~%")
- (format p " (v (make-float-vector 10)))~%")
- (format p " (with-sound (v :clipped #f :to-snd #f)~%")
- (format p " (do ((i 0 (+ i 1)))~%")
- (format p " ((= i 10) v)~%")
- (format p " (let ((x (oscil o)))~%")
- (format p " (outa i ~A))))~%" str)
- (format p " v))~%~%")
-
- (format p "(let ((v1 (tester-1))~%")
- (format p " (v2 (tester-2))~%")
- (format p " (v3 (tester-3))~%")
- (format p " (v4 (tester-4))~%")
- (format p " (v5 (tester-5))~%")
- (format p " (v6 (tester-6))~%")
- (format p " (v7 (tester-7))~%")
- (format p " (v8 (tester-8))~%")
- (format p " (v9 (tester-9))~%")
- (format p " (v10 (tester-10))~%")
- (format p " (v11 (tester-11))~%")
- (format p " (v12 (tester-12)))~%")
- (format p " (if (or (not (vequal v0 v1)) (not (vequal v1 v2)) (not (vequal v1 v3)) (not (vequal v1 v4)))~%")
- (format p " (format *stderr* \"~A:~~% no do: ~~A~~% float-vector-set: ~~A~~% outa->v:~~A~~% outa: ~~A~~% list: ~~A~~%\" v0 v1 v2 v3 v4))~%" str)
- (format p " (if (not (vequal v5 v6))~%")
- (format p " (format *stderr* \"dox ~A:~~% float-vector-set: ~~A~~% outa->v:~~A~~%\" v5 v6))~%" str)
- (format p " (if (not (vequal v7 v8))~%")
- (format p " (format *stderr* \"let ~A:~~% ~~A~~% ~~A~~%\" v7 v8))~%" str)
- (format p " (if (not (vequal v9 v10))~%")
- (format p " (format *stderr* \"env let ~A:~~% ~~A~~% ~~A~~%\" v9 v10))~%~%" str)
- (format p " (if (not (vequal v11 v12))~%")
- (format p " (format *stderr* \"letx ~A:~~% ~~A~~% ~~A~~%\" v11 v12))))~%~%" str)))))
-
- (define (out-args)
-
- (for-each
- (lambda (a)
- (try (format #f "~A" a))
- (try (format #f "(oscil o ~A)" a))
- (try (format #f "(abs (oscil o ~A))" a))
- )
- args1)
-
- (for-each
- (lambda (a)
- (for-each
- (lambda (b)
- (try (format #f "(+ ~A ~A)" a b))
- (try (format #f "(- ~A ~A)" a b))
- (try (format #f "(* ~A ~A)" a b))
- (try (format #f "(cos (+ ~A ~A))" a b))
- (try (format #f "(sin (* ~A ~A))" a b))
- (try (format #f "(abs (* ~A ~A))" a b))
- (try (format #f "(* ~A (abs ~A))" a b))
- (try (format #f "(oscil o (+ ~A ~A))" a b))
- (try (format #f "(oscil o (* ~A ~A))" a b))
- (try (format #f "(+ ~A (oscil o ~A))" a b))
- (try (format #f "(* ~A (oscil o ~A))" a b))
- (try (format #f "(+ (oscil o ~A) ~A)" a b))
- (try (format #f "(* (oscil o ~A) ~A)" a b))
- (try (format #f "(oscil o ~A ~A)" a b))
- (try (format #f "(abs (oscil o ~A ~A))" a b))
- (try (format #f "(* (abs (oscil o ~A)) ~A)" a b))
- )
- args2))
- args1)
-
- (for-each
- (lambda (c)
- (for-each
- (lambda (b)
- (for-each
- (lambda (a)
- (try (format #f "(+ ~A ~A ~A)" a b c))
- (try (format #f "(+ (* ~A ~A) ~A)" a b c))
- (try (format #f "(+ ~A (* ~A ~A))" a b c))
- (try (format #f "(* ~A ~A ~A)" a b c))
- (try (format #f "(* ~A (+ ~A ~A))" a b c))
- (try (format #f "(* (+ ~A ~A) ~A)" a b c))
- (try (format #f "(oscil o (+ ~A ~A ~A))" a b c))
- (try (format #f "(oscil o (* ~A ~A ~A))" a b c))
- (try (format #f "(oscil o (* ~A (+ ~A ~A)))" a b c))
- (try (format #f "(oscil o (+ ~A (* ~A ~A)))" a b c))
- (try (format #f "(oscil o (* (+ ~A ~A) ~A))" a b c))
- (try (format #f "(oscil o (+ (* ~A ~A) ~A))" a b c))
- (try (format #f "(+ ~A (oscil o (+ ~A ~A)))" a b c))
- (try (format #f "(+ ~A (oscil o (* ~A ~A)))" a b c))
- (try (format #f "(* ~A (oscil o (+ ~A ~A)))" a b c))
- (try (format #f "(* ~A (oscil o (* ~A ~A)))" a b c))
-
- (try (format #f "(+ ~A ~A (oscil o ~A))" a b c))
- (try (format #f "(* ~A ~A (oscil o ~A))" a b c))
- (try (format #f "(+ (* ~A ~A) (oscil o ~A))" a b c))
- (try (format #f "(* (+ ~A ~A) (oscil o ~A))" a b c))
- (try (format #f "(+ ~A (* ~A (oscil o ~A)))" a b c))
- (try (format #f "(* ~A (+ ~A (oscil o ~A)))" a b c))
-
- (try (format #f "(+ ~A (oscil o ~A) ~A)" a b c))
- (try (format #f "(* ~A (oscil o ~A) ~A)" a b c))
- (try (format #f "(+ (* ~A (oscil o ~A)) ~A)" a b c))
- (try (format #f "(* (+ ~A (oscil o ~A)) ~A)" a b c))
- (try (format #f "(+ ~A (* (oscil o ~A) ~A))" a b c))
- (try (format #f "(* ~A (+ (oscil o ~A) ~A))" a b c))
-
- (try (format #f "(+ (oscil o ~A) ~A ~A)" a b c))
- (try (format #f "(+ (oscil o ~A) (* ~A ~A))" a b c))
- (try (format #f "(* (oscil o ~A) (+ ~A ~A))" a b c))
- (try (format #f "(* (oscil o ~A) ~A ~A)" a b c))
-
- (try (format #f "(+ ~A (abs ~A) ~A)" a b c))
- (try (format #f "(+ ~A (sin ~A) ~A)" a b c))
- (try (format #f "(+ ~A (cos ~A) ~A)" a b c))
- (try (format #f "(* (cos ~A) (oscil o ~A ~A))" a b c))
- (try (format #f "(+ (oscil o ~A ~A) ~A)" a b c))
- (try (format #f "(+ (abs (oscil o ~A ~A)) ~A)" a b c))
- (try (format #f "(+ (cos (oscil o ~A ~A)) ~A)" a b c))
- (try (format #f "(+ (sin (oscil o ~A ~A)) ~A)" a b c))
- )
- args3))
- args2))
- args1))
- (out-args)
- (set! *clm-file-buffer-size* old-size)
- )))
+ (when all-args
+ (let ((old-size *clm-file-buffer-size*))
+ (set! *clm-file-buffer-size* 100)
+ (set! *mus-float-equal-fudge-factor* 1e-4)
+ (define v-1 (make-float-vector 100 .25))
+ (do ((i 0 (+ i 1)) (x 0.0 (+ x .01))) ((= i 100)) (float-vector-set! v-1 i x))
+ (define v0 (make-float-vector 10))
+
+ (define args1 (list 1.5 '(oscil o1) '(env e1) 'x 'i '(oscil o) '(- 1.0 x) '(oscil (vector-ref oscs k))))
+ (define args2 (list 1.5 '(oscil o2) '(env e2) 'y 'i '(float-vector-ref v-1 i)))
+ (define args3 (list 1.5 '(oscil o3) '(env e3) 'z 'i '(cos x)))
+ ;(define args4 (list 1.5 '(oscil o4) '(env e4) 'x 'i))
+
+ (define (try str)
+ (eval-string
+ (call-with-output-string
+ (lambda (p)
+ (for-each (lambda (line)
+ (apply format p line))
+ (vector
+ `("(let ()~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (i 0)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (set! (v0 0) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 1) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 2) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 3) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 4) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 5) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 6) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 7) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 8) ~A) (set! i (+ i 1))~%" ,str)
+ `(" (set! (v0 9) ~A))~%" ,str)
+ `("(define (tester-1)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (set! (v i) ~A))))~%~%" ,str)
+ `("(define (tester-2)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (outa i ~A)))~%" ,str)
+ `(" v))~%~%")
+ `("(define (tester-3)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (outa i ~A)))~%" ,str)
+ `(" ;(file->array \"try-test.snd\" 0 0 10 v)~%")
+ `(" v))~%~%")
+ `("(define (tester-4)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (v (make-float-vector 10))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (k 1)~%")
+ `(" (z 0.1))~%")
+ `(" (do ((i 0 (+ i 1))~%")
+ `(" (lst (make-list 10)))~%")
+ `(" ((= i 10) (apply float-vector lst))~%")
+ `(" (set! (lst i) ~A))))~%~%" ,str)
+ `("(define (tester-5)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (y -0.5)~%")
+ `(" (k 1)~%")
+ `(" (z 0.1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1))~%")
+ `(" (x 0.0 (+ x 0.1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (outa i ~A)))~%" ,str)
+ `(" ;(file->array \"try-test.snd\" 0 0 10 v)~%")
+ `(" v))~%~%")
+ `("(define (tester-6)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (do ((i 0 (+ i 1))~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (x 0.0 (+ x 0.1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (set! (v i) ~A))))~%~%" ,str)
+
+ `("(define (tester-7)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (k 1)~%")
+ `(" (z 0.1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((zz ~A))~%" ,str)
+ `(" (set! (v i) (oscil o zz))))))~%")
+ `("(define (tester-8)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((zz ~A))~%" ,str)
+ `(" (outa i (oscil o zz)))))~%")
+ `(" v))~%~%")
+
+ `("(define (tester-9)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((zz ~A))~%" ,str)
+ `(" (set! (v i) (* (env e1) (oscil o zz)))))))~%")
+ `("(define (tester-10)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (x 3.14)~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((zz ~A))~%" ,str)
+ `(" (outa i (* (env e1) (oscil o zz))))))~%")
+ `(" v))~%~%")
+
+ `("(define (tester-11)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((x (oscil o)))~%")
+ `(" (set! (v i) ~A)))))~%" ,str)
+ `("(define (tester-12)~%")
+ `(" (let ((o (make-oscil 1000.0))~%")
+ `(" (o1 (make-oscil 1000.0))~%")
+ `(" (o2 (make-oscil 1000.0))~%")
+ `(" (o3 (make-oscil 1000.0))~%")
+ `(" (o4 (make-oscil 1000.0))~%")
+ `(" (oscs (vector (make-oscil 400.0) (make-oscil 500.0) (make-oscil 600.0)))~%")
+ `(" (e1 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e2 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e3 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (e4 (make-env '(0 .1 1 1) :length 100))~%")
+ `(" (y -0.5)~%")
+ `(" (z 0.1)~%")
+ `(" (k 1)~%")
+ `(" (v (make-float-vector 10)))~%")
+ `(" (with-sound (v :clipped #f :to-snd #f)~%")
+ `(" (do ((i 0 (+ i 1)))~%")
+ `(" ((= i 10) v)~%")
+ `(" (let ((x (oscil o)))~%")
+ `(" (outa i ~A))))~%" ,str)
+ `(" v))~%~%")
+
+ `("(let ((v1 (tester-1))~%")
+ `(" (v2 (tester-2))~%")
+ `(" (v3 (tester-3))~%")
+ `(" (v4 (tester-4))~%")
+ `(" (v5 (tester-5))~%")
+ `(" (v6 (tester-6))~%")
+ `(" (v7 (tester-7))~%")
+ `(" (v8 (tester-8))~%")
+ `(" (v9 (tester-9))~%")
+ `(" (v10 (tester-10))~%")
+ `(" (v11 (tester-11))~%")
+ `(" (v12 (tester-12)))~%")
+ `(" (if (or (not (vequal v0 v1)) (not (vequal v1 v2)) (not (vequal v1 v3)) (not (vequal v1 v4)))~%")
+ `(" (format *stderr* \"~A:~~% no do: ~~A~~% float-vector-set: ~~A~~% outa->v:~~A~~% outa: ~~A~~% list: ~~A~~%\" v0 v1 v2 v3 v4))~%" ,str)
+ `(" (if (not (vequal v5 v6))~%")
+ `(" (format *stderr* \"dox ~A:~~% float-vector-set: ~~A~~% outa->v:~~A~~%\" v5 v6))~%" ,str)
+ `(" (if (not (vequal v7 v8))~%")
+ `(" (format *stderr* \"let ~A:~~% ~~A~~% ~~A~~%\" v7 v8))~%" ,str)
+ `(" (if (not (vequal v9 v10))~%")
+ `(" (format *stderr* \"env let ~A:~~% ~~A~~% ~~A~~%\" v9 v10))~%~%" ,str)
+ `(" (if (not (vequal v11 v12))~%")
+ `(" (format *stderr* \"letx ~A:~~% ~~A~~% ~~A~~%\" v11 v12))))~%~%" ,str)))))))
+
+ (define (out-args)
+
+ (for-each
+ (lambda (a)
+ (try (format #f "~A" a))
+ (try (format #f "(oscil o ~A)" a))
+ (try (format #f "(abs (oscil o ~A))" a)))
+ args1)
+
+ (for-each
+ (lambda (a)
+ (for-each
+ (lambda (b)
+ (for-each try (vector (format #f "(+ ~A ~A)" a b)
+ (format #f "(- ~A ~A)" a b)
+ (format #f "(* ~A ~A)" a b)
+ (format #f "(cos (+ ~A ~A))" a b)
+ (format #f "(sin (* ~A ~A))" a b)
+ (format #f "(abs (* ~A ~A))" a b)
+ (format #f "(* ~A (abs ~A))" a b)
+ (format #f "(oscil o (+ ~A ~A))" a b)
+ (format #f "(oscil o (* ~A ~A))" a b)
+ (format #f "(+ ~A (oscil o ~A))" a b)
+ (format #f "(* ~A (oscil o ~A))" a b)
+ (format #f "(+ (oscil o ~A) ~A)" a b)
+ (format #f "(* (oscil o ~A) ~A)" a b)
+ (format #f "(oscil o ~A ~A)" a b)
+ (format #f "(abs (oscil o ~A ~A))" a b)
+ (format #f "(* (abs (oscil o ~A)) ~A)" a b))))
+ args2))
+ args1)
+
+ (for-each
+ (lambda (c)
+ (for-each
+ (lambda (b)
+ (for-each
+ (lambda (a)
+ (for-each try (vector (format #f "(+ ~A ~A ~A)" a b c)
+ (format #f "(+ (* ~A ~A) ~A)" a b c)
+ (format #f "(+ ~A (* ~A ~A))" a b c)
+ (format #f "(* ~A ~A ~A)" a b c)
+ (format #f "(* ~A (+ ~A ~A))" a b c)
+ (format #f "(* (+ ~A ~A) ~A)" a b c)
+ (format #f "(oscil o (+ ~A ~A ~A))" a b c)
+ (format #f "(oscil o (* ~A ~A ~A))" a b c)
+ (format #f "(oscil o (* ~A (+ ~A ~A)))" a b c)
+ (format #f "(oscil o (+ ~A (* ~A ~A)))" a b c)
+ (format #f "(oscil o (* (+ ~A ~A) ~A))" a b c)
+ (format #f "(oscil o (+ (* ~A ~A) ~A))" a b c)
+ (format #f "(+ ~A (oscil o (+ ~A ~A)))" a b c)
+ (format #f "(+ ~A (oscil o (* ~A ~A)))" a b c)
+ (format #f "(* ~A (oscil o (+ ~A ~A)))" a b c)
+ (format #f "(* ~A (oscil o (* ~A ~A)))" a b c)
+
+ (format #f "(+ ~A ~A (oscil o ~A))" a b c)
+ (format #f "(* ~A ~A (oscil o ~A))" a b c)
+ (format #f "(+ (* ~A ~A) (oscil o ~A))" a b c)
+ (format #f "(* (+ ~A ~A) (oscil o ~A))" a b c)
+ (format #f "(+ ~A (* ~A (oscil o ~A)))" a b c)
+ (format #f "(* ~A (+ ~A (oscil o ~A)))" a b c)
+
+ (format #f "(+ ~A (oscil o ~A) ~A)" a b c)
+ (format #f "(* ~A (oscil o ~A) ~A)" a b c)
+ (format #f "(+ (* ~A (oscil o ~A)) ~A)" a b c)
+ (format #f "(* (+ ~A (oscil o ~A)) ~A)" a b c)
+ (format #f "(+ ~A (* (oscil o ~A) ~A))" a b c)
+ (format #f "(* ~A (+ (oscil o ~A) ~A))" a b c)
+
+ (format #f "(+ (oscil o ~A) ~A ~A)" a b c)
+ (format #f "(+ (oscil o ~A) (* ~A ~A))" a b c)
+ (format #f "(* (oscil o ~A) (+ ~A ~A))" a b c)
+ (format #f "(* (oscil o ~A) ~A ~A)" a b c)
+
+ (format #f "(+ ~A (abs ~A) ~A)" a b c)
+ (format #f "(+ ~A (sin ~A) ~A)" a b c)
+ (format #f "(+ ~A (cos ~A) ~A)" a b c)
+ (format #f "(* (cos ~A) (oscil o ~A ~A))" a b c)
+ (format #f "(+ (oscil o ~A ~A) ~A)" a b c)
+ (format #f "(+ (abs (oscil o ~A ~A)) ~A)" a b c)
+ (format #f "(+ (cos (oscil o ~A ~A)) ~A)" a b c)
+ (format #f "(+ (sin (oscil o ~A ~A)) ~A)" a b c))))
+ args3))
+ args2))
+ args1))
+ (out-args)
+ (set! *clm-file-buffer-size* old-size)
+ )))
@@ -40763,9 +40039,8 @@ EDITS: 1
((sampler-at-end? rd))
(outa samp (src s incr))
(if (= (modulo samp 2205) 0)
- (set! incr (+ 2.0 (oscil o)))))))
- (len (mus-sound-framples tempfile)))
- (set-samples 0 (- len 1) tempfile #f #f #t "step-src" 0 #f #t)))
+ (set! incr (+ 2.0 (oscil o))))))))
+ (set-samples 0 (- (mus-sound-framples tempfile) 1) tempfile #f #f #t "step-src" 0 #f #t)))
(define* (clm-reverb-sound reverb-amount reverb (reverb-data ()) snd)
(let ((output (snd-tempnam))
@@ -40907,82 +40182,6 @@ EDITS: 1
((= i end))
(flocsig floc i (pulse-train os)))))
-
- (define (test-ws-errors)
- ;; since we only catch 'mus-error and 'with-sound-interrupt above, any other error
- ;; closes *output* and returns to the top-level
-
- (define (bad-ins start)
- (set! (playing) #f))
-
- (let ((prev (find-sound "test.snd")))
- (if (sound? prev)
- (close-sound prev)))
-
- (if (mus-output? *output*)
- (begin
- (snd-display #__line__ ";ws-error start: *output*: ~A" *output*)
- (mus-close *output*)
- (set! *output* #f)))
-
-
- ;; ---------------- catch 'wrong-type-arg (not handled by with-sound) ----------------
-
- (let ((tag (catch #t
- (lambda ()
- (with-sound ("test.snd")
- (fm-violin 0 1 440 .1)
- (fm-violin .1 1 660 .1)
- (fm-violin .2 1 880 .1)
- (fm-violin .3 1 -220 .1)))
- (lambda args args))))
-
- (if (or (not (list? tag))
- (not (eq? (car tag) 'wrong-type-arg)))
- (snd-display #__line__ ";ws-error -220: ~A" tag))
- (if (mus-output? *output*)
- (begin
- (snd-display #__line__ ";ws-error -220: *output*: ~A" *output*)
- (mus-close *output*)
- (set! *output* #f)))
- (let ((prev (find-sound "test.snd")))
- (if (sound? prev)
- (begin
- (snd-display #__line__ ";ws error -220 opened test.snd?")
- (close-sound prev)))))
-
-
- ;; ---------------- catch 'mus-error (handled by with-sound, but no continuation -- appears to exit after cleaning up) ----------------
-
- (snd-display #__line__ ";error printout expected.....")
-
- (let ((tag (catch #t
- (lambda ()
- (with-sound ("test.snd")
- (fm-violin 0 1 440 .1)
- (fm-violin .1 1 660 .1)
- (fm-violin .2 1 880 .1)
- (fm-violin .3 1 220 .1 :amp-env '(0 0 1 1 .5 1 0 0))))
- (lambda args args))))
-
- (if (or (not (string? tag))
- (not (string=? tag "test.snd")))
- (snd-display #__line__ ";ws-error bad env: ~A" tag))
- (if (mus-output? *output*)
- (begin
- (snd-display #__line__ ";ws-error bad env: *output*: ~A" *output*)
- (mus-close *output*)
- (set! *output* #f)))
- (let ((prev (find-sound "test.snd")))
- (if (not (sound? prev))
- (snd-display #__line__ ";ws error bad env did not open test.snd?")
- (close-sound prev))))
-
- (if (sound? (find-sound "test.snd"))
- (close-sound (find-sound "test.snd")))
- (delete-file "test.snd")
- )
-
(dismiss-all-dialogs)
(do ((clmtest 0 (+ 1 clmtest))) ((= clmtest tests))
@@ -40993,15 +40192,15 @@ EDITS: 1
;; check clm output for bad zero case
(for-each
(lambda (type)
- (let ((ind (find-sound
- (with-sound (:sample-type type :srate 22050)
- (fm-violin 0 .1 440 .1)
- (fm-violin 10 .1 440 .1)
- (fm-violin 100 .1 440 .1)
- (fm-violin 250 .1 440 .1)))))
- (let ((mx (maxamp ind)))
- (if (ffneq mx .1) ; mus-byte -> 0.093
- (snd-display #__line__ ";max: ~A, format: ~A" mx (mus-sample-type->string type))))))
+ (let* ((ind (find-sound
+ (with-sound (:sample-type type :srate 22050)
+ (fm-violin 0 .1 440 .1)
+ (fm-violin 10 .1 440 .1)
+ (fm-violin 100 .1 440 .1)
+ (fm-violin 250 .1 440 .1))))
+ (mx (maxamp ind)))
+ (if (ffneq mx .1) ; mus-byte -> 0.093
+ (snd-display ";max: ~A, format: ~A" mx (mus-sample-type->string type)))))
(list mus-bshort mus-lshort mus-mulaw mus-alaw mus-byte
mus-lfloat mus-bint mus-lint mus-b24int mus-l24int
mus-ubshort mus-ulshort mus-ubyte mus-bfloat mus-bdouble
@@ -41010,141 +40209,140 @@ EDITS: 1
(with-sound () (fm-violin 0 .1 440 .1))
(with-sound (:continue-old-file #t) (fm-violin .2 .1 660 .04))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp ind 0) .1) (snd-display #__line__ ";maxamp after continued sound: ~A" (maxamp ind 0)))
- (if (fneq (/ (framples ind) (srate ind)) .3) (snd-display #__line__ ";duration after continued sound: ~A" (/ (framples ind) (srate ind))))
+ (if (fneq (maxamp ind 0) .1) (snd-display ";maxamp after continued sound: ~A" (maxamp ind 0)))
+ (if (fneq (/ (framples ind) (srate ind)) .3) (snd-display ";duration after continued sound: ~A" (/ (framples ind) (srate ind))))
(close-sound ind))
(with-sound (:srate 22050 :channels 2 :output "test1.snd") (fm-violin 0 .1 440 .1 :degree 45.0))
(let ((ind (find-sound "test1.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound (1): ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound (1): ~A" (map file-name (sounds))))
(let ((mx (maxamp)))
- (if (fneq mx .05) (snd-display #__line__ ";with-sound max (1): ~A" (maxamp)))
- (if (or (not (= (srate ind) 22050))
- (not (= (mus-sound-srate "test1.snd") 22050)))
- (snd-display #__line__ ";with-sound srate (1): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (and (not (= (framples ind) 2205))
- (not (= (framples ind) 2206)))
- (snd-display #__line__ ";with-sound framples (1): ~A" (framples ind)))
- (if (or (not (= (chans ind) 2))
- (not (= (mus-sound-chans "test1.snd") 2)))
- (snd-display #__line__ ";with-sound chans (1): ~A" (chans ind))))
+ (if (fneq mx .05) (snd-display ";with-sound max (1): ~A" (maxamp))))
+ (if (not (and (= (srate ind) 22050)
+ (= (mus-sound-srate "test1.snd") 22050)))
+ (snd-display ";with-sound srate (1): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
+ (if (not (member (framples ind) '(2205 2206) =))
+ (snd-display ";with-sound framples (1): ~A" (framples ind)))
+ (if (not (and (= (chans ind) 2)
+ (= (mus-sound-chans "test1.snd") 2)))
+ (snd-display ";with-sound chans (1): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 48000 :channels 2 :header-type mus-riff :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (or (not (= (srate ind) 48000))
- (not (= (mus-sound-srate "test1.snd") 48000)))
- (snd-display #__line__ ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-riff)) (snd-display #__line__ ";with-sound type (~A, r): ~A" mus-riff (header-type ind)))
- (if (not (= (chans ind) 2)) (snd-display #__line__ ";with-sound chans (2, r): ~A" (chans ind)))
+ (if (not (and (= (srate ind) 48000)
+ (= (mus-sound-srate "test1.snd") 48000)))
+ (snd-display ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
+ (if (not (= (header-type ind) mus-riff)) (snd-display ";with-sound type (~A, r): ~A" mus-riff (header-type ind)))
+ (if (not (= (chans ind) 2)) (snd-display ";with-sound chans (2, r): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 48000 :channels 2 :header-type mus-rf64 :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (or (not (= (srate ind) 48000))
- (not (= (mus-sound-srate "test1.snd") 48000)))
- (snd-display #__line__ ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-rf64)) (snd-display #__line__ ";with-sound type (~A, r): ~A" mus-rf64 (header-type ind)))
- (if (not (= (chans ind) 2)) (snd-display #__line__ ";with-sound chans (2, r): ~A" (chans ind)))
+ (if (not (and (= (srate ind) 48000)
+ (= (mus-sound-srate "test1.snd") 48000)))
+ (snd-display ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
+ (if (not (= (header-type ind) mus-rf64)) (snd-display ";with-sound type (~A, r): ~A" mus-rf64 (header-type ind)))
+ (if (not (= (chans ind) 2)) (snd-display ";with-sound chans (2, r): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 48000 :channels 2 :header-type mus-caff :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (or (not (= (srate ind) 48000))
- (not (= (mus-sound-srate "test1.snd") 48000)))
- (snd-display #__line__ ";with-sound mus-caff srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-caff)) (snd-display #__line__ ";with-sound type (~A, r): ~A" mus-caff (header-type ind)))
- (if (not (= (chans ind) 2)) (snd-display #__line__ ";with-sound mus-caff chans (2, r): ~A" (chans ind)))
+ (if (not (and (= (srate ind) 48000)
+ (= (mus-sound-srate "test1.snd") 48000)))
+ (snd-display ";with-sound mus-caff srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
+ (if (not (= (header-type ind) mus-caff)) (snd-display ";with-sound type (~A, r): ~A" mus-caff (header-type ind)))
+ (if (not (= (chans ind) 2)) (snd-display ";with-sound mus-caff chans (2, r): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 8000 :channels 3 :header-type mus-next :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (= (srate ind) 8000)) (snd-display #__line__ ";with-sound srate (8000, s): ~A (~A, ~A)"
+ (if (not (= (srate ind) 8000)) (snd-display ";with-sound srate (8000, s): ~A (~A, ~A)"
(srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-next)) (snd-display #__line__ ";with-sound type (~A, s): ~A" mus-next (header-type ind)))
- (if (not (= (chans ind) 3)) (snd-display #__line__ ";with-sound chans (3, s): ~A" (chans ind)))
+ (if (not (= (header-type ind) mus-next)) (snd-display ";with-sound type (~A, s): ~A" mus-next (header-type ind)))
+ (if (not (= (chans ind) 3)) (snd-display ";with-sound chans (3, s): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 96000 :channels 4 :header-type mus-aifc :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (= (srate ind) 96000)) (snd-display #__line__ ";with-sound srate (96000, t): ~A (~A, ~A)"
+ (if (not (= (srate ind) 96000)) (snd-display ";with-sound srate (96000, t): ~A (~A, ~A)"
(srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-aifc)) (snd-display #__line__ ";with-sound type (~A, t): ~A" mus-aifc (header-type ind)))
- (if (not (= (chans ind) 4)) (snd-display #__line__ ";with-sound chans (4, t): ~A" (chans ind)))
+ (if (not (= (header-type ind) mus-aifc)) (snd-display ";with-sound type (~A, t): ~A" mus-aifc (header-type ind)))
+ (if (not (= (chans ind) 4)) (snd-display ";with-sound chans (4, t): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 22050 :channels 1 :header-type mus-raw :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (= (srate ind) 22050)) (snd-display #__line__ ";with-sound srate (22050, u): ~A (~A, ~A)"
+ (if (not (= (srate ind) 22050)) (snd-display ";with-sound srate (22050, u): ~A (~A, ~A)"
(srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
- (if (not (= (header-type ind) mus-raw)) (snd-display #__line__ ";with-sound type (~A, u): ~A" mus-raw (header-type ind)))
- (if (not (= (chans ind) 1)) (snd-display #__line__ ";with-sound chans (1, u): ~A" (chans ind)))
+ (if (not (= (header-type ind) mus-raw)) (snd-display ";with-sound type (~A, u): ~A" mus-raw (header-type ind)))
+ (if (not (= (chans ind) 1)) (snd-display ";with-sound chans (1, u): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 22050 :channels 2 :output "test1.snd" :reverb jc-reverb)
(if (not (= (mus-sound-srate (mus-file-name *output*)) 22050))
- (snd-display #__line__ ";srate file *output*: ~A" (mus-sound-srate (mus-file-name *output*))))
+ (snd-display ";srate file *output*: ~A" (mus-sound-srate (mus-file-name *output*))))
(if (not (= (mus-sound-srate (mus-file-name *reverb*)) 22050))
- (snd-display #__line__ ";srate file *reverb*: ~A" (mus-sound-srate (mus-file-name *reverb*))))
+ (snd-display ";srate file *reverb*: ~A" (mus-sound-srate (mus-file-name *reverb*))))
(fm-violin 0 .1 440 .1 :degree 45.0))
(let ((ind (find-sound "test1.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound (2): ~A" (map file-name (sounds)))
- (if (> (- (framples ind) (+ 22050 2205)) 1) (snd-display #__line__ ";with-sound reverbed framples (2): ~A" (framples ind))))
+ (if (not ind) (snd-display ";with-sound (2): ~A" (map file-name (sounds)))
+ (if (> (- (framples ind) 24255) 1) (snd-display ";with-sound reverbed framples (2): ~A" (framples ind))))
(close-sound ind))
(with-sound (:srate 22050 :comment "Snd+Run!" :scaled-to .5) (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound: ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound: ~A" (map file-name (sounds))))
(let ((mx (maxamp)))
- (if (fneq mx .5) (snd-display #__line__ ";with-sound scaled-to: ~A" (maxamp)))
- (if (not (string=? (comment ind) "Snd+Run!")) (snd-display #__line__ ";with-sound comment: ~A (~A)" (comment ind) (mus-sound-comment "test.snd"))))
+ (if (fneq mx .5) (snd-display ";with-sound scaled-to: ~A" (maxamp)))
+ (if (not (string=? (comment ind) "Snd+Run!")) (snd-display ";with-sound comment: ~A (~A)" (comment ind) (mus-sound-comment "test.snd"))))
(close-sound ind))
(with-sound (:scaled-to .9 :channels 2) (fm-violin 0 .1 440 1.5 :degree 90))
(let ((ind (find-sound "test.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound: ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound: ~A" (map file-name (sounds))))
(let ((mx0 (maxamp ind 0))
(mx1 (maxamp ind 1)))
(if (> (max mx0 mx1) .9)
- (snd-display #__line__ ";with-sound scaled-to: ~A" (maxamp))))
+ (snd-display ";with-sound scaled-to: ~A" (maxamp))))
(close-sound ind))
(with-sound (:scaled-to .9 :channels 2) (fm-violin 0 .1 440 1.5 :degree 0))
(let ((ind (find-sound "test.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound: ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound: ~A" (map file-name (sounds))))
(let ((mx0 (maxamp ind 0))
(mx1 (maxamp ind 1)))
(if (> (max mx0 mx1) .9)
- (snd-display #__line__ ";with-sound scaled-to: ~A" (maxamp))))
+ (snd-display ";with-sound scaled-to: ~A" (maxamp))))
(close-sound ind))
(with-sound (:srate 22050 :scaled-by .5 :header-type mus-aifc :sample-type mus-bfloat) (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound: ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound: ~A" (map file-name (sounds))))
(let ((mx (maxamp)))
- (if (fneq mx .05) (snd-display #__line__ ";with-sound scaled-by: ~A" (maxamp)))
- (if (not (= (header-type ind) mus-aifc)) (snd-display #__line__ ";with-sound type: ~A (~A)" (header-type ind) (mus-header-type-name (header-type ind))))
- (if (not (= (sample-type ind) mus-bfloat)) (snd-display #__line__ ";with-sound format: ~A (~A)" (sample-type ind) (mus-sample-type-name (sample-type ind)))))
+ (if (fneq mx .05) (snd-display ";with-sound scaled-by: ~A" (maxamp)))
+ (if (not (= (header-type ind) mus-aifc)) (snd-display ";with-sound type: ~A (~A)" (header-type ind) (mus-header-type-name (header-type ind))))
+ (if (not (= (sample-type ind) mus-bfloat)) (snd-display ";with-sound format: ~A (~A)" (sample-type ind) (mus-sample-type-name (sample-type ind)))))
(close-sound ind))
(hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) (list 1 22050 mus-bshort))))
(with-sound (:header-type mus-raw) (fm-violin 0 1 440 .1))
(set! (hook-functions open-raw-sound-hook) ())
(let ((ind (find-sound "test.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound (raw out): ~A" (map file-name (sounds))))
+ (if (not ind) (snd-display ";with-sound (raw out): ~A" (map file-name (sounds))))
(if (not (= (header-type ind) mus-raw))
- (snd-display #__line__ ";with-sound type raw: ~A (~A)" (header-type ind) (mus-header-type-name (header-type ind))))
- (if (and (not (= (sample-type ind) mus-bshort))
- (not (= (sample-type ind) mus-bfloat))
- (not (= (sample-type ind) mus-lfloat)))
- (snd-display #__line__ ";with-sound format raw: ~A (~A)" (sample-type ind) (mus-sample-type-name (sample-type ind))))
+ (snd-display ";with-sound type raw: ~A (~A)" (header-type ind) (mus-header-type-name (header-type ind))))
+ (if (not (or (= (sample-type ind) mus-bshort)
+ (= (sample-type ind) mus-bfloat)
+ (= (sample-type ind) mus-lfloat)))
+ (snd-display ";with-sound format raw: ~A (~A)" (sample-type ind) (mus-sample-type-name (sample-type ind))))
(close-sound ind))
(with-sound (:srate 44100 :statistics #t) (ws-sine 1000))
@@ -41155,7 +40353,7 @@ EDITS: 1
(and (< i 100)
(fneq y (sin (* 2 pi i (/ 1000.0 44100.0))))
(begin
- (format #t "~%;with-sound sine: ~D ~A ~A" i y (sin (* 2 pi i (/ 1000.0 44100.0))))
+ (format () "~%;with-sound sine: ~D ~A ~A" i y (sin (* 2 pi i (/ 1000.0 44100.0))))
#t)))))
(close-sound ind))
@@ -41172,20 +40370,20 @@ EDITS: 1
(let ((ind (find-sound "test.snd")))
(if (> (abs (- (framples ind) 144100)) 2)
- (snd-display #__line__ ";with-sound make-oscil framples: ~A" (framples)))
+ (snd-display ";with-sound make-oscil framples: ~A" (framples)))
(if (fneq (maxamp ind) .1)
- (snd-display #__line__ ";with-sound make-oscil maxamp: ~A" (maxamp ind)))
+ (snd-display ";with-sound make-oscil maxamp: ~A" (maxamp ind)))
(close-sound ind))
(let ((old-srate *clm-srate*))
(with-sound ()
(if (not (= old-srate *clm-srate*))
- (format #t ";srates: ~A ~A~%" old-srate, *clm-srate*))
+ (format () ";srates: ~A ~A~%" old-srate, *clm-srate*))
(with-sound (:srate 12345)
(if (not (= *clm-srate* 12345))
- (format #t ";clm-srate: ~A (12345)~%" *clm-srate*)))
+ (format () ";clm-srate: ~A (12345)~%" *clm-srate*)))
(if (not (= old-srate *clm-srate*))
- (format #t ";returned srates: ~A ~A~%" old-srate, *clm-srate*))))
+ (format () ";returned srates: ~A ~A~%" old-srate, *clm-srate*))))
(for-each close-sound (sounds))
(if (file-exists? "ii.scm")
@@ -41196,39 +40394,39 @@ EDITS: 1
(delete-file "test.rev")))
(let ((var (make-st1 :one 1 :two 2)))
- (if (not (= (var 'one) 1)) (snd-display #__line__ ";st1-one: ~A" (var 'one)))
- (if (not (= (var 'two) 2)) (snd-display #__line__ ";st1-two: ~A" (var 'two)))
- (if (not (st1? var)) (snd-display #__line__ ";st1? ~A (~A)" (st1? var) var))
+ (if (not (= (var 'one) 1)) (snd-display ";st1-one: ~A" (var 'one)))
+ (if (not (= (var 'two) 2)) (snd-display ";st1-two: ~A" (var 'two)))
+ (if (not (st1? var)) (snd-display ";st1? ~A (~A)" (st1? var) var))
(set! (var 'one) 321)
(set! (var 'two) "hiho")
- (if (not (= (var 'one) 321)) (snd-display #__line__ ";st1-one (321): ~A" (var 'one)))
- (if (not (string=? (var 'two) "hiho")) (snd-display #__line__ ";st1-two (hiho): ~A" (var 'two)))
+ (if (not (= (var 'one) 321)) (snd-display ";st1-one (321): ~A" (var 'one)))
+ (if (not (string=? (var 'two) "hiho")) (snd-display ";st1-two (hiho): ~A" (var 'two)))
(set! var (make-st1))
- (if (fneq (var 'one) 0.0) (snd-display #__line__ ";st1-one #f: ~A" (var 'one)))
- (if (fneq (var 'two) 0.0) (snd-display #__line__ ";st1-two #f: ~A" (var 'two)))
+ (if (fneq (var 'one) 0.0) (snd-display ";st1-one #f: ~A" (var 'one)))
+ (if (fneq (var 'two) 0.0) (snd-display ";st1-two #f: ~A" (var 'two)))
(set! var (make-st1 :two 3))
- (if (fneq (var 'one) 0.0) (snd-display #__line__ ";st1-one #f (def): ~A" (var 'one)))
- (if (not (= (var 'two) 3)) (snd-display #__line__ ";st1-two (3): ~A" (var 'two))))
+ (if (fneq (var 'one) 0.0) (snd-display ";st1-one #f (def): ~A" (var 'one)))
+ (if (not (= (var 'two) 3)) (snd-display ";st1-two (3): ~A" (var 'two))))
(let ((var (make-st2 :one 1 :two 2)))
- (if (not (= (var 'one) 1)) (snd-display #__line__ ";st2-one: ~A" (var 'one)))
- (if (not (= (var 'two) 2)) (snd-display #__line__ ";st2-two: ~A" (var 'two)))
- (if (not (st2? var)) (snd-display #__line__ ";st2? ~A (~A)" (st1? var) var))
- (if (st1? var) (snd-display #__line__ ";st1? (not ~A): ~A" (st1? var) var))
+ (if (not (= (var 'one) 1)) (snd-display ";st2-one: ~A" (var 'one)))
+ (if (not (= (var 'two) 2)) (snd-display ";st2-two: ~A" (var 'two)))
+ (if (not (st2? var)) (snd-display ";st2? ~A (~A)" (st1? var) var))
+ (if (st1? var) (snd-display ";st1? (not ~A): ~A" (st1? var) var))
(set! (var 'one) 321)
(set! (var 'two) "hiho")
- (if (not (= (var 'one) 321)) (snd-display #__line__ ";st2-one (321): ~A" (var 'one)))
- (if (not (string=? (var 'two) "hiho")) (snd-display #__line__ ";st2-two (hiho): ~A" (var 'two)))
+ (if (not (= (var 'one) 321)) (snd-display ";st2-one (321): ~A" (var 'one)))
+ (if (not (string=? (var 'two) "hiho")) (snd-display ";st2-two (hiho): ~A" (var 'two)))
(set! var (make-st2))
- (if (not (= (var 'one) 11)) (snd-display #__line__ ";st2-one 11: ~A" (var 'one)))
- (if (not (= (var 'two) 22)) (snd-display #__line__ ";st2-two 22: ~A" (var 'two)))
+ (if (not (= (var 'one) 11)) (snd-display ";st2-one 11: ~A" (var 'one)))
+ (if (not (= (var 'two) 22)) (snd-display ";st2-two 22: ~A" (var 'two)))
(set! var (make-st2 :two 3))
- (if (not (= (var 'one) 11)) (snd-display #__line__ ";st2-one 11 (def): ~A" (var 'one)))
- (if (not (= (var 'two) 3)) (snd-display #__line__ ";st2-two (3): ~A" (var 'two))))
+ (if (not (= (var 'one) 11)) (snd-display ";st2-one 11 (def): ~A" (var 'one)))
+ (if (not (= (var 'two) 3)) (snd-display ";st2-two (3): ~A" (var 'two))))
(let ((gad (make-grab-bag)))
(if (not (= (gad 'i) 0))
- (snd-display #__line__ ";grab-bag-i: ~A" (gad 'i)))
+ (snd-display ";grab-bag-i: ~A" (gad 'i)))
(set! (gad 'flt) 123.0)
(set! (gad 'v) (float-vector .1 .2 .3))
(set! (gad 'fvect) (vector .1 .2 .3))
@@ -41238,20 +40436,19 @@ EDITS: 1
((= i 3))
(vector-set! (gad 'cvect) i (make-oscil 440.0)))
(set! (gad 'gen) (make-oscil 440.0))
- (let ((val 0.0))
- (set! val (gad 'flt))
- (if (fneq val 123.0) (snd-display #__line__ ";defgenerator flt: ~A ~A" val (gad 'flt))))
- (if (fneq (gad 'flt1) 1.0) (snd-display #__line__ ";defgenerator flt1: ~A" (gad 'flt1)))
- (if (not (= (gad 'i) 0)) (snd-display #__line__ ";defgenerator i: ~A" (gad 'i)))
- (if (not (= (gad 'i1) 123)) (snd-display #__line__ ";defgenerator i1: ~A" (gad 'i1))))
+ (let ((val (gad 'flt)))
+ (if (fneq val 123.0) (snd-display ";defgenerator flt: ~A ~A" val (gad 'flt))))
+ (if (fneq (gad 'flt1) 1.0) (snd-display ";defgenerator flt1: ~A" (gad 'flt1)))
+ (if (not (= (gad 'i) 0)) (snd-display ";defgenerator i: ~A" (gad 'i)))
+ (if (not (= (gad 'i1) 123)) (snd-display ";defgenerator i1: ~A" (gad 'i1))))
(let ()
(defgenerator (g1 :methods (list (cons 'g1-method (lambda (g) 440)))))
(let ((g (make-g1)))
(if (not (g1? g))
- (format #t ";not g1: ~A~%" (reverse (map values g))))
+ (format () ";not g1: ~A~%" (reverse (map values g))))
(if (not (= ((g 'g1-method) g) 440))
- (format #t ";g1-method: ~A~%" ((g 'g1-method) g)))))
+ (format () ";g1-method: ~A~%" ((g 'g1-method) g)))))
(if (file-exists? "test.snd") (delete-file "test.snd"))
(set! *clm-srate* 22050)
@@ -41260,11 +40457,11 @@ EDITS: 1
(sound-let ((a () (fm-violin 0 .1 440 .1)))
(mus-file-mix *output* a)))))
(if (not (string=? outer "test.snd"))
- (snd-display #__line__ ";with-sound returns: ~A" outer))
+ (snd-display ";with-sound returns: ~A" outer))
(let ((ind (find-sound outer)))
- (if (or (not (sound? ind))
- (> (- (framples ind) (floor (* *clm-srate* .1))) 1))
- (snd-display #__line__ ";sound-let: ~A ~A" (framples ind) (floor (* *clm-srate* .1))))
+ (if (not (and (sound? ind)
+ (<= (- (framples ind) (floor (* *clm-srate* .1))) 1)))
+ (snd-display ";sound-let: ~A ~A" (framples ind) (floor (* *clm-srate* .1))))
(close-sound ind)))
(if (file-exists? "test.snd") (delete-file "test.snd"))
@@ -41275,54 +40472,54 @@ EDITS: 1
(sound-let ((c (:channels 1 :output "temp.snd") (fm-violin 0 .1 110.0 .1)))
(mus-file-mix *output* c))))))
(if (not (string=? outer "test.snd"))
- (snd-display #__line__ ";with-sound (2) returns: ~A" outer))
+ (snd-display ";with-sound (2) returns: ~A" outer))
(let ((ind (find-sound outer)))
(if (or (not (sound? ind))
- (> (- (framples ind) (+ 100 (floor (* *clm-srate* .1)))) 1))
- (snd-display #__line__ ";sound-let (2): ~A ~A" (framples ind) (+ 100 (floor (* *clm-srate* .1)))))
+ (> (- (framples ind) 100 (floor (* *clm-srate* .1))) 1))
+ (snd-display ";sound-let (2): ~A ~A" (framples ind) (+ 100 (floor (* *clm-srate* .1)))))
(if (file-exists? "temp.snd")
- (snd-display #__line__ ";sound-let explicit output exists?"))
+ (snd-display ";sound-let explicit output exists?"))
(close-sound ind)))
(let ((w (init-with-sound)))
(fm-violin 0 1 440 .1)
(let ((outer (finish-with-sound w)))
(if (not (string=? outer "test.snd"))
- (snd-display #__line__ ";finish-with-sound returns: ~A" outer))
+ (snd-display ";finish-with-sound returns: ~A" outer))
(let ((ind (find-sound outer)))
(if (not (sound? ind))
- (snd-display #__line__ ";init-with-sound: ~A" (map short-file-name (sounds)))
+ (snd-display ";init-with-sound: ~A" (map short-file-name (sounds)))
(begin
(if (fneq (maxamp ind 0) .1)
- (snd-display #__line__ ";init-with-sound max: ~A" (maxamp ind 0)))
+ (snd-display ";init-with-sound max: ~A" (maxamp ind 0)))
(close-sound ind))))))
(let ((w (init-with-sound :output "test.aiff" :header-type mus-aifc :scaled-to .5)))
(fm-violin 0 1 440 .1)
(let ((outer (finish-with-sound w)))
(if (not (string=? outer "test.aiff"))
- (snd-display #__line__ ";finish-with-sound (2) returns: ~A ~A" outer w))
+ (snd-display ";finish-with-sound (2) returns: ~A ~A" outer w))
(let ((ind (find-sound outer)))
(if (not (sound? ind))
- (snd-display #__line__ ";init-with-sound (2): ~A" (map short-file-name (sounds)))
+ (snd-display ";init-with-sound (2): ~A" (map short-file-name (sounds)))
(begin
(if (fneq (maxamp ind 0) .5)
- (snd-display #__line__ ";init-with-sound scaled-to: ~A ~A" (maxamp ind 0) w))
+ (snd-display ";init-with-sound scaled-to: ~A ~A" (maxamp ind 0) w))
(if (not (= (header-type ind) mus-aifc))
- (snd-display #__line__ ";init-with-sound type: ~A ~A" (header-type ind) w))
+ (snd-display ";init-with-sound type: ~A ~A" (header-type ind) w))
(close-sound ind))))))
(with-sound ("test1.snd" :reverb freeverb :reverb-data '(:output-gain 3.0)) (fm-violin 0 .1 440 .1 :reverb-amount .1))
(let ((ind (find-sound "test1.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound (freeverb): ~A" (map file-name (sounds))))
- (if (<= (maxamp ind) .1) (snd-display #__line__ ";freeverb 3.0: ~A" (maxamp ind)))
+ (if (not ind) (snd-display ";with-sound (freeverb): ~A" (map file-name (sounds))))
+ (if (<= (maxamp ind) .1) (snd-display ";freeverb 3.0: ~A" (maxamp ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound ("test1.snd" :reverb freeverb :reverb-data '(:output-gain 3.0 :global 0.5)) (fm-violin 0 .1 440 .1 :reverb-amount .1))
(let ((ind (find-sound "test1.snd")))
- (if (not ind) (snd-display #__line__ ";with-sound (freeverb): ~A" (map file-name (sounds))))
- (if (<= (maxamp ind) .16) (snd-display #__line__ ";freeverb 3.0 global 0.5: ~A" (maxamp ind)))
+ (if (not ind) (snd-display ";with-sound (freeverb): ~A" (map file-name (sounds))))
+ (if (<= (maxamp ind) .16) (snd-display ";freeverb 3.0 global 0.5: ~A" (maxamp ind)))
(close-sound ind)
(delete-file "test1.snd"))
@@ -41523,31 +40720,31 @@ EDITS: 1
(with-sound (:channels 2)
(fullmix "4.aiff" 0.0 0.1 36.4 '((0.0 0.0) (0.0 0.0) (1.0 0.0) (0.0 1.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.8865) (snd-display #__line__ ";4->2(0) fullmix: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.8865) (snd-display ";4->2(0) fullmix: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 1)
(fullmix "4.aiff" 0.0 0.1 36.4 '((1.0) (0.0) (0.0) (0.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.221649169921875) (snd-display #__line__ ";4->1(0) fullmix: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.221649169921875) (snd-display ";4->1(0) fullmix: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 1)
(fullmix "4.aiff" 0.0 0.1 36.4 '((0.0) (1.0) (0.0) (0.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.44329833984375) (snd-display #__line__ ";4->1(1) fullmix: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.44329833984375) (snd-display ";4->1(1) fullmix: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 1)
(fullmix "4.aiff" 0.0 0.1 36.4 '((0.0) (0.0) (1.0) (0.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.664947509765625) (snd-display #__line__ ";4->1(2) fullmix: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.664947509765625) (snd-display ";4->1(2) fullmix: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 1)
(fullmix "4.aiff" 0.0 0.1 36.4 '((0.0) (0.0) (0.0) (1.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.8865966796875) (snd-display #__line__ ";4->1(3) fullmix: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.8865966796875) (snd-display ";4->1(3) fullmix: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 2)
@@ -41556,7 +40753,7 @@ EDITS: 1
(mxs (maxamp ind #t)))
(if (or (fneq (car mxs) 0.664947509765625)
(fneq (cadr mxs) 0.8865966796875))
- (snd-display #__line__ ";4->2(1) fullmix: ~A" mxs))
+ (snd-display ";4->2(1) fullmix: ~A" mxs))
(close-sound ind))
(with-sound (:channels 2)
@@ -41565,7 +40762,7 @@ EDITS: 1
(mxs (maxamp ind #t)))
(if (or (fneq (car mxs) 0.8865966796875)
(fneq (cadr mxs) 0.664947509765625))
- (snd-display #__line__ ";4->2(2) fullmix: ~A" mxs))
+ (snd-display ";4->2(2) fullmix: ~A" mxs))
(close-sound ind))
(with-sound (:channels 2 :reverb nrev)
@@ -41582,24 +40779,24 @@ EDITS: 1
(fullmix "pistol.snd")
(fullmix "oboe.snd" 1 2 0 (list (list .1 (make-env '(0 0 1 1) :duration 2 :scaler .5)))))
(let ((ind (find-sound "test.snd")))
- (if (sound? ind) (close-sound ind) (snd-display #__line__ ";fullmix.scm no output?")))
+ (if (sound? ind) (close-sound ind) (snd-display ";fullmix.scm no output?")))
(with-sound (:channels 2)
(fullmix "4.aiff" 0.0 0.1 36.4 '((0.0 0.0) (0.0 0.0) (1.0 0.0) (0.0 1.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.8865) (snd-display #__line__ ";4->2(0) fullmix.scm: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.8865) (snd-display ";4->2(0) fullmix.scm: ~A" (maxamp)))
(close-sound ind))
(with-sound (:channels 1)
(fullmix "4.aiff" 0.0 0.1 36.4 '((1.0) (0.0) (0.0) (0.0))))
(let ((ind (find-sound "test.snd")))
- (if (fneq (maxamp) 0.221649169921875) (snd-display #__line__ ";4->1(0) fullmix.scm: ~A" (maxamp)))
+ (if (fneq (maxamp) 0.221649169921875) (snd-display ";4->1(0) fullmix.scm: ~A" (maxamp)))
(close-sound ind))
(with-sound (:statistics #t :scaled-to .5 :srate 44100 :channels 1)
(cnvrev "oboe.snd" "fyow.snd"))
(let ((ind (find-sound "test.snd")))
- (if (sound? ind) (close-sound ind) (snd-display #__line__ ";cnvrev no output?")))
+ (if (sound? ind) (close-sound ind) (snd-display ";cnvrev no output?")))
(with-sound ()
@@ -41609,9 +40806,9 @@ EDITS: 1
(mus-file-mix *output* temp-1 0)
(mus-file-mix *output* temp-2 22050)))
(let ((ind (find-sound "test.snd")))
- (if (not (sound? ind)) (snd-display #__line__ ";with-sound+sound-lets init: no test.snd?"))
- (if (or (> (maxamp ind) .2) (< (maxamp ind) .15)) (snd-display #__line__ ";with-mix+sound-lets maxamp: ~A" (maxamp ind)))
- (if (fneq 3.0 (/ (framples ind) (srate ind))) (snd-display #__line__ ";with-sound+sound-lets dur: ~A" (/ (framples ind) (srate ind))))
+ (if (not (sound? ind)) (snd-display ";with-sound+sound-lets init: no test.snd?"))
+ (if (or (> (maxamp ind) .2) (< (maxamp ind) .15)) (snd-display ";with-mix+sound-lets maxamp: ~A" (maxamp ind)))
+ (if (fneq 3.0 (/ (framples ind) (srate ind))) (snd-display ";with-sound+sound-lets dur: ~A" (/ (framples ind) (srate ind))))
(close-sound ind))
(with-sound (:srate 44100 :play #f) (bigbird 0 2 60 0 .5 '(0 0 1 1) '(0 0 1 1 2 1 3 0) '(1 1 2 1 3 1 4 1 5 1 6 1 7 1 8 1 9 1 10 1)))
@@ -41620,29 +40817,25 @@ EDITS: 1
(notch-sound (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)))
(if (or (fneq mx .5)
(ffneq (maxamp) .027))
- (snd-display #__line__ ";notch 60 Hz: ~A to ~A" mx (maxamp)))
- (undo)
- (notch-sound (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f ind 0 10)
- (if (ffneq (maxamp) .011)
- (snd-display #__line__ ";notch-sound 60 hz 2: ~A" (maxamp)))
- (undo)
- (notch-channel (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f #f #f ind 0 #f #f 10)
- (if (ffneq (maxamp) .004)
- (snd-display #__line__ ";notch-channel 60 hz 2: ~A" (maxamp)))
- (undo)
-
- ; (select-all)
- (make-selection 10000 11000)
- (notch-selection (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f 10)
- ; (if (ffneq (maxamp) .066)
- ; (snd-display #__line__ ";notch-selection 60 hz 2: ~A" (maxamp)))
- (close-sound ind)))
+ (snd-display ";notch 60 Hz: ~A to ~A" mx (maxamp))))
+ (undo)
+ (notch-sound (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f ind 0 10)
+ (if (ffneq (maxamp) .011)
+ (snd-display ";notch-sound 60 hz 2: ~A" (maxamp)))
+ (undo)
+ (notch-channel (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f #f #f ind 0 #f #f 10)
+ (if (ffneq (maxamp) .004)
+ (snd-display ";notch-channel 60 hz 2: ~A" (maxamp)))
+ (undo)
+ (make-selection 10000 11000)
+ (notch-selection (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f 10)
+ (close-sound ind))
(with-sound (:srate 44100 :play #f) (bigbird 0 30 60 0 .5 '(0 0 1 1) '(0 0 1 1 2 1 3 0) '(1 1 2 1 3 1 4 1 5 1 6 1 7 1 8 1 9 1 10 1)))
(let ((ind (find-sound "test.snd")))
(notch-sound (let ((freqs ())) (do ((i 60 (+ i 60))) ((= i 3000)) (set! freqs (cons i freqs))) (reverse freqs)) #f ind 0 10)
(if (ffneq (maxamp) .011)
- (snd-display #__line__ ";notch-sound 60 hz 2 60: ~A" (maxamp)))
+ (snd-display ";notch-sound 60 hz 2 60: ~A" (maxamp)))
(close-sound ind))
(play-sine 440 .1)
@@ -41705,89 +40898,88 @@ EDITS: 1
(let ((ind (open-sound "oboe.snd")))
(with-sound ("test1.snd" :to-snd #f) (fm-violin 0 .1 440 .1))
(set-samples 0 2205 "test1.snd" ind 0 #f "set-samples auto-delete test" 0 #f #t)
- (if (not (file-exists? "test1.snd")) (snd-display #__line__ ";oops: auto-delete test1.snd?"))
+ (if (not (file-exists? "test1.snd")) (snd-display ";oops: auto-delete test1.snd?"))
(undo 1 ind)
(with-sound ("test2.snd" :to-snd #f) (fm-violin 0 .1 440 .1))
(insert-sound "test2.snd" 0 0 ind 0 #f #t)
- (if (file-exists? "test1.snd") (snd-display #__line__ ";auto-delete set-samples?"))
+ (if (file-exists? "test1.snd") (snd-display ";auto-delete set-samples?"))
(undo 1 ind)
(with-sound ("test3.snd" :to-snd #f) (fm-violin 0 .1 440 .1))
(insert-samples 0 2205 "test3.snd" ind 0 #f #t)
- (if (file-exists? "test2.snd") (snd-display #__line__ ";auto-delete insert-sound?"))
+ (if (file-exists? "test2.snd") (snd-display ";auto-delete insert-sound?"))
(undo 1 ind)
(with-sound ("test4.snd" :to-snd #f) (fm-violin 0 .1 440 .1))
(mix "test4.snd" 0 0 ind 0 #f #t)
- (if (file-exists? "test3.snd") (snd-display #__line__ ";auto-delete insert-samples?"))
+ (if (file-exists? "test3.snd") (snd-display ";auto-delete insert-samples?"))
(undo 1 ind)
(delete-sample 100)
- (if (file-exists? "test4.snd") (snd-display #__line__ ";auto-delete mix?"))
+ (if (file-exists? "test4.snd") (snd-display ";auto-delete mix?"))
(with-sound ("test5.snd" :to-snd #f) (fm-violin 0 .1 440 .1))
(mix "test5.snd" 0 0 ind 0 #t #t)
(revert-sound ind)
(close-sound ind)
- (if (file-exists? "test5.snd") (snd-display #__line__ ";auto-delete mix (with-tag)?")))
+ (if (file-exists? "test5.snd") (snd-display ";auto-delete mix (with-tag)?")))
)
(let ((o2 (optkey-1 1)))
- (if (not (eqv? o2 1)) (snd-display #__line__ ";optkey-1: ~A" o2)))
+ (if (not (eqv? o2 1)) (snd-display ";optkey-1: ~A" o2)))
(let ((o2 (optkey-1 :a 1)))
- (if (not (eqv? o2 1)) (snd-display #__line__ ";optkey-1 1: ~A" o2)))
+ (if (not (eqv? o2 1)) (snd-display ";optkey-1 1: ~A" o2)))
(let ((o2 (optkey-1)))
- (if o2 (snd-display #__line__ ";optkey-1 2: ~A" o2)))
+ (if o2 (snd-display ";optkey-1 2: ~A" o2)))
(let ((o2 (optkey-2 1 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display #__line__ ";optkey-2: ~A" o2)))
+ (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2: ~A" o2)))
(let ((o2 (optkey-2 :a 1 :b 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display #__line__ ";optkey-2 1: ~A" o2)))
+ (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2 1: ~A" o2)))
(let ((o2 (optkey-2)))
- (if (not (equal? o2 (list 3 #f))) (snd-display #__line__ ";optkey-2 2: ~A" o2)))
+ (if (not (equal? o2 (list 3 #f))) (snd-display ";optkey-2 2: ~A" o2)))
(let ((o2 (optkey-2 1 :b 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display #__line__ ";optkey-2 3: ~A" o2)))
+ (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2 3: ~A" o2)))
(let ((o2 (optkey-3 1 2 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display #__line__ ";optkey-3: ~A" o2)))
+ (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3: ~A" o2)))
(let ((o2 (optkey-3 1 :b 2 :c 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display #__line__ ";optkey-3 1: ~A" o2)))
+ (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3 1: ~A" o2)))
(let ((o2 (optkey-3 1 2 :c 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display #__line__ ";optkey-3 2: ~A" o2)))
+ (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3 2: ~A" o2)))
(let ((o2 (optkey-4)))
- (if (not (equal? o2 (list 1 2 3 #f))) (snd-display #__line__ ";optkey-4: ~A" o2)))
+ (if (not (equal? o2 (list 1 2 3 #f))) (snd-display ";optkey-4: ~A" o2)))
(let ((o2 (optkey-4 1 :b 3 :c 4 :d 5)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display #__line__ ";optkey-4 1: ~A 1" o2)))
+ (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 1: ~A 1" o2)))
(let ((o2 (optkey-4 1 :d 5 :c 4 :b 3)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display #__line__ ";optkey-4 2: ~A 1" o2)))
+ (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 2: ~A 1" o2)))
(let ((o2 (optkey-4 1 3 4 5)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display #__line__ ";optkey-4 3: ~A 2" o2)))
+ (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 3: ~A 2" o2)))
- (if (and (or (provided? 'snd-motif)
- (and (provided? 'snd-gtk) (defined? 'gtk_box_new)))
- (defined? 'variable-display))
+ (when (and (or (provided? 'snd-motif)
+ (and (provided? 'snd-gtk) (defined? 'gtk_box_new)))
+ (defined? 'variable-display))
+ (let ((wid3 (make-variable-display "do-loop" "i3" 'spectrum))
+ (wid4 (make-variable-display "do-loop" "i4" 'graph)))
(let ((wid1 (make-variable-display "do-loop" "i*1" 'text))
- (wid2 (make-variable-display "do-loop" "i*2" 'scale '(-1.0 1.0)))
- (wid3 (make-variable-display "do-loop" "i3" 'spectrum))
- (wid4 (make-variable-display "do-loop" "i4" 'graph)))
+ (wid2 (make-variable-display "do-loop" "i*2" 'scale '(-1.0 1.0))))
(do ((i 0 (+ i 1)))
((= i 1000))
- (variable-display (variable-display (* (variable-display (sin (* (variable-display i wid1) .1)) wid3) .5) wid2) wid4))
- (let ((tag (catch #t (lambda () (set! (sample 0 (car wid3) 0) .5)) (lambda args (car args)))))
- (if (> (edit-position (car wid3) 0) 0) (snd-display #__line__ ";edited variable graph? ~A ~A" tag (edit-position (car wid3) 0))))
- (if (provided? 'snd-motif)
- ((*motif* 'XtUnmanageChild) variables-dialog)
- ((*gtk* 'gtk_widget_hide) variables-dialog))
- (close-sound (car wid3))
- (close-sound (car wid4))
- ))
-
- (if (not (= *clm-srate* *default-output-srate*)) (snd-display #__line__ ";*clm-srate*: ~A ~A" *clm-srate* *default-output-srate*))
- (if (not (= *clm-channels* *default-output-chans*)) (snd-display #__line__ ";*clm-channels*: ~A ~A" *clm-channels* *default-output-chans*))
- (if (not (= *clm-header-type* *default-output-header-type*)) (snd-display #__line__ ";*clm-header-type*: ~A ~A" *clm-header-type* *default-output-header-type*))
- ; (if (not (= *clm-sample-type* *default-output-sample-type*)) (snd-display #__line__ ";*clm-sample-type*: ~A ~A" *clm-sample-type* *default-output-sample-type*))
- (if (not (= *clm-reverb-channels* 1)) (snd-display #__line__ ";*clm-reverb-channels*: ~A" *clm-reverb-channels*))
- (if (not (string=? *clm-file-name* "test.snd")) (snd-display #__line__ ";*clm-file-name*: ~A" *clm-file-name*))
- (if *clm-play* (snd-display #__line__ ";*clm-play*: ~A" *clm-play*))
- (if *clm-verbose* (snd-display #__line__ ";*clm-verbose*: ~A" *clm-verbose*))
- (if *clm-statistics* (snd-display #__line__ ";*clm-statistics*: ~A" *clm-statistics*))
- (if *clm-reverb* (snd-display #__line__ ";*clm-reverb*: ~A" *clm-reverb*))
- (if (pair? *clm-reverb-data*) (snd-display #__line__ ";*clm-reverb-data*: ~A?" *clm-reverb-data*))
- (if *clm-delete-reverb* (snd-display #__line__ ";*clm-delete-reverb*: ~A" *clm-delete-reverb*))
+ (variable-display (variable-display (* (variable-display (sin (* (variable-display i wid1) .1)) wid3) .5) wid2) wid4)))
+ (let ((tag (catch #t (lambda () (set! (sample 0 (car wid3) 0) .5)) (lambda args (car args)))))
+ (if (> (edit-position (car wid3) 0) 0) (snd-display ";edited variable graph? ~A ~A" tag (edit-position (car wid3) 0))))
+ (if (provided? 'snd-motif)
+ ((*motif* 'XtUnmanageChild) variables-dialog)
+ ((*gtk* 'gtk_widget_hide) variables-dialog))
+ (close-sound (car wid3))
+ (close-sound (car wid4))))
+
+ (if (not (= *clm-srate* *default-output-srate*)) (snd-display ";*clm-srate*: ~A ~A" *clm-srate* *default-output-srate*))
+ (if (not (= *clm-channels* *default-output-chans*)) (snd-display ";*clm-channels*: ~A ~A" *clm-channels* *default-output-chans*))
+ (if (not (= *clm-header-type* *default-output-header-type*)) (snd-display ";*clm-header-type*: ~A ~A" *clm-header-type* *default-output-header-type*))
+ ; (if (not (= *clm-sample-type* *default-output-sample-type*)) (snd-display ";*clm-sample-type*: ~A ~A" *clm-sample-type* *default-output-sample-type*))
+ (if (not (= *clm-reverb-channels* 1)) (snd-display ";*clm-reverb-channels*: ~A" *clm-reverb-channels*))
+ (if (not (string=? *clm-file-name* "test.snd")) (snd-display ";*clm-file-name*: ~A" *clm-file-name*))
+ (if *clm-play* (snd-display ";*clm-play*: ~A" *clm-play*))
+ (if *clm-verbose* (snd-display ";*clm-verbose*: ~A" *clm-verbose*))
+ (if *clm-statistics* (snd-display ";*clm-statistics*: ~A" *clm-statistics*))
+ (if *clm-reverb* (snd-display ";*clm-reverb*: ~A" *clm-reverb*))
+ (if (pair? *clm-reverb-data*) (snd-display ";*clm-reverb-data*: ~A?" *clm-reverb-data*))
+ (if *clm-delete-reverb* (snd-display ";*clm-delete-reverb*: ~A" *clm-delete-reverb*))
(let ((old-stats *clm-statistics*))
(set! *clm-channels* 2)
@@ -41806,25 +40998,25 @@ EDITS: 1
(let ((ind (find-sound "test.wav")))
(if (not (sound? ind))
- (snd-display #__line__ ";default output in ws: ~A" (map file-name (sounds)))
+ (snd-display ";default output in ws: ~A" (map file-name (sounds)))
(begin
- (if (not (= (srate ind) 44100)) (snd-display #__line__ ";default srate in ws: ~A ~A" (srate ind) *clm-srate*))
- (if (not (= (channels ind) 2)) (snd-display #__line__ ";default chans in ws: ~A ~A" (channels ind) *clm-channels*))
- (if (not (= (sample-type ind) mus-mulaw)) (snd-display #__line__ ";default format in ws: ~A ~A" (sample-type ind) *clm-sample-type*))
- (if (not (= (header-type ind) mus-riff)) (snd-display #__line__ ";default type in ws: ~A ~A" (header-type ind) *clm-header-type*))
- (if (> (abs (- (framples ind) 88200)) 1) (snd-display #__line__ ";reverb+1 sec out in ws: ~A" (framples ind)))
- (if (file-exists? "test.rev") (snd-display #__line__ ";perhaps reverb not deleted in ws?"))
+ (if (not (= (srate ind) 44100)) (snd-display ";default srate in ws: ~A ~A" (srate ind) *clm-srate*))
+ (if (not (= (channels ind) 2)) (snd-display ";default chans in ws: ~A ~A" (channels ind) *clm-channels*))
+ (if (not (= (sample-type ind) mus-mulaw)) (snd-display ";default format in ws: ~A ~A" (sample-type ind) *clm-sample-type*))
+ (if (not (= (header-type ind) mus-riff)) (snd-display ";default type in ws: ~A ~A" (header-type ind) *clm-header-type*))
+ (if (> (abs (- (framples ind) 88200)) 1) (snd-display ";reverb+1 sec out in ws: ~A" (framples ind)))
+ (if (file-exists? "test.rev") (snd-display ";perhaps reverb not deleted in ws?"))
(close-sound ind))))
(let ((val 0)
(old-hook *clm-notehook*))
(set! *clm-notehook* (lambda args (set! val 1)))
(with-sound () (fm-violin 0 .1 440 .1))
- (if (not (= val 1)) (snd-display #__line__ ";*clm-notehook*: ~A ~A" val *clm-notehook*))
+ (if (not (= val 1)) (snd-display ";*clm-notehook*: ~A ~A" val *clm-notehook*))
(with-sound (:notehook (lambda args (set! val 2))) (fm-violin 0 .1 440 .1))
- (if (not (= val 2)) (snd-display #__line__ ";:notehook: ~A" val))
+ (if (not (= val 2)) (snd-display ";:notehook: ~A" val))
(with-sound () (fm-violin 0 .1 440 .1))
- (if (not (= val 1)) (snd-display #__line__ ";*clm-notehook* (1): ~A ~A" val *clm-notehook*))
+ (if (not (= val 1)) (snd-display ";*clm-notehook* (1): ~A ~A" val *clm-notehook*))
(set! *clm-notehook* old-hook))
(set! *clm-channels* 1)
@@ -41911,7 +41103,7 @@ EDITS: 1
(simple-fof 8 1 270 .1 .001 730 .6 1090 .3 2440 .1) ;"Ahh"
(simple-fof 9 4 270 .1 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 .5 1 3 .5 10 .2 20 .1 50 .1 60 .2 85 1 100 0))
- (simple-fof 9 4 (* 6/5 540) .1 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
+ (simple-fof 9 4 648 .1 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 .5 .5 3 .25 6 .1 10 .1 50 .1 60 .2 85 1 100 0))
(simple-fof 9 4 135 .1 0.005 730 .6 1090 .3 2440 .1 '(0 0 40 0 75 .2 100 1)
'(0 0 1 3 3 1 6 .2 10 .1 50 .1 60 .2 85 1 100 0))
@@ -41953,13 +41145,12 @@ EDITS: 1
(with-sound (:channels 4 :play #f :srate 22050) (simple-dloc-4 0 2 440 .5))
(with-sound (:play #f :srate 22050)
- (or1) (or2) (or3) (or4)
(sample-desc 0 .2 440 .1)
(sample-mdat .25 .2 440 .1)
(sample-xtab .5 .2 440 .1)
(sample-xts .75 .2 440 .1)
- (sample-srl2 1 .2 .2 .5 (* 440 2))
- (sample-srll 1.25 .2 .1 .5 (* 440 4))
+ (sample-srl2 1 .2 .2 .5 880)
+ (sample-srll 1.25 .2 .1 .5 1760)
(sample-srl3 1.5 .2 .1 .5 880)
(sample-grn2 1.75 .2 .1 .5 880)
(sample-grn3 2 .45 1 1 "oboe.snd")
@@ -41973,7 +41164,6 @@ EDITS: 1
(if all-args (sample-ardcl 5.5 .2 440 .1))
(sample-flt 6 .2 440 .1)
(sample-arrintp 6.25 .2 440 .1)
- (sample-if 6.5 .2 440 .1)
(sample-arrfile 6.75 .2 440 .15)
(sample-pvoc5 7.25 .2 .1 256 "oboe.snd" 440.0)
)
@@ -41982,46 +41172,46 @@ EDITS: 1
(fm-violin 0 .1 440 pi)))
(ind (find-sound file))
(mx (maxamp ind)))
- (if (fneq mx pi) (snd-display #__line__ ";clipped #f: ~A" mx))
+ (if (fneq mx pi) (snd-display ";clipped #f: ~A" mx))
(close-sound ind)
(set! file (with-sound (:clipped #t :sample-type mus-lfloat :header-type mus-next)
(fm-violin 0 .1 440 pi)))
(set! ind (find-sound file))
(set! mx (maxamp ind))
- (if (fneq mx 1.0) (snd-display #__line__ ";clipped #t: ~A" mx))
+ (if (fneq mx 1.0) (snd-display ";clipped #t: ~A" mx))
(close-sound ind)
(set! file (with-sound (:sample-type mus-lfloat :header-type mus-next :scaled-by .1 :clipped #f)
(fm-violin 0 .1 440 pi)))
(set! ind (find-sound file))
(set! mx (maxamp ind))
- (if (fneq mx .314159) (snd-display #__line__ ";scaled-by ~A" mx))
+ (if (fneq mx .314159) (snd-display ";scaled-by ~A" mx))
(close-sound ind)
(set! file (with-sound (:sample-type mus-lfloat :header-type mus-next :scaled-to .1 :clipped #f)
(fm-violin 0 .1 440 pi)))
(set! ind (find-sound file))
(set! mx (maxamp ind))
- (if (fneq mx .1) (snd-display #__line__ ";scaled-to ~A" mx))
+ (if (fneq mx .1) (snd-display ";scaled-to ~A" mx))
(close-sound ind)
(let ((old-bufsize *clm-file-buffer-size*)
(old-tsize *clm-table-size*)
(old-arrp *clm-array-print-length*))
- (set! *clm-file-buffer-size* (* 1024 1024))
+ (set! *clm-file-buffer-size* 1048576)
(set! *clm-table-size* 256)
(set! *clm-array-print-length* 123)
(let ((tsize 0)
(arrp 0))
(set! file (with-sound (:sample-type mus-lfloat :header-type mus-next)
- (set! mx *clm-file-buffer-size*)
- (set! tsize *clm-table-size*)
- (set! arrp *mus-array-print-length*)
- (fm-violin 0 .1 440 .1)))
+ (set! mx *clm-file-buffer-size*)
+ (set! tsize *clm-table-size*)
+ (set! arrp *mus-array-print-length*)
+ (fm-violin 0 .1 440 .1)))
(set! ind (find-sound file))
- (if (not (= mx (* 1024 1024))) (snd-display #__line__ ";*clm-file-buffer-size*: ~A" mx))
- (if (not (= tsize 256)) (snd-display #__line__ ";*clm-table-size*: ~A" tsize))
- (if (not (= arrp 123)) (snd-display #__line__ ";*clm-array-print-length*: ~A" arrp))
+ (if (not (= mx 1048576)) (snd-display ";*clm-file-buffer-size*: ~A" mx))
+ (if (not (= tsize 256)) (snd-display ";*clm-table-size*: ~A" tsize))
+ (if (not (= arrp 123)) (snd-display ";*clm-array-print-length*: ~A" arrp))
(set! *clm-file-buffer-size* old-bufsize)
(set! *clm-table-size* old-tsize)
(set! *clm-array-print-length* old-arrp)
@@ -42033,12 +41223,12 @@ EDITS: 1
(set! (x-bounds ind 0) (list 1.0 2.0))
(set! file (with-sound () (fm-violin 0 4.0 440 .1)))
(set! ind (find-sound file))
- (if (fneq (amp-control ind) .5) (snd-display #__line__ ";update ws amp: ~A" (amp-control ind)))
+ (if (fneq (amp-control ind) .5) (snd-display ";update ws amp: ~A" (amp-control ind)))
(if (or (fneq (car (x-bounds ind 0)) 1.0)
(fneq (cadr (x-bounds ind 0)) 2.0))
- (snd-display #__line__ ";update ws bounds: ~A" (x-bounds ind)))
+ (snd-display ";update ws bounds: ~A" (x-bounds ind)))
- (if (not (= (->sample 1.0) (srate))) (snd-display #__line__ ";1.0->sample: ~A" (->sample 1.0)))
+ (if (not (= (->sample 1.0) (srate))) (snd-display ";1.0->sample: ~A" (->sample 1.0)))
(close-sound ind)
(set! file (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount .1)))
@@ -42046,49 +41236,49 @@ EDITS: 1
(set! mx (maxamp ind))
(set! file (with-sound (:reverb jc-reverb :reverb-data '(#f 12.0 (0 0 1 1 20 1 21 0))) (fm-violin 0 .1 440 .1 :reverb-amount .1)))
(set! ind (find-sound file))
- (if (<= (maxamp ind) mx) (snd-display #__line__ ";reverb-data: ~A ~A" mx (maxamp ind)))
+ (if (<= (maxamp ind) mx) (snd-display ";reverb-data: ~A ~A" mx (maxamp ind)))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
(step-src)
- (if (> (abs (- (framples) 24602)) 100) (snd-display #__line__ ";step-src framples: ~A (~A)" (framples) (edits)))
+ (if (> (abs (- (framples) 24602)) 100) (snd-display ";step-src framples: ~A (~A)" (framples) (edits)))
(close-sound ind))
- (let ((file (with-sound (:channels 3)
- (let ((rg (make-rmsgain))
- (rg1 (make-rmsgain 40))
- (rg2 (make-rmsgain 2))
- (e (make-env '(0 0 1 1 2 0) :length 10000))
- (e1 (make-env '(0 0 1 1) :length 10000))
- (e2 (make-env '(0 0 1 1 2 0 10 0) :length 10000))
- (o (make-oscil 440.0)))
- (do ((i 0 (+ i 1)))
- ((= i 10000))
- (let ((sig (env e)))
- (outa i (balance rg sig (env e2)))
- (outb i (balance rg1 sig (env e1)))
- (outc i (balance rg2 (* .1 (oscil o)) (env e2)))))
- (if (fneq (gain-avg rg) 0.98402) (snd-display #__line__ ";rmsgain gain-avg: ~A" (gain-avg rg)))
- (if (not (= (rg2 'avgc) 10000)) (snd-display #__line__ ";rmsgain count: ~A" (rg2 'avgc)))))))
- (let ((ind (find-sound file)))
- (if (not (sound? ind))
- (snd-display #__line__ ";with-sound balance?")
- (close-sound ind))))
-
+ (let* ((file (with-sound (:channels 3)
+ (let ((rg (make-rmsgain))
+ (rg1 (make-rmsgain 40))
+ (rg2 (make-rmsgain 2))
+ (e (make-env '(0 0 1 1 2 0) :length 10000))
+ (e1 (make-env '(0 0 1 1) :length 10000))
+ (e2 (make-env '(0 0 1 1 2 0 10 0) :length 10000))
+ (o (make-oscil 440.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10000))
+ (let ((sig (env e)))
+ (outa i (balance rg sig (env e2)))
+ (outb i (balance rg1 sig (env e1)))
+ (outc i (balance rg2 (* .1 (oscil o)) (env e2)))))
+ (if (fneq (gain-avg rg) 0.98402) (snd-display ";rmsgain gain-avg: ~A" (gain-avg rg)))
+ (if (not (= (rg2 'avgc) 10000)) (snd-display ";rmsgain count: ~A" (rg2 'avgc))))))
+ (ind (find-sound file)))
+ (if (sound? ind)
+ (close-sound ind)
+ (snd-display ";with-sound balance?")))
+
(let ((mg (make-oscil 100.0))
(gen (make-ssb-fm 1000))
(ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next)))
(pad-channel 0 1000 ind 0)
- (catch #t (lambda () (map-channel (lambda (y) (ssb-fm gen (* .02 (oscil mg)))))) (lambda arg (display arg) arg))
+ (catch #t (lambda () (map-channel (lambda (y) (ssb-fm gen (* .02 (oscil mg)))))) (lambda arg (display arg)))
(close-sound ind))
;; dlocsig tests
(if (not (provided? 'snd-dlocsig.scm))
(catch #t
(lambda () (load "dlocsig.scm"))
- (lambda args (snd-display #__line__ ";load dlocsig: ~A" args))))
+ (lambda args (snd-display ";load dlocsig: ~A" args))))
(if (not (defined? 'make-spiral-path))
- (snd-display #__line__ ";make-spiral-path is not defined, dlocsig is ~Aloaded"
+ (snd-display ";make-spiral-path is not defined, dlocsig is ~Aloaded"
(if (provided? 'snd-dlocsig.scm) "" "not "))
(begin
@@ -42096,66 +41286,66 @@ EDITS: 1
(mix-move-sound 0 "oboe.snd" (make-spiral-path :turns 3))
(close-sound file))
- (let ((ind 0))
- (with-sound (:channels 2) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
- (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
- (with-sound (:channels 8) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
- (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #t)))
- (with-sound (:channels 4 :reverb jc-reverb) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :error .001 :3d #f)))
- (with-sound (:channels 2) (dloc-sinewave 0 1.0 440 .5 :path (make-path :path '((-10 10 0 1) (0 5 0 0) (10 10 10 1)) :3d #t)))
- (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :total-angle 360)))
- (with-sound (:channels 8) (dloc-sinewave 0 3.0 440 .5 :path (make-spiral-path :turns 3)))
- (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-literal-path '((-10 10) (10 10)) :polar #f)))
- (with-sound (:channels 3) (dloc-sinewave 0 1.0 440 .5 :path (make-literal-path '((-10 10) (10 10)) :polar #t)))
- (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :total-angle 360 :distance '(0 10 1 30 2 10))))
-
- (set-speaker-configuration (arrange-speakers :speakers '(-45 45 90 135 225)
- :delays '(.010 .020 .030 .040 .050)
- :channel-map '(0 1 3 2 4)))
- (with-sound (:channels 5) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
- (with-sound (:channels 5 :reverb freeverb :reverb-channels 5 :reverb-data '(:decay-time .9))
- (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
-
- (set-speaker-configuration (arrange-speakers :speakers '(-45 45 90 135 225)
- :delays '(.010 .020 .030 .040 .050)
- :channel-map '(4 3 2 1 0)))
-
- (with-sound (:channels 5 :reverb freeverb :reverb-channels 5)
- (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
- (with-sound (:channels 4)
- (dlocsig-sinewave-1 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f) :decode b-format-ambisonics))
- (with-sound (:channels 4)
- (dlocsig-sinewave-1 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f) :decode decoded-ambisonics))
- )))
- (let ((f (with-sound (:channels 5 :reverb freeverb :reverb-channels 5 :srate 44100 :reverb-data '(:decay-time .1))
- (frample->file *reverb* 0 (float-vector .2 .1 .05 .025 .0125)))))
+ (with-sound (:channels 2) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
+ (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
+ (with-sound (:channels 8) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
+ (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #t)))
+ (with-sound (:channels 4 :reverb jc-reverb) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :error .001 :3d #f)))
+ (with-sound (:channels 2) (dloc-sinewave 0 1.0 440 .5 :path (make-path :path '((-10 10 0 1) (0 5 0 0) (10 10 10 1)) :3d #t)))
+ (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :total-angle 360)))
+ (with-sound (:channels 8) (dloc-sinewave 0 3.0 440 .5 :path (make-spiral-path :turns 3)))
+ (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-literal-path '((-10 10) (10 10)) :polar #f)))
+ (with-sound (:channels 3) (dloc-sinewave 0 1.0 440 .5 :path (make-literal-path '((-10 10) (10 10)) :polar #t)))
+ (with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :total-angle 360 :distance '(0 10 1 30 2 10))))
+
+ (set-speaker-configuration (arrange-speakers :speakers '(-45 45 90 135 225)
+ :delays '(.010 .020 .030 .040 .050)
+ :channel-map '(0 1 3 2 4)))
+ (with-sound (:channels 5) (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
+ (with-sound (:channels 5 :reverb freeverb :reverb-channels 5 :reverb-data '(:decay-time .9))
+ (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
+
+ (set-speaker-configuration (arrange-speakers :speakers '(-45 45 90 135 225)
+ :delays '(.010 .020 .030 .040 .050)
+ :channel-map '(4 3 2 1 0)))
+
+ (with-sound (:channels 5 :reverb freeverb :reverb-channels 5)
+ (dloc-sinewave 0 1.0 440 .5 :path (make-spiral-path :turns 2)))
+ (with-sound (:channels 4)
+ (dlocsig-sinewave-1 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f) :decode b-format-ambisonics))
+ (with-sound (:channels 4)
+ (dlocsig-sinewave-1 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f) :decode decoded-ambisonics))
+ ))
+ (let ()
+ (with-sound (:channels 5 :reverb freeverb :reverb-channels 5 :srate 44100 :reverb-data '(:decay-time .1))
+ (frample->file *reverb* 0 (float-vector .2 .1 .05 .025 .0125)))
(define (frample n)
- (let ((ind (selected-sound)))
- (let ((c (channels ind)))
- (let ((v (make-float-vector c)))
- (do ((i 0 (+ i 1)))
- ((= i c) v)
- (set! (v i) (sample n ind i)))))))
+ (let* ((ind (selected-sound))
+ (c (channels ind))
+ (v (make-float-vector c)))
+ (do ((i 0 (+ i 1)))
+ ((= i c) v)
+ (set! (v i) (sample n ind i)))))
(if (not (vvequal (frample 2438) (make-float-vector 5)))
- (snd-display #__line__ ";freeverb 2438: ~A" (frample 2438)))
+ (snd-display ";freeverb 2438: ~A" (frample 2438)))
(if (not (vvequal (frample 2439) (float-vector 0.04276562482118607 -0.0009843750158324838 0.00995312537997961 -0.0009843750158324838 0.001750000054016709)))
(format *stderr* ";freeverb 2439: ~A" (frample 2439)))
(if (not (vvequal (frample 4305) (float-vector 0.03010422177612782 -0.00203015236184001 0.007028832100331783 -0.001004761666990817 0.00125998433213681)))
(format *stderr* ";freeverb 4305: ~A" (frample 4305)))
(close-sound))
- (let ((a4 (->frequency 'a4))
- (a440 (->frequency 440.0))
- (cs5 (->frequency 'cs5))
- (df3 (->frequency 'df3))
- (c1 (->frequency 'cn1))
- (b8 (->frequency 'b8)))
- (if (fneq a4 440.0) (snd-display #__line__ ";a4->frequency: ~A" a4))
- (if (fneq a440 440.0) (snd-display #__line__ ";a440->frequency: ~A" a440))
- (if (fneq cs5 554.365) (snd-display #__line__ ";cs5->frequency: ~A" cs5))
- (if (fneq df3 138.591) (snd-display #__line__ ";df3->frequency: ~A" df3))
- (if (fneq c1 32.703) (snd-display #__line__ ";c1->frequency: ~A" c1))
- (if (fneq b8 7902.132) (snd-display #__line__ ";b8->frequency: ~A" b8)))
+ (let ((a4 (->frequency 'a4)))
+ (if (fneq a4 440.0) (snd-display ";a4->frequency: ~A" a4)))
+ (let ((a440 (->frequency 440.0)))
+ (if (fneq a440 440.0) (snd-display ";a440->frequency: ~A" a440)))
+ (let ((cs5 (->frequency 'cs5)))
+ (if (fneq cs5 554.365) (snd-display ";cs5->frequency: ~A" cs5)))
+ (let ((df3 (->frequency 'df3)))
+ (if (fneq df3 138.591) (snd-display ";df3->frequency: ~A" df3)))
+ (let ((c1 (->frequency 'cn1)))
+ (if (fneq c1 32.703) (snd-display ";c1->frequency: ~A" c1)))
+ (let ((b8 (->frequency 'b8)))
+ (if (fneq b8 7902.132) (snd-display ";b8->frequency: ~A" b8)))
(let ((violins (make-sample->file "violins.snd" 1 mus-ldouble mus-next))
(cellos (make-sample->file "cellos.snd" 1 mus-ldouble mus-next)))
@@ -42191,7 +41381,7 @@ EDITS: 1
(c (csr))
(f (fsr)))
(if (fneq f (+ c v))
- (snd-display #__line__ ";multi temp output: ~A != ~A + ~A" f v c))))
+ (snd-display ";multi temp output: ~A != ~A + ~A" f v c))))
(free-sampler vsr)
(free-sampler csr)
@@ -42202,91 +41392,93 @@ EDITS: 1
(if (file-exists? "cellos.snd") (delete-file "cellos.snd"))))
(let ((v1 (with-sound ((make-float-vector 2210)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (fneq (float-vector-peak v1) .1) (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
+ (if (fneq (float-vector-peak v1) .1) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 2210)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (fneq (float-vector-peak v2) .1) (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
- (if (not (vequal v1 v2)) (snd-display #__line__ ";with-sound -> float-vector v1 v2 not equal?"))
- (sound-let ((tmp () (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)))
- (let ((v3 (make-float-vector 2210)))
- (file->array tmp 0 0 2205 v3)
- (if (not (vequal v1 v3)) (snd-display #__line__ ";with-sound -> float-vector v1 v3 not equal?"))))
- (with-sound (v1)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (fneq (float-vector-peak v1) .2) (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1)))))
+ (if (fneq (float-vector-peak v2) .1) (snd-display ";with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
+ (if (not (vequal v1 v2)) (snd-display ";with-sound -> float-vector v1 v2 not equal?")))
+ (sound-let ((tmp () (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)))
+ (let ((v3 (make-float-vector 2210)))
+ (file->array tmp 0 0 2205 v3)
+ (if (not (vequal v1 v3)) (snd-display ";with-sound -> float-vector v1 v3 not equal?"))))
+ (with-sound (v1)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
+ (if (fneq (float-vector-peak v1) .2) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1))))
(let ((v1 (with-sound ((make-float-vector (list 1 2210) 0.0)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v1) .1) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
+ (if (fneq (maxamp v1) .1) (snd-display ";with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 1 2210) 0.0)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v2) .1) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display #__line__ ";with-sound -> vector2 v1 v2 not equal?"))
- (with-sound (v1)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (fneq (maxamp v1) .2) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (if (fneq (maxamp v2) .1) (snd-display ";with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
+ (if (not (sd-equal v1 v2)) (snd-display ";with-sound -> vector2 v1 v2 not equal?")))
+ (with-sound (v1)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
+ (if (fneq (maxamp v1) .2) (snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(set! (locsig-type) mus-interp-linear)
(let ((v1 (with-sound ((make-float-vector (list 2 2210) 0.0))
- (if (not (= (mus-channels *output*) 2)) (snd-display #__line__ ";with-sound *output* chans: ~A" (mus-channels *output*)))
+ (if (not (= (mus-channels *output*) 2)) (snd-display ";with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v1) .05) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
- (if (fneq (maxamp v1) .05) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+ (if (fneq (maxamp v1) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
+ (if (fneq (maxamp v1) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 2 2210) 0.0))
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v2) .05) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
- (if (fneq (maxamp v2) .05) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display #__line__ ";with-sound (2 chans) -> vector2 v1 v2 not equal?"))
- (with-sound (v1)
- (fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
- (fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0))
- (if (fneq (maxamp v1) .2) (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (if (fneq (maxamp v2) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
+ (if (fneq (maxamp v2) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
+ (if (not (sd-equal v1 v2)) (snd-display ";with-sound (2 chans) -> vector2 v1 v2 not equal?")))
+ (with-sound (v1)
+ (fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
+ (fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0))
+ (if (fneq (maxamp v1) .2) (snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(let ((v1 (with-sound ((make-float-vector 2210) :scaled-to .3) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (float-vector-peak v1) .3)
- (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp (opt, scaled-to): ~A" (float-vector-peak v1)))
+ (snd-display ";with-sound -> float-vector fm-violin maxamp (opt, scaled-to): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 2210) :scaled-to .3) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (float-vector-peak v2) .3)
- (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp scaled-to: ~A" (float-vector-peak v2)))
- (if (not (vequal v1 v2)) (snd-display #__line__ ";with-sound (scaled-to) -> float-vector v1 v2 not equal?"))
- (with-sound (v1 :scaled-by 2.0)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (fneq (float-vector-peak v1) .4) (snd-display #__line__ ";with-sound -> float-vector fm-violin maxamp (opt 2 scaled-by): ~A" (float-vector-peak v1)))))
+ (snd-display ";with-sound -> float-vector fm-violin maxamp scaled-to: ~A" (float-vector-peak v2)))
+ (if (not (vequal v1 v2)) (snd-display ";with-sound (scaled-to) -> float-vector v1 v2 not equal?")))
+ (with-sound (v1 :scaled-by 2.0)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
+ (if (fneq (float-vector-peak v1) .4) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt 2 scaled-by): ~A" (float-vector-peak v1))))
(let ((v1 (with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v1) .5)
- (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt, scaled-to): ~A" (maxamp v1)))
+ (snd-display ";with-sound -> vector2 fm-violin maxamp (opt, scaled-to): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v2) .5)
- (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp scaled-to: ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display #__line__ ";with-sound scaled-to -> vector2 v1 v2 not equal?"))
- (with-sound (v1 :scaled-by 0.5)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (fneq (maxamp v1) .1)
- (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt 2 scaled-by): ~A" (maxamp v1)))))
+ (snd-display ";with-sound -> vector2 fm-violin maxamp scaled-to: ~A" (maxamp v2)))
+ (if (not (sd-equal v1 v2)) (snd-display ";with-sound scaled-to -> vector2 v1 v2 not equal?")))
+ (with-sound (v1 :scaled-by 0.5)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
+ (if (fneq (maxamp v1) .1)
+ (snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2 scaled-by): ~A" (maxamp v1))))
(let ((stats-string ""))
(with-sound ((make-float-vector 2210) :statistics (lambda (str) (set! stats-string str)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (and (not (string=? stats-string "\n;vector:\n maxamp: 0.1000\n compute time: 0.000\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.1000\n compute time: 0.001\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.1000\n compute time: 0.002\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.1000\n compute time: 0.010\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.09999998\n compute time: 0.001\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.09999998\n compute time: 0.000\n"))
- (not (string=? stats-string "\n;vector:\n maxamp: 0.1000\n compute time: 0.180\n")))
- (snd-display #__line__ ";with-sound to float-vector stats: [~A]" stats-string))
+ (if (not (member stats-string '("\n;vector:\n maxamp: 0.1000\n compute time: 0.000\n"
+ "\n;vector:\n maxamp: 0.1000\n compute time: 0.001\n"
+ "\n;vector:\n maxamp: 0.1000\n compute time: 0.002\n"
+ "\n;vector:\n maxamp: 0.1000\n compute time: 0.010\n"
+ "\n;vector:\n maxamp: 0.09999998\n compute time: 0.001\n"
+ "\n;vector:\n maxamp: 0.09999998\n compute time: 0.000\n"
+ "\n;vector:\n maxamp: 0.1000\n compute time: 0.180\n")
+ string=?))
+ (snd-display ";with-sound to float-vector stats: [~A]" stats-string))
(with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5 :statistics (lambda (str) (set! stats-string str)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (if (and (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.000\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.001\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.002\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.010\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.09999998\n compute time: 0.001\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.09999998\n compute time: 0.000\n"))
- (not (string=? stats-string "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.009\n")))
- (snd-display #__line__ ";with-sound to float-vector stats: [~A]" stats-string))
+ (if (not (member stats-string '("\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.000\n"
+ "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.001\n"
+ "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.002\n"
+ "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.010\n"
+ "\n;vector:\n maxamp (before scaling): 0.09999998\n compute time: 0.001\n"
+ "\n;vector:\n maxamp (before scaling): 0.09999998\n compute time: 0.000\n"
+ "\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.009\n")
+ string=?))
+ (snd-display ";with-sound to float-vector stats: [~A]" stats-string))
(with-sound ((make-float-vector (list 4 2210) 0.0) :channels 4 :statistics (lambda (str) (set! stats-string str)))
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
@@ -42301,11 +41493,11 @@ EDITS: 1
;; testing overwrites here -- just hope we don't crash...
(let ((v1 (with-sound ((make-float-vector 20) :channels 1)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (fneq (v1 0) 0.0) (snd-display #__line__ ";overwrite float-vector with-sound: ~A (~A)" (v1 0) (float-vector-peak v1))))
+ (if (fneq (v1 0) 0.0) (snd-display ";overwrite float-vector with-sound: ~A (~A)" (v1 0) (float-vector-peak v1))))
(let ((v1 (with-sound ((make-float-vector 20) 4)
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
- (if (fneq (v1 0) 0.0) (snd-display #__line__ ";overwrite float-vector with-sound (4): ~A (~A)" (v1 0) (float-vector-peak v1))))
+ (if (fneq (v1 0) 0.0) (snd-display ";overwrite float-vector with-sound (4): ~A (~A)" (v1 0) (float-vector-peak v1))))
(let ((v1 (with-sound ((make-float-vector (list 4 20) 0.0) :channels 4)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
@@ -42313,7 +41505,7 @@ EDITS: 1
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .4 :degree 270 :random-vibrato-amplitude 0.0))))
(do ((i 0 (+ i 1))) ((= i 4))
- (if (fneq (v1 i 0) 0.0) (snd-display #__line__ ";overwrite sd ~D with-sound: ~A" i (v1 i 0)))))
+ (if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd ~D with-sound: ~A" i (v1 i 0)))))
(let ((v1 (with-sound ((make-float-vector (list 2 20) 0.0) 4)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
@@ -42321,7 +41513,7 @@ EDITS: 1
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .4 :degree 270 :random-vibrato-amplitude 0.0))))
(do ((i 0 (+ i 1))) ((= i 2))
- (if (fneq (v1 i 0) 0.0) (snd-display #__line__ ";overwrite sd (2) ~D with-sound: ~A" i (v1 i 0)))))
+ (if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd (2) ~D with-sound: ~A" i (v1 i 0)))))
(let ((v1 (with-sound ((make-float-vector (list 4 20) 0.0) :channels 1)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
@@ -42329,199 +41521,197 @@ EDITS: 1
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .4 :degree 270 :random-vibrato-amplitude 0.0))))
(do ((i 0 (+ i 1))) ((= i 4))
- (if (fneq (v1 i 0) 0.0) (snd-display #__line__ ";overwrite sd (4) ~D with-sound: ~A" i (v1 i 0)))))
+ (if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd (4) ~D with-sound: ~A" i (v1 i 0)))))
)
(list 0 3 6))
;; reverb cases parallel to above
(let ((v1 (with-sound ((make-float-vector 44100) :reverb jc-reverb)
- (if (not (= (mus-length *output*) 44100)) (snd-display #__line__ ";ws mus-length float-vector: ~A" (mus-length *output*)))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9)))
- (v4 (with-sound ((make-float-vector 44100))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (vequal v1 v4) (snd-display #__line__ ";reverb output not written to float-vector?"))
+ (if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length float-vector: ~A" (mus-length *output*)))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9))))
+ (let ((v4 (with-sound ((make-float-vector 44100))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (if (vequal v1 v4) (snd-display ";reverb output not written to float-vector?")))
(if (< (float-vector-peak v1) .28)
- (snd-display #__line__ ";rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
+ (snd-display ";rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 44100) :reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (float-vector-peak v2) .28)
- (snd-display #__line__ ";rev with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
- (with-sound (v1 :channels 1 :reverb jc-reverb)
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9)
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9))
- (if (< (float-vector-peak v1) .28)
- (snd-display #__line__ ";rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1)))))
+ (snd-display ";rev with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2))))
+ (with-sound (v1 :channels 1 :reverb jc-reverb)
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9)
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9))
+ (if (< (float-vector-peak v1) .28)
+ (snd-display ";rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1))))
(let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
- (if (not (= (mus-length *output*) 44100)) (snd-display #__line__ ";ws mus-length sd: ~A" (mus-length *output*)))
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0)))
- (v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display #__line__ ";reverb output not written to sd?"))
+ (if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
+ (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (if (sd-equal v1 v4) (snd-display ";reverb output not written to sd?")))
(if (< (maxamp v1) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
- (with-sound (v1 :reverb jc-reverb)
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9)
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9))
- (if (< (maxamp v1) .52)
- (snd-display #__line__ ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2))))
+ (with-sound (v1 :reverb jc-reverb)
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9)
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9))
+ (if (< (maxamp v1) .52)
+ (snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(set! (locsig-type) mus-interp-linear)
(let ((v1 (with-sound ((make-float-vector (list 2 44100) 0.0) :reverb jc-reverb)
(if (not (= (mus-channels *output*) 2))
- (snd-display #__line__ ";rev with-sound *output* chans: ~A" (mus-channels *output*)))
+ (snd-display ";rev with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
(if (< (maxamp v1) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
(if (< (maxamp v1) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+
(let ((v2 (with-sound ((make-float-vector (list 2 44100) 0.0) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
(if (< (maxamp v2) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
(if (< (maxamp v2) .23)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
- (with-sound (v1 :reverb jc-reverb)
- (fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9)
- (fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9))
- (if (< (maxamp v1) .5)
- (snd-display #__line__ ";rev with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2))))
+ (with-sound (v1 :reverb jc-reverb)
+ (fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9)
+ (fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9))
+ (if (< (maxamp v1) .5)
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(let ((v1 (with-sound ((make-float-vector 44100) :revfile (make-float-vector 44100) :reverb jc-reverb)
- (if (not (= (mus-length *output*) 44100)) (snd-display #__line__ ";1 ws mus-length float-vector: ~A" (mus-length *output*)))
- (if (not (= (mus-length *reverb*) 44100)) (snd-display #__line__ ";1 ws mus-length float-vector rev: ~A" (mus-length *reverb*)))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9)))
- (v4 (with-sound ((make-float-vector 44100))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (vequal v1 v4) (snd-display #__line__ ";1 reverb output not written to float-vector?"))
+ (if (not (= (mus-length *output*) 44100)) (snd-display ";1 ws mus-length float-vector: ~A" (mus-length *output*)))
+ (if (not (= (mus-length *reverb*) 44100)) (snd-display ";1 ws mus-length float-vector rev: ~A" (mus-length *reverb*)))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9))))
+ (let ((v4 (with-sound ((make-float-vector 44100))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (if (vequal v1 v4) (snd-display ";1 reverb output not written to float-vector?")))
(if (< (float-vector-peak v1) .28)
- (snd-display #__line__ ";1 rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
+ (snd-display ";1 rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 44100) :revfile (make-float-vector 44100) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (float-vector-peak v2) .28)
- (snd-display #__line__ ";1 rev with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
+ (snd-display ";1 rev with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
(with-sound (v1 :revfile v2 :channels 1 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))
(if (< (float-vector-peak v1) .28)
- (snd-display #__line__ ";1 rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1)))))
+ (snd-display ";1 rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1)))))
(let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
- (if (not (= (mus-length *output*) 44100)) (snd-display #__line__ ";ws mus-length sd: ~A" (mus-length *output*)))
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0)))
- (v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display #__line__ ";2 reverb output not written to sd?"))
+ (if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
+ (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (if (sd-equal v1 v4) (snd-display ";2 reverb output not written to sd?")))
(if (< (maxamp v1) .28)
- (snd-display #__line__ ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
+ (snd-display ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .28)
- (snd-display #__line__ ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
+ (snd-display ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
(with-sound (v1 :revfile v2 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))
(if (< (maxamp v1) .5)
- (snd-display #__line__ ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (snd-display ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
(let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
- (if (not (= (mus-length *output*) 44100)) (snd-display #__line__ ";ws mus-length sd: ~A" (mus-length *output*)))
- (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0)))
- (v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
- (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display #__line__ ";2 reverb output not written to sd?"))
+ (if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
+ (fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
+ (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (if (sd-equal v1 v4) (snd-display ";2 reverb output not written to sd?")))
(if (< (maxamp v1) .28)
- (snd-display #__line__ ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
+ (snd-display ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .28)
- (snd-display #__line__ ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
+ (snd-display ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
(with-sound (v1 :revfile v2 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))
(if (< (maxamp v1) .5)
- (snd-display #__line__ ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (snd-display ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
(set! (locsig-type) mus-interp-linear)
(let ((v1 (with-sound ((make-float-vector (list 2 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
(if (not (= (mus-channels *output*) 2))
- (snd-display #__line__ ";3 rev with-sound *output* chans: ~A" (mus-channels *output*)))
+ (snd-display ";3 rev with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
(if (< (maxamp v1) .23)
- (snd-display #__line__ ";3 rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
(if (< (maxamp v1) .23)
- (snd-display #__line__ ";3 rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
(let ((v2 (with-sound ((make-float-vector (list 2 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
(if (< (maxamp v2) .23)
- (snd-display #__line__ ";3 rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
(if (< (maxamp v2) .23)
- (snd-display #__line__ ";3 rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
(with-sound (v1 :revfile v2 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9))
(if (< (maxamp v1) .55)
- (snd-display #__line__ ";3 rev with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
(for-each
(lambda (n)
+ (let ((v2 (with-sound ((make-float-vector 400))
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0))))
+ (if (fneq (float-vector-peak v2) 0.1) (snd-display ";outa tests 2 ~A: ~A" n (float-vector-peak v2))))
+ (let ((v3 (with-sound ((make-float-vector 400))
+ (simple-outn 0 .01 440 0.0 .5 0.0 0.0 0.0 0.0))))
+ (if (fneq (float-vector-peak v3) 0.0) (snd-display ";outa tests 3 ~A: ~A" n (float-vector-peak v3))))
+ (let ((v4 (with-sound ((make-float-vector 4410) :reverb jc-reverb)
+ (simple-outn 0 .01 440 0.2 0.0 0.0 0.0 0.05 0.0))))
+ (if (fneq (float-vector-peak v4) 0.2) (snd-display ";outa tests 4 ~A: ~A" n (float-vector-peak v4))))
+ (let ((v5 (with-sound ((make-float-vector 4410) :reverb simple-in-rev :reverb-data '(0.0 1.0 1.0 0.0))
+ (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.0))))
+ (if (fneq (float-vector-peak v5) 0.5) (snd-display ";outa tests 5 ~A: ~A" n (float-vector-peak v5))))
+ (let ((v6 (with-sound ((make-float-vector 400))
+ (simple-outn 0 .01 440 0.5 0.0 0.0 0.0 0.0 0.0)
+ (simple-outn 0 .01 440 0.2 0.0 0.0 0.0 0.0 0.0))))
+ (if (fneq (float-vector-peak v6) 0.7) (snd-display ";outa tests 11 ~A: ~A" n (float-vector-peak v6))))
+ (let* ((sd1 (with-sound ((make-float-vector (list 1 4410) 0.0))
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
+ (mx1 (maxamp sd1)))
+ (if (fneq mx1 .1) (snd-display ";outa tests 6 ~A: ~A" n mx1)))
+ (let* ((sd3 (with-sound ((make-float-vector (list 2 4410) 0.0))
+ (simple-outn 0 .01 440 0.0 0.0 .3 .4 0.0 0.0)))
+ (mx3 (maxamp sd3)))
+ (if (fneq mx3 0.0) (snd-display ";outa tests 8 ~A: ~A" n mx3)))
+ (let* ((sd4 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 2 :reverb-data '(0.0 1.0 1.0 1.0))
+ (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
+ (mx4 (maxamp sd4)))
+ (if (fneq mx4 0.5) (snd-display ";outa tests 9 ~A: ~A" n mx4)))
+ (let* ((sd5 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 1 :reverb-data '(0.0 1.0 1.0 1.0))
+ (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
+ (mx5 (maxamp sd5)))
+ (if (fneq mx5 0.5) (snd-display ";outa tests 10 ~A: ~A" n mx5)))
+ (let* ((sd6 (with-sound ((make-float-vector (list 4 4410) 0.0))
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
+ (mx6 (maxamp sd6)))
+ (if (fneq mx6 .8) (snd-display ";outa tests 12 ~A: ~A" n mx6)))
(let ((v1 (with-sound ((make-float-vector 4410))
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
- (v2 (with-sound ((make-float-vector 400))
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
- (v3 (with-sound ((make-float-vector 400))
- (simple-outn 0 .01 440 0.0 .5 0.0 0.0 0.0 0.0)))
- (v4 (with-sound ((make-float-vector 4410) :reverb jc-reverb)
- (simple-outn 0 .01 440 0.2 0.0 0.0 0.0 0.05 0.0)))
- (v5 (with-sound ((make-float-vector 4410) :reverb simple-in-rev :reverb-data '(0.0 1.0 1.0 0.0))
- (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.0)))
- (v6 (with-sound ((make-float-vector 400))
- (simple-outn 0 .01 440 0.5 0.0 0.0 0.0 0.0 0.0)
- (simple-outn 0 .01 440 0.2 0.0 0.0 0.0 0.0 0.0)))
- (sd1 (with-sound ((make-float-vector (list 1 4410) 0.0))
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
- (sd2 (with-sound ((make-float-vector (list 4 4410) 0.0))
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
- (sd3 (with-sound ((make-float-vector (list 2 4410) 0.0))
- (simple-outn 0 .01 440 0.0 0.0 .3 .4 0.0 0.0)))
- (sd4 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 2 :reverb-data '(0.0 1.0 1.0 1.0))
- (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
- (sd5 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 1 :reverb-data '(0.0 1.0 1.0 1.0))
- (simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
- (sd6 (with-sound ((make-float-vector (list 4 4410) 0.0))
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)
- (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0))))
- (if (fneq (float-vector-peak v1) 0.1) (snd-display #__line__ ";outa tests 1 ~A: ~A" n (float-vector-peak v1)))
- (if (fneq (float-vector-peak v2) 0.1) (snd-display #__line__ ";outa tests 2 ~A: ~A" n (float-vector-peak v2)))
- (if (fneq (float-vector-peak v3) 0.0) (snd-display #__line__ ";outa tests 3 ~A: ~A" n (float-vector-peak v3)))
- (if (fneq (float-vector-peak v4) 0.2) (snd-display #__line__ ";outa tests 4 ~A: ~A" n (float-vector-peak v4)))
- (if (fneq (float-vector-peak v5) 0.5) (snd-display #__line__ ";outa tests 5 ~A: ~A" n (float-vector-peak v5)))
- (if (fneq (float-vector-peak v6) 0.7) (snd-display #__line__ ";outa tests 11 ~A: ~A" n (float-vector-peak v6)))
-
- (let ((mx1 (maxamp sd1)))
- (if (fneq mx1 .1) (snd-display #__line__ ";outa tests 6 ~A: ~A" n mx1)))
- (let ((mx2 (maxamp sd2)))
- (if (fneq mx2 .4) (snd-display #__line__ ";outa tests 7 ~A: ~A" n mx2)))
- (let ((mx3 (maxamp sd3)))
- (if (fneq mx3 0.0) (snd-display #__line__ ";outa tests 8 ~A: ~A" n mx3)))
- (let ((mx4 (maxamp sd4)))
- (if (fneq mx4 0.5) (snd-display #__line__ ";outa tests 9 ~A: ~A" n mx4)))
- (let ((mx5 (maxamp sd5)))
- (if (fneq mx5 0.5) (snd-display #__line__ ";outa tests 10 ~A: ~A" n mx5)))
- (let ((mx6 (maxamp sd6)))
- (if (fneq mx6 .8) (snd-display #__line__ ";outa tests 12 ~A: ~A" n mx6)))
-
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0))))
+ (if (fneq (float-vector-peak v1) 0.1) (snd-display ";outa tests 1 ~A: ~A" n (float-vector-peak v1)))
(with-sound (v1 :continue-old-file #t)
- (simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
- (if (fneq (float-vector-peak v1) 0.2) (snd-display #__line__ ";outa tests 13 ~A: ~A" n (float-vector-peak v1)))
-
- (with-sound (sd2 :continue-old-file #t)
- (simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
- (let ((mx7 (maxamp sd2)))
- (if (fneq mx7 .8) (snd-display #__line__ ";outa tests 14 ~A: ~A" n mx7)))))
- (list 0 6))
+ (simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
+ (if (fneq (float-vector-peak v1) 0.2) (snd-display ";outa tests 13 ~A: ~A" n (float-vector-peak v1)))
+ (let ((sd2 (with-sound ((make-float-vector (list 4 4410) 0.0))
+ (simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0))))
+ (let ((mx2 (maxamp sd2)))
+ (if (fneq mx2 .4) (snd-display ";outa tests 7 ~A: ~A" n mx2)))
+ (with-sound (sd2 :continue-old-file #t)
+ (simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
+ (let ((mx7 (maxamp sd2)))
+ (if (fneq mx7 .8) (snd-display ";outa tests 14 ~A: ~A" n mx7))))))
+ (list 0 6))
(let* ((file (with-sound ()
(fm-violin 0 .1 880 .1 :random-vibrato-amplitude 0.0)
@@ -42535,11 +41725,11 @@ EDITS: 1
(fm-violin 0 .1 220.0 .1 :random-vibrato-amplitude 0.0)))
(ind (find-sound file)))
(if (not (sound? ind))
- (snd-display #__line__ ";can't find mixed with-sound output")
+ (snd-display ";can't find mixed with-sound output")
(let ((mx (maxamp ind 0)))
- (if (< mx .35) (snd-display #__line__ ";mixed with-sound max: ~A" mx))
+ (if (< mx .35) (snd-display ";mixed with-sound max: ~A" mx))
(if (not (vequal (channel->float-vector 1000 10) (float-vector 0.255 0.275 0.316 0.364 0.391 0.379 0.337 0.283 0.228 0.170)))
- (snd-display #__line__ ";mixed with-sound: ~A" (channel->float-vector 1000 10)))
+ (snd-display ";mixed with-sound: ~A" (channel->float-vector 1000 10)))
(close-sound ind))))
(let* ((file (with-sound ()
@@ -42557,51 +41747,50 @@ EDITS: 1
(fm-violin 0 .1 220.0 .1 :random-vibrato-amplitude 0.0)))
(ind (find-sound file)))
(if (not (sound? ind))
- (snd-display #__line__ ";can't find mixed with-sound sound-let output")
+ (snd-display ";can't find mixed with-sound sound-let output")
(let ((mx (maxamp ind 0)))
- (if (< mx .375) (snd-display #__line__ ";mixed with-sound max: ~A" mx))
+ (if (< mx .375) (snd-display ";mixed with-sound max: ~A" mx))
(if (not (vequal (channel->float-vector 1000 10) (float-vector 0.349 0.370 0.412 0.461 0.489 0.478 0.436 0.383 0.328 0.270)))
- (snd-display #__line__ ";mixed with-sound via sound-let: ~A" (channel->float-vector 1000 10)))
+ (snd-display ";mixed with-sound via sound-let: ~A" (channel->float-vector 1000 10)))
(close-sound ind))))
(let* ((res (with-mixed-sound () (fm-violin 0 .1 440 .1)))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";with-mixed-sound (1): ~A?" res))
+ (if (not (sound? snd)) (snd-display ";with-mixed-sound (1): ~A?" res))
(let ((mxs (mixes snd 0))
(info (sound-property 'with-mixed-sound-info snd)))
(if (not (list? mxs))
- (snd-display #__line__ ";with-mixed-sound (1) mixes: ~A" mxs))
- (if (or (not (equal? (car (info 0)) (car mxs)))
- (not (= (cadr (info 0)) 0))
- (not (= (caddr (info 0)) 1)))
- (snd-display #__line__ ";with-mixed-sound info (1) 0: ~A" (info 0)))
- (if (ffneq (maxamp snd) .1)
- (snd-display #__line__ ";with-mixed-sound (1) 0: ~A" (maxamp snd)))
- (close-sound snd)))
+ (snd-display ";with-mixed-sound (1) mixes: ~A" mxs))
+ (if (not (and (equal? (car (info 0)) (car mxs))
+ (= (cadr (info 0)) 0)
+ (= (caddr (info 0)) 1)))
+ (snd-display ";with-mixed-sound info (1) 0: ~A" (info 0))))
+ (if (ffneq (maxamp snd) .1)
+ (snd-display ";with-mixed-sound (1) 0: ~A" (maxamp snd)))
+ (close-sound snd))
(let* ((res (with-mixed-sound (:srate 44100)
(fm-violin 0 .1 440 .1)
(fm-violin 1 .1 660 .1)))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";with-mixed-sound (2): ~A?" res))
+ (if (not (sound? snd)) (snd-display ";with-mixed-sound (2): ~A?" res))
(let ((mxs (mixes snd 0))
(info (sound-property 'with-mixed-sound-info snd)))
- (if (or (not (list? mxs))
- (not (= (length mxs) 2)))
- (snd-display #__line__ ";with-mixed-sound mixes (2): ~A" mxs))
- (if (or (not (equal? (car (info 0)) (car mxs)))
- (not (= (cadr (info 0)) 0))
- (not (= (caddr (info 0)) 1)))
- (snd-display #__line__ ";with-mixed-sound info (2) 0: ~A" (info 0)))
- (if (or (not (equal? (car (info 1)) (cadr mxs)))
- (not (= (cadr (info 1)) 44100))
- (not (= (caddr (info 1)) 1)))
- (snd-display #__line__ ";with-mixed-sound info (2) 1: ~A" (info 1)))
- (if (or (and (not (= (framples snd) 48510))
- (not (= (framples snd) 48511)))
+ (if (not (and (list? mxs)
+ (= (length mxs) 2)))
+ (snd-display ";with-mixed-sound mixes (2): ~A" mxs))
+ (if (not (and (equal? (car (info 0)) (car mxs))
+ (= (cadr (info 0)) 0)
+ (= (caddr (info 0)) 1)))
+ (snd-display ";with-mixed-sound info (2) 0: ~A" (info 0)))
+ (if (not (and (equal? (car (info 1)) (cadr mxs))
+ (= (cadr (info 1)) 44100)
+ (= (caddr (info 1)) 1)))
+ (snd-display ";with-mixed-sound info (2) 1: ~A" (info 1)))
+ (if (or (not (member (framples snd) '(48510 48511) =))
(fneq (maxamp snd) .1))
- (snd-display #__line__ ";with-mixed-sound 0 (2): ~A ~A" (framples snd) (maxamp snd)))
+ (snd-display ";with-mixed-sound 0 (2): ~A ~A" (framples snd) (maxamp snd)))
(close-sound snd)))
(let* ((res (with-mixed-sound (:channels 2 :srate 44100)
@@ -42610,11 +41799,11 @@ EDITS: 1
(snd (find-sound res))
(mxs (mixes snd))
(info (sound-property 'with-mixed-sound-info snd)))
- (if (or (not (= (length mxs) 2))
- (not (= (length (car mxs)) 2))
- (not (= (length info) 2))
- (not (equal? (caar info) (caar mxs))))
- (snd-display #__line__ ";with-mixed-sound (3) 1: ~A ~A" mxs info))
+ (if (not (and (= (length mxs) 2)
+ (= (length (car mxs)) 2)
+ (= (length info) 2)
+ (equal? (caar info) (caar mxs))))
+ (snd-display ";with-mixed-sound (3) 1: ~A ~A" mxs info))
(close-sound snd))
(let* ((res (with-marked-sound ()
@@ -42623,12 +41812,12 @@ EDITS: 1
(snd (find-sound res))
(mxs (marks snd 0)))
(if (not (= (length mxs) 2))
- (snd-display #__line__ ";with-marked-sound marks: ~A " mxs)
+ (snd-display ";with-marked-sound marks: ~A " mxs)
(begin
(if (not (string=? (mark-name (car mxs)) "fm-violin 0 0.1"))
- (snd-display #__line__ ";with-marked-sound name: ~A" (mark-name (car mxs))))
+ (snd-display ";with-marked-sound name: ~A" (mark-name (car mxs))))
(if (fneq (maxamp snd) .1)
- (snd-display #__line__ ";with-marked-sound maxamp: ~A" (maxamp snd)))))
+ (snd-display ";with-marked-sound maxamp: ~A" (maxamp snd)))))
(close-sound snd))
(set! (hook-functions mark-click-hook) ())
@@ -42644,8 +41833,8 @@ EDITS: 1
((= i 10000))
(outa i (ercos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";ercos: ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";ercos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";ercos: ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";ercos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-ercos 100 :r 0.1)))
@@ -42663,8 +41852,8 @@ EDITS: 1
(set! scaler (* (sinh r) offset)))
(outa i (ercos g))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";ercos 1: ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";ercos 1 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";ercos 1: ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";ercos 1 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-erssb 1000.0 0.1 1.0)))
@@ -42672,8 +41861,8 @@ EDITS: 1
((= i 20000))
(outa i (erssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";erssb: ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";erssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";erssb: ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";erssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-noddsin 100 :n 10)))
@@ -42681,8 +41870,8 @@ EDITS: 1
((= i 10000))
(outa i (noddsin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";noddsin: ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";noddsin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";noddsin: ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";noddsin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-noddcos 100 :n 10)))
@@ -42690,8 +41879,8 @@ EDITS: 1
((= i 10000))
(outa i (noddcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";noddcos: ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";noddcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";noddcos: ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";noddcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-noddssb 1000.0 0.1 5)))
@@ -42699,8 +41888,8 @@ EDITS: 1
((= i 10000))
(outa i (noddssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";noddssb: ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";noddssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";noddssb: ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";noddssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-asyfm 2000.0 :ratio .1)))
@@ -42708,8 +41897,8 @@ EDITS: 1
((= i 1000))
(outa i (asyfm-J gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";asyfm-J ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";asyfm-J max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";asyfm-J ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";asyfm-J max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-asyfm 2000.0 :ratio .1 :index 1))
@@ -42719,8 +41908,8 @@ EDITS: 1
(set! (gen 'r) (env r-env))
(outa i (asyfm-J gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";asyfm-J1 ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";asyfm-J1 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";asyfm-J1 ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";asyfm-J1 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-asyfm 2000.0 :ratio .1)))
@@ -42728,8 +41917,8 @@ EDITS: 1
((= i 1000))
(outa i (asyfm-I gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";asyfm-I ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";asyfm-I max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";asyfm-I ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";asyfm-I max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :statistics #t)
(let ((gen (make-nrcos 400.0 :n 5 :r 0.5)))
@@ -42737,8 +41926,8 @@ EDITS: 1
((= i 10000))
(outa i (nrcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nrcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nrcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nrcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((samps 44100)
@@ -42747,8 +41936,8 @@ EDITS: 1
((= i samps))
(outa i (noid gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";noid ~A" snd))
- (if (ffneq (maxamp snd) 0.6599) (snd-display #__line__ ";noid min-peak max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";noid ~A" snd))
+ (if (ffneq (maxamp snd) 0.6599) (snd-display ";noid min-peak max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((samps 44100)
@@ -42757,8 +41946,8 @@ EDITS: 1
((= i samps))
(outa i (noid gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";noid ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";noid max-peak max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";noid ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";noid max-peak max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nrcos 100 :n 15 :r 0.5))
@@ -42769,8 +41958,8 @@ EDITS: 1
(set-nrcos-scaler gen (env indr))
(outa i (nrcos gen)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrcos with scaler ~A" snd))
- ;(if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nrcos with scaler max: ~A" (maxamp snd)))
+ (if (not (sound? snd)) (snd-display ";nrcos with scaler ~A" snd))
+ ;(if (fneq (maxamp snd) 1.0) (snd-display ";nrcos with scaler max: ~A" (maxamp snd)))
;; this is not a new problem -- was the scaler supposed to fix maxamp?
)
@@ -42780,8 +41969,8 @@ EDITS: 1
((= i 20000))
(outa i (ncos2 gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";ncos2 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";ncos2 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";ncos2 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";ncos2 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-ncos4 100.0 :n 10)))
@@ -42789,8 +41978,8 @@ EDITS: 1
((= i 20000))
(outa i (ncos4 gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";ncos4 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";ncos4 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";ncos4 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";ncos4 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-npcos 100.0 :n 10)))
@@ -42798,8 +41987,8 @@ EDITS: 1
((= i 20000))
(outa i (npcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";npcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";npcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";npcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";npcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-n1cos 100.0 :n 10)))
@@ -42807,8 +41996,8 @@ EDITS: 1
((= i 20000))
(outa i (n1cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";n1cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";n1cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";n1cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";n1cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rcos 100.0 :r 0.5)))
@@ -42816,8 +42005,8 @@ EDITS: 1
((= i 20000))
(outa i (rcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-bess 100.0 :n 0)))
@@ -42825,8 +42014,8 @@ EDITS: 1
((= i 1000))
(outa i (bess gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";bess ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";bess max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";bess ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";bess max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen1 (make-bess 400.0 :n 1))
@@ -42836,8 +42025,8 @@ EDITS: 1
((= i 20000))
(outa i (bess gen1 (* (env vol) (bess gen2 0.0))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";bess 1 ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";bess 1 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";bess 1 ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";bess 1 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen1 (make-bess 400.0 :n 1))
@@ -42847,8 +42036,8 @@ EDITS: 1
((= i 20000))
(outa i (bess gen1 (* (env vol) (oscil gen2 0.0))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";bess 2 ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";bess 2 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";bess 2 ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";bess 2 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-eoddcos 400.0 :r 1.0)))
@@ -42856,8 +42045,8 @@ EDITS: 1
((= i 10000))
(outa i (eoddcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";eoddcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";eoddcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";eoddcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";eoddcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-eoddcos 400.0 :r 0.0))
@@ -42867,8 +42056,8 @@ EDITS: 1
(set! (gen 'r) (env a-env))
(outa i (eoddcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";eoddcos 1 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";eoddcos 1 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";eoddcos 1 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";eoddcos 1 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen1 (make-eoddcos 400.0 :r 0.0))
@@ -42879,8 +42068,8 @@ EDITS: 1
(set! (gen1 'r) (env a-env))
(outa i (eoddcos gen1 (* .1 (oscil gen2))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";eoddcos 2 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";eoddcos 2 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";eoddcos 2 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";eoddcos 2 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nssb 2000.0 0.05 3)))
@@ -42888,8 +42077,8 @@ EDITS: 1
((= i 10000))
(outa i (* .3 (nssb gen)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nssb ~A" snd))
- (if (fneq (maxamp snd) 0.3) (snd-display #__line__ ";nssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nssb ~A" snd))
+ (if (fneq (maxamp snd) 0.3) (snd-display ";nssb max: ~A" (maxamp snd))))
(let ()
(define (test-nssb-0)
@@ -42900,11 +42089,11 @@ EDITS: 1
(let ((v1 (nssb g1 1.0))
(v2 (nssb g2 1.0)))
(if (> (abs (- v1 v2)) 1e-6)
- (snd-display #__line__ ";nssb ~D (0): ~A ~A" i v1 v2)))
+ (snd-display ";nssb ~D (0): ~A ~A" i v1 v2)))
(let ((v1 (nssb g1 0.0))
(v2 (nssb g2)))
(if (> (abs (- v1 v2)) 1e-6)
- (snd-display #__line__ ";nssb ~D (1): ~A ~A" i v1 v2))))))
+ (snd-display ";nssb ~D (1): ~A ~A" i v1 v2))))))
(test-nssb-0)
(test-nssb-0)
@@ -42912,13 +42101,13 @@ EDITS: 1
(define (test-nssb-1)
(let ((g1 (make-nssb 10.0 1.0 1.0)))
(nssb g1 1.0)
- (if (not (= (g1 'fm) 1.0)) (snd-display #__line__ ";nssb 1: ~A" (g1 'fm)))
+ (if (not (= (g1 'fm) 1.0)) (snd-display ";nssb 1: ~A" (g1 'fm)))
(nssb g1 0.0)
- (if (not (= (g1 'fm) 0.0)) (snd-display #__line__ ";nssb 2: ~A" (g1 'fm)))
+ (if (not (= (g1 'fm) 0.0)) (snd-display ";nssb 2: ~A" (g1 'fm)))
(nssb g1 1.0)
- (if (not (= (g1 'fm) 1.0)) (snd-display #__line__ ";nssb 3: ~A" (g1 'fm)))
+ (if (not (= (g1 'fm) 1.0)) (snd-display ";nssb 3: ~A" (g1 'fm)))
(nssb g1)
- (if (not (= (g1 'fm) 0.0)) (snd-display #__line__ ";nssb 4: ~A" (g1 'fm)))
+ (if (not (= (g1 'fm) 0.0)) (snd-display ";nssb 4: ~A" (g1 'fm)))
))
(test-nssb-1)
@@ -42930,8 +42119,8 @@ EDITS: 1
((= i 10000))
(outa i (nrssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrssb ~A" snd))
- (if (fneq (maxamp snd) 0.777) (snd-display #__line__ ";nrssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nrssb ~A" snd))
+ (if (fneq (maxamp snd) 0.777) (snd-display ";nrssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rkcos 440.0 :r 0.5)))
@@ -42939,8 +42128,8 @@ EDITS: 1
((= i 10000))
(outa i (rkcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rkcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rkcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rkcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rkcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rk!cos 440.0 :r 0.5)))
@@ -42948,8 +42137,8 @@ EDITS: 1
((= i 10000))
(outa i (rk!cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rk!cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rk!cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rk!cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rk!cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-r2k!cos 440.0 :r 0.5 :k 3.0)))
@@ -42957,8 +42146,8 @@ EDITS: 1
((= i 10000))
(outa i (r2k!cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";r2k!cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";r2k!cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";r2k!cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";r2k!cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-k2sin 440.0)))
@@ -42966,8 +42155,8 @@ EDITS: 1
((= i 10000))
(outa i (k2sin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";k2sin ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";k2sin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";k2sin ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";k2sin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-k2cos 440.0)))
@@ -42975,8 +42164,8 @@ EDITS: 1
((= i 10000))
(outa i (k2cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";k2cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";k2cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";k2cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";k2cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-k2ssb 1000.0 0.1)))
@@ -42984,8 +42173,8 @@ EDITS: 1
((= i 10000))
(outa i (k2ssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";k2ssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";k2ssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";k2ssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";k2ssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rssb 1000 0.1 0.5)))
@@ -42993,8 +42182,8 @@ EDITS: 1
((= i 10000))
(outa i (rssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-dblsum 100 0.5)))
@@ -43002,8 +42191,8 @@ EDITS: 1
((= i 10000))
(outa i (* .47 (dblsum gen))))))) ; k starts at 0, so maxamp would be 2 except something else is wrong
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";dblsum ~A" snd))
- (if (> (maxamp snd) 1.0) (snd-display #__line__ ";dblsum max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";dblsum ~A" snd))
+ (if (> (maxamp snd) 1.0) (snd-display ";dblsum max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nkssb 1000.0 0.1 5)))
@@ -43011,8 +42200,8 @@ EDITS: 1
((= i 10000))
(outa i (nkssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nkssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nkssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nkssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nkssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nkssb 1000.0 0.1 5))
@@ -43021,8 +42210,8 @@ EDITS: 1
((= i 30000))
(outa i (nkssb gen (polywave vib)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nkssb 1 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nkssb 1 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nkssb 1 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nkssb 1 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nkssb 1000.0 0.1 5))
@@ -43032,8 +42221,8 @@ EDITS: 1
((= i 30000))
(outa i (nkssb-interp gen (polywave vib) (env move)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nkssb 2 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nkssb 2 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nkssb 2 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nkssb 2 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rkoddssb 1000.0 0.1 0.5)))
@@ -43041,8 +42230,8 @@ EDITS: 1
((= i 10000))
(outa i (rkoddssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rkoddssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rkoddssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rkoddssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rkoddssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-krksin 440.0 0.5)))
@@ -43050,7 +42239,7 @@ EDITS: 1
((= i 10000))
(outa i (krksin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";krksin ~A" snd)))
+ (if (not (sound? snd)) (snd-display ";krksin ~A" snd)))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-abcos 100.0 0.5 0.25)))
@@ -43058,8 +42247,8 @@ EDITS: 1
((= i 10000))
(outa i (abcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";abcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";abcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";abcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";abcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :statistics #t)
(let ((gen (make-absin 100.0 0.5 0.25)))
@@ -43067,8 +42256,8 @@ EDITS: 1
((= i 10000))
(outa i (absin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";absin ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";absin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";absin ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";absin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-r2k2cos 100.0 1.0)))
@@ -43076,8 +42265,8 @@ EDITS: 1
((= i 10000))
(outa i (r2k2cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";r2k2cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";r2k2cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";r2k2cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";r2k2cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-jjcos 100.0 :a 1.0 :r 1.0 :k 1)))
@@ -43085,8 +42274,8 @@ EDITS: 1
((= i 10000))
(outa i (jjcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";jjcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";jjcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";jjcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";jjcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-j0evencos 100.0 1.0)))
@@ -43094,8 +42283,8 @@ EDITS: 1
((= i 10000))
(outa i (j0evencos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";j0evencos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";j0evencos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";j0evencos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";j0evencos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rksin 100.0 :r 0.5)))
@@ -43103,8 +42292,8 @@ EDITS: 1
((= i 10000))
(outa i (rksin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rksin ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rksin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rksin ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rksin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rkssb 1000.0 0.1 :r 0.5)))
@@ -43112,8 +42301,8 @@ EDITS: 1
((= i 10000))
(outa i (rkssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rkssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rkssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rkssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rkssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rk!ssb 1000.0 0.1 :r 0.5)))
@@ -43121,8 +42310,8 @@ EDITS: 1
((= i 10000))
(outa i (rk!ssb gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rk!ssb ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rk!ssb max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rk!ssb ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rk!ssb max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-jpcos 100.0 :a 1.0 :r 0.99 :k 1)))
@@ -43130,8 +42319,8 @@ EDITS: 1
((= i 10000))
(outa i (jpcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";jpcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";jpcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";jpcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";jpcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-j2cos 100.0 :r 1.0 :n 0)))
@@ -43139,8 +42328,8 @@ EDITS: 1
((= i 10000))
(outa i (j2cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";j2cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";j2cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";j2cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";j2cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nxysin 300 1/3 3)))
@@ -43148,7 +42337,7 @@ EDITS: 1
((= i 10000))
(outa i (nxysin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nxysin ~A" snd)))
+ (if (not (sound? snd)) (snd-display ";nxysin ~A" snd)))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nxycos 300 1/3 3)))
@@ -43156,8 +42345,8 @@ EDITS: 1
((= i 10000))
(outa i (nxycos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nxycos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nxycos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nxycos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nxycos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nxy1cos 300 1/3 3)))
@@ -43165,8 +42354,8 @@ EDITS: 1
((= i 10000))
(outa i (nxy1cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nxy1cos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nxy1cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nxy1cos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nxy1cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nxy1sin 300 1/3 3)))
@@ -43174,8 +42363,8 @@ EDITS: 1
((= i 10000))
(outa i (nxy1sin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nxy1sin ~A" snd))
- (if (fneq (maxamp snd) 0.951) (snd-display #__line__ ";nxy1sin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nxy1sin ~A" snd))
+ (if (fneq (maxamp snd) 0.951) (snd-display ";nxy1sin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :statistics #t)
(let ((gen (make-nrxysin 1000 0.1 5 0.5)))
@@ -43183,8 +42372,8 @@ EDITS: 1
((= i 2000))
(outa i (nrxysin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrxysin ~A" snd))
- (if (fneq (maxamp snd) 0.985) (snd-display #__line__ ";nrxysin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nrxysin ~A" snd))
+ (if (fneq (maxamp snd) 0.985) (snd-display ";nrxysin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nrxycos 1000 0.1 5 0.5)))
@@ -43192,8 +42381,8 @@ EDITS: 1
((= i 2000))
(outa i (nrxycos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrxycos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nrxycos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nrxycos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nrxycos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-nrxycos 1000 0.1 15 0.5))
@@ -43203,8 +42392,8 @@ EDITS: 1
(set! (mus-scaler gen) (env indr))
(outa i (nrxycos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nrxycos with scaler ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nrxycos with scaler max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nrxycos with scaler ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nrxycos with scaler max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((black4 (make-blackman 440.0)))
@@ -43212,8 +42401,8 @@ EDITS: 1
((= i 10000))
(outa i (blackman black4 0.0))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";blackman ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";blackman max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";blackman ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";blackman max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((black4 (make-sinc-train 440.0 10)))
@@ -43221,8 +42410,8 @@ EDITS: 1
((= i 10000))
(outa i (sinc-train black4 0.0))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";sinc-train ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";sinc-train max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";sinc-train ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";sinc-train max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-k3sin 100.0)))
@@ -43230,8 +42419,8 @@ EDITS: 1
((= i 10000))
(outa i (k3sin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";k3sin ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";k3sin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";k3sin ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";k3sin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :statistics #t)
(let ((gen (make-izcos 100.0 1.0)))
@@ -43239,8 +42428,8 @@ EDITS: 1
((= i 30000))
(outa i (izcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";izcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";izcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";izcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";izcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rxysin 1000 0.1 0.5)))
@@ -43248,8 +42437,8 @@ EDITS: 1
((= i 10000))
(outa i (* .5 (rxysin gen)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rxysin ~A" snd))
- (if (> (maxamp snd) 1.0) (snd-display #__line__ ";rxysin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rxysin ~A" snd))
+ (if (> (maxamp snd) 1.0) (snd-display ";rxysin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rxycos 1000 0.1 0.5)))
@@ -43257,8 +42446,8 @@ EDITS: 1
((= i 10000))
(outa i (rxycos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rxycos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";rxycos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rxycos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";rxycos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :srate 44100)
(let ((gen (make-safe-rxycos 1000 0.1 0.5)))
@@ -43266,8 +42455,8 @@ EDITS: 1
((= i 10000))
(outa i (safe-rxycos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";safe-rxycos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";safe-rxycos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";safe-rxycos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";safe-rxycos max: ~A" (maxamp snd))))
(let* ((base-r 0.0)
(end-r 0.0)
@@ -43281,14 +42470,14 @@ EDITS: 1
((= i 10000))
(let ((fm (env frqf)))
(set-freq gen2 (+ 1000 (radians->hz fm)))
- (outa i (safe-rxycos gen1 fm))
- (outb i (safe-rxycos gen2 0.0))
- (set! end-r (clamp-rxycos-r gen2 0.0))))))))
+ (outa i (safe-rxycos gen1 fm)))
+ (outb i (safe-rxycos gen2 0.0))
+ (set! end-r (clamp-rxycos-r gen2 0.0)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";safe-rxycos 1 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";safe-rxycos 1 max: ~A" (maxamp snd)))
- (if (fneq base-r .588) (snd-display #__line__ ";safe-rxycos-r 1 base: ~A" base-r))
- (if (fneq end-r .316) (snd-display #__line__ ";safe-rxycos-r 1 end: ~A" end-r)))
+ (if (not (sound? snd)) (snd-display ";safe-rxycos 1 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";safe-rxycos 1 max: ~A" (maxamp snd)))
+ (if (fneq base-r .588) (snd-display ";safe-rxycos-r 1 base: ~A" base-r))
+ (if (fneq end-r .316) (snd-display ";safe-rxycos-r 1 end: ~A" end-r)))
(let* ((base-r 0.0)
(end-r 0.0)
@@ -43302,14 +42491,14 @@ EDITS: 1
((= i 10000))
(let ((fm (env frqf)))
(set-freq gen2 (+ 1000 (radians->hz fm)))
- (outa i (safe-rxycos gen1 fm))
- (outb i (safe-rxycos gen2 0.0))
- (set! end-r (clamp-rxycos-r gen2 0.0))))))))
+ (outa i (safe-rxycos gen1 fm)))
+ (outb i (safe-rxycos gen2 0.0))
+ (set! end-r (clamp-rxycos-r gen2 0.0)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";safe-rxycos 2 ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";safe-rxycos 2 max: ~A" (maxamp snd)))
- (if (fneq base-r .951) (snd-display #__line__ ";safe-rxycos-r 2 base: ~A" base-r))
- (if (fneq end-r .896) (snd-display #__line__ ";safe-rxycos-r 2 end: ~A" end-r)))
+ (if (not (sound? snd)) (snd-display ";safe-rxycos 2 ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";safe-rxycos 2 max: ~A" (maxamp snd)))
+ (if (fneq base-r .951) (snd-display ";safe-rxycos-r 2 base: ~A" base-r))
+ (if (fneq end-r .896) (snd-display ";safe-rxycos-r 2 end: ~A" end-r)))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rxyk!sin 1000 0.1 0.5)))
@@ -43317,8 +42506,8 @@ EDITS: 1
((= i 10000))
(outa i (rxyk!sin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rxyk!sin ~A" snd))
- (if (fneq (maxamp snd) 0.992) (snd-display #__line__ ";rxyk!sin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rxyk!sin ~A" snd))
+ (if (fneq (maxamp snd) 0.992) (snd-display ";rxyk!sin max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-rxyk!cos 1000 0.1 0.5)))
@@ -43326,8 +42515,8 @@ EDITS: 1
((= i 10000))
(outa i (rxyk!cos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";rxyk!cos ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";rxyk!cos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";rxyk!cos ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";rxyk!cos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :statistics #t :play #f)
(let ((gen (make-nsincos 100.0 3)))
@@ -43335,8 +42524,8 @@ EDITS: 1
((= i 20000))
(outa i (nsincos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nsincos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";nsincos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nsincos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";nsincos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f :play #f)
(let ((gen (make-nchoosekcos 2000.0 0.05 10)))
@@ -43344,8 +42533,8 @@ EDITS: 1
((= i 30000))
(outa i (nchoosekcos gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";nchoosekcos ~A" snd))
- (if (ffneq (maxamp snd) 1.0) (snd-display #__line__ ";nchoosekcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";nchoosekcos ~A" snd))
+ (if (ffneq (maxamp snd) 1.0) (snd-display ";nchoosekcos max: ~A" (maxamp snd))))
(let* ((res (with-sound ()
(let ((gen (make-adjustable-square-wave 100 .2 .5)))
@@ -43353,8 +42542,8 @@ EDITS: 1
((= i 200))
(outa i (adjustable-square-wave gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";adj sq ~A" snd))
- (if (fneq (maxamp snd) 0.5) (snd-display #__line__ ";adj sq max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";adj sq ~A" snd))
+ (if (fneq (maxamp snd) 0.5) (snd-display ";adj sq max: ~A" (maxamp snd))))
(let* ((res (with-sound ()
(let ((gen (make-adjustable-triangle-wave 100 .2 .5)))
@@ -43362,8 +42551,8 @@ EDITS: 1
((= i 22050))
(outa i (adjustable-triangle-wave gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";adj tri ~A" snd))
- (if (ffneq (maxamp snd) 0.5) (snd-display #__line__ ";adj tri max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";adj tri ~A" snd))
+ (if (ffneq (maxamp snd) 0.5) (snd-display ";adj tri max: ~A" (maxamp snd))))
(let* ((res (with-sound ()
(let ((gen (make-adjustable-sawtooth-wave 100 .2 .5)))
@@ -43371,8 +42560,8 @@ EDITS: 1
((= i 22050))
(outa i (adjustable-sawtooth-wave gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";adj saw ~A" snd))
- (if (ffneq (maxamp snd) 0.5) (snd-display #__line__ ";adj saw max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";adj saw ~A" snd))
+ (if (ffneq (maxamp snd) 0.5) (snd-display ";adj saw max: ~A" (maxamp snd))))
(with-sound (:clipped #f) ; at least run the thing -- not sure how to test this automatically
(let ((gen (make-pink-noise 12)))
@@ -43386,8 +42575,8 @@ EDITS: 1
((= i 10000))
(outa i (brown-noise gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";brown-noise ~A" snd))
- (if (< (maxamp snd) 0.01) (snd-display #__line__ ";brown-noise max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";brown-noise ~A" snd))
+ (if (< (maxamp snd) 0.01) (snd-display ";brown-noise max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise 100.0)))
@@ -43395,8 +42584,8 @@ EDITS: 1
((= i 10000))
(outa i (green-noise gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";green-noise ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display #__line__ ";green-noise max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";green-noise ~A" snd))
+ (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display ";green-noise max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise 100.0 0.1 -0.1 0.5)))
@@ -43404,8 +42593,8 @@ EDITS: 1
((= i 10000))
(outa i (green-noise gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";green-noise .5 ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display #__line__ ";green-noise .5 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";green-noise .5 ~A" snd))
+ (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display ";green-noise .5 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise-interp 100.0)))
@@ -43413,8 +42602,8 @@ EDITS: 1
((= i 10000))
(outa i (green-noise-interp gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";green-noise-interp ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display #__line__ ";green-noise-interp max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";green-noise-interp ~A" snd))
+ (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display ";green-noise-interp max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise-interp 100.0 0.1 -0.1 0.5)))
@@ -43422,8 +42611,8 @@ EDITS: 1
((= i 10000))
(outa i (green-noise-interp gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";green-noise-interp .5 ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display #__line__ ";green-noise-interp .5 max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";green-noise-interp .5 ~A" snd))
+ (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display ";green-noise-interp .5 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-tanhsin 440.0 2.0)))
@@ -43431,8 +42620,8 @@ EDITS: 1
((= i 10000))
(outa i (tanhsin gen))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";tanhsin ~A" snd))
- (if (> (abs (- 1.0 (maxamp snd))) 0.1) (snd-display #__line__ ";tanhsin max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";tanhsin ~A" snd))
+ (if (> (abs (- 1.0 (maxamp snd))) 0.1) (snd-display ";tanhsin max: ~A" (maxamp snd))))
(if (not (provided? 'snd-nogui))
(let* ((snd (new-sound))
@@ -43456,9 +42645,8 @@ EDITS: 1
(set! *clm-srate* cur-srate)
(let* ((scn (make-moving-pitch rd))
(pitch (moving-pitch scn)))
- (if (or (> pitch 443.0)
- (< pitch 439.0))
- (snd-display #__line__ ";moving-pitch 1a: ~A" pitch)))
+ (if (not (>= 443.0 pitch 439.0))
+ (snd-display ";moving-pitch 1a: ~A" pitch)))
(set! *clm-srate* old-srate))
(let ((val (make-vector 3))
@@ -43467,7 +42655,7 @@ EDITS: 1
(set! (val 1) (make-nrcos 200))
(set! (val 2) (make-nrcos 300))
(set! frq (mus-frequency (vector-ref val 1)))
- (if (fneq frq 200.0) (snd-display #__line__ ";defgen vect freq: ~A" frq)))
+ (if (fneq frq 200.0) (snd-display ";defgen vect freq: ~A" frq)))
(let ((val (make-vector 3))
(frq 0.0))
@@ -43477,7 +42665,7 @@ EDITS: 1
(set! frq (+ (mus-frequency (vector-ref val 0))
(mus-frequency (vector-ref val 1))
(mus-frequency (vector-ref val 2))))
- (if (fneq frq 600.0) (snd-display #__line__ ";defgen vect freq 1: ~A" frq)))
+ (if (fneq frq 600.0) (snd-display ";defgen vect freq 1: ~A" frq)))
(let ((val (make-vector 3))
(frq 0.0))
@@ -43486,7 +42674,7 @@ EDITS: 1
(set! (val 2) (make-nrcos 300))
(set! (mus-frequency (vector-ref val 1)) 500.0)
(set! frq (mus-frequency (vector-ref val 1)))
- (if (fneq frq 500.0) (snd-display #__line__ ";defgen set freq: ~A ~A" frq (mus-frequency (vector-ref val 1)))))
+ (if (fneq frq 500.0) (snd-display ";defgen set freq: ~A ~A" frq (mus-frequency (vector-ref val 1)))))
(let* ((res (with-sound (:clipped #f)
(let ((v (make-vector 2 #f)))
@@ -43496,8 +42684,8 @@ EDITS: 1
((= i 1000))
(outa i (nrcos (vector-ref v 0) 0.0))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";vect nrcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";vect nrcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";vect nrcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";vect nrcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((val (make-vector 2)))
@@ -43508,8 +42696,8 @@ EDITS: 1
(outa i (* .5 (+ (nrcos (vector-ref val 0) 0.0)
(nrcos (vector-ref val 1) 0.0))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";vect 2 nrcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";vect 2 nrcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";vect 2 nrcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";vect 2 nrcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen1 (make-nrcos 100 1 .1))
@@ -43519,8 +42707,8 @@ EDITS: 1
(outa i (* .5 (+ (nrcos gen1 0.0)
(nrcos gen2 0.0))))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";no vect 2 nrcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";no vect 2 nrcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";no vect 2 nrcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";no vect 2 nrcos max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((v (make-vector 2 #f)))
@@ -43531,38 +42719,39 @@ EDITS: 1
(let ((gen (vector-ref v 0)))
(outa i (nrcos gen)))))))
(snd (find-sound res)))
- (if (not (sound? snd)) (snd-display #__line__ ";vect let nrcos ~A" snd))
- (if (fneq (maxamp snd) 1.0) (snd-display #__line__ ";vect let nrcos max: ~A" (maxamp snd))))
+ (if (not (sound? snd)) (snd-display ";vect let nrcos ~A" snd))
+ (if (fneq (maxamp snd) 1.0) (snd-display ";vect let nrcos max: ~A" (maxamp snd))))
(with-sound (:play #t)
- (let* ((exp-amt 8.0)
- (dur 2.0)
- (samps (seconds->samples dur))
- (ampf (make-env '(0.000 0.000 0.011 0.147 0.023 0.131 0.028 0.034 0.059 0.000 0.063 0.153 0.067 0.113
- 0.072 0.391 0.081 0.095 0.088 0.052 0.102 0.025 0.124 0.000 0.131 0.452 0.139 0.327
- 0.144 0.099 0.156 0.097 0.160 0.048 0.186 0.000 0.194 0.438 0.200 0.366 0.201 0.156
- 0.211 0.063 0.247 0.000 0.256 0.628 0.268 0.154 0.274 0.190 0.285 0.027 0.296 0.059
- 0.309 0.031 0.312 0.481 0.322 0.939 0.331 0.314 0.351 0.061 0.363 0.099 0.374 0.056
- 0.377 0.438 0.389 0.858 0.394 0.467 0.403 0.241 0.414 0.197 0.415 0.127 0.425 0.075
- 0.436 0.090 0.441 0.526 0.454 0.869 0.471 0.239 0.490 0.029 0.503 0.117 0.505 0.485
- 0.514 0.811 0.528 0.415 0.538 0.088 0.552 0.056 0.561 0.106 0.580 0.075 0.597 0.000
- 0.776 0.000 0.777 0.573 0.786 0.145 0.801 0.054 0.826 0.000 0.827 0.632 0.844 1.000
- 0.856 0.524 0.866 0.031 0.883 0.074 0.891 0.136 0.896 0.745 0.907 0.424 0.915 0.765
- 0.934 0.059 0.951 0.048 0.962 0.079 0.970 0.436 0.986 0.266 1.000 0.000)
- :duration 0.25 :scaler 0.5))
- (frqf (make-env '(0.000 0.220 0.074 0.249 0.133 0.249 0.194 0.240 0.258 0.252 0.324 0.264 0.389 0.267
- 0.456 0.270 0.520 0.264 0.847 0.270 0.920 0.273 1.000 0.279)
- :duration 0.25 :scaler (hz->radians (* 0.5 0.205 22050.0))))
- (gen1 (make-polywave :partials (list 2 .35 3 .1 4 .8 5 .01 6 .03 8 .005)))
- (rnd (make-rand-interp 600 (hz->radians 50))))
- (define (ifunc dir)
- (* (env ampf)
- (polywave gen1 (+ (env frqf)
- (rand-interp rnd)))))
- (let ((gran (make-granulate :expansion exp-amt :input ifunc)))
- (do ((i 0 (+ i 1)))
- ((= i samps))
- (outa i (granulate gran))))))
+ (define ifunc
+ (let ((ampf (make-env '(0.000 0.000 0.011 0.147 0.023 0.131 0.028 0.034 0.059 0.000 0.063 0.153 0.067 0.113
+ 0.072 0.391 0.081 0.095 0.088 0.052 0.102 0.025 0.124 0.000 0.131 0.452 0.139 0.327
+ 0.144 0.099 0.156 0.097 0.160 0.048 0.186 0.000 0.194 0.438 0.200 0.366 0.201 0.156
+ 0.211 0.063 0.247 0.000 0.256 0.628 0.268 0.154 0.274 0.190 0.285 0.027 0.296 0.059
+ 0.309 0.031 0.312 0.481 0.322 0.939 0.331 0.314 0.351 0.061 0.363 0.099 0.374 0.056
+ 0.377 0.438 0.389 0.858 0.394 0.467 0.403 0.241 0.414 0.197 0.415 0.127 0.425 0.075
+ 0.436 0.090 0.441 0.526 0.454 0.869 0.471 0.239 0.490 0.029 0.503 0.117 0.505 0.485
+ 0.514 0.811 0.528 0.415 0.538 0.088 0.552 0.056 0.561 0.106 0.580 0.075 0.597 0.000
+ 0.776 0.000 0.777 0.573 0.786 0.145 0.801 0.054 0.826 0.000 0.827 0.632 0.844 1.000
+ 0.856 0.524 0.866 0.031 0.883 0.074 0.891 0.136 0.896 0.745 0.907 0.424 0.915 0.765
+ 0.934 0.059 0.951 0.048 0.962 0.079 0.970 0.436 0.986 0.266 1.000 0.000)
+ :duration 0.25 :scaler 0.5))
+ (frqf (make-env '(0.000 0.220 0.074 0.249 0.133 0.249 0.194 0.240 0.258 0.252 0.324 0.264 0.389 0.267
+ 0.456 0.270 0.520 0.264 0.847 0.270 0.920 0.273 1.000 0.279)
+ :duration 0.25 :scaler (hz->radians (* 0.5 0.205 22050.0))))
+ (gen1 (make-polywave :partials (list 2 .35 3 .1 4 .8 5 .01 6 .03 8 .005)))
+ (rnd (make-rand-interp 600 (hz->radians 50))))
+ (lambda (dir)
+ (* (env ampf)
+ (polywave gen1 (+ (env frqf)
+ (rand-interp rnd)))))))
+ (let* ((exp-amt 8.0)
+ (dur 2.0)
+ (samps (seconds->samples dur))
+ (gran (make-granulate :expansion exp-amt :input ifunc)))
+ (do ((i 0 (+ i 1)))
+ ((= i samps))
+ (outa i (granulate gran)))))
(calling-all-animals)
(calling-all-generators)
@@ -43647,7 +42836,7 @@ EDITS: 1
(val1 (oscil gen1 0.0 pm))
(val2 (run-with-fm-and-pm gen2 0.0 pm))) ; generators.scm
(if (fneq val1 val2)
- (snd-display #__line__ ";run-with-fm-and-pm: ~A ~A" val1 val2)))))
+ (snd-display ";run-with-fm-and-pm: ~A ~A" val1 val2)))))
(let ((gen1 (make-oscil 440.0))
(gen2 (make-oscil 440.0))
@@ -43661,7 +42850,7 @@ EDITS: 1
(if (fneq val1 val2)
(set! happy #f))))
(if (not happy)
- (snd-display #__line__ ";run-with-fm-and-pm unhappy")))
+ (snd-display ";run-with-fm-and-pm unhappy")))
(if (pair? (sounds)) (for-each close-sound (sounds)))
@@ -43696,188 +42885,185 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i len) new-str)
(let ((c (str i)))
- (if (memv c '(#\\ #\/))
- (string-set! new-str i #\_)
- (string-set! new-str i c))))))
+ (string-set! new-str i (if (memv c '(#\\ #\/)) #\_ c))))))
- (define (tagged-p val sym) (or (not val) (and (list? val) (pair? val) (eq? (car val) sym))))
- (define (array-p val type) (and (list? val) (or (null? val) (type (car val)))))
+ (define (tagged-p val sym) (or (not val) (and (list? val) (pair? val) (eq? (car val) sym))))
+ (define (array-p val type) (or (null? val) (and (pair? val) (type (car val)))))
(define XM_INT integer?)
(define (XM_ULONG val) (and (integer? val) (>= val 0)))
(define (XM_UCHAR val) (or (char? val) (and (integer? val) (>= val 0) (< val 65536))))
(define XM_FLOAT real?)
- (define (XM_STRING val) (or (not val) (string? val) (and (number? val) (= val 0))))
- (define (XM_XMSTRING val) (or (tagged-p val 'XmString) (and (number? val) (= val 0))))
- (define (XM_STRING_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'XmString))) (and (number? val) (= val 0))))
- (define (XM_INT_TABLE val) (or (array-p val integer?) (and (number? val) (= val 0))))
- (define (XM_BOOLEAN val) (or (boolean? val) (and (number? val) (= val 0))))
- (define (XM_RENDER_TABLE val) (or (tagged-p val 'XmRenderTable) (and (number? val) (= val 0))))
- (define (XM_TRANSFER_ENTRY_LIST val) (or (list? val) (and (number? val) (= val 0))))
- (define (XM_RECTANGLE_LIST val) (or (array-p val (lambda (n) (eq? (car n) 'XRectangle))) (and (number? val) (= val 0))))
- (define (XM_TAB_LIST val) (or (tagged-p val 'XmTabList) (and (number? val) (= val 0))))
- (define (XM_WIDGET_LIST val) (or (array-p val (lambda (n) (eq? (car n) 'Widget))) (and (number? val) (= val 0))))
- (define (XM_ATOM_LIST val) (or (not val) (array-p val (lambda (n) (eq? (car n) 'Atom))) (and (number? val) (= val 0))))
- (define (XM_STRING_LIST val) (or (array-p val (lambda (n) (eq? (car n) 'XmString))) (and (number? val) (= val 0))))
- (define (XM_CHARSET_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'CharSet))) (and (number? val) (= val 0))))
- (define (XM_KEYSYM_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'KeySym))) (and (number? val) (= val 0))))
- (define (XM_WIDGET val) (or (tagged-p val 'Widget) (and (number? val) (= val 0))))
- (define (XM_PIXEL val) (or (tagged-p val 'Pixel) (and (number? val) (= val 0))))
- (define (XM_PIXMAP val) (or (tagged-p val 'Pixmap) (and (number? val) (= val 0))))
- (define (XM_XFONTSTRUCT val) (or (tagged-p val 'XFontStruct) (and (number? val) (= val 0))))
+ (define (XM_STRING val) (or (not val) (string? val) (memv val '(0 0.0))))
+ (define (XM_XMSTRING val) (or (tagged-p val 'XmString) (memv val '(0 0.0))))
+ (define (XM_STRING_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'XmString))) (memv val '(0 0.0))))
+ (define (XM_INT_TABLE val) (or (array-p val integer?) (memv val '(0 0.0))))
+ (define (XM_BOOLEAN val) (memv val '(#f #t 0 0.0)))
+ (define (XM_RENDER_TABLE val) (or (tagged-p val 'XmRenderTable) (memv val '(0 0.0))))
+ (define (XM_TRANSFER_ENTRY_LIST val) (or (list? val) (memv val '(0 0.0))))
+ (define (XM_RECTANGLE_LIST val) (or (array-p val (lambda (n) (eq? (car n) 'XRectangle))) (memv val '(0 0.0))))
+ (define (XM_TAB_LIST val) (or (tagged-p val 'XmTabList) (memv val '(0 0.0))))
+ (define (XM_WIDGET_LIST val) (or (array-p val (lambda (n) (eq? (car n) 'Widget))) (memv val '(0 0.0))))
+ (define (XM_ATOM_LIST val) (or (not val) (array-p val (lambda (n) (eq? (car n) 'Atom))) (memv val '(0 0.0))))
+ (define XM_STRING_LIST XM_STRING_TABLE)
+ (define (XM_CHARSET_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'CharSet))) (memv val '(0 0.0))))
+ (define (XM_KEYSYM_TABLE val) (or (array-p val (lambda (n) (eq? (car n) 'KeySym))) (memv val '(0 0.0))))
+ (define (XM_WIDGET val) (or (tagged-p val 'Widget) (memv val '(0 0.0))))
+ (define (XM_PIXEL val) (or (tagged-p val 'Pixel) (memv val '(0 0.0))))
+ (define (XM_PIXMAP val) (or (tagged-p val 'Pixmap) (memv val '(0 0.0))))
+ (define (XM_XFONTSTRUCT val) (or (tagged-p val 'XFontStruct) (memv val '(0 0.0))))
(define (XM_DIMENSION val) (and (integer? val) (>= val 0) (< val 65536)))
- (define (XM_ATOM val) (or (tagged-p val 'Atom) (and (number? val) (= val 0))))
- (define (XM_TEXT_SOURCE val) (or (tagged-p val 'XmTextSource) (and (number? val) (= val 0))))
- (define (XM_COLORMAP val) (or (tagged-p val 'Colormap) (and (number? val) (= val 0))))
- (define (XM_KEYSYM val) (or (tagged-p val 'KeySym) (and (number? val) (= val 0))))
- (define (XM_SCREEN val) (or (tagged-p val 'Screen) (and (number? val) (= val 0))))
- (define (XM_WINDOW val) (or (tagged-p val 'Window) (and (number? val) (= val 0))))
- (define (XM_VISUAL val) (or (tagged-p val 'Visual) (and (number? val) (= val 0))))
- (define (XM_WIDGET_CLASS val) (or (tagged-p val 'WidgetClass) (and (number? val) (= val 0))))
+ (define (XM_ATOM val) (or (tagged-p val 'Atom) (memv val '(0 0.0))))
+ (define (XM_TEXT_SOURCE val) (or (tagged-p val 'XmTextSource) (memv val '(0 0.0))))
+ (define (XM_COLORMAP val) (or (tagged-p val 'Colormap) (memv val '(0 0.0))))
+ (define (XM_KEYSYM val) (or (tagged-p val 'KeySym) (memv val '(0 0.0))))
+ (define (XM_SCREEN val) (or (tagged-p val 'Screen) (memv val '(0 0.0))))
+ (define (XM_WINDOW val) (or (tagged-p val 'Window) (memv val '(0 0.0))))
+ (define (XM_VISUAL val) (or (tagged-p val 'Visual) (memv val '(0 0.0))))
+ (define (XM_WIDGET_CLASS val) (or (tagged-p val 'WidgetClass) (memv val '(0 0.0))))
(define (XM_STRING_OR_INT val) (or (string? val) (integer? val) (not val)))
- (define (XM_STRING_OR_XMSTRING val) (or (string? val) (not val) (and (list? val) (pair? val) (eq? (car val) 'XmString)) (and (number? val) (= val 0))))
+ (define (XM_STRING_OR_XMSTRING val) (or (string? val) (not val) (and (list? val) (pair? val) (eq? (car val) 'XmString)) (memv val '(0 0.0))))
(define (XM_POSITION val) (and (integer? val) (< (abs val) 65536)))
- (define (XM_SHORT val) (and (integer? val) (< (abs val) 65536)))
+ (define XM_SHORT XM_POSITION)
(define (XM_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_TRANSFER_CALLBACK val) (or (procedure? val) (not val) (integer? val) (and (list? val) (pair? val) (procedure? (car val)))))
- (define (XM_CONVERT_CALLBACK val) (or (procedure? val) (not val) (integer? val) (and (list? val) (pair? val) (procedure? (car val)))))
- (define (XM_SEARCH_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_ORDER_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_QUALIFY_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_ALLOC_COLOR_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_POPUP_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_SCREEN_COLOR_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_DROP_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
- (define (XM_PARSE_CALLBACK val) (or (procedure? val) (not val) (integer? val)))
+ (define (XM_TRANSFER_CALLBACK val) (or (procedure? val) (not val) (integer? val) (and (pair? val) (procedure? (car val)))))
+ (define XM_CONVERT_CALLBACK XM_TRANSFER_CALLBACK)
+ (define XM_SEARCH_CALLBACK XM_CALLBACK)
+ (define XM_ORDER_CALLBACK XM_CALLBACK)
+ (define XM_QUALIFY_CALLBACK XM_CALLBACK)
+ (define XM_ALLOC_COLOR_CALLBACK XM_CALLBACK)
+ (define XM_POPUP_CALLBACK XM_CALLBACK)
+ (define XM_SCREEN_COLOR_CALLBACK XM_CALLBACK)
+ (define XM_DROP_CALLBACK XM_CALLBACK)
+ (define XM_PARSE_CALLBACK XM_CALLBACK)
;; check some resource stuff first
(let ((hgt (cadr (XtVaGetValues (cadr (main-widgets)) (list XmNheight 0))))
(wid (cadr (XtVaGetValues (cadr (main-widgets)) (list XmNwidth 0)))))
(if (or (<= wid 0) (<= hgt 0) (> wid 65535) (> hgt 65535))
- (snd-display #__line__ ";Dimension miscast: ~A ~A" wid hgt)))
+ (snd-display ";Dimension miscast: ~A ~A" wid hgt)))
;; ---------------- X tests ----------------
(let ((scr (current-screen))
(dpy (XtDisplay (cadr (main-widgets)))))
- (if (and (not (= (.height scr) 1200))
- (not (= (.height scr) 1600)))
- (snd-display #__line__ ";screen height: ~A" (.height scr)))
- (if (and (not (= (.width scr) 1600))
- (not (= (.width scr) 2560)))
- (snd-display #__line__ ";screen width: ~A" (.width scr)))
+ (if (not (member (.height scr) '(1200 1600) =))
+ (snd-display ";screen height: ~A" (.height scr)))
+ (if (not (member (.width scr) '(1600 2560) =))
+ (snd-display ";screen width: ~A" (.width scr)))
(if (not (= (.ndepths scr) 7))
- (snd-display #__line__ ";screen ndepths: ~A" (.ndepths scr)))
- (let ((dps (.depths scr)))
- (if (or (not (= (length dps) (.ndepths scr)))
- (not (Depth? (car dps))))
- (snd-display #__line__ ";depths: ~A" (.depths scr)))
- (if (not (= (.depth (car dps)) 24)) (snd-display #__line__ ";.depths val: ~A" (map .depth dps)))
- (if (pair? (.visuals (car dps)))
- (if (not (Visual? (car (.visuals (car dps)))))
- (snd-display #__line__ ";visuals: ~A" (map .visuals dps))
- (if (not (= (.bits_per_rgb (car (.visuals (car dps)))) 8))
- (snd-display #__line__ ";bits/visuals: ~A" (map .bits_per_rgb (.visuals (car dps))))))
+ (snd-display ";screen ndepths: ~A" (.ndepths scr)))
+ (let* ((dps (.depths scr))
+ (cdp (car dps)))
+ (if (not (and (= (length dps) (.ndepths scr))
+ (Depth? cdp)))
+ (snd-display ";depths: ~A" (.depths scr)))
+ (if (not (= (.depth cdp) 24)) (snd-display ";.depths val: ~A" (map .depth dps)))
+ (if (pair? (.visuals cdp))
+ (if (not (Visual? (car (.visuals cdp))))
+ (snd-display ";visuals: ~A" (map .visuals dps))
+ (if (not (= (.bits_per_rgb (car (.visuals cdp))) 8))
+ (snd-display ";bits/visuals: ~A" (map .bits_per_rgb (.visuals cdp)))))
(if (and (cadr dps)
(pair? (.visuals (cadr dps))))
(if (not (Visual? (car (.visuals (cadr dps)))))
- (snd-display #__line__ ";visuals: ~A" (map .visuals dps))
+ (snd-display ";visuals: ~A" (map .visuals dps))
(if (not (= (.bits_per_rgb (car (.visuals (cadr dps)))) 8))
- (snd-display #__line__ ";bits/visuals: ~A" (map .bits_per_rgb (.visuals (cadr dps)))))))))
+ (snd-display ";bits/visuals: ~A" (map .bits_per_rgb (.visuals (cadr dps)))))))))
(if (not (= (cadr (.white_pixel scr)) 16777215))
- (snd-display #__line__ ";screen white_pixel: ~A" (.white_pixel scr)))
+ (snd-display ";screen white_pixel: ~A" (.white_pixel scr)))
(if (not (= (cadr (.black_pixel scr)) 0))
- (snd-display #__line__ ";screen black_pixel: ~A" (.black_pixel scr)))
+ (snd-display ";screen black_pixel: ~A" (.black_pixel scr)))
(if (.backing_store scr)
- (snd-display #__line__ ";screen backing_store: ~A" (.backing_store scr)))
+ (snd-display ";screen backing_store: ~A" (.backing_store scr)))
(if (not (= (.min_maps scr) 1))
- (snd-display #__line__ ";screen min_maps: ~A" (.min_maps scr)))
+ (snd-display ";screen min_maps: ~A" (.min_maps scr)))
(if (not (= (.max_maps scr) 1))
- (snd-display #__line__ ";screen max_maps: ~A" (.max_maps scr)))
+ (snd-display ";screen max_maps: ~A" (.max_maps scr)))
(if (.save_unders scr)
- (snd-display #__line__ ";screen save_unders: ~A" (.save_unders scr)))
+ (snd-display ";screen save_unders: ~A" (.save_unders scr)))
(if (not (GC? (.default_gc scr)))
- (snd-display #__line__ ";screen default_gc: ~A" (.default_gc scr)))
+ (snd-display ";screen default_gc: ~A" (.default_gc scr)))
(if (not (Window? (.root scr)))
- (snd-display #__line__ ";screen root: ~A" (.root scr)))
+ (snd-display ";screen root: ~A" (.root scr)))
(if (not (Colormap? (.cmap scr)))
- (snd-display #__line__ ";screen colormap: ~A" (.cmap scr)))
+ (snd-display ";screen colormap: ~A" (.cmap scr)))
(if (not (equal? (DisplayOfScreen scr) (.display scr)))
- (snd-display #__line__ ";DisplayOfScreen: ~A ~A" (DisplayOfScreen scr) (.display scr)))
+ (snd-display ";DisplayOfScreen: ~A ~A" (DisplayOfScreen scr) (.display scr)))
(if (not (equal? (RootWindowOfScreen scr) (.root scr)))
- (snd-display #__line__ ";RootWindowOfScreen: ~A ~A" (RootWindowOfScreen scr) (.root scr)))
+ (snd-display ";RootWindowOfScreen: ~A ~A" (RootWindowOfScreen scr) (.root scr)))
(if (not (equal? (BlackPixelOfScreen scr) (.black_pixel scr)))
- (snd-display #__line__ ";BlackPixelOfScreen: ~A ~A" (BlackPixelOfScreen scr) (.black_pixel scr)))
+ (snd-display ";BlackPixelOfScreen: ~A ~A" (BlackPixelOfScreen scr) (.black_pixel scr)))
(if (not (equal? (WhitePixelOfScreen scr) (.white_pixel scr)))
- (snd-display #__line__ ";WhitePixelOfScreen: ~A ~A" (WhitePixelOfScreen scr) (.white_pixel scr)))
+ (snd-display ";WhitePixelOfScreen: ~A ~A" (WhitePixelOfScreen scr) (.white_pixel scr)))
(if (not (equal? (DefaultColormapOfScreen scr) (.cmap scr)))
- (snd-display #__line__ ";DefaultColormapOfScreen: ~A ~A" (DefaultColormapOfScreen scr) (.cmap scr)))
+ (snd-display ";DefaultColormapOfScreen: ~A ~A" (DefaultColormapOfScreen scr) (.cmap scr)))
(if (not (equal? (DefaultDepthOfScreen scr) (.root_depth scr)))
- (snd-display #__line__ ";DefaultDepthOfScreen: ~A ~A" (DefaultDepthOfScreen scr) (.root_depth scr)))
+ (snd-display ";DefaultDepthOfScreen: ~A ~A" (DefaultDepthOfScreen scr) (.root_depth scr)))
(if (not (equal? (DefaultGCOfScreen scr) (.default_gc scr)))
- (snd-display #__line__ ";DefaultGCOfScreen: ~A ~A" (DefaultGCOfScreen scr) (.default_gc scr)))
+ (snd-display ";DefaultGCOfScreen: ~A ~A" (DefaultGCOfScreen scr) (.default_gc scr)))
(if (not (equal? (DefaultVisualOfScreen scr) (.root_visual scr)))
- (snd-display #__line__ ";DefaultVisualOfScreen: ~A ~A" (DefaultVisualOfScreen scr) (.root_visual scr)))
+ (snd-display ";DefaultVisualOfScreen: ~A ~A" (DefaultVisualOfScreen scr) (.root_visual scr)))
(if (not (equal? (WidthOfScreen scr) (.width scr)))
- (snd-display #__line__ ";WidthOfScreen: ~A ~A" (WidthOfScreen scr) (.width scr)))
+ (snd-display ";WidthOfScreen: ~A ~A" (WidthOfScreen scr) (.width scr)))
(if (not (equal? (HeightOfScreen scr) (.height scr)))
- (snd-display #__line__ ";HeightOfScreen: ~A ~A" (HeightOfScreen scr) (.height scr)))
+ (snd-display ";HeightOfScreen: ~A ~A" (HeightOfScreen scr) (.height scr)))
(if (not (equal? (WidthMMOfScreen scr) (.mwidth scr)))
- (snd-display #__line__ ";WidthMMOfScreen: ~A ~A" (WidthMMOfScreen scr) (.mwidth scr)))
+ (snd-display ";WidthMMOfScreen: ~A ~A" (WidthMMOfScreen scr) (.mwidth scr)))
(if (not (equal? (HeightMMOfScreen scr) (.mheight scr)))
- (snd-display #__line__ ";HeightMMOfScreen: ~A ~A" (HeightMMOfScreen scr) (.mheight scr)))
+ (snd-display ";HeightMMOfScreen: ~A ~A" (HeightMMOfScreen scr) (.mheight scr)))
(if (not (equal? (PlanesOfScreen scr) (.root_depth scr)))
- (snd-display #__line__ ";PlanesOfScreen: ~A ~A" (PlanesOfScreen scr) (.root_depth scr)))
+ (snd-display ";PlanesOfScreen: ~A ~A" (PlanesOfScreen scr) (.root_depth scr)))
(if (not (equal? (MinCmapsOfScreen scr) (.min_maps scr)))
- (snd-display #__line__ ";MinCmapsOfScreen: ~A ~A" (MinCmapsOfScreen scr) (.min_maps scr)))
+ (snd-display ";MinCmapsOfScreen: ~A ~A" (MinCmapsOfScreen scr) (.min_maps scr)))
(if (not (equal? (MaxCmapsOfScreen scr) (.max_maps scr)))
- (snd-display #__line__ ";MaxCmapsOfScreen: ~A ~A" (MaxCmapsOfScreen scr) (.max_maps scr)))
+ (snd-display ";MaxCmapsOfScreen: ~A ~A" (MaxCmapsOfScreen scr) (.max_maps scr)))
(if (not (equal? (DoesSaveUnders scr) (.save_unders scr)))
- (snd-display #__line__ ";DoesSaveUnders: ~A ~A" (DoesSaveUnders scr) (.save_unders scr)))
+ (snd-display ";DoesSaveUnders: ~A ~A" (DoesSaveUnders scr) (.save_unders scr)))
(if (not (equal? (DoesBackingStore scr) (.backing_store scr)))
- (snd-display #__line__ ";DoesBackingStore: ~A ~A" (DoesBackingStore scr) (.backing_store scr)))
+ (snd-display ";DoesBackingStore: ~A ~A" (DoesBackingStore scr) (.backing_store scr)))
(if (not (equal? (EventMaskOfScreen scr) (.root_input_mask scr)))
- (snd-display #__line__ ";EventMaskOfScreen: ~A ~A" (EventMaskOfScreen scr) (.root_input_mask scr)))
+ (snd-display ";EventMaskOfScreen: ~A ~A" (EventMaskOfScreen scr) (.root_input_mask scr)))
(if (not (equal? (XDisplayOfScreen scr) (.display scr)))
- (snd-display #__line__ ";XDisplayOfScreen: ~A ~A" (XDisplayOfScreen scr) (.display scr)))
+ (snd-display ";XDisplayOfScreen: ~A ~A" (XDisplayOfScreen scr) (.display scr)))
(if (not (equal? (XDisplayOfScreen (XScreenOfDisplay dpy 0)) dpy))
- (snd-display #__line__ ";XScreenOfDisplay ~A ~A" (XDisplayOfScreen (XScreenOfDisplay dpy 0)) dpy))
+ (snd-display ";XScreenOfDisplay ~A ~A" (XDisplayOfScreen (XScreenOfDisplay dpy 0)) dpy))
(if (not (equal? (XDefaultScreenOfDisplay dpy) scr))
- (snd-display #__line__ ";XDefaultScreenOfDisplay ~A ~A" (XDefaultScreenOfDisplay dpy) scr))
+ (snd-display ";XDefaultScreenOfDisplay ~A ~A" (XDefaultScreenOfDisplay dpy) scr))
(if (not (equal? (XRootWindowOfScreen scr) (.root scr)))
- (snd-display #__line__ ";XRootWindowOfScreen: ~A ~A" (XRootWindowOfScreen scr) (.root scr)))
+ (snd-display ";XRootWindowOfScreen: ~A ~A" (XRootWindowOfScreen scr) (.root scr)))
(if (not (equal? (XBlackPixelOfScreen scr) (.black_pixel scr)))
- (snd-display #__line__ ";XBlackPixelOfScreen: ~A ~A" (XBlackPixelOfScreen scr) (.black_pixel scr)))
+ (snd-display ";XBlackPixelOfScreen: ~A ~A" (XBlackPixelOfScreen scr) (.black_pixel scr)))
(if (not (equal? (XWhitePixelOfScreen scr) (.white_pixel scr)))
- (snd-display #__line__ ";XWhitePixelOfScreen: ~A ~A" (XWhitePixelOfScreen scr) (.white_pixel scr)))
+ (snd-display ";XWhitePixelOfScreen: ~A ~A" (XWhitePixelOfScreen scr) (.white_pixel scr)))
(if (not (equal? (XDefaultColormapOfScreen scr) (.cmap scr)))
- (snd-display #__line__ ";XDefaultColormapOfScreen: ~A ~A" (XDefaultColormapOfScreen scr) (.cmap scr)))
+ (snd-display ";XDefaultColormapOfScreen: ~A ~A" (XDefaultColormapOfScreen scr) (.cmap scr)))
(if (not (equal? (XDefaultDepthOfScreen scr) (.root_depth scr)))
- (snd-display #__line__ ";XDefaultDepthOfScreen: ~A ~A" (XDefaultDepthOfScreen scr) (.root_depth scr)))
+ (snd-display ";XDefaultDepthOfScreen: ~A ~A" (XDefaultDepthOfScreen scr) (.root_depth scr)))
(if (not (equal? (XDefaultGCOfScreen scr) (.default_gc scr)))
- (snd-display #__line__ ";XDefaultGCOfScreen: ~A ~A" (XDefaultGCOfScreen scr) (.default_gc scr)))
+ (snd-display ";XDefaultGCOfScreen: ~A ~A" (XDefaultGCOfScreen scr) (.default_gc scr)))
(if (not (equal? (XDefaultVisualOfScreen scr) (.root_visual scr)))
- (snd-display #__line__ ";XDefaultVisualOfScreen: ~A ~A" (XDefaultVisualOfScreen scr) (.root_visual scr)))
+ (snd-display ";XDefaultVisualOfScreen: ~A ~A" (XDefaultVisualOfScreen scr) (.root_visual scr)))
(if (not (equal? (XWidthOfScreen scr) (.width scr)))
- (snd-display #__line__ ";XWidthOfScreen: ~A ~A" (XWidthOfScreen scr) (.width scr)))
+ (snd-display ";XWidthOfScreen: ~A ~A" (XWidthOfScreen scr) (.width scr)))
(if (not (equal? (XHeightOfScreen scr) (.height scr)))
- (snd-display #__line__ ";XHeightOfScreen: ~A ~A" (XHeightOfScreen scr) (.height scr)))
+ (snd-display ";XHeightOfScreen: ~A ~A" (XHeightOfScreen scr) (.height scr)))
(if (not (equal? (XWidthMMOfScreen scr) (.mwidth scr)))
- (snd-display #__line__ ";XWidthMMOfScreen: ~A ~A" (XWidthMMOfScreen scr) (.mwidth scr)))
+ (snd-display ";XWidthMMOfScreen: ~A ~A" (XWidthMMOfScreen scr) (.mwidth scr)))
(if (not (equal? (XHeightMMOfScreen scr) (.mheight scr)))
- (snd-display #__line__ ";XHeightMMOfScreen: ~A ~A" (XHeightMMOfScreen scr) (.mheight scr)))
+ (snd-display ";XHeightMMOfScreen: ~A ~A" (XHeightMMOfScreen scr) (.mheight scr)))
(if (not (equal? (XPlanesOfScreen scr) (.root_depth scr)))
- (snd-display #__line__ ";XPlanesOfScreen: ~A ~A" (XPlanesOfScreen scr) (.root_depth scr)))
+ (snd-display ";XPlanesOfScreen: ~A ~A" (XPlanesOfScreen scr) (.root_depth scr)))
(if (not (equal? (XMinCmapsOfScreen scr) (.min_maps scr)))
- (snd-display #__line__ ";XMinCmapsOfScreen: ~A ~A" (XMinCmapsOfScreen scr) (.min_maps scr)))
+ (snd-display ";XMinCmapsOfScreen: ~A ~A" (XMinCmapsOfScreen scr) (.min_maps scr)))
(if (not (equal? (XMaxCmapsOfScreen scr) (.max_maps scr)))
- (snd-display #__line__ ";XMaxCmapsOfScreen: ~A ~A" (XMaxCmapsOfScreen scr) (.max_maps scr)))
+ (snd-display ";XMaxCmapsOfScreen: ~A ~A" (XMaxCmapsOfScreen scr) (.max_maps scr)))
(if (not (equal? (XDoesSaveUnders scr) (.save_unders scr)))
- (snd-display #__line__ ";XDoesSaveUnders: ~A ~A" (XDoesSaveUnders scr) (.save_unders scr)))
+ (snd-display ";XDoesSaveUnders: ~A ~A" (XDoesSaveUnders scr) (.save_unders scr)))
(if (not (equal? (XDoesBackingStore scr) (.backing_store scr)))
- (snd-display #__line__ ";XDoesBackingStore: ~A ~A" (XDoesBackingStore scr) (.backing_store scr)))
+ (snd-display ";XDoesBackingStore: ~A ~A" (XDoesBackingStore scr) (.backing_store scr)))
(if (not (equal? (XEventMaskOfScreen scr) (.root_input_mask scr)))
- (snd-display #__line__ ";XEventMaskOfScreen: ~A ~A" (XEventMaskOfScreen scr) (.root_input_mask scr)))
+ (snd-display ";XEventMaskOfScreen: ~A ~A" (XEventMaskOfScreen scr) (.root_input_mask scr)))
)
(let* ((scr (current-screen))
@@ -43887,178 +43073,173 @@ EDITS: 1
(win (XtWindow (cadr (main-widgets)))))
(if (not (equal? (RootWindow dpy scrn) (.root scr)))
- (snd-display #__line__ ";RootWindow: ~A ~A" (RootWindow dpy scrn) (.root scr)))
+ (snd-display ";RootWindow: ~A ~A" (RootWindow dpy scrn) (.root scr)))
(if (not (equal? (DefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
- (snd-display #__line__ ";DefaultRootWindow: ~A ~A" (DefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
+ (snd-display ";DefaultRootWindow: ~A ~A" (DefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
(if (not (equal? (DefaultVisual dpy scrn) (.root_visual scr)))
- (snd-display #__line__ ";DefaultVisual: ~A ~A" (DefaultVisual dpy scrn) (.root_visual scr)))
+ (snd-display ";DefaultVisual: ~A ~A" (DefaultVisual dpy scrn) (.root_visual scr)))
(if (not (equal? (DefaultGC dpy scrn) (.default_gc scr)))
- (snd-display #__line__ ";DefaultGC: ~A ~A" (DefaultGC dpy scrn) (.default_gc scr)))
+ (snd-display ";DefaultGC: ~A ~A" (DefaultGC dpy scrn) (.default_gc scr)))
(if (not (equal? (BlackPixel dpy scrn) (.black_pixel scr)))
- (snd-display #__line__ ";BlackPixel: ~A ~A" (BlackPixel dpy scrn) (.black_pixel scr)))
+ (snd-display ";BlackPixel: ~A ~A" (BlackPixel dpy scrn) (.black_pixel scr)))
(if (not (equal? (WhitePixel dpy scrn) (.white_pixel scr)))
- (snd-display #__line__ ";WhitePixel ~A ~A" (WhitePixel dpy scrn) (.white_pixel scr)))
+ (snd-display ";WhitePixel ~A ~A" (WhitePixel dpy scrn) (.white_pixel scr)))
(if (not (equal? (DisplayWidth dpy scrn) (.width scr)))
- (snd-display #__line__ ";DisplayWidth: ~A ~A" (DisplayWidth dpy scrn) (.width scr)))
+ (snd-display ";DisplayWidth: ~A ~A" (DisplayWidth dpy scrn) (.width scr)))
(if (not (equal? (DisplayHeight dpy scrn) (.height scr)))
- (snd-display #__line__ ";DisplayHeight: ~A ~A" (DisplayHeight dpy scrn) (.height scr)))
+ (snd-display ";DisplayHeight: ~A ~A" (DisplayHeight dpy scrn) (.height scr)))
(if (not (equal? (DisplayWidthMM dpy scrn) (.mwidth scr)))
- (snd-display #__line__ ";DisplayWidthMM: ~A ~A" (DisplayWidthMM dpy scrn) (.mwidth scr)))
+ (snd-display ";DisplayWidthMM: ~A ~A" (DisplayWidthMM dpy scrn) (.mwidth scr)))
(if (not (equal? (DisplayHeightMM dpy scrn) (.mheight scr)))
- (snd-display #__line__ ";DisplayHeightMM: ~A ~A" (DisplayHeightMM dpy scrn) (.mheight scr)))
+ (snd-display ";DisplayHeightMM: ~A ~A" (DisplayHeightMM dpy scrn) (.mheight scr)))
(if (not (equal? (DisplayPlanes dpy scrn) (.root_depth scr)))
- (snd-display #__line__ ";DisplayPlanes: ~A ~A" (DisplayPlanes dpy scrn) (.root_depth scr)))
+ (snd-display ";DisplayPlanes: ~A ~A" (DisplayPlanes dpy scrn) (.root_depth scr)))
(if (not (equal? (DefaultDepth dpy scrn) (.root_depth scr)))
- (snd-display #__line__ ";DefaultDepth: ~A ~A" (DefaultDepth dpy scrn) (.root_depth scr)))
+ (snd-display ";DefaultDepth: ~A ~A" (DefaultDepth dpy scrn) (.root_depth scr)))
(if (not (equal? (DefaultColormap dpy scrn) (.cmap scr)))
- (snd-display #__line__ ";DefaultColormap: ~A ~A" (DefaultColormap dpy scrn) (.cmap scr)))
+ (snd-display ";DefaultColormap: ~A ~A" (DefaultColormap dpy scrn) (.cmap scr)))
(if (not (equal? (XRootWindow dpy scrn) (.root scr)))
- (snd-display #__line__ ";XRootWindow: ~A ~A" (XRootWindow dpy scrn) (.root scr)))
+ (snd-display ";XRootWindow: ~A ~A" (XRootWindow dpy scrn) (.root scr)))
(if (not (equal? (XDefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
- (snd-display #__line__ ";XDefaultRootWindow: ~A ~A" (XDefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
+ (snd-display ";XDefaultRootWindow: ~A ~A" (XDefaultRootWindow dpy) (.root (ScreenOfDisplay dpy (DefaultScreen dpy)))))
(if (not (equal? (XDefaultVisual dpy scrn) (.root_visual scr)))
- (snd-display #__line__ ";XDefaultVisual: ~A ~A" (XDefaultVisual dpy scrn) (.root_visual scr)))
+ (snd-display ";XDefaultVisual: ~A ~A" (XDefaultVisual dpy scrn) (.root_visual scr)))
(if (not (equal? (XDefaultGC dpy scrn) (.default_gc scr)))
- (snd-display #__line__ ";XDefaultGC: ~A ~A" (XDefaultGC dpy scrn) (.default_gc scr)))
+ (snd-display ";XDefaultGC: ~A ~A" (XDefaultGC dpy scrn) (.default_gc scr)))
(if (not (equal? (XBlackPixel dpy scrn) (.black_pixel scr)))
- (snd-display #__line__ ";XBlackPixel: ~A ~A" (XBlackPixel dpy scrn) (.black_pixel scr)))
+ (snd-display ";XBlackPixel: ~A ~A" (XBlackPixel dpy scrn) (.black_pixel scr)))
(if (not (equal? (XWhitePixel dpy scrn) (.white_pixel scr)))
- (snd-display #__line__ ";XWhitePixel ~A ~A" (XWhitePixel dpy scrn) (.white_pixel scr)))
+ (snd-display ";XWhitePixel ~A ~A" (XWhitePixel dpy scrn) (.white_pixel scr)))
(if (not (equal? (XDisplayWidth dpy scrn) (.width scr)))
- (snd-display #__line__ ";XDisplayWidth: ~A ~A" (XDisplayWidth dpy scrn) (.width scr)))
+ (snd-display ";XDisplayWidth: ~A ~A" (XDisplayWidth dpy scrn) (.width scr)))
(if (not (equal? (XDisplayHeight dpy scrn) (.height scr)))
- (snd-display #__line__ ";XDisplayHeight: ~A ~A" (XDisplayHeight dpy scrn) (.height scr)))
+ (snd-display ";XDisplayHeight: ~A ~A" (XDisplayHeight dpy scrn) (.height scr)))
(if (not (equal? (XDisplayWidthMM dpy scrn) (.mwidth scr)))
- (snd-display #__line__ ";XDisplayWidthMM: ~A ~A" (XDisplayWidthMM dpy scrn) (.mwidth scr)))
+ (snd-display ";XDisplayWidthMM: ~A ~A" (XDisplayWidthMM dpy scrn) (.mwidth scr)))
(if (not (equal? (XDisplayHeightMM dpy scrn) (.mheight scr)))
- (snd-display #__line__ ";XDisplayHeightMM: ~A ~A" (XDisplayHeightMM dpy scrn) (.mheight scr)))
+ (snd-display ";XDisplayHeightMM: ~A ~A" (XDisplayHeightMM dpy scrn) (.mheight scr)))
(if (not (equal? (XDisplayPlanes dpy scrn) (.root_depth scr)))
- (snd-display #__line__ ";XDisplayPlanes: ~A ~A" (XDisplayPlanes dpy scrn) (.root_depth scr)))
+ (snd-display ";XDisplayPlanes: ~A ~A" (XDisplayPlanes dpy scrn) (.root_depth scr)))
(if (not (equal? (XDefaultDepth dpy scrn) (.root_depth scr)))
- (snd-display #__line__ ";XDefaultDepth: ~A ~A" (XDefaultDepth dpy scrn) (.root_depth scr)))
+ (snd-display ";XDefaultDepth: ~A ~A" (XDefaultDepth dpy scrn) (.root_depth scr)))
(if (not (equal? (XDefaultColormap dpy scrn) (.cmap scr)))
- (snd-display #__line__ ";XDefaultColormap: ~A ~A" (XDefaultColormap dpy scrn) (.cmap scr)))
+ (snd-display ";XDefaultColormap: ~A ~A" (XDefaultColormap dpy scrn) (.cmap scr)))
(if (not (equal? (XDefaultVisual dpy scrn) vis))
- (snd-display #__line__ ";XDefaultVisual: ~A ~A" (XDefaultVisual dpy scrn) vis))
+ (snd-display ";XDefaultVisual: ~A ~A" (XDefaultVisual dpy scrn) vis))
(if (not (equal? (DisplayCells dpy scrn) (.map_entries vis)))
- (snd-display #__line__ ";DisplayCells: ~A ~A" (DisplayCells dpy scrn) (.map_entries vis)))
+ (snd-display ";DisplayCells: ~A ~A" (DisplayCells dpy scrn) (.map_entries vis)))
(if (not (equal? (CellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
- (snd-display #__line__ ";CellsOfScreen: ~A ~A" (CellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
+ (snd-display ";CellsOfScreen: ~A ~A" (CellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
(if (not (equal? (XDisplayCells dpy scrn) (.map_entries vis)))
- (snd-display #__line__ ";XDisplayCells: ~A ~A" (XDisplayCells dpy scrn) (.map_entries vis)))
+ (snd-display ";XDisplayCells: ~A ~A" (XDisplayCells dpy scrn) (.map_entries vis)))
(if (not (equal? (XCellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
- (snd-display #__line__ ";XCellsOfScreen: ~A ~A" (XCellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
+ (snd-display ";XCellsOfScreen: ~A ~A" (XCellsOfScreen scr) (.map_entries (DefaultVisualOfScreen scr))))
(if (< (XNextRequest dpy) (XLastKnownRequestProcessed dpy))
- (snd-display #__line__ ";XRequests: ~A ~A" (XNextRequest dpy) (XLastKnownRequestProcessed dpy)))
+ (snd-display ";XRequests: ~A ~A" (XNextRequest dpy) (XLastKnownRequestProcessed dpy)))
(if (< (NextRequest dpy) (LastKnownRequestProcessed dpy))
- (snd-display #__line__ ";Requests: ~A ~A" (NextRequest dpy) (LastKnownRequestProcessed dpy)))
+ (snd-display ";Requests: ~A ~A" (NextRequest dpy) (LastKnownRequestProcessed dpy)))
(if (not (= (XDisplayMotionBufferSize dpy) 256))
- (snd-display #__line__ ";XDisplayMotionBufferSize: ~A" (XDisplayMotionBufferSize dpy)))
+ (snd-display ";XDisplayMotionBufferSize: ~A" (XDisplayMotionBufferSize dpy)))
(XGetMotionEvents dpy win (list 'Time 100) (list 'Time CurrentTime))
(let ((lmapk (XNewModifiermap 2))
(kcd (list 'KeyCode 50)))
(if (not (XModifierKeymap? lmapk))
- (snd-display #__line__ ";xNewModifiermap: ~A" lmapk)
- (begin
- (set! lmapk (XInsertModifiermapEntry lmapk kcd ShiftMapIndex))
- (set! lmapk (XDeleteModifiermapEntry lmapk kcd ShiftMapIndex))
- ; (XFreeModifiermap lmapk) ;prone to segfault in X
- )))
+ (snd-display ";xNewModifiermap: ~A" lmapk)
+ (set! lmapk (XDeleteModifiermapEntry (XInsertModifiermapEntry lmapk kcd ShiftMapIndex) kcd ShiftMapIndex))))
(if (not (= (XExtendedMaxRequestSize dpy) 4194303))
- (snd-display #__line__ ";XExtendedMaxRequestSize ~A" (XExtendedMaxRequestSize dpy)))
+ (snd-display ";XExtendedMaxRequestSize ~A" (XExtendedMaxRequestSize dpy)))
(if (not (= (XMaxRequestSize dpy) 65535))
- (snd-display #__line__ ";XMaxRequestSize ~A" (XMaxRequestSize dpy)))
+ (snd-display ";XMaxRequestSize ~A" (XMaxRequestSize dpy)))
(if (not (member (list 'Atom 40) (XListProperties dpy win)))
- (snd-display #__line__ ";XListProperties: ~A" (XListProperties dpy win)))
+ (snd-display ";XListProperties: ~A" (XListProperties dpy win)))
(if (not (member "SHAPE" (XListExtensions dpy)))
- (snd-display #__line__ ";XListExtensions: ~A" (XListExtensions dpy)))
+ (snd-display ";XListExtensions: ~A" (XListExtensions dpy)))
(let ((val (XListInstalledColormaps dpy win)))
- (if (or (not val)
- (null? val)
+ (if (or (memq val '(#f ()))
(not (Colormap? (car val))))
- (snd-display #__line__ ";XListInstalledColormaps: ~A" (XListInstalledColormaps dpy win))))
+ (snd-display ";XListInstalledColormaps: ~A" (XListInstalledColormaps dpy win))))
(if (not (string=? (XKeysymToString (list 'KeySym 80)) "P"))
- (snd-display #__line__ ";XKeysymToString: ~A" (XKeysymToString (list 'KeySym 80))))
+ (snd-display ";XKeysymToString: ~A" (XKeysymToString (list 'KeySym 80))))
(if (not (string=? (XGetAtomName dpy (list 'Atom 40)) "WM_NORMAL_HINTS"))
- (snd-display #__line__ ";XGetAtomName: ~A" (XGetAtomName dpy (list 'Atom 40))))
-
- (if (not (= (.bits_per_rgb vis) 8)) (snd-display #__line__ ";bits_per_rgb: ~A" (.bits_per_rgb vis)))
- (if (not (= (.blue_mask vis) 255)) (snd-display #__line__ ";blue_mask: ~A" (.blue_mask vis)))
- (if (not (= (.green_mask vis) 65280)) (snd-display #__line__ ";green_mask: ~A" (.green_mask vis)))
- (if (not (= (.red_mask vis) 16711680)) (snd-display #__line__ ";red_mask: ~A" (.red_mask vis)))
- (if (not (= AllPlanes 4294967295)) (snd-display #__line__ ";AllPlanes: ~A" AllPlanes))
-
- (if (< (QLength dpy) 0) (snd-display #__line__ ";QLength: ~A" (QLength dpy)))
- (if (not (= (ScreenCount dpy) 1)) (snd-display #__line__ ";ScreenCount: ~A" (ScreenCount dpy)))
- (if (not (string=? (ServerVendor dpy) "The X.Org Foundation")) (snd-display #__line__ ";ServerVendor: ~A" (ServerVendor dpy)))
- (if (not (= (ProtocolRevision dpy) 0)) (snd-display #__line__ ";ProtocolRevision: ~A" (ProtocolRevision dpy)))
- (if (not (= (ProtocolVersion dpy) 11)) (snd-display #__line__ ";ProtocolVersion: ~A" (ProtocolVersion dpy)))
- (if (not (number? (VendorRelease dpy))) (snd-display #__line__ ";VendorRelease: ~A" (VendorRelease dpy)))
- (if (not (string=? (DisplayString dpy) ":0.0")) (snd-display #__line__ ";DisplayString: ~A" (DisplayString dpy)))
- (if (not (= (BitmapUnit dpy) 32)) (snd-display #__line__ ";BitmapUnit: ~A" (BitmapUnit dpy)))
- (if (not (= (BitmapPad dpy) 32)) (snd-display #__line__ ";BitmapPad: ~A" (BitmapPad dpy)))
- (if (not (= (BitmapBitOrder dpy) 0)) (snd-display #__line__ ";BitmapBitOrder: ~A" (BitmapBitOrder dpy)))
- (if (not (= (ImageByteOrder dpy) 0)) (snd-display #__line__ ";ImageByteOrder: ~A" (ImageByteOrder dpy)))
- (if (not (= (DefaultScreen dpy) 0)) (snd-display #__line__ ";DefaultScreen: ~A" (DefaultScreen dpy)))
+ (snd-display ";XGetAtomName: ~A" (XGetAtomName dpy (list 'Atom 40))))
+
+ (if (not (= (.bits_per_rgb vis) 8)) (snd-display ";bits_per_rgb: ~A" (.bits_per_rgb vis)))
+ (if (not (= (.blue_mask vis) 255)) (snd-display ";blue_mask: ~A" (.blue_mask vis)))
+ (if (not (= (.green_mask vis) 65280)) (snd-display ";green_mask: ~A" (.green_mask vis)))
+ (if (not (= (.red_mask vis) 16711680)) (snd-display ";red_mask: ~A" (.red_mask vis)))
+ (if (not (= AllPlanes 4294967295)) (snd-display ";AllPlanes: ~A" AllPlanes))
+
+ (if (< (QLength dpy) 0) (snd-display ";QLength: ~A" (QLength dpy)))
+ (if (not (= (ScreenCount dpy) 1)) (snd-display ";ScreenCount: ~A" (ScreenCount dpy)))
+ (if (not (string=? (ServerVendor dpy) "The X.Org Foundation")) (snd-display ";ServerVendor: ~A" (ServerVendor dpy)))
+ (if (not (= (ProtocolRevision dpy) 0)) (snd-display ";ProtocolRevision: ~A" (ProtocolRevision dpy)))
+ (if (not (= (ProtocolVersion dpy) 11)) (snd-display ";ProtocolVersion: ~A" (ProtocolVersion dpy)))
+ (if (not (number? (VendorRelease dpy))) (snd-display ";VendorRelease: ~A" (VendorRelease dpy)))
+ (if (not (string=? (DisplayString dpy) ":0.0")) (snd-display ";DisplayString: ~A" (DisplayString dpy)))
+ (if (not (= (BitmapUnit dpy) 32)) (snd-display ";BitmapUnit: ~A" (BitmapUnit dpy)))
+ (if (not (= (BitmapPad dpy) 32)) (snd-display ";BitmapPad: ~A" (BitmapPad dpy)))
+ (if (not (= (BitmapBitOrder dpy) 0)) (snd-display ";BitmapBitOrder: ~A" (BitmapBitOrder dpy)))
+ (if (not (= (ImageByteOrder dpy) 0)) (snd-display ";ImageByteOrder: ~A" (ImageByteOrder dpy)))
+ (if (not (= (DefaultScreen dpy) 0)) (snd-display ";DefaultScreen: ~A" (DefaultScreen dpy)))
(let* ((col (XColor))
(col1 (XColor))
(dpy (XtDisplay (cadr (main-widgets))))
(scr (DefaultScreen dpy))
(cmap (DefaultColormap dpy scr)))
- (if (= (XAllocNamedColor dpy cmap "blue" col col) 0) (snd-display #__line__ ";XAllocNamedColor blue ~A?" col))
- (if (not (= (.red col) 0)) (snd-display #__line__ ";XAllocNamedColor: ~A" (.red col)))
- (if (= (XAllocColor dpy cmap col) 0) (snd-display #__line__ ";XAllocColor?"))
- (if (not (= (.red col) 0)) (snd-display #__line__ ";XAllocColor: ~A" (.red col)))
- (if (= (XParseColor dpy cmap "blue" col) 0) (snd-display #__line__ ";XParseColor?"))
- (if (not (= (.red col) 0)) (snd-display #__line__ ";XParseColor: ~A" (.red col)))
- (if (= (XAllocNamedColor dpy cmap "green" col1 col1) 0) (snd-display #__line__ ";XAllocNamedColor green ~A?" col1))
+ (if (= (XAllocNamedColor dpy cmap "blue" col col) 0) (snd-display ";XAllocNamedColor blue ~A?" col))
+ (if (not (= (.red col) 0)) (snd-display ";XAllocNamedColor: ~A" (.red col)))
+ (if (= (XAllocColor dpy cmap col) 0) (snd-display ";XAllocColor?"))
+ (if (not (= (.red col) 0)) (snd-display ";XAllocColor: ~A" (.red col)))
+ (if (= (XParseColor dpy cmap "blue" col) 0) (snd-display ";XParseColor?"))
+ (if (not (= (.red col) 0)) (snd-display ";XParseColor: ~A" (.red col)))
+ (if (= (XAllocNamedColor dpy cmap "green" col1 col1) 0) (snd-display ";XAllocNamedColor green ~A?" col1))
(XQueryColor dpy cmap col)
(XQueryColors dpy cmap (list col col1)))
(XSetAfterFunction dpy (lambda (n) 0))
(XSetAfterFunction dpy #f)
(if (not (equal? (XDisplayKeycodes dpy) (list 1 8 255)))
- (snd-display #__line__ ";XDisplayKeycodes: ~A" (XDisplayKeycodes dpy)))
+ (snd-display ";XDisplayKeycodes: ~A" (XDisplayKeycodes dpy)))
(let ((str (XFetchName dpy win)))
(if (not (string=? (substring str 0 3) "snd"))
- (snd-display #__line__ ";XFetchName: ~A" str)))
+ (snd-display ";XFetchName: ~A" str)))
(XStoreName dpy win "hiho")
(let ((str (XFetchName dpy win)))
(if (not (string=? str "hiho"))
- (snd-display #__line__ ";XStoreName: ~A" str)))
+ (snd-display ";XStoreName: ~A" str)))
(XStoreName dpy win "snd")
(let ((str (XGetIconName dpy win)))
(if (not (string=? str "snd"))
- (snd-display #__line__ ";XGetIconName: ~A" str)))
+ (snd-display ";XGetIconName: ~A" str)))
(XSetIconName dpy win "hiho")
(let ((str (XGetIconName dpy win)))
(if (not (string=? str "hiho"))
- (snd-display #__line__ ";XSetIconName: ~A" str)))
+ (snd-display ";XSetIconName: ~A" str)))
(let ((geo (XGetGeometry dpy win)))
- (if (or (not (= (window-width) (geo 4)))
- (not (= (window-height) (geo 5))))
- (snd-display #__line__ ";XGetGeometry: ~A (~A ~A)" geo (window-width) (window-height))))
+ (if (not (and (= (window-width) (geo 4))
+ (= (window-height) (geo 5))))
+ (snd-display ";XGetGeometry: ~A (~A ~A)" geo (window-width) (window-height))))
(let ((focus (XGetInputFocus dpy)))
- (if (or (not (= (car focus) 1))
- (not (Window? (cadr focus))))
- (snd-display #__line__ ";XGetInputFocus: ~A" focus)))
+ (if (not (and (= (car focus) 1)
+ (Window? (cadr focus))))
+ (snd-display ";XGetInputFocus: ~A" focus)))
(let ((vals (XGetPointerControl dpy)))
- (if (not (equal? vals (list 1 2 1 4))) (snd-display #__line__ ";pointer state: ~A" vals))
+ (if (not (equal? vals (list 1 2 1 4))) (snd-display ";pointer state: ~A" vals))
(XChangePointerControl dpy #f #t 2 1 8)
(set! vals (XGetPointerControl dpy))
- (if (not (equal? vals (list 1 2 1 8))) (snd-display #__line__ ";set pointer state: ~A" vals))
+ (if (not (equal? vals (list 1 2 1 8))) (snd-display ";set pointer state: ~A" vals))
(XChangePointerControl dpy #f #t 2 1 4))
(XAutoRepeatOff dpy)
- (if (not (= ((XGetKeyboardControl dpy) 5) 0)) (snd-display #__line__ ";AutoRepeatOff?"))
+ (if (not (= ((XGetKeyboardControl dpy) 5) 0)) (snd-display ";AutoRepeatOff?"))
(XAutoRepeatOn dpy)
- (if (not (= ((XGetKeyboardControl dpy) 5) 1)) (snd-display #__line__ ";AutoRepeatOn?"))
+ (if (not (= ((XGetKeyboardControl dpy) 5) 1)) (snd-display ";AutoRepeatOn?"))
(let ((vals (XGetPointerMapping dpy 0 3)))
- (if (not (equal? vals (list 1 2 3))) (snd-display #__line__ ";XGetPointerMapping: ~A" vals)))
+ (if (not (equal? vals (list 1 2 3))) (snd-display ";XGetPointerMapping: ~A" vals)))
(XGetScreenSaver dpy)
(XMoveWindow dpy win 100 10)
(XSync dpy #f)
@@ -44067,77 +43248,73 @@ EDITS: 1
(XMoveResizeWindow dpy win 120 20 500 500)
(XSync dpy #f)
(let ((attr (XGetWindowAttributes dpy win)))
- (if (> (abs (- (.x attr) 120)) 200) (snd-display #__line__ ";XMoveWindow x etc: ~A" (.x attr)))
- (if (> (abs (- (.y attr) 20)) 200) (snd-display #__line__ ";XMoveWindow y etc: ~A" (.y attr)))
- (if (> (abs (- (.width attr) 500)) 20) (snd-display #__line__ ";XMoveWindow width etc: ~A" (.width attr)))
- (if (> (abs (- (.height attr) 500)) 20) (snd-display #__line__ ";XMoveWindow height etc: ~A" (.height attr)))
- (if (not (= (.border_width attr) 0)) (snd-display #__line__ ";XGetWindowAttributes border_width: ~A" (.border_width attr)))
- (if (not (= (.depth attr) 24)) (snd-display #__line__ ";XGetWindowAttributes depth: ~A" (.depth attr)))
- (if (not (= (.bit_gravity attr) 0)) (snd-display #__line__ ";XGetWindowAttributes bit_gravity: ~A" (.bit_gravity attr)))
- (if (not (= (.win_gravity attr) 1)) (snd-display #__line__ ";XGetWindowAttributes win_gravity: ~A" (.win_gravity attr)))
- (if (.backing_store attr) (snd-display #__line__ ";XGetWindowAttributes backing_store: ~A" (.backing_store attr)))
- (if (.override_redirect attr) (snd-display #__line__ ";XGetWindowAttributes override_redirect: ~A" (.override_redirect attr)))
- (if (.save_under attr) (snd-display #__line__ ";XGetWindowAttributes save_under: ~A" (.save_under attr)))
- ; (if (.map_installed attr) (snd-display #__line__ ";XGetWindowAttributes map_installed: ~A" (.map_installed attr)))
- (if (not (equal? (.backing_pixel attr) (list 'Pixel 0))) (snd-display #__line__ ";XGetWindowAttributes backing_pixel: ~A" (.backing_pixel attr)))
- (if (not (= (.map_state attr) 2)) (snd-display #__line__ ";XGetWindowAttributes map_state: ~A" (.map_state attr)))
- (if (not (= (.your_event_mask attr) #x628033)) (snd-display #__line__ ";your_event_mask: ~X" (.your_event_mask attr)))
- (if (and (not (= (.all_event_masks attr) #x628033))
- (not (= (.all_event_masks attr) #xe28033))
- (not (= (.all_event_masks attr) #xea8033)))
- (snd-display #__line__ ";all_event_masks: ~X" (.all_event_masks attr)))
- (if (not (Screen? (.screen attr))) (snd-display #__line__ ";XGetWindowAttributes screen: ~A" (.screen attr)))
- (if (and (not (= (.do_not_propagate_mask attr) 0))
- (not (= (.do_not_propagate_mask attr) 8204)))
- (snd-display #__line__ ";XGetWindowAttributes do_not_propagate_mask: ~A" (.do_not_propagate_mask attr)))
- (if (not (= (.backing_planes attr) AllPlanes)) (snd-display #__line__ ";XGetWindowAttributes backing_planes: ~A" (.backing_planes attr)))
- (if (not (= (.win_gravity attr) 1)) (snd-display #__line__ ";XGetWindowAttributes win_gravity: ~A" (.win_gravity attr)))
- (if (not (= (.bit_gravity attr) 0)) (snd-display #__line__ ";XGetWindowAttributes bit_gravity: ~A" (.bit_gravity attr)))
+ (if (> (abs (- (.x attr) 120)) 200) (snd-display ";XMoveWindow x etc: ~A" (.x attr)))
+ (if (> (abs (- (.y attr) 20)) 200) (snd-display ";XMoveWindow y etc: ~A" (.y attr)))
+ (if (> (abs (- (.width attr) 500)) 20) (snd-display ";XMoveWindow width etc: ~A" (.width attr)))
+ (if (> (abs (- (.height attr) 500)) 20) (snd-display ";XMoveWindow height etc: ~A" (.height attr)))
+ (if (not (= (.border_width attr) 0)) (snd-display ";XGetWindowAttributes border_width: ~A" (.border_width attr)))
+ (if (not (= (.depth attr) 24)) (snd-display ";XGetWindowAttributes depth: ~A" (.depth attr)))
+ (if (not (= (.bit_gravity attr) 0)) (snd-display ";XGetWindowAttributes bit_gravity: ~A" (.bit_gravity attr)))
+ (if (not (= (.win_gravity attr) 1)) (snd-display ";XGetWindowAttributes win_gravity: ~A" (.win_gravity attr)))
+ (if (.backing_store attr) (snd-display ";XGetWindowAttributes backing_store: ~A" (.backing_store attr)))
+ (if (.override_redirect attr) (snd-display ";XGetWindowAttributes override_redirect: ~A" (.override_redirect attr)))
+ (if (.save_under attr) (snd-display ";XGetWindowAttributes save_under: ~A" (.save_under attr)))
+ (if (not (equal? (.backing_pixel attr) (list 'Pixel 0))) (snd-display ";XGetWindowAttributes backing_pixel: ~A" (.backing_pixel attr)))
+ (if (not (= (.map_state attr) 2)) (snd-display ";XGetWindowAttributes map_state: ~A" (.map_state attr)))
+ (if (not (= (.your_event_mask attr) #x628033)) (snd-display ";your_event_mask: ~X" (.your_event_mask attr)))
+ (if (not (member (.all_event_masks attr) '(#x628033 #xe28033 #xea8033) =))
+ (snd-display ";all_event_masks: ~X" (.all_event_masks attr)))
+ (if (not (Screen? (.screen attr))) (snd-display ";XGetWindowAttributes screen: ~A" (.screen attr)))
+ (if (not (member (.do_not_propagate_mask attr) '(0 8204) =))
+ (snd-display ";XGetWindowAttributes do_not_propagate_mask: ~A" (.do_not_propagate_mask attr)))
+ (if (not (= (.backing_planes attr) AllPlanes)) (snd-display ";XGetWindowAttributes backing_planes: ~A" (.backing_planes attr)))
+ (if (not (= (.win_gravity attr) 1)) (snd-display ";XGetWindowAttributes win_gravity: ~A" (.win_gravity attr)))
+ (if (not (= (.bit_gravity attr) 0)) (snd-display ";XGetWindowAttributes bit_gravity: ~A" (.bit_gravity attr)))
;(segfault) (XFree (cadr attr))
)
(XResetScreenSaver dpy)
- (if (< (XPending dpy) 0) (snd-display #__line__ ";XPending: ~A" (XPending dpy)))
+ (if (< (XPending dpy) 0) (snd-display ";XPending: ~A" (XPending dpy)))
(XNoOp dpy)
(XQueryBestStipple dpy win 100 100)
(XQueryBestTile dpy win 100 100)
(XQueryBestSize dpy 0 win 100 100)
(let ((ext (XQueryExtension dpy "SHAPE")))
(if (not (eq? (car ext) #t))
- (snd-display #__line__ ";XQueryExtension: ~A" ext)))
+ (snd-display ";XQueryExtension: ~A" ext)))
(XQueryKeymap dpy)
(let ((tree (XQueryTree dpy win)))
- (if (or (not (= (car tree) 1))
- (not (equal? (XRootWindow dpy 0) (cadr tree))))
- (snd-display #__line__ ";XQueryTree: ~A (~A)" tree (XRootWindow dpy 0))))
-
- (if (< (XQLength dpy) 0) (snd-display #__line__ ";XQLength: ~A" (XQLength dpy)))
- (if (not (= (XScreenCount dpy) 1)) (snd-display #__line__ ";XScreenCount: ~A" (XScreenCount dpy)))
- (if (not (string=? (XServerVendor dpy) "The X.Org Foundation")) (snd-display #__line__ ";XServerVendor: ~A" (XServerVendor dpy)))
- (if (not (= (XProtocolRevision dpy) 0)) (snd-display #__line__ ";XProtocolRevision: ~A" (XProtocolRevision dpy)))
- (if (not (= (XProtocolVersion dpy) 11)) (snd-display #__line__ ";XProtocolVersion: ~A" (XProtocolVersion dpy)))
- (if (not (number? (XVendorRelease dpy))) (snd-display #__line__ ";XVendorRelease: ~A" (XVendorRelease dpy)))
- (if (not (string=? (XDisplayString dpy) ":0.0")) (snd-display #__line__ ";XDisplayString: ~A" (XDisplayString dpy)))
- (if (not (= (XBitmapUnit dpy) 32)) (snd-display #__line__ ";XBitmapUnit: ~A" (XBitmapUnit dpy)))
- (if (not (= (XBitmapPad dpy) 32)) (snd-display #__line__ ";XBitmapPad: ~A" (XBitmapPad dpy)))
- (if (not (= (XBitmapBitOrder dpy) 0)) (snd-display #__line__ ";XBitmapBitOrder: ~A" (XBitmapBitOrder dpy)))
- (if (not (= (XImageByteOrder dpy) 0)) (snd-display #__line__ ";XImageByteOrder: ~A" (XImageByteOrder dpy)))
- (if (not (= (XDefaultScreen dpy) 0)) (snd-display #__line__ ";XDefaultScreen: ~A" (XDefaultScreen dpy)))
- (if (XGetIconSizes dpy win) (snd-display #__line__ ";XGetIconSizes: ~A" (XGetIconSizes dpy win)))
+ (if (not (and (= (car tree) 1)
+ (equal? (XRootWindow dpy 0) (cadr tree))))
+ (snd-display ";XQueryTree: ~A (~A)" tree (XRootWindow dpy 0))))
+
+ (if (< (XQLength dpy) 0) (snd-display ";XQLength: ~A" (XQLength dpy)))
+ (if (not (= (XScreenCount dpy) 1)) (snd-display ";XScreenCount: ~A" (XScreenCount dpy)))
+ (if (not (string=? (XServerVendor dpy) "The X.Org Foundation")) (snd-display ";XServerVendor: ~A" (XServerVendor dpy)))
+ (if (not (= (XProtocolRevision dpy) 0)) (snd-display ";XProtocolRevision: ~A" (XProtocolRevision dpy)))
+ (if (not (= (XProtocolVersion dpy) 11)) (snd-display ";XProtocolVersion: ~A" (XProtocolVersion dpy)))
+ (if (not (number? (XVendorRelease dpy))) (snd-display ";XVendorRelease: ~A" (XVendorRelease dpy)))
+ (if (not (string=? (XDisplayString dpy) ":0.0")) (snd-display ";XDisplayString: ~A" (XDisplayString dpy)))
+ (if (not (= (XBitmapUnit dpy) 32)) (snd-display ";XBitmapUnit: ~A" (XBitmapUnit dpy)))
+ (if (not (= (XBitmapPad dpy) 32)) (snd-display ";XBitmapPad: ~A" (XBitmapPad dpy)))
+ (if (not (= (XBitmapBitOrder dpy) 0)) (snd-display ";XBitmapBitOrder: ~A" (XBitmapBitOrder dpy)))
+ (if (not (= (XImageByteOrder dpy) 0)) (snd-display ";XImageByteOrder: ~A" (XImageByteOrder dpy)))
+ (if (not (= (XDefaultScreen dpy) 0)) (snd-display ";XDefaultScreen: ~A" (XDefaultScreen dpy)))
+ (if (XGetIconSizes dpy win) (snd-display ";XGetIconSizes: ~A" (XGetIconSizes dpy win)))
(if (XGetRGBColormaps dpy win XA_RGB_DEFAULT_MAP)
- (snd-display #__line__ ";XGetRGBColormaps: ~A!" (XGetRGBColormaps dpy win XA_RGB_DEFAULT_MAP)))
+ (snd-display ";XGetRGBColormaps: ~A!" (XGetRGBColormaps dpy win XA_RGB_DEFAULT_MAP)))
(let ((cmap (XAllocStandardColormap)))
(for-each
(lambda (func name)
- (if (not (= (func cmap) 0)) (snd-display #__line__ ";standardcolormap ~A: ~A" name (func cmap))))
+ (if (not (= (func cmap) 0)) (snd-display ";standardcolormap ~A: ~A" name (func cmap))))
(list .visualid .red_max .red_mult .green_max .green_mult .blue_max .blue_mult)
(list 'visualid 'red_max 'red_mult 'green_max 'green_mult 'blue_max 'blue_mult))
- (if (.colormap cmap) (snd-display #__line__ ";colormap: ~A" (.colormap cmap)))
+ (if (.colormap cmap) (snd-display ";colormap: ~A" (.colormap cmap)))
(XtFree (cadr cmap))
)
(let ((icon (XAllocIconSize)))
(for-each
(lambda (func name)
- (if (not (= (func icon) 0)) (snd-display #__line__ ";iconsize ~A: ~A" name (func icon))))
+ (if (not (= (func icon) 0)) (snd-display ";iconsize ~A: ~A" name (func icon))))
(list .min_width .min_height .max_width .max_height .width_inc .height_inc)
(list 'min_width 'min_height 'max_width 'max_height 'width_inc 'height_inc))
(XFree icon))
@@ -44145,56 +43322,56 @@ EDITS: 1
(let ((fs (XCreateFontSet dpy "*-*-*-*-Normal-*-*-*-*-*-*")))
(if (or (not (XFontSet? fs))
(= (cadr fs) 0))
- (snd-display #__line__ ";XCreateFontSet: ~A" fs)
+ (snd-display ";XCreateFontSet: ~A" fs)
(let* ((fnts (XFontsOfFontSet fs))
(fnt (caar fnts)))
(if (not (XFontStruct? fnt))
- (snd-display #__line__ ";XFontsOfFontSet: ~A" fnts))
+ (snd-display ";XFontsOfFontSet: ~A" fnts))
(if (XContextualDrawing fs)
- (snd-display #__line__ ";XContextualDrawing: ~A" (XContextualDrawing fs)))
+ (snd-display ";XContextualDrawing: ~A" (XContextualDrawing fs)))
(if (XContextDependentDrawing fs)
- (snd-display #__line__ ";XContextDependentDrawing: ~A" (XContextDependentDrawing fs)))
+ (snd-display ";XContextDependentDrawing: ~A" (XContextDependentDrawing fs)))
(if (XDirectionalDependentDrawing fs)
- (snd-display #__line__ ";XDirectionalDependentDrawing: ~A" (XDirectionalDependentDrawing fs)))
+ (snd-display ";XDirectionalDependentDrawing: ~A" (XDirectionalDependentDrawing fs)))
(if (not (string=? (XLocaleOfFontSet fs) "en_US"))
- (snd-display #__line__ ";XLocaleOfFontSet: ~A" (XLocaleOfFontSet fs)))
+ (snd-display ";XLocaleOfFontSet: ~A" (XLocaleOfFontSet fs)))
(if (not (string=? (XBaseFontNameListOfFontSet fs) "*-*-*-*-Normal-*-*-*-*-*-*"))
- (snd-display #__line__ ";XBaseFontNameListOfFontSet: ~A" (XBaseFontNameListOfFontSet fs)))
- (if fnt
- (let ((wgt (XGetFontProperty fnt XA_WEIGHT))
- (siz (XGetFontProperty fnt XA_POINT_SIZE)))
- (if (or (not (= (cadr wgt) 10))
- (not (= (cadr siz) 120)))
- (snd-display #__line__ ";XGetFontProperty: ~A ~A" wgt siz))
- (if (not (= (.descent fnt) 2)) (snd-display #__line__ ";descent: ~A" (.descent fnt)))
- (if (not (= (.ascent fnt) 11)) (snd-display #__line__ ";ascent: ~A" (.ascent fnt)))
- (if (not (XCharStruct? (.per_char fnt))) (snd-display #__line__ ";per_char: ~A" (.per_char fnt)))
- (if (not (XCharStruct? (.max_bounds fnt))) (snd-display #__line__ ";max_bounds: ~A" (.max_bounds fnt)))
- (if (not (XCharStruct? (.min_bounds fnt))) (snd-display #__line__ ";min_bounds: ~A" (.min_bounds fnt)))
- (if (not (XFontProp? (car (.properties fnt)))) (snd-display #__line__ ";properties ~A" (.properties fnt)))
- (if (not (= (.card32 (car (.properties fnt))) 7)) (snd-display #__line__ ";card32: ~A" (.card32 (car (.properties fnt)))))))
+ (snd-display ";XBaseFontNameListOfFontSet: ~A" (XBaseFontNameListOfFontSet fs)))
+ (when fnt
+ (let ((wgt (XGetFontProperty fnt XA_WEIGHT))
+ (siz (XGetFontProperty fnt XA_POINT_SIZE)))
+ (if (not (and (= (cadr wgt) 10)
+ (= (cadr siz) 120)))
+ (snd-display ";XGetFontProperty: ~A ~A" wgt siz)))
+ (if (not (= (.descent fnt) 2)) (snd-display ";descent: ~A" (.descent fnt)))
+ (if (not (= (.ascent fnt) 11)) (snd-display ";ascent: ~A" (.ascent fnt)))
+ (if (not (XCharStruct? (.per_char fnt))) (snd-display ";per_char: ~A" (.per_char fnt)))
+ (if (not (XCharStruct? (.max_bounds fnt))) (snd-display ";max_bounds: ~A" (.max_bounds fnt)))
+ (if (not (XCharStruct? (.min_bounds fnt))) (snd-display ";min_bounds: ~A" (.min_bounds fnt)))
+ (if (not (XFontProp? (car (.properties fnt)))) (snd-display ";properties ~A" (.properties fnt)))
+ (if (not (= (.card32 (car (.properties fnt))) 7)) (snd-display ";card32: ~A" (.card32 (car (.properties fnt))))))
(XFreeFontSet dpy fs))))
(XBell dpy 10)
(let ((cmd (XGetCommand dpy win)))
(if (or (<= (length cmd) 0)
(not (string=? (substring (car cmd) (- (length (car cmd)) 3)) "snd")))
- (snd-display #__line__ ";XGetCommand: ~A" cmd)))
+ (snd-display ";XGetCommand: ~A" cmd)))
(XSetCommand dpy win (list "hiho" "away") 2)
(if (not (equal? (XGetCommand dpy win) (list "hiho" "away")))
- (snd-display #__line__ ";XSetCommand: ~A" (XGetCommand dpy win)))
+ (snd-display ";XSetCommand: ~A" (XGetCommand dpy win)))
(let ((wmp (map (lambda (w) (XGetAtomName dpy w)) (XGetWMProtocols dpy win))))
(if (not (equal? wmp (list "_MOTIF_WM_MESSAGES" "WM_DELETE_WINDOW")))
- (snd-display #__line__ ";XGetWMProtocols: ~A" wmp)))
+ (snd-display ";XGetWMProtocols: ~A" wmp)))
(if (not (equal? (XListDepths dpy 0) (list 24 1 4 8 15 16 32)))
- (snd-display #__line__ ";XListDepths: ~A" (XListDepths dpy 0)))
+ (snd-display ";XListDepths: ~A" (XListDepths dpy 0)))
(if (not (equal? (XListPixmapFormats dpy) '((1 1 32) (4 8 32) (8 8 32) (15 16 32) (16 16 32) (24 32 32) (32 32 32))))
- (snd-display #__line__ ";XListPixmapFormats: ~A" (XListPixmapFormats dpy)))
+ (snd-display ";XListPixmapFormats: ~A" (XListPixmapFormats dpy)))
(XWarpPointer dpy (list 'Window None) (list 'Window None) 0 0 10 10 100 100)
(let ((cs (XQueryBestCursor dpy win 10 10)))
- (if (not (equal? cs (list 1 10 10))) (snd-display #__line__ ";XQueryBestCursor: ~A" cs)))
+ (if (not (equal? cs (list 1 10 10))) (snd-display ";XQueryBestCursor: ~A" cs)))
(let ((pt (XQueryPointer dpy win)))
- (if (not (Window? (cadr pt))) (snd-display #__line__ ";XQueryPointer: ~A" pt)))
+ (if (not (Window? (cadr pt))) (snd-display ";XQueryPointer: ~A" pt)))
(XRaiseWindow dpy win)
(XRotateBuffers dpy 1)
(XSetWindowBorderWidth dpy win 10)
@@ -44209,32 +43386,32 @@ EDITS: 1
;(segfault) (XFree (cadr vis))
)
(let ((hints (XGetWMHints dpy win)))
- (if (or (not hints) (not (XWMHints? hints))) (snd-display #__line__ ";XGetWMHints?"))
- (if (not (= (.flags hints) 7)) (snd-display #__line__ ";flags wmhints: ~A" (.flags hints)))
- (if (not (= (.initial_state hints) 1)) (snd-display #__line__ ";initial_state wmhints: ~A" (.initial_state hints)))
- (if (not (.input hints)) (snd-display #__line__ ";input wmhints: ~A" (.input hints)))
- (if (not (Pixmap? (.icon_pixmap hints))) (snd-display #__line__ ";icon_pixmap wmhints: ~A" (.icon_pixmap hints)))
- (if (.icon_window hints) (snd-display #__line__ ";icon_window: ~A" (.icon_window hints)))
- (if (not (equal? (.icon_mask hints) (list 'Pixmap 0))) (snd-display #__line__ ";icon_mask: ~A" (.icon_mask hints)))
- (if (not (number? (.window_group hints))) (snd-display #__line__ ";window_group: ~A" (.window_group hints)))
+ (if (not (and hints (XWMHints? hints))) (snd-display ";XGetWMHints?"))
+ (if (not (= (.flags hints) 7)) (snd-display ";flags wmhints: ~A" (.flags hints)))
+ (if (not (= (.initial_state hints) 1)) (snd-display ";initial_state wmhints: ~A" (.initial_state hints)))
+ (if (not (.input hints)) (snd-display ";input wmhints: ~A" (.input hints)))
+ (if (not (Pixmap? (.icon_pixmap hints))) (snd-display ";icon_pixmap wmhints: ~A" (.icon_pixmap hints)))
+ (if (.icon_window hints) (snd-display ";icon_window: ~A" (.icon_window hints)))
+ (if (not (equal? (.icon_mask hints) (list 'Pixmap 0))) (snd-display ";icon_mask: ~A" (.icon_mask hints)))
+ (if (not (number? (.window_group hints))) (snd-display ";window_group: ~A" (.window_group hints)))
(XtFree (cadr hints))
(let ((st (XAllocWMHints)))
- (if (not (XWMHints? st)) (snd-display #__line__ ";XAllocWMHints: ~A" st))
+ (if (not (XWMHints? st)) (snd-display ";XAllocWMHints: ~A" st))
(XFree st))))
- (if (not (IsKeypadKey (list 'KeySym XK_KP_Space))) (snd-display #__line__ ";IsKeypadKey kp-space"))
- (if (IsKeypadKey (list 'KeySym XK_A)) (snd-display #__line__ ";IsKeypadKey A"))
- (if (IsPrivateKeypadKey (list 'KeySym XK_A)) (snd-display #__line__ ";IsPrivateKeypadKey A"))
- (if (not (IsCursorKey (list 'KeySym XK_Home))) (snd-display #__line__ ";IsCursorKey Home"))
- (if (IsCursorKey (list 'KeySym XK_S)) (snd-display #__line__ ";IsCursorKey S"))
- (if (not (IsPFKey (list 'KeySym XK_KP_F1))) (snd-display #__line__ ";IsPFKey F1"))
- (if (IsPFKey (list 'KeySym XK_S)) (snd-display #__line__ ";IsPFKey S"))
- (if (not (IsFunctionKey (list 'KeySym XK_F1))) (snd-display #__line__ ";IsFunctionKey F1"))
- (if (IsFunctionKey (list 'KeySym XK_S)) (snd-display #__line__ ";IsFunctionKey S"))
- (if (not (IsMiscFunctionKey (list 'KeySym XK_Select))) (snd-display #__line__ ";IsMiscFunctionKey Select"))
- (if (IsMiscFunctionKey (list 'KeySym XK_S)) (snd-display #__line__ ";IsMiscFunctionKey S"))
- (if (not (IsModifierKey (list 'KeySym XK_Shift_L))) (snd-display #__line__ ";IsModifierKey Shift"))
- (if (IsModifierKey (list 'KeySym XK_S)) (snd-display #__line__ ";IsModifierKey S"))
+ (if (not (IsKeypadKey (list 'KeySym XK_KP_Space))) (snd-display ";IsKeypadKey kp-space"))
+ (if (IsKeypadKey (list 'KeySym XK_A)) (snd-display ";IsKeypadKey A"))
+ (if (IsPrivateKeypadKey (list 'KeySym XK_A)) (snd-display ";IsPrivateKeypadKey A"))
+ (if (not (IsCursorKey (list 'KeySym XK_Home))) (snd-display ";IsCursorKey Home"))
+ (if (IsCursorKey (list 'KeySym XK_S)) (snd-display ";IsCursorKey S"))
+ (if (not (IsPFKey (list 'KeySym XK_KP_F1))) (snd-display ";IsPFKey F1"))
+ (if (IsPFKey (list 'KeySym XK_S)) (snd-display ";IsPFKey S"))
+ (if (not (IsFunctionKey (list 'KeySym XK_F1))) (snd-display ";IsFunctionKey F1"))
+ (if (IsFunctionKey (list 'KeySym XK_S)) (snd-display ";IsFunctionKey S"))
+ (if (not (IsMiscFunctionKey (list 'KeySym XK_Select))) (snd-display ";IsMiscFunctionKey Select"))
+ (if (IsMiscFunctionKey (list 'KeySym XK_S)) (snd-display ";IsMiscFunctionKey S"))
+ (if (not (IsModifierKey (list 'KeySym XK_Shift_L))) (snd-display ";IsModifierKey Shift"))
+ (if (IsModifierKey (list 'KeySym XK_S)) (snd-display ";IsModifierKey S"))
(let (;(scr (current-screen))
(dpy (XtDisplay (cadr (main-widgets))))
@@ -44242,60 +43419,60 @@ EDITS: 1
(wn (XtWindow (cadr (main-widgets)))))
(set! (.function val) GXclear)
(if (not (equal? (.function val) GXclear))
- (snd-display #__line__ ";function: ~A ~A" (.function val) GXclear))
+ (snd-display ";function: ~A ~A" (.function val) GXclear))
(set! (.line_width val) 10)
(if (not (eqv? (.line_width val) 10))
- (snd-display #__line__ ";line_width: ~A ~A" (.line_width val) 10))
+ (snd-display ";line_width: ~A ~A" (.line_width val) 10))
(set! (.line_style val) LineSolid)
(if (not (equal? (.line_style val) LineSolid))
- (snd-display #__line__ ";line_style: ~A ~A" (.line_style val) LineSolid))
+ (snd-display ";line_style: ~A ~A" (.line_style val) LineSolid))
(set! (.background val) (WhitePixelOfScreen (current-screen)))
(if (not (equal? (.background val) (WhitePixelOfScreen (current-screen))))
- (snd-display #__line__ ";background: ~A ~A" (.background val) (WhitePixelOfScreen (current-screen))))
+ (snd-display ";background: ~A ~A" (.background val) (WhitePixelOfScreen (current-screen))))
(set! (.foreground val) (BlackPixelOfScreen (current-screen)))
(if (not (equal? (.foreground val) (BlackPixelOfScreen (current-screen))))
- (snd-display #__line__ ";foreground: ~A ~A" (.foreground val) (BlackPixelOfScreen (current-screen))))
+ (snd-display ";foreground: ~A ~A" (.foreground val) (BlackPixelOfScreen (current-screen))))
;; plane_mask?
(set! (.cap_style val) CapRound)
(if (not (equal? (.cap_style val) CapRound))
- (snd-display #__line__ ";cap_style: ~A ~A" (.cap_style val) CapRound))
+ (snd-display ";cap_style: ~A ~A" (.cap_style val) CapRound))
(set! (.join_style val) JoinMiter)
(if (not (equal? (.join_style val) JoinMiter))
- (snd-display #__line__ ";join_style: ~A ~A" (.join_style val) JoinMiter))
+ (snd-display ";join_style: ~A ~A" (.join_style val) JoinMiter))
(set! (.fill_style val) FillSolid)
(if (not (equal? (.fill_style val) FillSolid))
- (snd-display #__line__ ";fill_style: ~A ~A" (.fill_style val) FillSolid))
+ (snd-display ";fill_style: ~A ~A" (.fill_style val) FillSolid))
(set! (.fill_rule val) EvenOddRule)
(if (not (equal? (.fill_rule val) EvenOddRule))
- (snd-display #__line__ ";fill_rule: ~A ~A" (.fill_rule val) EvenOddRule))
+ (snd-display ";fill_rule: ~A ~A" (.fill_rule val) EvenOddRule))
(set! (.arc_mode val) ArcChord)
(if (not (equal? (.arc_mode val) ArcChord))
- (snd-display #__line__ ";arc_mode: ~A ~A" (.arc_mode val) ArcChord))
+ (snd-display ";arc_mode: ~A ~A" (.arc_mode val) ArcChord))
;; tile stipple clip_mask are Pixmaps
(set! (.ts_x_origin val) 1)
(if (not (eqv? (.ts_x_origin val) 1))
- (snd-display #__line__ ";ts_x_origin: ~A ~A" (.ts_x_origin val) 1))
+ (snd-display ";ts_x_origin: ~A ~A" (.ts_x_origin val) 1))
(set! (.ts_y_origin val) 1)
(if (not (eqv? (.ts_y_origin val) 1))
- (snd-display #__line__ ";ts_y_origin: ~A ~A" (.ts_y_origin val) 1))
+ (snd-display ";ts_y_origin: ~A ~A" (.ts_y_origin val) 1))
;; font is Font
(set! (.subwindow_mode val) ClipByChildren)
(if (not (equal? (.subwindow_mode val) ClipByChildren))
- (snd-display #__line__ ";subwindow_mode: ~A ~A" (.subwindow_mode val) ClipByChildren))
+ (snd-display ";subwindow_mode: ~A ~A" (.subwindow_mode val) ClipByChildren))
(set! (.graphics_exposures val) #f)
(if (.graphics_exposures val)
- (snd-display #__line__ ";graphics_exposures: ~A ~A" (.graphics_exposures val) #f))
+ (snd-display ";graphics_exposures: ~A ~A" (.graphics_exposures val) #f))
(set! (.clip_x_origin val) 0)
(if (not (eqv? (.clip_x_origin val) 0))
- (snd-display #__line__ ";clip_x_origin: ~A ~A" (.clip_x_origin val) 0))
+ (snd-display ";clip_x_origin: ~A ~A" (.clip_x_origin val) 0))
(set! (.clip_y_origin val) 0)
(if (not (eqv? (.clip_y_origin val) 0))
- (snd-display #__line__ ";clip_y_origin: ~A ~A" (.clip_y_origin val) 0))
+ (snd-display ";clip_y_origin: ~A ~A" (.clip_y_origin val) 0))
(set! (.dash_offset val) 1)
(if (not (eqv? (.dash_offset val) 1))
- (snd-display #__line__ ";dash_offset: ~A ~A" (.dash_offset val) 1))
+ (snd-display ";dash_offset: ~A ~A" (.dash_offset val) 1))
(if (not (number? (XConnectionNumber dpy)))
- (snd-display #__line__ ";XConnectionNumber: ~A" (XConnectionNumber dpy)))
+ (snd-display ";XConnectionNumber: ~A" (XConnectionNumber dpy)))
(let ((sgc (XCreateGC dpy wn (+ GCFunction GCForeground GCBackground GCLineWidth GCLineStyle
GCCapStyle GCJoinStyle GCFillStyle GCFillRule GCTileStipXOrigin
@@ -44303,7 +43480,7 @@ EDITS: 1
GCClipYOrigin GCDashOffset GCArcMode)
val)))
- (if (not (GC? sgc)) (snd-display #__line__ ";XCreateGC returned ~A" sgc))
+ (if (not (GC? sgc)) (snd-display ";XCreateGC returned ~A" sgc))
(XSetArcMode dpy sgc ArcPieSlice)
(XSetFunction dpy sgc GXcopy)
(XSetLineAttributes dpy sgc 3 LineDoubleDash CapButt JoinMiter)
@@ -44317,24 +43494,24 @@ EDITS: 1
(XSetSubwindowMode dpy sgc IncludeInferiors)
(let ((owner (XGetSelectionOwner dpy XA_PRIMARY)))
(if (and owner (not (Window? owner)))
- (snd-display #__line__ ";XGetSelectionOwner: ~A" owner)))
+ (snd-display ";XGetSelectionOwner: ~A" owner)))
(let ((mods (XGetModifierMapping dpy)))
(if (not (XModifierKeymap? mods))
- (snd-display #__line__ ";XGetModifierMapping: ~A" mods)))
- (let ((vis (XGetVisualInfo dpy 0 (list 'XVisualInfo 0))))
- (if (or (not vis)
- (not (XVisualInfo? (car vis))))
- (snd-display #__line__ ";XGetVisualInfo: ~A" vis))
- (if (not (= (.depth (car vis)) 24)) (snd-display #__line__ ";depth vis: ~A" (.depth (car vis))))
- (if (not (= (.screen (car vis)) 0)) (snd-display #__line__ ";screen vis: ~A" (.screen (car vis))))
+ (snd-display ";XGetModifierMapping: ~A" mods)))
+ (let* ((vis (XGetVisualInfo dpy 0 (list 'XVisualInfo 0)))
+ (vi (car vis)))
+ (if (not (and vis (XVisualInfo? vi)))
+ (snd-display ";XGetVisualInfo: ~A" vis))
+ (if (not (= (.depth vi) 24)) (snd-display ";depth vis: ~A" (.depth vi)))
+ (if (not (= (.screen vi) 0)) (snd-display ";screen vis: ~A" (.screen vi)))
(catch #t ; in c++ no class field
(lambda ()
- (if (not (= (.class (car vis)) TrueColor)) (snd-display #__line__ ";class vis: ~A (~A)" (.class (car vis)) TrueColor)))
+ (if (not (= (.class vi) TrueColor)) (snd-display ";class vis: ~A (~A)" (.class vi) TrueColor)))
(lambda args args))
- (if (not (= (.colormap_size (car vis)) 256)) (snd-display #__line__ ";colormap_size vis: ~A" (.colormap_size (car vis))))
- (if (and (not (XVisualInfo? (XMatchVisualInfo dpy 0 24 TrueColor)))
- (not (XVisualInfo? (XMatchVisualInfo dpy 0 16 TrueColor))))
- (snd-display #__line__ ";XMatchVisualInfo: ~A" (XMatchVisualInfo dpy 0 24 TrueColor))))
+ (if (not (= (.colormap_size vi) 256)) (snd-display ";colormap_size vis: ~A" (.colormap_size vi)))
+ (if (not (or (XVisualInfo? (XMatchVisualInfo dpy 0 24 TrueColor))
+ (XVisualInfo? (XMatchVisualInfo dpy 0 16 TrueColor))))
+ (snd-display ";XMatchVisualInfo: ~A" (XMatchVisualInfo dpy 0 24 TrueColor))))
(XCheckMaskEvent dpy KeyPressMask)
(let* ((vals (XGetGCValues dpy sgc (+ GCFunction GCForeground GCBackground GCLineWidth GCLineStyle
@@ -44343,52 +43520,52 @@ EDITS: 1
GCClipYOrigin GCDashOffset GCArcMode)))
(val1 (cadr vals)))
(if (= (car vals) 0)
- (snd-display #__line__ ";XGetGCValues failed"))
+ (snd-display ";XGetGCValues failed"))
(if (not (equal? (.function val1) GXcopy))
- (snd-display #__line__ ";function: ~A ~A" (.function val1) GXcopy))
+ (snd-display ";function: ~A ~A" (.function val1) GXcopy))
(if (not (eqv? (.line_width val1) 3))
- (snd-display #__line__ ";line_width: ~A ~A" (.line_width val1) 3))
+ (snd-display ";line_width: ~A ~A" (.line_width val1) 3))
(if (not (equal? (.line_style val1) LineDoubleDash))
- (snd-display #__line__ ";line_style: ~A ~A" (.line_style val1) LineDoubleDash))
+ (snd-display ";line_style: ~A ~A" (.line_style val1) LineDoubleDash))
(if (not (equal? (.background val1) (BlackPixelOfScreen (current-screen))))
- (snd-display #__line__ ";background: ~A ~A" (.background val1) (BlackPixelOfScreen (current-screen))))
+ (snd-display ";background: ~A ~A" (.background val1) (BlackPixelOfScreen (current-screen))))
(if (not (equal? (.foreground val1) (WhitePixelOfScreen (current-screen))))
- (snd-display #__line__ ";foreground: ~A ~A" (.foreground val1) (WhitePixelOfScreen (current-screen))))
+ (snd-display ";foreground: ~A ~A" (.foreground val1) (WhitePixelOfScreen (current-screen))))
(if (not (equal? (.cap_style val1) CapButt))
- (snd-display #__line__ ";cap_style: ~A ~A" (.cap_style val1) CapButt))
+ (snd-display ";cap_style: ~A ~A" (.cap_style val1) CapButt))
(if (not (equal? (.join_style val1) JoinMiter))
- (snd-display #__line__ ";join_style: ~A ~A" (.join_style val1) JoinMiter))
+ (snd-display ";join_style: ~A ~A" (.join_style val1) JoinMiter))
(if (not (equal? (.fill_style val1) FillStippled))
- (snd-display #__line__ ";fill_style: ~A ~A" (.fill_style val1) FillStippled))
+ (snd-display ";fill_style: ~A ~A" (.fill_style val1) FillStippled))
(if (not (equal? (.fill_rule val1) WindingRule))
- (snd-display #__line__ ";fill_rule: ~A ~A" (.fill_rule val1) WindingRule))
+ (snd-display ";fill_rule: ~A ~A" (.fill_rule val1) WindingRule))
(if (not (equal? (.arc_mode val1) ArcPieSlice))
- (snd-display #__line__ ";arc_mode: ~A ~A" (.arc_mode val1) ArcPieSlice))
+ (snd-display ";arc_mode: ~A ~A" (.arc_mode val1) ArcPieSlice))
(if (not (eqv? (.ts_x_origin val1) 0))
- (snd-display #__line__ ";ts_x_origin: ~A ~A" (.ts_x_origin val1) 0))
+ (snd-display ";ts_x_origin: ~A ~A" (.ts_x_origin val1) 0))
(if (not (eqv? (.ts_y_origin val1) 0))
- (snd-display #__line__ ";ts_y_origin: ~A ~A" (.ts_y_origin val1) 0))
+ (snd-display ";ts_y_origin: ~A ~A" (.ts_y_origin val1) 0))
(if (not (equal? (.subwindow_mode val1) IncludeInferiors))
- (snd-display #__line__ ";subwindow_mode: ~A ~A" (.subwindow_mode val1) IncludeInferiors))
+ (snd-display ";subwindow_mode: ~A ~A" (.subwindow_mode val1) IncludeInferiors))
(if (not (.graphics_exposures val1))
- (snd-display #__line__ ";graphics_exposures: ~A ~A" (.graphics_exposures val1) #t))
+ (snd-display ";graphics_exposures: ~A ~A" (.graphics_exposures val1) #t))
(if (not (eqv? (.clip_x_origin val1) 1))
- (snd-display #__line__ ";clip_x_origin: ~A ~A" (.clip_x_origin val1) 1))
+ (snd-display ";clip_x_origin: ~A ~A" (.clip_x_origin val1) 1))
(if (not (eqv? (.clip_y_origin val1) 1))
- (snd-display #__line__ ";clip_y_origin: ~A ~A" (.clip_y_origin val1) 1))
+ (snd-display ";clip_y_origin: ~A ~A" (.clip_y_origin val1) 1))
(if (not (eqv? (.dash_offset val1) 1))
- (snd-display #__line__ ";dash_offset: ~A ~A" (.dash_offset val1) 1))
+ (snd-display ";dash_offset: ~A ~A" (.dash_offset val1) 1))
(set! (.plane_mask val) 0)
(if (not (eqv? (.plane_mask val) 0))
- (snd-display #__line__ ";plane_mask: ~A ~A" (.plane_mask val) 0))
+ (snd-display ";plane_mask: ~A ~A" (.plane_mask val) 0))
(set! (.tile val) (list 'Pixmap 0))
(if (not (equal? (.tile val) (list 'Pixmap 0)))
- (snd-display #__line__ ";tile: ~A" (.tile val)))
+ (snd-display ";tile: ~A" (.tile val)))
(set! (.stipple val) (list 'Pixmap 0))
(if (not (equal? (.stipple val) (list 'Pixmap 0)))
- (snd-display #__line__ ";stipple: ~A" (.stipple val)))
+ (snd-display ";stipple: ~A" (.stipple val)))
(let* ((dpy (XtDisplay (cadr (main-widgets))))
(win (XtWindow (cadr (main-widgets))))
@@ -44397,18 +43574,18 @@ EDITS: 1
CopyFromParent InputOutput (list 'Visual CopyFromParent)
(logior CWBackPixel CWBorderPixel)
attr)))
- (if (not (= (.do_not_propagate_mask attr) 0)) (snd-display #__line__ ";do_not_propagate_mask: ~A" (.do_not_propagate_mask attr)))
- (if (not (= (.event_mask attr) 0)) (snd-display #__line__ ";event_mask: ~A" (.event_mask attr)))
- (if (not (Pixel? (.backing_pixel attr))) (snd-display #__line__ ";backing_pixel: ~A" (.backing_pixel attr)))
- (if (not (Pixel? (.border_pixel attr))) (snd-display #__line__ ";border_pixel: ~A" (.border_pixel attr)))
- (if (not (= (cadr (.border_pixmap attr)) 0)) (snd-display #__line__ ";border_pixmap: ~A" (.border_pixmap attr)))
- (if (not (Pixel? (.background_pixel attr))) (snd-display #__line__ ";background_pixel: ~A" (.background_pixel attr)))
- (if (not (= (cadr (.background_pixmap attr)) 0)) (snd-display #__line__ ";background_pixmap: ~A" (.background_pixmap attr)))
- (if (not (= (.backing_planes attr) 0)) (snd-display #__line__ ";backing_planes: ~A" (.backing_planes attr)))
- (if (.save_under attr) (snd-display #__line__ ";save_under: ~A" (.save_under attr)))
- (if (not (= (cadr (.cursor attr)) 0)) (snd-display #__line__ ";cursor: ~A" (.cursor attr)))
- (if (not (Window? newwin)) (snd-display #__line__ ";XCreateWindow: ~A" newwin))
- (if (not (= (.bit_gravity attr) 0)) (snd-display #__line__ ";bit_gravity: ~A" (.bit_gravity attr)))
+ (if (not (= (.do_not_propagate_mask attr) 0)) (snd-display ";do_not_propagate_mask: ~A" (.do_not_propagate_mask attr)))
+ (if (not (= (.event_mask attr) 0)) (snd-display ";event_mask: ~A" (.event_mask attr)))
+ (if (not (Pixel? (.backing_pixel attr))) (snd-display ";backing_pixel: ~A" (.backing_pixel attr)))
+ (if (not (Pixel? (.border_pixel attr))) (snd-display ";border_pixel: ~A" (.border_pixel attr)))
+ (if (not (= (cadr (.border_pixmap attr)) 0)) (snd-display ";border_pixmap: ~A" (.border_pixmap attr)))
+ (if (not (Pixel? (.background_pixel attr))) (snd-display ";background_pixel: ~A" (.background_pixel attr)))
+ (if (not (= (cadr (.background_pixmap attr)) 0)) (snd-display ";background_pixmap: ~A" (.background_pixmap attr)))
+ (if (not (= (.backing_planes attr) 0)) (snd-display ";backing_planes: ~A" (.backing_planes attr)))
+ (if (.save_under attr) (snd-display ";save_under: ~A" (.save_under attr)))
+ (if (not (= (cadr (.cursor attr)) 0)) (snd-display ";cursor: ~A" (.cursor attr)))
+ (if (not (Window? newwin)) (snd-display ";XCreateWindow: ~A" newwin))
+ (if (not (= (.bit_gravity attr) 0)) (snd-display ";bit_gravity: ~A" (.bit_gravity attr)))
(XChangeWindowAttributes dpy newwin CWBackPixel (XSetWindowAttributes #f *basic-color*))
(XDestroyWindow dpy newwin)
(set! newwin (XCreateSimpleWindow dpy win 10 10 100 100 3 *basic-color* *highlight-color*))
@@ -44417,7 +43594,7 @@ EDITS: 1
(XSetRegion dpy sgc (XPolygonRegion (list (XPoint 0 0) (XPoint 10 0) (XPoint 10 10) (XPoint 0 10)) 4 WindingRule))
(let ((pix (make-pixmap (cadr (main-widgets)) arrow-strs)))
(if (not (Pixmap? pix))
- (snd-display #__line__ ";make-pixmap?")
+ (snd-display ";make-pixmap?")
(begin
(XSetTile dpy sgc pix)
(XSetStipple dpy sgc (XCreateBitmapFromData dpy wn right-arrow 16 12))
@@ -44427,11 +43604,11 @@ EDITS: 1
(XSetDashes dpy sgc 0 '(3 4 3 1))
(XSetClipRectangles dpy sgc 0 0 (list (XRectangle 0 0 10 10) (XRectangle 10 10 100 100)) 2 Unsorted)
(let ((err (XWriteBitmapFile dpy "testx.data" pix 16 12 -1 -1)))
- (if (not (= BitmapSuccess err)) (snd-display #__line__ ";XWriteBitmapFile: ~A" err)))
+ (if (not (= BitmapSuccess err)) (snd-display ";XWriteBitmapFile: ~A" err)))
;(let ((vals (XReadBitmapFile dpy (XtWindow (cadr (main-widgets))) "testx.data")))
- ; (if (not (= (car vals BitmapSuccess))) (snd-display #__line__ ";XReadBitmapFile: ~A" vals)))
+ ; (if (not (= (car vals BitmapSuccess))) (snd-display ";XReadBitmapFile: ~A" vals)))
;(let ((vals (XReadBitmapFileData "testx.data")))
- ; (if (not (= (car vals BitmapSuccess))) (snd-display #__line__ ";XReadBitmapFileData: ~A" vals)))
+ ; (if (not (= (car vals BitmapSuccess))) (snd-display ";XReadBitmapFileData: ~A" vals)))
(let* ((fid (XLoadFont dpy "cursor"))
(col (XColor))
@@ -44441,9 +43618,9 @@ EDITS: 1
(XAllocNamedColor dpy cmap "blue" col col)
(XAllocNamedColor dpy cmap "green" col1 col1)
(let ((vals (XCreateGlyphCursor dpy fid None XC_dot 0 col col1)))
- (if (not (Cursor? vals)) (snd-display #__line__ ";XCreateGlyphCursor: ~A" vals)))
+ (if (not (Cursor? vals)) (snd-display ";XCreateGlyphCursor: ~A" vals)))
(let ((vals (XCreatePixmapCursor dpy pix None col col1 5 5)))
- (if (not (Cursor? vals)) (snd-display #__line__ ";XCreatePixmapCursor: ~A" vals))
+ (if (not (Cursor? vals)) (snd-display ";XCreatePixmapCursor: ~A" vals))
(XRecolorCursor dpy vals col1 col))
(XAllocColorPlanes dpy cmap #f 2 1 1 1)
(XAllocColorCells dpy cmap #f 1 1))
@@ -44453,22 +43630,22 @@ EDITS: 1
(let* ((fid (XLoadFont dpy "-*-times-medium-r-*-*-14-*-*-*-*-*-*-*"))
(fnt (XLoadQueryFont dpy "-*-times-medium-r-*-*-14-*-*-*-*-*-*-*"))
(chs (XQueryTextExtents dpy fid "hiho"))
- (struct (chs 4))
- (fnt1 (XQueryFont dpy fid)))
- (if (not (Font? fid)) (snd-display #__line__ ";XLoadFont: ~A" fid))
- (if (not (XFontStruct? fnt)) (snd-display #__line__ ";XLoadQueryFont: ~A" fnt))
- (if (not (XFontStruct? fnt1)) (snd-display #__line__ ";XQueryFont: ~A" fnt1))
- (if (not (XCharStruct? struct)) (snd-display #__line__ ";XQueryTextExtents: ~A" chs))
- (if (not (= (chs 2) 12)) (snd-display #__line__ ";XQueryTextExtents max ascent: ~A" (chs 2)))
- (if (not (= (chs 3) 3)) (snd-display #__line__ ";XQueryTextExtents max descent: ~A" (chs 3)))
- (if (not (= (.lbearing struct) 0)) (snd-display #__line__ ";lbearing: ~A" (.lbearing struct)))
- (if (not (= (.rbearing struct) 23)) (snd-display #__line__ ";rbearing: ~A" (.rbearing struct)))
- (if (not (= (.width struct) 24)) (snd-display #__line__ ";width: ~A" (.width struct)))
- (if (not (= (.ascent struct) 10)) (snd-display #__line__ ";ascent: ~A" (.ascent struct)))
- (if (not (= (.descent struct) 0)) (snd-display #__line__ ";descent: ~A" (.descent struct)))
- (if (not (= (.attributes struct) 0)) (snd-display #__line__ ";attributes: ~A" (.attributes struct)))
+ (struct (chs 4)))
+ (let ((fnt1 (XQueryFont dpy fid)))
+ (if (not (Font? fid)) (snd-display ";XLoadFont: ~A" fid))
+ (if (not (XFontStruct? fnt)) (snd-display ";XLoadQueryFont: ~A" fnt))
+ (if (not (XFontStruct? fnt1)) (snd-display ";XQueryFont: ~A" fnt1)))
+ (if (not (XCharStruct? struct)) (snd-display ";XQueryTextExtents: ~A" chs))
+ (if (not (= (chs 2) 12)) (snd-display ";XQueryTextExtents max ascent: ~A" (chs 2)))
+ (if (not (= (chs 3) 3)) (snd-display ";XQueryTextExtents max descent: ~A" (chs 3)))
+ (if (not (= (.lbearing struct) 0)) (snd-display ";lbearing: ~A" (.lbearing struct)))
+ (if (not (= (.rbearing struct) 23)) (snd-display ";rbearing: ~A" (.rbearing struct)))
+ (if (not (= (.width struct) 24)) (snd-display ";width: ~A" (.width struct)))
+ (if (not (= (.ascent struct) 10)) (snd-display ";ascent: ~A" (.ascent struct)))
+ (if (not (= (.descent struct) 0)) (snd-display ";descent: ~A" (.descent struct)))
+ (if (not (= (.attributes struct) 0)) (snd-display ";attributes: ~A" (.attributes struct)))
(let ((fid (load-font "-*-helvetica-bold-r-*-*-14-*-*-*-*-*-*-*")))
- (if (not (Font? fid)) (snd-display #__line__ ";load-font -> ~A" fid)))
+ (if (not (Font? fid)) (snd-display ";load-font -> ~A" fid)))
)
(XFreeGC (XtDisplay (cadr (main-widgets))) sgc)
)))
@@ -44498,264 +43675,261 @@ EDITS: 1
(for-each
(lambda (n name)
(if (not (Atom? n))
- (snd-display #__line__ ";Atom: ~A -> ~A" name (Atom? n))))
+ (snd-display ";Atom: ~A -> ~A" name (Atom? n))))
atoms
atom-names))
(let ((r (XRectangle 10 20 100 110)))
(if (not (= (.width r) 100))
- (snd-display #__line__ ";XRectangle width: ~A" (.width r)))
+ (snd-display ";XRectangle width: ~A" (.width r)))
(if (not (= (.height r) 110))
- (snd-display #__line__ ";XRectangle height: ~A" (.height r)))
+ (snd-display ";XRectangle height: ~A" (.height r)))
(if (not (= (.x r) 10))
- (snd-display #__line__ ";XRectangle x: ~A" (.x r)))
+ (snd-display ";XRectangle x: ~A" (.x r)))
(if (not (= (.y r) 20))
- (snd-display #__line__ ";XRectangle y: ~A" (.y r)))
+ (snd-display ";XRectangle y: ~A" (.y r)))
(set! (.width r) 10)
(if (not (= (.width r) 10))
- (snd-display #__line__ ";set XRectangle width: ~A" (.width r)))
+ (snd-display ";set XRectangle width: ~A" (.width r)))
(set! (.height r) 11)
(if (not (= (.height r) 11))
- (snd-display #__line__ ";set XRectangle height: ~A" (.height r)))
+ (snd-display ";set XRectangle height: ~A" (.height r)))
(set! (.x r) 1)
(if (not (= (.x r) 1))
- (snd-display #__line__ ";set XRectangle x: ~A" (.x r)))
+ (snd-display ";set XRectangle x: ~A" (.x r)))
(set! (.y r) 2)
(if (not (= (.y r) 2))
- (snd-display #__line__ ";XRectangle y: ~A" (.y r))))
+ (snd-display ";XRectangle y: ~A" (.y r))))
(let ((r (XArc 10 20 100 110 0 235)))
(if (not (= (.width r) 100))
- (snd-display #__line__ ";XArc width: ~A" (.width r)))
+ (snd-display ";XArc width: ~A" (.width r)))
(if (not (= (.height r) 110))
- (snd-display #__line__ ";XArc height: ~A" (.height r)))
+ (snd-display ";XArc height: ~A" (.height r)))
(if (not (= (.x r) 10))
- (snd-display #__line__ ";XArc x: ~A" (.x r)))
+ (snd-display ";XArc x: ~A" (.x r)))
(if (not (= (.y r) 20))
- (snd-display #__line__ ";XArc y: ~A" (.y r)))
+ (snd-display ";XArc y: ~A" (.y r)))
(if (not (= (.angle1 r) 0))
- (snd-display #__line__ ";XArc angle1: ~A" (.angle1 r)))
+ (snd-display ";XArc angle1: ~A" (.angle1 r)))
(if (not (= (.angle2 r) 235))
- (snd-display #__line__ ";XArc angle2: ~A" (.angle2 r)))
+ (snd-display ";XArc angle2: ~A" (.angle2 r)))
(set! (.width r) 10)
(if (not (= (.width r) 10))
- (snd-display #__line__ ";set XArc width: ~A" (.width r)))
+ (snd-display ";set XArc width: ~A" (.width r)))
(set! (.height r) 11)
(if (not (= (.height r) 11))
- (snd-display #__line__ ";set XArc height: ~A" (.height r)))
+ (snd-display ";set XArc height: ~A" (.height r)))
(set! (.x r) 1)
(if (not (= (.x r) 1))
- (snd-display #__line__ ";set XArc x: ~A" (.x r)))
+ (snd-display ";set XArc x: ~A" (.x r)))
(set! (.y r) 2)
(if (not (= (.y r) 2))
- (snd-display #__line__ ";set XArc y: ~A" (.y r)))
+ (snd-display ";set XArc y: ~A" (.y r)))
(set! (.angle1 r) 123)
(if (not (= (.angle1 r) 123))
- (snd-display #__line__ ";set XArc angle1: ~A" (.angle1 r)))
+ (snd-display ";set XArc angle1: ~A" (.angle1 r)))
(set! (.angle2 r) 321)
(if (not (= (.angle2 r) 321))
- (snd-display #__line__ ";set XArc angle2: ~A" (.angle2 r))))
+ (snd-display ";set XArc angle2: ~A" (.angle2 r))))
(let ((r (XPoint 10 20)))
(if (not (= (.x r) 10))
- (snd-display #__line__ ";XPoint x: ~A" (.x r)))
+ (snd-display ";XPoint x: ~A" (.x r)))
(if (not (= (.y r) 20))
- (snd-display #__line__ ";XPoint y: ~A" (.y r)))
+ (snd-display ";XPoint y: ~A" (.y r)))
(set! (.x r) 1)
(if (not (= (.x r) 1))
- (snd-display #__line__ ";set XPoint x: ~A" (.x r)))
+ (snd-display ";set XPoint x: ~A" (.x r)))
(set! (.y r) 2)
(if (not (= (.y r) 2))
- (snd-display #__line__ ";set XPoint y: ~A" (.y r))))
+ (snd-display ";set XPoint y: ~A" (.y r))))
(let ((r (XSegment 10 20 100 110)))
(if (not (= (.x1 r) 10))
- (snd-display #__line__ ";XSegment x1: ~A" (.x1 r)))
+ (snd-display ";XSegment x1: ~A" (.x1 r)))
(if (not (= (.y1 r) 20))
- (snd-display #__line__ ";XSegment y1: ~A" (.y1 r)))
+ (snd-display ";XSegment y1: ~A" (.y1 r)))
(if (not (= (.x2 r) 100))
- (snd-display #__line__ ";XSegment x2: ~A" (.x2 r)))
+ (snd-display ";XSegment x2: ~A" (.x2 r)))
(if (not (= (.y2 r) 110))
- (snd-display #__line__ ";XSegment y2: ~A" (.y2 r)))
+ (snd-display ";XSegment y2: ~A" (.y2 r)))
(set! (.x1 r) 1)
(if (not (= (.x1 r) 1))
- (snd-display #__line__ ";set XSegment x1: ~A" (.x1 r)))
+ (snd-display ";set XSegment x1: ~A" (.x1 r)))
(set! (.y1 r) 2)
(if (not (= (.y1 r) 2))
- (snd-display #__line__ ";set XSegment y1: ~A" (.y1 r)))
+ (snd-display ";set XSegment y1: ~A" (.y1 r)))
(set! (.x2 r) 10)
(if (not (= (.x2 r) 10))
- (snd-display #__line__ ";set XSegment x2: ~A" (.x2 r)))
+ (snd-display ";set XSegment x2: ~A" (.x2 r)))
(set! (.y2 r) 11)
(if (not (= (.y2 r) 11))
- (snd-display #__line__ ";set XSegment y2: ~A" (.y2 r))))
+ (snd-display ";set XSegment y2: ~A" (.y2 r))))
(let ((c (XColor)))
(set! (.red c) 1)
- (if (not (= (.red c) 1)) (snd-display #__line__ ";Xcolor red: ~A" (.red c)))
+ (if (not (= (.red c) 1)) (snd-display ";Xcolor red: ~A" (.red c)))
(set! (.green c) 1)
- (if (not (= (.green c) 1)) (snd-display #__line__ ";Xcolor green: ~A" (.green c)))
+ (if (not (= (.green c) 1)) (snd-display ";Xcolor green: ~A" (.green c)))
(set! (.blue c) 1)
- (if (not (= (.blue c) 1)) (snd-display #__line__ ";Xcolor blue: ~A" (.blue c)))
+ (if (not (= (.blue c) 1)) (snd-display ";Xcolor blue: ~A" (.blue c)))
(set! (.flags c) DoRed)
- (if (not (= (.flags c) DoRed)) (snd-display #__line__ ";Xcolor flags: ~A" (.flags c)))
- (if (not (= (.pad c) 0)) (snd-display #__line__ ";pad: ~A" (.pad c)))
+ (if (not (= (.flags c) DoRed)) (snd-display ";Xcolor flags: ~A" (.flags c)))
+ (if (not (= (.pad c) 0)) (snd-display ";pad: ~A" (.pad c)))
(set! (.pixel c) *basic-color*)
- (if (not (equal? (.pixel c) *basic-color*)) (snd-display #__line__ ";Xcolor pixel: ~A" (.pixel c))))
+ (if (not (equal? (.pixel c) *basic-color*)) (snd-display ";Xcolor pixel: ~A" (.pixel c))))
(let ((obj (XTextItem "hiho" 4 3 (list 'Font 1))))
- (if (not (XTextItem? obj)) (snd-display #__line__ ";XTextItem -> ~A" obj))
- (if (not (equal? (.font obj) (list 'Font 1))) (snd-display #__line__ ";font ~A" (.font obj)))
+ (if (not (XTextItem? obj)) (snd-display ";XTextItem -> ~A" obj))
+ (if (not (equal? (.font obj) (list 'Font 1))) (snd-display ";font ~A" (.font obj)))
(set! (.font obj) (list 'Font 2))
- (if (not (equal? (.font obj) (list 'Font 2))) (snd-display #__line__ ";set font ~A" (.font obj)))
- (if (not (string=? (.chars obj) "hiho")) (snd-display #__line__ ";chars: ~A" (.chars obj)))
- (if (not (= (.nchars obj) 4)) (snd-display #__line__ ";chars: ~A" (.nchars obj)))
+ (if (not (equal? (.font obj) (list 'Font 2))) (snd-display ";set font ~A" (.font obj)))
+ (if (not (string=? (.chars obj) "hiho")) (snd-display ";chars: ~A" (.chars obj)))
+ (if (not (= (.nchars obj) 4)) (snd-display ";chars: ~A" (.nchars obj)))
(set! (.chars obj) "away!")
(set! (.nchars obj) 5)
- (if (not (string=? (.chars obj) "away!")) (snd-display #__line__ ";set chars: ~A" (.chars obj)))
- (if (not (= (.nchars obj) 5)) (snd-display #__line__ ";set chars: ~A" (.nchars obj)))
- (if (not (= (.delta obj) 3)) (snd-display #__line__ ";delta ~A" (.delta obj)))
+ (if (not (string=? (.chars obj) "away!")) (snd-display ";set chars: ~A" (.chars obj)))
+ (if (not (= (.nchars obj) 5)) (snd-display ";set chars: ~A" (.nchars obj)))
+ (if (not (= (.delta obj) 3)) (snd-display ";delta ~A" (.delta obj)))
(set! (.delta obj) 4)
- (if (not (= (.delta obj) 4)) (snd-display #__line__ ";set delta ~A" (.delta obj)))
+ (if (not (= (.delta obj) 4)) (snd-display ";set delta ~A" (.delta obj)))
)
(let ((reg (XPolygonRegion (list (XPoint 0 0) (XPoint 10 0) (XPoint 10 10) (XPoint 0 10)) 4 WindingRule)))
- (if (not (XPointInRegion reg 4 4)) (snd-display #__line__ ";XPointInRegion"))
+ (if (not (XPointInRegion reg 4 4)) (snd-display ";XPointInRegion"))
(XShrinkRegion reg 1 2)
- (if (not (XPointInRegion reg 4 7)) (snd-display #__line__ ";t XShrinkRegion"))
- (if (XPointInRegion reg 4 9) (snd-display #__line__ ";f XShrinkRegion"))
+ (if (not (XPointInRegion reg 4 7)) (snd-display ";t XShrinkRegion"))
+ (if (XPointInRegion reg 4 9) (snd-display ";f XShrinkRegion"))
(XOffsetRegion reg 1 2)
- (if (not (XPointInRegion reg 4 9)) (snd-display #__line__ ";t XOffsetRegion"))
- (if (XPointInRegion reg 1 9) (snd-display #__line__ ";f XOffsetRegion"))
+ (if (not (XPointInRegion reg 4 9)) (snd-display ";t XOffsetRegion"))
+ (if (XPointInRegion reg 1 9) (snd-display ";f XOffsetRegion"))
(let ((reg2 (XCreateRegion))
(reg1 (XPolygonRegion (list (XPoint 2 2) (XPoint 10 2) (XPoint 10 10) (XPoint 2 10)) 4 WindingRule)))
- (if (XEqualRegion reg reg1) (snd-display #__line__ ";f XEqualRegion"))
- (if (XEmptyRegion reg) (snd-display #__line__ ";f XEmptyRegion"))
+ (if (XEqualRegion reg reg1) (snd-display ";f XEqualRegion"))
+ (if (XEmptyRegion reg) (snd-display ";f XEmptyRegion"))
(XXorRegion reg reg1 reg2)
(let ((box (XClipBox reg2)))
- (if (or (not (= (.x (cadr box)) 2))
- (not (= (.y (cadr box)) 2))
- (not (= (.width (cadr box)) 8))
- (not (= (.height (cadr box)) 2)))
- (snd-display #__line__ ";XXorRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 2)
+ (= (.y (cadr box)) 2)
+ (= (.width (cadr box)) 8)
+ (= (.height (cadr box)) 2)))
+ (snd-display ";XXorRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XUnionRegion reg reg1 reg2)
(let ((box (XClipBox reg2)))
- (if (or (not (= (.x (cadr box)) 2))
- (not (= (.y (cadr box)) 2))
- (not (= (.width (cadr box)) 8))
- (not (= (.height (cadr box)) 8)))
- (snd-display #__line__ ";XUnionRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 2)
+ (= (.y (cadr box)) 2)
+ (= (.width (cadr box)) 8)
+ (= (.height (cadr box)) 8)))
+ (snd-display ";XUnionRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XSubtractRegion reg reg1 reg2)
(let ((box (XClipBox reg2)))
- (if (or (not (= (.x (cadr box)) 0))
- (not (= (.y (cadr box)) 0))
- (not (= (.width (cadr box)) 0))
- (not (= (.height (cadr box)) 0)))
- (snd-display #__line__ ";XSubtractRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 0)
+ (= (.y (cadr box)) 0)
+ (= (.width (cadr box)) 0)
+ (= (.height (cadr box)) 0)))
+ (snd-display ";XSubtractRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XIntersectRegion reg reg1 reg2)
(let ((box (XClipBox reg2)))
- (if (or (not (= (.x (cadr box)) 2))
- (not (= (.y (cadr box)) 4))
- (not (= (.width (cadr box)) 8))
- (not (= (.height (cadr box)) 6)))
- (snd-display #__line__ ";XIntersectRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 2)
+ (= (.y (cadr box)) 4)
+ (= (.width (cadr box)) 8)
+ (= (.height (cadr box)) 6)))
+ (snd-display ";XIntersectRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XUnionRectWithRegion (XRectangle 1 3 100 100) reg1 reg2)
(let ((box (XClipBox reg2)))
- (if (or (not (= (.x (cadr box)) 1))
- (not (= (.y (cadr box)) 2))
- (not (= (.width (cadr box)) 100))
- (not (= (.height (cadr box)) 101)))
- (snd-display #__line__ ";XUnionRectWithRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 1)
+ (= (.y (cadr box)) 2)
+ (= (.width (cadr box)) 100)
+ (= (.height (cadr box)) 101)))
+ (snd-display ";XUnionRectWithRegion: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XRectInRegion reg 0 0 100 100)
(let ((box (XClipBox reg1)))
- (if (or (not (= (.x (cadr box)) 2))
- (not (= (.y (cadr box)) 2))
- (not (= (.width (cadr box)) 8))
- (not (= (.height (cadr box)) 8)))
- (snd-display #__line__ ";XClipBox: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
+ (if (not (and (= (.x (cadr box)) 2)
+ (= (.y (cadr box)) 2)
+ (= (.width (cadr box)) 8)
+ (= (.height (cadr box)) 8)))
+ (snd-display ";XClipBox: ~A ~A ~A ~A" (.x (cadr box)) (.y (cadr box)) (.width (cadr box)) (.height (cadr box)))))
(XDestroyRegion reg1)
))
(let ((xid (XUniqueContext))
(dpy (XtDisplay (cadr (main-widgets)))))
(if (not (eq? (car xid) 'XContext))
- (snd-display #__line__ ";XUniqueContext: ~A" xid))
+ (snd-display ";XUniqueContext: ~A" xid))
(XSaveContext dpy 123 xid "hiho")
(let ((val (XFindContext dpy 123 xid)))
- (if (or (not (= 0 (car val)))
- (not (string=? (cadr val) "hiho")))
- (snd-display #__line__ ";XFindContext: ~A" val)))
+ (if (not (and (= 0 (car val))
+ (string=? (cadr val) "hiho")))
+ (snd-display ";XFindContext: ~A" val)))
(XDeleteContext dpy 123 xid)
(XStoreBytes dpy "hiho" 4)
- (if (not (string=? (XFetchBytes dpy) "hiho")) (snd-display #__line__ ";XStoreBytes: ~A" (XFetchBytes dpy)))
+ (if (not (string=? (XFetchBytes dpy) "hiho")) (snd-display ";XStoreBytes: ~A" (XFetchBytes dpy)))
(XStoreBuffer dpy "hiho" 4 1)
- (if (not (string=? (XFetchBuffer dpy 1) "hiho")) (snd-display #__line__ ";XStoreBuffer: ~A" (XFetchBuffer dpy 1)))
+ (if (not (string=? (XFetchBuffer dpy 1) "hiho")) (snd-display ";XStoreBuffer: ~A" (XFetchBuffer dpy 1)))
)
;; ---------------- Xt tests ----------------
(let ((name (XtGetApplicationNameAndClass (XtDisplay (cadr (main-widgets))))))
(if (not (equal? name (list "snd" "Snd")))
- (snd-display #__line__ ";XtGetApplicationNameAndClass: ~A?" name)))
+ (snd-display ";XtGetApplicationNameAndClass: ~A?" name)))
(let ((dpys (XtGetDisplays (car (main-widgets)))))
(if (not (Display? (car dpys)))
- (snd-display #__line__ ";XtGetDisplays: ~A?" dpys)))
+ (snd-display ";XtGetDisplays: ~A?" dpys)))
(let ((app (XtDisplayToApplicationContext (XtDisplay (cadr (main-widgets)))))
(orig (car (main-widgets)))
(wid (XtWidgetToApplicationContext (cadr (main-widgets)))))
(if (not (equal? app orig))
- (snd-display #__line__ ";XtDisplayToApplicationContext: ~A ~A?" app orig))
+ (snd-display ";XtDisplayToApplicationContext: ~A ~A?" app orig))
(if (not (equal? app wid))
- (snd-display #__line__ ";XtWidgetToApplicationContext: ~A ~A?" app wid)))
+ (snd-display ";XtWidgetToApplicationContext: ~A ~A?" app wid)))
(if (not (string=? (XtName (caddr (main-widgets))) "mainpane"))
- (snd-display #__line__ ";XtName main pane: ~A" (XtName (caddr (main-widgets)))))
+ (snd-display ";XtName main pane: ~A" (XtName (caddr (main-widgets)))))
(if (not (= (XtGetMultiClickTime (XtDisplay (cadr (main-widgets)))) 200))
- (snd-display #__line__ ";XtGetMultiClickTime: ~A" (XtGetMultiClickTime (XtDisplay (cadr (main-widgets))))))
+ (snd-display ";XtGetMultiClickTime: ~A" (XtGetMultiClickTime (XtDisplay (cadr (main-widgets))))))
(XtSetMultiClickTime (XtDisplay (cadr (main-widgets))) 250)
(if (not (= (XtGetMultiClickTime (XtDisplay (cadr (main-widgets)))) 250))
- (snd-display #__line__ ";XtSetMultiClickTime: ~A" (XtGetMultiClickTime (XtDisplay (cadr (main-widgets))))))
- (XtGetResourceList xmListWidgetClass)
- (let ((wid1 (XtCreateWidget "wid1" xmPushButtonWidgetClass (cadr (main-widgets)) ())))
- (XtDestroyWidget wid1))
-
- (let ((hook-id (XtAppAddActionHook
- (car (main-widgets))
- (lambda (w data name e p)
- (format #t "~A ~A ~A ~A ~A~%" w data name e p))
- #f)))
- (XtRemoveActionHook hook-id))
+ (snd-display ";XtSetMultiClickTime: ~A" (XtGetMultiClickTime (XtDisplay (cadr (main-widgets))))))
+ (XtGetResourceList xmListWidgetClass)
+ (XtDestroyWidget (XtCreateWidget "wid1" xmPushButtonWidgetClass (cadr (main-widgets)) ()))
+ (XtRemoveActionHook (XtAppAddActionHook
+ (car (main-widgets))
+ (lambda (w data name e p)
+ (format () "~A ~A ~A ~A ~A~%" w data name e p))
+ #f))
(let* ((shell (cadr (main-widgets)))
(wid (XtCreateWidget "wid" xmFormWidgetClass shell ()))
(wid1 (XtCreateWidget "wid1" xmPushButtonWidgetClass wid ()))
(wid2 (XtVaCreateWidget "wid" xmFormWidgetClass shell ())))
- (if (XtIsApplicationShell wid) (snd-display #__line__ ";XtIsApplicationShell"))
- (if (not (XtIsApplicationShell shell)) (snd-display #__line__ ";XtIsApplicationShell of appshell"))
- (if (not (XtIsComposite wid)) (snd-display #__line__ ";XtIsComposite"))
- (if (not (XtIsConstraint wid)) (snd-display #__line__ ";XtIsConstraint"))
- (if (XtIsManaged wid) (snd-display #__line__ ";XtIsManaged"))
- (if (not (XtIsObject wid)) (snd-display #__line__ ";XtIsObject"))
- (if (XtIsOverrideShell wid) (snd-display #__line__ ";XtIsOverrideShell"))
- (if (XtIsRealized wid) (snd-display #__line__ ";XtIsRealized"))
- (if (not (XtIsRealized shell)) (snd-display #__line__ ";XtIsRealized main shell"))
- (if (not (XtIsRectObj wid)) (snd-display #__line__ ";XtIsRectObj"))
- (if (not (XtIsSensitive wid)) (snd-display #__line__ ";XtIsSensitive"))
- (if (not (XtIsSensitive shell)) (snd-display #__line__ ";XtIsSensitive of main shell"))
+ (if (XtIsApplicationShell wid) (snd-display ";XtIsApplicationShell"))
+ (if (not (XtIsApplicationShell shell)) (snd-display ";XtIsApplicationShell of appshell"))
+ (if (not (XtIsComposite wid)) (snd-display ";XtIsComposite"))
+ (if (not (XtIsConstraint wid)) (snd-display ";XtIsConstraint"))
+ (if (XtIsManaged wid) (snd-display ";XtIsManaged"))
+ (if (not (XtIsObject wid)) (snd-display ";XtIsObject"))
+ (if (XtIsOverrideShell wid) (snd-display ";XtIsOverrideShell"))
+ (if (XtIsRealized wid) (snd-display ";XtIsRealized"))
+ (if (not (XtIsRealized shell)) (snd-display ";XtIsRealized main shell"))
+ (if (not (XtIsRectObj wid)) (snd-display ";XtIsRectObj"))
+ (if (not (XtIsSensitive wid)) (snd-display ";XtIsSensitive"))
+ (if (not (XtIsSensitive shell)) (snd-display ";XtIsSensitive of main shell"))
(XtSetSensitive wid1 #t)
- (if (not (XtIsSensitive wid1)) (snd-display #__line__ ";XtIsSensitive of button"))
- (if (XtIsSessionShell wid) (snd-display #__line__ ";XtIsSessionShell"))
- (if (XtIsShell wid) (snd-display #__line__ ";XtIsShell"))
- (if (not (XtIsShell shell)) (snd-display #__line__ ";XtIsShell of main shell"))
- (if (XtIsTopLevelShell wid) (snd-display #__line__ ";XtIsTopLevelShell"))
- (if (not (XtIsTopLevelShell shell)) (snd-display #__line__ ";XtIsTopLevelShell of main shell"))
- (if (XtIsTransientShell wid) (snd-display #__line__ ";XtIsTransientShell"))
- (if (XtIsVendorShell wid) (snd-display #__line__ ";XtIsVendorShell"))
- (if (not (XtIsVendorShell shell)) (snd-display #__line__ ";XtIsVendorShell of main shell"))
- (if (XtIsWMShell wid) (snd-display #__line__ ";XtIsWMShell"))
- (if (not (XtIsWidget wid)) (snd-display #__line__ ";XtIsWidget"))
- (if (not (XtIsWidget wid2)) (snd-display #__line__ ";XtIsWidget 2"))
+ (if (not (XtIsSensitive wid1)) (snd-display ";XtIsSensitive of button"))
+ (if (XtIsSessionShell wid) (snd-display ";XtIsSessionShell"))
+ (if (XtIsShell wid) (snd-display ";XtIsShell"))
+ (if (not (XtIsShell shell)) (snd-display ";XtIsShell of main shell"))
+ (if (XtIsTopLevelShell wid) (snd-display ";XtIsTopLevelShell"))
+ (if (not (XtIsTopLevelShell shell)) (snd-display ";XtIsTopLevelShell of main shell"))
+ (if (XtIsTransientShell wid) (snd-display ";XtIsTransientShell"))
+ (if (XtIsVendorShell wid) (snd-display ";XtIsVendorShell"))
+ (if (not (XtIsVendorShell shell)) (snd-display ";XtIsVendorShell of main shell"))
+ (if (XtIsWMShell wid) (snd-display ";XtIsWMShell"))
+ (if (not (XtIsWidget wid)) (snd-display ";XtIsWidget"))
+ (if (not (XtIsWidget wid2)) (snd-display ";XtIsWidget 2"))
(XtRealizeWidget wid)
- (if (not (XtIsRealized wid)) (snd-display #__line__ ";XtRealizeWidget?"))
+ (if (not (XtIsRealized wid)) (snd-display ";XtRealizeWidget?"))
(XtAddGrab shell #f #f)
(XtRemoveGrab shell)
(XtMakeResizeRequest wid 200 200)
@@ -44768,7 +43942,7 @@ EDITS: 1
(XtSetLanguageProc
(car (main-widgets))
(lambda (dpy str data)
- (snd-display #__line__ ";YOW: language proc: got ~A ~A" str data))
+ (snd-display ";YOW: language proc: got ~A ~A" str data))
"who called us?")
(XtSetLanguageProc (car (main-widgets)) #f "oops")
(XtSetLanguageProc #f #f "oops")
@@ -44777,21 +43951,21 @@ EDITS: 1
(let* ((shell (cadr (main-widgets)))
(dpy (XtDisplay shell)))
(if (not (equal? (XtClass shell) applicationShellWidgetClass))
- (snd-display #__line__ ";XtClass shell: ~A" (XtClass shell)))
+ (snd-display ";XtClass shell: ~A" (XtClass shell)))
(if (not (equal? (XtSuperclass shell) topLevelShellWidgetClass))
- (snd-display #__line__ ";XtSuperclass shell: ~A" (XtClass shell)))
+ (snd-display ";XtSuperclass shell: ~A" (XtClass shell)))
(if (not (string=? (XtName shell) "snd"))
- (snd-display #__line__ ";XtName: ~A" (XtName shell)))
+ (snd-display ";XtName: ~A" (XtName shell)))
(if (not (equal? (XtWindow shell) (XtWindowOfObject shell)))
- (snd-display #__line__ ";XtWindow: ~A ~A" (XtWindow shell) (XtWindowOfObject shell)))
+ (snd-display ";XtWindow: ~A ~A" (XtWindow shell) (XtWindowOfObject shell)))
(if (not (equal? (XtScreen shell) (XtScreenOfObject shell)))
- (snd-display #__line__ ";XtScreen: ~A ~A" (XtScreen shell) (XtScreenOfObject shell)))
+ (snd-display ";XtScreen: ~A ~A" (XtScreen shell) (XtScreenOfObject shell)))
(if (not (equal? (XtDisplay shell) (XtDisplayOfObject shell)))
- (snd-display #__line__ ";XtDisplay: ~A ~A" (XtDisplay shell) (XtDisplayOfObject shell)))
+ (snd-display ";XtDisplay: ~A ~A" (XtDisplay shell) (XtDisplayOfObject shell)))
(if (not (Time? (XtLastTimestampProcessed dpy)))
- (snd-display #__line__ ";XtLastTimestampProcessed: ~A" (XtLastTimestampProcessed dpy)))
+ (snd-display ";XtLastTimestampProcessed: ~A" (XtLastTimestampProcessed dpy)))
(if (not (XEvent? (XtLastEventProcessed dpy)))
- (snd-display #__line__ ";XtLastEventProcessed: ~A" (XtLastEventProcessed dpy)))
+ (snd-display ";XtLastEventProcessed: ~A" (XtLastEventProcessed dpy)))
(XtBuildEventMask shell)
(let ((val 0))
(XtRegisterCaseConverter
@@ -44803,40 +43977,38 @@ EDITS: 1
(list 'KeySym 65)
(list 'KeySym 65))
(XtConvertCase dpy (list 'KeySym 65))
- (if (not (= val 123)) (snd-display #__line__ ";XtRegisterCaseConverter: ~A" val)))
+ (if (not (= val 123)) (snd-display ";XtRegisterCaseConverter: ~A" val)))
(XtRegisterGrabAction (lambda (a b c) #f) #f ColormapChangeMask GrabModeSync GrabModeAsync)
(let ((vals (XtTranslateKeycode dpy (list 'KeyCode XK_B) 0)))
- (if (or (not (= (car vals) 0))
- (not (KeySym? (cadr vals))))
- (snd-display #__line__ ";XtTranslateKeycode: ~A" vals))
+ (if (not (and (= (car vals) 0)
+ (KeySym? (cadr vals))))
+ (snd-display ";XtTranslateKeycode: ~A" vals))
(if (not (equal? vals (XtTranslateKey dpy (list 'KeyCode XK_B) 0)))
- (snd-display #__line__ ";XtTranslateKey: ~A ~A" vals (XtTranslateKey dpy (list 'KeyCode XK_B) 0)))
+ (snd-display ";XtTranslateKey: ~A ~A" vals (XtTranslateKey dpy (list 'KeyCode XK_B) 0)))
(XtSetKeyTranslator dpy #f)
(if (not (equal? vals (XtTranslateKeycode dpy (list 'KeyCode XK_B) 0)))
- (snd-display #__line__ ";XtSetKeyTranslator #f: ~A ~A" vals (XtTranslateKeycode dpy (list 'KeyCode XK_B) 0)))
+ (snd-display ";XtSetKeyTranslator #f: ~A ~A" vals (XtTranslateKeycode dpy (list 'KeyCode XK_B) 0)))
(XtSetKeyTranslator dpy (lambda (d k m)
- (if (not (equal? d dpy)) (snd-display #__line__ ";d in keyproc: ~A ~A" d dpy))
+ (if (not (equal? d dpy)) (snd-display ";d in keyproc: ~A ~A" d dpy))
(XtTranslateKey d k m)))
(let ((newvals (XtTranslateKeycode dpy (list 'KeyCode XK_B) 0)))
- (if (not (equal? vals newvals)) (snd-display #__line__ ";XtSetKeyTranslator: ~A ~A" vals newvals)))
+ (if (not (equal? vals newvals)) (snd-display ";XtSetKeyTranslator: ~A ~A" vals newvals)))
(XtSetKeyTranslator dpy #f))
(if (not (KeySym? (cadr (XmTranslateKey dpy (list 'KeyCode XK_B) 0))))
- (snd-display #__line__ ";XmTranslateKey: ~A" (XmTranslateKey dpy XK_B 0)))
+ (snd-display ";XmTranslateKey: ~A" (XmTranslateKey dpy XK_B 0)))
(let ((kv (XtKeysymToKeycodeList dpy (list 'KeySym 65509))))
(if (not (equal? (car kv) (list 'KeyCode 66)))
- (snd-display #__line__ ";XtKeysymToKeycodeList: ~A ~A" kv (XtKeysymToKeycodeList dpy (list 'KeySym 65509)))))
+ (snd-display ";XtKeysymToKeycodeList: ~A ~A" kv (XtKeysymToKeycodeList dpy (list 'KeySym 65509)))))
(XtInstallAllAccelerators (cadr (main-widgets)) (caddr (main-widgets)))
(XtInstallAccelerators (cadr (main-widgets)) (caddr (main-widgets)))
- (if (not (equal? (list 0 1 2) (XtSetArg 0 1 2))) (snd-display #__line__ ";XtSetArg: ~A" (XtSetArg 0 1 2)))
+ (if (not (equal? (list 0 1 2) (XtSetArg 0 1 2))) (snd-display ";XtSetArg: ~A" (XtSetArg 0 1 2)))
(if (not (Widget? (XtGetKeyboardFocusWidget (cadr (main-widgets)))))
- (snd-display #__line__ ";XtGetKeyboardFocusWidget: ~A" (XtGetKeyboardFocusWidget (cadr (main-widgets)))))
- (let ((id (XtAppAddInput (car (main-widgets)) 1 XtInputReadMask (lambda (a b c) #f) #f)))
- (XtRemoveInput id))
+ (snd-display ";XtGetKeyboardFocusWidget: ~A" (XtGetKeyboardFocusWidget (cadr (main-widgets)))))
+ (XtRemoveInput (XtAppAddInput (car (main-widgets)) 1 XtInputReadMask (lambda (a b c) #f) #f))
- (let ((id (XtAppAddWorkProc (car (main-widgets)) (lambda (me) #f) #f)))
- (XtRemoveWorkProc id))
+ (XtRemoveWorkProc (XtAppAddWorkProc (car (main-widgets)) (lambda (me) #f) #f))
(if (not (equal? (caddr (main-widgets)) (XtNameToWidget (cadr (main-widgets)) "mainpane")))
- (snd-display #__line__ ";XtNameToWidget: ~A ~A" (caddr (main-widgets)) (XtNameToWidget (cadr (main-widgets)) "mainpane")))
+ (snd-display ";XtNameToWidget: ~A ~A" (caddr (main-widgets)) (XtNameToWidget (cadr (main-widgets)) "mainpane")))
(XtVaCreatePopupShell "hiho" vendorShellWidgetClass (cadr (main-widgets)) ())
(XtResolvePathname (XtDisplay (cadr (main-widgets))) "app-defaults" #f #f #f #f 0 #f)
(XtFindFile ".snd" #f 0 #f)
@@ -44844,9 +44016,9 @@ EDITS: 1
(XtAppLock (car (main-widgets)))
(XtAppUnlock (car (main-widgets)))
(let ((acts (XtGetActionList xmLabelWidgetClass)))
- (if (or (not (= (length acts) 4))
- (not (string=? (caar acts) "Enter")))
- (snd-display #__line__ ";XtGetActionList: ~A" acts)))
+ (if (not (and (= (length acts) 4)
+ (string=? (caar acts) "Enter")))
+ (snd-display ";XtGetActionList: ~A" acts)))
)
(let ((pop (XtCreatePopupShell "hiho" xmGrabShellWidgetClass (cadr (main-widgets))
@@ -44856,24 +44028,16 @@ EDITS: 1
(XtAppSetWarningHandler (car (main-widgets))
(lambda (n)
(if (not (string=? n "hiho"))
- (snd-display #__line__ ";XtWarning: ~A" n))))
+ (snd-display ";XtWarning: ~A" n))))
(XtAppSetWarningMsgHandler (car (main-widgets))
(lambda (name type klass def pars num)
- (snd-display #__line__ ";ignore: ~A ~A ~A~%" name def pars)))
+ (snd-display ";ignore: ~A ~A ~A~%" name def pars)))
(let ((listener ((main-widgets) 4)))
- (XtCallActionProc listener "text-transpose" (XEvent) #f 0)
- (XtCallActionProc listener "begin-of-line" (XEvent) #f 0)
- (XtCallActionProc listener "kill-line" (XEvent) #f 0)
- (XtCallActionProc listener "yank" (XEvent) #f 0)
- (XtCallActionProc listener "name-completion" (XEvent) #f 0)
- (XtCallActionProc listener "listener-completion" (XEvent) #f 0)
- (XtCallActionProc listener "no-op" (XEvent) #f 0)
- (XtCallActionProc listener "delete-region" (XEvent) #f 0)
- (XtCallActionProc listener "listener-g" (XEvent) #f 0)
- (XtCallActionProc listener "listener-clear" (XEvent) #f 0)
- (XtCallActionProc listener "b1-press" (XEvent) #f 0)
- (XtCallActionProc listener "delete-to-previous-command" (XEvent) #f 0)
+ (for-each (lambda (arg)
+ (XtCallActionProc listener arg (XEvent) #f 0))
+ '("text-transpose" "begin-of-line" "kill-line" "yank" "listener-completion"
+ "no-op" "delete-region" "listener-g" "listener-clear" "b1-press" "delete-to-previous-command"))
(let ((BEvent (XEvent ButtonPress)))
(set! (.x BEvent) 10)
(set! (.y BEvent) 10)
@@ -44893,7 +44057,7 @@ EDITS: 1
(let ((tag (catch #t (lambda () (XtVaGetValues (car (sound-widgets)) (list "XmNpaneMaximum" 0)))
(lambda args (car args)))))
(if (not (eq? tag 'no-such-resource))
- (snd-display #__line__ ";XtVaGetValues of incorrectly quoted resource name: ~A" tag)))
+ (snd-display ";XtVaGetValues of incorrectly quoted resource name: ~A" tag)))
)
(close-sound ind))
@@ -44907,9 +44071,9 @@ EDITS: 1
(cadr (XmRenditionRetrieve (car renditions) (list XmNfontName 0)))))
(default-font-info (and renditions
(XmRenditionRetrieve (car renditions) (list XmNfont 0 XmNfontType 0)))))
- (if (not (string=? default-font-name "fixed")) (snd-display #__line__ ";XmRenderTableGetRenditions name: ~A" default-font-name))
- (if (not (XFontStruct? (default-font-info 1))) (snd-display #__line__ ";XmRenderTableGetRenditions font struct: ~A" default-font-info))
- (if (not (= (default-font-info 3) XmFONT_IS_FONT)) (snd-display #__line__ ";XmRenderTableGetRenditions font type: ~A" default-font-info)))
+ (if (not (string=? default-font-name "fixed")) (snd-display ";XmRenderTableGetRenditions name: ~A" default-font-name))
+ (if (not (XFontStruct? (default-font-info 1))) (snd-display ";XmRenderTableGetRenditions font struct: ~A" default-font-info))
+ (if (not (= (default-font-info 3) XmFONT_IS_FONT)) (snd-display ";XmRenderTableGetRenditions font type: ~A" default-font-info)))
(let* ((button-render-table (cadr (XtVaGetValues (cadr (main-widgets)) (list XmNbuttonRenderTable 0))))
@@ -44937,7 +44101,7 @@ EDITS: 1
(XInternAtom dpy "XA_FOUNDRY" #f)
XA_CAP_HEIGHT)
(list #f #t #t #t #t #t #t #f))
- (if (not (string=? "Fixed" (cadr (data 1)))) (snd-display #__line__ ";XmRenderTableGetRendition: ~A" data)))))
+ (if (not (string=? "Fixed" (cadr (data 1)))) (snd-display ";XmRenderTableGetRendition: ~A" data)))))
(let* ((tabs (let ((ctr 0))
(map
@@ -44947,18 +44111,18 @@ EDITS: 1
(list 1.5 1.5 1.5 1.5))))
(tablist (XmTabListInsertTabs #f tabs (length tabs) 0)))
(if (not (= (XmTabListTabCount tablist) (length tabs)))
- (snd-display #__line__ ";tablist len: ~A ~A~%" (XmTabListTabCount tablist) (length tabs)))
+ (snd-display ";tablist len: ~A ~A~%" (XmTabListTabCount tablist) (length tabs)))
(if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 0)) (list 1.5 5 0 0 ".")))
- (snd-display #__line__ ";XmTabs 0: ~A" (XmTabGetValues (XmTabListGetTab tablist 0))))
+ (snd-display ";XmTabs 0: ~A" (XmTabGetValues (XmTabListGetTab tablist 0))))
(if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 2)) (list 1.5 5 1 0 ".")))
- (snd-display #__line__ ";XmTabs 2: ~A" (XmTabGetValues (XmTabListGetTab tablist 2))))
+ (snd-display ";XmTabs 2: ~A" (XmTabGetValues (XmTabListGetTab tablist 2))))
(let ((copytab (XmTabListCopy tablist 0 0)))
(if (not (equal? (XmTabGetValues (XmTabListGetTab copytab 0)) (list 1.5 5 0 0 ".")))
- (snd-display #__line__ ";XmTabListCopy 0: ~A" (XmTabGetValues (XmTabListGetTab copytab 0))))
+ (snd-display ";XmTabListCopy 0: ~A" (XmTabGetValues (XmTabListGetTab copytab 0))))
(let ((another (XmTabListRemoveTabs copytab (list 0 1)))
(atab (XmTabCreate 3.0 XmINCHES XmABSOLUTE XmALIGNMENT_BEGINNING ".")))
(if (not (equal? (XmTabGetValues (XmTabListGetTab another 0)) (list 1.5 5 1 0 ".")))
- (snd-display #__line__ ";XmTabListRemoveTabs: ~A" (XmTabGetValues (XmTabListGetTab another 0))))
+ (snd-display ";XmTabListRemoveTabs: ~A" (XmTabGetValues (XmTabListGetTab another 0))))
(XmTabListReplacePositions (XmTabListCopy tablist 0 0) (list 1) (list atab))
;; this (replacepositions) is very prone to segfaults -- *very* poorly implemented!
(XmTabSetValue atab 6.0)
@@ -44969,16 +44133,16 @@ EDITS: 1
(cadr (main-widgets))
1.0
XmABSOLUTE)))
- (if (not (XmTabList? tabl)) (snd-display #__line__ ";XmStringTableProposeTabList: ~A" tabl))
+ (if (not (XmTabList? tabl)) (snd-display ";XmStringTableProposeTabList: ~A" tabl))
(XmTabListFree tabl)))
(let ((hname (host-name))) ; from snd-motif.scm
(if (not (equal? hname (getenv "HOSTNAME")))
- (snd-display #__line__ ";host name appears to be ~A or maybe ~A" hname (getenv "HOSTNAME"))))
+ (snd-display ";host name appears to be ~A or maybe ~A" hname (getenv "HOSTNAME"))))
(let ((blu (x->snd-color "blue")))
- (if (not (Pixel? blu)) (snd-display #__line__ ";x->snd-color can't find blue! ~A" blu))
+ (if (not (Pixel? blu)) (snd-display ";x->snd-color can't find blue! ~A" blu))
(if (not (equal? (color->list blu) (list 0.0 0.0 1.0)))
- (snd-display #__line__ ";x->snd-color blue: ~A" (color->list blu))))
+ (snd-display ";x->snd-color blue: ~A" (color->list blu))))
(let* ((tmp (XmStringCreateLocalized "h"))
(pm (XmParseMappingCreate (list XmNincludeStatus XmINSERT
@@ -44996,7 +44160,7 @@ EDITS: 1
(lambda (txt end type tag entry pattern)
#f)))))
(lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmNinvokeParseProc wrong arity: ~A" tag))))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmNinvokeParseProc wrong arity: ~A" tag))))
(let* ((fonts (list "fixed"
"-*-times-bold-r-*-*-14-*-*-*-*-*-*-*"
@@ -45010,15 +44174,15 @@ EDITS: 1
(cmap (DefaultColormap dpy scr)))
(let ((col (XColor)))
(XParseColor dpy cmap "blue" col)
- (if (or (not (= (.red col) 0))
- (not (= (.green col) 0))
- (not (= (.blue col) 65535)))
- (snd-display #__line__ ";XParseColor: ~A ~A ~A ~A" col (.red col) (.blue col) (.green col)))
+ (if (not (and (= (.red col) 0)
+ (= (.green col) 0)
+ (= (.blue col) 65535)))
+ (snd-display ";XParseColor: ~A ~A ~A ~A" col (.red col) (.blue col) (.green col)))
(XLookupColor dpy cmap "red" col (XColor))
- (if (or (not (= (.red col) 65535))
- (not (= (.green col) 0))
- (not (= (.blue col) 0)))
- (snd-display #__line__ ";XLookupColor: ~A ~A ~A ~A" col (.red col) (.blue col) (.green col))))
+ (if (not (and (= (.red col) 65535)
+ (= (.green col) 0)
+ (= (.blue col) 0)))
+ (snd-display ";XLookupColor: ~A ~A ~A ~A" col (.red col) (.blue col) (.green col))))
(map
(lambda (color)
(let ((col (XColor)))
@@ -45047,22 +44211,22 @@ EDITS: 1
(let* ((dpy (XtDisplay (cadr (main-widgets))))
(scr (DefaultScreenOfDisplay dpy))
(p1 (XmGetPixmap scr "hiho" (car pixels) (cadr pixels))))
- (if (not (Pixmap? p1)) (snd-display #__line__ ";XmGetPixmap: ~A" p1))
+ (if (not (Pixmap? p1)) (snd-display ";XmGetPixmap: ~A" p1))
(set! p1 (XmGetPixmapByDepth scr "hoho" (car pixels) (cadr pixels) (XDefaultDepth dpy (XScreenNumberOfScreen scr))))
- (if (not (Pixmap? p1)) (snd-display #__line__ ";XmGetPixmapByDepth: ~A" p1))
+ (if (not (Pixmap? p1)) (snd-display ";XmGetPixmapByDepth: ~A" p1))
(XmDestroyPixmap scr p1))
(let ((tabl (XmStringTableParseStringArray (list "hi" "ho") 2 "hiho" XmCHARSET_TEXT #f 0 #f)))
- (if (not (XmString? (car tabl))) (snd-display #__line__ ";XmStringTableParseStringArray: ~A" tabl))
+ (if (not (XmString? (car tabl))) (snd-display ";XmStringTableParseStringArray: ~A" tabl))
(let ((strs (XmStringTableUnparse tabl 2 "hiho" XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (if (not (equal? strs (list "hi" "ho"))) (snd-display #__line__ ";XmStringTableUnparse: ~A" strs)))
+ (if (not (equal? strs (list "hi" "ho"))) (snd-display ";XmStringTableUnparse: ~A" strs)))
(let ((str (XmStringTableToXmString tabl 2 #f)))
- (if (not (XmString? str)) (snd-display #__line__ ";XmStringTableToXmString: ~A" str))
+ (if (not (XmString? str)) (snd-display ";XmStringTableToXmString: ~A" str))
(XmStringToXmStringTable str #f)
(let ((val (XmStringUnparse str "hiho" XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (if (not (string=? val "hiho")) (snd-display #__line__ ";XmStringUnparse: ~A" val))
+ (if (not (string=? val "hiho")) (snd-display ";XmStringUnparse: ~A" val))
(set! val (XmStringUnparse (XmStringCreateLocalized "hi") #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL))
- (if (not (string=? val "hi")) (snd-display #__line__ ";XmStringUnparse null tag: ~A" val)))
+ (if (not (string=? val "hi")) (snd-display ";XmStringUnparse null tag: ~A" val)))
;; XmCvtXmStringToByteStream test deleted because it seems to be buggy in memory handling
(let* ((ind (open-sound "oboe.snd"))
(grf1 (car (channel-widgets)))
@@ -45071,19 +44235,19 @@ EDITS: 1
(scr (DefaultScreenOfDisplay dpy))
(scrn (XScreenNumberOfScreen scr))
(gv (XGCValues)))
- (if (not (Font? (current-font ind))) (snd-display #__line__ ";current-font: ~A" (current-font ind)))
+ (if (not (Font? (current-font ind))) (snd-display ";current-font: ~A" (current-font ind)))
(let ((old-font (current-font))
(a-font (load-font "6x12")))
(set! (current-font) a-font)
(if (not (equal? a-font (current-font)))
- (snd-display #__line__ ";set current-font: ~A ~A" a-font (current-font)))
+ (snd-display ";set current-font: ~A ~A" a-font (current-font)))
(set! (current-font ind) old-font)
(if (not (equal? old-font (current-font ind)))
- (snd-display #__line__ ";set current-font with ind: ~A ~A" old-font (current-font ind)))
+ (snd-display ";set current-font with ind: ~A ~A" old-font (current-font ind)))
(set! (current-font) a-font)
(set! (current-font ind 0) old-font)
(if (not (equal? old-font (current-font ind 0)))
- (snd-display #__line__ ";set current-font with ind/0: ~A ~A" old-font (current-font ind 0)))
+ (snd-display ";set current-font with ind/0: ~A ~A" old-font (current-font ind 0)))
(set! (current-font) old-font))
(set! (.foreground gv) *data-color*)
@@ -45094,14 +44258,14 @@ EDITS: 1
(logior GCForeground GCBackground GCFunction)
gv
(logior GCFont GCDashList)
- 0))
- (str2 (XmStringCreateLocalized "hiho")))
- (XmStringDraw dpy win rendertable str2 sgc 10 10 100
- XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100))
- (XmStringDrawImage dpy win rendertable str2 sgc 10 10 100
- XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100))
- (XmStringDrawUnderline dpy win rendertable str2 sgc 10 10 100
- XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100) str2)
+ 0)))
+ (let ((str2 (XmStringCreateLocalized "hiho")))
+ (XmStringDraw dpy win rendertable str2 sgc 10 10 100
+ XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100))
+ (XmStringDrawImage dpy win rendertable str2 sgc 10 10 100
+ XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100))
+ (XmStringDrawUnderline dpy win rendertable str2 sgc 10 10 100
+ XmALIGNMENT_END XmSTRING_DIRECTION_L_TO_R (XRectangle 0 0 100 100) str2))
(XtGetGC (cadr (main-widgets)) GCForeground gv)
(XCopyGC dpy sgc GCFunction sgc)
(XCopyArea dpy win win sgc 0 0 100 100 0 0)
@@ -45109,12 +44273,12 @@ EDITS: 1
(XtReleaseGC grf1 sgc))
(close-sound ind))
(let ((lc (XmStringLineCount (XmStringCreateLocalized "hiho"))))
- (if (not (= lc 1)) (snd-display #__line__ ";XmStringLineCount: ~A" lc)))
- (if (not (XmStringHasSubstring str (XmStringCreateLocalized "hi"))) (snd-display #__line__ ";XmStringHasSubstring?"))))
+ (if (not (= lc 1)) (snd-display ";XmStringLineCount: ~A" lc)))
+ (if (not (XmStringHasSubstring str (XmStringCreateLocalized "hi"))) (snd-display ";XmStringHasSubstring?"))))
(if (not (equal? (XmRenderTableGetTags rendertable) (list "one" "two" "three" "four")))
- (snd-display #__line__ ";tags: ~A~%" (XmRenderTableGetTags rendertable)))
+ (snd-display ";tags: ~A~%" (XmRenderTableGetTags rendertable)))
(let* ((rend (XmRenderTableGetRendition rendertable "one"))
(r (and rend (XmRenditionRetrieve rend
(list XmNrenditionForeground 0
@@ -45123,18 +44287,17 @@ EDITS: 1
XmNtag 0)))))
(if (and rend r)
(begin
- (if (or (not (string=? (r 7) "one"))
- (not (string=? (r 3) "fixed")))
- (snd-display #__line__ ";rendertable: ~A" r))
+ (if (not (and (string=? (r 7) "one")
+ (string=? (r 3) "fixed")))
+ (snd-display ";rendertable: ~A" r))
(XmRenditionUpdate rend (list XmNstrikethruType XmSINGLE_LINE))
(if (not (= (cadr (XmRenditionRetrieve rend (list XmNstrikethruType 0))) XmSINGLE_LINE))
- (snd-display #__line__ ";XmRenditionUpdate: ~A ~A" (cadr (XtGetValues rend (list XmNstrikethruType 0))) XmSINGLE_LINE)))
- (snd-display #__line__ ";r and rend: ~A ~A~%" r rend)))
- (let ((r1 (XmRenditionCreate (cadr (main-widgets)) "r1" (list XmNfontName "fixed"))))
- (XmRenditionFree r1))
+ (snd-display ";XmRenditionUpdate: ~A ~A" (cadr (XtGetValues rend (list XmNstrikethruType 0))) XmSINGLE_LINE)))
+ (snd-display ";r and rend: ~A ~A~%" r rend)))
+ (XmRenditionFree (XmRenditionCreate (cadr (main-widgets)) "r1" (list XmNfontName "fixed")))
(if (not (equal? (XmDropSiteQueryStackingOrder ((main-widgets) 4)) (list #f)))
- (snd-display #__line__ ";XmDropSiteQueryStackingOrder: ~A" (XmDropSiteQueryStackingOrder ((main-widgets) 4))))
+ (snd-display ";XmDropSiteQueryStackingOrder: ~A" (XmDropSiteQueryStackingOrder ((main-widgets) 4))))
(let ((tab (XmStringComponentCreate XmSTRING_COMPONENT_TAB 0 #f))
(row #f)
(table ())
@@ -45145,20 +44308,20 @@ EDITS: 1
#f
XmCHARSET_TEXT
(car our-tags))))
- (if (XmStringIsVoid entry) (snd-display #__line__ ";~A is void?" entry))
- (if (XmStringEmpty entry) (snd-display #__line__ ";~A is empty?" entry))
+ (if (XmStringIsVoid entry) (snd-display ";~A is void?" entry))
+ (if (XmStringEmpty entry) (snd-display ";~A is empty?" entry))
(if row
(let ((tmp (XmStringConcat row tab)))
(XmStringFree row)
(set! row (XmStringConcatAndFree tmp entry)))
- (set! row entry))
- (set! our-tags (cdr our-tags))
- (if (null? our-tags)
- (begin
- (set! our-tags tags)
- (set! table (cons row table))
- (set! row #f)))))
+ (set! row entry)))
+ (set! our-tags (cdr our-tags))
+ (if (null? our-tags)
+ (begin
+ (set! our-tags tags)
+ (set! table (cons row table))
+ (set! row #f))))
(list "this" "is" "a" "test" "of" "the" "renditions" "and" "rendertables"
"perhaps" "all" "will" "go" "well" "and" "then" "again" "perhaps" "not"))
(let* ((n (car table))
@@ -45168,10 +44331,10 @@ EDITS: 1
((not happy))
(let ((type (XmStringGetNextTriple (cadr c))))
(if (= (car type) XmSTRING_COMPONENT_TEXT)
- (if (or (not (= (cadr type) ((list 0 0 2 0 0 0 4 0 0 0 3 0 0 0 4) i)))
- (not (string=? (caddr type)
- ((list "o" "o" "go" "o" "o" "o" "well" "o" "o" "o" "and" "o" "o" "o" "then") i))))
- (snd-display #__line__ ";component ~A -> ~A" i (cdr type)))
+ (if (not (and (= (cadr type) ((list 0 0 2 0 0 0 4 0 0 0 3 0 0 0 4) i))
+ (string=? (caddr type)
+ ((list "o" "o" "go" "o" "o" "o" "well" "o" "o" "o" "and" "o" "o" "o" "then") i))))
+ (snd-display ";component ~A -> ~A" i (cdr type)))
(if (and (not (= (car type) XmSTRING_COMPONENT_TAB))
(= (car type) XmSTRING_COMPONENT_END))
(set! happy #f)))))
@@ -45179,16 +44342,15 @@ EDITS: 1
(XtAppAddActions (car (main-widgets))
(list (list "try1" (lambda (w e strs)
- (snd-display #__line__ ";try1: ~A~%" strs)))
+ (snd-display ";try1: ~A~%" strs)))
(list "try2" (lambda (w e strs)
- (snd-display #__line__ ";try2: ~A~%" strs)))))
- (let ((tab (XtParseTranslationTable
- (format #f "Ctrl <Key>osfLeft: try1()~%Ctrl <Key>osfRight: try2()~%Ctrl <Key>osfUp: try1(hiho)~%Ctrl <Key>osfDown: try2(down, up)~%")))
- (pane (add-main-pane "hiho" xmTextWidgetClass ())))
- (XtOverrideTranslations pane tab))
+ (snd-display ";try2: ~A~%" strs)))))
+ (XtOverrideTranslations (add-main-pane "hiho" xmTextWidgetClass ())
+ (XtParseTranslationTable
+ (format #f "Ctrl <Key>osfLeft: try1()~%Ctrl <Key>osfRight: try2()~%Ctrl <Key>osfUp: try1(hiho)~%Ctrl <Key>osfDown: try2(down, up)~%")))
(let ((XmNhiho (add-resource "hiho" 0)))
- (if (not (string=? XmNhiho "hiho")) (snd-display #__line__ ";add-resource XmNhiho: ~A" XmNhiho)))
+ (if (not (string=? XmNhiho "hiho")) (snd-display ";add-resource XmNhiho: ~A" XmNhiho)))
(open-sound "cardinal.snd")
(let* ((mouse_width 32)
@@ -45231,165 +44393,161 @@ EDITS: 1
(let ((cmap (XCreateColormap dpy win vis AllocNone)))
(set! cmap (XCopyColormapAndFree dpy cmap))
- (XFreeColormap dpy cmap)
- (if (XCheckTypedWindowEvent dpy win ExposureMask)
- (snd-display #__line__ ";XCheckTypedWindowEvent: ~A" (XCheckTypedWindowEvent dpy win ExposureMask)))
- (if (XCheckTypedEvent dpy ExposureMask)
- (snd-display #__line__ ";XCheckTypedEvent: ~A" (XCheckTypedEvent dpy ExposureMask)))
- (XCheckWindowEvent dpy win ExposureMask)
+ (XFreeColormap dpy cmap))
+ (if (XCheckTypedWindowEvent dpy win ExposureMask)
+ (snd-display ";XCheckTypedWindowEvent: ~A" (XCheckTypedWindowEvent dpy win ExposureMask)))
+ (if (XCheckTypedEvent dpy ExposureMask)
+ (snd-display ";XCheckTypedEvent: ~A" (XCheckTypedEvent dpy ExposureMask)))
+ (XCheckWindowEvent dpy win ExposureMask)
; (if (XCheckIfEvent dpy (lambda (d e data) #f) #f)
- ; (snd-display #__line__ ";XCheckIfEvent: ~A" (XCheckIfEvent dpy (lambda (d e data) #f) #f)))
- (XCirculateSubwindows dpy win RaiseLowest)
- (XCirculateSubwindowsUp dpy win)
- (XCirculateSubwindowsDown dpy win)
- (let ((wc (XWindowChanges 10 10 100 100 10 win 0)))
- (if (not (= (.stack_mode wc) 0)) (snd-display #__line__ ";stack_mode wc: ~A" (.stack_mode wc)))
- (if (not (equal? (.sibling wc) win)) (snd-display #__line__ ";sibling wc: ~A" (.sibling wc)))
- (if (not (= (.x wc) 10)) (snd-display #__line__ ";x wc: ~A" (.x wc)))
- (if (not (= (.y wc) 10)) (snd-display #__line__ ";y wc: ~A" (.y wc)))
- (if (not (= (.width wc) 100)) (snd-display #__line__ ";width wc: ~A" (.width wc)))
- (if (not (= (.height wc) 100)) (snd-display #__line__ ";height wc: ~A" (.height wc)))
- (if (not (= (.border_width wc) 10)) (snd-display #__line__ ";border_width wc: ~A" (.border_width wc))))
- (if (defined? 'XpmImage)
- (let ((xp (XpmImage 10 10 0 1 0)))
- (if (not (= (.cpp xp) 0)) (snd-display #__line__ ";cpp xp: ~A" (.cpp xp)))
- (if (not (= (.ncolors xp) 1)) (snd-display #__line__ ";ncolors xp: ~A" (.ncolors xp)))))
- )
+ ; (snd-display ";XCheckIfEvent: ~A" (XCheckIfEvent dpy (lambda (d e data) #f) #f)))
+ (XCirculateSubwindows dpy win RaiseLowest)
+ (XCirculateSubwindowsUp dpy win)
+ (XCirculateSubwindowsDown dpy win)
+ (let ((wc (XWindowChanges 10 10 100 100 10 win 0)))
+ (if (not (= (.stack_mode wc) 0)) (snd-display ";stack_mode wc: ~A" (.stack_mode wc)))
+ (if (not (equal? (.sibling wc) win)) (snd-display ";sibling wc: ~A" (.sibling wc)))
+ (if (not (= (.x wc) 10)) (snd-display ";x wc: ~A" (.x wc)))
+ (if (not (= (.y wc) 10)) (snd-display ";y wc: ~A" (.y wc)))
+ (if (not (= (.width wc) 100)) (snd-display ";width wc: ~A" (.width wc)))
+ (if (not (= (.height wc) 100)) (snd-display ";height wc: ~A" (.height wc)))
+ (if (not (= (.border_width wc) 10)) (snd-display ";border_width wc: ~A" (.border_width wc))))
+ (if (defined? 'XpmImage)
+ (let ((xp (XpmImage 10 10 0 1 0)))
+ (if (not (= (.cpp xp) 0)) (snd-display ";cpp xp: ~A" (.cpp xp)))
+ (if (not (= (.ncolors xp) 1)) (snd-display ";ncolors xp: ~A" (.ncolors xp)))))
+
(XmObjectAtPoint shell 100 100)
- (if (not (string=? (XmGetAtomName dpy XA_STRING) "STRING")) (snd-display #__line__ ";XmGetAtomName: ~A" (XmGetAtomName dpy XA_STRING)))
- (if (not (XmTargetsAreCompatible dpy (list XA_STRING) 1 (list XA_STRING) 1)) (snd-display #__line__ ";XmTargetsAreCompatible"))
+ (if (not (string=? (XmGetAtomName dpy XA_STRING) "STRING")) (snd-display ";XmGetAtomName: ~A" (XmGetAtomName dpy XA_STRING)))
+ (if (not (XmTargetsAreCompatible dpy (list XA_STRING) 1 (list XA_STRING) 1)) (snd-display ";XmTargetsAreCompatible"))
(XmUpdateDisplay grf1)
(let ((lines (XmWidgetGetBaselines ((main-widgets) 4))))
- (if (not lines) (snd-display #__line__ ";XmWidgetGetBaselines?"))
- (if (< (length lines) 4) (snd-display #__line__ ";no listener text?? ~A" lines)))
+ (if (not lines) (snd-display ";XmWidgetGetBaselines?"))
+ (if (< (length lines) 4) (snd-display ";no listener text?? ~A" lines)))
(let ((r (XmWidgetGetDisplayRect ((sound-widgets) 8))))
- (if (not (XRectangle? r)) (snd-display #__line__ ";XmWidgetGetDisplayRect: ~A" r)))
+ (if (not (XRectangle? r)) (snd-display ";XmWidgetGetDisplayRect: ~A" r)))
(XDrawImageString dpy (list 'Window (cadr pix)) sgc 0 10 "hiho" 4)
- (let* ((data (XtCalloc (* 11 11 depth) 1))
- (before (XCreateImage dpy vis depth XYPixmap 0 data 10 10 8 0))
- (newimage (XGetSubImage dpy (list 'Window (cadr pix)) 0 0 10 10 AllPlanes XYPixmap before 0 0)))
- (XSubImage newimage 0 0 3 3)
- (if (not (= (.bytes_per_line newimage) 2)) (snd-display #__line__ ";bytes_per_line: ~A" (.bytes_per_line newimage)))
- (if (not (= (.byte_order newimage) 0)) (snd-display #__line__ ";byte_order: ~A" (.byte_order newimage)))
- (if (not (= (.bitmap_pad newimage) 8)) (snd-display #__line__ ";bitmap_pad: ~A" (.bitmap_pad newimage)))
- (if (not (= (.bitmap_bit_order newimage) 0)) (snd-display #__line__ ";bitmap_bit_order: ~A" (.bitmap_bit_order newimage)))
- (if (not (= (.bitmap_unit newimage) 32)) (snd-display #__line__ ";bitmap_unit: ~A" (.bitmap_unit newimage)))
- ; (if (not (= (.obdata newimage) 0)) (snd-display #__line__ ";obdata: ~A" (.obdata newimage)))
- (if (not (= (.xoffset newimage) 0)) (snd-display #__line__ ";xoffset: ~A" (.xoffset newimage)))
+ (let ((before (XCreateImage dpy vis depth XYPixmap 0 (XtCalloc (* 121 depth) 1) 10 10 8 0)))
+ (let ((newimage (XGetSubImage dpy (list 'Window (cadr pix)) 0 0 10 10 AllPlanes XYPixmap before 0 0)))
+ (XSubImage newimage 0 0 3 3)
+ (if (not (= (.bytes_per_line newimage) 2)) (snd-display ";bytes_per_line: ~A" (.bytes_per_line newimage)))
+ (if (not (= (.byte_order newimage) 0)) (snd-display ";byte_order: ~A" (.byte_order newimage)))
+ (if (not (= (.bitmap_pad newimage) 8)) (snd-display ";bitmap_pad: ~A" (.bitmap_pad newimage)))
+ (if (not (= (.bitmap_bit_order newimage) 0)) (snd-display ";bitmap_bit_order: ~A" (.bitmap_bit_order newimage)))
+ (if (not (= (.bitmap_unit newimage) 32)) (snd-display ";bitmap_unit: ~A" (.bitmap_unit newimage)))
+ (if (not (= (.xoffset newimage) 0)) (snd-display ";xoffset: ~A" (.xoffset newimage))))
(XPutPixel before 1 1 *basic-color*)
(XGetPixel before 1 1)
(XPutImage dpy (list 'Window (cadr rotpix)) sgc before 0 0 0 0 10 10)
(XAddPixel before 1)
- (if (> (.bits_per_pixel before) 123) (snd-display #__line__ ";bits_per_pixel: ~A" (.bits_per_pixel before)))
+ (if (> (.bits_per_pixel before) 123) (snd-display ";bits_per_pixel: ~A" (.bits_per_pixel before)))
(XmInstallImage before "before_image")
(XmUninstallImage before)
- (if (defined? 'XpmAttributes)
- (let ((i11 (XGetImage dpy (list 'Window (cadr pix)) 0 0 10 10 AllPlanes XYPixmap))
- (attr (XpmAttributes))
- (vals (XtGetValues (cadr (main-widgets)) (list XmNcolormap 0 XmNdepth 0)))
- (sym (XpmColorSymbol "basiccolor" #f *basic-color*)))
- (if (not (string=? (.name sym) "basiccolor")) (snd-display #__line__ ";.name colorsymbol: ~A" (.name sym)))
- (set! (.name sym) "hiho")
- (if (not (string=? (.name sym) "hiho")) (snd-display #__line__ ";set .name colorsymbol: ~A" (.name sym)))
- (set! (.visual attr) vis)
- (if (not (equal? vis (.visual attr))) (snd-display #__line__ ";visual xpm attr: ~A" (.visual attr)))
- (if (not (list? (.colorsymbols attr))) (snd-display #__line__ ";.colorsymbols attr: ~A" (.colorsymbols attr)))
- (set! (.colorsymbols attr) (list sym))
- (set! (.pixel sym) *basic-color*)
- (set! (.numsymbols attr) 1)
- (if (not (eqv? 1 (.numsymbols attr))) (snd-display #__line__ ";numsymbols xpm attr: ~A" (.numsymbols attr)))
- (set! (.depth attr) (vals 3))
- (if (not (equal? (vals 3) (.depth attr))) (snd-display #__line__ ";depth xpm attr: ~A" (.depth attr)))
- (set! (.colormap attr) (vals 1))
- (if (not (equal? (vals 1) (.colormap attr))) (snd-display #__line__ ";colormap xpm attr: ~A" (.colormap attr)))
- (set! (.valuemask attr) (logior XpmColorSymbols XpmDepth XpmColormap XpmVisual))
- (if (not (= (.valuemask attr) (logior XpmColorSymbols XpmDepth XpmColormap XpmVisual)))
- (snd-display #__line__ ";valuemask: ~A" (.valuemask attr)))
- (if (not (= (.x_hotspot attr) 0)) (snd-display #__line__ ";x_hotspot: ~A" (.x_hotspot attr)))
- (if (not (= (.y_hotspot attr) 0)) (snd-display #__line__ ";y_hotspot: ~A" (.y_hotspot attr)))
- (if (not (= (.npixels attr) 0)) (snd-display #__line__ ";npixels: ~A" (.npixels attr)))
- (let ((err (XpmCreatePixmapFromData dpy win
- (list "16 14 6 1"
- " c None s None"
- ". c gray50"
- "X c black"
- "o c white"
- "O c yellow"
- "- c ivory2 s basiccolor"
- "------.XXX.-----"
- "-----X.ooo.X----"
- "----..oXXXo..---"
- "----XoX...XoX---"
- "----XoX.--XoX.--"
- "----XoX.--XoX.--"
- "---XXXXXXXXXXX--"
- "---XOOOOOOOOOX.-"
- "---XO.......OX.-"
- "---XOOOOOOOOOX.-"
- "---XO.......OX.-"
- "---XOOOOOOOOOX.-"
- "---XXXXXXXXXXX.-"
- "----...........-")
- attr)))
- (if (or (not (= (car err) XpmSuccess))
- (not (Pixmap? (cadr err))))
- (snd-display #__line__ ";XpmCreatePixmapFromData: ~A" err)))
-
- (let* ((shell (cadr (main-widgets)))
- (dpy (XtDisplay shell))
- (button (XmCreatePushButton shell "button" ()))
- (status-and-whatnot (XpmReadFileToPixmap dpy (XRootWindowOfScreen (XtScreen shell)) "bullet.xpm" #f))
- (status (car status-and-whatnot))
- (pixmap (cadr status-and-whatnot))
- (pixmap1 (caddr status-and-whatnot)))
- (if (not (string=? (XpmGetErrorString XpmSuccess) "XpmSuccess"))
- (snd-display #__line__ ";XpmGetErrorString: ~A" (XpmGetErrorString XpmSuccess)))
- (if (not (= status XpmSuccess))
- (snd-display #__line__ "; XpmError ReadFileToPixmap: ~A" (XpmGetErrorString status)))
- (XtVaSetValues button (list XmNlabelType XmPIXMAP
- XmNlabelPixmap pixmap))
- (XpmWriteFileFromPixmap dpy "test.xpm" pixmap pixmap1 #f)
- (XpmCreateDataFromPixmap dpy pixmap pixmap1 #f)
- (let ((status (XpmReadFileToXpmImage "bullet.xpm"))
- (symb (XpmColorSymbol "Foreground" "green" *basic-color*))
- (attr (XpmAttributes)))
- (if (not (XpmImage? status))
- (snd-display #__line__ "; XpmError ReadFileToXpmImage: ~A ~A" symb (XpmGetErrorString status)))
- (set! (.valuemask attr) XpmColorSymbols)
- (XpmCreatePixmapFromXpmImage dpy (XRootWindowOfScreen (XtScreen shell)) status attr)
- (XpmCreateXpmImageFromPixmap dpy pixmap pixmap1 attr)
- (for-each
- (lambda (func val name)
- (set! (func attr) val)
- (if (not (equal? (func attr) val)) (snd-display #__line__ ";attr ~A ~A" name (func attr))))
- (list .valuemask .depth .width .x_hotspot .y_hotspot .cpp .npixels .ncolors)
- (list 0 0 0 0 0 0 0 0)
- (list 'valuemask 'depth 'width 'x_hotspot 'y_hotspot 'cpp 'npixels 'ncolors)))
- )
- (XDestroyImage i11)))
-
- (XDestroyImage before)
- (XFreePixmap dpy pix)
- (XVisualIDFromVisual vis)
- (XGrabServer dpy)
- (XUngrabServer dpy)
- (XGrabPointer dpy win #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None) (list 'Time CurrentTime))
- (XUngrabPointer dpy (list 'Time CurrentTime))
- (XGrabKeyboard dpy win #t GrabModeSync GrabModeSync (list 'Time CurrentTime))
- (XUngrabKeyboard dpy (list 'Time CurrentTime))
- (XGrabKey dpy AnyKey AnyModifier win #t GrabModeSync GrabModeSync)
- (XUngrabKey dpy AnyKey AnyModifier win)
- (XGrabButton dpy AnyButton AnyModifier win #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None))
- (XUngrabButton dpy AnyButton AnyModifier win)
- (XtGrabPointer shell #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None) (list 'Time CurrentTime))
- (XtUngrabPointer shell (list 'Time CurrentTime))
- (XtGrabKeyboard shell #t GrabModeSync GrabModeSync (list 'Time CurrentTime))
- (XtUngrabKeyboard shell (list 'Time CurrentTime))
- (XtGrabKey shell (list 'KeyCode AnyKey) AnyModifier #t GrabModeSync GrabModeSync)
- (XtUngrabKey shell (list 'KeyCode AnyKey) AnyModifier)
- (XtGrabButton shell AnyButton AnyModifier #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None))
- (XtUngrabButton shell AnyButton AnyModifier)
- ))
+ (XDestroyImage before))
+ (when (defined? 'XpmAttributes)
+ (let ((i11 (XGetImage dpy (list 'Window (cadr pix)) 0 0 10 10 AllPlanes XYPixmap))
+ (attr (XpmAttributes))
+ (vals (XtGetValues (cadr (main-widgets)) (list XmNcolormap 0 XmNdepth 0))))
+ (let ((sym (XpmColorSymbol "basiccolor" #f *basic-color*)))
+ (if (not (string=? (.name sym) "basiccolor")) (snd-display ";.name colorsymbol: ~A" (.name sym)))
+ (set! (.name sym) "hiho")
+ (if (not (string=? (.name sym) "hiho")) (snd-display ";set .name colorsymbol: ~A" (.name sym)))
+ (set! (.visual attr) vis)
+ (if (not (equal? vis (.visual attr))) (snd-display ";visual xpm attr: ~A" (.visual attr)))
+ (if (not (list? (.colorsymbols attr))) (snd-display ";.colorsymbols attr: ~A" (.colorsymbols attr)))
+ (set! (.colorsymbols attr) (list sym))
+ (set! (.pixel sym) *basic-color*))
+ (set! (.numsymbols attr) 1)
+ (if (not (eqv? 1 (.numsymbols attr))) (snd-display ";numsymbols xpm attr: ~A" (.numsymbols attr)))
+ (set! (.depth attr) (vals 3))
+ (if (not (equal? (vals 3) (.depth attr))) (snd-display ";depth xpm attr: ~A" (.depth attr)))
+ (set! (.colormap attr) (vals 1))
+ (if (not (equal? (vals 1) (.colormap attr))) (snd-display ";colormap xpm attr: ~A" (.colormap attr)))
+ (set! (.valuemask attr) (logior XpmColorSymbols XpmDepth XpmColormap XpmVisual))
+ (if (not (= (.valuemask attr) (logior XpmColorSymbols XpmDepth XpmColormap XpmVisual)))
+ (snd-display ";valuemask: ~A" (.valuemask attr)))
+ (if (not (= (.x_hotspot attr) 0)) (snd-display ";x_hotspot: ~A" (.x_hotspot attr)))
+ (if (not (= (.y_hotspot attr) 0)) (snd-display ";y_hotspot: ~A" (.y_hotspot attr)))
+ (if (not (= (.npixels attr) 0)) (snd-display ";npixels: ~A" (.npixels attr)))
+ (let ((err (XpmCreatePixmapFromData dpy win
+ (list "16 14 6 1"
+ " c None s None"
+ ". c gray50"
+ "X c black"
+ "o c white"
+ "O c yellow"
+ "- c ivory2 s basiccolor"
+ "------.XXX.-----"
+ "-----X.ooo.X----"
+ "----..oXXXo..---"
+ "----XoX...XoX---"
+ "----XoX.--XoX.--"
+ "----XoX.--XoX.--"
+ "---XXXXXXXXXXX--"
+ "---XOOOOOOOOOX.-"
+ "---XO.......OX.-"
+ "---XOOOOOOOOOX.-"
+ "---XO.......OX.-"
+ "---XOOOOOOOOOX.-"
+ "---XXXXXXXXXXX.-"
+ "----...........-")
+ attr)))
+ (if (not (and (= (car err) XpmSuccess)
+ (Pixmap? (cadr err))))
+ (snd-display ";XpmCreatePixmapFromData: ~A" err)))
+
+ (let* ((shell (cadr (main-widgets)))
+ (dpy (XtDisplay shell))
+ (button (XmCreatePushButton shell "button" ()))
+ (status-and-whatnot (XpmReadFileToPixmap dpy (XRootWindowOfScreen (XtScreen shell)) "bullet.xpm" #f))
+ (status (car status-and-whatnot))
+ (pixmap (cadr status-and-whatnot))
+ (pixmap1 (caddr status-and-whatnot)))
+ (if (not (string=? (XpmGetErrorString XpmSuccess) "XpmSuccess"))
+ (snd-display ";XpmGetErrorString: ~A" (XpmGetErrorString XpmSuccess)))
+ (if (not (= status XpmSuccess))
+ (snd-display "; XpmError ReadFileToPixmap: ~A" (XpmGetErrorString status)))
+ (XtVaSetValues button (list XmNlabelType XmPIXMAP
+ XmNlabelPixmap pixmap))
+ (XpmWriteFileFromPixmap dpy "test.xpm" pixmap pixmap1 #f)
+ (XpmCreateDataFromPixmap dpy pixmap pixmap1 #f)
+ (let ((status (XpmReadFileToXpmImage "bullet.xpm"))
+ (attr (XpmAttributes)))
+ (let ((symb (XpmColorSymbol "Foreground" "green" *basic-color*)))
+ (if (not (XpmImage? status))
+ (snd-display "; XpmError ReadFileToXpmImage: ~A ~A" symb (XpmGetErrorString status))))
+ (set! (.valuemask attr) XpmColorSymbols)
+ (XpmCreatePixmapFromXpmImage dpy (XRootWindowOfScreen (XtScreen shell)) status attr)
+ (XpmCreateXpmImageFromPixmap dpy pixmap pixmap1 attr)
+ (for-each
+ (lambda (func val name)
+ (set! (func attr) val)
+ (if (not (equal? (func attr) val)) (snd-display ";attr ~A ~A" name (func attr))))
+ (list .valuemask .depth .width .x_hotspot .y_hotspot .cpp .npixels .ncolors)
+ (list 0 0 0 0 0 0 0 0)
+ (list 'valuemask 'depth 'width 'x_hotspot 'y_hotspot 'cpp 'npixels 'ncolors))))
+ (XDestroyImage i11)))
+
+ (XFreePixmap dpy pix)
+ (XVisualIDFromVisual vis)
+ (XGrabServer dpy)
+ (XUngrabServer dpy)
+ (XGrabPointer dpy win #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None) (list 'Time CurrentTime))
+ (XUngrabPointer dpy (list 'Time CurrentTime))
+ (XGrabKeyboard dpy win #t GrabModeSync GrabModeSync (list 'Time CurrentTime))
+ (XUngrabKeyboard dpy (list 'Time CurrentTime))
+ (XGrabKey dpy AnyKey AnyModifier win #t GrabModeSync GrabModeSync)
+ (XUngrabKey dpy AnyKey AnyModifier win)
+ (XGrabButton dpy AnyButton AnyModifier win #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None))
+ (XUngrabButton dpy AnyButton AnyModifier win)
+ (XtGrabPointer shell #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None) (list 'Time CurrentTime))
+ (XtUngrabPointer shell (list 'Time CurrentTime))
+ (XtGrabKeyboard shell #t GrabModeSync GrabModeSync (list 'Time CurrentTime))
+ (XtUngrabKeyboard shell (list 'Time CurrentTime))
+ (XtGrabKey shell (list 'KeyCode AnyKey) AnyModifier #t GrabModeSync GrabModeSync)
+ (XtUngrabKey shell (list 'KeyCode AnyKey) AnyModifier)
+ (XtGrabButton shell AnyButton AnyModifier #t ButtonPressMask GrabModeSync GrabModeSync (list 'Window None) (list 'Cursor None))
+ (XtUngrabButton shell AnyButton AnyModifier))
(let* ((sgc (car (snd-gcs)))
(grf1 (car (channel-widgets)))
@@ -45398,41 +44556,41 @@ EDITS: 1
(shl (cadr (main-widgets))))
(let ((wid (XtWindowToWidget dpy win)))
(if (not (equal? wid grf1))
- (snd-display #__line__ ";XtWindowToWidget: ~A ~A" grf1 win)))
+ (snd-display ";XtWindowToWidget: ~A ~A" grf1 win)))
; these are causing: X Error of failed request: BadAccess (attempt to access private resource denied)
; (if (not (equal? (XGetTransientForHint dpy win) (list 0 #f)))
- ; (snd-display #__line__ ";XGetTransientForHint: ~A" (XGetTransientForHint dpy win)))
+ ; (snd-display ";XGetTransientForHint: ~A" (XGetTransientForHint dpy win)))
(if (not (equal? (XGetErrorText dpy BadColor #f 9) (list 0 "BadColor")))
- (snd-display #__line__ ";XGetErrorText: ~A" (XGetErrorText dpy BadColor #f 9)))
+ (snd-display ";XGetErrorText: ~A" (XGetErrorText dpy BadColor #f 9)))
(if (not (equal? (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2) (list 12 10 10 500 400)))
- (snd-display #__line__ ";XGeometry: ~A" (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2)))
+ (snd-display ";XGeometry: ~A" (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2)))
(if (< (XEventsQueued dpy QueuedAlready) 0)
- (snd-display #__line__ ";XEventsQueued: ~A" (XEventsQueued dpy QueuedAlready)))
+ (snd-display ";XEventsQueued: ~A" (XEventsQueued dpy QueuedAlready)))
; (let ((coords (XTranslateCoordinates dpy (XtWindow shl) win 10 10)))
; (if (not (car coords))
- ; (snd-display #__line__ ";XTranslateCoordinates: ~A" coords)))
+ ; (snd-display ";XTranslateCoordinates: ~A" coords)))
(let ((coords (XtTranslateCoords shl 10 10)))
(if (not (number? (car coords)))
- (snd-display #__line__ ";XtTranslateCoords: ~A" coords)))
- (if (not (XmIsVendorShell shl)) (snd-display #__line__ ";XmIsVendorShell?"))
- (if (XmIsPrimitive shl) (snd-display #__line__ ";XmIsPrimitive?"))
- (if (XmIsManager shl) (snd-display #__line__ ";XmIsManager?"))
- (if (XmIsIconGadget shl) (snd-display #__line__ ";XmIsIconGadget?"))
- (if (XmIsGadget shl) (snd-display #__line__ ";XmIsGadget?"))
- (if (XmIsIconHeader shl) (snd-display #__line__ ";XmIsHeader?"))
- (if (XmIsDropTransfer shl) (snd-display #__line__ ";XmIsDropTransfer?"))
- (if (XmIsDropSiteManager shl) (snd-display #__line__ ";XmIsDropSiteManager?"))
- (if (XmIsDragContext shl) (snd-display #__line__ ";XmIsDragContext?"))
- (if (XmIsDragIconObjectClass shl) (snd-display #__line__ ";XmIsDragIconObjectClass?"))
- (if (XmIsMessageBox shl) (snd-display #__line__ ";XmIsMessageBox?"))
- (if (XmIsScreen shl) (snd-display #__line__ ";XmIsScreen?"))
- (if (XmIsDisplay shl) (snd-display #__line__ ";XmIsDisplay?"))
+ (snd-display ";XtTranslateCoords: ~A" coords)))
+ (if (not (XmIsVendorShell shl)) (snd-display ";XmIsVendorShell?"))
+ (if (XmIsPrimitive shl) (snd-display ";XmIsPrimitive?"))
+ (if (XmIsManager shl) (snd-display ";XmIsManager?"))
+ (if (XmIsIconGadget shl) (snd-display ";XmIsIconGadget?"))
+ (if (XmIsGadget shl) (snd-display ";XmIsGadget?"))
+ (if (XmIsIconHeader shl) (snd-display ";XmIsHeader?"))
+ (if (XmIsDropTransfer shl) (snd-display ";XmIsDropTransfer?"))
+ (if (XmIsDropSiteManager shl) (snd-display ";XmIsDropSiteManager?"))
+ (if (XmIsDragContext shl) (snd-display ";XmIsDragContext?"))
+ (if (XmIsDragIconObjectClass shl) (snd-display ";XmIsDragIconObjectClass?"))
+ (if (XmIsMessageBox shl) (snd-display ";XmIsMessageBox?"))
+ (if (XmIsScreen shl) (snd-display ";XmIsScreen?"))
+ (if (XmIsDisplay shl) (snd-display ";XmIsDisplay?"))
(let ((val 0))
(XSetErrorHandler (lambda (dpy e)
(set! val (.error_code e))))
(XGetAtomName dpy '(Atom 0))
- (if (not (= val 5)) (snd-display #__line__ ";XSetErrorHandler: ~A" val)))
+ (if (not (= val 5)) (snd-display ";XSetErrorHandler: ~A" val)))
(XDrawImageString dpy win sgc 10 10 "hiho" 4)
(XDrawRectangle dpy win sgc 0 0 10 10)
@@ -45463,11 +44621,11 @@ EDITS: 1
(let ((descr (XtAddCallback button XmNactivateCallback call1 #f)))
(XtCallCallbacks button XmNactivateCallback #f)
(if (not (= val1 1))
- (snd-display #__line__ ";XtCallCallbacks val1: ~A" val1))
+ (snd-display ";XtCallCallbacks val1: ~A" val1))
(XtRemoveCallback button XmNactivateCallback descr)
(let ((calls (XtHasCallbacks button XmNactivateCallback)))
(if (not (= calls XtCallbackHasNone))
- (snd-display #__line__ ";XtRemoveCallbacks: ~A" calls))))
+ (snd-display ";XtRemoveCallbacks: ~A" calls))))
(XtUnmanageChild button)
;(XtDestroyWidget button)
)
@@ -45482,12 +44640,12 @@ EDITS: 1
(let ((descr1 (XtAddCallback button XmNactivateCallback call1 #f))
(descr2 (XtAddCallback button XmNactivateCallback call2 #f)))
(XtCallCallbacks button XmNactivateCallback #f)
- (if (and (not (= val1 1)) (not (= val2 1)))
- (snd-display #__line__ ";XtCallCallbacks val12: ~A ~A" val1 val2))
+ (if (not (or (= val1 1) (= val2 1)))
+ (snd-display ";XtCallCallbacks val12: ~A ~A" val1 val2))
(XtRemoveCallbacks button XmNactivateCallback (list descr1 descr2))
(let ((calls (XtHasCallbacks button XmNactivateCallback)))
(if (not (= calls XtCallbackHasNone))
- (snd-display #__line__ ";XtRemoveCallbacks: ~A" calls))))
+ (snd-display ";XtRemoveCallbacks: ~A" calls))))
(XtUnmanageChild button)
;(XtDestroyWidget button)
)
@@ -45501,12 +44659,12 @@ EDITS: 1
(set! val2 (+ 1 val2)))
(let ((descrs (XtAddCallbacks button XmNactivateCallback (list (list call1 #f) (list call2 #f)))))
(XtCallCallbacks button XmNactivateCallback #f)
- (if (and (not (= val1 1)) (not (= val2 1)))
- (snd-display #__line__ ";XtCallCallbacks add val12: ~A ~A" val1 val2))
+ (if (not (or (= val1 1) (= val2 1)))
+ (snd-display ";XtCallCallbacks add val12: ~A ~A" val1 val2))
(XtRemoveCallbacks button XmNactivateCallback descrs)
(let ((calls (XtHasCallbacks button XmNactivateCallback)))
(if (not (= calls XtCallbackHasNone))
- (snd-display #__line__ ";XtRemoveCallbacks (add): ~A" calls))))
+ (snd-display ";XtRemoveCallbacks (add): ~A" calls))))
(XtUnmanageChild button)
;(XtDestroyWidget button)
)
@@ -45541,62 +44699,62 @@ EDITS: 1
XmNlistMarginWidth 0 XmNlistSizePolicy 0 XmNlistSpacing 0 XmNmatchBehavior 0
XmNprimaryOwnership 0 XmNscrollBarDisplayPolicy 0 XmNselectColor 0 XmNselectionMode 0
XmNselectionPolicy 0 XmNhorizontalScrollBar 0 XmNselectedItemCount 0 XmNtopItemPosition 0))))
- (if (not (= (vals 1) XmNO_AUTO_SELECT)) (snd-display #__line__ ";XmNautomaticSelection: ~A" (vals 1)))
- (if (not (= (vals 3) 100)) (snd-display #__line__ ";XmNdoubleClickInterval: ~A" (vals 3)))
- (if (not (= (vals 5) 3)) (snd-display #__line__ ";XmNitemCount: ~A" (vals 5)))
- (if (or (null? (vals 7)) (not (XmString? (car (vals 7))))) (snd-display #__line__ ";XmNitems: ~A" (vals 7)))
- (if (not (= (vals 9) 4)) (snd-display #__line__ ";XmNlistMarginHeight: ~A" (vals 9)))
- (if (not (= (vals 11) 1)) (snd-display #__line__ ";XmNlistMarginWidth: ~A" (vals 11)))
- (if (not (= (vals 13) XmVARIABLE)) (snd-display #__line__ ";XmNlistSizePolicy: ~A" (vals 13)))
- (if (not (= (vals 15) 2)) (snd-display #__line__ ";XmNlistSpacing: ~A" (vals 15)))
- (if (not (= (vals 17) XmQUICK_NAVIGATE)) (snd-display #__line__ ";XmNmatchBehavior: ~A" (vals 17)))
- (if (not (= (vals 19) XmOWN_NEVER)) (snd-display #__line__ ";XmNprimaryOwnership : ~A" (vals 19)))
- (if (not (= (vals 21) XmAS_NEEDED)) (snd-display #__line__ ";XmNscrollBarDisplayPolicy: ~A" (vals 21)))
- (if (not (Pixel? (vals 23))) (snd-display #__line__ ";XmNselectColor: ~A" (vals 23)))
- (if (not (= (vals 25) XmNORMAL_MODE)) (snd-display #__line__ ";XmNselectionMode: ~A" (vals 25)))
- (if (not (= (vals 27) XmBROWSE_SELECT)) (snd-display #__line__ ";XmNselectionPolicy: ~A" (vals 27)))
- (if (vals 29) (snd-display #__line__ ";XmNhorizontalScrollBar: ~A" (vals 29)))
- (if (not (= (vals 31) 0)) (snd-display #__line__ ";XmNselectedItemCount : ~A" (vals 31)))
- (if (not (= (vals 33) 1)) (snd-display #__line__ ";XmNtopItemPosition: ~A" (vals 33)))
+ (if (not (= (vals 1) XmNO_AUTO_SELECT)) (snd-display ";XmNautomaticSelection: ~A" (vals 1)))
+ (if (not (= (vals 3) 100)) (snd-display ";XmNdoubleClickInterval: ~A" (vals 3)))
+ (if (not (= (vals 5) 3)) (snd-display ";XmNitemCount: ~A" (vals 5)))
+ (if (or (null? (vals 7)) (not (XmString? (car (vals 7))))) (snd-display ";XmNitems: ~A" (vals 7)))
+ (if (not (= (vals 9) 4)) (snd-display ";XmNlistMarginHeight: ~A" (vals 9)))
+ (if (not (= (vals 11) 1)) (snd-display ";XmNlistMarginWidth: ~A" (vals 11)))
+ (if (not (= (vals 13) XmVARIABLE)) (snd-display ";XmNlistSizePolicy: ~A" (vals 13)))
+ (if (not (= (vals 15) 2)) (snd-display ";XmNlistSpacing: ~A" (vals 15)))
+ (if (not (= (vals 17) XmQUICK_NAVIGATE)) (snd-display ";XmNmatchBehavior: ~A" (vals 17)))
+ (if (not (= (vals 19) XmOWN_NEVER)) (snd-display ";XmNprimaryOwnership : ~A" (vals 19)))
+ (if (not (= (vals 21) XmAS_NEEDED)) (snd-display ";XmNscrollBarDisplayPolicy: ~A" (vals 21)))
+ (if (not (Pixel? (vals 23))) (snd-display ";XmNselectColor: ~A" (vals 23)))
+ (if (not (= (vals 25) XmNORMAL_MODE)) (snd-display ";XmNselectionMode: ~A" (vals 25)))
+ (if (not (= (vals 27) XmBROWSE_SELECT)) (snd-display ";XmNselectionPolicy: ~A" (vals 27)))
+ (if (vals 29) (snd-display ";XmNhorizontalScrollBar: ~A" (vals 29)))
+ (if (not (= (vals 31) 0)) (snd-display ";XmNselectedItemCount : ~A" (vals 31)))
+ (if (not (= (vals 33) 1)) (snd-display ";XmNtopItemPosition: ~A" (vals 33)))
(let ((tag (catch #t
(lambda ()
(XmListAddItem frm (XmStringCreate "four" XmFONTLIST_DEFAULT_TAG) 0))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";list type check: ~A" tag)))
+ (snd-display ";list type check: ~A" tag)))
(XmListAddItem lst (XmStringCreate "four" XmFONTLIST_DEFAULT_TAG) 0) ; 0 -> last position
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 4)) (snd-display #__line__ ";XmAddItem len: ~A" (vals 1)))
+ (if (not (= (vals 1) 4)) (snd-display ";XmAddItem len: ~A" (vals 1)))
(XmListAddItems lst (list (XmStringCreateLocalized "five") (XmStringCreateLocalized "six")) 2 0)
(let ((tag (catch #t
(lambda () (XmListAddItems lst (list (XmStringCreateLocalized "seven") 123) 2 0))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";xstrings->list add: ~A" tag)))
+ (snd-display ";xstrings->list add: ~A" tag)))
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 6)) (snd-display #__line__ ";XmAddItems len: ~A" (vals 1)))
+ (if (not (= (vals 1) 6)) (snd-display ";XmAddItems len: ~A" (vals 1)))
(XmListDeletePos lst 1)
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 5)) (snd-display #__line__ ";XmListDeletePos len: ~A" (vals 1)))
+ (if (not (= (vals 1) 5)) (snd-display ";XmListDeletePos len: ~A" (vals 1)))
(XmListDeletePositions lst (list 2 4))
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 3)) (snd-display #__line__ ";XmListDeletePositions len: ~A" (vals 1)))
+ (if (not (= (vals 1) 3)) (snd-display ";XmListDeletePositions len: ~A" (vals 1)))
(XmListAddItemUnselected lst (XmStringCreate "seven" XmFONTLIST_DEFAULT_TAG) 0) ; 0 -> last position
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 4)) (snd-display #__line__ ";XmListAddItemUnselected len: ~A" (vals 1)))
+ (if (not (= (vals 1) 4)) (snd-display ";XmListAddItemUnselected len: ~A" (vals 1)))
(XmListAddItemsUnselected lst (list (XmStringCreateLocalized "eight") (XmStringCreateLocalized "nine")) 2 0)
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 6)) (snd-display #__line__ ";XmListAddItemsUnselected len: ~A" (vals 1)))
+ (if (not (= (vals 1) 6)) (snd-display ";XmListAddItemsUnselected len: ~A" (vals 1)))
(XmListDeleteAllItems lst)
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 0)) (snd-display #__line__ ";XmListDeleteAllItems len: ~A" (vals 1)))
+ (if (not (= (vals 1) 0)) (snd-display ";XmListDeleteAllItems len: ~A" (vals 1)))
(if (pair? (vals 3))
- (snd-display #__line__ ";deleted all items: ~A" (vals 3)))
+ (snd-display ";deleted all items: ~A" (vals 3)))
(let ((item1 (XmStringCreate "one" XmFONTLIST_DEFAULT_TAG))
(item2 (XmStringCreate "two" XmFONTLIST_DEFAULT_TAG))
@@ -45607,45 +44765,45 @@ EDITS: 1
(list XmNitemCount 5
XmNitems (list item1 item2 item3 item4 item5)))
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 5)) (snd-display #__line__ ";Xt set items len: ~A" (vals 1)))
+ (if (not (= (vals 1) 5)) (snd-display ";Xt set items len: ~A" (vals 1)))
(XmListSelectItem lst item3 #t)
- (if (not (= browsed 123)) (snd-display #__line__ ";XmListSelectItem callback: ~A" browsed))
- (if (XmListPosSelected lst 1) (snd-display #__line__ ";XmList selected pos 1?"))
- (if (not (XmListPosSelected lst 3)) (snd-display #__line__ ";XmList didn't select pos 3?"))
+ (if (not (= browsed 123)) (snd-display ";XmListSelectItem callback: ~A" browsed))
+ (if (XmListPosSelected lst 1) (snd-display ";XmList selected pos 1?"))
+ (if (not (XmListPosSelected lst 3)) (snd-display ";XmList didn't select pos 3?"))
(set! vals (XtVaGetValues lst (list XmNselectedItemCount 0 XmNselectedItems 0)))
- (if (not (= (vals 1) 1)) (snd-display #__line__ ";selected count: ~A" (vals 1)))
+ (if (not (= (vals 1) 1)) (snd-display ";selected count: ~A" (vals 1)))
(set! vals (XmListGetSelectedPos lst))
- (if (not (= (length vals) 1)) (snd-display #__line__ ";XmListGetSelectedPos: ~A" vals))
- (if (not (= (car vals) 3)) (snd-display #__line__ ";XmListGetSelectedPos: ~A" vals))
+ (if (not (and (pair? vals) (null? (cdr vals))))
+ (snd-display ";XmListGetSelectedPos: ~A" vals))
+ (if (not (= (car vals) 3)) (snd-display ";XmListGetSelectedPos: ~A" vals))
(set! browsed 0)
(XmListSelectPos lst 1 #f)
- (if (not (= browsed 0)) (snd-display #__line__ ";XmListSelectPos callback: ~A" browsed))
- (if (not (XmListPosSelected lst 1)) (snd-display #__line__ ";XmList select pos?"))
- (if (not (= (XmListItemPos lst item3) 3)) (snd-display #__line__ ";XmListItemPos: ~A" (XmListItemPos lst item3)))
- (if (not (= (car (XmListGetMatchPos lst item3)) 3)) (snd-display #__line__ ";XmListGetMatchPos: ~A" (XmListGetMatchPos lst item3)))
- (if (not (XmListItemExists lst item3)) (snd-display #__line__ ";XmListItemExists?"))
+ (if (not (= browsed 0)) (snd-display ";XmListSelectPos callback: ~A" browsed))
+ (if (not (XmListPosSelected lst 1)) (snd-display ";XmList select pos?"))
+ (if (not (= (XmListItemPos lst item3) 3)) (snd-display ";XmListItemPos: ~A" (XmListItemPos lst item3)))
+ (if (not (= (car (XmListGetMatchPos lst item3)) 3)) (snd-display ";XmListGetMatchPos: ~A" (XmListGetMatchPos lst item3)))
+ (if (not (XmListItemExists lst item3)) (snd-display ";XmListItemExists?"))
- (if (not (= (XmListYToPos lst 40) 2)) (snd-display #__line__ ";XmListYToPos: ~A" (XmListYToPos lst 40)))
+ (if (not (= (XmListYToPos lst 40) 2)) (snd-display ";XmListYToPos: ~A" (XmListYToPos lst 40)))
(let ((box (XmListPosToBounds lst 2)))
- (if (and (not (= (cadr box) 3))
- (not (= (cadr box) 2)))
- (snd-display #__line__ ";XmListPosToBounds: ~A" box)))
+ (if (not (memv (cadr box) '(3 2)))
+ (snd-display ";XmListPosToBounds: ~A" box)))
(XmListDeselectPos lst 1)
- (if (XmListPosSelected lst 1) (snd-display #__line__ ";XmList deselected pos?"))
+ (if (XmListPosSelected lst 1) (snd-display ";XmList deselected pos?"))
(XmListSelectItem lst item3 #t)
(XmListDeselectAllItems lst)
- (if (XmListPosSelected lst 3) (snd-display #__line__ ";XmList deselect all pos?"))
+ (if (XmListPosSelected lst 3) (snd-display ";XmList deselect all pos?"))
(XmListSelectItem lst item3 #f)
(XmListDeselectItem lst item3)
- (if (XmListPosSelected lst 3) (snd-display #__line__ ";XmList deselect item?"))
+ (if (XmListPosSelected lst 3) (snd-display ";XmList deselect item?"))
(XmListDeleteItem lst item2)
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 4)) (snd-display #__line__ ";XmDeleteItem len: ~A" (vals 1)))
+ (if (not (= (vals 1) 4)) (snd-display ";XmDeleteItem len: ~A" (vals 1)))
(XmListDeleteItems lst (list item1 item4))
(set! vals (XtGetValues lst (list XmNitemCount 0 XmNitems 0)))
- (if (not (= (vals 1) 2)) (snd-display #__line__ ";XmDeleteItems len: ~A" (vals 1)))
+ (if (not (= (vals 1) 2)) (snd-display ";XmDeleteItems len: ~A" (vals 1)))
(XmListDeleteAllItems lst)
(XtVaSetValues lst
(list XmNitemCount 5
@@ -45665,7 +44823,7 @@ EDITS: 1
XmNdestinationCallback
(list (lambda (w c i)
(set! (calls c) "dest")
- (if (< (.location_data i) 0) (snd-display #__line__ ";location_data: ~A" (.location_data i))))
+ (if (< (.location_data i) 0) (snd-display ";location_data: ~A" (.location_data i))))
1)
XmNactivateCallback (list (lambda (w c i) (set! (calls c) "act")) 2)
XmNfocusCallback (list (lambda (w c i) (set! (calls c) "focus")) 3)
@@ -45675,11 +44833,11 @@ EDITS: 1
XmNmodifyVerifyCallback
(list (lambda (w c i)
(set! (calls c) "modify")
- (if (< (.currInsert i) 0) (snd-display #__line__ ";currInsert: ~A" (.currInsert i)))
- (if (< (.newInsert i) 0) (snd-display #__line__ ";newInsert: ~A" (.newInsert i)))
- (if (string? (.doit i)) (snd-display #__line__ ";doit: ~A" (.doit i)))
- (if (< (.startPos i) 0) (snd-display #__line__ ";startPos: ~A" (.startPos i)))
- (if (< (.endPos i) 0) (snd-display #__line__ ";endPos: ~A" (.endPos i))))
+ (if (< (.currInsert i) 0) (snd-display ";currInsert: ~A" (.currInsert i)))
+ (if (< (.newInsert i) 0) (snd-display ";newInsert: ~A" (.newInsert i)))
+ (if (string? (.doit i)) (snd-display ";doit: ~A" (.doit i)))
+ (if (< (.startPos i) 0) (snd-display ";startPos: ~A" (.startPos i)))
+ (if (< (.endPos i) 0) (snd-display ";endPos: ~A" (.endPos i))))
7)
XmNmotionVerifyCallback (list (lambda (w c i) (set! (calls c) "motion")) 8)
XmNvalueChangedCallback (list (lambda (w c i) (set! (calls c) "value")) 9)))))
@@ -45715,14 +44873,14 @@ EDITS: 1
XmNbottomAttachment XmATTACH_FORM))))
(let ((vals (XtVaGetValues txt (list XmNrenderTable 0 XmNselectionArray 0))))
- (if (not (XmRenderTable? (vals 1))) (snd-display #__line__ ";XmNrenderTable: ~A" (vals 1)))
- (if (not (pair? (vals 3))) (snd-display #__line__ ";XmNselectionArray: ~A" (vals 3))))
- (if (not (XmTextGetEditable txt)) (snd-display #__line__ ";XmTextGetEditable?"))
- (if (not (XmTextFieldGetEditable txtf)) (snd-display #__line__ ";XmTextFieldGetEditable?"))
+ (if (not (XmRenderTable? (vals 1))) (snd-display ";XmNrenderTable: ~A" (vals 1)))
+ (if (not (pair? (vals 3))) (snd-display ";XmNselectionArray: ~A" (vals 3))))
+ (if (not (XmTextGetEditable txt)) (snd-display ";XmTextGetEditable?"))
+ (if (not (XmTextFieldGetEditable txtf)) (snd-display ";XmTextFieldGetEditable?"))
(XmTextSetEditable txt #f)
(XmTextFieldSetEditable txtf #f)
- (if (XmTextGetEditable txt) (snd-display #__line__ ";XmTextSetEditable?"))
- (if (XmTextFieldGetEditable txtf) (snd-display #__line__ ";XmTextFieldSetEditable?"))
+ (if (XmTextGetEditable txt) (snd-display ";XmTextSetEditable?"))
+ (if (XmTextFieldGetEditable txtf) (snd-display ";XmTextFieldSetEditable?"))
(XmTextSetEditable txt #t)
(XmTextFieldSetEditable txtf #t)
(XmTextSetString txt "0123456789")
@@ -45732,163 +44890,163 @@ EDITS: 1
(valf (XmTextFieldGetString txtf))
(val1 (cadr (XtVaGetValues txt (list XmNvalue 0))))
(val1f (cadr (XtVaGetValues txtf (list XmNvalue 0)))))
- (if (not (string=? val "0123456789")) (snd-display #__line__ ";XmTextSetString: ~A" val))
- (if (not (string=? valf "0123456789")) (snd-display #__line__ ";XmTextFieldSetString: ~A" valf))
- (if (not (string=? val1 "0123456789")) (snd-display #__line__ ";text value: ~A" val1))
- (if (not (string=? val1f "0123456789")) (snd-display #__line__ ";text field value: ~A" val)))
- (let ((untext (XtCreateWidget "untext" xmTextWidgetClass frm ()))
- (source (XmTextGetSource txt)))
- (XmTextSetSource untext source 0 3)
- (if (not (XmTextSource? source))
- (snd-display #__line__ ";XmTextSource? ~A" source))
- (if (not (equal? (XmTextGetSource untext) source))
- (snd-display #__line__ ";XmTextSetSource: ~A ~A" source (XmTextGetSource untext)))
+ (if (not (string=? val "0123456789")) (snd-display ";XmTextSetString: ~A" val))
+ (if (not (string=? valf "0123456789")) (snd-display ";XmTextFieldSetString: ~A" valf))
+ (if (not (string=? val1 "0123456789")) (snd-display ";text value: ~A" val1))
+ (if (not (string=? val1f "0123456789")) (snd-display ";text field value: ~A" val)))
+ (let ((untext (XtCreateWidget "untext" xmTextWidgetClass frm ())))
+ (let ((source (XmTextGetSource txt)))
+ (XmTextSetSource untext source 0 3)
+ (if (not (XmTextSource? source))
+ (snd-display ";XmTextSource? ~A" source))
+ (if (not (equal? (XmTextGetSource untext) source))
+ (snd-display ";XmTextSetSource: ~A ~A" source (XmTextGetSource untext))))
(if (XtIsSubclass untext xmFormWidgetClass)
- (snd-display #__line__ ";XtIsSubclass thinks untext is a form?"))
+ (snd-display ";XtIsSubclass thinks untext is a form?"))
(if (not (XtIsSubclass untext coreWidgetClass))
- (snd-display #__line__ ";XtIsSubclass thinks untext is not a core widget"))
+ (snd-display ";XtIsSubclass thinks untext is not a core widget"))
(XmTextCopyLink untext (list 'Time CurrentTime))
(XmTextPasteLink untext))
(let ((val (XmTextGetSubstring txt 2 3))
(valf (XmTextFieldGetSubstring txtf 2 3)))
- (if (or (not (string? val)) (not (string=? val "234"))) (snd-display #__line__ ";XmTextGetSubstring: ~A" val))
- (if (or (not (string? valf)) (not (string=? valf "234"))) (snd-display #__line__ ";XmTextFieldGetSubstring: ~A" valf)))
+ (if (not (equal? val "234")) (snd-display ";XmTextGetSubstring: ~A" val))
+ (if (not (equal? valf "234")) (snd-display ";XmTextFieldGetSubstring: ~A" valf)))
(XmTextSetSelection txt 2 5 current-time)
(let ((val (XmTextGetSelection txt)))
- (if (or (not (string? val)) (not (string=? val "234"))) (snd-display #__line__ ";XmTextGetSelection: ~A" val)))
+ (if (not (equal? val "234")) (snd-display ";XmTextGetSelection: ~A" val)))
(XmTextClearSelection txt current-time)
(let ((val (XmTextGetSelection txt)))
- (if val (snd-display #__line__ ";XmTextClearSelection: ~A" val)))
+ (if val (snd-display ";XmTextClearSelection: ~A" val)))
(XmTextFieldSetSelection txtf 2 5 current-time)
(let ((tag (catch #t
(lambda ()
(XmTextFieldSetSelection txt 2 3 current-time))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";text field type check: ~A" tag)))
+ (snd-display ";text field type check: ~A" tag)))
(let ((tag (catch #t
(lambda ()
(XmTextSetSelection frm 2 3 current-time))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";text type check: ~A" tag)))
+ (snd-display ";text type check: ~A" tag)))
(let ((dpy (XtDisplay (cadr (main-widgets))))
- (win (XtWindow (cadr (main-widgets))))
- (app (car (main-widgets))))
+ (win (XtWindow (cadr (main-widgets)))))
+ (let* ((app (car (main-widgets)))
+ (tag (catch #t (lambda () (XtDisplayInitialize app dpy "hi" "ho" 1 1)) (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtDisplayInitialize type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmTransferSetParameters 123 123 123 123 "hiho")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmTransferSetParameters type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmTransferSetParameters type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmDropSiteConfigureStackingOrder txtf txtf "hiho")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmDropSiteConfigureStackingOrder type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmDropSiteConfigureStackingOrder type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmScrollVisible txtf txtf 5 "hiho")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmScrollVisible type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmScrollVisible type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmDragStart txtf (XEvent KeyPress) (list 0 1) "hiho")) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmDragStart type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmDragStart type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmClipboardStartRetrieve dpy win 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmClipboardStartRetrieve type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmClipboardStartRetrieve type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmClipboardCopyByName dpy win 1 "hi" "hi" 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmClipboardCopyByName type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmClipboardCopyByName type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmClipboardBeginCopy dpy win "hi" txtf #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmClipboardBeginCopy type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmClipboardBeginCopy type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmRemoveProtocolCallback txtf XA_STRING XA_STRING #f 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmRemoveProtocolCallback type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmRemoveProtocolCallback type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetRGBColormaps dpy win (list 'XStandardColormap 0) 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetRGBColormap type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetRGBColormap type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetWMHints dpy win 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetWMHints type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetWMHints type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XWindowEvent dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XWindowEvent type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XWindowEvent type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XStoreNamedColor dpy (list 'Colormap 0) "hi" 0 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XStoreNamedColor type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XStoreNamedColor type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XStoreColors dpy (list 'Colormap 0) (list 1 2) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XStoreColors type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XStoreColors type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XStoreColor dpy (list 'Colormap 0) (list 1 2))) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XStoreColor type check: ~A" tag)))
- (let ((tag (catch #t (lambda () (XtDisplayInitialize app dpy "hi" "ho" 1 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtDisplayInitialize type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XStoreColor type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtOwnSelectionIncremental txtf '(Atom 0) '(Time 0) #f #f #f #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtOwnSelectionIncremental type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtOwnSelectionIncremental type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtOwnSelection txtf '(Atom 0) '(Time 0) #f #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtOwnSelection type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtOwnSelection type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtGetSelectionValue txtf '(Atom 0) '(Atom 0) #f #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtGetSelectionValue type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtGetSelectionValue type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtGetSelectionValues txtf '(Atom 0) (list (list 'Atom 0)) #f #f #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtGetSelectionValues type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtGetSelectionValues type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtDisownSelection txtf '(Atom 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtDisownSelection type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtDisownSelection type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtGetSelectionRequest txtf '(Atom 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtGetSelectionRequest type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtGetSelectionRequest type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtGetSelectionValueIncremental txtf '(Atom 0) (list (list 'Atom 0)) 1 #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtGetSelectionValueIncremental type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtGetSelectionValueIncremental type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtGetSelectionValuesIncremental txtf '(Atom 0) '(Atom 0) 1 #f #f #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtGetSelectionValuesIncremental type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtGetSelectionValuesIncremental type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XtSendSelectionRequest txtf '(Atom 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XtSendSelectionRequest type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtSendSelectionRequest type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XReconfigureWMWindow dpy win 1 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XReconfigureWMWindow type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XReconfigureWMWindow type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetWMProtocols dpy win 1 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetWMProtocols type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetWMProtocols type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XIconifyWindow dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XIconifyWindow type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XIconifyWindow type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XWithdrawWindow dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XWithdrawWindow type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XWithdrawWindow type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetWMColormapWindows dpy win #f 1)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetWMColormapWindows type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetWMColormapWindows type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetTransientForHint dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetTransientForHint type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetTransientForHint type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XAllowEvents dpy 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XAllowEvents type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XAllowEvents type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XChangeActivePointerGrab dpy 1 '(Cursor 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XChangeActivePointerGrab type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XChangeActivePointerGrab type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XChangeGC dpy '(GC 0) 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XChangeGC type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XChangeGC type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XChangeKeyboardMapping dpy 1 1 (list 1 1) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XChangeKeyboardMapping type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XChangeKeyboardMapping type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XConfigureWindow dpy win 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XConfigureWindow type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XConfigureWindow type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XConvertSelection dpy '(Atom 0) '(Atom 0) '(Atom 0) win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XConvertSelection type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XConvertSelection type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XReparentWindow dpy win win 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XReparentWindow type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XReparentWindow type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XFreeColors dpy '(Colormap 0) (list 0) 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XFreeColors type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XFreeColors type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XReadBitmapFile dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XReadBitmapFile type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XReadBitmapFile type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XRebindKeysym dpy '(KeySym 0) (list 0) 1 "hi" #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XRebindKeysym type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XRebindKeysym type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XRestackWindows dpy (list 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XRestackWindows type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XRestackWindows type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XRotateWindowProperties dpy win (list 0) 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XRotateWindowProperties type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XRotateWindowProperties type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSelectInput dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSelectInput type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSelectInput type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetFontPath dpy (list 0) #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetFontPath type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetFontPath type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetInputFocus dpy win 1 #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetInputFocus type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetInputFocus type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetSelectionOwner dpy '(Atom 0) win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetSelectionOwner type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetSelectionOwner type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XSetWindowColormap dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XSetWindowColormap type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XSetWindowColormap type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmClipboardCancelCopy dpy win #f)) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display #__line__ ";XmClipboardCancelCopy type check: ~A" tag)))
+ (if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmClipboardCancelCopy type check: ~A" tag)))
)
(let ((valf (XmTextFieldGetSelection txtf)))
- (if (not (string=? valf "234")) (snd-display #__line__ ";XmTextFieldGetSelection: ~A" valf)))
+ (if (not (string=? valf "234")) (snd-display ";XmTextFieldGetSelection: ~A" valf)))
(XmTextFieldClearSelection txtf current-time)
(let ((valf (XmTextFieldGetSelection txtf)))
- (if valf (snd-display #__line__ ";XmTextFieldClearSelection: ~A" valf)))
+ (if valf (snd-display ";XmTextFieldClearSelection: ~A" valf)))
(let ((val (XmTextGetInsertionPosition txt))
(valf (XmTextFieldGetInsertionPosition txtf)))
- (if (not (= val 5)) (snd-display #__line__ ";XmTextGetInsertionPosition: ~A" val))
- (if (not (= valf 5)) (snd-display #__line__ ";XmTextFieldGetInsertionPosition: ~A" val)))
+ (if (not (= val 5)) (snd-display ";XmTextGetInsertionPosition: ~A" val))
+ (if (not (= valf 5)) (snd-display ";XmTextFieldGetInsertionPosition: ~A" val)))
(XmTextScroll txt 1)
(XmTextScroll txt -1)
(let ((pos (XmTextGetTopCharacter txt)))
- (if (not (= pos 0)) (snd-display #__line__ ";XmTextGetTopCharacter after scroll: ~A" pos)))
+ (if (not (= pos 0)) (snd-display ";XmTextGetTopCharacter after scroll: ~A" pos)))
(XmTextShowPosition txt 0)
(XmTextFieldShowPosition txtf 0)
(XmTextSetTopCharacter txt 0)
@@ -45899,14 +45057,14 @@ EDITS: 1
(XmTextFieldSetHighlight txtf 3 6 XmHIGHLIGHT_SELECTED)
(XmTextFieldGetBaseline txtf)
(XmTextSetAddMode txt #t)
- (if (not (XmTextGetAddMode txt)) (snd-display #__line__ ";XmTextSetAddMode?"))
+ (if (not (XmTextGetAddMode txt)) (snd-display ";XmTextSetAddMode?"))
(XmTextFieldSetAddMode txtf #t)
- (if (not (XmTextFieldGetAddMode txtf)) (snd-display #__line__ ";XmTextFieldSetAddMode?"))
+ (if (not (XmTextFieldGetAddMode txtf)) (snd-display ";XmTextFieldSetAddMode?"))
- (if (not (string=? (vector-ref calls 5) "gain")) (snd-display #__line__ ";gain callback: ~A" (vector-ref calls 5)))
- (if (not (string=? (vector-ref calls 7) "modify")) (snd-display #__line__ ";modify callback: ~A" (vector-ref calls 7)))
- (if (not (string=? (vector-ref calls 8) "motion")) (snd-display #__line__ ";motion callback: ~A" (vector-ref calls 8)))
- (if (not (string=? (vector-ref calls 9) "value")) (snd-display #__line__ ";value callback: ~A" (vector-ref calls 9)))
+ (if (not (string=? (vector-ref calls 5) "gain")) (snd-display ";gain callback: ~A" (vector-ref calls 5)))
+ (if (not (string=? (vector-ref calls 7) "modify")) (snd-display ";modify callback: ~A" (vector-ref calls 7)))
+ (if (not (string=? (vector-ref calls 8) "motion")) (snd-display ";motion callback: ~A" (vector-ref calls 8)))
+ (if (not (string=? (vector-ref calls 9) "value")) (snd-display ";value callback: ~A" (vector-ref calls 9)))
(let ((txtf1 (XtVaCreateManagedWidget "textfield" xmTextFieldWidgetClass frm
(list XmNeditable #t
@@ -45928,10 +45086,10 @@ EDITS: 1
(focus-widget txtf1)
(XmTextFieldPaste txtf1)
(XmTextFieldPasteLink txtf1)
- (if (not (Widget? (XmGetTabGroup txtf1))) (snd-display #__line__ ";XmGetTabGroup: ~A " (XmGetTabGroup txtf1)))
+ (if (not (Widget? (XmGetTabGroup txtf1))) (snd-display ";XmGetTabGroup: ~A " (XmGetTabGroup txtf1)))
(let ((fw (XmGetFocusWidget (cadr (main-widgets)))))
(if (not (equal? fw txtf1))
- (snd-display #__line__ ";XmGetFocusWidget: ~A" fw)))
+ (snd-display ";XmGetFocusWidget: ~A" fw)))
(let ((callback (lambda (w context ev flag)
(XtSetValues w (list XmNbackground (white-pixel))))))
(XtAddEventHandler txtf1 EnterWindowMask #f callback #f)
@@ -45954,7 +45112,7 @@ EDITS: 1
(win (XtWindow shell))
(err (XmClipboardRegisterFormat dpy "SND_DATA" 8)))
(if (not (= err ClipboardSuccess))
- (snd-display #__line__ ";XmClipboardRegisterFormat: ~A" err)
+ (snd-display ";XmClipboardRegisterFormat: ~A" err)
(let ((vals (XmClipboardStartCopy dpy win
(XmStringCreateLocalized "SND_DATA")
(list 'Time CurrentTime)
@@ -45962,28 +45120,27 @@ EDITS: 1
(lambda (w id pid reason)
(XmClipboardCopyByName dpy win id "copy this" 10 123)))))
(if (not (= (car vals) ClipboardSuccess))
- (snd-display #__line__ ";XmClipboardStartCopy: ~A" vals)
+ (snd-display ";XmClipboardStartCopy: ~A" vals)
(let ((data-id (cadr vals)))
(set! err (XmClipboardCopy dpy win data-id "SND_DATA" "copy this" 10 0))
- (if (not (= (car err) ClipboardSuccess)) (snd-display #__line__ ";XmClipboardCopy: ~A" err))
+ (if (not (= (car err) ClipboardSuccess)) (snd-display ";XmClipboardCopy: ~A" err))
(let ((item-id (cadr err)))
(set! err (XmClipboardEndCopy dpy win data-id))
- (if (not (= err ClipboardSuccess)) (snd-display #__line__ ";copy ~A" err))
+ (if (not (= err ClipboardSuccess)) (snd-display ";copy ~A" err))
(if (not (= (cadr (XmClipboardInquireLength dpy win "SND_DATA")) 10))
- (snd-display #__line__ ";clip len: ~A" (XmClipboardInquireLength dpy win "SND_DATA")))
+ (snd-display ";clip len: ~A" (XmClipboardInquireLength dpy win "SND_DATA")))
(let ((pend (XmClipboardInquirePendingItems dpy win "SND_DATA")))
- (if (not (= (car pend) ClipboardSuccess)) (snd-display #__line__ ";XmClipboardInquirePendingItems: ~A" pend)))
+ (if (not (= (car pend) ClipboardSuccess)) (snd-display ";XmClipboardInquirePendingItems: ~A" pend)))
(let ((formats1 (XmClipboardInquireCount dpy win)))
- (if (= (cadr formats1) 0) (snd-display #__line__ ";XmClipboardInquireCount: ~A" formats1))
+ (if (= (cadr formats1) 0) (snd-display ";XmClipboardInquireCount: ~A" formats1))
(XmClipboardInquireFormat dpy win 1 10)
(let ((clip (XmClipboardRetrieve dpy win "SND_DATA" 10)))
- (if (not (string=? (cadr clip) "copy this")) (snd-display #__line__ ";XmClipboardRetrieve: ~A" clip))
+ (if (not (string=? (cadr clip) "copy this")) (snd-display ";XmClipboardRetrieve: ~A" clip))
(XmClipboardWithdrawFormat dpy win item-id))))))))
(let ((val (XmClipboardLock dpy win)))
(if (not (= val ClipboardLocked))
(XmClipboardUnlock dpy win #t)))
- (let ((selbox (XmCreateSelectionBox shell "selbox" () 0)))
- (XmSelectionBoxGetChild selbox XmDIALOG_APPLY_BUTTON)))
+ (XmSelectionBoxGetChild (XmCreateSelectionBox shell "selbox" () 0) XmDIALOG_APPLY_BUTTON))
(let* ((frm (add-main-pane "hi" xmFormWidgetClass (list XmNpaneMinimum 120)))
(current-time (list 'Time CurrentTime))
@@ -46034,45 +45191,42 @@ EDITS: 1
(XtCreateManagedWidget "one" xmPushButtonWidgetClass notes ())
(XtCreateManagedWidget "two" xmPushButtonWidgetClass notes ())
(let ((info (cadr (XmNotebookGetPageInfo notes 1))))
- (if (not (= (.page_number info) 1)) (snd-display #__line__ ";page_number: ~A" (.page_number info)))
- (if (.page_widget info) (snd-display #__line__ ";page_widget: ~A" (.page_widget info)))
- (if (.status_area_widget info) (snd-display #__line__ ";status_area_widget: ~A" (.status_area_widget info)))
- (if (not (Widget? (.major_tab_widget info))) (snd-display #__line__ ";major_tab_widget: ~A" (.major_tab_widget info)))
- (if (.minor_tab_widget info) (snd-display #__line__ ";minor_tab_widget: ~A" (.minor_tab_widget info)))
+ (if (not (= (.page_number info) 1)) (snd-display ";page_number: ~A" (.page_number info)))
+ (if (.page_widget info) (snd-display ";page_widget: ~A" (.page_widget info)))
+ (if (.status_area_widget info) (snd-display ";status_area_widget: ~A" (.status_area_widget info)))
+ (if (not (Widget? (.major_tab_widget info))) (snd-display ";major_tab_widget: ~A" (.major_tab_widget info)))
+ (if (.minor_tab_widget info) (snd-display ";minor_tab_widget: ~A" (.minor_tab_widget info)))
;(segfault) (XtFree (cadr info))
)
(XmSimpleSpinBoxAddItem spn (XmStringCreateLocalized "hiho") 0)
(XmSimpleSpinBoxAddItem spn (XmStringCreateLocalized "away") 0)
(XmSimpleSpinBoxDeletePos spn 0)
- (let ((vals (XtVaGetValues spn (list XmNvalues 0))))
- (XmSimpleSpinBoxSetItem spn (caadr vals)))
+ (XmSimpleSpinBoxSetItem spn (caadr (XtVaGetValues spn (list XmNvalues 0))))
(XmSimpleSpinBoxAddItem spn (XmStringCreateLocalized "another") 0)
(let ((vals (XtGetValues spn (list XmNeditable 0 XmNtextField 0))))
- (if (not (vals 1)) (snd-display #__line__ ";XmNeditable spin box"))
- (if (not (Widget? (vals 3))) (snd-display #__line__ ";XmNtextField: ~A" (vals 3))))
+ (if (not (vals 1)) (snd-display ";XmNeditable spin box"))
+ (if (not (Widget? (vals 3))) (snd-display ";XmNtextField: ~A" (vals 3))))
(XtAddCallback tgl XmNvalueChangedCallback (lambda (w c i) (set! toggled 123)) #f)
(XmToggleButtonSetState tgl #f #f)
(XmToggleButtonGadgetSetState tgg #f #f)
- (if (not (= toggled 0)) (snd-display #__line__ ";toggle calledback: ~A?" toggled))
- (if (XmToggleButtonGetState tgl) (snd-display #__line__ ";XmToggleButtonSetState #f"))
- (if (XmToggleButtonGadgetGetState tgg) (snd-display #__line__ ";XmToggleButtonGadgetSetState #f"))
+ (if (not (= toggled 0)) (snd-display ";toggle calledback: ~A?" toggled))
+ (if (XmToggleButtonGetState tgl) (snd-display ";XmToggleButtonSetState #f"))
+ (if (XmToggleButtonGadgetGetState tgg) (snd-display ";XmToggleButtonGadgetSetState #f"))
(XtVaSetValues tgl (list XmNtoggleMode XmTOGGLE_INDETERMINATE))
(XmToggleButtonSetValue tgl XmINDETERMINATE #t)
(XmToggleButtonGadgetSetValue tgg XmINDETERMINATE #t)
- (if (not (= toggled 123)) (snd-display #__line__ ";toggle not calledback: ~A?" toggled))
+ (if (not (= toggled 123)) (snd-display ";toggle not calledback: ~A?" toggled))
(XmCommandAppendValue cmd (XmStringCreateLocalized "hiho"))
(XmCommandError cmd (XmStringCreateLocalized "hiho"))
(if (not (Widget? (XmCommandGetChild cmd XmDIALOG_COMMAND_TEXT)))
- (snd-display #__line__ ";XmCommandGetChild: ~A" (XmCommandGetChild cmd XmDIALOG_COMMAND_TEXT)))
+ (snd-display ";XmCommandGetChild: ~A" (XmCommandGetChild cmd XmDIALOG_COMMAND_TEXT)))
(XmCommandSetValue cmd (XmStringCreateLocalized "hiho"))
-
- (let ((one1 (XmStringCreateLocalized "one"))
- (two1 (XmStringCreateLocalized "two"))
+ (XmComboBoxAddItem cmb (XmStringCreateLocalized "one") 0 #f)
+ (let ((two1 (XmStringCreateLocalized "two"))
(three1 (XmStringCreateLocalized "three")))
- (XmComboBoxAddItem cmb one1 0 #f)
(XmComboBoxAddItem cmb two1 0 #f)
(XmComboBoxAddItem cmb three1 0 #f)
(XmComboBoxDeletePos cmb 1)
@@ -46080,7 +45234,7 @@ EDITS: 1
(XmComboBoxSetItem cmb three1) ; hunh??
(XmComboBoxUpdate cmb)
(let ((vals (cadr (XtGetValues cmb (list XmNitems 0)))))
- (if (not (equal? vals (list two1 three1))) (snd-display #__line__ ";XmComboBox: ~A" vals))))
+ (if (not (equal? vals (list two1 three1))) (snd-display ";XmComboBox: ~A" vals))))
(XmContainerCut box current-time)
(XmContainerCopy box current-time)
@@ -46094,12 +45248,12 @@ EDITS: 1
(null? (cdddr vals))
(not (real? (cadddr vals)))
(fneq (cadddr vals) 0.0))
- (snd-display #__line__ ";xm-float resource vals: ~A" vals)))
+ (snd-display ";xm-float resource vals: ~A" vals)))
(XtAddCallback scl XmNvalueChangedCallback (lambda (w c i) #f))
(XmScaleSetValue scl 25)
- (if (not (= (XmScaleGetValue scl) 25)) (snd-display #__line__ ";XmScaleSetValue: ~A" (XmScaleGetValue scl)))
- (if (XmGetTearOffControl (car (menu-widgets))) (snd-display #__line__ ";XmGetTearOffControl: ~A" (XmGetTearOffControl (car (menu-widgets)))))
+ (if (not (= (XmScaleGetValue scl) 25)) (snd-display ";XmScaleSetValue: ~A" (XmScaleGetValue scl)))
+ (if (XmGetTearOffControl (car (menu-widgets))) (snd-display ";XmGetTearOffControl: ~A" (XmGetTearOffControl (car (menu-widgets)))))
(let ((children (cadr (XtGetValues scl (list XmNchildren 0)))))
(for-each
(lambda (w)
@@ -46120,108 +45274,100 @@ EDITS: 1
;(old-h (cadr (XtVaGetValues scr (list XmNhorizontalFontUnit 0))))
;(old-v (cadr (XtVaGetValues scr (list XmNverticalFontUnit 0))))
)
- (if (not (XmIsScreen scr)) (snd-display #__line__ ";XmIsScreen: ~A" scr))
+ (if (not (XmIsScreen scr)) (snd-display ";XmIsScreen: ~A" scr))
(let ((colors (XmGetColors screen cmap *basic-color*)))
(if (not (Pixel? (car colors)))
- (snd-display #__line__ ";colors: ~A " colors))
+ (snd-display ";colors: ~A " colors))
(let ((color-proc (lambda (bg)
(list (white-pixel) (black-pixel) (white-pixel) (black-pixel)))))
(XmSetColorCalculation color-proc)
(if (not (equal? (XmGetColorCalculation) color-proc))
- (snd-display #__line__ ";XmSetColorcalulcation ~A" (XmGetColorCalculation)))))
+ (snd-display ";XmSetColorcalulcation ~A" (XmGetColorCalculation)))))
(let ((vals (XtVaGetValues scr
(list XmNbitmapConversionModel 0 XmNdarkThreshold 0 XmNfont 0 XmNunpostBehavior 0))))
- (if (not (= (vals 1) XmMATCH_DEPTH)) (snd-display #__line__ ";XmNbitmapConversionModel: ~A" (vals 1)))
- (if (not (= (vals 3) 0)) (snd-display #__line__ ";XmNdarkThreshold: ~A" (vals 3)))
- (if (not (XFontStruct? (vals 5))) (snd-display #__line__ ";XmNfont: ~A" (vals 5)))
- (if (not (= (vals 7) XmUNPOST_AND_REPLAY)) (snd-display #__line__ ";XmNunpostBehavior: ~A" (vals 7)))
+ (if (not (= (vals 1) XmMATCH_DEPTH)) (snd-display ";XmNbitmapConversionModel: ~A" (vals 1)))
+ (if (not (= (vals 3) 0)) (snd-display ";XmNdarkThreshold: ~A" (vals 3)))
+ (if (not (XFontStruct? (vals 5))) (snd-display ";XmNfont: ~A" (vals 5)))
+ (if (not (= (vals 7) XmUNPOST_AND_REPLAY)) (snd-display ";XmNunpostBehavior: ~A" (vals 7)))
(XSetScreenSaver dpy -1 5 DefaultBlanking DefaultExposures)
))
(let ((dpy (XtDisplay (cadr (main-widgets)))))
(let* ((dp (XmGetXmDisplay dpy))
(vals (XtVaGetValues dp
(list XmNdragInitiatorProtocolStyle 0 XmNenableThinThickness 0 XmNmotifVersion 0))))
- (if (not (XmIsDisplay dp)) (snd-display #__line__ ";XmIsDisplay: ~A" dp))
- (if (not (= (vals 1) XmDRAG_PREFER_RECEIVER)) (snd-display #__line__ ";XmNdragInitiatorProtocolStyle: ~A" (vals 1)))
- (if (not (vals 3)) (snd-display #__line__ ";XmNenableThinThickness?"))
- (if (not (= (vals 5) 2002)) (snd-display #__line__ ";XmGetXmDisplay motif version: ~A" (vals 5)))
+ (if (not (XmIsDisplay dp)) (snd-display ";XmIsDisplay: ~A" dp))
+ (if (not (= (vals 1) XmDRAG_PREFER_RECEIVER)) (snd-display ";XmNdragInitiatorProtocolStyle: ~A" (vals 1)))
+ (if (not (vals 3)) (snd-display ";XmNenableThinThickness?"))
+ (if (not (= (vals 5) 2002)) (snd-display ";XmGetXmDisplay motif version: ~A" (vals 5)))
(XtAddCallback dp XmNdragStartCallback (lambda (w c i) #f)))
(if (not (string=? (XmCvtXmStringToCT (XmStringCreateLocalized "hiho")) "hiho"))
- (snd-display #__line__ ";XmCvtXmStringToCT: ~A" (XmCvtXmStringToCT (XmStringCreateLocalized "hiho"))))
+ (snd-display ";XmCvtXmStringToCT: ~A" (XmCvtXmStringToCT (XmStringCreateLocalized "hiho"))))
(let ((val (XmConvertStringToUnits (XDefaultScreenOfDisplay dpy) "3.14 in" XmHORIZONTAL XmINCHES)))
- (if (not (= val 3)) (snd-display #__line__ ";XmConvertStringToUnits in->in ~A" val)))
+ (if (not (= val 3)) (snd-display ";XmConvertStringToUnits in->in ~A" val)))
(let ((val (XmConvertStringToUnits (XDefaultScreenOfDisplay dpy) "3.14 in" XmHORIZONTAL XmPOINTS)))
- (if (not (= val 225)) (snd-display #__line__ ";XmConvertStringToUnits in->pts ~A" val)))
+ (if (not (= val 225)) (snd-display ";XmConvertStringToUnits in->pts ~A" val)))
(let ((val (XmConvertStringToUnits (XDefaultScreenOfDisplay dpy) "3.14 in" XmHORIZONTAL XmCENTIMETERS)))
- (if (not (= val 7)) (snd-display #__line__ ";XmConvertStringToUnits in->cm ~A" val)))
+ (if (not (= val 7)) (snd-display ";XmConvertStringToUnits in->cm ~A" val)))
(let ((val (XmConvertUnits (cadr (main-widgets)) XmHORIZONTAL XmCENTIMETERS 7 XmMILLIMETERS)))
- (if (not (= val 70)) (snd-display #__line__ ";XmConvertUnits cm->mm ~A" val)))
- (let ((val (XmConvertUnits (cadr (main-widgets)) XmHORIZONTAL XmCENTIMETERS 7 XmPIXELS)))
- (if (and (not (= val 278)) (not (= val 273))) (snd-display #__line__ ";XmConvertUnits cm->pix ~A" val)))
- (XmVaCreateSimpleRadioBox (caddr (main-widgets)) "hiho" 0 (lambda (w c i) #f) ())
- (XmVaCreateSimpleCheckBox (caddr (main-widgets)) "hiho" (lambda (w c i) #f) ())
- (XmVaCreateSimplePulldownMenu (caddr (main-widgets)) "hiho" 0 (lambda (w c i) #f) ())
- (XmVaCreateSimplePopupMenu (caddr (main-widgets)) "hiho" (lambda (w c i) #f) ())
- (XmVaCreateSimpleMenuBar (caddr (main-widgets)) "hiho" ())
- (zync)
- (make-pixmap (cadr (main-widgets)) arrow-strs)
- ;(display-scanned-synthesis) -- needs updating
- (add-mark-pane)
- (let ((ind (open-sound "oboe.snd")))
- (snd-clock-icon ind 6)
- (add-tooltip (cadr (channel-widgets)) "the w button")
- (with-minmax-button ind)
- (make-channel-drop-site ind 0)
- (set-channel-drop (lambda (file s c) (snd-print file)) ind 0)
- (let ((drop-site (find-child (XtParent (XtParent ((channel-widgets ind 0) 7))) "drop here")))
- (if drop-site
- (begin
- (XtVaGetValues drop-site (list XmNdropRectangles 0))
- (let ((val (XmDropSiteRetrieve drop-site (list XmNnumImportTargets 0))))
- (if (not (= (cadr val) 1)) (snd-display #__line__ ";XmDropSiteRetrieve num: ~A" val)))
- (XmDropSiteRetrieve drop-site (list XmNimportTargets 0))
- (if (not (XmDropSiteRegistered drop-site))
- (snd-display #__line__ ";XmDropSiteRegistered?"))
- (XmDropSiteUnregister drop-site))
- (snd-display #__line__ ";no drop site?"))))
-
- (add-mark 123)
- (let ((container
- (make-sound-box "sounds"
- ((main-widgets) 3)
- (lambda (file)
- (mix file))
- (lambda (file chn)
- (define (without-directories filename)
- (call-with-exit
- (lambda (return)
- (do ((i (- (length filename) 1) (- i 1)))
- ((= i 0) filename)
- (if (char=? (filename i) #\/)
- (return (substring filename (+ i 1))))))))
- (format #f "~~/peaks/~A-peaks-~D"
- (snd-test-clean-string (mus-expand-filename file))
- chn))
- (list "oboe.snd" "pistol.snd" "cardinal.snd" "storm.snd")
- ())))
- (XmContainerRelayout container)
- (let ((vals (XtVaGetValues container
- (list XmNlargeCellHeight 0 XmNcollapsedStatePixmap 0 XmNdetailOrder 0 XmNdetailTabList 0
- XmNselectedObjects 0 XmNconvertCallback 0 XmNdestinationCallback 0 XmNselectionCallback 0))))
- (if (not (= (vals 1) 0)) (snd-display #__line__ ";XmNlargeCellHeight: ~A" (vals 1)))
- (if (not (Pixmap? (vals 3))) (snd-display #__line__ ";XmNcollapsedStatePixmap: ~A" (vals 3)))
- (let ((children ()))
- (for-each-child container
- (lambda (w)
- (if (XmIsIconGadget w)
- (set! children (cons w children)))))
- (XmContainerReorder container children (length children)))
- (let ((func (lambda (w) 0)))
- (XtSetValues container (list XmNinsertPosition func))
- (let ((func1 (cadr (XtGetValues container (list XmNinsertPosition 0)))))
- (if (not (equal? func func1)) (snd-display #__line__ ";XmNinsertPosition: ~A ~A" func func1))))))
- (close-sound))
+ (if (not (= val 70)) (snd-display ";XmConvertUnits cm->mm ~A" val))))
+ (let ((val (XmConvertUnits (cadr (main-widgets)) XmHORIZONTAL XmCENTIMETERS 7 XmPIXELS)))
+ (if (not (memv val '(278 273))) (snd-display ";XmConvertUnits cm->pix ~A" val)))
+ (XmVaCreateSimpleRadioBox (caddr (main-widgets)) "hiho" 0 (lambda (w c i) #f) ())
+ (XmVaCreateSimpleCheckBox (caddr (main-widgets)) "hiho" (lambda (w c i) #f) ())
+ (XmVaCreateSimplePulldownMenu (caddr (main-widgets)) "hiho" 0 (lambda (w c i) #f) ())
+ (XmVaCreateSimplePopupMenu (caddr (main-widgets)) "hiho" (lambda (w c i) #f) ())
+ (XmVaCreateSimpleMenuBar (caddr (main-widgets)) "hiho" ())
+ (zync)
+ (make-pixmap (cadr (main-widgets)) arrow-strs)
+ ;(display-scanned-synthesis) -- needs updating
+ (add-mark-pane)
+ (let ((ind (open-sound "oboe.snd")))
+ (snd-clock-icon ind 6)
+ (add-tooltip (cadr (channel-widgets)) "the w button")
+ (with-minmax-button ind)
+ (make-channel-drop-site ind 0)
+ (set-channel-drop (lambda (file s c) (snd-print file)) ind 0)
+ (let ((drop-site (find-child (XtParent (XtParent ((channel-widgets ind 0) 7))) "drop here")))
+ (if (not drop-site)
+ (snd-display ";no drop site?")
+ (begin
+ (XtVaGetValues drop-site (list XmNdropRectangles 0))
+ (let ((val (XmDropSiteRetrieve drop-site (list XmNnumImportTargets 0))))
+ (if (not (= (cadr val) 1)) (snd-display ";XmDropSiteRetrieve num: ~A" val)))
+ (XmDropSiteRetrieve drop-site (list XmNimportTargets 0))
+ (if (not (XmDropSiteRegistered drop-site))
+ (snd-display ";XmDropSiteRegistered?"))
+ (XmDropSiteUnregister drop-site)))))
+
+ (add-mark 123)
+ (let ((container
+ (make-sound-box "sounds"
+ ((main-widgets) 3)
+ mix
+ (lambda (file chn)
+ (format #f "~~/peaks/~A-peaks-~D"
+ (snd-test-clean-string (mus-expand-filename file))
+ chn))
+ (list "oboe.snd" "pistol.snd" "cardinal.snd" "storm.snd")
+ ())))
+ (XmContainerRelayout container)
+ (let ((vals (XtVaGetValues container
+ (list XmNlargeCellHeight 0 XmNcollapsedStatePixmap 0 XmNdetailOrder 0 XmNdetailTabList 0
+ XmNselectedObjects 0 XmNconvertCallback 0 XmNdestinationCallback 0 XmNselectionCallback 0))))
+ (if (not (= (vals 1) 0)) (snd-display ";XmNlargeCellHeight: ~A" (vals 1)))
+ (if (not (Pixmap? (vals 3))) (snd-display ";XmNcollapsedStatePixmap: ~A" (vals 3))))
+ (let ((children ()))
+ (for-each-child container
+ (lambda (w)
+ (if (XmIsIconGadget w)
+ (set! children (cons w children)))))
+ (XmContainerReorder container children (length children)))
+ (let ((func (lambda (w) 0)))
+ (XtSetValues container (list XmNinsertPosition func))
+ (let ((func1 (cadr (XtGetValues container (list XmNinsertPosition 0)))))
+ (if (not (equal? func func1)) (snd-display ";XmNinsertPosition: ~A ~A" func func1)))))
+ (close-sound)
;; qualify proc is causing a segfault somehow
; (let ((box (XmCreateFileSelectionBox (cadr (main-widgets)) "box"
@@ -46252,68 +45398,64 @@ EDITS: 1
))
(XtUnmanageChild hi))
- (if (and (defined? 'XmCreateFontSelector)
- (defined? 'XmCreateColorSelector))
- (let ((fonts-dialog #f)
- (colors-dialog #f))
- (for-each
- (lambda (make-dialog)
- (let* ((xdismiss (XmStringCreate "Dismiss" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
- (titlestr (XmStringCreate "Fonts" XmFONTLIST_DEFAULT_TAG))
- (new-dialog (XmCreateTemplateDialog
- (cadr (main-widgets)) "Fonts"
- (list XmNcancelLabelString xdismiss
- XmNhelpLabelString xhelp
- XmNokLabelString xok
- XmNautoUnmanage #f
- XmNdialogTitle titlestr
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNbackground *basic-color*
- XmNtransient #f))))
- (XtAddCallback new-dialog XmNcancelCallback (lambda (w c i) (XtUnmanageChild w)))
- (XtAddCallback new-dialog XmNhelpCallback (lambda (w c i) (help-dialog "Fonts" "no help yet")))
- (XtAddCallback new-dialog XmNokCallback (lambda (w c i) (XtUnmanageChild w)))
- (XmStringFree xhelp)
- (XmStringFree xok)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
- (if (not fonts-dialog)
- (set! fonts-dialog new-dialog)
- (set! colors-dialog new-dialog))
- (let* ((mainform (XtCreateManagedWidget "mainform" xmFormWidgetClass new-dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild new-dialog XmDIALOG_SEPARATOR)
- XmNbackground *basic-color*)))
- (fnts (make-dialog mainform)))
- (XtManageChild fnts)
- (if (not colors-dialog)
- (XtManageChild fonts-dialog)
- (XtManageChild colors-dialog)))))
- (list
- (lambda (mainform)
- (XmCreateFontSelector mainform "Fonts"
- (list XmNbackground *basic-color*
- XmNcurrentFont "-*-times-bold-r-*-*-14-140-*-*-*-*-*-*"
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE)))
-
- (lambda (mainform)
- (XmCreateColorSelector mainform "Colors"
- (list XmNbackground *basic-color*
- XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_NONE)))))
- (XtUnmanageChild fonts-dialog)
- (XtUnmanageChild colors-dialog)))
+ (when (and (defined? 'XmCreateFontSelector)
+ (defined? 'XmCreateColorSelector))
+ (let ((fonts-dialog #f)
+ (colors-dialog #f))
+ (for-each
+ (lambda (make-dialog)
+ (let* ((xdismiss (XmStringCreate "Dismiss" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG))
+ (titlestr (XmStringCreate "Fonts" XmFONTLIST_DEFAULT_TAG))
+ (new-dialog (XmCreateTemplateDialog
+ (cadr (main-widgets)) "Fonts"
+ (list XmNcancelLabelString xdismiss
+ XmNhelpLabelString xhelp
+ XmNokLabelString xok
+ XmNautoUnmanage #f
+ XmNdialogTitle titlestr
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNbackground *basic-color*
+ XmNtransient #f))))
+ (XtAddCallback new-dialog XmNcancelCallback (lambda (w c i) (XtUnmanageChild w)))
+ (XtAddCallback new-dialog XmNhelpCallback (lambda (w c i) (help-dialog "Fonts" "no help yet")))
+ (XtAddCallback new-dialog XmNokCallback (lambda (w c i) (XtUnmanageChild w)))
+ (for-each XmStringFree (vector xhelp xok xdismiss titlestr))
+ (if (not fonts-dialog)
+ (set! fonts-dialog new-dialog)
+ (set! colors-dialog new-dialog))
+ (let* ((mainform (XtCreateManagedWidget "mainform" xmFormWidgetClass new-dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild new-dialog XmDIALOG_SEPARATOR)
+ XmNbackground *basic-color*)))
+ (fnts (make-dialog mainform)))
+ (XtManageChild fnts)
+ (XtManageChild (or colors-dialog fonts-dialog)))))
+
+ (list
+ (lambda (mainform)
+ (XmCreateFontSelector mainform "Fonts"
+ (list XmNbackground *basic-color*
+ XmNcurrentFont "-*-times-bold-r-*-*-14-140-*-*-*-*-*-*"
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE)))
+
+ (lambda (mainform)
+ (XmCreateColorSelector mainform "Colors"
+ (list XmNbackground *basic-color*
+ XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_NONE)))))
+ (XtUnmanageChild fonts-dialog)
+ (XtUnmanageChild colors-dialog)))
(let* ((xdismiss (XmStringCreate "Dismiss" XmFONTLIST_DEFAULT_TAG))
(xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
@@ -46330,10 +45472,7 @@ EDITS: 1
XmNnoResize #f
XmNbackground *basic-color*
XmNtransient #f))))
- (XmStringFree xhelp)
- (XmStringFree xok)
- (XmStringFree xdismiss)
- (XmStringFree titlestr)
+ (for-each XmStringFree (vector xhelp xok xdismiss titlestr))
(let* ((mainform (XtCreateManagedWidget "mainform" xmFormWidgetClass new-dialog
(list XmNleftAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_FORM
@@ -46344,49 +45483,50 @@ EDITS: 1
(fnts
(and (defined? 'XmIsColumn)
(let* ((w1 (XmCreateColumn mainform "column" ()))
- (w1-child (XtCreateManagedWidget "hihi" xmLabelWidgetClass w1 () 0))
- (w2 (XtCreateManagedWidget "column1" xmColumnWidgetClass mainform () 0)))
- (if (or (not (XmIsColumn w1))
- (not (XmIsColumn w2))
- (not (XmColumn? w1)))
- (snd-display #__line__ ";XmIsColumn: ~A ~A" w1 w2))
+ (w1-child (XtCreateManagedWidget "hihi" xmLabelWidgetClass w1 () 0)))
+ (let ((w2 (XtCreateManagedWidget "column1" xmColumnWidgetClass mainform () 0)))
+ (if (not (and (XmIsColumn w1)
+ (XmIsColumn w2)
+ (XmColumn? w1)))
+ (snd-display ";XmIsColumn: ~A ~A" w1 w2)))
(if (defined? 'XmColumnGetChildLabel)
(let ((child (XmColumnGetChildLabel w1)))
- (if (or (not (child)) (not (equal? child w1-child)))
- (snd-display #__line__ ";XmColumn child: ~A ~A" child w1-child))))
+ (if (not (and (child)
+ (equal? child w1-child)))
+ (snd-display ";XmColumn child: ~A ~A" child w1-child))))
(XtManageChild w1)
w1)))
(fntt
(and (defined? 'XmIsButtonBox)
(let ((w1 (XmCreateButtonBox mainform "box" (list XmNfillOption XmFillMajor))))
- (if (or (not (XmIsButtonBox w1))
- (not (XmButtonBox? w1)))
- (snd-display #__line__ ";XmIsButtonBox: ~A ~A ~A" w1 (XmIsButtonBox w1) (XmButtonBox? w1)))
+ (if (not (and (XmIsButtonBox w1)
+ (XmButtonBox? w1)))
+ (snd-display ";XmIsButtonBox: ~A ~A ~A" w1 (XmIsButtonBox w1) (XmButtonBox? w1)))
(XtManageChild w1)
w1)))
(fntd
(and (defined? 'XmIsDropDown)
(let ((w1 (XmCreateDropDown mainform "drop" ())))
- (if (or (not (XmIsDropDown w1))
- (not (XmDropDown? w1)))
- (snd-display #__line__ ";XmIsDropDown: ~A ~A ~A" w1 (XmIsDropDown w1) (XmDropDown? w1)))
+ (if (not (and (XmIsDropDown w1)
+ (XmDropDown? w1)))
+ (snd-display ";XmIsDropDown: ~A ~A ~A" w1 (XmIsDropDown w1) (XmDropDown? w1)))
(XtManageChild w1)
- (let ((text (XmDropDownGetText w1))
- (label (XmDropDownGetLabel w1))
- (arrow (XmDropDownGetArrow w1))
- (lst (XmDropDownGetList w1)))
- (XmDropDownGetValue w1)
- (if (not (XmTextField? text)) (snd-display #__line__ ";dropdown text: ~A" text))
- (if (not (XmLabel? label)) (snd-display #__line__ ";dropdown label: ~A" label))
- (if (not (XmArrowButton? arrow)) (snd-display #__line__ ";dropdown arrow: ~A" arrow))
- (if (not (XmList? lst)) (snd-display #__line__ ";dropdown lst: ~A" text))
- w1))))
+ (XmDropDownGetValue w1)
+ (let ((text (XmDropDownGetText w1)))
+ (if (not (XmTextField? text)) (snd-display ";dropdown text: ~A" text)))
+ (let ((label (XmDropDownGetLabel w1)))
+ (if (not (XmLabel? label)) (snd-display ";dropdown label: ~A" label)))
+ (let ((arrow (XmDropDownGetArrow w1)))
+ (if (not (XmArrowButton? arrow)) (snd-display ";dropdown arrow: ~A" arrow)))
+ (let ((lst (XmDropDownGetList w1)))
+ (if (not (XmList? lst)) (snd-display ";dropdown lst: ~A" text)))
+ w1)))
(fntda
(and (defined? 'XmIsDataField)
(let ((w1 (XmCreateDataField mainform "data" ())))
- (if (or (not (XmIsDataField w1))
- (not (XmDataField? w1)))
- (snd-display #__line__ ";XmIsDataField: ~A ~A ~A" w1 (XmIsDataField w1) (XmDataField? w1)))
+ (if (not (and (XmIsDataField w1)
+ (XmDataField? w1)))
+ (snd-display ";XmIsDataField: ~A ~A ~A" w1 (XmIsDataField w1) (XmDataField? w1)))
(XmDataFieldGetString w1)
(XmDataFieldGetSelection w1)
(XmDataFieldSetString w1 "hiho")
@@ -46403,23 +45543,23 @@ EDITS: 1
(fnttab
(and (defined? 'XmIsTabStack)
(let ((w1 (XmCreateTabStack mainform "hi" ())))
- (if (or (not (XmIsTabStack w1))
- (not (XmTabStack? w1)))
- (snd-display #__line__ ";XmIsTabStack: ~A ~A ~A" w1 (XmIsTabStack w1) (XmTabStack? w1)))
+ (if (not (and (XmIsTabStack w1)
+ (XmTabStack? w1)))
+ (snd-display ";XmIsTabStack: ~A ~A ~A" w1 (XmIsTabStack w1) (XmTabStack? w1)))
(XmTabStackGetSelectedTab w1)
(XmTabStackSelectTab w1 #f)
w1))))
(if (and (defined? 'XmToolTipGetLabel)
(defined? 'XmNtoolTipString))
- (let ((wid1 (XtCreateManagedWidget "wid1" xmPushButtonWidgetClass mainform
+ (let* ((wid1 (XtCreateManagedWidget "wid1" xmPushButtonWidgetClass mainform
(list XmNtoolTipString (XmStringCreateLocalized "tooltip")
XmNtoolTipPostDelay 100
XmNtoolTipPostDuration 500
XmNtoolTipEnable #t
- XmNanimate #f))))
- (let ((tip (XmToolTipGetLabel wid1)))
- (if (not (Widget? tip)) (snd-display #__line__ ";tooltip label: ~A ~A ~A ~A ~A ~A" tip fnttab fntda fntd fntt fnts)))))
+ XmNanimate #f)))
+ (tip (XmToolTipGetLabel wid1)))
+ (if (not (Widget? tip)) (snd-display ";tooltip label: ~A ~A ~A ~A ~A ~A" tip fnttab fntda fntd fntt fnts))))
(XtManageChild new-dialog)
(XtUnmanageChild new-dialog)))
@@ -46430,17 +45570,17 @@ EDITS: 1
(proto1 (XmInternAtom dpy "TEST1" #f))
(proto2 (XmInternAtom dpy "TEST2" #f))
(val 0))
- (if (not (Atom? prop)) (snd-display #__line__ ";XmInternAtom: ~A" prop))
- (if (not (string=? (XmGetAtomName dpy prop) "TESTING")) (snd-display #__line__ ";XmGetAtomName: ~A" (XmGetAtomName dpy prop)))
+ (if (not (Atom? prop)) (snd-display ";XmInternAtom: ~A" prop))
+ (if (not (string=? (XmGetAtomName dpy prop) "TESTING")) (snd-display ";XmGetAtomName: ~A" (XmGetAtomName dpy prop)))
(XmAddProtocols shell prop (list proto1 proto2))
(XmSetProtocolHooks shell
(XmInternAtom dpy "WM_PROTOCOLS" #f)
prop
(lambda (w c i)
- (snd-display #__line__ ";prehook: ~A ~A ~A" w c i))
+ (snd-display ";prehook: ~A ~A ~A" w c i))
12345
(lambda (w c i)
- (snd-display #__line__ ";posthook: ~A ~A ~A" w c i))
+ (snd-display ";posthook: ~A ~A ~A" w c i))
54321)
(XmDeactivateProtocol shell prop proto2)
(XmRemoveProtocols shell prop (list proto2))
@@ -46576,7 +45716,7 @@ EDITS: 1
(set! (.event struct) (XEvent))
(for-each
(lambda (field)
- (if (not (pair? field)) (snd-display #__line__ ";~A: ~A" struct field))
+ (if (not (pair? field)) (snd-display ";~A: ~A" struct field))
(set! val ((car field) struct))
(if (< (length field) 4)
(case (cadr field)
@@ -46792,71 +45932,72 @@ EDITS: 1
(for-each
(lambda (n)
- (if (not (string? (car n))) (snd-display #__line__ ";resource ~A is not a string?" (car n)))
+ (if (not (string? (car n))) (snd-display ";resource ~A is not a string?" (car n)))
(XtVaGetValues shell (list (car n) 0)))
resource-list)
)
(if (not (XEvent? (XEvent)))
- (snd-display #__line__ ";xevent type trouble! ~A -> ~A" (XEvent) (XEvent? (XEvent))))
+ (snd-display ";xevent type trouble! ~A -> ~A" (XEvent) (XEvent? (XEvent))))
(if (not (XGCValues? (XGCValues)))
- (snd-display #__line__ ";xgcvalues type trouble! ~A -> ~A" (XGCValues) (XGCValues? (XGCValues))))
+ (snd-display ";xgcvalues type trouble! ~A -> ~A" (XGCValues) (XGCValues? (XGCValues))))
(if (not (= (.direction (XmTraverseObscuredCallbackStruct)) 0))
- (snd-display #__line__ ";.direction: ~A" (.direction (XmTraverseObscuredCallbackStruct))))
+ (snd-display ";.direction: ~A" (.direction (XmTraverseObscuredCallbackStruct))))
(if (.ptr (XmTextBlock))
- (snd-display #__line__ ";.ptr block: ~A" (.ptr (XmTextBlock))))
+ (snd-display ";.ptr block: ~A" (.ptr (XmTextBlock))))
(let ((hi (XmTextBlock)))
(set! (.ptr hi) "hi")
(if (not (string=? (.ptr hi) "hi"))
- (snd-display #__line__ ";.ptr set block: ~A" (.ptr hi)))
- (if (not (= (.length hi) 0)) (snd-display #__line__ ";.length block: ~A" (.length hi)))
+ (snd-display ";.ptr set block: ~A" (.ptr hi)))
+ (if (not (= (.length hi) 0)) (snd-display ";.length block: ~A" (.length hi)))
(set! (.length hi) 3)
- (if (not (= (.length hi) 3)) (snd-display #__line__ ";set .length block: ~A" (.length hi))))
- (if (not (= (.dashes (XGCValues)) 0)) (snd-display #__line__ ";dashes: ~A" (.dashes (XGCValues))))
+ (if (not (= (.length hi) 3)) (snd-display ";set .length block: ~A" (.length hi))))
+ (if (not (= (.dashes (XGCValues)) 0)) (snd-display ";dashes: ~A" (.dashes (XGCValues))))
(set! (.dashes (XGCValues)) 1)
(set! (.clip_mask (XGCValues)) (list 'Pixmap 0))
(set! (.resourceid (XEvent -1)) 0)
(set! (.error_code (XEvent -1)) 0)
(set! (.request_code (XEvent -1)) 0)
- (if (not (= (.resourceid (XEvent -1)) 0)) (snd-display #__line__ ";error resourceid: ~A" (.resourceid (XEvent -1))))
- (if (not (= (.request_code (XEvent -1)) 0)) (snd-display #__line__ ";error request_code: ~A" (.request_code (XEvent -1))))
+ (if (not (= (.resourceid (XEvent -1)) 0)) (snd-display ";error resourceid: ~A" (.resourceid (XEvent -1))))
+ (if (not (= (.request_code (XEvent -1)) 0)) (snd-display ";error request_code: ~A" (.request_code (XEvent -1))))
(set! (.pad (XColor)) 1)
;;)
- (if (defined? 'XShapeQueryExtents)
- (let* ((dpy (XtDisplay (cadr (main-widgets))))
- (win (XtWindow (cadr (main-widgets))))
- (vals (XShapeQueryExtents dpy win)))
- (if (not (= (car vals) 1))
- (snd-display #__line__ ";XShapeQueryExtents: ~A" vals))
- (set! vals (XShapeGetRectangles dpy win 0))
- (if (not (list? vals)) (snd-display #__line__ ";XShapeGetRectangles: ~A" vals))
+ (when (defined? 'XShapeQueryExtents)
+ (let* ((dpy (XtDisplay (cadr (main-widgets))))
+ (win (XtWindow (cadr (main-widgets))))
+ (vals (XShapeQueryExtents dpy win)))
+ (if (not (= (car vals) 1))
+ (snd-display ";XShapeQueryExtents: ~A" vals))
+ (set! vals (XShapeGetRectangles dpy win 0))
+ (if (not (list? vals)) (snd-display ";XShapeGetRectangles: ~A" vals))
;(segfault) (XtFree (cadr vals))
- (set! vals (XShapeQueryExtension dpy))
- (if (not (equal? vals (list #t 64 0))) (snd-display #__line__ ";XShapeQueryExtension: ~A" vals))
- (set! vals (XShapeQueryVersion dpy))
- (if (and (not (equal? vals (list #t 1 0)))
- (not (equal? vals (list #t 1 1))))
- (snd-display #__line__ ";XShapeQueryVersion: ~A" vals))
- (if (XShapeOffsetShape dpy win 0 0 0) (snd-display #__line__ ";XShapeOffsetShape?"))
-
- (let* ((attr (XSetWindowAttributes #f *basic-color* #f *highlight-color*))
- (newwin (XCreateWindow dpy win 10 10 100 100 3
- CopyFromParent InputOutput (list 'Visual CopyFromParent)
- (logior CWBackPixel CWBorderPixel)
- attr))
- (bitmap (XCreateBitmapFromData dpy win right-arrow 16 12))) ; right-arrow is in snd-motif.scm
- (XShapeCombineMask dpy newwin ShapeClip 0 0 bitmap ShapeSet)
- (XShapeCombineRectangles dpy newwin ShapeUnion 0 0
- (list (XRectangle 0 0 10 10) (XRectangle 0 0 10 30)) 2
- ShapeSet ShapeBounding)
- (let ((newerwin (XCreateWindow dpy win 10 10 100 100 3
- CopyFromParent InputOutput (list 'Visual CopyFromParent)
- (logior CWBackPixel CWBorderPixel)
- attr)))
- (XShapeCombineShape dpy newerwin ShapeIntersect 0 0 newwin ShapeSet ShapeClip))
- (let ((reg1 (XPolygonRegion (list (XPoint 2 2) (XPoint 10 2) (XPoint 10 10) (XPoint 2 10)) 4 WindingRule)))
- (XShapeCombineRegion dpy newwin ShapeUnion 0 0 reg1 ShapeSet)))))
+ (set! vals (XShapeQueryExtension dpy))
+ (if (not (equal? vals (list #t 64 0))) (snd-display ";XShapeQueryExtension: ~A" vals))
+ (set! vals (XShapeQueryVersion dpy))
+ (if (not (or (equal? vals (list #t 1 0))
+ (equal? vals (list #t 1 1))))
+ (snd-display ";XShapeQueryVersion: ~A" vals))
+ (if (XShapeOffsetShape dpy win 0 0 0) (snd-display ";XShapeOffsetShape?"))
+
+ (let* ((attr (XSetWindowAttributes #f *basic-color* #f *highlight-color*))
+ (newwin (XCreateWindow dpy win 10 10 100 100 3
+ CopyFromParent InputOutput (list 'Visual CopyFromParent)
+ (logior CWBackPixel CWBorderPixel)
+ attr)))
+ (XShapeCombineMask dpy newwin ShapeClip 0 0
+ (XCreateBitmapFromData dpy win right-arrow 16 12) ; right-arrow is in snd-motif.scm
+ ShapeSet)
+ (XShapeCombineRectangles dpy newwin ShapeUnion 0 0
+ (list (XRectangle 0 0 10 10) (XRectangle 0 0 10 30)) 2
+ ShapeSet ShapeBounding)
+ (let ((newerwin (XCreateWindow dpy win 10 10 100 100 3
+ CopyFromParent InputOutput (list 'Visual CopyFromParent)
+ (logior CWBackPixel CWBorderPixel)
+ attr)))
+ (XShapeCombineShape dpy newerwin ShapeIntersect 0 0 newwin ShapeSet ShapeClip))
+ (let ((reg1 (XPolygonRegion (list (XPoint 2 2) (XPoint 10 2) (XPoint 10 10) (XPoint 2 10)) 4 WindingRule)))
+ (XShapeCombineRegion dpy newwin ShapeUnion 0 0 reg1 ShapeSet)))))
(let ((classes (list xmArrowButtonWidgetClass xmBulletinBoardWidgetClass xmCascadeButtonWidgetClass xmCommandWidgetClass
xmDrawingAreaWidgetClass xmDrawnButtonWidgetClass xmFileSelectionBoxWidgetClass xmFormWidgetClass
@@ -46880,7 +46021,7 @@ EDITS: 1
(let ((key (XStringToKeysym "Cancel")))
(if (not (= (cadr key) XK_Cancel))
- (snd-display #__line__ ";XStringToKeysym ~A ~A" key XK_Cancel)))
+ (snd-display ";XStringToKeysym ~A ~A" key XK_Cancel)))
(let* ((win (XtWindow (cadr (main-widgets))))
(xm-procs-1
@@ -47123,13 +46264,14 @@ EDITS: 1
XSelectionEvent? XSelectionRequestEvent? XSetWindowAttributes? XStandardColormap? XUnmapEvent? XVisibilityEvent?
))
- (xm-procs (if (defined? 'XpmImage?)
+ (xm-procs (if (not (defined? 'XpmImage?))
+ xm-procs-1
(append xm-procs-1
(list
XpmCreatePixmapFromData XpmCreateDataFromPixmap XpmReadFileToPixmap
XpmReadPixmapFile XpmWriteFileFromPixmap XpmWritePixmapFile XpmCreatePixmapFromXpmImage
- XpmCreateXpmImageFromPixmap XpmAttributes? XpmImage? XpmColorSymbol?))
- xm-procs-1))
+ XpmCreateXpmImageFromPixmap XpmAttributes? XpmImage? XpmColorSymbol?))))
+
(xm-procs0 (remove-if (lambda (n) (not (aritable? n 0))) xm-procs))
(xm-procs1 (remove-if (lambda (n) (not (aritable? n 1))) xm-procs))
(xm-procs2 (remove-if (lambda (n) (not (aritable? n 2))) xm-procs))
@@ -47154,7 +46296,7 @@ EDITS: 1
(lambda args (car args))))
xm-procs1))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t () (make-vector 0)))
+ (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t () #()))
;; ---------------- 2 Args
(for-each
@@ -47168,9 +46310,9 @@ EDITS: 1
(lambda args (car args))))
xm-procs2))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4
- 0+i (make-delay 32) :feedback -1 0 #f #t () (make-vector 0))))
+ 0+i (make-delay 32) :feedback -1 0 #f #t () #())))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4
- 0+i (make-delay 32) :frequency -1 0 #f #t () (make-vector 0)))
+ 0+i (make-delay 32) :frequency -1 0 #f #t () #()))
(if all-args
;; ---------------- 3 Args
@@ -47187,11 +46329,11 @@ EDITS: 1
(lambda args (car args))))
xm-procs3))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 0+i (make-delay 32)
- :start -1 0 #f #t () (make-vector 0))))
+ :start -1 0 #f #t () #())))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 0+i (make-delay 32)
- :phase -1 0 #f #t () (make-vector 0))))
+ :phase -1 0 #f #t () #())))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 0+i (make-delay 32)
- :channels -1 0 #f #t () (make-vector 0)))
+ :channels -1 0 #f #t () #()))
)
(let* ((struct-accessors-1
@@ -47224,11 +46366,12 @@ EDITS: 1
.event .override_redirect .border_width .parent .minor_code .major_code .drawable .count .key_vector .focus
.detail .mode .is_hint .button .same_screen .keycode .state .y_root .x_root .root .time .subwindow .window
.send_event .serial .type .value .doit .colormap .menuToPost .postIt))
- (struct-accessors (if (defined? 'XpmImage?)
+ (struct-accessors (if (not (defined? 'XpmImage?))
+ struct-accessors-1
(append struct-accessors-1
(list .valuemask .ncolors .cpp .numsymbols .colorsymbols .npixels
- .y_hotspot .x_hotspot .colormap_size))
- struct-accessors-1))
+ .y_hotspot .x_hotspot .colormap_size))))
+
(struct-accessor-names-1
(list '.pixel '.red '.green '.blue '.flags '.pad '.x '.y '.width '.height '.angle1 '.angle2 '.ptr
@@ -47260,11 +46403,12 @@ EDITS: 1
'.event '.override_redirect '.border_width '.parent '.minor_code '.major_code '.drawable '.count '.key_vector '.focus
'.detail '.mode '.is_hint '.button '.same_screen '.keycode '.state '.y_root '.x_root '.root '.time '.subwindow '.window
'.send_event '.serial '.type '.value '.doit '.colormap '.menuToPost '.postIt))
- (struct-accessor-names (if (defined? 'XpmImage?)
+ (struct-accessor-names (if (not (defined? 'XpmImage?))
+ struct-accessor-names-1
(append struct-accessor-names-1
(list '.valuemask '.ncolors '.cpp
- '.numsymbols '.colorsymbols '.npixels '.y_hotspot '.x_hotspot '.colormap_size))
- struct-accessor-names-1))
+ '.numsymbols '.colorsymbols '.npixels '.y_hotspot '.x_hotspot '.colormap_size))))
+
(dpy (XtDisplay (cadr (main-widgets))))
(win (XtWindow (cadr (main-widgets)))))
@@ -47276,7 +46420,7 @@ EDITS: 1
n
(lambda args (car args)))))
(if (not (memq tag '(wrong-type-arg wrong-number-of-args)))
- (snd-display #__line__ ";(~A) -> ~A" name tag)))
+ (snd-display ";(~A) -> ~A" name tag)))
(if (dilambda? n)
(let ((tag
(catch #t
@@ -47284,7 +46428,7 @@ EDITS: 1
(set! (n) 0))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-number-of-args))
- (snd-display #__line__ ";(~A) -> ~A" name tag)))))
+ (snd-display ";(~A) -> ~A" name tag)))))
struct-accessors
struct-accessor-names)
@@ -47298,7 +46442,7 @@ EDITS: 1
(lambda () (n arg))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";(~A ~A) -> ~A" name arg tag)))
+ (snd-display ";(~A ~A) -> ~A" name arg tag)))
(if (dilambda? n)
(begin
(let ((tag
@@ -47306,16 +46450,16 @@ EDITS: 1
(lambda () (set! (n arg) 0))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";(~A ~A) -> ~A" name arg tag)))
+ (snd-display ";(~A ~A) -> ~A" name arg tag)))
(let ((tag
(catch #t
(lambda () (set! (n 0) arg))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";(set ~A ~A) -> ~A" name arg tag))))))
+ (snd-display ";(set ~A ~A) -> ~A" name arg tag))))))
struct-accessors
struct-accessor-names))
- (list dpy win '(Atom 0) '(Colormap 0) 1.5 "/hiho" 1234 #f #\c '(Time 0) '(Font 0) (make-vector 0) '(Cursor 1))))
+ (list dpy win '(Atom 0) '(Colormap 0) 1.5 "/hiho" 1234 #f #\c '(Time 0) '(Font 0) #() '(Cursor 1))))
)
(show-sounds-in-directory)
;(show-all-atoms)
@@ -47326,117 +46470,115 @@ EDITS: 1
;;; ---------------- test 24: GL --------------------
(define (snd_test_24)
- (if (and (provided? 'snd-motif)
- (provided? 'gl)
- (provided? 'xm))
-
- (with-let (sublet *gl*)
- (require snd-snd-gl.scm)
- (gl-info)
- (if all-args (gl-dump-state))
- (let ((gl-procs
- (list
- glXChooseVisual glXCopyContext glXCreateContext glXCreateGLXPixmap glXDestroyContext glXDestroyGLXPixmap glXGetConfig
- glXGetCurrentContext glXGetCurrentDrawable glXIsDirect glXMakeCurrent glXQueryExtension glXQueryVersion glXSwapBuffers
- glXUseXFont glXWaitGL glXWaitX glXGetClientString glXQueryServerString glXQueryExtensionsString glClearIndex glClearColor
- glClear glIndexMask glColorMask glAlphaFunc glBlendFunc glLogicOp glCullFace glFrontFace glPointSize glLineWidth glLineStipple
- glPolygonMode glPolygonOffset glPolygonStipple glEdgeFlag glScissor glClipPlane glGetClipPlane
- glDrawBuffer glReadBuffer glEnable glDisable glIsEnabled glEnableClientState glDisableClientState glGetBooleanv
- glGetDoublev glGetFloatv glGetIntegerv glPushAttrib glPopAttrib glPushClientAttrib glPopClientAttrib glRenderMode
- glGetError glGetString glFinish glFlush glHint glClearDepth glDepthFunc glDepthMask glDepthRange glClearAccum glAccum
- glMatrixMode glOrtho glFrustum glViewport glPushMatrix glPopMatrix glLoadIdentity glLoadMatrixd glLoadMatrixf
- glMultMatrixd glMultMatrixf glRotated glRotatef glScaled glScalef glTranslated glTranslatef glIsList glDeleteLists
- glGenLists glNewList glEndList glCallList glCallLists glListBase glBegin glEnd glVertex2d glVertex2f glVertex2i glVertex2s
- glVertex3d glVertex3f glVertex3i glVertex3s glVertex4d glVertex4f glVertex4i glVertex4s glNormal3b glNormal3d glNormal3f
- glNormal3i glNormal3s glIndexd glIndexf glIndexi glIndexs glIndexub glColor3b glColor3d glColor3f glColor3i glColor3s
- glColor3ub glColor3ui glColor3us glColor4b glColor4d glColor4f glColor4i glColor4s glColor4ub glColor4ui glColor4us glTexCoord1d
- glTexCoord1f glTexCoord1i glTexCoord1s glTexCoord2d glTexCoord2f glTexCoord2i glTexCoord2s glTexCoord3d glTexCoord3f glTexCoord3i
- glTexCoord3s glTexCoord4d glTexCoord4f glTexCoord4i glTexCoord4s glRasterPos2d glRasterPos2f glRasterPos2i glRasterPos2s
- glRasterPos3d glRasterPos3f glRasterPos3i glRasterPos3s glRasterPos4d glRasterPos4f glRasterPos4i glRasterPos4s glRectd
- glRectf glRecti glRects glVertexPointer glNormalPointer glColorPointer glIndexPointer glTexCoordPointer glEdgeFlagPointer
- glGetPointerv glArrayElement glDrawArrays glDrawElements glInterleavedArrays glShadeModel glLightf glLighti glGetLightfv
- glGetLightiv glLightModelf glLightModeli glMaterialf glMateriali glGetMaterialfv glGetMaterialiv glColorMaterial glPixelZoom
- glPixelStoref glPixelStorei glPixelTransferf glPixelTransferi glGetPixelMapfv glGetPixelMapuiv glGetPixelMapusv glBitmap
- glReadPixels glDrawPixels glCopyPixels glStencilFunc glStencilMask glStencilOp glClearStencil glTexGend glTexGenf glTexGeni
- glGetTexGendv glGetTexGenfv glGetTexGeniv glTexEnvf glTexEnvi glGetTexEnvfv glGetTexEnviv glTexParameterf glTexParameteri
- glGetTexParameterfv glGetTexParameteriv glGetTexLevelParameterfv glGetTexLevelParameteriv glTexImage1D glTexImage2D
- glGenTextures glDeleteTextures glBindTexture glAreTexturesResident glIsTexture glTexSubImage1D glTexSubImage2D glCopyTexImage1D
- glCopyTexImage2D glCopyTexSubImage1D glCopyTexSubImage2D glMap1d glMap1f glMap2d glMap2f glGetMapdv glGetMapfv glGetMapiv
- glEvalCoord1d glEvalCoord1f glEvalCoord2d glEvalCoord2f glMapGrid1d glMapGrid1f glMapGrid2d glMapGrid2f glEvalPoint1
- glEvalPoint2 glEvalMesh1 glEvalMesh2 glFogf glFogi glFeedbackBuffer glPassThrough glSelectBuffer glInitNames glLoadName
- glPushName glPopName glDrawRangeElements glTexImage3D glTexSubImage3D glCopyTexSubImage3D glColorTable glColorSubTable
- glCopyColorSubTable glCopyColorTable glGetColorTableParameterfv glGetColorTableParameteriv glBlendEquation glBlendColor
- glHistogram glResetHistogram glGetHistogram glGetHistogramParameterfv glGetHistogramParameteriv glMinmax glResetMinmax
- glGetMinmax glGetMinmaxParameterfv glGetMinmaxParameteriv glConvolutionFilter1D glConvolutionFilter2D glConvolutionParameterf
- glConvolutionParameteri glCopyConvolutionFilter1D glCopyConvolutionFilter2D glSeparableFilter2D ))
- (glu-procs
- (if (defined? 'gluBeginPolygon)
- (list
- gluBeginPolygon gluBuild1DMipmaps gluLookAt gluNewTess gluNextContour gluTessEndContour
- gluBuild2DMipmaps gluDeleteTess gluEndPolygon gluErrorString gluGetString gluGetTessProperty
- gluOrtho2D gluPerspective gluPickMatrix gluProject gluScaleImage gluTessBeginContour gluTessBeginPolygon
- gluTessEndPolygon gluTessNormal gluTessProperty gluTessVertex gluUnProject)
- ())))
-
- ;; ---------------- 1 Arg
+ (when (and (provided? 'snd-motif)
+ (provided? 'gl)
+ (provided? 'xm))
+
+ (with-let (sublet *gl*)
+ (require snd-snd-gl.scm)
+ (gl-info)
+ (if all-args (gl-dump-state))
+ (let ((gl-procs
+ (list
+ glXChooseVisual glXCopyContext glXCreateContext glXCreateGLXPixmap glXDestroyContext glXDestroyGLXPixmap glXGetConfig
+ glXGetCurrentContext glXGetCurrentDrawable glXIsDirect glXMakeCurrent glXQueryExtension glXQueryVersion glXSwapBuffers
+ glXUseXFont glXWaitGL glXWaitX glXGetClientString glXQueryServerString glXQueryExtensionsString glClearIndex glClearColor
+ glClear glIndexMask glColorMask glAlphaFunc glBlendFunc glLogicOp glCullFace glFrontFace glPointSize glLineWidth glLineStipple
+ glPolygonMode glPolygonOffset glPolygonStipple glEdgeFlag glScissor glClipPlane glGetClipPlane
+ glDrawBuffer glReadBuffer glEnable glDisable glIsEnabled glEnableClientState glDisableClientState glGetBooleanv
+ glGetDoublev glGetFloatv glGetIntegerv glPushAttrib glPopAttrib glPushClientAttrib glPopClientAttrib glRenderMode
+ glGetError glGetString glFinish glFlush glHint glClearDepth glDepthFunc glDepthMask glDepthRange glClearAccum glAccum
+ glMatrixMode glOrtho glFrustum glViewport glPushMatrix glPopMatrix glLoadIdentity glLoadMatrixd glLoadMatrixf
+ glMultMatrixd glMultMatrixf glRotated glRotatef glScaled glScalef glTranslated glTranslatef glIsList glDeleteLists
+ glGenLists glNewList glEndList glCallList glCallLists glListBase glBegin glEnd glVertex2d glVertex2f glVertex2i glVertex2s
+ glVertex3d glVertex3f glVertex3i glVertex3s glVertex4d glVertex4f glVertex4i glVertex4s glNormal3b glNormal3d glNormal3f
+ glNormal3i glNormal3s glIndexd glIndexf glIndexi glIndexs glIndexub glColor3b glColor3d glColor3f glColor3i glColor3s
+ glColor3ub glColor3ui glColor3us glColor4b glColor4d glColor4f glColor4i glColor4s glColor4ub glColor4ui glColor4us glTexCoord1d
+ glTexCoord1f glTexCoord1i glTexCoord1s glTexCoord2d glTexCoord2f glTexCoord2i glTexCoord2s glTexCoord3d glTexCoord3f glTexCoord3i
+ glTexCoord3s glTexCoord4d glTexCoord4f glTexCoord4i glTexCoord4s glRasterPos2d glRasterPos2f glRasterPos2i glRasterPos2s
+ glRasterPos3d glRasterPos3f glRasterPos3i glRasterPos3s glRasterPos4d glRasterPos4f glRasterPos4i glRasterPos4s glRectd
+ glRectf glRecti glRects glVertexPointer glNormalPointer glColorPointer glIndexPointer glTexCoordPointer glEdgeFlagPointer
+ glGetPointerv glArrayElement glDrawArrays glDrawElements glInterleavedArrays glShadeModel glLightf glLighti glGetLightfv
+ glGetLightiv glLightModelf glLightModeli glMaterialf glMateriali glGetMaterialfv glGetMaterialiv glColorMaterial glPixelZoom
+ glPixelStoref glPixelStorei glPixelTransferf glPixelTransferi glGetPixelMapfv glGetPixelMapuiv glGetPixelMapusv glBitmap
+ glReadPixels glDrawPixels glCopyPixels glStencilFunc glStencilMask glStencilOp glClearStencil glTexGend glTexGenf glTexGeni
+ glGetTexGendv glGetTexGenfv glGetTexGeniv glTexEnvf glTexEnvi glGetTexEnvfv glGetTexEnviv glTexParameterf glTexParameteri
+ glGetTexParameterfv glGetTexParameteriv glGetTexLevelParameterfv glGetTexLevelParameteriv glTexImage1D glTexImage2D
+ glGenTextures glDeleteTextures glBindTexture glAreTexturesResident glIsTexture glTexSubImage1D glTexSubImage2D glCopyTexImage1D
+ glCopyTexImage2D glCopyTexSubImage1D glCopyTexSubImage2D glMap1d glMap1f glMap2d glMap2f glGetMapdv glGetMapfv glGetMapiv
+ glEvalCoord1d glEvalCoord1f glEvalCoord2d glEvalCoord2f glMapGrid1d glMapGrid1f glMapGrid2d glMapGrid2f glEvalPoint1
+ glEvalPoint2 glEvalMesh1 glEvalMesh2 glFogf glFogi glFeedbackBuffer glPassThrough glSelectBuffer glInitNames glLoadName
+ glPushName glPopName glDrawRangeElements glTexImage3D glTexSubImage3D glCopyTexSubImage3D glColorTable glColorSubTable
+ glCopyColorSubTable glCopyColorTable glGetColorTableParameterfv glGetColorTableParameteriv glBlendEquation glBlendColor
+ glHistogram glResetHistogram glGetHistogram glGetHistogramParameterfv glGetHistogramParameteriv glMinmax glResetMinmax
+ glGetMinmax glGetMinmaxParameterfv glGetMinmaxParameteriv glConvolutionFilter1D glConvolutionFilter2D glConvolutionParameterf
+ glConvolutionParameteri glCopyConvolutionFilter1D glCopyConvolutionFilter2D glSeparableFilter2D ))
+ (glu-procs
+ (if (not (defined? 'gluBeginPolygon))
+ ()
+ (list
+ gluBeginPolygon gluBuild1DMipmaps gluLookAt gluNewTess gluNextContour gluTessEndContour
+ gluBuild2DMipmaps gluDeleteTess gluEndPolygon gluErrorString gluGetString gluGetTessProperty
+ gluOrtho2D gluPerspective gluPickMatrix gluProject gluScaleImage gluTessBeginContour gluTessBeginPolygon
+ gluTessEndPolygon gluTessNormal gluTessProperty gluTessVertex gluUnProject))))
+
+ ;; ---------------- 1 Arg
+ (for-each
+ (lambda (arg)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (n arg))
+ (lambda args (car args))))
+ gl-procs))
+ (list (list 0 1) 0+i))
+
+ (when (pair? glu-procs)
(for-each
(lambda (arg)
(for-each
(lambda (n)
(catch #t
- (lambda () (n arg))
- (lambda args (car args))))
+ (lambda () (n arg))
+ (lambda args (car args))))
gl-procs))
(list (list 0 1) 0+i))
- (if (pair? glu-procs)
- (begin
- (for-each
- (lambda (arg)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (n arg))
- (lambda args (car args))))
- gl-procs))
- (list (list 0 1) 0+i))
-
- (let ((ind (open-sound "oboe.snd")))
- (glXMakeCurrent ((*motif* 'XtDisplay) (cadr (main-widgets)))
- ((*motif* 'XtWindow) (car (channel-widgets)))
- (snd-gl-context))
- (glEnable GL_DEPTH_TEST)
- (glDepthFunc GL_LEQUAL)
- (glClearDepth 1.0)
- (glClearColor 0.0 0.0 0.0 0.0)
- (glLoadIdentity)
- (gluPerspective 40.0 1.0 10.0 200.0)
- (glTranslatef 0.0 0.0 -50.0)
- (glRotatef -58.0 0.0 1.0 0.0)
- (let ((vals ((*motif* 'XtVaGetValues) (car (channel-widgets)) (list (*motif* 'XmNwidth) 0 (*motif* 'XmNheight) 0))))
- (glViewport 0 0 (vals 1) (vals 3)))
- (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
- (glBegin GL_POLYGON)
- (glColor3f 0.0 0.0 0.0) (glVertex3f -10.0 -10.0 0.0)
- (glColor3f 0.7 0.7 0.7) (glVertex3f 10.0 -10.0 0.0)
- (glColor3f 1.0 1.0 1.0) (glVertex3f -10.0 10.0 0.0)
- (glEnd)
- (glBegin GL_POLYGON)
- (glColor3f 1.0 1.0 0.0) (glVertex3f 0.0 -10.0 -10.0)
- (glColor3f 0.0 1.0 0.7) (glVertex3f 0.0 -10.0 10.0)
- (glColor3f 0.0 0.0 1.0) (glVertex3f 0.0 5.0 -10.0)
- (glEnd)
- (glBegin GL_POLYGON)
- (glColor3f 1.0 1.0 0.0) (glVertex3f -10.0 6.0 4.0)
- (glColor3f 1.0 0.0 1.0) (glVertex3f -10.0 3.0 4.0)
- (glColor3f 0.0 0.0 1.0) (glVertex3f 4.0 -9.0 -10.0)
- (glColor3f 1.0 0.0 1.0) (glVertex3f 4.0 -6.0 -10.0)
- (glEnd)
- (glXSwapBuffers ((*motif* 'XtDisplay) (cadr (main-widgets)))
- ((*motif* 'XtWindow) (car (channel-widgets))))
- (glFlush)
- (close-sound ind)))))
- )))
+ (let ((ind (open-sound "oboe.snd")))
+ (glXMakeCurrent ((*motif* 'XtDisplay) (cadr (main-widgets)))
+ ((*motif* 'XtWindow) (car (channel-widgets)))
+ (snd-gl-context))
+ (glEnable GL_DEPTH_TEST)
+ (glDepthFunc GL_LEQUAL)
+ (glClearDepth 1.0)
+ (glClearColor 0.0 0.0 0.0 0.0)
+ (glLoadIdentity)
+ (gluPerspective 40.0 1.0 10.0 200.0)
+ (glTranslatef 0.0 0.0 -50.0)
+ (glRotatef -58.0 0.0 1.0 0.0)
+ (let ((vals ((*motif* 'XtVaGetValues) (car (channel-widgets)) (list (*motif* 'XmNwidth) 0 (*motif* 'XmNheight) 0))))
+ (glViewport 0 0 (vals 1) (vals 3)))
+ (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+ (glBegin GL_POLYGON)
+ (glColor3f 0.0 0.0 0.0) (glVertex3f -10.0 -10.0 0.0)
+ (glColor3f 0.7 0.7 0.7) (glVertex3f 10.0 -10.0 0.0)
+ (glColor3f 1.0 1.0 1.0) (glVertex3f -10.0 10.0 0.0)
+ (glEnd)
+ (glBegin GL_POLYGON)
+ (glColor3f 1.0 1.0 0.0) (glVertex3f 0.0 -10.0 -10.0)
+ (glColor3f 0.0 1.0 0.7) (glVertex3f 0.0 -10.0 10.0)
+ (glColor3f 0.0 0.0 1.0) (glVertex3f 0.0 5.0 -10.0)
+ (glEnd)
+ (glBegin GL_POLYGON)
+ (glColor3f 1.0 1.0 0.0) (glVertex3f -10.0 6.0 4.0)
+ (glColor3f 1.0 0.0 1.0) (glVertex3f -10.0 3.0 4.0)
+ (glColor3f 0.0 0.0 1.0) (glVertex3f 4.0 -9.0 -10.0)
+ (glColor3f 1.0 0.0 1.0) (glVertex3f 4.0 -6.0 -10.0)
+ (glEnd)
+ (glXSwapBuffers ((*motif* 'XtDisplay) (cadr (main-widgets)))
+ ((*motif* 'XtWindow) (car (channel-widgets))))
+ (glFlush)
+ (close-sound ind)))))))
(if (and with-gui
(provided? 'xm)
@@ -47448,1506 +46590,1422 @@ EDITS: 1
;;; ---------------- test 25: errors ----------------
-(define-macro (simple-time a)
- `(let ((start (get-internal-real-time)))
- ,a
- (- (get-internal-real-time) start)))
-
-
(define (snd_test_25)
- (define (traced a) (+ 2 a))
-
- (define (extract-channel filename snd chn)
- (save-sound-as filename snd :channel chn))
-
- (define* (extract-channels :rest chans)
- ;; extract a list of channels from the current sound and save as test.snd: (extract-channels 0 2)
- (let ((snd (or (selected-sound) (car (sounds)))))
- (if (sound? snd)
- (begin
- (for-each
- (lambda (chan)
- (set! (selection-member? snd chan) #t)
- (set! (selection-position snd chan) 0)
- (set! (selection-framples snd chan) (framples snd chan)))
- chans)
- (save-selection "test.snd")))))
-
- (define notch-out-rumble-and-hiss
- (let ((documentation "(notch-out-rumble-and-hiss s c) applies a bandpass filter with cutoffs at 40 Hz and 3500 Hz"))
- (lambda* (snd chn)
- (let ((cur-srate (* 1.0 (srate snd))))
- (filter-sound
- (list 0.0 0.0 ; get rid of DC
- (/ 80.0 cur-srate) 0.0 ; get rid of anything under 40 Hz (1.0=srate/2 here)
- (/ 90.0 cur-srate) 1.0 ; now the passband
- (/ 7000.0 cur-srate) 1.0
- (/ 8000.0 cur-srate) 0.0 ; end passband (40..4000)
- 1.0 0.0) ; get rid of some of the hiss
- ;; since the minimum band is 10 Hz here,
- ;; cur-srate/10 rounded up to next power of 2 seems a safe filter size
- ;; filter-sound will actually use overlap-add convolution in this case
- (expt 2 (ceiling (log (/ cur-srate 10.0) 2.0)))
- snd chn)))))
-
- (define* (reverse-channels snd)
- (let* ((ind (or snd (selected-sound) (car (sounds))))
- (chns (chans ind)))
- (let ((swaps (floor (/ chns 2))))
- (as-one-edit
- (lambda ()
- (do ((i 0 (+ i 1))
- (j (- chns 1) (- j 1)))
- ((= i swaps))
- (swap-channels ind i ind j)))))))
-
- (define* (rotate-channel (samps 1) snd chn)
- (let ((ind (or snd (selected-sound) (car (sounds))))
- (chan (or chn (selected-channel) 0)))
- (let ((reg (make-region 0 (- samps 1) ind chan)))
- (as-one-edit
- (lambda ()
- (delete-samples 0 samps ind chan)
- (insert-region reg (framples ind chan))))
- (forget-region reg))))
-
- (define (randomize-list lst)
- (let* ((len (length lst))
- (vals (make-vector len #f))
- (nlst ()))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (let ((loc (random len)))
- (if (vector-ref vals loc)
- (do ((j 0 (+ j 1)))
- ((or (= j len)
- (not (vector-ref vals j)))
- (set! (vals j) (car lst))))
- (set! (vals loc) (car lst)))
- (set! lst (cdr lst))))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (set! nlst (cons (vector-ref vals i) nlst)))
- nlst))
-
(define (check-error-tag expected-tag thunk)
(let ((tag
(catch #t
thunk
(lambda args args))))
- (if (or (and (not (list? tag))
- (not (pair? tag)))
- (not (eq? (car tag) expected-tag)))
- (snd-display #__line__ ";check-error-tag ~A from ~A: ~A"
+ (if (not (and (pair? tag)
+ (eq? (car tag) expected-tag)))
+ (snd-display ";check-error-tag ~A from ~A: ~A"
expected-tag (procedure-source thunk) tag))))
(set! *with-background-processes* #t)
(set! *remember-sound-state* #f)
- (if with-gui
- (let* ((delay-32 (make-delay 32))
- (color-95 (make-color-with-catch .95 .95 .95))
- (vector-0 (make-vector 0))
- (str-3 "/hiho")
- (float-vector-3 (make-float-vector 3))
- (float-vector-5 (make-float-vector 5))
- (car-main (and with-gui (car (main-widgets))))
- (cadr-main (and with-gui (cadr (main-widgets))))
- (a-hook (make-hook 'a 'b))
- (exts (sound-file-extensions)) ; save across possible set below
-
- (procs (list
- add-mark add-sound-file-extension add-source-file-extension sound-file-extensions sound-file?
- add-to-main-menu add-to-menu add-transform amp-control ask-about-unsaved-edits
- as-one-edit ask-before-overwrite
- auto-resize auto-update autocorrelate axis-color axis-info axis-label-font axis-numbers-font
- basic-color bind-key apply-controls change-samples-with-origin channel-style
- channel-widgets channels chans peaks-font bold-peaks-font close-sound combined-data-color
- color-cutoff color-orientation-dialog colormap-ref add-colormap delete-colormap colormap-size colormap-name colormap?
- color-inverted color-scale color->list colormap color? comment contrast-control contrast-control-amp
- contrast-control? convolve-selection-with convolve-with channel-properties channel-property controls->channel
- amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
- reverb-control-length-bounds reverb-control-scale-bounds cursor-update-interval cursor-location-offset
- auto-update-interval current-font cursor cursor-color with-tracking-cursor cursor-size
- cursor-style tracking-cursor-style dac-combines-channels dac-size clipping data-color sample-type data-location data-size
- default-output-chans default-output-sample-type default-output-srate default-output-header-type define-envelope
- delete-mark delete-marks forget-region delete-sample delete-samples delete-samples-and-smooth
- delete-selection delete-selection-and-smooth dialog-widgets display-edits dot-size draw-dot draw-dots draw-line
- draw-lines draw-string edit-header-dialog edit-fragment edit-list->function edit-position edit-tree edits env-selection
- env-sound enved-envelope enved-base enved-clip? enved-in-dB enved-dialog enved-style enved-power
- enved-target enved-waveform-color enved-wave? eps-file eps-left-margin
- eps-bottom-margin eps-size expand-control expand-control-hop expand-control-jitter expand-control-length expand-control-ramp
- expand-control? fft fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size disk-kspace
- transform-graph-type fft-window transform-graph? mix-file-dialog file-name fill-polygon
- fill-rectangle filter-sound filter-control-in-dB filter-control-envelope enved-filter-order enved-filter
- filter-control-in-hz filter-control-order filter-selection filter-channel filter-control-waveform-color filter-control?
- find-mark find-sound finish-progress-report foreground-color insert-file-dialog file-write-date
- framples free-sampler graph transform? delete-transform
- graph-color graph-cursor graph-data graph->ps gl-graph->ps graph-style lisp-graph? graphs-horizontal header-type
- help-dialog info-dialog highlight-color insert-region insert-sample insert-samples
- insert-samples-with-origin insert-selection insert-silence insert-sound just-sounds key key-binding
- left-sample listener-color listener-font listener-prompt listener-selection listener-text-color
- main-widgets make-color make-graph-data make-mix-sampler make-player make-region
- make-region-sampler make-sampler mark-color mark-name mark-properties mark-property
- mark-sample mark-sync mark-sync-max mark-home marks mark? max-transform-peaks max-regions
- maxamp maxamp-position menu-widgets min-dB log-freq-start mix mixes mix-amp mix-amp-env
- mix-color mix-length mix? view-mixes-dialog mix-position
- mix-dialog-mix mix-name mix-sync-max mix-sync mix-properties mix-property
- mix-region mix-sampler? mix-selection mix-sound mix-home mix-speed mix-tag-height mix-tag-width mark-tag-height mark-tag-width
- mix-tag-y mix-float-vector mix-waveform-height time-graph-style lisp-graph-style transform-graph-style
+ (define (set-arity-ok func args)
+ (let ((arit (if (dilambda? func)
+ (arity (procedure-setter func))
+ (and (procedure? (procedure-setter func))
+ (arity (procedure-setter func))))))
+ (and (pair? arit)
+ (>= args (car arit))
+ (<= args (cdr arit)))))
+
+ (when with-gui ; to the end!
+ (let* ((delay-32 (make-delay 32))
+ (color-95 (make-color-with-catch .95 .95 .95))
+ (vector-0 #())
+ (str-3 "/hiho")
+ (float-vector-3 (make-float-vector 3))
+ (float-vector-5 (make-float-vector 5))
+ (car-main (and with-gui (car (main-widgets))))
+ (cadr-main (and with-gui (cadr (main-widgets))))
+ (a-hook (make-hook 'a 'b))
+ (exts (sound-file-extensions)) ; save across possible set below
+
+ (procs (list
+ add-mark add-sound-file-extension add-source-file-extension sound-file-extensions sound-file?
+ add-to-main-menu add-to-menu add-transform amp-control ask-about-unsaved-edits
+ as-one-edit ask-before-overwrite
+ auto-resize auto-update autocorrelate axis-color axis-info axis-label-font axis-numbers-font
+ basic-color bind-key apply-controls change-samples-with-origin channel-style
+ channel-widgets channels chans peaks-font bold-peaks-font close-sound combined-data-color
+ color-cutoff color-orientation-dialog colormap-ref add-colormap delete-colormap colormap-size colormap-name colormap?
+ color-inverted color-scale color->list colormap color? comment contrast-control contrast-control-amp
+ contrast-control? convolve-selection-with convolve-with channel-properties channel-property controls->channel
+ amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
+ reverb-control-length-bounds reverb-control-scale-bounds cursor-update-interval cursor-location-offset
+ auto-update-interval current-font cursor cursor-color with-tracking-cursor cursor-size
+ cursor-style tracking-cursor-style dac-combines-channels dac-size clipping data-color sample-type data-location data-size
+ default-output-chans default-output-sample-type default-output-srate default-output-header-type define-envelope
+ delete-mark delete-marks forget-region delete-sample delete-samples delete-samples-and-smooth
+ delete-selection delete-selection-and-smooth dialog-widgets display-edits dot-size draw-dot draw-dots draw-line
+ draw-lines draw-string edit-header-dialog edit-fragment edit-list->function edit-position edit-tree edits env-selection
+ env-sound enved-envelope enved-base enved-clip? enved-in-dB enved-dialog enved-style enved-power
+ enved-target enved-waveform-color enved-wave? eps-file eps-left-margin
+ eps-bottom-margin eps-size expand-control expand-control-hop expand-control-jitter expand-control-length expand-control-ramp
+ expand-control? fft fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size disk-kspace
+ transform-graph-type fft-window transform-graph? mix-file-dialog file-name fill-polygon
+ fill-rectangle filter-sound filter-control-in-dB filter-control-envelope enved-filter-order enved-filter
+ filter-control-in-hz filter-control-order filter-selection filter-channel filter-control-waveform-color filter-control?
+ find-mark find-sound finish-progress-report foreground-color insert-file-dialog file-write-date
+ framples free-sampler graph transform? delete-transform
+ graph-color graph-cursor graph-data graph->ps gl-graph->ps graph-style lisp-graph? graphs-horizontal header-type
+ help-dialog info-dialog highlight-color insert-region insert-sample insert-samples
+ insert-samples-with-origin insert-selection insert-silence insert-sound just-sounds key key-binding
+ left-sample listener-color listener-font listener-prompt listener-selection listener-text-color
+ main-widgets make-color make-graph-data make-mix-sampler make-player make-region
+ make-region-sampler make-sampler mark-color mark-name mark-properties mark-property
+ mark-sample mark-sync mark-sync-max mark-home marks mark? max-transform-peaks max-regions
+ maxamp maxamp-position menu-widgets min-dB log-freq-start mix mixes mix-amp mix-amp-env
+ mix-color mix-length mix? view-mixes-dialog mix-position
+ mix-dialog-mix mix-name mix-sync-max mix-sync mix-properties mix-property
+ mix-region mix-sampler? mix-selection mix-sound mix-home mix-speed mix-tag-height mix-tag-width mark-tag-height mark-tag-width
+ mix-tag-y mix-float-vector mix-waveform-height time-graph-style lisp-graph-style transform-graph-style
;new-sound in
- read-mix-sample next-sample read-region-sample show-full-duration show-full-range initial-beg initial-dur
- transform-normalization open-file-dialog-directory open-raw-sound open-sound previous-sample
- peaks player? players play-arrow-size
- position-color position->x position->y
- print-length progress-report read-only read-sample-with-direction
- redo region-chans view-regions-dialog region-home
- region-graph-style region-framples region-position region-maxamp region-maxamp-position remember-sound-state
- selection-maxamp selection-maxamp-position region-sample region->float-vector
- region-srate regions region? remove-from-menu status-report reset-controls restore-controls
- restore-region reverb-control-decay reverb-control-feedback
- reverb-control-length reverb-control-lowpass reverb-control-scale reverb-control? reverse-sound
- reverse-selection revert-sound right-sample sample sampler-at-end? sampler? samples sampler-position
- sash-color save-controls ladspa-dir peak-env-dir save-dir save-edit-history save-envelopes
- save-listener save-marks save-region save-selection save-sound save-sound-as
- save-state save-state-file scale-by scale-selection-by scale-selection-to scale-to
- search-procedure select-all select-channel select-sound
- selected-channel selected-data-color selected-graph-color selected-sound
- selection-position selection-color selection-creates-region selection-framples selection-member? selection?
- short-file-name show-axes show-controls show-transform-peaks show-indices show-listener show-selection unselect-all
- show-marks show-mix-waveforms show-selection-transform show-y-zero sinc-width show-grid show-sonogram-cursor grid-density
- smooth-sound smooth-selection snd-print snd-spectrum snd-tempnam snd-version sound-files-in-directory
- sound-loop-info sound-widgets soundfont-info sound? sounds spectrum-end spectro-hop spectrum-start
- spectro-x-angle spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale
- speed-control speed-control-style speed-control-tones squelch-update srate src-sound src-selection
+ read-mix-sample next-sample read-region-sample show-full-duration show-full-range initial-beg initial-dur
+ transform-normalization open-file-dialog-directory open-raw-sound open-sound previous-sample
+ peaks player? players play-arrow-size
+ position-color position->x position->y
+ print-length progress-report read-only read-sample-with-direction
+ redo region-chans view-regions-dialog region-home
+ region-graph-style region-framples region-position region-maxamp region-maxamp-position remember-sound-state
+ selection-maxamp selection-maxamp-position region-sample region->float-vector
+ region-srate regions region? remove-from-menu status-report reset-controls restore-controls
+ restore-region reverb-control-decay reverb-control-feedback
+ reverb-control-length reverb-control-lowpass reverb-control-scale reverb-control? reverse-sound
+ reverse-selection revert-sound right-sample sample sampler-at-end? sampler? samples sampler-position
+ sash-color save-controls ladspa-dir peak-env-dir save-dir save-edit-history save-envelopes
+ save-listener save-marks save-region save-selection save-sound save-sound-as
+ save-state save-state-file scale-by scale-selection-by scale-selection-to scale-to
+ search-procedure select-all select-channel select-sound
+ selected-channel selected-data-color selected-graph-color selected-sound
+ selection-position selection-color selection-creates-region selection-framples selection-member? selection?
+ short-file-name show-axes show-controls show-transform-peaks show-indices show-listener show-selection unselect-all
+ show-marks show-mix-waveforms show-selection-transform show-y-zero sinc-width show-grid show-sonogram-cursor grid-density
+ smooth-sound smooth-selection snd-print snd-spectrum snd-tempnam snd-version sound-files-in-directory
+ sound-loop-info sound-widgets soundfont-info sound? sounds spectrum-end spectro-hop spectrum-start
+ spectro-x-angle spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale
+ speed-control speed-control-style speed-control-tones squelch-update srate src-sound src-selection
;start-playing
- start-progress-report stop-player stop-playing swap-channels syncd-marks sync sync-max sound-properties sound-property temp-dir
- text-focus-color tiny-font region-sampler? transform-dialog transform-sample
- transform->float-vector transform-framples transform-type with-file-monitor unbind-key undo
- update-transform-graph update-time-graph update-lisp-graph update-sound clm-table-size clm-default-frequency
- with-verbose-cursor view-sound wavelet-type with-inset-graph with-interrupts with-pointer-focus with-smpte-label
- with-toolbar with-tooltips with-menu-icons save-as-dialog-src save-as-dialog-auto-comment
- time-graph? time-graph-type wavo-hop wavo-trace window-height window-width window-x window-y
- with-mix-tags with-relative-panes with-gl x-axis-style beats-per-measure
- beats-per-minute x-bounds x-position-slider x->position x-zoom-slider mus-header-type->string mus-sample-type->string
- y-bounds y-position-slider y->position y-zoom-slider zero-pad zoom-color zoom-focus-style sync-style mus-set-formant-radius-and-frequency
- mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size mus-sound-data-location data-size
- mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type mus-sound-length
- mus-sound-type-specifier mus-header-type-name mus-sample-type-name mus-sound-comment mus-sound-write-date
- mus-bytes-per-sample mus-sound-loop-info mus-sound-mark-info
+ start-progress-report stop-player stop-playing swap-channels syncd-marks sync sync-max sound-properties sound-property stdin-prompt
+ temp-dir text-focus-color tiny-font region-sampler? transform-dialog transform-sample
+ transform->float-vector transform-framples transform-type with-file-monitor unbind-key undo
+ update-transform-graph update-time-graph update-lisp-graph update-sound clm-table-size clm-default-frequency
+ with-verbose-cursor view-sound wavelet-type with-inset-graph with-interrupts with-pointer-focus with-smpte-label
+ with-toolbar with-tooltips with-menu-icons save-as-dialog-src save-as-dialog-auto-comment
+ time-graph? time-graph-type wavo-hop wavo-trace window-height window-width window-x window-y
+ with-mix-tags with-relative-panes with-gl x-axis-style beats-per-measure
+ beats-per-minute x-bounds x-position-slider x->position x-zoom-slider mus-header-type->string mus-sample-type->string
+ y-bounds y-position-slider y->position y-zoom-slider zero-pad zoom-color zoom-focus-style sync-style mus-set-formant-radius-and-frequency
+ mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size mus-sound-data-location data-size
+ mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type mus-sound-length
+ mus-sound-type-specifier mus-header-type-name mus-sample-type-name mus-sound-comment mus-sound-write-date
+ mus-bytes-per-sample mus-sound-loop-info mus-sound-mark-info
;mus-alsa-buffers mus-alsa-buffer-size mus-apply
- mus-alsa-squelch-warning
+ mus-alsa-squelch-warning
;mus-alsa-device mus-alsa-playback-device mus-alsa-capture-device
- mus-sound-maxamp mus-sound-maxamp-exists?
- mus-clipping mus-file-clipping mus-header-raw-defaults
- moving-average moving-average? make-moving-average moving-max moving-max? make-moving-max
- make-moving-norm moving-norm moving-norm? mus-expand-filename
- all-pass all-pass? amplitude-modulate
- array->file array-interp mus-interpolate asymmetric-fm asymmetric-fm?
- comb comb? filtered-comb filtered-comb? contrast-enhancement convolution convolve convolve? db->linear degrees->radians
- delay delay? dot-product env env-interp env? file->array file->frample file->frample? file->sample
- even-multiple even-weight odd-multiple odd-weight
- file->sample? filter filter? fir-filter fir-filter? formant formant-bank formant-bank? formant? firmant firmant?
- comb-bank make-comb-bank comb-bank? all-pass-bank make-all-pass-bank all-pass-bank? filtered-comb-bank make-filtered-comb-bank filtered-comb-bank?
- granulate granulate? hz->radians iir-filter iir-filter? linear->db locsig ; in-any ina inb
- locsig-ref locsig-reverb-ref locsig-reverb-set! locsig-set! locsig? make-all-pass make-asymmetric-fm
- make-comb make-filtered-comb make-convolve make-delay make-env make-fft-window make-file->frample
- make-file->sample make-filter make-fir-filter make-formant make-firmant make-frample->file make-granulate
- make-iir-filter make-locsig move-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil
- make-pulse-train make-rand make-rand-interp make-readin make-sample->file make-sawtooth-wave
- make-nrxysin make-nrxycos make-square-wave make-src make-ncos make-rxyk!cos make-rxyk!sin
- make-nsin make-ssb-am make-table-lookup make-triangle-wave
- make-two-pole make-two-zero make-wave-train
- move-sound make-move-sound move-sound? mus-float-equal-fudge-factor
- mus-array-print-length mus-channel mus-channels make-polyshape polyshape polyshape? make-polywave polywave polywave?
- mus-close mus-data mus-feedback mus-feedforward mus-fft mus-frequency
- mus-hop mus-increment mus-input? mus-file-name mus-length mus-location mus-file-mix mus-order mus-output? mus-phase
- mus-ramp mus-random mus-scaler mus-srate mus-xcoeff mus-xcoeffs mus-ycoeff mus-ycoeffs
- notch notch? one-pole one-pole? one-pole-all-pass one-pole-all-pass?
- one-zero one-zero? oscil oscil? out-any outa outb outc outd partials->polynomial normalize-partials
- partials->wave phase-partials->wave polynomial pulse-train pulse-train?
- radians->degrees radians->hz rand rand-interp rand-interp? rand? readin readin? rectangular->polar rectangular->magnitudes
- ring-modulate sample->file sample->file? sawtooth-wave
- sawtooth-wave? nrxysin nrxysin? nrxycos nrxycos? rxyk!cos rxyk!cos? rxyk!sin rxyk!sin?
- spectrum square-wave square-wave? src src? ncos nsin ssb-am
- ncos? nsin? ssb-am? table-lookup table-lookup? tap tap? triangle-wave triangle-wave? two-pole two-pole? two-zero
- two-zero? wave-train wave-train? make-float-vector float-vector-add! float-vector-subtract!
- float-vector-multiply! float-vector-offset! float-vector-ref float-vector-scale! float-vector-set! float-vector-peak float-vector-max float-vector-min
- float-vector? float-vector-move! float-vector-subseq float-vector little-endian? float-vector->string
- clm-channel env-channel env-channel-with-base map-channel scan-channel
- reverse-channel seconds->samples samples->seconds
- smooth-channel float-vector->channel channel->float-vector src-channel scale-channel ramp-channel pad-channel normalize-channel
- cursor-position clear-listener mus-sound-prune mus-sound-forget xramp-channel
- snd->sample snd->sample? make-snd->sample
-
- beats-per-minute beats-per-measure channel-amp-envs convolve-files filter-control-coeffs
- locsig-type make-phase-vocoder
- mus-describe mus-error-type->string mus-file-buffer-size mus-name mus-offset mus-out-format mus-reset
- mus-rand-seed mus-width phase-vocoder?
- polar->rectangular phase-vocoder-amp-increments phase-vocoder-amps phase-vocoder-freqs
- phase-vocoder-phase-increments phase-vocoder-phases mus-generator?
-
- read-sample reset-listener-cursor goto-listener-end sampler-home selection-chans selection-srate snd-gcs snd-font snd-color
- snd-warning x-axis-label variable-graph? y-axis-label
- snd-url snd-urls free-player
-
- delay-tick playing pausing draw-axes copy-sampler html-dir html-program
- make-fir-coeffs mus-interp-type mus-run phase-vocoder
- player-home redo-edit undo-edit widget-position widget-size
- focus-widget
- ))
-
- (set-procs (list
- amp-control ask-about-unsaved-edits ask-before-overwrite auto-resize
- auto-update axis-color axis-label-font axis-numbers-font ;basic-color
- channel-style peaks-font bold-peaks-font sound-file-extensions show-full-duration show-full-range initial-beg initial-dur
- color-cutoff color-inverted color-scale contrast-control contrast-control-amp combined-data-color
- amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
- reverb-control-length-bounds reverb-control-scale-bounds cursor-update-interval cursor-location-offset
- contrast-control? auto-update-interval current-font cursor cursor-color channel-properties channel-property
- with-tracking-cursor cursor-size cursor-style tracking-cursor-style dac-combines-channels dac-size clipping data-color
- default-output-chans default-output-sample-type default-output-srate default-output-header-type dot-size
- enved-envelope enved-base enved-clip? enved-in-dB enved-style enved-power
- enved-target enved-waveform-color enved-wave? eps-file eps-left-margin eps-bottom-margin eps-size
- expand-control expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control?
- fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window
- transform-graph? filter-control-in-dB filter-control-envelope enved-filter-order enved-filter
- filter-control-in-hz filter-control-order filter-control-waveform-color filter-control? foreground-color
- graph-color graph-cursor graph-style lisp-graph? graphs-horizontal highlight-color
- just-sounds left-sample listener-color listener-font listener-prompt listener-text-color mark-color
- mark-name mark-properties mark-property mark-sample mark-sync max-transform-peaks max-regions min-dB log-freq-start mix-amp
- mix-amp-env mix-color mix-name mix-position mix-sync mix-properties mix-property
- mix-speed mix-tag-height mix-tag-width mix-tag-y mark-tag-width mark-tag-height
- mix-waveform-height transform-normalization open-file-dialog-directory
- position-color print-length play-arrow-size
- region-graph-style reverb-control-decay reverb-control-feedback
- reverb-control-length reverb-control-lowpass reverb-control-scale time-graph-style lisp-graph-style transform-graph-style
- reverb-control? sash-color ladspa-dir peak-env-dir save-dir save-state-file selected-data-color selected-graph-color
- selection-color selection-creates-region show-axes show-controls
- show-transform-peaks show-indices show-marks show-mix-waveforms show-selection-transform show-listener
- show-y-zero show-grid show-sonogram-cursor sinc-width spectrum-end spectro-hop spectrum-start spectro-x-angle grid-density
- spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale speed-control
- speed-control-style speed-control-tones squelch-update sync sound-properties sound-property temp-dir text-focus-color tiny-font y-bounds
- transform-type with-file-monitor with-verbose-cursor
- with-inset-graph with-interrupts with-pointer-focus wavelet-type x-bounds with-smpte-label
- with-toolbar with-tooltips with-menu-icons save-as-dialog-src save-as-dialog-auto-comment
- time-graph? wavo-hop wavo-trace with-gl with-mix-tags x-axis-style beats-per-minute zero-pad zoom-color zoom-focus-style sync-style
- with-relative-panes window-x window-y window-width window-height mix-dialog-mix beats-per-measure
- channels chans colormap comment sample-type data-location data-size edit-position framples header-type maxamp
- read-only right-sample sample samples selected-channel colormap-size colormap?
- selected-sound selection-position selection-framples selection-member? sound-loop-info
- srate time-graph-type x-position-slider x-zoom-slider
- y-position-slider y-zoom-slider mus-array-print-length mus-float-equal-fudge-factor
+ mus-sound-maxamp mus-sound-maxamp-exists?
+ mus-clipping mus-file-clipping mus-header-raw-defaults
+ moving-average moving-average? make-moving-average moving-max moving-max? make-moving-max
+ make-moving-norm moving-norm moving-norm? mus-expand-filename
+ all-pass all-pass? amplitude-modulate
+ array->file array-interp mus-interpolate asymmetric-fm asymmetric-fm?
+ comb comb? filtered-comb filtered-comb? contrast-enhancement convolution convolve convolve? db->linear degrees->radians
+ delay delay? dot-product env env-interp env? file->array file->frample file->frample? file->sample
+ even-multiple even-weight odd-multiple odd-weight
+ file->sample? filter filter? fir-filter fir-filter? formant formant-bank formant-bank? formant? firmant firmant?
+ comb-bank make-comb-bank comb-bank? all-pass-bank make-all-pass-bank all-pass-bank? filtered-comb-bank make-filtered-comb-bank filtered-comb-bank?
+ granulate granulate? hz->radians iir-filter iir-filter? linear->db locsig ; in-any ina inb
+ locsig-ref locsig-reverb-ref locsig-reverb-set! locsig-set! locsig? make-all-pass make-asymmetric-fm
+ make-comb make-filtered-comb make-convolve make-delay make-env make-fft-window make-file->frample
+ make-file->sample make-filter make-fir-filter make-formant make-firmant make-frample->file make-granulate
+ make-iir-filter make-locsig move-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil
+ make-pulse-train make-rand make-rand-interp make-readin make-sample->file make-sawtooth-wave
+ make-nrxysin make-nrxycos make-square-wave make-src make-ncos make-rxyk!cos make-rxyk!sin
+ make-nsin make-ssb-am make-table-lookup make-triangle-wave
+ make-two-pole make-two-zero make-wave-train
+ move-sound make-move-sound move-sound? mus-float-equal-fudge-factor
+ mus-array-print-length mus-channel mus-channels make-polyshape polyshape polyshape? make-polywave polywave polywave?
+ mus-close mus-data mus-feedback mus-feedforward mus-fft mus-frequency
+ mus-hop mus-increment mus-input? mus-file-name mus-length mus-location mus-file-mix mus-order mus-output? mus-phase
+ mus-ramp mus-random mus-scaler mus-srate mus-xcoeff mus-xcoeffs mus-ycoeff mus-ycoeffs
+ notch notch? one-pole one-pole? one-pole-all-pass one-pole-all-pass?
+ one-zero one-zero? oscil oscil? out-any outa outb outc outd partials->polynomial normalize-partials
+ partials->wave phase-partials->wave polynomial pulse-train pulse-train?
+ radians->degrees radians->hz rand rand-interp rand-interp? rand? readin readin? rectangular->polar rectangular->magnitudes
+ ring-modulate sample->file sample->file? sawtooth-wave
+ sawtooth-wave? nrxysin nrxysin? nrxycos nrxycos? rxyk!cos rxyk!cos? rxyk!sin rxyk!sin?
+ spectrum square-wave square-wave? src src? ncos nsin ssb-am
+ ncos? nsin? ssb-am? table-lookup table-lookup? tap tap? triangle-wave triangle-wave? two-pole two-pole? two-zero
+ two-zero? wave-train wave-train? make-float-vector float-vector-add! float-vector-subtract!
+ float-vector-multiply! float-vector-offset! float-vector-ref float-vector-scale!
+ float-vector-set! float-vector-peak float-vector-max float-vector-min
+ float-vector? float-vector-move! float-vector-subseq float-vector little-endian? float-vector->string
+ clm-channel env-channel env-channel-with-base map-channel scan-channel
+ reverse-channel seconds->samples samples->seconds
+ smooth-channel float-vector->channel channel->float-vector src-channel scale-channel ramp-channel pad-channel normalize-channel
+ cursor-position clear-listener mus-sound-prune mus-sound-forget xramp-channel
+ snd->sample snd->sample? make-snd->sample
+
+ beats-per-minute beats-per-measure channel-amp-envs convolve-files filter-control-coeffs
+ locsig-type make-phase-vocoder
+ mus-describe mus-error-type->string mus-file-buffer-size mus-name mus-offset mus-out-format mus-reset
+ mus-rand-seed mus-width phase-vocoder?
+ polar->rectangular phase-vocoder-amp-increments phase-vocoder-amps phase-vocoder-freqs
+ phase-vocoder-phase-increments phase-vocoder-phases mus-generator?
+
+ read-sample reset-listener-cursor goto-listener-end sampler-home selection-chans selection-srate snd-gcs snd-font snd-color
+ snd-warning x-axis-label variable-graph? y-axis-label
+ snd-url snd-urls free-player
+
+ delay-tick playing pausing draw-axes copy-sampler html-dir html-program
+ make-fir-coeffs mus-interp-type mus-run phase-vocoder
+ player-home redo-edit undo-edit widget-position widget-size
+ focus-widget
+ ))
+
+ (set-procs (list
+ amp-control ask-about-unsaved-edits ask-before-overwrite auto-resize
+ auto-update axis-color axis-label-font axis-numbers-font ;basic-color
+ channel-style peaks-font bold-peaks-font sound-file-extensions show-full-duration show-full-range initial-beg initial-dur
+ color-cutoff color-inverted color-scale contrast-control contrast-control-amp combined-data-color
+ amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
+ reverb-control-length-bounds reverb-control-scale-bounds cursor-update-interval cursor-location-offset
+ contrast-control? auto-update-interval current-font cursor cursor-color channel-properties channel-property
+ with-tracking-cursor cursor-size cursor-style tracking-cursor-style dac-combines-channels dac-size clipping data-color
+ default-output-chans default-output-sample-type default-output-srate default-output-header-type dot-size
+ enved-envelope enved-base enved-clip? enved-in-dB enved-style enved-power
+ enved-target enved-waveform-color enved-wave? eps-file eps-left-margin eps-bottom-margin eps-size
+ expand-control expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control?
+ fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window
+ transform-graph? filter-control-in-dB filter-control-envelope enved-filter-order enved-filter
+ filter-control-in-hz filter-control-order filter-control-waveform-color filter-control? foreground-color
+ graph-color graph-cursor graph-style lisp-graph? graphs-horizontal highlight-color
+ just-sounds left-sample listener-color listener-font listener-prompt listener-text-color mark-color
+ mark-name mark-properties mark-property mark-sample mark-sync max-transform-peaks max-regions min-dB log-freq-start mix-amp
+ mix-amp-env mix-color mix-name mix-position mix-sync mix-properties mix-property
+ mix-speed mix-tag-height mix-tag-width mix-tag-y mark-tag-width mark-tag-height
+ mix-waveform-height transform-normalization open-file-dialog-directory
+ position-color print-length play-arrow-size
+ region-graph-style reverb-control-decay reverb-control-feedback
+ reverb-control-length reverb-control-lowpass reverb-control-scale time-graph-style lisp-graph-style transform-graph-style
+ reverb-control? sash-color ladspa-dir peak-env-dir save-dir save-state-file selected-data-color selected-graph-color
+ selection-color selection-creates-region show-axes show-controls
+ show-transform-peaks show-indices show-marks show-mix-waveforms show-selection-transform show-listener
+ show-y-zero show-grid show-sonogram-cursor sinc-width spectrum-end spectro-hop spectrum-start spectro-x-angle grid-density
+ spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale speed-control
+ speed-control-style speed-control-tones squelch-update sync sound-properties sound-property stdin-prompt
+ temp-dir text-focus-color tiny-font y-bounds
+ transform-type with-file-monitor with-verbose-cursor
+ with-inset-graph with-interrupts with-pointer-focus wavelet-type x-bounds with-smpte-label
+ with-toolbar with-tooltips with-menu-icons save-as-dialog-src save-as-dialog-auto-comment
+ time-graph? wavo-hop wavo-trace with-gl with-mix-tags x-axis-style beats-per-minute zero-pad zoom-color zoom-focus-style sync-style
+ with-relative-panes window-x window-y window-width window-height mix-dialog-mix beats-per-measure
+ channels chans colormap comment sample-type data-location data-size edit-position framples header-type maxamp
+ read-only right-sample sample samples selected-channel colormap-size colormap?
+ selected-sound selection-position selection-framples selection-member? sound-loop-info
+ srate time-graph-type x-position-slider x-zoom-slider
+ y-position-slider y-zoom-slider mus-array-print-length mus-float-equal-fudge-factor
;mus-data
- mus-feedback mus-feedforward mus-frequency mus-hop
- mus-increment mus-length mus-location mus-name mus-phase mus-ramp mus-scaler x-axis-label
- filter-control-coeffs locsig-type mus-file-buffer-size
- mus-rand-seed mus-width clm-table-size clm-default-frequency mus-offset mus-reset
- phase-vocoder-amp-increments phase-vocoder-amps
- phase-vocoder-freqs phase-vocoder-phase-increments phase-vocoder-phases
- html-dir html-program mus-interp-type widget-position widget-size
- mus-clipping mus-file-clipping mus-header-raw-defaults
- ))
-
- (make-procs (list
- make-all-pass make-asymmetric-fm make-snd->sample make-moving-average make-moving-max make-moving-norm
- make-comb make-filtered-comb make-convolve make-delay make-env make-fft-window make-file->frample
- make-file->sample make-filter make-fir-filter make-formant make-firmant make-frample->file make-granulate
- make-iir-filter make-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil
- make-pulse-train make-rand make-rand-interp make-readin make-sample->file make-sawtooth-wave
- make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave
- make-src make-ncos make-nsin make-table-lookup make-triangle-wave
- make-two-pole make-two-zero make-wave-train make-phase-vocoder make-ssb-am make-polyshape make-polywave
- make-color make-player make-region
- ))
-
- (keyargs
- (list
- :frequency :initial-phase :wave :cosines :amplitude :ratio :size :a0 :a1 :a2 :b1 :b2 :input
- :srate :file :channel :start :initial-contents :initial-element :scaler :feedforward :feedback
- :max-size :radius :gain :partials :r :a :n :fill-time :order :xcoeffs :ycoeffs :envelope
- :base :duration :offset :end :direction :degree :distance :reverb :output :fft-size :expansion
- :length :hop :ramp :jitter :type :format :comment :channels :filter :revout :width :edit
- :synthesize :analyze :interp :overlap :pitch :distribution :sines :dur))
-
- (procs0 (remove-if (lambda (n) (or (not (procedure? n)) (not (aritable? n 0)))) procs))
- (set-procs0 (remove-if (lambda (n) (or (not (procedure? n)) (not (set-arity-ok n 1)))) set-procs))
- (procs1 (remove-if (lambda (n) (or (not (procedure? n)) (not (aritable? n 1)))) procs))
- (set-procs1 (remove-if (lambda (n) (or (not (procedure? n)) (not (set-arity-ok n 2)))) set-procs))
- (procs2 (remove-if (lambda (n) (or (not (procedure? n)) (not (aritable? n 2)))) procs))
- (set-procs2 (remove-if (lambda (n) (or (not (procedure? n)) (not (set-arity-ok n 3)))) set-procs))
- )
-
- (reset-all-hooks)
+ mus-feedback mus-feedforward mus-frequency mus-hop
+ mus-increment mus-length mus-location mus-name mus-phase mus-ramp mus-scaler x-axis-label
+ filter-control-coeffs locsig-type mus-file-buffer-size
+ mus-rand-seed mus-width clm-table-size clm-default-frequency mus-offset mus-reset
+ phase-vocoder-amp-increments phase-vocoder-amps
+ phase-vocoder-freqs phase-vocoder-phase-increments phase-vocoder-phases
+ html-dir html-program mus-interp-type widget-position widget-size
+ mus-clipping mus-file-clipping mus-header-raw-defaults
+ ))
+
+ (make-procs (list
+ make-all-pass make-asymmetric-fm make-snd->sample make-moving-average make-moving-max make-moving-norm
+ make-comb make-filtered-comb make-convolve make-delay make-env make-fft-window make-file->frample
+ make-file->sample make-filter make-fir-filter make-formant make-firmant make-frample->file make-granulate
+ make-iir-filter make-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil
+ make-pulse-train make-rand make-rand-interp make-readin make-sample->file make-sawtooth-wave
+ make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave
+ make-src make-ncos make-nsin make-table-lookup make-triangle-wave
+ make-two-pole make-two-zero make-wave-train make-phase-vocoder make-ssb-am make-polyshape make-polywave
+ make-color make-player make-region
+ ))
+
+ (keyargs
+ (list
+ :frequency :initial-phase :wave :cosines :amplitude :ratio :size :a0 :a1 :a2 :b1 :b2 :input
+ :srate :file :channel :start :initial-contents :initial-element :scaler :feedforward :feedback
+ :max-size :radius :gain :partials :r :a :n :fill-time :order :xcoeffs :ycoeffs :envelope
+ :base :duration :offset :end :direction :degree :distance :reverb :output :fft-size :expansion
+ :length :hop :ramp :jitter :type :format :comment :channels :filter :revout :width :edit
+ :synthesize :analyze :interp :overlap :pitch :distribution :sines :dur))
+
+ (procs0 (remove-if (lambda (n) (not (and (procedure? n) (aritable? n 0)))) procs))
+ (set-procs0 (remove-if (lambda (n) (not (and (procedure? n) (set-arity-ok n 1)))) set-procs))
+ (procs1 (remove-if (lambda (n) (not (and (procedure? n) (aritable? n 1)))) procs))
+ (set-procs1 (remove-if (lambda (n) (not (and (procedure? n) (set-arity-ok n 2)))) set-procs))
+ (procs2 (remove-if (lambda (n) (not (and (procedure? n) (aritable? n 2)))) procs))
+ (set-procs2 (remove-if (lambda (n) (not (and (procedure? n) (set-arity-ok n 3)))) set-procs))
+ )
+
+ (reset-all-hooks)
+
+ (do ((test-errors 0 (+ 1 test-errors)))
+ ((= test-errors tests))
+ (log-mem test-errors)
+
+ (case test-errors
+ ((1)
+ (set! delay-32 (make-oscil 440))
+ (set! color-95 (vector 1 2 3))
+ (set! vector-0 (make-comb 0.1 3))
+ (set! float-vector-3 (make-notch 0.1 101))
+ (set! car-main (make-all-pass 0.4 0.5 2))
+ (set! cadr-main (make-table-lookup 101))
+ (set! a-hook (make-triangle-wave 220)))
+ ((2)
+ (set! delay-32 (make-sawtooth-wave 440))
+ (set! color-95 123+123i)
+ (set! vector-0 (make-rand 100))
+ (set! float-vector-3 (make-rand-interp 100))
+ (set! car-main (make-asymmetric-fm 100))
+ (set! a-hook (make-one-pole 0.1 0.1)))
+ ((3)
+ (set! delay-32 (make-two-zero 0.5 0.5 0.1))
+ (set! color-95 (list 1 2 3))
+ (set! vector-0 (make-formant 100 0.1))
+ (set! float-vector-3 (make-polyshape :frequency 300 :partials '(1 1 2 1)))
+ (set! car-main (make-oscil))
+ (set! cadr-main (vector 1 2 3))
+ (set! a-hook (float-vector 0.2 0.1)))
+ ((4)
+ (set! delay-32 (make-filter 3 (float-vector 3 1 2 3) (float-vector 3 1 2 3)))
+ (set! color-95 (make-float-vector (list 2 1) 0.0))
+ (set! vector-0 (make-iir-filter 3 (float-vector 1 2 3)))
+ (set! float-vector-3 (make-ncos))
+ (set! car-main (make-env '(0 0 1 1) :length 101))
+ (set! cadr-main (make-nsin 100 4))
+ (set! a-hook (make-nsin 100 3)))
+ ((5)
+ (set! delay-32 1.5)
+ (set! color-95 (make-color-with-catch 0.9 0.9 0.9))
+ (set! vector-0 (make-vector 1))
+ (set! car-main (make-moving-average 3))
+ (set! cadr-main (make-oscil 440))
+ (set! a-hook (make-shared-vector (float-vector 0.1 0.2 0.1 0.2) (list 2 2)))))
- (do ((test-28 0 (+ 1 test-28)))
- ((= test-28 tests))
- (log-mem test-28)
-
- (if (= test-28 1)
- (begin
- (set! delay-32 (make-oscil 440))
- (set! color-95 (vector 1 2 3))
- (set! vector-0 (make-comb .1 3))
- (set! float-vector-3 (make-notch .1 101))
- (set! car-main (make-all-pass .4 .5 2))
- (set! cadr-main (make-table-lookup 101))
- (set! a-hook (make-triangle-wave 220)))
- (if (= test-28 2)
- (begin
- (set! delay-32 (make-sawtooth-wave 440))
- (set! color-95 123+123i)
- (set! vector-0 (make-rand 100))
- (set! float-vector-3 (make-rand-interp 100))
- (set! car-main (make-asymmetric-fm 100))
- (set! a-hook (make-one-pole .1 .1)))
- (if (= test-28 3)
- (begin
- (set! delay-32 (make-two-zero .5 .5 .1))
- (set! color-95 (list 1 2 3))
- (set! vector-0 (make-formant 100 .1))
- (set! float-vector-3 (make-polyshape :frequency 300 :partials '(1 1 2 1)))
- (set! car-main (make-oscil))
- (set! cadr-main (vector 1 2 3))
- (set! a-hook (float-vector .2 .1)))
- (if (= test-28 4)
- (begin
- (set! delay-32 (make-filter 3 (float-vector 3 1 2 3) (float-vector 3 1 2 3)))
- (set! color-95 (make-float-vector (list 2 1) 0.0))
- (set! vector-0 (make-iir-filter 3 (float-vector 1 2 3)))
- (set! float-vector-3 (make-ncos))
- (set! car-main (make-env '(0 0 1 1) :length 101))
- (set! cadr-main (make-nsin 100 4))
- (set! a-hook (make-nsin 100 3)))
- (if (= test-28 5)
- (begin
- (set! delay-32 '(1 2))
- (set! color-95 (make-color-with-catch .9 .9 .9))
- (set! vector-0 (make-vector 1))
- (set! car-main (make-moving-average 3))
- (set! cadr-main (make-oscil 440))
- (set! a-hook (make-shared-vector (float-vector .1 .2 .1 .2) (list 2 2)))
- ))))))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (integer->sound 123)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-sound))
- (snd-display #__line__ ";snd no-such-sound ~A: ~A" n tag))))
- (list amp-control apply-controls channels chans comment contrast-control
- amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
- reverb-control-length-bounds reverb-control-scale-bounds
- contrast-control-amp contrast-control? sample-type data-location data-size
- expand-control expand-control-hop expand-control-jitter
- expand-control-length expand-control-ramp expand-control? file-name filter-control-in-dB filter-control-in-hz
- filter-control-envelope filter-control-order filter-control? finish-progress-report framples header-type
- progress-report read-only reset-controls restore-controls reverb-control-decay reverb-control-feedback
- reverb-control-length reverb-control-lowpass reverb-control-scale reverb-control? save-controls
- select-sound short-file-name sound-loop-info soundfont-info speed-control speed-control-style
- speed-control-tones srate channel-style start-progress-report sync sound-properties sound-property swap-channels))
-
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (integer->sound 123)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-sound))
+ (snd-display ";snd no-such-sound ~A: ~A" n tag))))
+ (list amp-control apply-controls channels chans comment contrast-control
+ amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
+ reverb-control-length-bounds reverb-control-scale-bounds
+ contrast-control-amp contrast-control? sample-type data-location data-size
+ expand-control expand-control-hop expand-control-jitter
+ expand-control-length expand-control-ramp expand-control? file-name filter-control-in-dB filter-control-in-hz
+ filter-control-envelope filter-control-order filter-control? finish-progress-report framples header-type
+ progress-report read-only reset-controls restore-controls reverb-control-decay reverb-control-feedback
+ reverb-control-length reverb-control-lowpass reverb-control-scale reverb-control? save-controls
+ select-sound short-file-name sound-loop-info soundfont-info speed-control speed-control-style
+ speed-control-tones srate channel-style start-progress-report sync sound-properties sound-property swap-channels))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg mus-error)))
+ (snd-display ";snd wrong-type-arg ~A: ~A ~A" n tag arg))))
+ (list amp-control apply-controls close-sound comment contrast-control
+ amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
+ reverb-control-length-bounds reverb-control-scale-bounds
+ contrast-control-amp contrast-control? sample-type data-location data-size expand-control
+ expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control?
+ filter-control-in-dB filter-control-in-hz filter-control-envelope filter-control-order filter-control?
+ finish-progress-report header-type read-only reset-controls restore-controls
+ reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-lowpass
+ reverb-control-scale reverb-control? save-controls select-sound short-file-name
+ sound-loop-info soundfont-info speed-control speed-control-style speed-control-tones srate
+ channel-style start-progress-report sync sound-properties swap-channels)))
+ (list float-vector-5 0+i 1.5 "hiho" delay-32))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (set! (n arg) 0))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg syntax-error error)))
+ (snd-display ";snd set wrong-type-arg: ~A: ~A ~A" n tag arg))))
+ (list amp-control channels chans comment contrast-control contrast-control-amp
+ amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
+ reverb-control-length-bounds reverb-control-scale-bounds
+ contrast-control? sample-type data-location data-size expand-control expand-control-hop expand-control-jitter
+ expand-control-length expand-control-ramp expand-control? filter-control-in-dB filter-control-in-hz
+ filter-control-envelope filter-control-order filter-control? framples header-type read-only
+ reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-lowpass
+ reverb-control-scale reverb-control? sound-loop-info soundfont-info speed-control
+ speed-control-style speed-control-tones srate channel-style sync)))
+ (list float-vector-5 0+i 1.5 "hiho" delay-32))
+
+ (let ((index (open-sound "obtest.snd")))
(for-each (lambda (arg)
(for-each (lambda (n)
(let ((tag
(catch #t
(lambda ()
- (n arg))
+ (set! (n index) arg))
(lambda args (car args)))))
- (if (and (not (eq? tag 'wrong-type-arg))
- (not (eq? tag 'mus-error)))
- (snd-display #__line__ ";snd wrong-type-arg ~A: ~A ~A" n tag arg))))
- (list amp-control apply-controls close-sound comment contrast-control
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display ";snd safe set wrong-type-arg: ~A ~A ~A" n tag arg))))
+ (list amp-control contrast-control contrast-control-amp contrast-control? expand-control
amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
reverb-control-length-bounds reverb-control-scale-bounds
- contrast-control-amp contrast-control? sample-type data-location data-size expand-control
expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control?
filter-control-in-dB filter-control-in-hz filter-control-envelope filter-control-order filter-control?
- finish-progress-report header-type read-only reset-controls restore-controls
- reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-lowpass
- reverb-control-scale reverb-control? save-controls select-sound short-file-name
- sound-loop-info soundfont-info speed-control speed-control-style speed-control-tones srate
- channel-style start-progress-report sync sound-properties swap-channels)))
- (list float-vector-5 0+i 1.5 "hiho" delay-32))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n arg) 0))
- (lambda args (car args)))))
- (if (and (not (eq? tag 'wrong-type-arg))
- (not (eq? tag 'syntax-error))
- (not (eq? tag 'error)))
- (snd-display #__line__ ";snd set wrong-type-arg: ~A: ~A ~A" n tag arg))))
- (list amp-control channels chans comment contrast-control contrast-control-amp
- amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
- reverb-control-length-bounds reverb-control-scale-bounds
- contrast-control? sample-type data-location data-size expand-control expand-control-hop expand-control-jitter
- expand-control-length expand-control-ramp expand-control? filter-control-in-dB filter-control-in-hz
- filter-control-envelope filter-control-order filter-control? framples header-type read-only
reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-lowpass
- reverb-control-scale reverb-control? sound-loop-info soundfont-info speed-control
- speed-control-style speed-control-tones srate channel-style sync)))
- (list float-vector-5 0+i 1.5 "hiho" delay-32))
-
- (let ((index (open-sound "obtest.snd")))
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n index) arg))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";snd safe set wrong-type-arg: ~A ~A ~A" n tag arg))))
- (list amp-control contrast-control contrast-control-amp contrast-control? expand-control
- amp-control-bounds speed-control-bounds expand-control-bounds contrast-control-bounds
- reverb-control-length-bounds reverb-control-scale-bounds
- expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control?
- filter-control-in-dB filter-control-in-hz filter-control-envelope filter-control-order filter-control?
- reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-lowpass
- reverb-control-scale reverb-control? speed-control speed-control-style speed-control-tones
- channel-style sync)))
- (list float-vector-5 0+i "hiho" delay-32))
- (close-sound index))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n arg))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";float-vector 0 wrong-type-arg ~A: ~A ~A" n tag arg))))
- (list make-float-vector float-vector-peak float-vector-max float-vector-min)))
- (list (make-vector 1) "hiho" 0+i 1.5 #(0 1) delay-32))
-
- (for-each (lambda (arg1)
- (for-each (lambda (arg2)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n arg1 arg2))
- (lambda args (car args)))))
- (if (not (memq tag '(wrong-type-arg wrong-number-of-args mus-error)))
- (snd-display #__line__ ";float-vector 1 wrong-whatever ~A: ~A ~A ~A" n tag arg1 arg2))))
- (list float-vector-add! float-vector-subtract! float-vector-multiply! float-vector-ref float-vector-scale!)))
- (list float-vector-5 "hiho" 0+i 1.5 (list 1 0) #(0 1) delay-32)))
- (list (make-vector 1) "hiho" 0+i 1.5 (list 1 0) #(0 1) delay-32))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n float-vector-3 arg))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";float-vector arg 2 (scaler) wrong-type-arg ~A: ~A ~A" n arg tag))))
- (list float-vector-add! float-vector-subtract! float-vector-multiply! float-vector-ref float-vector-scale!)))
- (list (make-vector 1) "hiho" 0+i (list 1 0) #(0 1) delay-32))
-
- (let ((v float-vector-3))
- (let ((tag
- (catch #t
- (lambda ()
- (v 12))
- (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range))
- (snd-display #__line__ ";float-vector[12]: ~A" tag))))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n arg))
- (lambda args (car args)))))
- (if tag
- (snd-display #__line__ ";?proc ~A: ~A" n tag))))
- (list all-pass? asymmetric-fm? comb? filtered-comb? convolve? delay? env? file->frample? file->sample? snd->sample?
- filter? fir-filter? formant? formant-bank? firmant? frample->file? granulate? iir-filter? locsig? move-sound? mus-input?
- mus-output? notch? one-pole? one-pole-all-pass? one-zero? oscil? phase-vocoder? pulse-train? rand-interp? rand? readin?
- sample->file? sawtooth-wave? nrxysin? nrxycos? rxyk!cos? rxyk!sin?
- square-wave? src? ncos? nsin? tap? table-lookup?
- triangle-wave? two-pole? two-zero? wave-train? color? mix-sampler? moving-average? moving-max? moving-norm? ssb-am?
- sampler? region-sampler? float-vector? )))
- (list (make-vector 1) "hiho" 0+i 1.5 (list 1 0) #(0 1)))
-
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (make-oscil 440)))
- (lambda args (car args)))))
- (if tag
- (snd-display #__line__ ";oscil?proc ~A: ~A" n tag))))
- (list all-pass? asymmetric-fm? comb? filtered-comb? convolve? delay? env? file->frample? file->sample? snd->sample?
- filter? fir-filter? formant? formant-bank? firmant? frample->file? granulate? iir-filter? locsig? move-sound? mus-input?
- mus-output? notch? one-pole? one-pole-all-pass? one-zero? phase-vocoder? pulse-train? rand-interp? rand? readin?
- sample->file? sawtooth-wave? nrxysin? nrxycos? rxyk!cos? rxyk!sin?
- square-wave? src? ncos? nsin? tap? table-lookup?
- triangle-wave? two-pole? two-zero? wave-train? sound? color? mix-sampler? moving-average? moving-max? moving-norm? ssb-am?
- sampler? region-sampler? float-vector?))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- n
- (lambda args (car args)))))
- (if (not (eq? tag 'no-active-selection))
- (snd-display #__line__ ";selection ~A: ~A" n tag))))
- (list reverse-selection selection-position selection-framples smooth-selection
- scale-selection-to insert-selection delete-selection delete-selection-and-smooth mix-selection))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n 0.0))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-active-selection))
- (snd-display #__line__ ";selection ~A: ~A" n tag))))
- (list src-selection filter-selection env-selection))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n arg))
- (lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg no-data no-such-method bad-type error arg-error) eq?))
- (snd-display #__line__ ";clm ~A: tag: ~A arg: ~A" n tag arg))))
- (list all-pass asymmetric-fm comb filtered-comb convolve db->linear moving-average moving-max moving-norm
- degrees->radians delay env formant firmant granulate hz->radians linear->db even-weight odd-weight
- make-all-pass make-asymmetric-fm make-comb make-filtered-comb make-convolve make-delay make-env
- make-file->frample make-file->sample make-filter make-fir-filter make-formant make-firmant
- make-granulate make-iir-filter make-locsig make-notch make-one-pole make-one-zero
- make-oscil make-pulse-train make-rand make-rand-interp make-readin
- make-sawtooth-wave make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave make-src
- make-ncos make-nsin
- make-table-lookup make-triangle-wave make-two-pole make-two-zero make-wave-train make-ssb-am
- mus-channel mus-channels make-polyshape make-polywave
- mus-data mus-feedback mus-feedforward mus-frequency mus-hop
- mus-increment mus-length mus-file-name mus-location mus-name mus-order mus-phase mus-ramp mus-random mus-run
- mus-scaler mus-xcoeffs mus-ycoeffs notch one-pole one-pole-all-pass one-zero
- make-moving-average make-moving-max make-moving-norm
- seconds->samples samples->seconds
- oscil partials->polynomial partials->wave phase-partials->wave
- phase-vocoder pulse-train radians->degrees radians->hz rand rand-interp readin
- sawtooth-wave nrxysin nrxycos rxyk!cos rxyk!sin square-wave src
- ncos nsin table-lookup tap triangle-wave
- two-pole two-zero wave-train ssb-am)))
- (list (make-vector 1) color-95 (list 1.0)))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (make-oscil) float-vector-5)
- )
- (lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg bad-arity error mus-error) eq?))
- (snd-display #__line__ ";clm-1 ~A: ~A" n tag))))
- (list all-pass array-interp asymmetric-fm comb filtered-comb contrast-enhancement convolution convolve moving-average moving-max moving-norm
- convolve-files delay dot-product env-interp file->sample snd->sample filter fir-filter formant firmant
- formant-bank granulate iir-filter ina
- inb locsig-ref locsig-reverb-ref make-all-pass make-asymmetric-fm make-comb make-filtered-comb
- make-delay make-env make-fft-window make-filter make-fir-filter make-formant make-firmant make-granulate
- make-iir-filter make-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil make-phase-vocoder
- make-pulse-train make-rand make-rand-interp make-readin make-sawtooth-wave make-moving-average make-moving-max make-moving-norm
- make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave make-src make-ncos
- make-nsin make-table-lookup make-triangle-wave
- make-two-pole make-two-zero make-wave-train
- notch one-pole one-pole-all-pass one-zero oscil partials->polynomial partials->wave make-polyshape make-polywave
- phase-partials->wave phase-vocoder polynomial pulse-train rand rand-interp rectangular->polar rectangular->magnitudes
- ring-modulate sawtooth-wave nrxysin nrxycos rxyk!cos rxyk!sin square-wave src ncos nsin
- table-lookup tap triangle-wave two-pole two-zero wave-train ssb-am make-ssb-am))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n (make-oscil)) vector-0))
- (lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg syntax-error error) eq?))
- (snd-display #__line__ ";mus-gen ~A: ~A" n tag))))
- (list mus-channel mus-channels mus-data
- mus-feedback mus-feedforward mus-frequency mus-hop mus-increment mus-length
- mus-location mus-file-mix mus-name mus-order mus-phase mus-ramp mus-random mus-run mus-scaler mus-xcoeffs
- mus-ycoeffs))
-
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n float-vector-5))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ ";mus-sound ~A: ~A" n tag))))
- (list mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size
- mus-sound-data-location mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type
- mus-sound-length mus-sound-type-specifier mus-header-type-name mus-sample-type-name mus-sound-comment
- mus-sound-write-date mus-bytes-per-sample mus-sound-loop-info mus-sound-mark-info mus-sound-maxamp
- mus-sound-maxamp-exists? mus-header-type->string mus-sample-type->string))
-
+ reverb-control-scale reverb-control? speed-control speed-control-style speed-control-tones
+ channel-style sync)))
+ (list float-vector-5 0+i "hiho" delay-32))
+ (close-sound index))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display ";float-vector 0 wrong-type-arg ~A: ~A ~A" n tag arg))))
+ (list make-float-vector float-vector-peak float-vector-max float-vector-min)))
+ (list (make-vector 1) "hiho" 0+i 1.5 #(0 1) delay-32))
+
+ (for-each (lambda (arg1)
+ (for-each (lambda (arg2)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg1 arg2))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg wrong-number-of-args mus-error)))
+ (snd-display ";float-vector 1 wrong-whatever ~A: ~A ~A ~A" n tag arg1 arg2))))
+ (list float-vector-add! float-vector-subtract! float-vector-multiply! float-vector-ref float-vector-scale!)))
+ (list float-vector-5 "hiho" 0+i 1.5 (list 1 0) #(0 1) delay-32)))
+ (list (make-vector 1) "hiho" 0+i 1.5 (list 1 0) #(0 1) delay-32))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n float-vector-3 arg))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display ";float-vector arg 2 (scaler) wrong-type-arg ~A: ~A ~A" n arg tag))))
+ (list float-vector-add! float-vector-subtract! float-vector-multiply! float-vector-ref float-vector-scale!)))
+ (list (make-vector 1) "hiho" 0+i (list 1 0) #(0 1) delay-32))
+
+ (let* ((v float-vector-3)
+ (tag
+ (catch #t
+ (lambda ()
+ (v 12))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range))
+ (snd-display ";float-vector[12]: ~A" tag)))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg))
+ (lambda args (car args)))))
+ (if tag
+ (snd-display ";?proc ~A: ~A" n tag))))
+ (list all-pass? asymmetric-fm? comb? filtered-comb? convolve? delay? env? file->frample? file->sample? snd->sample?
+ filter? fir-filter? formant? formant-bank? firmant? frample->file? granulate? iir-filter? locsig? move-sound? mus-input?
+ mus-output? notch? one-pole? one-pole-all-pass? one-zero? oscil? phase-vocoder? pulse-train? rand-interp? rand? readin?
+ sample->file? sawtooth-wave? nrxysin? nrxycos? rxyk!cos? rxyk!sin?
+ square-wave? src? ncos? nsin? tap? table-lookup?
+ triangle-wave? two-pole? two-zero? wave-train? color? mix-sampler? moving-average? moving-max? moving-norm? ssb-am?
+ sampler? region-sampler? float-vector? )))
+ (list (make-vector 1) "hiho" 0+i 1.5 (list 1 0) #(0 1)))
+
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (make-oscil 440)))
+ (lambda args (car args)))))
+ (if tag
+ (snd-display ";oscil?proc ~A: ~A" n tag))))
+ (list all-pass? asymmetric-fm? comb? filtered-comb? convolve? delay? env? file->frample? file->sample? snd->sample?
+ filter? fir-filter? formant? formant-bank? firmant? frample->file? granulate? iir-filter? locsig? move-sound? mus-input?
+ mus-output? notch? one-pole? one-pole-all-pass? one-zero? phase-vocoder? pulse-train? rand-interp? rand? readin?
+ sample->file? sawtooth-wave? nrxysin? nrxycos? rxyk!cos? rxyk!sin?
+ square-wave? src? ncos? nsin? tap? table-lookup?
+ triangle-wave? two-pole? two-zero? wave-train? sound? color? mix-sampler? moving-average? moving-max? moving-norm? ssb-am?
+ sampler? region-sampler? float-vector?))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ n
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-active-selection))
+ (snd-display ";selection ~A: ~A" n tag))))
+ (list reverse-selection selection-position selection-framples smooth-selection
+ scale-selection-to insert-selection delete-selection delete-selection-and-smooth mix-selection))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n 0.0))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-active-selection))
+ (snd-display ";selection ~A: ~A" n tag))))
+ (list src-selection filter-selection env-selection))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg no-data no-such-method bad-type error arg-error)))
+ (snd-display ";clm ~A: tag: ~A arg: ~A" n tag arg))))
+ (list all-pass asymmetric-fm comb filtered-comb convolve db->linear moving-average moving-max moving-norm
+ degrees->radians delay env formant firmant granulate hz->radians linear->db even-weight odd-weight
+ make-all-pass make-asymmetric-fm make-comb make-filtered-comb make-convolve make-delay make-env
+ make-file->frample make-file->sample make-filter make-fir-filter make-formant make-firmant
+ make-granulate make-iir-filter make-locsig make-notch make-one-pole make-one-zero
+ make-oscil make-pulse-train make-rand make-rand-interp make-readin
+ make-sawtooth-wave make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave make-src
+ make-ncos make-nsin
+ make-table-lookup make-triangle-wave make-two-pole make-two-zero make-wave-train make-ssb-am
+ mus-channel mus-channels make-polyshape make-polywave
+ mus-data mus-feedback mus-feedforward mus-frequency mus-hop
+ mus-increment mus-length mus-file-name mus-location mus-name mus-order mus-phase mus-ramp mus-random mus-run
+ mus-scaler mus-xcoeffs mus-ycoeffs notch one-pole one-pole-all-pass one-zero
+ make-moving-average make-moving-max make-moving-norm
+ seconds->samples samples->seconds
+ oscil partials->polynomial partials->wave phase-partials->wave
+ phase-vocoder pulse-train radians->degrees radians->hz rand rand-interp readin
+ sawtooth-wave nrxysin nrxycos rxyk!cos rxyk!sin square-wave src
+ ncos nsin table-lookup tap triangle-wave
+ two-pole two-zero wave-train ssb-am)))
+ (list (make-vector 1) color-95 (list 1.0)))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (make-oscil) float-vector-5)
+ )
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg bad-arity error mus-error)))
+ (snd-display ";clm-1 ~A: ~A" n tag))))
+ (list all-pass array-interp asymmetric-fm comb filtered-comb contrast-enhancement convolution convolve moving-average moving-max moving-norm
+ convolve-files delay dot-product env-interp file->sample snd->sample filter fir-filter formant firmant
+ formant-bank granulate iir-filter ina
+ inb locsig-ref locsig-reverb-ref make-all-pass make-asymmetric-fm make-comb make-filtered-comb
+ make-delay make-env make-fft-window make-filter make-fir-filter make-formant make-firmant make-granulate
+ make-iir-filter make-locsig make-notch make-one-pole make-one-pole-all-pass make-one-zero make-oscil make-phase-vocoder
+ make-pulse-train make-rand make-rand-interp make-readin make-sawtooth-wave make-moving-average make-moving-max make-moving-norm
+ make-nrxysin make-nrxycos make-rxyk!cos make-rxyk!sin make-square-wave make-src make-ncos
+ make-nsin make-table-lookup make-triangle-wave
+ make-two-pole make-two-zero make-wave-train
+ notch one-pole one-pole-all-pass one-zero oscil partials->polynomial partials->wave make-polyshape make-polywave
+ phase-partials->wave phase-vocoder polynomial pulse-train rand rand-interp rectangular->polar rectangular->magnitudes
+ ring-modulate sawtooth-wave nrxysin nrxycos rxyk!cos rxyk!sin square-wave src ncos nsin
+ table-lookup tap triangle-wave two-pole two-zero wave-train ssb-am make-ssb-am))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (set! (n (make-oscil)) vector-0))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg syntax-error error)))
+ (snd-display ";mus-gen ~A: ~A" n tag))))
+ (list mus-channel mus-channels mus-data
+ mus-feedback mus-feedforward mus-frequency mus-hop mus-increment mus-length
+ mus-location mus-file-mix mus-name mus-order mus-phase mus-ramp mus-random mus-run mus-scaler mus-xcoeffs
+ mus-ycoeffs))
+
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n float-vector-5))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display ";mus-sound ~A: ~A" n tag))))
+ (list mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size
+ mus-sound-data-location mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type
+ mus-sound-length mus-sound-type-specifier mus-header-type-name mus-sample-type-name mus-sound-comment
+ mus-sound-write-date mus-bytes-per-sample mus-sound-loop-info mus-sound-mark-info mus-sound-maxamp
+ mus-sound-maxamp-exists? mus-header-type->string mus-sample-type->string))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n "/bad/baddy"))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'mus-error))
+ (snd-display ";bad file mus-sound ~A: ~A" n tag))))
+ (list mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size
+ mus-sound-data-location mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type
+ mus-sound-length mus-sound-type-specifier mus-sound-comment mus-sound-write-date mus-sound-maxamp
+ mus-sound-maxamp-exists?))
+ (mus-sound-forget "/bad/baddy") ; for possible second time around
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n float-vector-5))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg error no-such-sound)))
+ (snd-display "; chn (no snd) procs ~A: ~A" n tag))))
+ (list channel-widgets cursor channel-properties channel-property
+ cursor-position cursor-size cursor-style tracking-cursor-style delete-sample display-edits dot-size
+ draw-dots draw-lines edit-fragment edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency
+ fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window transform-graph?
+ graph graph-style lisp-graph? (lambda (a) (insert-region 0 a)) insert-sound
+ time-graph-style lisp-graph-style transform-graph-style
+ left-sample make-graph-data max-transform-peaks maxamp-position min-dB mix-region
+ transform-normalization peaks ;play
+ position->x position->y reverse-sound
+ revert-sound right-sample sample save-sound save-sound-as
+ select-channel show-axes show-transform-peaks show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
+ spectrum-end spectro-hop spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle grid-density
+ spectro-y-scale spectro-z-angle spectro-z-scale squelch-update transform-sample
+ transform->float-vector transform-framples transform-type update-transform-graph update-time-graph
+ update-lisp-graph update-sound wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds
+ x-position-slider x-zoom-slider x-axis-label y-axis-label y-bounds y-position-slider y-zoom-slider zero-pad))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n 0 float-vector-5))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display "; chn (no chn) procs ~A: ~A" n tag))))
+ (list channel-widgets cursor channel-properties channel-property combined-data-color
+ cursor-position cursor-size cursor-style tracking-cursor-style delete-sample display-edits dot-size draw-dots draw-lines
+ edit-fragment edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
+ transform-size transform-graph-type fft-window transform-graph?
+ graph graph-style lisp-graph? insert-region insert-sound left-sample
+ time-graph-style lisp-graph-style transform-graph-style
+ make-graph-data max-transform-peaks maxamp maxamp-position min-dB mix-region transform-normalization
+ peaks play position->x position->y reverse-sound right-sample sample
+ save-sound-as show-axes show-transform-peaks show-marks
+ show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
+ spectrum-end spectro-hop spectrum-start spectro-x-angle
+ spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale squelch-update grid-density
+ transform-sample transform->float-vector transform-framples transform-type
+ update-transform-graph update-time-graph update-lisp-graph wavelet-type time-graph? time-graph-type
+ wavo-hop wavo-trace x-bounds x-position-slider x-zoom-slider x-axis-label y-axis-label y-bounds y-position-slider
+ y-zoom-slider zero-pad))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (integer->sound 1234)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-sound))
+ (snd-display "; chn procs ~A: ~A" n tag))))
+ (list channel-widgets cursor channel-properties
+ cursor-position cursor-size cursor-style tracking-cursor-style
+ (lambda (snd) (delete-sample 0 snd)) display-edits dot-size
+ (lambda (snd) (edit-fragment 0 snd))
+ edit-position edit-tree edits env-sound fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
+ transform-size transform-graph-type fft-window transform-graph? filter-sound
+ graph-data graph-style lisp-graph? left-sample
+ time-graph-style lisp-graph-style transform-graph-style
+ make-graph-data max-transform-peaks maxamp maxamp-position min-dB transform-normalization
+ (lambda (snd) (position->x 0 snd))
+ (lambda (snd) (position->y 0 snd))
+ (lambda (snd) (redo 1 snd)) reverse-sound revert-sound right-sample
+ (lambda (snd) (sample 0 snd))
+ save-sound scale-by scale-to show-axes show-transform-peaks
+ show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
+ spectrum-end spectro-hop spectrum-start spectro-x-angle
+ spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale squelch-update grid-density
+ src-sound
+ (lambda (snd) (transform-sample 0 0 snd)) transform->float-vector
+ transform-framples transform-type
+ (lambda (snd) (undo 1 snd)) update-transform-graph update-time-graph update-lisp-graph
+ update-sound wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds x-position-slider
+ (lambda (snd) (normalize-channel 0.5 0 #f snd))
+ (lambda (snd) (x->position 0 snd))
+ x-zoom-slider y-bounds y-position-slider x-axis-label y-axis-label
+ (lambda (snd) (y->position 0 snd)) y-zoom-slider
+ zero-pad
+ (lambda (snd) (scale-channel 2.0 0 #f snd))
+ ))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n 0 1234))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-sound))
+ (snd-display "; snd(1) chn procs ~A: ~A" n tag))))
+ (list delete-sample edit-fragment graph-data graph-style play position->x position->y redo
+ time-graph-style lisp-graph-style transform-graph-style
+ scale-by scale-to undo x->position y->position x-axis-label))
+
+ (let ((index (open-sound "oboe.snd")))
(for-each (lambda (n)
(let ((tag
(catch #t
(lambda ()
- (n "/bad/baddy"))
+ (n 0 index 1234))
(lambda args (car args)))))
- (if (not (eq? tag 'mus-error))
- (snd-display #__line__ ";bad file mus-sound ~A: ~A" n tag))))
- (list mus-sound-samples mus-sound-framples mus-sound-duration mus-sound-datum-size
- mus-sound-data-location mus-sound-chans mus-sound-srate mus-sound-header-type mus-sound-sample-type
- mus-sound-length mus-sound-type-specifier mus-sound-comment mus-sound-write-date mus-sound-maxamp
- mus-sound-maxamp-exists?))
- (mus-sound-forget "/bad/baddy") ; for possible second time around
-
+ (if (not (eq? tag 'no-such-channel))
+ (snd-display "; snd(1 1234) chn procs ~A: ~A" n tag))))
+ (list delete-sample edit-fragment graph-data position->x position->y redo scale-by
+ scale-to undo x->position y->position))
+ (close-sound index))
+ (if (sound? (find-sound "oboe.snd"))
+ (snd-display ";oboe.snd is still open?"))
+
+ (let ((index (open-sound "oboe.snd")))
(for-each (lambda (n)
(let ((tag
(catch #t
(lambda ()
- (n float-vector-5))
+ (n index 1234))
(lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg error no-such-sound) eq?))
- (snd-display #__line__ "; chn (no snd) procs ~A: ~A" n tag))))
- (list channel-widgets cursor channel-properties channel-property
- cursor-position cursor-size cursor-style tracking-cursor-style delete-sample display-edits dot-size
- draw-dots draw-lines edit-fragment edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency
- fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window transform-graph?
- graph graph-style lisp-graph? (lambda (a) (insert-region 0 a)) insert-sound
- time-graph-style lisp-graph-style transform-graph-style
- left-sample make-graph-data max-transform-peaks maxamp-position min-dB mix-region
- transform-normalization peaks ;play
- position->x position->y reverse-sound
- revert-sound right-sample sample save-sound save-sound-as
- select-channel show-axes show-transform-peaks show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
- spectrum-end spectro-hop spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle grid-density
- spectro-y-scale spectro-z-angle spectro-z-scale squelch-update transform-sample
- transform->float-vector transform-framples transform-type update-transform-graph update-time-graph
- update-lisp-graph update-sound wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds
- x-position-slider x-zoom-slider x-axis-label y-axis-label y-bounds y-position-slider y-zoom-slider zero-pad))
-
+ (if (not (memq tag '(no-such-channel no-such-sound)))
+ (snd-display "; chn procs ~A: ~A" n tag))))
+ (list channel-widgets cursor cursor-position cursor-size cursor-style tracking-cursor-style display-edits
+ dot-size edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
+ transform-size transform-graph-type fft-window transform-graph? graph-style lisp-graph? left-sample
+ time-graph-style lisp-graph-style transform-graph-style combined-data-color
+ make-graph-data max-transform-peaks maxamp maxamp-position min-dB transform-normalization
+ reverse-sound right-sample show-axes show-transform-peaks show-marks
+ show-mix-waveforms show-y-zero show-grid show-sonogram-cursor grid-density
+ spectrum-end spectro-hop spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle
+ spectro-y-scale spectro-z-angle spectro-z-scale squelch-update transform->float-vector
+ transform-framples transform-type update-transform-graph update-time-graph update-lisp-graph
+ wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds x-position-slider x-axis-label
+ x-zoom-slider y-bounds y-position-slider y-zoom-slider zero-pad channel-properties channel-property ))
+ (close-sound index))
+ (if (sound? (find-sound "oboe.snd"))
+ (snd-display ";oboe.snd is still open?"))
+
+ (let ((index (open-sound "oboe.snd")))
(for-each (lambda (n)
(let ((tag
(catch #t
(lambda ()
- (n 0 float-vector-5))
+ (set! (n index 0) float-vector-5))
(lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ "; chn (no chn) procs ~A: ~A" n tag))))
- (list channel-widgets cursor channel-properties channel-property combined-data-color
- cursor-position cursor-size cursor-style tracking-cursor-style delete-sample display-edits dot-size draw-dots draw-lines
- edit-fragment edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
- transform-size transform-graph-type fft-window transform-graph?
- graph graph-style lisp-graph? insert-region insert-sound left-sample
- time-graph-style lisp-graph-style transform-graph-style
- make-graph-data max-transform-peaks maxamp maxamp-position min-dB mix-region transform-normalization
- peaks play position->x position->y reverse-sound right-sample sample
- save-sound-as show-axes show-transform-peaks show-marks
- show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
- spectrum-end spectro-hop spectrum-start spectro-x-angle
- spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale squelch-update grid-density
- transform-sample transform->float-vector transform-framples transform-type
+ (if (not (memq tag '(wrong-type-arg syntax-error error)))
+ (snd-display "; set chn procs ~A: ~A" n tag))))
+ (list channel-widgets cursor cursor-position display-edits dot-size edit-tree edits
+ fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window
+ transform-graph? graph-style lisp-graph? left-sample make-graph-data max-transform-peaks maxamp maxamp-position
+ time-graph-style lisp-graph-style transform-graph-style combined-data-color
+ min-dB transform-normalization reverse-sound right-sample show-axes grid-density
+ show-transform-peaks show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor spectrum-end spectro-hop
+ spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle
+ spectro-z-scale squelch-update transform->float-vector transform-framples transform-type
update-transform-graph update-time-graph update-lisp-graph wavelet-type time-graph? time-graph-type
- wavo-hop wavo-trace x-bounds x-position-slider x-zoom-slider x-axis-label y-axis-label y-bounds y-position-slider
- y-zoom-slider zero-pad))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (integer->sound 1234)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-sound))
- (snd-display #__line__ "; chn procs ~A: ~A" n tag))))
- (list channel-widgets cursor channel-properties
- cursor-position cursor-size cursor-style tracking-cursor-style
- (lambda (snd) (delete-sample 0 snd)) display-edits dot-size
- (lambda (snd) (edit-fragment 0 snd))
- edit-position edit-tree edits env-sound fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
- transform-size transform-graph-type fft-window transform-graph? filter-sound
- graph-data graph-style lisp-graph? left-sample
- time-graph-style lisp-graph-style transform-graph-style
- make-graph-data max-transform-peaks maxamp maxamp-position min-dB transform-normalization
- (lambda (snd) (position->x 0 snd))
- (lambda (snd) (position->y 0 snd))
- (lambda (snd) (redo 1 snd)) reverse-sound revert-sound right-sample
- (lambda (snd) (sample 0 snd))
- save-sound scale-by scale-to show-axes show-transform-peaks
- show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor
- spectrum-end spectro-hop spectrum-start spectro-x-angle
- spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle spectro-z-scale squelch-update grid-density
- src-sound
- (lambda (snd) (transform-sample 0 0 snd)) transform->float-vector
- transform-framples transform-type
- (lambda (snd) (undo 1 snd)) update-transform-graph update-time-graph update-lisp-graph
- update-sound wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds x-position-slider
- (lambda (snd) (normalize-channel 0.5 0 #f snd))
- (lambda (snd) (x->position 0 snd))
- x-zoom-slider y-bounds y-position-slider x-axis-label y-axis-label
- (lambda (snd) (y->position 0 snd)) y-zoom-slider
- zero-pad
- (lambda (snd) (scale-channel 2.0 0 #f snd))
+ wavo-hop wavo-trace x-bounds x-position-slider x-zoom-slider y-bounds y-position-slider
+ y-zoom-slider zero-pad x-axis-label
))
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n 0 1234))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-sound))
- (snd-display #__line__ "; snd(1) chn procs ~A: ~A" n tag))))
- (list delete-sample edit-fragment graph-data graph-style play position->x position->y redo
- time-graph-style lisp-graph-style transform-graph-style
- scale-by scale-to undo x->position y->position x-axis-label))
-
- (let ((index (open-sound "oboe.snd")))
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n 0 index 1234))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-channel))
- (snd-display #__line__ "; snd(1 1234) chn procs ~A: ~A" n tag))))
- (list delete-sample edit-fragment graph-data position->x position->y redo scale-by
- scale-to undo x->position y->position))
- (close-sound index))
- (if (sound? (find-sound "oboe.snd"))
- (snd-display #__line__ ";oboe.snd is still open?"))
-
- (let ((index (open-sound "oboe.snd")))
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n index 1234))
- (lambda args (car args)))))
- (if (not (member tag '(no-such-channel no-such-sound) eq?))
- (snd-display #__line__ "; chn procs ~A: ~A" n tag))))
- (list channel-widgets cursor cursor-position cursor-size cursor-style tracking-cursor-style display-edits
- dot-size edit-position edit-tree edits fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases
- transform-size transform-graph-type fft-window transform-graph? graph-style lisp-graph? left-sample
- time-graph-style lisp-graph-style transform-graph-style combined-data-color
- make-graph-data max-transform-peaks maxamp maxamp-position min-dB transform-normalization
- reverse-sound right-sample show-axes show-transform-peaks show-marks
- show-mix-waveforms show-y-zero show-grid show-sonogram-cursor grid-density
- spectrum-end spectro-hop spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle
- spectro-y-scale spectro-z-angle spectro-z-scale squelch-update transform->float-vector
- transform-framples transform-type update-transform-graph update-time-graph update-lisp-graph
- wavelet-type time-graph? time-graph-type wavo-hop wavo-trace x-bounds x-position-slider x-axis-label
- x-zoom-slider y-bounds y-position-slider y-zoom-slider zero-pad channel-properties channel-property ))
- (close-sound index))
- (if (sound? (find-sound "oboe.snd"))
- (snd-display #__line__ ";oboe.snd is still open?"))
-
- (let ((index (open-sound "oboe.snd")))
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n index 0) float-vector-5))
- (lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg syntax-error error) eq?))
- (snd-display #__line__ "; set chn procs ~A: ~A" n tag))))
- (list channel-widgets cursor cursor-position display-edits dot-size edit-tree edits
- fft-window-alpha fft-window-beta fft-log-frequency fft-log-magnitude fft-with-phases transform-size transform-graph-type fft-window
- transform-graph? graph-style lisp-graph? left-sample make-graph-data max-transform-peaks maxamp maxamp-position
- time-graph-style lisp-graph-style transform-graph-style combined-data-color
- min-dB transform-normalization reverse-sound right-sample show-axes grid-density
- show-transform-peaks show-marks show-mix-waveforms show-y-zero show-grid show-sonogram-cursor spectrum-end spectro-hop
- spectrum-start spectro-x-angle spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle
- spectro-z-scale squelch-update transform->float-vector transform-framples transform-type
- update-transform-graph update-time-graph update-lisp-graph wavelet-type time-graph? time-graph-type
- wavo-hop wavo-trace x-bounds x-position-slider x-zoom-slider y-bounds y-position-slider
- y-zoom-slider zero-pad x-axis-label
- ))
-
- (close-sound index))
- (if (sound? (find-sound "oboe.snd"))
- (snd-display #__line__ ";oboe.snd is still open?"))
-
+ (close-sound index))
+ (if (sound? (find-sound "oboe.snd"))
+ (snd-display ";oboe.snd is still open?"))
+
+ (for-each (lambda (n b)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n float-vector-5))
+ (lambda args (car args)))))
+ (if (not (memq tag '(error wrong-type-arg syntax-error)))
+ (snd-display ";[0]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
+ (list mix-amp mix-amp-env mix-length mix-name mix-position mix-home mix-speed mix-tag-y)
+ (list 'mix-amp 'mix-amp-env 'mix-length 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (integer->mix 1234)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-mix))
+ (snd-display ";[1]: mix procs ~A: ~A" n tag))))
+ (list mix-amp mix-length mix-name mix-position mix-home mix-speed mix-tag-y))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (set! (n (integer->mix 1234)) float-vector-5))
+ (lambda args (car args)))))
+ (if (not (memq tag '(error wrong-type-arg syntax-error no-such-mix)))
+ (snd-display ";[2]: mix procs ~A: ~A" n tag))))
+ (list mix-name mix-position mix-home mix-speed mix-tag-y))
+
+ (let ((index (open-sound "oboe.snd"))
+ (id (mix-sound "oboe.snd" 10)))
(for-each (lambda (n b)
(let ((tag
(catch #t
(lambda ()
- (n float-vector-5))
- (lambda args (car args)))))
- (if (not (member tag '(error wrong-type-arg syntax-error) eq?))
- (snd-display #__line__ ";[0]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
- (list mix-amp mix-amp-env mix-length mix-name mix-position mix-home mix-speed mix-tag-y)
- (list 'mix-amp 'mix-amp-env 'mix-length 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (integer->mix 1234)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-mix))
- (snd-display #__line__ ";[1]: mix procs ~A: ~A" n tag))))
- (list mix-amp mix-length mix-name mix-position mix-home mix-speed mix-tag-y))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n (integer->mix 1234)) float-vector-5))
+ (set! (n id) float-vector-5))
(lambda args (car args)))))
- (if (not (member tag '(error wrong-type-arg syntax-error no-such-mix) eq?))
- (snd-display #__line__ ";[2]: mix procs ~A: ~A" n tag))))
- (list mix-name mix-position mix-home mix-speed mix-tag-y))
-
- (let ((index (open-sound "oboe.snd"))
- (id (mix-sound "oboe.snd" 10)))
- (for-each (lambda (n b)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n id) float-vector-5))
- (lambda args (car args)))))
- (if (not (member tag '(error wrong-type-arg syntax-error) eq?))
- (snd-display #__line__ ";[3]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
- (list mix-name mix-position mix-home mix-speed mix-tag-y)
- (list 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
- (close-sound index))
- (if (sound? (find-sound "oboe.snd"))
- (snd-display #__line__ ";oboe.snd is still open?"))
-
+ (if (not (memq tag '(error wrong-type-arg syntax-error)))
+ (snd-display ";[3]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
+ (list mix-name mix-position mix-home mix-speed mix-tag-y)
+ (list 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
+ (close-sound index))
+ (if (sound? (find-sound "oboe.snd"))
+ (snd-display ";oboe.snd is still open?"))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n float-vector-5))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'wrong-type-arg))
+ (snd-display "; mark procs ~A: ~A" n tag))))
+ (list add-mark mark-name mark-sample mark-sync mark-home delete-mark delete-marks find-mark))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (integer->mark 1234)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-mark))
+ (snd-display "; no mark procs ~A: ~A" n tag))))
+ (list mark-name mark-sample mark-sync mark-home delete-mark))
+
+ (let* ((index (open-sound "oboe.snd"))
+ (id (add-mark 0 index 0)))
(for-each (lambda (n)
(let ((tag
(catch #t
(lambda ()
- (n float-vector-5))
+ (set! (n id) float-vector-5))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ "; mark procs ~A: ~A" n tag))))
- (list add-mark mark-name mark-sample mark-sync mark-home delete-mark delete-marks find-mark))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (integer->mark 1234)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-mark))
- (snd-display #__line__ "; no mark procs ~A: ~A" n tag))))
- (list mark-name mark-sample mark-sync mark-home delete-mark))
-
- (let* ((index (open-sound "oboe.snd"))
- (id (add-mark 0 index 0)))
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n id) float-vector-5))
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg))
- (snd-display #__line__ "; set mark procs ~A: ~A" n tag))))
- (list mark-name mark-sample mark-sync))
- (close-sound index))
- (if (sound? (find-sound "oboe.snd"))
- (snd-display #__line__ ";oboe.snd is still open?"))
-
- (for-each (lambda (arg)
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n arg))
- (lambda args (car args)))))
- (if (not (member tag '(wrong-type-arg wrong-number-of-args) eq?))
- (snd-display #__line__ "; region procs ~A: ~A ~A" n tag arg))))
- (list region-chans region-home region-framples
- region-position region-maxamp region-maxamp-position region-sample
- region->float-vector region-srate forget-region)))
- (list float-vector-5 #(0 1) 0+i "hiho" (list 0 1)))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (n (integer->region 1234)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-region))
- (snd-display #__line__ "; (no) region procs ~A: ~A" n tag))))
- (list region-chans region-home region-framples region-position
- region-maxamp region-maxamp-position region-srate forget-region))
-
- (for-each (lambda (n)
- (let ((tag
- (catch #t
- (lambda ()
- (set! (n) float-vector-5))
- (lambda args (car args)))))
- (if (not (member tag '(error wrong-type-arg syntax-error) eq?))
- (snd-display #__line__ "; misc procs ~A: ~A" n tag))))
- (list axis-color enved-filter-order enved-filter filter-control-waveform-color ask-before-overwrite ask-about-unsaved-edits
- auto-resize auto-update axis-label-font axis-numbers-font basic-color bind-key show-full-duration show-full-range initial-beg initial-dur
- channel-style color-cutoff color-orientation-dialog color-inverted color-scale
- cursor-color dac-combines-channels dac-size clipping data-color default-output-chans
- default-output-sample-type default-output-srate default-output-header-type enved-envelope enved-base
- enved-clip? enved-in-dB enved-dialog enved-style enved-power enved-target
- enved-waveform-color enved-wave? eps-file eps-left-margin eps-bottom-margin eps-size
- foreground-color graph-color graph-cursor highlight-color just-sounds key-binding
- listener-color listener-font listener-prompt listener-text-color max-regions
- mix-waveform-height region-graph-style position-color
- time-graph-style lisp-graph-style transform-graph-style peaks-font bold-peaks-font
- print-length play-arrow-size sash-color ladspa-dir peak-env-dir save-dir save-state-file
- selected-channel selected-data-color selected-graph-color
- selected-sound selection-creates-region show-controls show-indices show-listener
- show-selection-transform sinc-width temp-dir text-focus-color tiny-font
- with-file-monitor unbind-key with-verbose-cursor
- with-inset-graph with-interrupts with-pointer-focus window-height beats-per-measure with-smpte-label
- with-toolbar with-tooltips with-menu-icons remember-sound-state save-as-dialog-src save-as-dialog-auto-comment
- window-width window-x window-y with-gl with-mix-tags x-axis-style beats-per-minute zoom-color mix-tag-height
- mix-tag-width with-relative-panes clm-table-size clm-default-frequency mark-tag-width mark-tag-height
- ))
-
-
- (set! *ask-about-unsaved-edits* #f)
- (set! *remember-sound-state* #f)
- (if (= test-28 0)
- (begin
- (check-error-tag 'no-such-envelope (lambda () (set! (enved-envelope) "not-an-env")))
- (check-error-tag 'wrong-type-arg (lambda () (envelope-interp 1.0 '(0 0 .5))))
- (check-error-tag 'cannot-save (lambda () (save-envelopes "/bad/baddy")))
- (check-error-tag 'cannot-save (lambda () (mus-sound-report-cache "/bad/baddy")))
- (check-error-tag 'bad-arity (lambda () (set! (search-procedure) (lambda (a b c) a))))
- (check-error-tag 'no-such-channel (lambda () (make-sampler 0 "oboe.snd" 1)))
- (check-error-tag 'no-such-channel (lambda () (make-sampler 0 "oboe.snd" -1)))
- (check-error-tag 'bad-arity (lambda () (bind-key (char->integer #\p) 0 (lambda (a b) (play-often (max 1 a))))))
- (check-error-tag 'bad-arity (lambda () (set! *zoom-focus-style* (lambda (a) 0))))
- (check-error-tag 'bad-header (lambda () (mus-file-mix "oboe.snd" (string-append sf-dir "bad_chans.aifc"))))
- (check-error-tag 'mus-error (lambda () (mus-file-mix "oboe.snd" (string-append sf-dir "bad_length.aifc"))))
- (check-error-tag 'bad-header (lambda () (mus-file-mix (string-append sf-dir "bad_chans.aifc") "oboe.snd")))
- (check-error-tag 'no-such-sound (lambda () (set! (sound-loop-info 123) '(0 0 1 1))))
- (check-error-tag 'bad-header (lambda () (new-sound "fmv.snd" 2 22050 mus-bfloat mus-nist "this is a comment")))
- (check-error-tag 'wrong-type-arg (lambda () (player-home 123)))
- (check-error-tag 'no-such-file (lambda () (set! *temp-dir* "/hiho")))
- (check-error-tag 'no-such-file (lambda () (set! *save-dir* "/hiho")))
- (check-error-tag 'out-of-range (lambda () (snd-transform (integer->transform 20) (make-float-vector 4))))
- (check-error-tag 'bad-header (lambda () (mus-sound-maxamp (string-append sf-dir "bad_chans.snd"))))
- (check-error-tag 'mus-error (lambda () (make-iir-filter :order 32 :ycoeffs (make-float-vector 4))))
- (check-error-tag 'mus-error (lambda () (make-iir-filter :coeffs (make-float-vector 4) :ycoeffs (make-float-vector 4))))
- (check-error-tag 'mus-error (lambda () (make-fir-filter :coeffs (make-float-vector 4) :xcoeffs (make-float-vector 4))))
- (check-error-tag 'out-of-range (lambda () (make-table-lookup :size 123456789)))
+ (snd-display "; set mark procs ~A: ~A" n tag))))
+ (list mark-name mark-sample mark-sync))
+ (close-sound index))
+ (if (sound? (find-sound "oboe.snd"))
+ (snd-display ";oboe.snd is still open?"))
+
+ (for-each (lambda (arg)
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n arg))
+ (lambda args (car args)))))
+ (if (not (memq tag '(wrong-type-arg wrong-number-of-args)))
+ (snd-display "; region procs ~A: ~A ~A" n tag arg))))
+ (list region-chans region-home region-framples
+ region-position region-maxamp region-maxamp-position region-sample
+ region->float-vector region-srate forget-region)))
+ (list float-vector-5 #(0 1) 0+i "hiho" (list 0 1)))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (n (integer->region 1234)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-region))
+ (snd-display "; (no) region procs ~A: ~A" n tag))))
+ (list region-chans region-home region-framples region-position
+ region-maxamp region-maxamp-position region-srate forget-region))
+
+ (for-each (lambda (n)
+ (let ((tag
+ (catch #t
+ (lambda ()
+ (set! (n) float-vector-5))
+ (lambda args (car args)))))
+ (if (not (memq tag '(error wrong-type-arg syntax-error)))
+ (snd-display "; misc procs ~A: ~A" n tag))))
+ (list axis-color enved-filter-order enved-filter filter-control-waveform-color ask-before-overwrite ask-about-unsaved-edits
+ auto-resize auto-update axis-label-font axis-numbers-font basic-color bind-key show-full-duration show-full-range initial-beg initial-dur
+ channel-style color-cutoff color-orientation-dialog color-inverted color-scale
+ cursor-color dac-combines-channels dac-size clipping data-color default-output-chans
+ default-output-sample-type default-output-srate default-output-header-type enved-envelope enved-base
+ enved-clip? enved-in-dB enved-dialog enved-style enved-power enved-target
+ enved-waveform-color enved-wave? eps-file eps-left-margin eps-bottom-margin eps-size
+ foreground-color graph-color graph-cursor highlight-color just-sounds key-binding
+ listener-color listener-font listener-prompt listener-text-color max-regions
+ mix-waveform-height region-graph-style position-color
+ time-graph-style lisp-graph-style transform-graph-style peaks-font bold-peaks-font
+ print-length play-arrow-size sash-color ladspa-dir peak-env-dir save-dir save-state-file
+ selected-channel selected-data-color selected-graph-color
+ selected-sound selection-creates-region show-controls show-indices show-listener
+ show-selection-transform sinc-width stdin-prompt temp-dir text-focus-color tiny-font
+ with-file-monitor unbind-key with-verbose-cursor
+ with-inset-graph with-interrupts with-pointer-focus window-height beats-per-measure with-smpte-label
+ with-toolbar with-tooltips with-menu-icons remember-sound-state save-as-dialog-src save-as-dialog-auto-comment
+ window-width window-x window-y with-gl with-mix-tags x-axis-style beats-per-minute zoom-color mix-tag-height
+ mix-tag-width with-relative-panes clm-table-size clm-default-frequency mark-tag-width mark-tag-height
+ ))
+
+
+ (set! *ask-about-unsaved-edits* #f)
+ (set! *remember-sound-state* #f)
+ (when (zero? test-errors)
+ (check-error-tag 'no-such-envelope (lambda () (set! (enved-envelope) "not-an-env")))
+ (check-error-tag 'wrong-type-arg (lambda () (envelope-interp 1.0 '(0 0 .5))))
+ (check-error-tag 'cannot-save (lambda () (save-envelopes "/bad/baddy")))
+ (check-error-tag 'cannot-save (lambda () (mus-sound-report-cache "/bad/baddy")))
+ (check-error-tag 'bad-arity (lambda () (set! (search-procedure) (lambda (a b c) a))))
+ (check-error-tag 'no-such-channel (lambda () (make-sampler 0 "oboe.snd" 1)))
+ (check-error-tag 'no-such-channel (lambda () (make-sampler 0 "oboe.snd" -1)))
+ (check-error-tag 'bad-arity (lambda () (bind-key (char->integer #\p) 0 (lambda (a b) (play-often (max 1 a))))))
+ (check-error-tag 'bad-arity (lambda () (set! *zoom-focus-style* (lambda (a) 0))))
+ (check-error-tag 'bad-header (lambda () (mus-file-mix "oboe.snd" (string-append sf-dir "bad_chans.aifc"))))
+ (check-error-tag 'mus-error (lambda () (mus-file-mix "oboe.snd" (string-append sf-dir "bad_length.aifc"))))
+ (check-error-tag 'bad-header (lambda () (mus-file-mix (string-append sf-dir "bad_chans.aifc") "oboe.snd")))
+ (check-error-tag 'no-such-sound (lambda () (set! (sound-loop-info 123) '(0 0 1 1))))
+ (check-error-tag 'bad-header (lambda () (new-sound "fmv.snd" 2 22050 mus-bfloat mus-nist "this is a comment")))
+ (check-error-tag 'wrong-type-arg (lambda () (player-home 123)))
+ (check-error-tag 'no-such-file (lambda () (set! *temp-dir* "/hiho")))
+ (check-error-tag 'no-such-file (lambda () (set! *save-dir* "/hiho")))
+ (check-error-tag 'out-of-range (lambda () (snd-transform (integer->transform 20) (make-float-vector 4))))
+ (check-error-tag 'bad-header (lambda () (mus-sound-maxamp (string-append sf-dir "bad_chans.snd"))))
+ (check-error-tag 'mus-error (lambda () (make-iir-filter :order 32 :ycoeffs (make-float-vector 4))))
+ (check-error-tag 'mus-error (lambda () (make-iir-filter :coeffs (make-float-vector 4) :ycoeffs (make-float-vector 4))))
+ (check-error-tag 'mus-error (lambda () (make-fir-filter :coeffs (make-float-vector 4) :xcoeffs (make-float-vector 4))))
+ (check-error-tag 'out-of-range (lambda () (make-table-lookup :size 123456789)))
; (check-error-tag 'out-of-range (lambda () (make-src :srate -0.5)))
- (check-error-tag 'out-of-range (lambda () (make-granulate :ramp -0.5)))
- (check-error-tag 'out-of-range (lambda () (make-granulate :ramp 1.5)))
- (check-error-tag 'mus-error (lambda () (make-granulate :expansion 32000.0)))
- (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :channels 0)))
- (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :srate 0)))
- (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :size -1)))
- (check-error-tag 'out-of-range (lambda () (make-readin "oboe.snd" :size 0)))
- (check-error-tag 'out-of-range (lambda () (make-readin "oboe.snd" :size -1)))
- (check-error-tag 'out-of-range (lambda () (make-file->sample "oboe.snd" 0)))
- (check-error-tag 'out-of-range (lambda () (make-file->sample "oboe.snd" -1)))
- (check-error-tag 'out-of-range (lambda () (make-file->frample "oboe.snd" 0)))
- (check-error-tag 'out-of-range (lambda () (make-file->frample "oboe.snd" -1)))
- (check-error-tag 'out-of-range (lambda () (set! *default-output-sample-type* -1)))
- (check-error-tag 'out-of-range (lambda () (set! *default-output-header-type* mus-soundfont)))
- (check-error-tag 'mus-error (lambda () (mus-sound-chans (string-append sf-dir "bad_location.nist"))))
- (check-error-tag 'mus-error (lambda () (mus-sound-chans (string-append sf-dir "bad_field.nist"))))
- (check-error-tag 'mus-error (lambda () (make-locsig 1/0 :channels 2)))
- (if (provided? 'snd-motif)
- (begin
- (check-error-tag 'no-such-widget (lambda () (widget-position (list 'Widget 0)))) ; dubious -- not sure these should be supported
- (check-error-tag 'no-such-widget (lambda () (widget-size (list 'Widget 0))))
- (check-error-tag 'no-such-widget (lambda () (widget-text (list 'Widget 0))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-position (list 'Widget 0)) (list 0 0))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-size (list 'Widget 0)) (list 10 10))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-text (list 'Widget 0)) "hiho")))
- ))
- (check-error-tag 'no-such-menu (lambda () (main-menu -1)))
- (check-error-tag 'no-such-menu (lambda () (main-menu 111)))
- (check-error-tag 'out-of-range (lambda () (new-sound "hiho" :header-type 123)))
- (check-error-tag 'out-of-range (lambda () (new-sound "hiho" :header-type mus-nist :sample-type 123)))
- (check-error-tag 'bad-header (lambda () (new-sound "hiho" :header-type mus-nist :sample-type mus-bfloat)))
- (check-error-tag 'out-of-range (lambda () (set! *mus-array-print-length* -1)))
- (check-error-tag 'out-of-range (lambda () (set! *print-length* -1)))
- (check-error-tag 'out-of-range (lambda () (set! *play-arrow-size* -1)))
- (check-error-tag 'out-of-range (lambda () (set! *enved-style* 12)))
- (check-error-tag 'out-of-range (lambda () (make-color 1.5 0.0 0.0)))
- (check-error-tag 'out-of-range (lambda () (make-color -0.5 0.0 0.0)))
- (check-error-tag 'wrong-type-arg (lambda () (make-variable-graph #f)))
- (check-error-tag 'cannot-print graph->ps)
- (let ((ind (open-sound "oboe.snd")))
- (set! *selection-creates-region* #t)
- (select-all)
- (check-error-tag 'mus-error (lambda () (save-selection "sel0.snd" :not-a-key 3)))
- (check-error-tag 'wrong-type-arg (lambda () (read-only (list ind))))
- (check-error-tag 'wrong-type-arg (lambda () (framples ind (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (smooth-sound 0 -10)))
- (check-error-tag 'no-such-channel (lambda () (mix-selection 0 ind 123)))
- (check-error-tag 'no-such-channel (lambda () (insert-selection 0 ind 123)))
- (check-error-tag 'out-of-range (lambda () (set! (channels ind) 0)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (channels ind) -1)))
- (check-error-tag 'out-of-range (lambda () (set! (channels ind) 12340)))
- (check-error-tag 'out-of-range (lambda () (set! (sample-type ind) 12340)))
- (check-error-tag 'out-of-range (lambda () (set! (header-type ind) 12340)))
- (check-error-tag 'out-of-range (lambda () (set! (srate ind) 0)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (data-location ind) -1)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (data-size ind) -1)))
- (check-error-tag 'no-such-sample (lambda () (set! (sample -1) -1)))
- (check-error-tag 'no-such-sample (lambda () (sample -1)))
- (check-error-tag 'out-of-range (lambda () (set! (framples) -10)))
- (check-error-tag 'out-of-range (lambda () (set! *min-dB* 0.0)))
- (check-error-tag 'out-of-range (lambda () (set! (min-dB ind 0) 0.0)))
- (check-error-tag 'out-of-range (lambda () (start-playing 1 -22)))
- (check-error-tag 'out-of-range (lambda () (start-playing 1 0)))
- (check-error-tag 'out-of-range (lambda () (set! (filter-control-envelope ind) (list 0.0 1.0 0.1 -0.1 1.0 0.0))))
- (check-error-tag 'out-of-range (lambda () (set! (filter-control-envelope ind) (list 0.0 1.0 0.1 1.1 1.0 0.0))))
- (check-error-tag 'env-error (lambda () (filter-sound '(0 0 .1 .1 .05 .1 1 1) 32)))
- (check-error-tag 'out-of-range (lambda () (apply-controls ind 123)))
- (check-error-tag 'out-of-range (lambda () (set! (speed-control-bounds) (list 0.0 2.0))))
- (check-error-tag 'out-of-range (lambda () (set! (expand-control-bounds) (list 0.0 2.0))))
- (check-error-tag 'out-of-range (lambda () (set! (speed-control-bounds) (list 2.0 0.0))))
- (check-error-tag 'out-of-range (lambda () (set! (expand-control-bounds) (list 2.0 0.0))))
- (check-error-tag 'bad-header (lambda () (insert-sound (string-append sf-dir "bad_chans.snd"))))
- (check-error-tag 'IO-error (lambda () (convolve-with (string-append sf-dir "bad_chans.snd"))))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "hiho.snd" ind -12)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "hiho.snd" ind :header-type mus-next :sample-type -12)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-nist :sample-type mus-bdouble)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-aifc :sample-type mus-lfloat)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-riff :sample-type mus-bshort)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-voc :sample-type mus-bshort)))
- (check-error-tag 'cannot-save (lambda () (save-selection "test.snd" 22050 mus-bshort mus-riff)))
- (check-error-tag 'cannot-save (lambda () (save-selection "test.snd" 22050 mus-bshort mus-voc)))
- (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 0 1 1) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 1 1 0) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 1 1 -1) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 -1 1 1) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 0 1 1) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 1 1 0) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 1 1 -1) :length 11))))
- (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 -1 1 1) :length 11))))
- (check-error-tag 'mus-error (lambda () (make-readin 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
- (check-error-tag 'out-of-range (lambda () (filter-sound float-vector-3 32)))
- (check-error-tag 'out-of-range (lambda () (filter-sound '(0 0 1 1) 0)))
- (check-error-tag 'no-such-sound (lambda () (swap-channels ind 0 12345 0)))
- (check-error-tag 'no-such-sample (lambda () (mix-float-vector (float-vector 0.1 0.2 0.3) -1 ind 0 #t)))
- (check-error-tag 'out-of-range (lambda () (snd-spectrum (make-float-vector 8) 0 -123)))
- (check-error-tag 'out-of-range (lambda () (snd-spectrum (make-float-vector 8) 0 0)))
- (check-error-tag 'no-such-file (lambda () (play "/baddy/hiho")))
- (check-error-tag 'bad-sample-type (lambda () (play (string-append sf-dir "nist-shortpack.wav"))))
+ (check-error-tag 'out-of-range (lambda () (make-granulate :ramp -0.5)))
+ (check-error-tag 'out-of-range (lambda () (make-granulate :ramp 1.5)))
+ (check-error-tag 'mus-error (lambda () (make-granulate :expansion 32000.0)))
+ (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :channels 0)))
+ (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :srate 0)))
+ (check-error-tag 'out-of-range (lambda () (new-sound "test.snd" :size -1)))
+ (check-error-tag 'out-of-range (lambda () (make-readin "oboe.snd" :size 0)))
+ (check-error-tag 'out-of-range (lambda () (make-readin "oboe.snd" :size -1)))
+ (check-error-tag 'out-of-range (lambda () (make-file->sample "oboe.snd" 0)))
+ (check-error-tag 'out-of-range (lambda () (make-file->sample "oboe.snd" -1)))
+ (check-error-tag 'out-of-range (lambda () (make-file->frample "oboe.snd" 0)))
+ (check-error-tag 'out-of-range (lambda () (make-file->frample "oboe.snd" -1)))
+ (check-error-tag 'out-of-range (lambda () (set! *default-output-sample-type* -1)))
+ (check-error-tag 'out-of-range (lambda () (set! *default-output-header-type* mus-soundfont)))
+ (check-error-tag 'mus-error (lambda () (mus-sound-chans (string-append sf-dir "bad_location.nist"))))
+ (check-error-tag 'mus-error (lambda () (mus-sound-chans (string-append sf-dir "bad_field.nist"))))
+ (check-error-tag 'mus-error (lambda () (make-locsig 1/0 :channels 2)))
+ (when (provided? 'snd-motif)
+ (check-error-tag 'no-such-widget (lambda () (widget-position (list 'Widget 0)))) ; dubious -- not sure these should be supported
+ (check-error-tag 'no-such-widget (lambda () (widget-size (list 'Widget 0))))
+ (check-error-tag 'no-such-widget (lambda () (widget-text (list 'Widget 0))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-position (list 'Widget 0)) (list 0 0))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-size (list 'Widget 0)) (list 10 10))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-text (list 'Widget 0)) "hiho"))))
+ (check-error-tag 'no-such-menu (lambda () (main-menu -1)))
+ (check-error-tag 'no-such-menu (lambda () (main-menu 111)))
+ (check-error-tag 'out-of-range (lambda () (new-sound "hiho" :header-type 123)))
+ (check-error-tag 'out-of-range (lambda () (new-sound "hiho" :header-type mus-nist :sample-type 123)))
+ (check-error-tag 'bad-header (lambda () (new-sound "hiho" :header-type mus-nist :sample-type mus-bfloat)))
+ (check-error-tag 'out-of-range (lambda () (set! *mus-array-print-length* -1)))
+ (check-error-tag 'out-of-range (lambda () (set! *print-length* -1)))
+ (check-error-tag 'out-of-range (lambda () (set! *play-arrow-size* -1)))
+ (check-error-tag 'out-of-range (lambda () (set! *enved-style* 12)))
+ (check-error-tag 'out-of-range (lambda () (make-color 1.5 0.0 0.0)))
+ (check-error-tag 'out-of-range (lambda () (make-color -0.5 0.0 0.0)))
+ (check-error-tag 'wrong-type-arg (lambda () (make-variable-graph #f)))
+ (check-error-tag 'cannot-print graph->ps)
+ (let ((ind (open-sound "oboe.snd")))
+ (set! *selection-creates-region* #t)
+ (select-all)
+ (check-error-tag 'mus-error (lambda () (save-selection "sel0.snd" :not-a-key 3)))
+ (check-error-tag 'wrong-type-arg (lambda () (read-only (list ind))))
+ (check-error-tag 'wrong-type-arg (lambda () (framples ind (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (smooth-sound 0 -10)))
+ (check-error-tag 'no-such-channel (lambda () (mix-selection 0 ind 123)))
+ (check-error-tag 'no-such-channel (lambda () (insert-selection 0 ind 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (channels ind) 0)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (channels ind) -1)))
+ (check-error-tag 'out-of-range (lambda () (set! (channels ind) 12340)))
+ (check-error-tag 'out-of-range (lambda () (set! (sample-type ind) 12340)))
+ (check-error-tag 'out-of-range (lambda () (set! (header-type ind) 12340)))
+ (check-error-tag 'out-of-range (lambda () (set! (srate ind) 0)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (data-location ind) -1)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (data-size ind) -1)))
+ (check-error-tag 'no-such-sample (lambda () (set! (sample -1) -1)))
+ (check-error-tag 'no-such-sample (lambda () (sample -1)))
+ (check-error-tag 'out-of-range (lambda () (set! (framples) -10)))
+ (check-error-tag 'out-of-range (lambda () (set! *min-dB* 0.0)))
+ (check-error-tag 'out-of-range (lambda () (set! (min-dB ind 0) 0.0)))
+ (check-error-tag 'out-of-range (lambda () (start-playing 1 -22)))
+ (check-error-tag 'out-of-range (lambda () (start-playing 1 0)))
+ (check-error-tag 'out-of-range (lambda () (set! (filter-control-envelope ind) (list 0.0 1.0 0.1 -0.1 1.0 0.0))))
+ (check-error-tag 'out-of-range (lambda () (set! (filter-control-envelope ind) (list 0.0 1.0 0.1 1.1 1.0 0.0))))
+ (check-error-tag 'env-error (lambda () (filter-sound '(0 0 .1 .1 .05 .1 1 1) 32)))
+ (check-error-tag 'out-of-range (lambda () (apply-controls ind 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (speed-control-bounds) (list 0.0 2.0))))
+ (check-error-tag 'out-of-range (lambda () (set! (expand-control-bounds) (list 0.0 2.0))))
+ (check-error-tag 'out-of-range (lambda () (set! (speed-control-bounds) (list 2.0 0.0))))
+ (check-error-tag 'out-of-range (lambda () (set! (expand-control-bounds) (list 2.0 0.0))))
+ (check-error-tag 'bad-header (lambda () (insert-sound (string-append sf-dir "bad_chans.snd"))))
+ (check-error-tag 'IO-error (lambda () (convolve-with (string-append sf-dir "bad_chans.snd"))))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "hiho.snd" ind -12)))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "hiho.snd" ind :header-type mus-next :sample-type -12)))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-nist :sample-type mus-bdouble)))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-aifc :sample-type mus-lfloat)))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-riff :sample-type mus-bshort)))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "test.snd" ind :header-type mus-voc :sample-type mus-bshort)))
+ (check-error-tag 'cannot-save (lambda () (save-selection "test.snd" 22050 mus-bshort mus-riff)))
+ (check-error-tag 'cannot-save (lambda () (save-selection "test.snd" 22050 mus-bshort mus-voc)))
+ (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 0 1 1) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 1 1 0) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 1 1 -1) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-channel (make-env '(0 -1 1 1) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 0 1 1) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 1 1 0) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 1 1 -1) :length 11))))
+ (check-error-tag 'out-of-range (lambda () (src-sound (make-env '(0 -1 1 1) :length 11))))
+ (check-error-tag 'mus-error (lambda () (make-readin 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
+ (check-error-tag 'out-of-range (lambda () (filter-sound float-vector-3 32)))
+ (check-error-tag 'out-of-range (lambda () (filter-sound '(0 0 1 1) 0)))
+ (check-error-tag 'no-such-sound (lambda () (swap-channels ind 0 12345 0)))
+ (check-error-tag 'no-such-sample (lambda () (mix-float-vector (float-vector 0.1 0.2 0.3) -1 ind 0 #t)))
+ (check-error-tag 'out-of-range (lambda () (snd-spectrum (make-float-vector 8) 0 -123)))
+ (check-error-tag 'out-of-range (lambda () (snd-spectrum (make-float-vector 8) 0 0)))
+ (check-error-tag 'no-such-file (lambda () (play "/baddy/hiho")))
+ (check-error-tag 'bad-sample-type (lambda () (play (string-append sf-dir "nist-shortpack.wav"))))
; (check-error-tag 'no-such-channel (lambda () (play ind 0 :channel 123)))
- (check-error-tag 'no-such-channel (lambda () (make-player ind 123)))
- (check-error-tag 'no-such-file (lambda () (mix "/baddy/hiho")))
- (check-error-tag 'no-such-channel (lambda () (mix "oboe.snd" 0 2)))
- (check-error-tag 'no-such-file (lambda () (mix-sound "/baddy/hiho" 0)))
- (check-error-tag 'no-such-file (lambda () (insert-sound "/baddy/hiho.snd")))
- (check-error-tag 'no-such-file (lambda () (insert-samples 0 10 "/baddy/hiho.snd")))
- (check-error-tag 'no-data (lambda () (set! (filter-control-envelope ind) ())))
- (check-error-tag 'out-of-range (lambda () (set! (sample-type ind) 123)))
- (check-error-tag 'out-of-range (lambda () (set! (header-type ind) 123)))
- (check-error-tag 'no-such-channel (lambda () (set! (selected-channel ind) 123)))
- (check-error-tag 'bad-arity (lambda () (set! (search-procedure) (lambda (a b c) #t))))
- (check-error-tag 'bad-arity (lambda () (map-channel (lambda (a b c) 1.0))))
- (check-error-tag 'bad-arity (lambda () (scan-channel (lambda (a b c) 1.0))))
- (check-error-tag 'bad-arity (lambda () (set! (cursor-style ind 0) (lambda (a) 32))))
- (check-error-tag 'no-such-graphics-context (lambda () (draw-line 0 0 1 1 ind 0 1234)))
- (check-error-tag 'no-such-graphics-context (lambda () (foreground-color ind 0 1234)))
- (check-error-tag 'no-such-graphics-context (lambda () (current-font ind 0 1234)))
- (check-error-tag 'no-such-graphics-context (lambda () (graph-data (list float-vector-3 float-vector-3) ind 0 1234 0 1 0)))
- (check-error-tag 'no-such-axis (lambda () (position->x 100 ind 0 1234)))
- (check-error-tag 'no-such-axis (lambda () (position->y 100 ind 0 1234)))
- (check-error-tag 'no-such-axis (lambda () (x->position 100 ind 0 1234)))
- (check-error-tag 'no-such-axis (lambda () (y->position 100 ind 0 1234)))
- (check-error-tag 'no-such-axis (lambda () (axis-info ind 0 1234)))
- (check-error-tag 'out-of-range (lambda () (draw-axes (car (channel-widgets)) (car (snd-gcs)) "hiho" 0.0 1.0 -1.0 1.0 x-axis-in-seconds 1234)))
- (check-error-tag 'out-of-range (lambda () (draw-axes (car (channel-widgets)) (car (snd-gcs)) "hiho" 0.0 1.0 -1.0 1.0 1234)))
- (check-error-tag 'no-such-channel (lambda () (axis-info ind 1234)))
- (check-error-tag 'no-such-sound (lambda () (axis-info 1234)))
- (set! *time-graph-type* graph-once)
+ (check-error-tag 'no-such-channel (lambda () (make-player ind 123)))
+ (check-error-tag 'no-such-file (lambda () (mix "/baddy/hiho")))
+ (check-error-tag 'no-such-channel (lambda () (mix "oboe.snd" 0 2)))
+ (check-error-tag 'no-such-file (lambda () (mix-sound "/baddy/hiho" 0)))
+ (check-error-tag 'no-such-file (lambda () (insert-sound "/baddy/hiho.snd")))
+ (check-error-tag 'no-such-file (lambda () (insert-samples 0 10 "/baddy/hiho.snd")))
+ (check-error-tag 'no-data (lambda () (set! (filter-control-envelope ind) ())))
+ (check-error-tag 'out-of-range (lambda () (set! (sample-type ind) 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (header-type ind) 123)))
+ (check-error-tag 'no-such-channel (lambda () (set! (selected-channel ind) 123)))
+ (check-error-tag 'bad-arity (lambda () (set! (search-procedure) (lambda (a b c) #t))))
+ (check-error-tag 'bad-arity (lambda () (map-channel (lambda (a b c) 1.0))))
+ (check-error-tag 'bad-arity (lambda () (scan-channel (lambda (a b c) 1.0))))
+ (check-error-tag 'bad-arity (lambda () (set! (cursor-style ind 0) (lambda (a) 32))))
+ (check-error-tag 'no-such-graphics-context (lambda () (draw-line 0 0 1 1 ind 0 1234)))
+ (check-error-tag 'no-such-graphics-context (lambda () (foreground-color ind 0 1234)))
+ (check-error-tag 'no-such-graphics-context (lambda () (current-font ind 0 1234)))
+ (check-error-tag 'no-such-graphics-context (lambda () (graph-data (list float-vector-3 float-vector-3) ind 0 1234 0 1 0)))
+ (check-error-tag 'no-such-axis (lambda () (position->x 100 ind 0 1234)))
+ (check-error-tag 'no-such-axis (lambda () (position->y 100 ind 0 1234)))
+ (check-error-tag 'no-such-axis (lambda () (x->position 100 ind 0 1234)))
+ (check-error-tag 'no-such-axis (lambda () (y->position 100 ind 0 1234)))
+ (check-error-tag 'no-such-axis (lambda () (axis-info ind 0 1234)))
+ (check-error-tag 'out-of-range (lambda () (draw-axes (car (channel-widgets)) (car (snd-gcs)) "hiho" 0.0 1.0 -1.0 1.0 x-axis-in-seconds 1234)))
+ (check-error-tag 'out-of-range (lambda () (draw-axes (car (channel-widgets)) (car (snd-gcs)) "hiho" 0.0 1.0 -1.0 1.0 1234)))
+ (check-error-tag 'no-such-channel (lambda () (axis-info ind 1234)))
+ (check-error-tag 'no-such-sound (lambda () (axis-info 1234)))
+ (set! *time-graph-type* graph-once)
; (check-error-tag 'out-of-range (lambda () (set! (x-bounds) (list 0 0))))
- (check-error-tag 'out-of-range (lambda () (set! (x-bounds) (list .1 -.1))))
+ (check-error-tag 'out-of-range (lambda () (set! (x-bounds) (list .1 -.1))))
; (check-error-tag 'out-of-range (lambda () (set! (y-bounds) (list .2 .1))))
- (check-error-tag 'out-of-range (lambda () (make-region 100 0)))
- (check-error-tag 'no-such-sample (lambda () (delete-sample -1)))
- (check-error-tag 'no-such-sample (lambda () (delete-sample (* 2 (framples ind)))))
- (check-error-tag 'no-such-file (lambda () (play "/bad/baddy.snd")))
- (check-error-tag 'no-such-sound (lambda () (play 1234 0)))
+ (check-error-tag 'out-of-range (lambda () (make-region 100 0)))
+ (check-error-tag 'no-such-sample (lambda () (delete-sample -1)))
+ (check-error-tag 'no-such-sample (lambda () (delete-sample (* 2 (framples ind)))))
+ (check-error-tag 'no-such-file (lambda () (play "/bad/baddy.snd")))
+ (check-error-tag 'no-such-sound (lambda () (play 1234 0)))
; (check-error-tag 'no-such-channel (lambda () (play ind 0 :channel 1234)))
- (if (= (length (regions)) 0) (make-region 0 100))
- (check-error-tag 'no-such-channel (lambda () (region-sample (car (regions)) 0 1234)))
- (check-error-tag 'no-such-channel (lambda () (region-framples (car (regions)) 1234)))
- (check-error-tag 'no-such-channel (lambda () (region-position (car (regions)) 1234)))
+ (if (null? (regions)) (make-region 0 100))
+ (check-error-tag 'no-such-channel (lambda () (region-sample (car (regions)) 0 1234)))
+ (check-error-tag 'no-such-channel (lambda () (region-framples (car (regions)) 1234)))
+ (check-error-tag 'no-such-channel (lambda () (region-position (car (regions)) 1234)))
; (check-error-tag 'no-such-region (lambda () (region->float-vector #f 0 1)))
; (check-error-tag 'no-such-channel (lambda () (region->float-vector (car regions) 0 1 1234)))
- (check-error-tag 'cannot-save (lambda () (save-sound-as "/bad/baddy.snd")))
- (check-error-tag 'no-such-sound (lambda () (transform-sample 0 1 1234)))
- (check-error-tag 'no-such-channel (lambda () (transform-sample 0 1 ind 1234)))
- (check-error-tag 'no-such-sound (lambda () (graph (float-vector 0 1) "hi" 0 1 0 1 1234)))
- (check-error-tag 'no-such-channel (lambda () (graph (float-vector 0 1) "hi" 0 1 0 1 ind 1234)))
- (set! (selection-member? #t) #f)
- (check-error-tag 'no-active-selection (lambda () (filter-selection (float-vector 0 0 1 1) 4)))
- (check-error-tag 'no-active-selection (lambda () (save-selection "/bad/baddy.snd")))
- (check-error-tag 'no-active-selection (lambda () (env-selection '(0 0 1 1))))
- (check-error-tag 'no-such-region (lambda () (save-region (integer->region 1234) "/bad/baddy.snd")))
- (make-region 0 100 ind 0)
- (check-error-tag 'cannot-save (lambda () (save-selection "/bad/baddy.snd")))
- (check-error-tag 'cannot-save (lambda () (save-region (car (regions)) "/bad/baddy.snd")))
- (check-error-tag 'no-such-mix (lambda () (make-mix-sampler (integer->mix 1234))))
- (check-error-tag 'no-such-sound (lambda () (make-region 0 12 1234 #t)))
- (set! (read-only ind) #t)
- (check-error-tag 'cannot-save (lambda () (set! (sound-loop-info ind) '(0 0 1 1))))
- (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 123)))
- (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 0)))
- (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 -2)))
- (check-error-tag 'no-data (lambda () (scale-by ())))
- (check-error-tag 'no-data (lambda () (scale-to ())))
- (check-error-tag 'no-such-sample (lambda () (set! (selection-position ind 0) -999)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (selection-framples ind 0) -999)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (selection-framples ind 0) 0)))
- (check-error-tag 'no-such-edit (lambda () (edit-fragment -1)))
- (check-error-tag 'no-such-edit (lambda () (edit-fragment 101 ind 0)))
- (check-error-tag 'no-such-edit (lambda () (edit-tree ind 0 -2)))
- (check-error-tag 'no-such-edit (lambda () (edit-tree ind 0 101)))
- (check-error-tag 'no-such-sample (lambda () (add-mark -1)))
- (check-error-tag 'no-such-sample (lambda () (add-mark (* 2 (framples)))))
- (check-error-tag 'no-such-file (lambda () (convolve-with "/bad/baddy")))
- (check-error-tag 'no-such-file (lambda () (mix "/bad/baddy")))
- (check-error-tag 'no-such-sound (lambda () (swap-channels ind 0 123)))
- (check-error-tag 'out-of-range (lambda () (set! (show-axes ind 0) 123)))
- (check-error-tag 'out-of-range (lambda () (set! (show-axes ind 0) -123)))
- (check-error-tag 'out-of-range (lambda () (set! (x-axis-style ind 0) 123)))
- (check-error-tag 'out-of-range (lambda () (set! (x-axis-style ind 0) -123)))
- (check-error-tag 'out-of-range (lambda () (set! (graph-style ind 0) 123)))
- (check-error-tag 'out-of-range (lambda () (set! (graph-style ind 0) -123)))
- (check-error-tag 'out-of-range (lambda () (env-sound '(0 0 1 1) 0 #f -1.5)))
- (check-error-tag 'out-of-range (lambda () (xramp-channel 0.0 1.0 -1.6)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (samples 0 2) -1)))
- (check-error-tag 'wrong-type-arg (lambda () (left-sample (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (amp-control (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (sound-loop-info (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (add-mark 123 (list 0))))
- (check-error-tag 'no-such-sound (lambda () (filter-channel '(0 0 1 1) 100 #f #f 1234 0)))
- (check-error-tag 'no-such-channel (lambda () (filter-channel '(0 0 1 1) 100 #f #f ind 1)))
- (check-error-tag 'no-such-channel (lambda () (filter-channel (float-vector 0 0 1 1) 4 #f #f ind 1)))
- (check-error-tag 'out-of-range (lambda () (filter-sound (float-vector 0 0 1 1) 0)))
- (check-error-tag 'out-of-range (lambda () (filter-sound (float-vector 0 0 1 1) 10)))
- (check-error-tag 'bad-arity (lambda () (play (selected-sound) 0 :stop (lambda () #f))))
- (check-error-tag 'out-of-range (lambda () (set! (reverb-control-length-bounds ind) (list .1 .01))))
- (check-error-tag 'out-of-range (lambda () (set! (reverb-control-scale-bounds ind) (list .1 .01))))
- (check-error-tag 'wrong-type-arg (lambda () (scale-by #f)))
- (check-error-tag 'wrong-type-arg (lambda () (src-sound 3.0 1.0 #t)))
- (check-error-tag 'wrong-type-arg (lambda () (src-sound 3.0 1.0 ind #t)))
- (check-error-tag 'no-such-edit (lambda () (display-edits ind 0 123)))
- (check-error-tag 'no-such-edit (lambda () (marks ind 0 123)))
- (check-error-tag 'no-such-edit (lambda () (save-sound-as "test.snd" :edit-position 123)))
- (check-error-tag 'no-such-auto-delete-choice (lambda () (insert-sound "1a.snd" 0 0 ind 0 0 123)))
- (close-sound ind))
- (check-error-tag 'bad-arity (lambda () (add-transform "hiho" "time" 0 1 (lambda () 1.0))))
- (check-error-tag 'cannot-save (lambda () (save-state "/bad/baddy")))
- (check-error-tag 'no-such-menu (lambda () (add-to-menu 1234 "hi" (lambda () #f))))
- (check-error-tag 'bad-arity (lambda () (add-to-main-menu "hi" (lambda (a b) #f))))
- (check-error-tag 'bad-arity (lambda () (add-to-menu 1 "hi" (lambda (a b) #f))))
- (check-error-tag 'wrong-type-arg (lambda () (set! *transform-type* (integer->transform -1))))
- (check-error-tag 'out-of-range (lambda () (set! *transform-type* (integer->transform 123))))
- (check-error-tag 'wrong-type-arg (lambda () (help-dialog (list 0 1) "hiho")))
- (check-error-tag 'wrong-type-arg (lambda () (info-dialog (list 0 1) "hiho")))
- (check-error-tag 'no-such-sound (lambda () (edit-header-dialog 1234)))
- (check-error-tag 'no-such-file (lambda () (open-sound "/bad/baddy.snd")))
- (check-error-tag 'no-such-file (lambda () (open-raw-sound "/bad/baddy.snd" 1 22050 mus-lshort)))
- (check-error-tag 'no-such-file (lambda () (view-sound "/bad/baddy.snd")))
- (check-error-tag 'no-such-file (lambda () (make-sampler 0 "/bad/baddy.snd")))
- (check-error-tag 'no-such-region (lambda () (make-region-sampler (integer->region 1234567) 0)))
- (check-error-tag 'no-such-key (lambda () (bind-key 12345678 0 #f)))
- (check-error-tag 'no-such-key (lambda () (bind-key -1 0 #f)))
- (check-error-tag 'no-such-key (lambda () (bind-key 12 17 #f)))
- (check-error-tag 'no-such-key (lambda () (bind-key 12 -1 #f)))
- (check-error-tag 'no-such-key (lambda () (key-binding 12345678 0)))
- (check-error-tag 'no-such-key (lambda () (key-binding -1 0)))
- (check-error-tag 'no-such-key (lambda () (key-binding 12 17)))
- (check-error-tag 'no-such-key (lambda () (key-binding 12 -1)))
- (check-error-tag 'bad-header (lambda () (file->array (string-append sf-dir "bad_chans.snd") 0 0 123 (make-float-vector 123))))
- (check-error-tag 'bad-header (lambda () (make-readin (string-append sf-dir "bad_chans.snd"))))
- (check-error-tag 'mus-error (lambda () (make-iir-filter 30 (make-float-vector 3))))
- (check-error-tag 'out-of-range (lambda () (make-wave-train :size (expt 2 30))))
- (check-error-tag 'out-of-range (lambda () (set! *clm-srate* 0.0)))
- (check-error-tag 'out-of-range (lambda () (set! *clm-srate* -1000)))
- (check-error-tag 'out-of-range (lambda () (dot-product (make-float-vector 3) (make-float-vector 3) -1)))
- (check-error-tag 'out-of-range (lambda () (make-delay 3 :initial-element 0.0 :initial-contents (float-vector .1 .2 .3))))
- (check-error-tag 'out-of-range (lambda () (make-delay 3 :max-size 100 :initial-contents (float-vector .1 .2 .3))))
- (check-error-tag 'out-of-range (lambda () (make-table-lookup :size 100 :wave (make-float-vector 3))))
- (check-error-tag 'out-of-range (lambda () (make-wave-train :size 100 :wave (make-float-vector 3))))
+ (check-error-tag 'cannot-save (lambda () (save-sound-as "/bad/baddy.snd")))
+ (check-error-tag 'no-such-sound (lambda () (transform-sample 0 1 1234)))
+ (check-error-tag 'no-such-channel (lambda () (transform-sample 0 1 ind 1234)))
+ (check-error-tag 'no-such-sound (lambda () (graph (float-vector 0 1) "hi" 0 1 0 1 1234)))
+ (check-error-tag 'no-such-channel (lambda () (graph (float-vector 0 1) "hi" 0 1 0 1 ind 1234)))
+ (set! (selection-member? #t) #f)
+ (check-error-tag 'no-active-selection (lambda () (filter-selection (float-vector 0 0 1 1) 4)))
+ (check-error-tag 'no-active-selection (lambda () (save-selection "/bad/baddy.snd")))
+ (check-error-tag 'no-active-selection (lambda () (env-selection '(0 0 1 1))))
+ (check-error-tag 'no-such-region (lambda () (save-region (integer->region 1234) "/bad/baddy.snd")))
+ (make-region 0 100 ind 0)
+ (check-error-tag 'cannot-save (lambda () (save-selection "/bad/baddy.snd")))
+ (check-error-tag 'cannot-save (lambda () (save-region (car (regions)) "/bad/baddy.snd")))
+ (check-error-tag 'no-such-mix (lambda () (make-mix-sampler (integer->mix 1234))))
+ (check-error-tag 'no-such-sound (lambda () (make-region 0 12 1234 #t)))
+ (set! (read-only ind) #t)
+ (check-error-tag 'cannot-save (lambda () (set! (sound-loop-info ind) '(0 0 1 1))))
+ (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 123)))
+ (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 0)))
+ (check-error-tag 'no-such-direction (lambda () (make-sampler 0 ind 0 -2)))
+ (check-error-tag 'no-data (lambda () (scale-by ())))
+ (check-error-tag 'no-data (lambda () (scale-to ())))
+ (check-error-tag 'no-such-sample (lambda () (set! (selection-position ind 0) -999)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (selection-framples ind 0) -999)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (selection-framples ind 0) 0)))
+ (check-error-tag 'no-such-edit (lambda () (edit-fragment -1)))
+ (check-error-tag 'no-such-edit (lambda () (edit-fragment 101 ind 0)))
+ (check-error-tag 'no-such-edit (lambda () (edit-tree ind 0 -2)))
+ (check-error-tag 'no-such-edit (lambda () (edit-tree ind 0 101)))
+ (check-error-tag 'no-such-sample (lambda () (add-mark -1)))
+ (check-error-tag 'no-such-sample (lambda () (add-mark (* 2 (framples)))))
+ (check-error-tag 'no-such-file (lambda () (convolve-with "/bad/baddy")))
+ (check-error-tag 'no-such-file (lambda () (mix "/bad/baddy")))
+ (check-error-tag 'no-such-sound (lambda () (swap-channels ind 0 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (show-axes ind 0) 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (show-axes ind 0) -123)))
+ (check-error-tag 'out-of-range (lambda () (set! (x-axis-style ind 0) 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (x-axis-style ind 0) -123)))
+ (check-error-tag 'out-of-range (lambda () (set! (graph-style ind 0) 123)))
+ (check-error-tag 'out-of-range (lambda () (set! (graph-style ind 0) -123)))
+ (check-error-tag 'out-of-range (lambda () (env-sound '(0 0 1 1) 0 #f -1.5)))
+ (check-error-tag 'out-of-range (lambda () (xramp-channel 0.0 1.0 -1.6)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (samples 0 2) -1)))
+ (check-error-tag 'wrong-type-arg (lambda () (left-sample (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (amp-control (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (sound-loop-info (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (add-mark 123 (list 0))))
+ (check-error-tag 'no-such-sound (lambda () (filter-channel '(0 0 1 1) 100 #f #f 1234 0)))
+ (check-error-tag 'no-such-channel (lambda () (filter-channel '(0 0 1 1) 100 #f #f ind 1)))
+ (check-error-tag 'no-such-channel (lambda () (filter-channel (float-vector 0 0 1 1) 4 #f #f ind 1)))
+ (check-error-tag 'out-of-range (lambda () (filter-sound (float-vector 0 0 1 1) 0)))
+ (check-error-tag 'out-of-range (lambda () (filter-sound (float-vector 0 0 1 1) 10)))
+ (check-error-tag 'bad-arity (lambda () (play (selected-sound) 0 :stop (lambda () #f))))
+ (check-error-tag 'out-of-range (lambda () (set! (reverb-control-length-bounds ind) (list .1 .01))))
+ (check-error-tag 'out-of-range (lambda () (set! (reverb-control-scale-bounds ind) (list .1 .01))))
+ (check-error-tag 'wrong-type-arg (lambda () (scale-by #f)))
+ (check-error-tag 'wrong-type-arg (lambda () (src-sound 3.0 1.0 #t)))
+ (check-error-tag 'wrong-type-arg (lambda () (src-sound 3.0 1.0 ind #t)))
+ (check-error-tag 'no-such-edit (lambda () (display-edits ind 0 123)))
+ (check-error-tag 'no-such-edit (lambda () (marks ind 0 123)))
+ (check-error-tag 'no-such-edit (lambda () (save-sound-as "test.snd" :edit-position 123)))
+ (check-error-tag 'no-such-auto-delete-choice (lambda () (insert-sound "1a.snd" 0 0 ind 0 0 123)))
+ (close-sound ind))
+ (check-error-tag 'bad-arity (lambda () (add-transform "hiho" "time" 0 1 (lambda () 1.0))))
+ (check-error-tag 'cannot-save (lambda () (save-state "/bad/baddy")))
+ (check-error-tag 'no-such-menu (lambda () (add-to-menu 1234 "hi" (lambda () #f))))
+ (check-error-tag 'bad-arity (lambda () (add-to-main-menu "hi" (lambda (a b) #f))))
+ (check-error-tag 'bad-arity (lambda () (add-to-menu 1 "hi" (lambda (a b) #f))))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *transform-type* (integer->transform -1))))
+ (check-error-tag 'out-of-range (lambda () (set! *transform-type* (integer->transform 123))))
+ (check-error-tag 'wrong-type-arg (lambda () (help-dialog (list 0 1) "hiho")))
+ (check-error-tag 'wrong-type-arg (lambda () (info-dialog (list 0 1) "hiho")))
+ (check-error-tag 'no-such-sound (lambda () (edit-header-dialog 1234)))
+ (check-error-tag 'no-such-file (lambda () (open-sound "/bad/baddy.snd")))
+ (check-error-tag 'no-such-file (lambda () (open-raw-sound "/bad/baddy.snd" 1 22050 mus-lshort)))
+ (check-error-tag 'no-such-file (lambda () (view-sound "/bad/baddy.snd")))
+ (check-error-tag 'no-such-file (lambda () (make-sampler 0 "/bad/baddy.snd")))
+ (check-error-tag 'no-such-region (lambda () (make-region-sampler (integer->region 1234567) 0)))
+ (check-error-tag 'no-such-key (lambda () (bind-key 12345678 0 #f)))
+ (check-error-tag 'no-such-key (lambda () (bind-key -1 0 #f)))
+ (check-error-tag 'no-such-key (lambda () (bind-key 12 17 #f)))
+ (check-error-tag 'no-such-key (lambda () (bind-key 12 -1 #f)))
+ (check-error-tag 'no-such-key (lambda () (key-binding 12345678 0)))
+ (check-error-tag 'no-such-key (lambda () (key-binding -1 0)))
+ (check-error-tag 'no-such-key (lambda () (key-binding 12 17)))
+ (check-error-tag 'no-such-key (lambda () (key-binding 12 -1)))
+ (check-error-tag 'bad-header (lambda () (file->array (string-append sf-dir "bad_chans.snd") 0 0 123 (make-float-vector 123))))
+ (check-error-tag 'bad-header (lambda () (make-readin (string-append sf-dir "bad_chans.snd"))))
+ (check-error-tag 'mus-error (lambda () (make-iir-filter 30 (make-float-vector 3))))
+ (check-error-tag 'out-of-range (lambda () (make-wave-train :size (expt 2 30))))
+ (check-error-tag 'out-of-range (lambda () (set! *clm-srate* 0.0)))
+ (check-error-tag 'out-of-range (lambda () (set! *clm-srate* -1000)))
+ (check-error-tag 'out-of-range (lambda () (dot-product (make-float-vector 3) (make-float-vector 3) -1)))
+ (check-error-tag 'out-of-range (lambda () (make-delay 3 :initial-element 0.0 :initial-contents (float-vector .1 .2 .3))))
+ (check-error-tag 'out-of-range (lambda () (make-delay 3 :max-size 100 :initial-contents (float-vector .1 .2 .3))))
+ (check-error-tag 'out-of-range (lambda () (make-table-lookup :size 100 :wave (make-float-vector 3))))
+ (check-error-tag 'out-of-range (lambda () (make-wave-train :size 100 :wave (make-float-vector 3))))
; (check-error-tag 'out-of-range (lambda () (make-granulate :max-size (expt 2 30))))
- (check-error-tag 'out-of-range (lambda () (make-ssb-am 100 12345678)))
- (check-error-tag 'mus-error (lambda () (make-rand :envelope '(0 0 1 1) :distribution (make-float-vector 10))))
- (check-error-tag 'mus-error (lambda () (make-rand :envelope '(0 0 1))))
- (check-error-tag 'out-of-range (lambda () (make-rand :envelope '(0 0 1 1) :size -2)))
- (check-error-tag 'out-of-range (lambda () (make-rand :envelope '(0 0 1 1) :size 1234567890)))
- (check-error-tag 'mus-error (lambda () (let ((f (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3))) (mus-xcoeff f 4))))
- (check-error-tag 'mus-error (lambda () (let ((f (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3))) (mus-ycoeff f 4))))
- (check-error-tag 'mus-error (lambda () (let ((f (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3))) (set! (mus-xcoeff f 4) 1.0))))
- (check-error-tag 'mus-error (lambda () (let ((f (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3))) (set! (mus-ycoeff f 4) 1.0))))
- (check-error-tag 'mus-error (lambda () (make-filter :ycoeffs (make-float-vector 4) :order 12)))
- (check-error-tag 'mus-error (lambda () (let ((hi (make-oscil))) (set! (mus-offset hi) 1))))
- (check-error-tag 'out-of-range (lambda () (make-locsig :channels (expt 2 30))))
- (check-error-tag 'out-of-range (lambda () (make-src :width 3000)))
- (check-error-tag 'bad-arity (lambda () (add-colormap "baddy" (lambda () #f))))
- (check-error-tag 'bad-arity (lambda () (add-colormap "baddy" (lambda (a b c) #f))))
+ (check-error-tag 'out-of-range (lambda () (make-ssb-am 100 12345678)))
+ (check-error-tag 'mus-error (lambda () (make-rand :envelope '(0 0 1 1) :distribution (make-float-vector 10))))
+ (check-error-tag 'mus-error (lambda () (make-rand :envelope '(0 0 1))))
+ (check-error-tag 'out-of-range (lambda () (make-rand :envelope '(0 0 1 1) :size -2)))
+ (check-error-tag 'out-of-range (lambda () (make-rand :envelope '(0 0 1 1) :size 1234567890)))
+ (check-error-tag 'mus-error (lambda () (mus-xcoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4)))
+ (check-error-tag 'mus-error (lambda () (mus-ycoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4)))
+ (check-error-tag 'mus-error (lambda () (set! (mus-xcoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4) 1.0)))
+ (check-error-tag 'mus-error (lambda () (set! (mus-ycoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4) 1.0)))
+ (check-error-tag 'mus-error (lambda () (make-filter :ycoeffs (make-float-vector 4) :order 12)))
+ (check-error-tag 'mus-error (lambda () (let ((hi (make-oscil))) (set! (mus-offset hi) 1))))
+ (check-error-tag 'out-of-range (lambda () (make-locsig :channels (expt 2 30))))
+ (check-error-tag 'out-of-range (lambda () (make-src :width 3000)))
+ (check-error-tag 'bad-arity (lambda () (add-colormap "baddy" (lambda () #f))))
+ (check-error-tag 'bad-arity (lambda () (add-colormap "baddy" (lambda (a b c) #f))))
; (check-error-tag 'out-of-range (lambda () (make-phase-vocoder :fft-size (expt 2 30))))
- (check-error-tag 'out-of-range (lambda () (let ((sr (make-src :input (lambda (dir) 1.0)))) (src sr 2000000.0))))
- (check-error-tag 'out-of-range (lambda () (partials->polynomial '(1 1) -1)))
- (check-error-tag 'out-of-range (lambda () (partials->polynomial '(1 1) 3)))
- (check-error-tag 'out-of-range (lambda () (make-polyshape 440.0 :partials '(1 1) :kind -1)))
- (check-error-tag 'out-of-range (lambda () (make-polyshape 440.0 :partials '(1 1) :kind 3)))
- (check-error-tag 'wrong-type-arg (lambda () (normalize-partials 32)))
- (check-error-tag 'wrong-type-arg (lambda () (normalize-partials ())))
- (check-error-tag 'bad-type (lambda () (normalize-partials '(1 2 3))))
- (check-error-tag 'bad-type (lambda () (normalize-partials (float-vector 3))))
-
- (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (float-vector 1 1 -2 1))))
- (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (list 1 1 -2 1))))
+ (check-error-tag 'out-of-range (lambda () (src (make-src :input (lambda (dir) 1.0)) 2000000.0)))
+ (check-error-tag 'out-of-range (lambda () (partials->polynomial '(1 1) -1)))
+ (check-error-tag 'out-of-range (lambda () (partials->polynomial '(1 1) 3)))
+ (check-error-tag 'out-of-range (lambda () (make-polyshape 440.0 :partials '(1 1) :kind -1)))
+ (check-error-tag 'out-of-range (lambda () (make-polyshape 440.0 :partials '(1 1) :kind 3)))
+ (check-error-tag 'wrong-type-arg (lambda () (normalize-partials 32)))
+ (check-error-tag 'wrong-type-arg (lambda () (normalize-partials ())))
+ (check-error-tag 'bad-type (lambda () (normalize-partials '(1 2 3))))
+ (check-error-tag 'bad-type (lambda () (normalize-partials (float-vector 3))))
+
+ (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (float-vector 1 1 -2 1))))
+ (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (list 1 1 -2 1))))
;(check-error-tag 'wrong-type-arg (lambda () (make-polyshape 440.0 :partials (list 1 1 "hi" 1)))) ; can be 'no-data etc
;(check-error-tag 'wrong-type-arg (lambda () (make-polyshape 440.0 :partials (list 1 1 2 "hi"))))
- (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (list))))
-
- (check-error-tag 'wrong-type-arg (lambda () (set! (mus-header-raw-defaults) 1234)))
- (check-error-tag 'wrong-type-arg (lambda () (set! (mus-header-raw-defaults) (list 44100 2.123 "hi"))))
-
- (check-error-tag 'wrong-type-arg (lambda () (set! *with-toolbar* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *with-tooltips* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *with-menu-icons* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *save-as-dialog-src* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *save-as-dialog-auto-comment* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *with-smpte-label* 123)))
- (check-error-tag 'wrong-type-arg (lambda () (set! *ask-about-unsaved-edits* 123)))
-
- (check-error-tag 'no-such-mix (lambda () (mix-properties (integer->mix (+ 1 (mix-sync-max))))))
- (check-error-tag 'no-such-mix (lambda () (set! (mix-properties (integer->mix (+ 1 (mix-sync-max)))) 1)))
- ))
+ (check-error-tag 'no-data (lambda () (make-polyshape 440.0 :partials (list))))
- ;; xen.h over-optimization regression check
- (catch #t
- (lambda ()
- (set! (x-zoom-slider -1) 123))
- (lambda args
- (let ((str (apply format #f (cadr args))))
- (if (not (string=? str "set! x-zoom-slider: no such sound: -1"))
- (snd-display #__line__ ";x-zoom-slider error: ~S~%" str)))))
- (catch #t
- (lambda ()
- (set! (y-zoom-slider -1) 123))
- (lambda args
- (let ((str (apply format #f (cadr args))))
- (if (not (string=? str "set! y-zoom-slider: no such sound: -1"))
- (snd-display #__line__ ";y-zoom-slider error: ~S~%" str)))))
- (catch #t
- (lambda ()
- (set! (beats-per-measure -1) 123))
- (lambda args
- (let ((str (apply format #f (cadr args))))
- (if (not (string=? str "set! beats-per-measure: no such sound: -1"))
- (snd-display #__line__ ";beats-per-measure error: ~S~%" str)))))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (mus-header-raw-defaults) 1234)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! (mus-header-raw-defaults) (list 44100 2.123 "hi"))))
- (if (pair? (sounds))
- (snd-display #__line__ ";sounds after error checks: ~A~%" (map short-file-name (sounds))))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *with-toolbar* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *with-tooltips* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *with-menu-icons* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *save-as-dialog-src* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *save-as-dialog-auto-comment* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *with-smpte-label* 123)))
+ (check-error-tag 'wrong-type-arg (lambda () (set! *ask-about-unsaved-edits* 123)))
- (if (provided? 'snd-motif)
- (for-each
- (lambda (n name)
- (let ((tag (catch #t
- (lambda () (n (list 'Widget 0)))
- (lambda args (car args)))))
- (if (not (eq? tag 'no-such-widget))
- (snd-display #__line__ ";~A of null widget -> ~A" name tag))))
- (list widget-position widget-size widget-text hide-widget show-widget focus-widget)
- (list 'widget-position 'widget-size 'widget-text 'hide-widget 'show-widget 'focus-widget)))
+ (check-error-tag 'no-such-mix (lambda () (mix-properties (integer->mix (+ 1 (mix-sync-max))))))
+ (check-error-tag 'no-such-mix (lambda () (set! (mix-properties (integer->mix (+ 1 (mix-sync-max)))) 1)))
+ )
+
+ ;; xen.h over-optimization regression check
+ (catch #t
+ (lambda ()
+ (set! (x-zoom-slider -1) 123))
+ (lambda args
+ (let ((str (apply format #f (cadr args))))
+ (if (not (string=? str "set! x-zoom-slider: no such sound: -1"))
+ (snd-display ";x-zoom-slider error: ~S~%" str)))))
+ (catch #t
+ (lambda ()
+ (set! (y-zoom-slider -1) 123))
+ (lambda args
+ (let ((str (apply format #f (cadr args))))
+ (if (not (string=? str "set! y-zoom-slider: no such sound: -1"))
+ (snd-display ";y-zoom-slider error: ~S~%" str)))))
+ (catch #t
+ (lambda ()
+ (set! (beats-per-measure -1) 123))
+ (lambda args
+ (let ((str (apply format #f (cadr args))))
+ (if (not (string=? str "set! beats-per-measure: no such sound: -1"))
+ (snd-display ";beats-per-measure error: ~S~%" str)))))
+
+ (if (pair? (sounds))
+ (snd-display ";sounds after error checks: ~A~%" (map short-file-name (sounds))))
+
+ (if (provided? 'snd-motif)
+ (for-each
+ (lambda (n name)
+ (let ((tag (catch #t
+ (lambda () (n (list 'Widget 0)))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-widget))
+ (snd-display ";~A of null widget -> ~A" name tag))))
+ (list widget-position widget-size widget-text hide-widget show-widget focus-widget)
+ (list 'widget-position 'widget-size 'widget-text 'hide-widget 'show-widget 'focus-widget)))
+
+ ;; ---------------- key args
+ (for-each
+ (lambda (arg1)
+ (for-each
+ (lambda (arg2)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (n arg1 arg2))
+ (lambda args (car args))))
+ make-procs))
+ (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
+ keyargs)
+
+ (when (and all-args (= test-errors 0))
+ (for-each
+ (lambda (arg1)
+ (for-each
+ (lambda (arg2)
+ (for-each
+ (lambda (arg3)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (n arg1 arg2 arg3))
+ (lambda args (car args))))
+ make-procs))
+ (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
+ keyargs))
+ (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32))
- ;; ---------------- key args
(for-each
(lambda (arg1)
(for-each
(lambda (arg2)
(for-each
+ (lambda (arg3)
+ (for-each
+ (lambda (arg4)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (n arg1 arg2 arg3 arg4))
+ (lambda args (car args))))
+ make-procs))
+ keyargs))
+ (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
+ keyargs))
+ (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
+
+ ;; ---------------- 0 Args
+ (for-each
+ (lambda (n)
+ (let ((err (catch #t
+ n
+ (lambda args (car args)))))
+ (if (eq? err 'wrong-number-of-args)
+ (snd-display ";procs0: ~A ~A" err (procedure-documentation n)))))
+ procs0)
+ (dismiss-all-dialogs)
+ (for-each close-sound (sounds))
+
+ (let* ((main-args (list 1.5 str-3 (list 0 1) 12 float-vector-3 color-95 #(0 1) 3/4 'mus-error 0+i delay-32
+ (lambda () #t) float-vector-5 :order 0 1 -1 a-hook #f #t #\c 0.0 -1.0
+ () 3 64 -64 vector-0 '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0) car-main cadr-main
+ (lambda (a) #f) abs
+ 1.0+1.0i (cons 1 2) '((1 2) (3 4)) '((1 (2)) (((3) 4)))
+ (vector 1 #\a '(3)) #()
+ (let ((x 3)) (lambda (y) (+ x y))) (lambda args args)
+ "" (make-hash-table 256)
+ #<undefined> #<unspecified> #<eof>
+ (random-state 12) (float-vector) (vector)))
+ (few-args (list 1.5 str-3 (list 0 1) 12 float-vector-3 color-95 #(0 1) 3/4 -1.0 (float-vector) (vector) (list) ""
+ 0+i delay-32 :feedback -1 0 1 'hi (lambda (a) (+ a 1)) -64 #f #t vector-0))
+ (less-args (if all-args main-args few-args)))
+
+ ;; ---------------- 1 Arg
+ (for-each
+ (lambda (arg)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (n arg))
+ (lambda args
+ (if (eq? (car args) 'wrong-number-of-args)
+ (snd-display ";procs1 wna: ~A" (procedure-documentation n))))))
+ procs1))
+ main-args)
+ (for-each close-sound (sounds))
+
+ ;; ---------------- 2 Args
+ (for-each
+ (lambda (arg1)
+ (for-each
+ (lambda (arg2)
+ (for-each
(lambda (n)
(catch #t
(lambda () (n arg1 arg2))
- (lambda args (car args))))
- make-procs))
- (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
- keyargs)
+ (lambda args
+ (if (eq? (car args) 'wrong-number-of-args)
+ (snd-display ";procs2: ~A" (procedure-documentation n))))))
+ procs2))
+ main-args))
+ main-args)
+ (for-each close-sound (sounds))
- (if (and all-args (= test-28 0))
- (begin
- (for-each
- (lambda (arg1)
- (for-each
- (lambda (arg2)
- (for-each
- (lambda (arg3)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (n arg1 arg2 arg3))
- (lambda args (car args))))
- make-procs))
- (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
- keyargs))
- (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32))
-
- (for-each
- (lambda (arg1)
- (for-each
- (lambda (arg2)
- (for-each
- (lambda (arg3)
- (for-each
- (lambda (arg4)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (n arg1 arg2 arg3 arg4))
- (lambda args (car args))))
- make-procs))
- keyargs))
- (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32)))
- keyargs))
- (list 1.5 str-3 (list 0 1) 12 float-vector-3 :wave -1 0 1 #f #t () vector-0 delay-32))))
-; (if all-args (snd-display #__line__ ";args: ~A~%" (strftime "%d-%b %H:%M %Z" (localtime (current-time)))))
+ ;; ---------------- set! no Args
+ (for-each
+ (lambda (arg)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (set! (n) arg))
+ (lambda args
+ (if (eq? (car args) 'wrong-number-of-args)
+ (snd-display ";set-procs0: ~A" (procedure-documentation n))))))
+ set-procs0))
+ main-args)
+ (for-each close-sound (sounds))
- ;; ---------------- 0 Args
+ ;; ---------------- set! 1 Arg
(for-each
- (lambda (n)
- (let ((err (catch #t
- n
- (lambda args (car args)))))
- (if (eq? err 'wrong-number-of-args)
- (snd-display #__line__ ";procs0: ~A ~A" err (procedure-documentation n)))))
- procs0)
- (dismiss-all-dialogs)
+ (lambda (arg1)
+ (for-each
+ (lambda (arg2)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (set! (n arg1) arg2))
+ (lambda args
+ (if (eq? (car args) 'wrong-number-of-args)
+ (snd-display ";set-procs1: ~A" (procedure-documentation n))))))
+ set-procs1))
+ main-args))
+ main-args)
(for-each close-sound (sounds))
- (let* ((main-args (list 1.5 str-3 (list 0 1) 12 float-vector-3 color-95 #(0 1) 3/4 'mus-error 0+i delay-32
- (lambda () #t) float-vector-5 :order 0 1 -1 a-hook #f #t #\c 0.0 -1.0
- () 3 64 -64 vector-0 '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0) car-main cadr-main
- (lambda (a) #f) abs
- 1.0+1.0i (cons 1 2) '((1 2) (3 4)) '((1 (2)) (((3) 4)))
- (vector 1 #\a '(3)) (make-vector 0)
- (let ((x 3)) (lambda (y) (+ x y))) (lambda args args)
- "" (make-hash-table 256)
- #<undefined> #<unspecified> #<eof>
- (random-state 12) (float-vector) (vector)))
- (few-args (list 1.5 str-3 (list 0 1) 12 float-vector-3 color-95 #(0 1) 3/4 -1.0 (float-vector) (vector) (list) (string)
- 0+i delay-32 :feedback -1 0 1 'hi (lambda (a) (+ a 1)) -64 #f #t vector-0))
- (less-args (if all-args main-args few-args)))
-
- ;; ---------------- 1 Arg
- (for-each
- (lambda (arg)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (n arg))
- (lambda args
- (if (eq? (car args) 'wrong-number-of-args)
- (snd-display #__line__ ";procs1 wna: ~A" (procedure-documentation n))))))
- procs1))
- main-args)
- (for-each close-sound (sounds))
-
- ;; ---------------- 2 Args
- (for-each
- (lambda (arg1)
- (for-each
- (lambda (arg2)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (n arg1 arg2))
- (lambda args
- (if (eq? (car args) 'wrong-number-of-args)
- (snd-display #__line__ ";procs2: ~A" (procedure-documentation n))))))
- procs2))
- main-args))
- main-args)
- (for-each close-sound (sounds))
-
- ;; ---------------- set! no Args
- (for-each
- (lambda (arg)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (set! (n) arg))
- (lambda args
- (if (eq? (car args) 'wrong-number-of-args)
- (snd-display #__line__ ";set-procs0: ~A" (procedure-documentation n))))))
- set-procs0))
- main-args)
- (for-each close-sound (sounds))
-
- ;; ---------------- set! 1 Arg
- (for-each
- (lambda (arg1)
- (for-each
- (lambda (arg2)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (set! (n arg1) arg2))
- (lambda args
- (if (eq? (car args) 'wrong-number-of-args)
- (snd-display #__line__ ";set-procs1: ~A" (procedure-documentation n))))))
- set-procs1))
- main-args))
- main-args)
- (for-each close-sound (sounds))
-
- ;; ---------------- set! 2 Args
- (for-each
- (lambda (arg1)
- (for-each close-sound (sounds))
- (for-each
- (lambda (arg2)
- (for-each
- (lambda (arg3)
- (for-each
- (lambda (n)
- (catch #t
- (lambda () (set! (n arg1 arg2) arg3))
- (lambda args
- (if (eq? (car args) 'wrong-number-of-args)
- (snd-display #__line__ ";set-procs2: ~A" (procedure-documentation n))))))
- set-procs2))
- less-args))
- less-args))
- less-args)
-
- (set! delay-32 #f)
- (set! color-95 #f)
- (set! vector-0 #f)
- (set! float-vector-3 #f)
- (set! *clm-srate* 22050)
- (set! *print-length* 12)
- (set! *mus-array-print-length* 12)
- (set! (sound-file-extensions) exts)
- (set! car-main #f)
- (set! cadr-main #f)
- (set! a-hook #f)
- (set! float-vector-5 #f)
- )))))
-
-
+ ;; ---------------- set! 2 Args
+ (for-each
+ (lambda (arg1)
+ (for-each close-sound (sounds))
+ (for-each
+ (lambda (arg2)
+ (for-each
+ (lambda (arg3)
+ (for-each
+ (lambda (n)
+ (catch #t
+ (lambda () (set! (n arg1 arg2) arg3))
+ (lambda args
+ (if (eq? (car args) 'wrong-number-of-args)
+ (snd-display ";set-procs2: ~A" (procedure-documentation n))))))
+ set-procs2))
+ less-args))
+ less-args))
+ less-args)
+
+ (set! delay-32 #f)
+ (set! color-95 #f)
+ (set! vector-0 #f)
+ (set! float-vector-3 #f)
+ (set! *clm-srate* 22050)
+ (set! *print-length* 12)
+ (set! *mus-array-print-length* 12)
+ (set! (sound-file-extensions) exts)
+ (set! car-main #f)
+ (set! cadr-main #f)
+ (set! a-hook #f)
+ (set! float-vector-5 #f)
+ )))))
+
+
;;; ---------------- test 26: s7 ----------------
-
+
(define (snd_test_26)
(load "s7test.scm"))
@@ -48965,9 +48023,9 @@ EDITS: 1
(set! (test-funcs 10) snd_test_10)
(set! (test-funcs 11) snd_test_11)
(set! (test-funcs 12) snd_test_12)
-(if (or (and (not (provided? 'openbsd))
- (not (provided? 'freebsd)))
- (not (provided? 'snd-gtk)))
+(if (not (or (provided? 'openbsd)
+ (provided? 'freebsd)
+ (provided? 'snd-gtk)))
(begin
(set! (test-funcs 13) snd_test_13)
(set! (test-funcs 14) snd_test_14)
@@ -48988,33 +48046,31 @@ EDITS: 1
(set! (test-funcs 25) snd_test_25)
(set! (test-funcs 26) snd_test_26)
-(if (> test-at-random 0)
- (do ((i 0 (+ i 1))) ; run tests in any random order
- ((= i test-at-random))
- (set! snd-test (random 23))
- (if (> snd-test 22) (set! snd-test 22))
- (format *stderr* "~%~A: ~A~%" i snd-test)
- (before-test-hook snd-test)
- ((vector-ref test-funcs snd-test))
- (after-test-hook snd-test))
-
- (if (and (not full-test)
- (not keep-going)
- (>= snd-test 0))
- (begin ; run one test
- (before-test-hook snd-test)
- ((vector-ref test-funcs snd-test))
- (after-test-hook snd-test))
-
- (do ((i 0 (+ i 1))) ; run all tests except the irritating ones
- ((> i total-tests))
- (if (and (or (< i 23) (> i 24))
- (or full-test
- (and keep-going (<= snd-test i))))
- (begin
- (before-test-hook i)
- ((vector-ref test-funcs i))
- (after-test-hook i))))))
+(cond ((> test-at-random 0) ; run tests in any random order
+ (do ((i 0 (+ i 1)))
+ ((= i test-at-random))
+ (set! snd-test (random 23))
+ (format *stderr* "~%~A: ~A~%" i snd-test)
+ (before-test-hook snd-test)
+ ((vector-ref test-funcs snd-test))
+ (after-test-hook snd-test)))
+
+ ((not (or full-test
+ keep-going
+ (< snd-test 0)))
+ (before-test-hook snd-test)
+ ((vector-ref test-funcs snd-test))
+ (after-test-hook snd-test))
+
+ (else
+ (do ((i 0 (+ i 1)))
+ ((> i total-tests))
+ (when (and (not (<= 23 i 24))
+ (or full-test
+ (and keep-going (<= snd-test i))))
+ (before-test-hook i)
+ ((vector-ref test-funcs i))
+ (after-test-hook i)))))
;;; ---------------- test all done
@@ -49031,10 +48087,11 @@ EDITS: 1
;(save-listener "test.output")
(set! *listener-prompt* original-prompt)
+(set! *stdin-prompt* "")
(clear-listener)
(set! (show-listener) #t)
-(format #t "~%;all done!~%~A" original-prompt)
+(format () "~%;all done!~%~A" original-prompt)
(set! *print-length* 64)
(format *stderr* "~%;times: ~A~%;total: ~A~%" timings (round (- (real-time) overall-start-time)))
@@ -49074,31 +48131,19 @@ EDITS: 1
(if (file-exists? "saved-snd.scm") (delete-file "saved-snd.scm"))
(if (file-exists? original-save-dir)
- (begin
- ;(format #t "ls ~A/snd_* | wc~%" original-save-dir)
- ;(system (format #f "ls ~A/snd_* | wc" original-save-dir))
- (system (format #f "rm -f ~A/snd_*" original-save-dir))))
+ (system (format #f "rm -f ~A/snd_*" original-save-dir)))
(if (file-exists? original-temp-dir)
- (begin
- ;(format #t "ls ~A/snd_* | wc~%" original-temp-dir)
- ;(system (format #f "ls ~A/snd_* | wc" original-temp-dir))
- (system (format #f "rm -f ~A/snd_*" original-temp-dir))))
+ (system (format #f "rm -f ~A/snd_*" original-temp-dir)))
(if (file-exists? "/tmp")
(begin
- ;(format #t "ls /tmp/snd_* | wc~%")
- ;(system "ls /tmp/snd_* | wc")
(system "rm -f /tmp/snd_*")
- ;(system "ls /tmp/file*.snd | wc")
(system "rm -f /tmp/file*.snd")))
(if (file-exists? "/var/tmp")
(begin
- ;(format #t "ls /var/tmp/snd_* | wc~%")
- ;(system "ls /var/tmp/snd_* | wc")
(system "rm -f /var/tmp/snd_*")
- ;(system "ls /var/tmp/file*.snd | wc")
(system "rm -f /var/tmp/file*.snd")))
(if (defined? 'dlocsig-speaker-configs) (set! dlocsig-speaker-configs #f))
@@ -49191,7 +48236,7 @@ EDITS: 1
(let ((val (symbol->value sym)))
(if (and (procedure? val)
(string=? "" (procedure-documentation val)))
- (snd-display #__line__ "~A " sym)))))
+ (snd-display "~A " sym)))))
st))
|#
diff --git a/snd-xen.c b/snd-xen.c
index 130f80b..6fed1d5 100644
--- a/snd-xen.c
+++ b/snd-xen.c
@@ -1188,6 +1188,12 @@ void snd_eval_stdin_str(const char *buf)
str = gl_print(result);
string_to_stdout(str, NULL);
+ if (mus_strlen(stdin_prompt(ss)) > 0)
+ {
+ fprintf(stdout, "%s", stdin_prompt(ss));
+ fflush(stdout);
+ }
+
if (str) free(str);
snd_unprotect_at(loc);
}
@@ -1657,18 +1663,6 @@ static Xen g_dlinit(Xen handle, Xen func)
}
#endif
-#if HAVE_SCHEME
-static s7_pointer g_line_reader(s7_scheme *sc, s7_pointer args)
-{
- const char *str;
- Xen_check_type(Xen_is_string(s7_car(args)), s7_car(args), 1, "#__line__", "a string");
- str = s7_string(s7_car(args));
- if ((str) && (strcmp(str, "__line__") == 0))
- return(s7_make_integer(sc, s7_port_line_number(s7_current_input_port(sc))));
- return(Xen_false);
-}
-#endif
-
static Xen g_little_endian(void)
{
#if MUS_LITTLE_ENDIAN
@@ -2714,7 +2708,7 @@ Xen_wrap_1_arg(g_snd_warning_w, g_snd_warning)
void g_xen_initialize(void)
{
#if HAVE_SCHEME
- s7_pointer pl_dr, pl_dir, pl_ss, pl_b;
+ s7_pointer pl_dr, pl_dir, pl_ss, pl_b, pl_pr;
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
s7_pointer pl_pf;
#endif
@@ -2825,14 +2819,16 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
#if HAVE_SCHEME
{
- s7_pointer s, i, b, r, d;
+ s7_pointer s, i, b, r, d, p;
s = s7_make_symbol(s7, "string?");
i = s7_make_symbol(s7, "integer?");
b = s7_make_symbol(s7, "boolean?");
r = s7_make_symbol(s7, "real?");
d = s7_make_symbol(s7, "float?");
+ p = s7_make_symbol(s7, "pair?");
pl_ss = s7_make_signature(s7, 2, s, s);
pl_dr = s7_make_circular_signature(s7, 1, 2, d, r);
+ pl_pr = s7_make_signature(s7, 2, p, r);
pl_dir = s7_make_signature(s7, 3, d, i, r);
pl_b = s7_make_signature(s7, 1, b);
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
@@ -2871,7 +2867,7 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
Xen_define_typed_procedure(S_bes_kn, g_kn_w, 2, 0, 0, H_kn, pl_dir);
Xen_define_typed_procedure("gsl-ellipk", g_gsl_ellipk_w, 1, 0, 0, H_gsl_ellipk, pl_dr);
- Xen_define_typed_procedure("gsl-ellipj", g_gsl_ellipj_w, 2, 0, 0, H_gsl_ellipj, pl_dr);
+ Xen_define_typed_procedure("gsl-ellipj", g_gsl_ellipj_w, 2, 0, 0, H_gsl_ellipj, pl_pr);
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
Xen_define_typed_procedure("gsl-eigenvectors", g_gsl_eigenvectors_w, 1, 0, 0, "returns eigenvalues and eigenvectors", pl_pf);
@@ -2953,7 +2949,6 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
#if HAVE_SCHEME
Xen_define_procedure("_snd_s7_error_handler_", g_snd_s7_error_handler_w, 0, 0, 1, "internal error redirection for snd/s7");
- s7_define_safe_function(s7, "_snd-line-reader_", g_line_reader, 1, 0, false, "port-line-number reader");
Xen_eval_C_string("(define redo-edit redo)"); /* consistency with Ruby */
Xen_eval_C_string("(define undo-edit undo)");
@@ -3133,6 +3128,10 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
Xen_provide_feature("audio");
#endif
+#if ENABLE_WEBSERVER
+ Xen_provide_feature("webserver");
+#endif
+
#if HAVE_RUBY
Xen_provide_feature("snd-ruby");
/* we need to set up the search path so that load and require will work as in the program irb */
diff --git a/snd-xref.c b/snd-xref.c
index fbeac26..c053965 100644
--- a/snd-xref.c
+++ b/snd-xref.c
@@ -1,5 +1,5 @@
/* Snd help index (generated by make-index.scm) */
-#define HELP_NAMES_SIZE 1602
+#define HELP_NAMES_SIZE 1607
#if HAVE_SCHEME || HAVE_FORTH
static const char *help_names[HELP_NAMES_SIZE] = {
"*#readers*", "->byte-vector", "abcos", "abcos?", "abort", "absin",
@@ -180,95 +180,96 @@ static const char *help_names[HELP_NAMES_SIZE] = {
"open-sound", "openlet", "openlet?", "orientation-hook", "oscil", "oscil-bank",
"oscil-bank?", "oscil?", "out-any", "out-bank", "outa", "outlet",
"*output*", "output-comment-hook", "overlay-rms-env", "owlet", "pad-channel", "pad-marks",
- "pad-sound", "pan-mix", "pan-mix-float-vector", "partials->polynomial", "partials->wave", "pausing",
- "peak-env-dir", "peaks", "peaks-font", "phase-partials->wave", "phase-vocoder", "phase-vocoder?",
- "piano model", "pink-noise", "pink-noise?", "pins", "place-sound", "play",
- "play-arrow-size", "play-between-marks", "play-hook", "play-mixes", "play-often", "play-region-forever",
- "play-sine", "play-sines", "play-syncd-marks", "play-until-c-g", "play-with-envs", "player-home",
- "player?", "players", "playing", "pluck", "polar->rectangular", "polynomial",
- "polynomial operations", "polyoid", "polyoid-env", "polyoid?", "polyshape", "polyshape?",
- "polywave", "polywave?", "position->x", "position->y", "position-color", "power-env",
- "pqw", "pqw-vox", "preferences-dialog", "previous-sample", "print-dialog", "print-length",
- "procedure-documentation", "procedure-setter", "procedure-signature", "procedure-source", "profile", "progress-report",
- "pulse-train", "pulse-train?", "pulsed-env", "pulsed-env?", "r2k!cos", "r2k!cos?",
- "r2k2cos", "r2k2cos?", "radians->degrees", "radians->hz", "ramp-channel", "rand",
- "rand-interp", "rand-interp?", "rand?", "random", "random-state", "random-state?",
- "rcos", "rcos?", "read-hook", "read-mix-sample", "read-only", "read-region-sample",
- "read-sample", "read-sample-with-direction", "reader-cond", "readin", "readin?", "rectangular->magnitudes",
- "rectangular->polar", "redo", "region->integer", "region->vct", "region-chans", "region-framples",
- "region-graph-style", "region-home", "region-maxamp", "region-maxamp-position", "region-play-list", "region-position",
- "region-rms", "region-sample", "region-sampler?", "region-srate", "region?", "regions",
- "remember-sound-state", "remove-clicks", "remove-from-menu", "replace-with-selection", "report-mark-names", "require",
- "reset-all-hooks", "reset-controls", "reset-listener-cursor", "reson", "restore-controls", "*reverb*",
- "reverb-control-decay", "reverb-control-feedback", "reverb-control-length", "reverb-control-length-bounds", "reverb-control-lowpass", "reverb-control-scale",
- "reverb-control-scale-bounds", "reverb-control?", "reverse!", "reverse-by-blocks", "reverse-channel", "reverse-envelope",
- "reverse-selection", "reverse-sound", "revert-sound", "right-sample", "ring-modulate", "rk!cos",
- "rk!cos?", "rk!ssb", "rk!ssb?", "rkcos", "rkcos?", "rkoddssb",
- "rkoddssb?", "rksin", "rksin?", "rkssb", "rkssb?", "rms",
- "rms, gain, balance gens", "rms-envelope", "rootlet", "round-interp", "round-interp?", "rssb",
- "rssb-interp", "rssb?", "rubber-sound", "rxycos", "rxycos?", "rxyk!cos",
- "rxyk!cos?", "rxyk!sin", "rxyk!sin?", "rxysin", "rxysin?", "sample",
- "sample->file", "sample->file?", "sample-type", "sampler-at-end?", "sampler-home", "sampler-position",
- "sampler?", "samples", "samples->seconds", "sash-color", "save-as-dialog-auto-comment", "save-as-dialog-src",
- "save-controls", "save-dir", "save-edit-history", "save-envelopes", "save-hook", "save-listener",
- "save-mark-properties", "save-marks", "save-mix", "save-region", "save-region-dialog", "save-selection",
- "save-selection-dialog", "save-sound", "save-sound-as", "save-sound-dialog", "save-state", "save-state-file",
- "save-state-hook", "savitzky-golay-filter", "sawtooth-wave", "sawtooth-wave?", "scale-by", "scale-channel",
- "scale-envelope", "scale-mixes", "scale-selection-by", "scale-selection-to", "scale-sound", "scale-tempo",
- "scale-to", "scan-channel", "scanned synthesis", "scentroid", "scratch", "script-arg",
- "script-args", "search-for-click", "search-procedure", "seconds->samples", "select-all", "select-channel",
- "select-channel-hook", "select-sound", "select-sound-hook", "selected-channel", "selected-data-color", "selected-graph-color",
- "selected-sound", "selection", "selection->mix", "selection-chans", "selection-color", "selection-context",
- "selection-creates-region", "selection-framples", "selection-maxamp", "selection-maxamp-position", "selection-member?", "selection-members",
- "selection-position", "selection-rms", "selection-srate", "selection?", "set-samples", "short-file-name",
- "show-axes", "show-controls", "show-disk-space", "show-full-duration", "show-full-range", "show-grid",
- "show-indices", "show-listener", "show-marks", "show-mix-waveforms", "show-selection", "show-selection-transform",
- "show-sonogram-cursor", "show-transform-peaks", "show-widget", "show-y-zero", "silence-all-mixes", "silence-mixes",
- "sinc-train", "sinc-train?", "sinc-width", "sine-env-channel", "sine-ramp", "singer",
- "smooth-channel", "smooth-selection", "smooth-sound", "SMS synthesis", "snap-mark-to-beat", "snap-marks",
- "snap-mix-to-beat", "snd->sample", "snd->sample?", "snd-color", "snd-error", "snd-error-hook",
- "snd-font", "snd-gcs", "snd-help", "snd-hooks", "*snd-opened-sound*", "snd-print",
- "snd-spectrum", "snd-tempnam", "snd-url", "snd-urls", "snd-version", "snd-warning",
- "snd-warning-hook", "sndwarp", "sort!", "sound->amp-env", "sound->integer", "sound-file-extensions",
- "sound-file?", "sound-files-in-directory", "sound-interp", "sound-loop-info", "sound-properties", "sound-property",
- "sound-widgets", "sound?", "soundfont-info", "sounds", "sounds->segment-data", "spectra",
- "spectral interpolation", "spectral-polynomial", "spectro-hop", "spectro-x-angle", "spectro-x-scale", "spectro-y-angle",
- "spectro-y-scale", "spectro-z-angle", "spectro-z-scale", "spectrum", "spectrum->coeffs", "spectrum-end",
- "spectrum-start", "speed-control", "speed-control-bounds", "speed-control-style", "speed-control-tones", "spot-freq",
- "square-wave", "square-wave?", "squelch-update", "squelch-vowels", "srate", "src",
- "src-channel", "src-duration", "src-fit-envelope", "src-mixes", "src-selection", "src-sound",
- "src?", "ssb-am", "ssb-am?", "ssb-bank", "ssb-bank-env", "ssb-fm",
- "start-dac", "start-playing", "start-playing-hook", "start-playing-selection-hook", "start-progress-report", "status-report",
- "stereo->mono", "stereo-flute", "stop-player", "stop-playing", "stop-playing-hook", "stop-playing-selection-hook",
- "stretch-envelope", "stretch-sound-via-dft", "string-position", "sublet", "superimpose-ffts", "swap-channels",
- "swap-selection-channels", "symbol->dynamic-value", "symbol->value", "symbol-access", "symbol-table", "sync",
- "sync-everything", "sync-max", "sync-style", "syncd-marks", "syncd-mixes", "syncup",
- "table-lookup", "table-lookup?", "tanhsin", "tanhsin?", "tap", "tap?",
- "telephone", "temp-dir", "text-focus-color", "time-graph-style", "time-graph-type", "time-graph?",
- "times->samples", "tiny-font", "touch-tone", "trace", "tracking-cursor-style", "transform->integer",
- "transform->vct", "transform-dialog", "transform-framples", "transform-graph-style", "transform-graph-type", "transform-graph?",
- "transform-normalization", "transform-sample", "transform-size", "transform-type", "transform?", "transpose-mixes",
- "triangle-wave", "triangle-wave?", "tubebell", "tubular bell", "two-pole", "two-pole?",
- "two-tab", "two-zero", "two-zero?", "unbind-key", "*unbound-variable-hook*", "unclip-channel",
- "undo", "undo-hook", "unlet", "unselect-all", "update-graphs", "update-hook",
- "update-lisp-graph", "update-sound", "update-time-graph", "update-transform-graph", "upon-save-yourself", "user interface extensions",
- "variable-display", "variable-graph?", "varlet", "vct", "vct*", "vct+",
- "vct->channel", "vct->list", "vct->string", "vct->vector", "vct-abs!", "vct-add!",
- "vct-copy", "vct-equal?", "vct-fill!", "vct-length", "vct-max", "vct-min",
- "vct-move!", "vct-multiply!", "vct-offset!", "vct-peak", "vct-ref", "vct-reverse!",
- "vct-scale!", "vct-set!", "vct-subseq", "vct-subtract!", "vct?", "vector->vct",
- "view-files-amp", "view-files-amp-env", "view-files-dialog", "view-files-files", "view-files-select-hook", "view-files-selected-files",
- "view-files-sort", "view-files-speed", "view-files-speed-style", "view-mixes-dialog", "view-regions-dialog", "view-sound",
- "voice physical model", "voiced->unvoiced", "volterra-filter", "vox", "wave-train", "wave-train?",
- "wavelet-type", "waveshaping voice", "wavo-hop", "wavo-trace", "weighted-moving-average", "widget-position",
- "widget-size", "widget-text", "window-height", "window-samples", "window-width", "window-x",
- "window-y", "with-background-processes", "with-baffle", "with-file-monitor", "with-gl", "with-inset-graph",
- "with-interrupts", "with-let", "with-local-hook", "with-menu-icons", "with-mix-tags", "with-pointer-focus",
- "with-relative-panes", "with-smpte-label", "with-sound", "with-temporary-selection", "with-toolbar", "with-tooltips",
- "with-tracking-cursor", "with-verbose-cursor", "x->position", "x-axis-label", "x-axis-style", "x-bounds",
- "x-position-slider", "x-zoom-slider", "xb-open", "xramp-channel", "y->position", "y-axis-label",
- "y-bounds", "y-position-slider", "y-zoom-slider", "z-transform", "zecho", "zero+",
- "zero-pad", "zero-phase", "zip-sound", "zipper", "zoom-color", "zoom-focus-style"};
+ "pad-sound", "pair-filename", "pair-line-number", "pan-mix", "pan-mix-float-vector", "partials->polynomial",
+ "partials->wave", "pausing", "peak-env-dir", "peaks", "peaks-font", "phase-partials->wave",
+ "phase-vocoder", "phase-vocoder?", "piano model", "pink-noise", "pink-noise?", "pins",
+ "place-sound", "play", "play-arrow-size", "play-between-marks", "play-hook", "play-mixes",
+ "play-often", "play-region-forever", "play-sine", "play-sines", "play-syncd-marks", "play-until-c-g",
+ "play-with-envs", "player-home", "player?", "players", "playing", "pluck",
+ "polar->rectangular", "polynomial", "polynomial operations", "polyoid", "polyoid-env", "polyoid?",
+ "polyshape", "polyshape?", "polywave", "polywave?", "port-filename", "port-line-number",
+ "position->x", "position->y", "position-color", "power-env", "pqw", "pqw-vox",
+ "preferences-dialog", "previous-sample", "print-dialog", "print-length", "procedure-documentation", "procedure-setter",
+ "procedure-signature", "procedure-source", "progress-report", "pulse-train", "pulse-train?", "pulsed-env",
+ "pulsed-env?", "r2k!cos", "r2k!cos?", "r2k2cos", "r2k2cos?", "radians->degrees",
+ "radians->hz", "ramp-channel", "rand", "rand-interp", "rand-interp?", "rand?",
+ "random", "random-state", "random-state?", "rcos", "rcos?", "*read-error-hook*",
+ "read-hook", "read-mix-sample", "read-only", "read-region-sample", "read-sample", "read-sample-with-direction",
+ "reader-cond", "readin", "readin?", "rectangular->magnitudes", "rectangular->polar", "redo",
+ "region->integer", "region->vct", "region-chans", "region-framples", "region-graph-style", "region-home",
+ "region-maxamp", "region-maxamp-position", "region-play-list", "region-position", "region-rms", "region-sample",
+ "region-sampler?", "region-srate", "region?", "regions", "remember-sound-state", "remove-clicks",
+ "remove-from-menu", "replace-with-selection", "report-mark-names", "require", "reset-all-hooks", "reset-controls",
+ "reset-listener-cursor", "reson", "restore-controls", "*reverb*", "reverb-control-decay", "reverb-control-feedback",
+ "reverb-control-length", "reverb-control-length-bounds", "reverb-control-lowpass", "reverb-control-scale", "reverb-control-scale-bounds", "reverb-control?",
+ "reverse!", "reverse-by-blocks", "reverse-channel", "reverse-envelope", "reverse-selection", "reverse-sound",
+ "revert-sound", "right-sample", "ring-modulate", "rk!cos", "rk!cos?", "rk!ssb",
+ "rk!ssb?", "rkcos", "rkcos?", "rkoddssb", "rkoddssb?", "rksin",
+ "rksin?", "rkssb", "rkssb?", "rms", "rms, gain, balance gens", "rms-envelope",
+ "rootlet", "round-interp", "round-interp?", "rssb", "rssb-interp", "rssb?",
+ "rubber-sound", "rxycos", "rxycos?", "rxyk!cos", "rxyk!cos?", "rxyk!sin",
+ "rxyk!sin?", "rxysin", "rxysin?", "sample", "sample->file", "sample->file?",
+ "sample-type", "sampler-at-end?", "sampler-home", "sampler-position", "sampler?", "samples",
+ "samples->seconds", "sash-color", "save-as-dialog-auto-comment", "save-as-dialog-src", "save-controls", "save-dir",
+ "save-edit-history", "save-envelopes", "save-hook", "save-listener", "save-mark-properties", "save-marks",
+ "save-mix", "save-region", "save-region-dialog", "save-selection", "save-selection-dialog", "save-sound",
+ "save-sound-as", "save-sound-dialog", "save-state", "save-state-file", "save-state-hook", "savitzky-golay-filter",
+ "sawtooth-wave", "sawtooth-wave?", "scale-by", "scale-channel", "scale-envelope", "scale-mixes",
+ "scale-selection-by", "scale-selection-to", "scale-sound", "scale-tempo", "scale-to", "scan-channel",
+ "scanned synthesis", "scentroid", "scratch", "script-arg", "script-args", "search-for-click",
+ "search-procedure", "seconds->samples", "select-all", "select-channel", "select-channel-hook", "select-sound",
+ "select-sound-hook", "selected-channel", "selected-data-color", "selected-graph-color", "selected-sound", "selection",
+ "selection->mix", "selection-chans", "selection-color", "selection-context", "selection-creates-region", "selection-framples",
+ "selection-maxamp", "selection-maxamp-position", "selection-member?", "selection-members", "selection-position", "selection-rms",
+ "selection-srate", "selection?", "set-samples", "short-file-name", "show-axes", "show-controls",
+ "show-disk-space", "show-full-duration", "show-full-range", "show-grid", "show-indices", "show-listener",
+ "show-marks", "show-mix-waveforms", "show-selection", "show-selection-transform", "show-sonogram-cursor", "show-transform-peaks",
+ "show-widget", "show-y-zero", "silence-all-mixes", "silence-mixes", "sinc-train", "sinc-train?",
+ "sinc-width", "sine-env-channel", "sine-ramp", "singer", "smooth-channel", "smooth-selection",
+ "smooth-sound", "SMS synthesis", "snap-mark-to-beat", "snap-marks", "snap-mix-to-beat", "snd->sample",
+ "snd->sample?", "snd-color", "snd-error", "snd-error-hook", "snd-font", "snd-gcs",
+ "snd-help", "snd-hooks", "*snd-opened-sound*", "snd-print", "snd-spectrum", "snd-tempnam",
+ "snd-url", "snd-urls", "snd-version", "snd-warning", "snd-warning-hook", "sndwarp",
+ "sort!", "sound->amp-env", "sound->integer", "sound-file-extensions", "sound-file?", "sound-files-in-directory",
+ "sound-interp", "sound-loop-info", "sound-properties", "sound-property", "sound-widgets", "sound?",
+ "soundfont-info", "sounds", "sounds->segment-data", "spectra", "spectral interpolation", "spectral-polynomial",
+ "spectro-hop", "spectro-x-angle", "spectro-x-scale", "spectro-y-angle", "spectro-y-scale", "spectro-z-angle",
+ "spectro-z-scale", "spectrum", "spectrum->coeffs", "spectrum-end", "spectrum-start", "speed-control",
+ "speed-control-bounds", "speed-control-style", "speed-control-tones", "spot-freq", "square-wave", "square-wave?",
+ "squelch-update", "squelch-vowels", "srate", "src", "src-channel", "src-duration",
+ "src-fit-envelope", "src-mixes", "src-selection", "src-sound", "src?", "ssb-am",
+ "ssb-am?", "ssb-bank", "ssb-bank-env", "ssb-fm", "start-dac", "start-playing",
+ "start-playing-hook", "start-playing-selection-hook", "start-progress-report", "status-report", "stdin-prompt", "stereo->mono",
+ "stereo-flute", "stop-player", "stop-playing", "stop-playing-hook", "stop-playing-selection-hook", "stretch-envelope",
+ "stretch-sound-via-dft", "string-position", "sublet", "superimpose-ffts", "swap-channels", "swap-selection-channels",
+ "symbol->dynamic-value", "symbol->value", "symbol-access", "symbol-table", "sync", "sync-everything",
+ "sync-max", "sync-style", "syncd-marks", "syncd-mixes", "syncup", "table-lookup",
+ "table-lookup?", "tanhsin", "tanhsin?", "tap", "tap?", "telephone",
+ "temp-dir", "text-focus-color", "time-graph-style", "time-graph-type", "time-graph?", "times->samples",
+ "tiny-font", "touch-tone", "trace", "tracking-cursor-style", "transform->integer", "transform->vct",
+ "transform-dialog", "transform-framples", "transform-graph-style", "transform-graph-type", "transform-graph?", "transform-normalization",
+ "transform-sample", "transform-size", "transform-type", "transform?", "transpose-mixes", "triangle-wave",
+ "triangle-wave?", "tubebell", "tubular bell", "two-pole", "two-pole?", "two-tab",
+ "two-zero", "two-zero?", "unbind-key", "*unbound-variable-hook*", "unclip-channel", "undo",
+ "undo-hook", "unlet", "unselect-all", "update-graphs", "update-hook", "update-lisp-graph",
+ "update-sound", "update-time-graph", "update-transform-graph", "upon-save-yourself", "user interface extensions", "variable-display",
+ "variable-graph?", "varlet", "vct", "vct*", "vct+", "vct->channel",
+ "vct->list", "vct->string", "vct->vector", "vct-abs!", "vct-add!", "vct-copy",
+ "vct-equal?", "vct-fill!", "vct-length", "vct-max", "vct-min", "vct-move!",
+ "vct-multiply!", "vct-offset!", "vct-peak", "vct-ref", "vct-reverse!", "vct-scale!",
+ "vct-set!", "vct-subseq", "vct-subtract!", "vct?", "vector->vct", "view-files-amp",
+ "view-files-amp-env", "view-files-dialog", "view-files-files", "view-files-select-hook", "view-files-selected-files", "view-files-sort",
+ "view-files-speed", "view-files-speed-style", "view-mixes-dialog", "view-regions-dialog", "view-sound", "voice physical model",
+ "voiced->unvoiced", "volterra-filter", "vox", "wave-train", "wave-train?", "wavelet-type",
+ "waveshaping voice", "wavo-hop", "wavo-trace", "weighted-moving-average", "widget-position", "widget-size",
+ "widget-text", "window-height", "window-samples", "window-width", "window-x", "window-y",
+ "with-background-processes", "with-baffle", "with-file-monitor", "with-gl", "with-inset-graph", "with-interrupts",
+ "with-let", "with-local-hook", "with-menu-icons", "with-mix-tags", "with-pointer-focus", "with-relative-panes",
+ "with-smpte-label", "with-sound", "with-temporary-selection", "with-toolbar", "with-tooltips", "with-tracking-cursor",
+ "with-verbose-cursor", "x->position", "x-axis-label", "x-axis-style", "x-bounds", "x-position-slider",
+ "x-zoom-slider", "xb-open", "xramp-channel", "y->position", "y-axis-label", "y-bounds",
+ "y-position-slider", "y-zoom-slider", "z-transform", "zecho", "zero+", "zero-pad",
+ "zero-phase", "zip-sound", "zipper", "zoom-color", "zoom-focus-style"};
#endif
#if HAVE_RUBY
static const char *help_names[HELP_NAMES_SIZE] = {
@@ -450,95 +451,96 @@ static const char *help_names[HELP_NAMES_SIZE] = {
"open_sound", "openlet", "openlet?", "orientation_hook", "oscil", "oscil_bank",
"oscil_bank?", "oscil?", "out_any", "out_bank", "outa", "outlet",
"_output_", "output_comment_hook", "overlay_rms_env", "owlet", "pad_channel", "pad_marks",
- "pad_sound", "pan_mix", "pan_mix_float_vector", "partials2polynomial", "partials2wave", "pausing",
- "peak_env_dir", "peaks", "peaks_font", "phase_partials2wave", "phase_vocoder", "phase_vocoder?",
- "piano_model", "pink_noise", "pink_noise?", "pins", "place_sound", "play",
- "play_arrow_size", "play_between_marks", "play_hook", "play_mixes", "play_often", "play_region_forever",
- "play_sine", "play_sines", "play_syncd_marks", "play_until_c_g", "play_with_envs", "player_home",
- "player?", "players", "playing", "pluck", "polar2rectangular", "polynomial",
- "polynomial_operations", "polyoid", "polyoid_env", "polyoid?", "polyshape", "polyshape?",
- "polywave", "polywave?", "position2x", "position2y", "position_color", "power_env",
- "pqw", "pqw_vox", "preferences_dialog", "previous_sample", "print_dialog", "print_length",
- "procedure_documentation", "procedure_setter", "procedure_signature", "procedure_source", "profile", "progress_report",
- "pulse_train", "pulse_train?", "pulsed_env", "pulsed_env?", "r2k!cos", "r2k!cos?",
- "r2k2cos", "r2k2cos?", "radians2degrees", "radians2hz", "ramp_channel", "rand",
- "rand_interp", "rand_interp?", "rand?", "random", "random_state", "random_state?",
- "rcos", "rcos?", "read_hook", "read_mix_sample", "read_only", "read_region_sample",
- "read_sample", "read_sample_with_direction", "reader_cond", "readin", "readin?", "rectangular2magnitudes",
- "rectangular2polar", "redo_edit", "region2integer", "region2vct", "region_chans", "region_framples",
- "region_graph_style", "region_home", "region_maxamp", "region_maxamp_position", "region_play_list", "region_position",
- "region_rms", "region_sample", "region_sampler?", "region_srate", "region?", "regions",
- "remember_sound_state", "remove_clicks", "remove_from_menu", "replace_with_selection", "report_mark_names", "require",
- "reset_all_hooks", "reset_controls", "reset_listener_cursor", "reson", "restore_controls", "_reverb_",
- "reverb_control_decay", "reverb_control_feedback", "reverb_control_length", "reverb_control_length_bounds", "reverb_control_lowpass", "reverb_control_scale",
- "reverb_control_scale_bounds", "reverb_control?", "reverse!", "reverse_by_blocks", "reverse_channel", "reverse_envelope",
- "reverse_selection", "reverse_sound", "revert_sound", "right_sample", "ring_modulate", "rk!cos",
- "rk!cos?", "rk!ssb", "rk!ssb?", "rkcos", "rkcos?", "rkoddssb",
- "rkoddssb?", "rksin", "rksin?", "rkssb", "rkssb?", "rms",
- "rms__gain__balance_gens", "rms_envelope", "rootlet", "round_interp", "round_interp?", "rssb",
- "rssb_interp", "rssb?", "rubber_sound", "rxycos", "rxycos?", "rxyk!cos",
- "rxyk!cos?", "rxyk!sin", "rxyk!sin?", "rxysin", "rxysin?", "sample",
- "sample2file", "sample2file?", "sample_type", "sampler_at_end?", "sampler_home", "sampler_position",
- "sampler?", "samples", "samples2seconds", "sash_color", "save_as_dialog_auto_comment", "save_as_dialog_src",
- "save_controls", "save_dir", "save_edit_history", "save_envelopes", "save_hook", "save_listener",
- "save_mark_properties", "save_marks", "save_mix", "save_region", "save_region_dialog", "save_selection",
- "save_selection_dialog", "save_sound", "save_sound_as", "save_sound_dialog", "save_state", "save_state_file",
- "save_state_hook", "savitzky_golay_filter", "sawtooth_wave", "sawtooth_wave?", "scale_by", "scale_channel",
- "scale_envelope", "scale_mixes", "scale_selection_by", "scale_selection_to", "scale_sound", "scale_tempo",
- "scale_to", "scan_channel", "scanned_synthesis", "scentroid", "scratch", "script_arg",
- "script_args", "search_for_click", "search_procedure", "seconds2samples", "select_all", "select_channel",
- "select_channel_hook", "select_sound", "select_sound_hook", "selected_channel", "selected_data_color", "selected_graph_color",
- "selected_sound", "selection", "selection2mix", "selection_chans", "selection_color", "Selection_context",
- "selection_creates_region", "selection_framples", "selection_maxamp", "selection_maxamp_position", "selection_member?", "selection_members",
- "selection_position", "selection_rms", "selection_srate", "selection?", "set_samples", "short_file_name",
- "show_axes", "show_controls", "show_disk_space", "show_full_duration", "show_full_range", "show_grid",
- "show_indices", "show_listener", "show_marks", "show_mix_waveforms", "show_selection", "show_selection_transform",
- "show_sonogram_cursor", "show_transform_peaks", "show_widget", "show_y_zero", "silence_all_mixes", "silence_mixes",
- "sinc_train", "sinc_train?", "sinc_width", "sine_env_channel", "sine_ramp", "singer",
- "smooth_channel", "smooth_selection", "smooth_sound", "SMS_synthesis", "snap_mark_to_beat", "snap_marks",
- "snap_mix_to_beat", "snd2sample", "snd2sample?", "snd_color", "snd_error", "snd_error_hook",
- "snd_font", "snd_gcs", "snd_help", "snd_hooks", "_snd_opened_sound_", "snd_print",
- "snd_spectrum", "snd_tempnam", "snd_url", "snd_urls", "snd_version", "snd_warning",
- "snd_warning_hook", "sndwarp", "sort!", "sound2amp_env", "sound2integer", "sound_file_extensions",
- "sound_file?", "sound_files_in_directory", "sound_interp", "sound_loop_info", "sound_properties", "sound_property",
- "sound_widgets", "sound?", "soundfont_info", "sounds", "sounds2segment_data", "spectra",
- "spectral_interpolation", "spectral_polynomial", "spectro_hop", "spectro_x_angle", "spectro_x_scale", "spectro_y_angle",
- "spectro_y_scale", "spectro_z_angle", "spectro_z_scale", "spectrum", "spectrum2coeffs", "spectrum_end",
- "spectrum_start", "speed_control", "speed_control_bounds", "speed_control_style", "speed_control_tones", "spot_freq",
- "square_wave", "square_wave?", "squelch_update", "squelch_vowels", "srate", "src",
- "src_channel", "src_duration", "src_fit_envelope", "src_mixes", "src_selection", "src_sound",
- "src?", "ssb_am", "ssb_am?", "ssb_bank", "ssb_bank_env", "ssb_fm",
- "start_dac", "start_playing", "start_playing_hook", "start_playing_selection_hook", "start_progress_report", "status_report",
- "stereo2mono", "stereo_flute", "stop_player", "stop_playing", "stop_playing_hook", "stop_playing_selection_hook",
- "stretch_envelope", "stretch_sound_via_dft", "string_position", "sublet", "superimpose_ffts", "swap_channels",
- "swap_selection_channels", "symbol2dynamic_value", "symbol2value", "symbol_access", "symbol_table", "sync",
- "sync_everything", "sync_max", "sync_style", "syncd_marks", "syncd_mixes", "syncup",
- "table_lookup", "table_lookup?", "tanhsin", "tanhsin?", "tap", "tap?",
- "telephone", "temp_dir", "text_focus_color", "time_graph_style", "time_graph_type", "time_graph?",
- "times2samples", "tiny_font", "touch_tone", "trace", "tracking_cursor_style", "transform2integer",
- "transform2vct", "transform_dialog", "transform_framples", "transform_graph_style", "transform_graph_type", "transform_graph?",
- "transform_normalization", "transform_sample", "transform_size", "transform_type", "transform?", "transpose_mixes",
- "triangle_wave", "triangle_wave?", "tubebell", "tubular_bell", "two_pole", "two_pole?",
- "two_tab", "two_zero", "two_zero?", "unbind_key", "_unbound_variable_hook_", "unclip_channel",
- "undo", "undo_hook", "unlet", "unselect_all", "update_graphs", "update_hook",
- "update_lisp_graph", "update_sound", "update_time_graph", "update_transform_graph", "upon_save_yourself", "user_interface_extensions",
- "variable_display", "variable_graph?", "varlet", "vct", "vct_", "vct_",
- "vct2channel", "vct2list", "vct2string", "vct2vector", "vct_abs!", "vct_add!",
- "vct_copy", "vct_equal?", "vct_fill!", "vct_length", "vct_max", "vct_min",
- "vct_move!", "vct_multiply!", "vct_offset!", "vct_peak", "vct_ref", "vct_reverse!",
- "vct_scale!", "vct_set!", "vct_subseq", "vct_subtract!", "vct?", "vector2vct",
- "view_files_amp", "view_files_amp_env", "view_files_dialog", "view_files_files", "view_files_select_hook", "view_files_selected_files",
- "view_files_sort", "view_files_speed", "view_files_speed_style", "view_mixes_dialog", "view_regions_dialog", "view_sound",
- "voice_physical_model", "voiced2unvoiced", "volterra_filter", "vox", "wave_train", "wave_train?",
- "wavelet_type", "waveshaping_voice", "wavo_hop", "wavo_trace", "weighted_moving_average", "widget_position",
- "widget_size", "widget_text", "window_height", "window_samples", "window_width", "window_x",
- "window_y", "with_background_processes", "with_baffle", "with_file_monitor", "with_gl", "with_inset_graph",
- "with_interrupts", "with_let", "with_local_hook", "with_menu_icons", "with_mix_tags", "with_pointer_focus",
- "with_relative_panes", "with_smpte_label", "with_sound", "with_temporary_selection", "with_toolbar", "with_tooltips",
- "with_tracking_cursor", "with_verbose_cursor", "x2position", "x_axis_label", "x_axis_style", "x_bounds",
- "x_position_slider", "x_zoom_slider", "xb_open", "xramp_channel", "y2position", "y_axis_label",
- "y_bounds", "y_position_slider", "y_zoom_slider", "z_transform", "zecho", "zero_",
- "zero_pad", "zero_phase", "zip_sound", "zipper", "zoom_color", "zoom_focus_style"};
+ "pad_sound", "pair_filename", "pair_line_number", "pan_mix", "pan_mix_float_vector", "partials2polynomial",
+ "partials2wave", "pausing", "peak_env_dir", "peaks", "peaks_font", "phase_partials2wave",
+ "phase_vocoder", "phase_vocoder?", "piano_model", "pink_noise", "pink_noise?", "pins",
+ "place_sound", "play", "play_arrow_size", "play_between_marks", "play_hook", "play_mixes",
+ "play_often", "play_region_forever", "play_sine", "play_sines", "play_syncd_marks", "play_until_c_g",
+ "play_with_envs", "player_home", "player?", "players", "playing", "pluck",
+ "polar2rectangular", "polynomial", "polynomial_operations", "polyoid", "polyoid_env", "polyoid?",
+ "polyshape", "polyshape?", "polywave", "polywave?", "port_filename", "port_line_number",
+ "position2x", "position2y", "position_color", "power_env", "pqw", "pqw_vox",
+ "preferences_dialog", "previous_sample", "print_dialog", "print_length", "procedure_documentation", "procedure_setter",
+ "procedure_signature", "procedure_source", "progress_report", "pulse_train", "pulse_train?", "pulsed_env",
+ "pulsed_env?", "r2k!cos", "r2k!cos?", "r2k2cos", "r2k2cos?", "radians2degrees",
+ "radians2hz", "ramp_channel", "rand", "rand_interp", "rand_interp?", "rand?",
+ "random", "random_state", "random_state?", "rcos", "rcos?", "_read_error_hook_",
+ "read_hook", "read_mix_sample", "read_only", "read_region_sample", "read_sample", "read_sample_with_direction",
+ "reader_cond", "readin", "readin?", "rectangular2magnitudes", "rectangular2polar", "redo_edit",
+ "region2integer", "region2vct", "region_chans", "region_framples", "region_graph_style", "region_home",
+ "region_maxamp", "region_maxamp_position", "region_play_list", "region_position", "region_rms", "region_sample",
+ "region_sampler?", "region_srate", "region?", "regions", "remember_sound_state", "remove_clicks",
+ "remove_from_menu", "replace_with_selection", "report_mark_names", "require", "reset_all_hooks", "reset_controls",
+ "reset_listener_cursor", "reson", "restore_controls", "_reverb_", "reverb_control_decay", "reverb_control_feedback",
+ "reverb_control_length", "reverb_control_length_bounds", "reverb_control_lowpass", "reverb_control_scale", "reverb_control_scale_bounds", "reverb_control?",
+ "reverse!", "reverse_by_blocks", "reverse_channel", "reverse_envelope", "reverse_selection", "reverse_sound",
+ "revert_sound", "right_sample", "ring_modulate", "rk!cos", "rk!cos?", "rk!ssb",
+ "rk!ssb?", "rkcos", "rkcos?", "rkoddssb", "rkoddssb?", "rksin",
+ "rksin?", "rkssb", "rkssb?", "rms", "rms__gain__balance_gens", "rms_envelope",
+ "rootlet", "round_interp", "round_interp?", "rssb", "rssb_interp", "rssb?",
+ "rubber_sound", "rxycos", "rxycos?", "rxyk!cos", "rxyk!cos?", "rxyk!sin",
+ "rxyk!sin?", "rxysin", "rxysin?", "sample", "sample2file", "sample2file?",
+ "sample_type", "sampler_at_end?", "sampler_home", "sampler_position", "sampler?", "samples",
+ "samples2seconds", "sash_color", "save_as_dialog_auto_comment", "save_as_dialog_src", "save_controls", "save_dir",
+ "save_edit_history", "save_envelopes", "save_hook", "save_listener", "save_mark_properties", "save_marks",
+ "save_mix", "save_region", "save_region_dialog", "save_selection", "save_selection_dialog", "save_sound",
+ "save_sound_as", "save_sound_dialog", "save_state", "save_state_file", "save_state_hook", "savitzky_golay_filter",
+ "sawtooth_wave", "sawtooth_wave?", "scale_by", "scale_channel", "scale_envelope", "scale_mixes",
+ "scale_selection_by", "scale_selection_to", "scale_sound", "scale_tempo", "scale_to", "scan_channel",
+ "scanned_synthesis", "scentroid", "scratch", "script_arg", "script_args", "search_for_click",
+ "search_procedure", "seconds2samples", "select_all", "select_channel", "select_channel_hook", "select_sound",
+ "select_sound_hook", "selected_channel", "selected_data_color", "selected_graph_color", "selected_sound", "selection",
+ "selection2mix", "selection_chans", "selection_color", "Selection_context", "selection_creates_region", "selection_framples",
+ "selection_maxamp", "selection_maxamp_position", "selection_member?", "selection_members", "selection_position", "selection_rms",
+ "selection_srate", "selection?", "set_samples", "short_file_name", "show_axes", "show_controls",
+ "show_disk_space", "show_full_duration", "show_full_range", "show_grid", "show_indices", "show_listener",
+ "show_marks", "show_mix_waveforms", "show_selection", "show_selection_transform", "show_sonogram_cursor", "show_transform_peaks",
+ "show_widget", "show_y_zero", "silence_all_mixes", "silence_mixes", "sinc_train", "sinc_train?",
+ "sinc_width", "sine_env_channel", "sine_ramp", "singer", "smooth_channel", "smooth_selection",
+ "smooth_sound", "SMS_synthesis", "snap_mark_to_beat", "snap_marks", "snap_mix_to_beat", "snd2sample",
+ "snd2sample?", "snd_color", "snd_error", "snd_error_hook", "snd_font", "snd_gcs",
+ "snd_help", "snd_hooks", "_snd_opened_sound_", "snd_print", "snd_spectrum", "snd_tempnam",
+ "snd_url", "snd_urls", "snd_version", "snd_warning", "snd_warning_hook", "sndwarp",
+ "sort!", "sound2amp_env", "sound2integer", "sound_file_extensions", "sound_file?", "sound_files_in_directory",
+ "sound_interp", "sound_loop_info", "sound_properties", "sound_property", "sound_widgets", "sound?",
+ "soundfont_info", "sounds", "sounds2segment_data", "spectra", "spectral_interpolation", "spectral_polynomial",
+ "spectro_hop", "spectro_x_angle", "spectro_x_scale", "spectro_y_angle", "spectro_y_scale", "spectro_z_angle",
+ "spectro_z_scale", "spectrum", "spectrum2coeffs", "spectrum_end", "spectrum_start", "speed_control",
+ "speed_control_bounds", "speed_control_style", "speed_control_tones", "spot_freq", "square_wave", "square_wave?",
+ "squelch_update", "squelch_vowels", "srate", "src", "src_channel", "src_duration",
+ "src_fit_envelope", "src_mixes", "src_selection", "src_sound", "src?", "ssb_am",
+ "ssb_am?", "ssb_bank", "ssb_bank_env", "ssb_fm", "start_dac", "start_playing",
+ "start_playing_hook", "start_playing_selection_hook", "start_progress_report", "status_report", "stdin_prompt", "stereo2mono",
+ "stereo_flute", "stop_player", "stop_playing", "stop_playing_hook", "stop_playing_selection_hook", "stretch_envelope",
+ "stretch_sound_via_dft", "string_position", "sublet", "superimpose_ffts", "swap_channels", "swap_selection_channels",
+ "symbol2dynamic_value", "symbol2value", "symbol_access", "symbol_table", "sync", "sync_everything",
+ "sync_max", "sync_style", "syncd_marks", "syncd_mixes", "syncup", "table_lookup",
+ "table_lookup?", "tanhsin", "tanhsin?", "tap", "tap?", "telephone",
+ "temp_dir", "text_focus_color", "time_graph_style", "time_graph_type", "time_graph?", "times2samples",
+ "tiny_font", "touch_tone", "trace", "tracking_cursor_style", "transform2integer", "transform2vct",
+ "transform_dialog", "transform_framples", "transform_graph_style", "transform_graph_type", "transform_graph?", "transform_normalization",
+ "transform_sample", "transform_size", "transform_type", "transform?", "transpose_mixes", "triangle_wave",
+ "triangle_wave?", "tubebell", "tubular_bell", "two_pole", "two_pole?", "two_tab",
+ "two_zero", "two_zero?", "unbind_key", "_unbound_variable_hook_", "unclip_channel", "undo",
+ "undo_hook", "unlet", "unselect_all", "update_graphs", "update_hook", "update_lisp_graph",
+ "update_sound", "update_time_graph", "update_transform_graph", "upon_save_yourself", "user_interface_extensions", "variable_display",
+ "variable_graph?", "varlet", "vct", "vct_", "vct_", "vct2channel",
+ "vct2list", "vct2string", "vct2vector", "vct_abs!", "vct_add!", "vct_copy",
+ "vct_equal?", "vct_fill!", "vct_length", "vct_max", "vct_min", "vct_move!",
+ "vct_multiply!", "vct_offset!", "vct_peak", "vct_ref", "vct_reverse!", "vct_scale!",
+ "vct_set!", "vct_subseq", "vct_subtract!", "vct?", "vector2vct", "view_files_amp",
+ "view_files_amp_env", "view_files_dialog", "view_files_files", "view_files_select_hook", "view_files_selected_files", "view_files_sort",
+ "view_files_speed", "view_files_speed_style", "view_mixes_dialog", "view_regions_dialog", "view_sound", "voice_physical_model",
+ "voiced2unvoiced", "volterra_filter", "vox", "wave_train", "wave_train?", "wavelet_type",
+ "waveshaping_voice", "wavo_hop", "wavo_trace", "weighted_moving_average", "widget_position", "widget_size",
+ "widget_text", "window_height", "window_samples", "window_width", "window_x", "window_y",
+ "with_background_processes", "with_baffle", "with_file_monitor", "with_gl", "with_inset_graph", "with_interrupts",
+ "with_let", "with_local_hook", "with_menu_icons", "with_mix_tags", "with_pointer_focus", "with_relative_panes",
+ "with_smpte_label", "with_sound", "with_temporary_selection", "with_toolbar", "with_tooltips", "with_tracking_cursor",
+ "with_verbose_cursor", "x2position", "x_axis_label", "x_axis_style", "x_bounds", "x_position_slider",
+ "x_zoom_slider", "xb_open", "xramp_channel", "y2position", "y_axis_label", "y_bounds",
+ "y_position_slider", "y_zoom_slider", "z_transform", "zecho", "zero_", "zero_pad",
+ "zero_phase", "zip_sound", "zipper", "zoom_color", "zoom_focus_style"};
#endif
#if (!HAVE_EXTENSION_LANGUAGE)
static const char **help_names = NULL;
@@ -811,26 +813,27 @@ static const char *help_urls[HELP_NAMES_SIZE] = {
"sndclm.html#oscil-bank?", "sndclm.html#oscil?", "sndclm.html#out-any", "sndclm.html#outbank",
"sndclm.html#outa", "s7.html#outlet", "sndclm.html#*output*", "extsnd.html#outputcommenthook",
"sndscm.html#overlayrmsenv", "s7.html#owlet", "extsnd.html#padchannel", "sndscm.html#padmarks",
- "sndscm.html#padsound", "sndscm.html#panmix", "sndscm.html#panmixvct", "sndclm.html#partialstopolynomial",
- "sndclm.html#partialstowave", "extsnd.html#pausing", "extsnd.html#peakenvdir", "extsnd.html#peaks",
- "extsnd.html#peaksfont", "sndclm.html#phase-partialstowave", "sndclm.html#phase-vocoder", "sndclm.html#phase-vocoder?",
- "sndscm.html#pianodoc", "sndclm.html#pink-noise", "sndclm.html#pink-noise?", "sndscm.html#pins",
- "sndscm.html#placesound", "extsnd.html#play", "extsnd.html#playarrowsize", "sndscm.html#playbetweenmarks",
- "extsnd.html#playhook", "sndscm.html#playmixes", "sndscm.html#playoften", "sndscm.html#playregionforever",
- "sndscm.html#playsine", "sndscm.html#playsines", "sndscm.html#playsyncdmarks", "sndscm.html#playuntilcg",
- "sndscm.html#playwithenvs", "extsnd.html#playerhome", "extsnd.html#playerQ", "extsnd.html#players",
- "extsnd.html#playing", "sndscm.html#pluck", "sndclm.html#polartorectangular", "sndclm.html#polynomial",
- "sndscm.html#polydoc", "sndclm.html#polyoid", "sndclm.html#polyoidenv", "sndclm.html#polyoid?",
- "sndclm.html#polyshape", "sndclm.html#polyshape?", "sndclm.html#polywave", "sndclm.html#polywave?",
+ "sndscm.html#padsound", "s7.html#pairfilename", "s7.html#pairlinenumber", "sndscm.html#panmix",
+ "sndscm.html#panmixvct", "sndclm.html#partialstopolynomial", "sndclm.html#partialstowave", "extsnd.html#pausing",
+ "extsnd.html#peakenvdir", "extsnd.html#peaks", "extsnd.html#peaksfont", "sndclm.html#phase-partialstowave",
+ "sndclm.html#phase-vocoder", "sndclm.html#phase-vocoder?", "sndscm.html#pianodoc", "sndclm.html#pink-noise",
+ "sndclm.html#pink-noise?", "sndscm.html#pins", "sndscm.html#placesound", "extsnd.html#play",
+ "extsnd.html#playarrowsize", "sndscm.html#playbetweenmarks", "extsnd.html#playhook", "sndscm.html#playmixes",
+ "sndscm.html#playoften", "sndscm.html#playregionforever", "sndscm.html#playsine", "sndscm.html#playsines",
+ "sndscm.html#playsyncdmarks", "sndscm.html#playuntilcg", "sndscm.html#playwithenvs", "extsnd.html#playerhome",
+ "extsnd.html#playerQ", "extsnd.html#players", "extsnd.html#playing", "sndscm.html#pluck",
+ "sndclm.html#polartorectangular", "sndclm.html#polynomial", "sndscm.html#polydoc", "sndclm.html#polyoid",
+ "sndclm.html#polyoidenv", "sndclm.html#polyoid?", "sndclm.html#polyshape", "sndclm.html#polyshape?",
+ "sndclm.html#polywave", "sndclm.html#polywave?", "s7.html#portfilename", "s7.html#portlinenumber",
"extsnd.html#positiontox", "extsnd.html#positiontoy", "extsnd.html#positioncolor", "sndscm.html#powerenv",
"sndscm.html#pqw", "sndscm.html#pqwvox", "extsnd.html#preferencesdialog", "extsnd.html#previoussample",
"extsnd.html#printdialog", "extsnd.html#printlength", "s7.html#proceduredocumentation", "s7.html#proceduresetter",
- "s7.html#proceduresignature", "s7.html#proceduresource", "s7.html#profile", "extsnd.html#progressreport",
- "sndclm.html#pulse-train", "sndclm.html#pulse-train?", "sndclm.html#pulsedenv", "sndclm.html#pulsedenv?",
- "sndclm.html#r2k!cos", "sndclm.html#r2k!cos?", "sndclm.html#r2k2cos", "sndclm.html#r2k2cos?",
- "sndclm.html#radianstodegrees", "sndclm.html#radianstohz", "extsnd.html#rampchannel", "sndclm.html#rand",
- "sndclm.html#rand-interp", "sndclm.html#rand-interp?", "sndclm.html#rand?", "s7.html#random",
- "s7.html#randomstate", "s7.html#randomstatep", "sndclm.html#rcos", "sndclm.html#rcos?",
+ "s7.html#proceduresignature", "s7.html#proceduresource", "extsnd.html#progressreport", "sndclm.html#pulse-train",
+ "sndclm.html#pulse-train?", "sndclm.html#pulsedenv", "sndclm.html#pulsedenv?", "sndclm.html#r2k!cos",
+ "sndclm.html#r2k!cos?", "sndclm.html#r2k2cos", "sndclm.html#r2k2cos?", "sndclm.html#radianstodegrees",
+ "sndclm.html#radianstohz", "extsnd.html#rampchannel", "sndclm.html#rand", "sndclm.html#rand-interp",
+ "sndclm.html#rand-interp?", "sndclm.html#rand?", "s7.html#random", "s7.html#randomstate",
+ "s7.html#randomstatep", "sndclm.html#rcos", "sndclm.html#rcos?", "s7.html#readerrorhook",
"extsnd.html#readhook", "extsnd.html#readmixsample", "extsnd.html#readonly", "extsnd.html#readregionsample",
"extsnd.html#readsample", "extsnd.html#readsamplewithdirection", "s7.html#readercond", "sndclm.html#readin",
"sndclm.html#readin?", "sndclm.html#rectangulartomagnitudes", "sndclm.html#rectangulartopolar", "extsnd.html#redo",
@@ -899,52 +902,52 @@ static const char *help_urls[HELP_NAMES_SIZE] = {
"extsnd.html#srcsoundselection", "extsnd.html#srcsound", "sndclm.html#src?", "sndclm.html#ssb-am",
"sndclm.html#ssb-am?", "sndscm.html#ssbbank", "sndscm.html#ssbbankenv", "sndscm.html#ssbfm",
"sndscm.html#startdac", "extsnd.html#startplaying", "extsnd.html#startplayinghook", "extsnd.html#startplayingselectionhook",
- "extsnd.html#startprogressreport", "extsnd.html#statusreport", "sndscm.html#stereotomono", "sndscm.html#stereoflute",
- "extsnd.html#stopplayer", "extsnd.html#stopplaying", "extsnd.html#stopplayinghook", "extsnd.html#stopplayingselectionhook",
- "sndscm.html#stretchenvelope", "sndscm.html#stretchsoundviadft", "s7.html#stringposition", "s7.html#sublet",
- "sndscm.html#superimposeffts", "extsnd.html#swapchannels", "sndscm.html#swapselectionchannels", "s7.html#symboltodynamicvalue",
- "s7.html#symboltovalue", "s7.html#symbolaccess", "s7.html#symboltable", "extsnd.html#sync",
- "sndscm.html#sync-everything", "extsnd.html#syncmax", "extsnd.html#syncstyle", "extsnd.html#syncdmarks",
- "sndscm.html#syncdmixes", "sndscm.html#syncup", "sndclm.html#table-lookup", "sndclm.html#table-lookup?",
- "sndclm.html#tanhsin", "sndclm.html#tanhsin?", "sndclm.html#tap", "sndclm.html#tap?",
- "sndscm.html#telephone", "extsnd.html#tempdir", "extsnd.html#textfocuscolor", "extsnd.html#timegraphstyle",
- "extsnd.html#timegraphtype", "extsnd.html#timegraphp", "sndclm.html#timestosamples", "extsnd.html#tinyfont",
- "sndscm.html#telephone", "s7.html#trace", "extsnd.html#trackingcursorstyle", "extsnd.html#transformtointeger",
- "extsnd.html#transformtovct", "extsnd.html#transformdialog", "extsnd.html#transformframples", "extsnd.html#transformgraphstyle",
- "extsnd.html#transformgraphtype", "extsnd.html#transformgraphp", "extsnd.html#normalizefft", "extsnd.html#transformsample",
- "extsnd.html#transformsize", "extsnd.html#transformtype", "extsnd.html#transformp", "sndscm.html#transposemixes",
- "sndclm.html#triangle-wave", "sndclm.html#triangle-wave?", "sndscm.html#tubebell", "sndscm.html#tubebell",
- "sndclm.html#two-pole", "sndclm.html#two-pole?", "sndscm.html#twotab", "sndclm.html#two-zero",
- "sndclm.html#two-zero?", "extsnd.html#unbindkey", "s7.html#unboundvariablehook", "sndscm.html#unclipchannel",
- "extsnd.html#undo", "extsnd.html#undohook", "s7.html#unlet", "extsnd.html#unselectall",
- "sndscm.html#updategraphs", "extsnd.html#updatehook", "extsnd.html#updatelispgraph", "extsnd.html#updatesound",
- "extsnd.html#updatetimegraph", "extsnd.html#updatetransformgraph", "sndscm.html#uponsaveyourself", "sndscm.html#sndmotifdoc",
- "sndscm.html#variabledisplay", "extsnd.html#variablegraphp", "s7.html#varlet", "extsnd.html#vct",
- "extsnd.html#vcttimes", "extsnd.html#vctplus", "extsnd.html#vcttochannel", "extsnd.html#vcttolist",
- "extsnd.html#vcttostring", "extsnd.html#vcttovector", "extsnd.html#vctabs", "extsnd.html#vctadd",
- "extsnd.html#vctcopy", "extsnd.html#vctequal", "extsnd.html#vctfill", "extsnd.html#vctlength",
- "extsnd.html#vctmax", "extsnd.html#vctmin", "extsnd.html#vctmove", "extsnd.html#vctmultiply",
- "extsnd.html#vctoffset", "extsnd.html#vctpeak", "extsnd.html#vctref", "extsnd.html#vctreverse",
- "extsnd.html#vctscale", "extsnd.html#vctset", "extsnd.html#vctsubseq", "extsnd.html#vctsubtract",
- "extsnd.html#vctp", "extsnd.html#vectortovct", "extsnd.html#viewfilesamp", "extsnd.html#viewfilesampenv",
- "extsnd.html#viewfilesdialog", "extsnd.html#viewfilesfiles", "extsnd.html#viewfilesselecthook", "extsnd.html#viewfilesselectedfiles",
- "extsnd.html#viewfilessort", "extsnd.html#viewfilesspeed", "extsnd.html#viewfilesspeedstyle", "extsnd.html#viewmixesdialog",
- "extsnd.html#viewregionsdialog", "extsnd.html#viewsound", "sndscm.html#singerdoc", "sndscm.html#voicedtounvoiced",
- "sndscm.html#volterrafilter", "sndscm.html#fmvox", "sndclm.html#wave-train", "sndclm.html#wave-train?",
- "extsnd.html#wavelettype", "sndscm.html#pqwvox", "extsnd.html#wavohop", "extsnd.html#wavotrace",
- "sndclm.html#weighted-moving-average", "extsnd.html#widgetposition", "extsnd.html#widgetsize", "extsnd.html#widgettext",
- "extsnd.html#windowheight", "sndscm.html#windowsamples", "extsnd.html#windowwidth", "extsnd.html#windowx",
- "extsnd.html#windowy", "extsnd.html#withbackgroundprocesses", "s7.html#withbaffle", "extsnd.html#withfilemonitor",
- "extsnd.html#withgl", "extsnd.html#withinsetgraph", "extsnd.html#withinterrupts", "s7.html#with-let",
- "sndscm.html#withlocalhook", "extsnd.html#withmenuicons", "extsnd.html#withmixtags", "extsnd.html#withpointerfocus",
- "extsnd.html#withrelativepanes", "extsnd.html#withsmptelabel", "sndscm.html#withsound", "sndscm.html#withtemporaryselection",
- "extsnd.html#withtoolbar", "extsnd.html#withtooltips", "extsnd.html#withtrackingcursor", "extsnd.html#withverbosecursor",
- "extsnd.html#xtoposition", "extsnd.html#xaxislabel", "extsnd.html#xaxisstyle", "extsnd.html#xbounds",
- "extsnd.html#xpositionslider", "extsnd.html#xzoomslider", "sndscm.html#xbopen", "extsnd.html#xrampchannel",
- "extsnd.html#ytoposition", "extsnd.html#yaxislabel", "extsnd.html#ybounds", "extsnd.html#ypositionslider",
- "extsnd.html#yzoomslider", "sndscm.html#ztransform", "sndscm.html#zecho", "sndscm.html#zeroplus",
- "extsnd.html#zeropad", "sndscm.html#zerophase", "sndscm.html#zipsound", "sndscm.html#zipper",
- "extsnd.html#zoomcolor", "extsnd.html#zoomfocusstyle"};
+ "extsnd.html#startprogressreport", "extsnd.html#statusreport", "extsnd.html#stdinprompt", "sndscm.html#stereotomono",
+ "sndscm.html#stereoflute", "extsnd.html#stopplayer", "extsnd.html#stopplaying", "extsnd.html#stopplayinghook",
+ "extsnd.html#stopplayingselectionhook", "sndscm.html#stretchenvelope", "sndscm.html#stretchsoundviadft", "s7.html#stringposition",
+ "s7.html#sublet", "sndscm.html#superimposeffts", "extsnd.html#swapchannels", "sndscm.html#swapselectionchannels",
+ "s7.html#symboltodynamicvalue", "s7.html#symboltovalue", "s7.html#symbolaccess", "s7.html#symboltable",
+ "extsnd.html#sync", "sndscm.html#sync-everything", "extsnd.html#syncmax", "extsnd.html#syncstyle",
+ "extsnd.html#syncdmarks", "sndscm.html#syncdmixes", "sndscm.html#syncup", "sndclm.html#table-lookup",
+ "sndclm.html#table-lookup?", "sndclm.html#tanhsin", "sndclm.html#tanhsin?", "sndclm.html#tap",
+ "sndclm.html#tap?", "sndscm.html#telephone", "extsnd.html#tempdir", "extsnd.html#textfocuscolor",
+ "extsnd.html#timegraphstyle", "extsnd.html#timegraphtype", "extsnd.html#timegraphp", "sndclm.html#timestosamples",
+ "extsnd.html#tinyfont", "sndscm.html#telephone", "s7.html#trace", "extsnd.html#trackingcursorstyle",
+ "extsnd.html#transformtointeger", "extsnd.html#transformtovct", "extsnd.html#transformdialog", "extsnd.html#transformframples",
+ "extsnd.html#transformgraphstyle", "extsnd.html#transformgraphtype", "extsnd.html#transformgraphp", "extsnd.html#normalizefft",
+ "extsnd.html#transformsample", "extsnd.html#transformsize", "extsnd.html#transformtype", "extsnd.html#transformp",
+ "sndscm.html#transposemixes", "sndclm.html#triangle-wave", "sndclm.html#triangle-wave?", "sndscm.html#tubebell",
+ "sndscm.html#tubebell", "sndclm.html#two-pole", "sndclm.html#two-pole?", "sndscm.html#twotab",
+ "sndclm.html#two-zero", "sndclm.html#two-zero?", "extsnd.html#unbindkey", "s7.html#unboundvariablehook",
+ "sndscm.html#unclipchannel", "extsnd.html#undo", "extsnd.html#undohook", "s7.html#unlet",
+ "extsnd.html#unselectall", "sndscm.html#updategraphs", "extsnd.html#updatehook", "extsnd.html#updatelispgraph",
+ "extsnd.html#updatesound", "extsnd.html#updatetimegraph", "extsnd.html#updatetransformgraph", "sndscm.html#uponsaveyourself",
+ "sndscm.html#sndmotifdoc", "sndscm.html#variabledisplay", "extsnd.html#variablegraphp", "s7.html#varlet",
+ "extsnd.html#vct", "extsnd.html#vcttimes", "extsnd.html#vctplus", "extsnd.html#vcttochannel",
+ "extsnd.html#vcttolist", "extsnd.html#vcttostring", "extsnd.html#vcttovector", "extsnd.html#vctabs",
+ "extsnd.html#vctadd", "extsnd.html#vctcopy", "extsnd.html#vctequal", "extsnd.html#vctfill",
+ "extsnd.html#vctlength", "extsnd.html#vctmax", "extsnd.html#vctmin", "extsnd.html#vctmove",
+ "extsnd.html#vctmultiply", "extsnd.html#vctoffset", "extsnd.html#vctpeak", "extsnd.html#vctref",
+ "extsnd.html#vctreverse", "extsnd.html#vctscale", "extsnd.html#vctset", "extsnd.html#vctsubseq",
+ "extsnd.html#vctsubtract", "extsnd.html#vctp", "extsnd.html#vectortovct", "extsnd.html#viewfilesamp",
+ "extsnd.html#viewfilesampenv", "extsnd.html#viewfilesdialog", "extsnd.html#viewfilesfiles", "extsnd.html#viewfilesselecthook",
+ "extsnd.html#viewfilesselectedfiles", "extsnd.html#viewfilessort", "extsnd.html#viewfilesspeed", "extsnd.html#viewfilesspeedstyle",
+ "extsnd.html#viewmixesdialog", "extsnd.html#viewregionsdialog", "extsnd.html#viewsound", "sndscm.html#singerdoc",
+ "sndscm.html#voicedtounvoiced", "sndscm.html#volterrafilter", "sndscm.html#fmvox", "sndclm.html#wave-train",
+ "sndclm.html#wave-train?", "extsnd.html#wavelettype", "sndscm.html#pqwvox", "extsnd.html#wavohop",
+ "extsnd.html#wavotrace", "sndclm.html#weighted-moving-average", "extsnd.html#widgetposition", "extsnd.html#widgetsize",
+ "extsnd.html#widgettext", "extsnd.html#windowheight", "sndscm.html#windowsamples", "extsnd.html#windowwidth",
+ "extsnd.html#windowx", "extsnd.html#windowy", "extsnd.html#withbackgroundprocesses", "s7.html#withbaffle",
+ "extsnd.html#withfilemonitor", "extsnd.html#withgl", "extsnd.html#withinsetgraph", "extsnd.html#withinterrupts",
+ "s7.html#with-let", "sndscm.html#withlocalhook", "extsnd.html#withmenuicons", "extsnd.html#withmixtags",
+ "extsnd.html#withpointerfocus", "extsnd.html#withrelativepanes", "extsnd.html#withsmptelabel", "sndscm.html#withsound",
+ "sndscm.html#withtemporaryselection", "extsnd.html#withtoolbar", "extsnd.html#withtooltips", "extsnd.html#withtrackingcursor",
+ "extsnd.html#withverbosecursor", "extsnd.html#xtoposition", "extsnd.html#xaxislabel", "extsnd.html#xaxisstyle",
+ "extsnd.html#xbounds", "extsnd.html#xpositionslider", "extsnd.html#xzoomslider", "sndscm.html#xbopen",
+ "extsnd.html#xrampchannel", "extsnd.html#ytoposition", "extsnd.html#yaxislabel", "extsnd.html#ybounds",
+ "extsnd.html#ypositionslider", "extsnd.html#yzoomslider", "sndscm.html#ztransform", "sndscm.html#zecho",
+ "sndscm.html#zeroplus", "extsnd.html#zeropad", "sndscm.html#zerophase", "sndscm.html#zipsound",
+ "sndscm.html#zipper", "extsnd.html#zoomcolor", "extsnd.html#zoomfocusstyle"};
static const char *Tracking_cursors_xrefs[] = {
"play from the current cursor position with a tracking cursor: {pfc}",
@@ -1759,7 +1762,7 @@ static const char *Reverb_urls[] = {
#if HAVE_SCHEME
-static const char *snd_names[11580] = {
+static const char *snd_names[11622] = {
"*clm-array-print-length*", "ws.scm",
"*clm-channels*", "ws.scm",
"*clm-clipped*", "ws.scm",
@@ -1798,7 +1801,9 @@ static const char *snd_names[11580] = {
"*mock-symbol*", "mockery.scm",
"*mock-vector*", "mockery.scm",
"*repl*", "repl.scm",
+ "*rgb*", "rgb.scm",
"*s7*->list", "stuff.scm",
+ "*spectr*", "spectr.scm",
"*to-snd*", "ws.scm",
"->frequency", "ws.scm",
"->predicate", "stuff.scm",
@@ -3716,6 +3721,7 @@ static const char *snd_names[11580] = {
"bytevector-length", "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",
"c-pointer->string", "libc.scm",
@@ -3945,12 +3951,12 @@ static const char *snd_names[11580] = {
"define-library", "r7rs.scm",
"define-record-type", "r7rs.scm",
"define-selection-via-marks", "marks.scm",
+ "define-values", "r7rs.scm",
"definstrument", "ws.scm",
"delay-channel-mixes", "mix.scm",
"delayl", "prc95.scm",
"delete-from-out-to-in", "spokenword.scm",
"delete-mix", "mix.scm",
- "describe", "dlocsig.scm",
"describe-hook", "hooks.scm",
"describe-mark", "marks.scm",
"determinant", "poly.scm",
@@ -5143,6 +5149,7 @@ static const char *snd_names[11580] = {
"gsl_multifit_linear_lcorner2", "libgsl.scm",
"gsl_multifit_linear_lcurve", "libgsl.scm",
"gsl_multifit_linear_lreg", "libgsl.scm",
+ "gsl_multifit_linear_rcond", "libgsl.scm",
"gsl_multifit_linear_residuals", "libgsl.scm",
"gsl_multifit_linear_solve", "libgsl.scm",
"gsl_multifit_linear_stdform1", "libgsl.scm",
@@ -5173,6 +5180,21 @@ static const char *snd_names[11580] = {
"gsl_multifit_wlinear", "libgsl.scm",
"gsl_multifit_wlinear_svd", "libgsl.scm",
"gsl_multifit_wlinear_usvd", "libgsl.scm",
+ "gsl_multilarge_linear_L_decomp", "libgsl.scm",
+ "gsl_multilarge_linear_accumulate", "libgsl.scm",
+ "gsl_multilarge_linear_alloc", "libgsl.scm",
+ "gsl_multilarge_linear_free", "libgsl.scm",
+ "gsl_multilarge_linear_genform1", "libgsl.scm",
+ "gsl_multilarge_linear_genform2", "libgsl.scm",
+ "gsl_multilarge_linear_lcurve", "libgsl.scm",
+ "gsl_multilarge_linear_name", "libgsl.scm",
+ "gsl_multilarge_linear_rcond", "libgsl.scm",
+ "gsl_multilarge_linear_reset", "libgsl.scm",
+ "gsl_multilarge_linear_solve", "libgsl.scm",
+ "gsl_multilarge_linear_stdform1", "libgsl.scm",
+ "gsl_multilarge_linear_stdform2", "libgsl.scm",
+ "gsl_multilarge_linear_wstdform1", "libgsl.scm",
+ "gsl_multilarge_linear_wstdform2", "libgsl.scm",
"gsl_multimin_diff", "libgsl.scm",
"gsl_multimin_fminimizer_alloc", "libgsl.scm",
"gsl_multimin_fminimizer_free", "libgsl.scm",
@@ -6344,6 +6366,7 @@ static const char *snd_names[11580] = {
"legendre", "numerics.scm",
"legendre-polynomial", "numerics.scm",
"lesser-nighthawk", "animals.scm",
+ "let-temporarily", "stuff.scm",
"libc.scm", "libc.scm",
"libdl.scm", "libdl.scm",
"libgdbm.scm", "libgdbm.scm",
@@ -6374,8 +6397,6 @@ static const char *snd_names[11580] = {
"localeconv", "libc.scm",
"locate-zero", "examp.scm",
"lockf", "libc.scm",
- "log-all-of", "stuff.scm",
- "log-any-of", "stuff.scm",
"log-n-of", "stuff.scm",
"log-none-of", "stuff.scm",
"log10", "dsp.scm",
@@ -6489,9 +6510,9 @@ static const char *snd_names[11580] = {
"make-k2ssb", "generators.scm",
"make-k3sin", "generators.scm",
"make-krksin", "generators.scm",
- "make-list-1", "dlocsig.scm",
"make-literal-path", "dlocsig.scm",
"make-literal-polar-path", "dlocsig.scm",
+ "make-local-method", "mockery.scm",
"make-lowpass", "dsp.scm",
"make-method", "mockery.scm",
"make-moog", "moog.scm",
@@ -6877,6 +6898,7 @@ static const char *snd_names[11580] = {
"pread", "libc.scm",
"pretty-print", "write.scm",
"previous-phrase", "spokenword.scm",
+ "progv", "stuff.scm",
"protoent.p_aliases", "libc.scm",
"protoent.p_name", "libc.scm",
"protoent.p_proto", "libc.scm",
@@ -7093,6 +7115,7 @@ static const char *snd_names[11580] = {
"shift-channel-pitch", "dsp.scm",
"show-digits-of-pi-starting-at-digit", "numerics.scm",
"show-mins", "peak-phases.scm",
+ "show-profile", "profile.scm",
"showall", "peak-phases.scm",
"showdiff", "peak-phases.scm",
"showodd", "peak-phases.scm",
@@ -7444,6 +7467,7 @@ static const char *snd_names[11580] = {
"update-graphs", "examp.scm",
"utf8->string", "r7rs.scm",
"utime", "libc.scm",
+ "value->symbol", "stuff.scm",
"varied-thrush", "animals.scm",
"various-gull-cries-from-end-of-colony-5", "bird.scm",
"vector->float-vector", "poly.scm",
@@ -7554,7 +7578,7 @@ static const char *snd_names[11580] = {
static void autoload_info(s7_scheme *sc)
{
- s7_autoload_set_names(sc, snd_names, 5790);
+ s7_autoload_set_names(sc, snd_names, 5811);
}
#endif
diff --git a/snd.1 b/snd.1
index 1fd56c9..856a017 100644
--- a/snd.1
+++ b/snd.1
@@ -17,9 +17,9 @@ snd oboe.snd
loads oboe.snd into Snd.
.SH OPTIONS
-.IP \-l file
+.IP "\-l file"
Load extension language code in file.
-.IP \-p dir
+.IP "\-p dir"
Preload sound files found in directory dir.
.IP \-noinit
Don't load any initialization files (~/.snd et al).
diff --git a/snd.c b/snd.c
index 326bd66..b528d64 100644
--- a/snd.c
+++ b/snd.c
@@ -142,6 +142,7 @@ void snd_set_global_defaults(bool need_cleanup)
if (ss->Save_State_File) {free(ss->Save_State_File); ss->Save_State_File = NULL;}
if (ss->Eps_File) {free(ss->Eps_File); ss->Eps_File = NULL;}
if (ss->Listener_Prompt) {free(ss->Listener_Prompt); ss->Listener_Prompt = NULL;}
+ if (ss->Stdin_Prompt) {free(ss->Stdin_Prompt); ss->Stdin_Prompt = NULL;}
if (ss->Open_File_Dialog_Directory) {free(ss->Open_File_Dialog_Directory); ss->Open_File_Dialog_Directory = NULL;}
/* not sure about the next two... */
@@ -222,6 +223,7 @@ void snd_set_global_defaults(bool need_cleanup)
ss->With_Pointer_Focus = DEFAULT_WITH_POINTER_FOCUS;
ss->Play_Arrow_Size = DEFAULT_PLAY_ARROW_SIZE;
ss->Sync_Style = DEFAULT_SYNC_STYLE;
+ ss->Stdin_Prompt = mus_strdup(DEFAULT_STDIN_PROMPT);
ss->Listener_Prompt = mus_strdup(DEFAULT_LISTENER_PROMPT);
ss->listener_prompt_length = mus_strlen(ss->Listener_Prompt);
ss->Clipping = DEFAULT_CLIPPING;
@@ -346,6 +348,7 @@ void snd_set_global_defaults(bool need_cleanup)
ss->show_selection_transform_symbol = s7_define_variable(s7, "*" S_show_selection_transform "*", s7_make_boolean(s7, DEFAULT_SHOW_SELECTION_TRANSFORM));
ss->with_mix_tags_symbol = s7_define_variable(s7, "*" S_with_mix_tags "*", s7_make_boolean(s7, DEFAULT_WITH_MIX_TAGS));
ss->listener_prompt_symbol = s7_define_variable(s7, "*" S_listener_prompt "*", s7_make_string(s7, DEFAULT_LISTENER_PROMPT));
+ ss->stdin_prompt_symbol = s7_define_variable(s7, "*" S_stdin_prompt "*", s7_make_string(s7, DEFAULT_STDIN_PROMPT));
ss->enved_base_symbol = s7_define_variable(s7, "*" S_enved_base "*", s7_make_real(s7, DEFAULT_ENVED_BASE));
ss->enved_power_symbol = s7_define_variable(s7, "*" S_enved_power "*", s7_make_real(s7, DEFAULT_ENVED_POWER));
ss->enved_with_wave_symbol = s7_define_variable(s7, "*" S_enved_with_wave "*", s7_make_boolean(s7, DEFAULT_ENVED_WITH_WAVE));
diff --git a/snd.h b/snd.h
index fa92aec..99a0dec 100644
--- a/snd.h
+++ b/snd.h
@@ -53,11 +53,11 @@
#include "snd-strings.h"
-#define SND_DATE "30-Nov-15"
+#define SND_DATE "9-May-16"
#ifndef SND_VERSION
-#define SND_VERSION "16.1"
+#define SND_VERSION "16.5"
#endif
#define SND_MAJOR_VERSION "16"
-#define SND_MINOR_VERSION "1"
+#define SND_MINOR_VERSION "5"
#endif
diff --git a/snd.html b/snd.html
index da085e9..45ef1ff 100644
--- a/snd.html
+++ b/snd.html
@@ -643,7 +643,7 @@ automatically translated to a readable format:
IEEE text, Mus10, SAM 16-bit (modes 1 and 4), AVI, NIST shortpack, HCOM, Intel,
IBM, and Oki (Dialogic) ADPCM, G721, G723_24, G723_40, MIDI sample dump, Ogg, Speex,
- Flac, Midi, Mpeg, Shorten, Wavepack, tta (via external programs)
+ Flac, Midi, Mpeg, Shorten, Wavepack (via external programs)
</pre>
diff --git a/snd13.scm b/snd13.scm
index 2be528b..57d7832 100644
--- a/snd13.scm
+++ b/snd13.scm
@@ -993,85 +993,6 @@ saved file "sec2.snd".
In the old days, when notes took hours to compute, this was a big deal,
but not anymore.
</p>
-
-
-;;; and these are the regression tests
-
- (define (check-with-mix num dur total-dur amp opts calls old-date chkmx)
- (let ((ind (find-sound "test.snd")))
- (if (not (sound? ind)) (snd-display #__line__ ";with-mix (~A) init: no test.snd?" num))
- (if (and chkmx (fneq (maxamp ind) amp)) (snd-display #__line__ ";with-mix (~A) maxamp: ~A (~A)" num (maxamp ind) amp))
- (if (not (file-exists? "with-mix.snd")) (snd-display #__line__ ";with-mix (~A) output doesn't exist" num))
- (let ((mx (mus-sound-maxamp "with-mix.snd"))
- (date (mus-sound-write-date "with-mix.snd"))
- (duration (mus-sound-duration "with-mix.snd")))
- (if (fneq duration dur) (snd-display #__line__ ";with-mix (~A) dur: ~A ~A" num dur duration))
- (if (fneq total-dur (/ (framples ind) (srate ind)))
- (snd-display #__line__ ";with-mix (~A) total dur: ~A ~A" num total-dur (/ (framples ind) (srate ind))))
- (if (and old-date
- (> (- date old-date) 1)) ; these can be off by some amount in Linux
- (snd-display #__line__ ";with-mix (~A) rewrote output?: ~A ~A ~A" num (- date old-date)
- (strftime "%d-%b-%g %H:%M:%S" (localtime old-date))
- (strftime "%d-%b-%g %H:%M:%S" (localtime date))))
- (if (and chkmx (or (not mx) (fneq (cadr mx) amp))) (snd-display #__line__ ";with-mix sndf (~A) maxamp: ~A (~A)" num mx amp))
- (let ((header-str (mus-sound-comment "with-mix.snd")))
- (if (not (string? header-str)) (snd-display #__line__ ";with-mix (~A) comment unwritten?: ~A" num (mus-sound-comment "with-mix.snd")))
- (let ((header (eval-string header-str)))
- (if (not (list? header)) (snd-display #__line__ ";with-mix (~A) comment: ~A -> ~A" num header-str header))
- (if (or (not (string=? (car header) opts))
- (not (string=? (cadr header) calls)))
- (snd-display #__line__ ";with-mix (~A) header values: ~A" num header))))
- (close-sound ind)
- date)))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound () (with-mix () "with-mix" 0 (fm-violin 0 .1 440 .1)))
- (let ((old-date (check-with-mix 1 .1 .1 .1 "()" "((fm-violin 0 0.1 440 0.1))" #f #t)))
- (with-sound () (with-mix () "with-mix" 0 (fm-violin 0 .1 440 .1)))
- (check-with-mix 1 .1 .1 .1 "()" "((fm-violin 0 0.1 440 0.1))" old-date #t))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound () (fm-violin 0 .1 660 .1) (with-mix () "with-mix" .1 (fm-violin 0 .1 440 .1)))
- (let ((old-date (check-with-mix 2 .1 .2 .1 "()" "((fm-violin 0 0.1 440 0.1))" #f #t)))
- (with-sound () (fm-violin 0 .1 660 .1) (with-mix () "with-mix" .1 (fm-violin 0 .1 440 .1)))
- (check-with-mix 2 .1 .2 .1 "()" "((fm-violin 0 0.1 440 0.1))" old-date #t))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound () (fm-violin 0 .1 660 .1) (with-mix () "with-mix" .1 (fm-violin 0 .1 440 .1) (fm-violin .1 .1 660 .2)))
- (let ((old-date (check-with-mix 3 .2 .3 .2 "()" "((fm-violin 0 0.1 440 0.1) (fm-violin 0.1 0.1 660 0.2))" #f #t)))
- (with-sound () (fm-violin 0 .1 660 .1) (with-mix () "with-mix" .1 (fm-violin 0 .1 440 .1) (fm-violin .1 .1 660 .2)))
- (check-with-mix 3 .2 .3 .2 "()" "((fm-violin 0 0.1 440 0.1) (fm-violin 0.1 0.1 660 0.2))" old-date #t))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound ()
- (with-mix () "with-mix" 0
- (sound-let ((tmp () (fm-violin 0 1 440 .1))) (mus-file-mix *output* tmp 0))))
- (let ((old-date (check-with-mix 4 1 1 .1 "()" "((sound-let ((tmp () (fm-violin 0 1 440 0.1))) (mus-file-mix *output* tmp 0)))" #f #t)))
- (with-sound ()
- (with-mix () "with-mix" 0
- (sound-let ((tmp () (fm-violin 0 1 440 .1))) (mus-file-mix *output* tmp 0))))
- (check-with-mix 4 1 1 .1 "()" "((sound-let ((tmp () (fm-violin 0 1 440 0.1))) (mus-file-mix *output* tmp 0)))" old-date #t))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound (:channels 2) (fm-violin 0 .1 440 .1 :degree 0) (with-mix () "with-mix" 0 (fm-violin 0 .1 550 .3 :degree 90)))
- (let ((ind (find-sound "test.snd")))
- (if (or (fneq (maxamp ind 0) .1)
- (fneq (maxamp ind 1) .3))
- (snd-display #__line__ ";with-mix stereo: ~A" (maxamp ind #t)))
- (if (not (= (mus-sound-chans "with-mix.snd") 2)) (snd-display #__line__ ";with-mix stereo out: ~A" (mus-sound-chans "with-mix.snd"))))
- (let ((old-date (mus-sound-write-date "with-mix.snd")))
- (with-sound (:channels 2) (fm-violin 0 .1 440 .1 :degree 0) (with-mix () "with-mix" 0 (fm-violin 0 .1 550 .3 :degree 90)))
- (if (not (= (mus-sound-write-date "with-mix.snd") old-date))
- (snd-display #__line__ ";stereo with-mix dates: ~A ~A" old-date (mus-sound-write-date "with-mix.snd"))))
- (let ((ind (find-sound "test.snd")))
- (close-sound ind))
-
- (if (file-exists? "with-mix.snd") (delete-file "with-mix.snd"))
- (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .1) (with-mix () "with-mix" 0 (fm-violin 0 .1 550 .3)))
- (let ((old-date (check-with-mix 6 .1 1.1 .398 "()" "((fm-violin 0 0.1 550 0.3))" #f #f)))
- (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .1) (with-mix () "with-mix" 0 (fm-violin 0 .1 550 .3)))
- (check-with-mix 6 .1 1.1 .398 "()" "((fm-violin 0 0.1 550 0.3))" old-date #f))
-
|#
;;; --------------------------------------------------------------------------------
diff --git a/sndclm.html b/sndclm.html
index f236cfa..e1865a9 100644
--- a/sndclm.html
+++ b/sndclm.html
@@ -425,9 +425,9 @@ do everything by hand:
</p>
<pre class="indented">
-(let ((sound (<a class=quiet href="extsnd.html#newsound">new-sound</a> "test.snd" :size 22050))
- (increment (/ (* 440.0 2.0 pi) 22050.0))
+(let ((increment (/ (* 440.0 2.0 pi) 22050.0))
(current-phase 0.0))
+ (<a class=quiet href="extsnd.html#newsound">new-sound</a> "test.snd" :size 22050)
(<a class=quiet href="extsnd.html#mapchannel">map-channel</a> (lambda (y)
(let ((val (* .1 (sin current-phase))))
(set! current-phase (+ current-phase increment))
@@ -1089,27 +1089,27 @@ magnitude spectrum, but with the phases chosen to minimize the peak amplitude.
0.504202 0.817304 -0.010580 0.584809 1.234045 0.840674 1.222939 0.685333 1.651765
0.299738 1.890117 0.740013 0.044764 1.547307 0.169892 1.452239 0.352220 0.122254
1.524772 1.183705 0.507801 1.419950 0.851259 0.008092 1.483245 0.608598 0.212267
- 0.545906 0.255277 1.784889 0.270552 1.164997 -0.083981 0.200818 1.204088)))
- (let ((freq 10.0)
- (dur 5.0)
- (n 98))
- (with-sound ()
- (let ((samps (floor (* dur 44100)))
- (1/n (/ 1.0 n))
- (freqs (make-float-vector n))
- (phases (make-float-vector n (* pi 0.5))))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((off (/ (* pi (- 0.5 (98-phases i))) (* dur 44100)))
- (h (hz->radians (* freq (+ i 1)))))
- (set! (freqs i) (+ h off))))
- (let ((ob (<em class=red>make-oscil-bank</em> freqs phases)))
- (do ((i 0 (+ i 1))) ; get rid of the distracting initial click
- ((= i 1000))
- (<em class=red>oscil-bank</em> ob))
- (do ((k 0 (+ k 1)))
- ((= k samps))
- (outa k (* 1/n (<em class=red>oscil-bank</em> ob)))))))))
+ 0.545906 0.255277 1.784889 0.270552 1.164997 -0.083981 0.200818 1.204088))
+ (freq 10.0)
+ (dur 5.0)
+ (n 98))
+ (with-sound ()
+ (let ((samps (floor (* dur 44100)))
+ (1/n (/ 1.0 n))
+ (freqs (make-float-vector n))
+ (phases (make-float-vector n (* pi 0.5))))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((off (/ (* pi (- 0.5 (98-phases i))) dur 44100))
+ (h (hz->radians (* freq (+ i 1)))))
+ (set! (freqs i) (+ h off))))
+ (let ((ob (<em class=red>make-oscil-bank</em> freqs phases)))
+ (do ((i 0 (+ i 1))) ; get rid of the distracting initial click
+ ((= i 1000))
+ (<em class=red>oscil-bank</em> ob))
+ (do ((k 0 (+ k 1)))
+ ((= k samps))
+ (outa k (* 1/n (<em class=red>oscil-bank</em> ob))))))))
</pre>
@@ -1663,7 +1663,7 @@ table-lookup might be defined:
(<a class=quiet href="#hztoradians">hz->radians</a> frequency)
(* fm-input
(/ (length wave)
- (* 2 pi)))))
+ 2 pi))))
result)
</pre>
@@ -2187,13 +2187,13 @@ in phase and amplitude at run-time by setting a float-vector value.
<pre class="indented">
(<a class=quiet href="sndscm.html#wsdoc">with-sound</a> (:clipped #f :statistics #t :play #t :scaled-to .5)
- (let ((gen (<em class=red>make-polywave</em> 200 (let ((harms (make-float-vector (* 5 2) 0.0))) ; 5 harmonics, 2 numbers for each
- (do ((k 1 (+ k 3))
- (i 0 (+ i 2)))
- ((= i (* 5 2)))
- (set! (harms i) k) ; harmonic number (k*freq)
- (set! (harms (+ i 1)) (/ 1.0 (sqrt k)))) ; harmonic amplitude
- harms)))
+ (let ((gen (<em class=red>make-polywave</em> 200
+ (do ((harms (make-float-vector (* 5 2) 0.0)) ; 5 harmonics, 2 numbers for each
+ (k 1 (+ k 3))
+ (i 0 (+ i 2)))
+ ((= i 10) harms)
+ (set! (harms i) k) ; harmonic number (k*freq)
+ (set! (harms (+ i 1)) (/ 1.0 (sqrt k)))))) ; harmonic amplitude
(ampf (<a class=quiet href="#make-env">make-env</a> '(0 0 1 1 10 1 11 0) :duration 1.0 :scaler .5)))
(do ((i 0 (+ i 1)))
((= i 44100))
@@ -2247,12 +2247,12 @@ Here is a somewhat low-level example:
<pre class="indented">
(define* (make-band-limited-triangle-wave (frequency *clm-default-frequency*) (order 1))
- (let ((freqs ()))
- (do ((i 1 (+ i 1))
- (j 1 (+ j 2)))
- ((> i order))
- (set! freqs (cons (/ 1.0 (* j j)) (cons j freqs))))
- (<em class=red>make-polywave</em> frequency :partials (reverse freqs))))
+ (do ((freqs ())
+ (i 1 (+ i 1))
+ (j 1 (+ j 2)))
+ ((> i order)
+ (<em class=red>make-polywave</em> frequency :partials (reverse freqs)))
+ (set! freqs (cons (/ 1.0 j j) (cons j freqs)))))
(define* (band-limited-triangle-wave gen (fm 0.0))
(<em class=red>polywave</em> gen fm))
@@ -2263,14 +2263,13 @@ Here is a somewhat low-level example:
<pre class="indented">
(<a class=quiet href="sndscm.html#definstrument">definstrument</a> (bl-saw start dur frequency order)
- (let ((norm (if (= order 1) 1.0 ; these peak amps were determined empirically
- (if (= order 2) 1.3 ; actual limit is supposed to be pi/2 (G&R 1.441)
- (if (< order 9) 1.7 ; but Gibbs phenomenon pushes it to 1.851
- 1.852))))
+ (let ((norm (cond ((assoc order '((1 . 1.0) (2 . 1.3)) =) => cdr) ; these peak amps were determined empirically
+ ((< order 9) 1.7) ; actual limit is supposed to be pi/2 (G&R 1.441)
+ (else 1.852))) ; but Gibbs phenomenon pushes it to 1.851
(freqs ()))
(do ((i 1 (+ i 1)))
((> i order))
- (set! freqs (cons (/ 1.0 (* norm i)) (cons i freqs))))
+ (set! freqs (cons (/ 1.0 norm i) (cons i freqs))))
(let* ((gen (<em class=red>make-polywave</em> frequency :partials (reverse freqs) :type <em class=red>mus-chebyshev-second-kind</em>))
(beg (<a class=quiet href="#secondstosamples">seconds->samples</a> start))
(end (+ beg (<a class=quiet href="#secondstosamples">seconds->samples</a> dur))))
@@ -2403,10 +2402,10 @@ changing spectra is to interpolate between two or more sets of coefficients.
((= i samps))
(let ((harm (<a class=quiet href="#env">env</a> harmf)))
(set! (coeffs 3) harm)
- (set! (coeffs 4) (- .25 harm))
- (<a class=quiet href="#outa">outa</a> i (* (<a class=quiet href="#env">env</a> ampf)
+ (set! (coeffs 4) (- .25 harm)))
+ (<a class=quiet href="#outa">outa</a> i (* (<a class=quiet href="#env">env</a> ampf)
(<em class=red>mus-chebyshev-t-sum</em> x coeffs)))
- (set! x (+ x incr))))))
+ (set! x (+ x incr)))))
</pre>
<p>
@@ -2532,8 +2531,8 @@ we get sum and difference tones, much as in complex FM:
(do ((i 0 (+ i 1)))
((= i 44100))
(<a class=quiet href="#outa">outa</a> i (<em class=red>polynomial</em> pcoeffs
- (+ (* 0.5 (<a class=quiet href="#oscil">oscil</a> gen1))
- (* 0.5 (<a class=quiet href="#oscil">oscil</a> gen2))))))))
+ (* 0.5 (+ (<a class=quiet href="#oscil">oscil</a> gen1))
+ (<a class=quiet href="#oscil">oscil</a> gen2)))))))
</pre>
<hr>
<div class="center"><img src="pix/t5sum.png" alt="t5"></div>
@@ -3040,15 +3039,14 @@ we can truncate its spectrum at the desired number of harmonics:
(previous-results n))
(let* ((coeffs (make-float-vector (* 2 n) 0.0))
(size (expt 2 12))
- (rl (make-float-vector size 0.0))
- (im (make-float-vector size 0.0))
- (incr (/ (* 2 pi) size))
- (index (or B (max 1 (floor (/ n 2))))))
- (do ((i 0 (+ i 1))
+ (rl (make-float-vector size 0.0)))
+ (do ((incr (/ (* 2 pi) size))
+ (index (or B (max 1 (floor (/ n 2)))))
+ (i 0 (+ i 1))
(x 0.0 (+ x incr)))
- ((= i size))
+ ((= i size))
(set! (rl i) (<em class=red>tanh</em> (* index (<em class=red>sin</em> x))))) ; make our desired square wave
- (<a class=quiet href="#spectrum">spectrum</a> rl im #f 2) ; get its spectrum
+ (<a class=quiet href="#spectrum">spectrum</a> rl (make-float-vector size 0.0) #f 2) ; get its spectrum
(do ((i 0 (+ i 1))
(j 0 (+ j 2)))
((= i n))
@@ -3138,7 +3136,7 @@ The derivative is B * cos(x) / (cosh^2(B * sin(x))):
(let* ((B (env Benv))
(num (cos (mus-phase osc)))
(den (cosh (* B (oscil osc)))))
- (outa i (/ num (* den den)))))))
+ (outa i (/ num den den))))))
</pre>
<img class="indented" src="pix/tanhsinderiv.png" alt="tanh(sin) as pulse train">
@@ -3437,7 +3435,7 @@ large component for the carrier, and all the others are very small.
(do ((i 1 (+ i 1)))
((> i n))
(set! harms (cons (* i modfreq) harms))
- (set! amps (cons (/ baseindex (* i n)) amps)))
+ (set! amps (cons (/ baseindex i n) amps)))
(<a class=quiet href="sndscm.html#fmparallelcomponent">fm-parallel-component</a> freq-we-want wc
(reverse harms) (reverse amps) () () #f)))
</pre>
@@ -4463,7 +4461,7 @@ And the fourth used the ssb-am-bank function in dsp.scm rewritten here for with-
(do ((i 1 (+ i 1)))
((> i pairs))
(let ((aff (* i old-freq))
- (bwf (* bw (+ 1.0 (/ i (* 2 pairs))))))
+ (bwf (* bw (+ 1.0 (/ i 2 pairs)))))
(set! (ssbs (- i 1)) (<em class=red>make-ssb-am</em> (* i factor old-freq)))
(set! (bands (- i 1)) (<a class=quiet href="sndscm.html#makebandpass">make-bandpass</a> (<a class=quiet href="#hztoradians">hz->radians</a> (- aff bwf)) ; bandpass is in dsp.scm
(<a class=quiet href="#hztoradians">hz->radians</a> (+ aff bwf))
@@ -4938,14 +4936,14 @@ using the "envelope" argument:
<pre class="indented">
(define (gaussian-envelope s)
- (let ((e ())
- (den (* 2.0 s s)))
- (do ((i 0 (+ i 1))
- (x -1.0 (+ x .1))
- (y -4.0 (+ y .4)))
- ((= i 21)
- (reverse e))
- (set! e (cons (exp (- (/ (* y y) den))) (cons x e))))))
+ (do ((e ())
+ (den (* 2.0 s s))
+ (i 0 (+ i 1))
+ (x -1.0 (+ x .1))
+ (y -4.0 (+ y .4)))
+ ((= i 21)
+ (reverse e))
+ (set! e (cons (exp (- (/ (* y y) den))) (cons x e)))))
(<em class=red>make-rand</em> :envelope (gaussian-envelope 1.0))
</pre>
@@ -4959,7 +4957,7 @@ but 0.5 should happen three times as often as either of the others:
(let ((vals (float-vector 0.0 0.5 0.5 0.5 1.0)))
(do ((i 0 (+ i 1)))
((= i 10))
- (<a class=quiet>format</a> #t ";~A " (vals (floor (random 5.0))))))
+ (<a class=quiet>format</a> () ";~A " (vals (random 5)))))
</pre>
<p>These "distributions" refer to the values returned by the random number
@@ -5746,9 +5744,9 @@ The Hilbert transform can be implemented with an fir-filter:
(let ((k (+ i len))
(denom (* pi i))
(num (- 1.0 (cos (* pi i)))))
- (if (or (= num 0.0) (= i 0))
- (set! (arr k) 0.0)
- (set! (arr k) (* (/ num denom)
+ (set! (arr k) (if (or (= num 0.0) (= i 0))
+ 0.0
+ (* (/ num denom)
(+ .54 (* .46 (cos (/ (* i pi) len)))))))))
(<em class=red>make-fir-filter</em> arrlen arr)))
@@ -6064,7 +6062,7 @@ lambda: ( -- )
7.0 * size / (1.0 - scaler) samples, so to get a decay of feedback-dur seconds,
</p>
<pre class="indented">
- (make-comb :size size :scaler (- 1.0 (/ (* 7.0 size) (* feedback-dur *clm-srate*))))
+ (make-comb :size size :scaler (- 1.0 (/ (* 7.0 size) feedback-dur *clm-srate*)))
</pre>
<p>The peak gain is 1.0 / (1.0 - (abs scaler)). The peaks (or valleys in notch's case) are evenly spaced
@@ -6361,8 +6359,7 @@ Code of the form:
</p>
<pre class="indented">
-(let ((ab (make-all-pass-bank (vector a1 a2))))
- (all-pass-bank ab input))
+(all-pass-bank (make-all-pass-bank (vector a1 a2)) input)
</pre>
@@ -7304,12 +7301,7 @@ lambda: ( -- )
</pre>
<p>These are arrays (float-vectors) containing the spectral data the phase-vocoder uses to
-reconstruct the sound. See clm23.scm for examples,
-in particular pvoc-e that
-specifies all of the functions with their default values (that is, it explicitly passes
-in functions that do what the phase-vocoder would have done without any function arguments).
-pvoc.scm implements the phase-vocoder directly in Scheme (rather than going through the CLM
-generator).
+reconstruct the sound.
In the next example we use all these special functions to resynthesize down an octave:
</p>
@@ -7587,7 +7579,7 @@ continue-frample->file and continue-sample->file reopen an existing file t
mus-output? returns #t is its argument is some sort of file writing generator, and mus-input? returns #t if its
argument is a file reader.
In make-file->sample and make-file->frample, the buffer-size defaults to *clm-file-buffer-size*.
-There are many examples of these functions in snd-test.scm, clm-ins.scm, and clm23.scm.
+There are many examples of these functions in snd-test.scm, and clm-ins.scm.
Here is one that uses file->sample to mix in a sound file (there are a zillion other ways to do this):
</p>
@@ -7980,9 +7972,8 @@ To have full output to both channels,</p>
(do ((i beg (+ i 1)))
((= i end))
(let ((rdval (* (<a class=quiet href="#readin">readin</a> rdA) (<a class=quiet href="#env">env</a> amp-env)))
- (degval (<a class=quiet href="#env">env</a> deg-env))
- (distval (<a class=quiet href="#env">env</a> dist-env)))
- (set! dist-scaler (/ 1.0 distval))
+ (degval (<a class=quiet href="#env">env</a> deg-env)))
+ (set! dist-scaler (/ (<a class=quiet href="#env">env</a> dist-env)))
(locsig-set! loc 0 (* (- 1.0 degval) dist-scaler))
(if (> (channels <a class=quiet>*output*</a>) 1)
(locsig-set! loc 1 (* degval dist-scaler)))
@@ -9118,7 +9109,7 @@ relatively conservative function to find the highest safe "r" given the current
<pre class="indented">
(define (safe-r-max freq srate) ; the safe-rxycos generator in generators.scm has this built-in
- (expt .001 (/ 1.0 (floor (/ srate (* 3 freq))))))
+ (expt .001 (/ 1.0 (floor (/ srate 3 freq)))))
</pre>
@@ -9346,7 +9337,7 @@ The (very) safe maximum "r" is:
<pre class="indented">
(define (safe-rk!-max freq srate)
- (let ((topk (floor (/ srate (* 3 freq)))))
+ (let ((topk (floor (/ srate 3 freq))))
(expt (* .001 (factorial topk)) (/ 1.0 topk))))
;; factorial is in numerics.scm
</pre>
@@ -9480,7 +9471,7 @@ safe maximum r is:
<pre class="indented">
(define (safe-rkodd-max-r freq srate)
- (let* ((topk (floor (/ srate (* 3 freq))))
+ (let* ((topk (floor (/ srate 3 freq)))
(k2-1 (- (* 2 topk) 1)))
(expt (* .001 k2-1) (/ 1.0 k2-1))))
</pre>
@@ -9553,7 +9544,7 @@ given assumes that r is less than 1.0, and in that case, the safe maximum r is g
<pre class="indented">
(define (safe-krk-max-r freq srate)
- (let ((topk (floor (/ srate (* 3 freq)))))
+ (let ((topk (floor (/ srate 3 freq))))
(expt (/ .001 topk) (/ 1.0 topk))))
</pre>
@@ -9684,7 +9675,7 @@ via mus-data.
(set! last-pitch pitch)
(set! pitch (<em class=red>moving-pitch</em> scn))
(if (not (= last-pitch pitch))
- (format #t "~A: ~A~%" (* 1.0 (/ i cur-srate)) pitch))))
+ (format () "~A: ~A~%" (* 1.0 (/ i cur-srate)) pitch))))
(set! *clm-srate* old-srate))
</pre>
<div class="separator"></div>
@@ -10266,21 +10257,19 @@ only difference is that mus-fft includes the fft length as an argument, whereas
(let* ((len (mus-sound-framples "oboe.snd"))
(fsize (expt 2 (ceiling (log len 2))))
(rdata (make-float-vector fsize 0.0))
- (idata (make-float-vector fsize 0.0))
- (cutoff (round (/ fsize 10)))
- (fsize2 (/ fsize 2)))
+ (idata (make-float-vector fsize 0.0)))
(file->array "oboe.snd" 0 0 len rdata)
-
(<em class=red>mus-fft</em> rdata idata fsize 1)
- (do ((i cutoff (+ i 1))
- (j (- fsize 1) (- j 1)))
- ((= i fsize2))
- (set! (rdata i) 0.0)
- (set! (idata i) 0.0)
- (set! (rdata j) 0.0)
- (set! (idata j) 0.0))
+ (let ((fsize2 (/ fsize 2))
+ (cutoff (round (/ fsize 10))))
+ (do ((i cutoff (+ i 1))
+ (j (- fsize 1) (- j 1)))
+ ((= i fsize2))
+ (set! (rdata i) 0.0)
+ (set! (idata i) 0.0)
+ (set! (rdata j) 0.0)
+ (set! (idata j) 0.0)))
(<em class=red>mus-fft</em> rdata idata fsize -1)
-
(array->file "test.snd"
(float-vector-scale! rdata (/ 1.0 fsize))
len
@@ -10858,14 +10847,6 @@ test 23 in snd-test.
<td></td>
</tr>
-<tr><td class="br">test ins</td>
- <td class="br">CLM regression tests — see clm-test.lisp</td>
- <td class="br">ug(1,2,3,4).ins</td>
- <td class="br"><a href="clm23.scm">clm23.scm</a></td>
- <td></td>
- <td></td>
- </tr>
-
<tr><td class="br">fm-violin</td>
<td class="br">fm violin (fmviolin.clm, popi.clm)</td>
<td class="br">v.ins</td>
diff --git a/snddiff.scm b/snddiff.scm
index 779c87d..f9411b4 100644
--- a/snddiff.scm
+++ b/snddiff.scm
@@ -54,7 +54,8 @@
(if (not (= (v1 i) 0.0))
(set! pos i)))
- (if (>= pos 0) ; if still -1, must be all zero
+ (if (< pos 0) ; if still -1, must be all zero
+ impulse-response
(let ((scl (/ (v1 pos) (v0 0)))
(size (float-vector-size v1)))
(float-vector-subtract!
@@ -63,8 +64,7 @@
(if (< (float-vector-size v1) size)
(unconvolve-1 v0 v1 (cons (list scl pos) impulse-response))
- impulse-response))
- impulse-response)))
+ impulse-response)))))
(define (unconvolve v0 v1)
(and (float-vector? v0)
@@ -74,8 +74,8 @@
(do ((i 0 (+ i 1)))
((or (> trim -1)
(= i len)))
- (if (or (not (= (v0 i) 0.0))
- (not (= (v1 i) 0.0)))
+ (if (not (and (= (v0 i) 0.0)
+ (= (v1 i) 0.0)))
(set! trim i)))
(if (> trim 0)
(begin
diff --git a/sndlib-ws.scm b/sndlib-ws.scm
index e49c3a2..262c340 100644
--- a/sndlib-ws.scm
+++ b/sndlib-ws.scm
@@ -154,7 +154,7 @@
(catch 'mus-error
thunk
(lambda args
- (format #t ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args))
+ (format () ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args))
(set! flush-reverb #t)))
(if (and reverb
@@ -180,7 +180,7 @@
(if statistics
(begin
(set! cycles (- (get-internal-real-time) start))
- (format #t "~%;~A:~% maxamp~A:~{ ~,4F~}~%~A compute time: ~,3F~%"
+ (format () "~%;~A:~% maxamp~A:~{ ~,4F~}~%~A compute time: ~,3F~%"
(if output-to-file
(if (or scaled-to scaled-by)
(substring output-1 0 (- (length output-1) 5))
diff --git a/sndlib2xen.c b/sndlib2xen.c
index 1684b01..babdc34 100644
--- a/sndlib2xen.c
+++ b/sndlib2xen.c
@@ -346,7 +346,6 @@ static Xen g_mus_sound_write_date(Xen filename)
return(result);
}
-
static Xen g_mus_header_writable(Xen head, Xen data)
{
#define H_mus_header_writable "(" S_mus_header_writable " header-type sample-type) returns " PROC_TRUE " if the header can handle the sample type"
@@ -697,7 +696,7 @@ static Xen g_mus_sound_preload(Xen file)
mus_float_t **bufs;
mus_long_t framples;
chans = mus_sound_chans(str);
- framples = mus_sound_framples(str) + 8; /* + 8 for readers than wander off the end */
+ framples = mus_sound_framples(str) + 8; /* + 8 for readers that wander off the end */
bufs = (mus_float_t **)malloc(chans * sizeof(mus_float_t *));
for (i = 0; i < chans; i++)
bufs[i] = (mus_float_t *)malloc(framples * sizeof(mus_float_t));
@@ -1088,8 +1087,8 @@ Xen_wrap_1_arg(g_mus_set_sound_path_w, g_mus_set_sound_path)
void mus_sndlib_xen_initialize(void)
{
#if HAVE_SCHEME
- s7_pointer pl_is, pl_isi, pl_si, pl_ss, pl_ps, pl_psp, pl_i, pl_bii, pl_p, pl_rs, pl_bi, pl_bib, pl_b;
- s7_pointer pl_l, pl_isfiii, pl_fsiiif, pl_bs, pl_ts;
+ s7_pointer pl_is, pl_isi, pl_si, pl_ss, pl_ps, pl_psp, pl_i, pl_bii, pl_p, pl_rs, pl_bi, pl_bib, pl_b, pl_ls;
+ s7_pointer pl_l, pl_isfiii, pl_fsiiif, pl_bs, pl_ts, pl_sh, pl_bhi;
#endif
mus_sound_initialize();
@@ -1140,8 +1139,16 @@ void mus_sndlib_xen_initialize(void)
Xen_define_constant(S_mus_lfloat_unscaled, MUS_LFLOAT_UNSCALED, "unscaled little-endian float sample type id");
#if HAVE_SCHEME
+ s7_eval_c_string(s7,
+ "(define (mus_header_t? form argn) \
+ (let ((h (list-ref form argn))) \
+ (if (not (memq h '(mus-next mus-aifc mus-riff mus-nist mus-raw mus-ircam mus-aiff mus-bicsf mus-voc mus-svx mus-soundfont mus-rf64 mus-caff))) \
+ (if (not (integer? h)) \
+ 'integer? \
+ (if (not (< 0 h 71)) \
+ \"an integer between 1 and 70\")))))");
{
- s7_pointer s, i, p, b, r, f, t, l;
+ s7_pointer s, i, p, b, r, f, t, l, h;
s = s7_make_symbol(s7, "string?");
i = s7_make_symbol(s7, "integer?");
p = s7_make_symbol(s7, "pair?");
@@ -1149,16 +1156,20 @@ void mus_sndlib_xen_initialize(void)
b = s7_make_symbol(s7, "boolean?");
r = s7_make_symbol(s7, "real?");
f = s7_make_symbol(s7, "float-vector?");
+ h = s7_make_symbol(s7, "mus_header_t?");
t = s7_t(s7);
pl_is = s7_make_signature(s7, 2, i, s);
pl_isi = s7_make_signature(s7, 3, i, s, i);
pl_si = s7_make_signature(s7, 2, s, i);
+ pl_sh = s7_make_signature(s7, 2, s, h);
pl_ss = s7_make_signature(s7, 2, s, s);
pl_ts = s7_make_signature(s7, 2, t, s);
+ pl_ls = s7_make_signature(s7, 2, l, s);
pl_ps = s7_make_signature(s7, 2, p, s);
pl_psp = s7_make_signature(s7, 3, p, s, p);
pl_i = s7_make_circular_signature(s7, 0, 1, i);
pl_bii = s7_make_signature(s7, 3, b, i, i);
+ pl_bhi = s7_make_signature(s7, 3, b, h, i);
pl_p = s7_make_circular_signature(s7, 0, 1, p);
pl_l = s7_make_circular_signature(s7, 0, 1, l);
pl_rs = s7_make_signature(s7, 2, r, s);
@@ -1190,15 +1201,15 @@ void mus_sndlib_xen_initialize(void)
Xen_define_typed_procedure(S_mus_sound_datum_size, g_mus_sound_datum_size_w, 1, 0, 0, H_mus_sound_datum_size, pl_is);
Xen_define_typed_procedure(S_mus_sound_length, g_mus_sound_length_w, 1, 0, 0, H_mus_sound_length, pl_is);
Xen_define_typed_procedure(S_mus_sound_type_specifier, g_mus_sound_type_specifier_w, 1, 0, 0, H_mus_sound_type_specifier, pl_is);
- Xen_define_typed_procedure(S_mus_header_type_name, g_mus_header_type_name_w, 1, 0, 0, H_mus_header_type_name, pl_si);
- Xen_define_typed_procedure(S_mus_header_type_to_string,g_mus_header_type_to_string_w, 1, 0, 0, H_mus_header_type_to_string, pl_si);
- Xen_define_typed_procedure(S_mus_header_writable, g_mus_header_writable_w, 2, 0, 0, H_mus_header_writable, pl_bii);
+ Xen_define_typed_procedure(S_mus_header_type_name, g_mus_header_type_name_w, 1, 0, 0, H_mus_header_type_name, pl_sh);
+ Xen_define_typed_procedure(S_mus_header_type_to_string,g_mus_header_type_to_string_w, 1, 0, 0, H_mus_header_type_to_string, pl_sh);
+ Xen_define_typed_procedure(S_mus_header_writable, g_mus_header_writable_w, 2, 0, 0, H_mus_header_writable, pl_bhi);
Xen_define_typed_procedure(S_mus_sample_type_name, g_mus_sample_type_name_w, 1, 0, 0, H_mus_sample_type_name, pl_si);
Xen_define_typed_procedure(S_mus_sample_type_to_string,g_mus_sample_type_to_string_w, 1, 0, 0, H_mus_sample_type_to_string, pl_si);
Xen_define_typed_procedure(S_mus_sound_comment, g_mus_sound_comment_w, 1, 0, 0, H_mus_sound_comment, pl_ts);
Xen_define_typed_procedure(S_mus_sound_write_date, g_mus_sound_write_date_w, 1, 0, 0, H_mus_sound_write_date, pl_is);
Xen_define_typed_procedure(S_mus_bytes_per_sample, g_mus_bytes_per_sample_w, 1, 0, 0, H_mus_bytes_per_sample, pl_i);
- Xen_define_typed_procedure(S_mus_sound_loop_info, g_mus_sound_loop_info_w, 1, 0, 0, H_mus_sound_loop_info, pl_ps);
+ Xen_define_typed_procedure(S_mus_sound_loop_info, g_mus_sound_loop_info_w, 1, 0, 0, H_mus_sound_loop_info, pl_ls);
Xen_define_typed_procedure(S_mus_sound_mark_info, g_mus_sound_mark_info_w, 1, 0, 0, H_mus_sound_mark_info, pl_ps);
Xen_define_typed_procedure(S_mus_sound_maxamp_exists, g_mus_sound_maxamp_exists_w, 1, 0, 0, H_mus_sound_maxamp_exists, pl_bs);
Xen_define_typed_procedure(S_mus_sound_forget, g_mus_sound_forget_w, 1, 0, 0, H_mus_sound_forget, pl_is);
diff --git a/sndscm.html b/sndscm.html
index 6cff621..0160245 100644
--- a/sndscm.html
+++ b/sndscm.html
@@ -208,7 +208,7 @@ For help with Forth and Snd/CLM, see the Forth documentation section "Snd, CLM,
<tr><td><a href="#cleandoc">clean</a></td>
<td>noise reduction</td></tr>
-<tr><td><a href="#clminsdoc">clm-ins, clm23, jcvoi</a></td>
+<tr><td><a href="#clminsdoc">clm-ins, jcvoi</a></td>
<td>various CLM instruments</td></tr>
<tr><td><a href="#dlocsigdoc">dlocsig</a></td>
@@ -417,8 +417,7 @@ elliptic filters depend on GSL, so you'll also need GSL (Snd's configure script
</p>
<pre class="indented">
-(let ((flt (make-elliptic-lowpass 8 .1))) ; 8th order elliptic with cutoff at .1 * srate
- (<a class=quiet href="extsnd.html#mapchannel">map-channel</a> flt)) ; flt is a clm filter generator
+(<a class=quiet href="extsnd.html#mapchannel">map-channel</a> (make-elliptic-lowpass 8 .1)) ; 8th order elliptic with cutoff at .1 * srate
</pre>
<p>
@@ -591,10 +590,10 @@ in the duration.
(let* ((start (<a class=quiet href="sndclm.html#secondstosamples">seconds->samples</a> beg))
(dur 0.08) ; filled in from the selection duration
(stop (+ start (<a class=quiet href="sndclm.html#secondstosamples">seconds->samples</a> dur)))
- (ampf (<a class=quiet href="sndclm.html#make-env">make-env</a> ' ; left blank for the moment
+ (ampf (<a class=quiet href="sndclm.html#make-env">make-env</a> ; left blank for the moment
:duration dur :scaler amp))
(gen1 (<a class=quiet href="sndclm.html#make-oscil">make-oscil</a>))
- (frqf (<a class=quiet href="sndclm.html#make-env">make-env</a> ' ; ditto
+ (frqf (<a class=quiet href="sndclm.html#make-env">make-env</a> ; ditto
:duration dur :scaler (<a class=quiet href="sndclm.html#hztoradians">hz->radians</a> 1.0))))
(do ((i start (+ i 1)))
((= i stop))
@@ -915,7 +914,7 @@ points, but these would be hard to find once the DC was removed. A quick check:
</p>
<pre class="indented">
-(count-matches (lambda (y) (or (> y .9999) (< y -.9999))))
+(count-matches (lambda (y) (not (>= 0.9999 y -0.9999))))
</pre>
<p>
@@ -927,8 +926,8 @@ those are just one sample clicks that can easily be smoothed over", so
(define* (count-clips snd chn)
(let ((y0 0.0))
(count-matches
- (lambda (y) (let ((val (and (or (> y0 .9999) (< y0 -.9999))
- (or (> y .9999) (< y -.9999)))))
+ (lambda (y) (let ((val (not (or (>= 0.9999 y0 -0.9999)
+ (>= 0.9999 y -0.9999)))))
(set! y0 y)
val))
0 snd chn)))
@@ -952,7 +951,7 @@ time for perfection...):
(samp 0))
(<a class=quiet href="extsnd.html#scanchannel">scan-channel</a>
(lambda (y)
- (if (or (> y .9999) (< y -.9999))
+ (if (not (<= -0.9999 y 0.9999))
(if in-clip
(set! clip-end samp)
(begin
@@ -1002,55 +1001,51 @@ end points. (This is also "just-good-enough" software).
</p>
<pre class="indented">
-(if (not (defined? 'pi)) (define pi 3.141592653589793))
-
(define (fix-clip clip-beg-1 clip-end-1)
- (if (> clip-end-1 clip-beg-1)
- (let* ((dur (+ 1 (- clip-end-1 clip-beg-1)))
- (samps (channel->float-vector (- clip-beg-1 4) (+ dur 9)))
- (clip-beg 3)
- (clip-end (+ dur 4)))
- (let ((samp0 (samps clip-beg))
- (samp1 (samps clip-end)))
- (if (or (> samp0 .99) (< samp0 -.99))
- (begin
- ;; weird! some of the clipped passages have "knees"
- ;; this looks nuts, but no time to scratch my head
- (set! clip-beg (- clip-beg 1))
- (set! samp0 (samps clip-beg))
- (if (or (> samp0 .99) (< samp0 -.99))
- (begin
- (set! clip-beg (- clip-beg 1))
- (set! samp0 (samps clip-beg))))))
- (if (or (> samp1 .99) (< samp1 -.99))
- (begin
- (set! clip-end (+ 1 clip-end))
- (set! samp1 (samps clip-end))
- (if (or (> samp1 .99) (< samp1 -.99))
- (begin
- (set! clip-end (+ 1 clip-end))
- (set! samp1 (samps clip-end))))))
- ;; now we have semi-plausible bounds
- ;; make sine dependent on rate of change of current
- (let* ((samp00 (samps (- clip-beg 1)))
- (samp11 (samps (+ 1 clip-end)))
- (dist (- clip-end clip-beg))
- (incr (/ pi dist))
- (amp (* .125 (+ (abs (- samp0 samp00)) (abs (- samp1 samp11))) dist)))
- (if (> samp0 0.0)
- ;; clipped at 1.0
- (do ((i (+ 1 clip-beg) (+ i 1))
- (angle incr (+ angle incr)))
- ((= i clip-end))
- (set! (samps i) (+ 1.0 (* amp (sin angle)))))
- ;; clipped at -1.0
- (do ((i (+ 1 clip-beg) (+ i 1))
- (angle incr (+ angle incr)))
- ((= i clip-end))
- (set! (samps i) (- -1.0 (* amp (sin angle))))))
- (float-vector->channel samps (- clip-beg-1 4))))
- #t) ; return values so I can tell when I hit a 1-sample section during testing
- #f))
+ (and (> clip-end-1 clip-beg-1)
+ (let* ((dur (+ 1 (- clip-end-1 clip-beg-1)))
+ (samps (channel->float-vector (- clip-beg-1 4) (+ dur 9)))
+ (clip-beg 3)
+ (clip-end (+ dur 4)))
+ (let ((samp0 (samps clip-beg))
+ (samp1 (samps clip-end)))
+ (if (not (>= 0.99 samp0 -0.99))
+ (begin
+ ;; weird! some of the clipped passages have "knees"
+ ;; this looks nuts, but no time to scratch my head
+ (set! clip-beg (- clip-beg 1))
+ (set! samp0 (samps clip-beg))
+ (if (not (>= 0.99 samp0 -0.99))
+ (begin
+ (set! clip-beg (- clip-beg 1))
+ (set! samp0 (samps clip-beg))))))
+ (if (not (>= 0.99 samp0 -0.99))
+ (begin
+ (set! clip-end (+ 1 clip-end))
+ (set! samp1 (samps clip-end))
+ (if (not (>= 0.99 samp0 -0.99))
+ (begin
+ (set! clip-end (+ 1 clip-end))
+ (set! samp1 (samps clip-end))))))
+ ;; now we have semi-plausible bounds
+ ;; make sine dependent on rate of change of current
+ (let* ((samp00 (samps (- clip-beg 1)))
+ (samp11 (samps (+ 1 clip-end)))
+ (dist (- clip-end clip-beg))
+ (incr (/ pi dist))
+ (amp (* .125 (+ (abs (- samp0 samp00)) (abs (- samp1 samp11))) dist)))
+ (if (> samp0 0.0)
+ ;; clipped at 1.0
+ (do ((i (+ 1 clip-beg) (+ i 1))
+ (angle incr (+ angle incr)))
+ ((= i clip-end))
+ (set! (samps i) (+ 1.0 (* amp (sin angle)))))
+ ;; clipped at -1.0
+ (do ((i (+ 1 clip-beg) (+ i 1))
+ (angle incr (+ angle incr)))
+ ((= i clip-end))
+ (set! (samps i) (- -1.0 (* amp (sin angle))))))
+ (float-vector->channel samps (- clip-beg-1 4)))))))
(define (fix-it n)
;; turn off graphics and fix all the clipped sections
@@ -2587,11 +2582,7 @@ end
<div class="separator"></div>
-<p>snd-test.scm has examples of calling all these instruments. For more examples of instruments,
-there are a variety of separate files such as v.scm, and
-clm23.scm has a translation of
-the CLM test instruments. It also has some comments about
-the differences between the CL and Scheme instruments.
+<p>snd-test.scm has examples of calling all these instruments.
</p>
<div class="seealso">
@@ -3240,8 +3231,7 @@ and returns a sample):
</p>
<pre class="indented">
-(let ((peaker (make-peaking-2 500 1000 1.0)))
- (<a class=quiet href="extsnd.html#mapchannel">map-channel</a> peaker))
+(<a class=quiet href="extsnd.html#mapchannel">map-channel</a> (make-peaking-2 500 1000 1.0))
</pre>
<p>In this case 'm' is the gain in the pass band.
@@ -4272,8 +4262,8 @@ current spectrum value.
<pre class="indented">
-(let ((op (<a class=quiet href="sndclm.html#make-one-zero">make-one-zero</a> .5 .5))) (filter-fft op))
-(let ((op (<a class=quiet href="sndclm.html#make-one-pole">make-one-pole</a> .05 .95))) (filter-fft op))
+(filter-fft (<a class=quiet href="sndclm.html#make-one-zero">make-one-zero</a> .5 .5))
+(filter-fft (<a class=quiet href="sndclm.html#make-one-pole">make-one-pole</a> .05 .95))
(filter-fft (lambda (y) (if (< y .1) 0.0 y))) ; like fft-squelch
(let ((rd (<a class=quiet href="extsnd.html#makesampler">make-sampler</a> 0 0 0 1 0)))
(<a class=quiet href="extsnd.html#scaleby">scale-by</a> 0)
@@ -7471,7 +7461,7 @@ now being acos(-(sqrt(2/3))):
(b (acos (- (sqrt 2/3))))
(ap (- (* 2 pi) a)) ; start loc peak 1
(bp (- (* 2 pi) b)) ; end loc
- (ax (+ ap (* phi (/ (- bp ap) (* 2 pi))))) ; peak 1
+ (ax (+ ap (* phi (/ (- bp ap) 2 pi)))) ; peak 1
(bx (- ax pi))) ; peak 2 (the two interleave)
(max (abs (+ (sin ax) (sin (+ (* 3 ax) phi)))) ; plug in our 2 peak locations
(abs (+ (sin bx) (sin (+ (* 3 bx) phi)))))) ; and return the max
@@ -8060,15 +8050,15 @@ If this worked in general, we could use it to speed up our search by following a
<pre class="indented">
;; this starts at the current min and marches to an n+1 min
-(let ((n 3))
- (let ((phases (vector 0.0 0.0 1.0)))
- (do ((x 0.1 (+ x .1)))
- ((>= x 1.0))
- (let ((p (fpsap x 0 n 1000 0.1 50 #f #t phases))) ; args may change without warning.
- (format #t ";~A: ~A~%" x p)
- (do ((k 0 (+ k 1)))
- ((= k n))
- (set! (phases k) (modulo (p k) 2.0)))))))
+(let ((n 3)
+ (phases (vector 0.0 0.0 1.0)))
+ (do ((x 0.1 (+ x .1)))
+ ((>= x 1.0))
+ (let ((p (fpsap x 0 n 1000 0.1 50 #f #t phases))) ; args may change without warning.
+ (format () ";~A: ~A~%" x p)
+ (do ((k 0 (+ k 1)))
+ ((= k n))
+ (set! (phases k) (modulo (p k) 2.0))))))
</pre>
<p>
@@ -8135,7 +8125,7 @@ multiply "mult" by the number of harmonics to get the FFT size):
(do ((i 2 (* i 2)))
((> i 8192))
(let ((fftval (fft-all 8 i phases)))
- (format #t "~D: ~A -> ~A~%" i fftval (abs (- fftval correct))))))
+ (format () "~D: ~A -> ~A~%" i fftval (abs (- fftval correct))))))
-->
<pre class="indented">
@@ -8180,7 +8170,7 @@ the 0.0 phase and minimum phase cases for 8 harmonics:
(do ((i 2 (* i 2)))
((> i 8192))
(let ((fftval (fft-all 8 i phases)))
- (format #t "~D: ~A -> ~A~%" i fftval (abs (- fftval correct))))))
+ (format () "~D: ~A -> ~A~%" i fftval (abs (- fftval correct))))))
2: 2.7906633022277 -> 0.0042455977723455
4: 2.7906633022277 -> 0.0042455977723455
@@ -8370,11 +8360,11 @@ minimum, maximum, and average peaks. The graph is logarithmic (that is we show
(let ((pk (get-peak :all n phases)))
(if (> pk n)
- (format #t " ;oops: n: ~D, pk: ~F~%" n pk))
+ (format () " ;oops: n: ~D, pk: ~F~%" n pk))
(if (< pk sqrt-n)
(begin
(format file " ;;~D: ~F (~F) from ~A~%" n pk sqrt-n phases)
- (format #t " ;~D: ~F (~F) from ~A~%" n pk sqrt-n phases)))
+ (format () " ;~D: ~F (~F) from ~A~%" n pk sqrt-n phases)))
(set! sum (+ sum pk))
(if (< pk min-peak)
@@ -8384,7 +8374,7 @@ minimum, maximum, and average peaks. The graph is logarithmic (that is we show
(set! sum (/ sum tries))
(format file "(~D ~,3F ~,3F ~,3F (~,3F ~,3F ~,3F))~%" n (log min-peak n) (log sum n) (log max-peak n) min-peak sum max-peak)
(if (zero? (modulo n 10))
- (format #t "~A: ~,3F ~,3F ~,3F (~,3F ~,3F ~,3F)~%" n (log min-peak n) (log sum n) (log max-peak n) min-peak sum max-peak))
+ (format () "~A: ~,3F ~,3F ~,3F (~,3F ~,3F ~,3F)~%" n (log min-peak n) (log sum n) (log max-peak n) min-peak sum max-peak))
)))
(close-output-port file))
@@ -8515,9 +8505,7 @@ the search each time from the new best point, slowly reducing the search radius
(set! (phases i) (random 1.0)))
(do ()
((< cur-incr .001))
- (let ((vals (<em class=red>fpsap</em> (if (eq? choice :all) 0
- (if (eq? choice :odd) 1
- (if (eq? choice :even) 2 3)))
+ (let ((vals (<em class=red>fpsap</em> (case choice ((:all) 0) ((:odd) 1) ((:even) 2) (else 3))
n phases 5000 cur-incr)))
(let ((pk (car vals))
(new-phases (cadr vals)))
@@ -8553,8 +8541,8 @@ Here is the GA code used to find the initial-phase polynomials mentioned above:
(do ((try 0 (+ try 1))
(increment .3 (* increment .98)))
((= try 1000))
- (sort! pop (lambda (a b) (< (car a) (car b))))
- (format #t "~A ~D ~A ~A~%" choice n (pop 0) (log (car (pop 0)) n))
+ (set! pop (sort! pop (lambda (a b) (< (car a) (car b)))))
+ (format () "~A ~D ~A ~A~%" choice n (pop 0) (log (car (pop 0)) n))
(do ((i 0 (+ i 1))
(j (/ size 2) (+ j 1)))
((= i (/ size 2)))
@@ -8724,10 +8712,10 @@ of harmonics, then the minimum peak amplitude, then (log peak n).
all odd even prime
=============================================================================================
-20 4.288 0.4860 | 11 3.177 0.4820 | 115 11.164 0.5085 | 24 5.643 0.5445
-14 3.612 0.4867 | 9 2.886 0.4824 | 113 11.086 0.5089 | 18 4.855 0.5467
-23 4.604 0.4870 | 17 3.926 0.4827 | 126 11.729 0.5091 | 25 5.811 0.5467
-11 3.218 0.4874 | 10 3.053 0.4848 | 114 11.157 0.5093 | 19 5.001 0.5467
+20 4.288 0.4860 | 11 3.177 0.4820 | 115 11.164 0.5085 | 24 5.642 0.5444
+14 3.612 0.4867 | 9 2.886 0.4824 | 113 11.086 0.5089 | 19 4.999 0.5465
+23 4.604 0.4870 | 17 3.926 0.4827 | 126 11.729 0.5091 | 18 4.855 0.5467
+11 3.218 0.4874 | 10 3.053 0.4848 | 114 11.157 0.5093 | 25 5.811 0.5467
17 3.980 0.4876 | 19 4.172 0.4851 | 127 11.792 0.5094 | 28 6.191 0.5471
16 3.874 0.4884 | 14 3.598 0.4852 | 117 11.317 0.5095 | 93 11.942 0.5472
24 4.728 0.4888 | 13 3.475 0.4856 | 124 11.657 0.5095 | 23 5.562 0.5473
@@ -8747,104 +8735,104 @@ of harmonics, then the minimum peak amplitude, then (log peak n).
35 5.762 0.4926 | 29 5.263 0.4932 | 116 11.309 0.5103 | 87 11.613 0.5491
26 4.982 0.4929 | 30 5.353 0.4933 | 122 11.609 0.5104 | 109 13.144 0.5491
33 5.608 0.4931 | 8 2.791 0.4935 | 109 10.962 0.5104 | 20 5.183 0.5492
-32 5.526 0.4932 | 27 5.089 0.4937 | 94 10.168 0.5105 | 21 5.324 0.5492
-30 5.361 0.4937 | 26 5.006 0.4944 | 103 10.655 0.5105 | 74 10.650 0.5496
-31 5.453 0.4939 | 7 2.618 0.4946 | 105 10.762 0.5105 | 89 11.788 0.5496
-36 5.872 0.4940 | 32 5.563 0.4952 | 83 9.549 0.5106 | 29 6.365 0.5496
-9 2.962 0.4941 | 52 7.080 0.4954 | 93 10.121 0.5107 | 96 12.293 0.5497
-8 2.795 0.4942 | 50 6.947 0.4955 | 119 11.483 0.5107 | 101 12.654 0.5499
-34 5.715 0.4943 | 34 5.741 0.4956 | 112 11.133 0.5107 | 114 13.530 0.5500
-70 8.177 0.4946 | 82 8.895 0.4960 | 108 10.929 0.5108 | 38 7.396 0.5501
-39 6.124 0.4946 | 35 5.833 0.4960 | 1024 34.487 0.5108 | 57 9.246 0.5501
-93 9.413 0.4947 | 48 6.828 0.4962 | 106 10.831 0.5109 | 59 9.424 0.5502
-41 6.278 0.4947 | 41 6.322 0.4966 | 97 10.354 0.5109 | 33 6.846 0.5502
-60 7.589 0.4950 | 43 6.474 0.4966 | 101 10.578 0.5111 | 37 7.292 0.5502
-38 6.056 0.4951 | 72 8.366 0.4967 | 85 9.691 0.5112 | 31 6.616 0.5502
-69 8.144 0.4953 | 45 6.625 0.4967 | 84 9.634 0.5113 | 97 12.398 0.5503
-48 6.804 0.4953 | 42 6.403 0.4968 | 95 10.275 0.5116 | 27 6.134 0.5503
-58 7.475 0.4954 | 74 8.488 0.4969 | 82 9.531 0.5116 | 41 7.720 0.5504
-56 7.349 0.4955 | 78 8.715 0.4970 | 118 11.484 0.5117 | 36 7.188 0.5504
-42 6.374 0.4956 | 37 6.019 0.4971 | 110 11.084 0.5117 | 16 4.600 0.5504
-64 7.856 0.4956 | 46 6.709 0.4972 | 91 10.063 0.5118 | 108 13.162 0.5505
-40 6.224 0.4956 | 39 6.182 0.4972 | 86 9.779 0.5119 | 122 14.078 0.5505
-83 8.939 0.4957 | 105 10.116 0.4972 | 107 10.937 0.5119 | 43 7.936 0.5507
-63 7.800 0.4958 | 47 6.785 0.4973 | 92 10.124 0.5119 | 54 8.998 0.5508
-59 7.557 0.4960 | 38 6.108 0.4975 | 90 10.013 0.5120 | 52 8.817 0.5509
-92 9.420 0.4960 | 89 9.332 0.4976 | 71 8.877 0.5122 | 66 10.066 0.5512
-50 6.967 0.4962 | 111 10.417 0.4976 | 79 9.381 0.5123 | 70 10.403 0.5513
-47 6.757 0.4962 | 40 6.272 0.4978 | 75 9.137 0.5124 | 106 13.080 0.5513
-45 6.613 0.4962 | 56 7.419 0.4979 | 98 10.481 0.5124 | 45 8.157 0.5514
-100 9.828 0.4962 | 106 10.198 0.4980 | 78 9.336 0.5127 | 62 9.734 0.5514
-44 6.544 0.4964 | 59 7.618 0.4980 | 87 9.875 0.5128 | 12 3.936 0.5514
-46 6.691 0.4965 | 57 7.489 0.4980 | 512 24.510 0.5128 | 34 6.991 0.5515
-57 7.443 0.4965 | 91 9.457 0.4981 | 77 9.278 0.5128 | 85 11.589 0.5515
-84 9.023 0.4965 | 51 7.088 0.4981 | 89 9.998 0.5129 | 125 14.336 0.5515
-94 9.544 0.4965 | 80 8.870 0.4981 | 81 9.529 0.5130 | 88 11.815 0.5515
-95 9.595 0.4966 | 81 8.926 0.4981 | 70 8.849 0.5132 | 64 9.912 0.5515
-49 6.908 0.4966 | 101 9.965 0.4982 | 61 8.247 0.5132 | 46 8.261 0.5515
-43 6.475 0.4966 | 119 10.815 0.4982 | 72 8.986 0.5134 | 72 10.580 0.5516
-67 8.073 0.4967 | 77 8.707 0.4982 | 80 9.493 0.5136 | 92 12.112 0.5516
-54 7.254 0.4968 | 76 8.651 0.4982 | 73 9.061 0.5137 | 60 9.568 0.5516
-68 8.135 0.4968 | 62 7.817 0.4982 | 74 9.134 0.5139 | 124 14.280 0.5516
-71 8.312 0.4968 | 55 7.364 0.4982 | 63 8.414 0.5141 | 103 12.892 0.5516
-114 10.518 0.4968 | 67 8.128 0.4983 | 68 8.755 0.5142 | 123 14.218 0.5516
-85 9.093 0.4969 | 110 10.408 0.4984 | 57 7.998 0.5143 | 56 9.213 0.5517
-91 9.407 0.4969 | 90 9.422 0.4985 | 76 9.274 0.5143 | 98 12.555 0.5518
-87 9.201 0.4969 | 60 7.700 0.4985 | 64 8.501 0.5146 | 48 8.469 0.5519
-73 8.433 0.4969 | 86 9.213 0.4985 | 67 8.715 0.5149 | 128 14.551 0.5519
-88 9.256 0.4970 | 108 10.325 0.4986 | 58 8.103 0.5153 | 120 14.042 0.5519
-55 7.328 0.4970 | 44 6.599 0.4986 | 2048 50.887 0.5154 | 116 13.783 0.5519
-98 9.767 0.4971 | 88 9.324 0.4986 | 62 8.391 0.5154 | 110 13.386 0.5519
-86 9.154 0.4971 | 64 7.957 0.4987 | 69 8.870 0.5155 | 32 6.772 0.5519
-80 8.832 0.4971 | 83 9.061 0.4988 | 65 8.610 0.5157 | 84 11.537 0.5519
-78 8.722 0.4971 | 68 8.204 0.4988 | 66 8.679 0.5158 | 42 7.870 0.5520
-74 8.497 0.4971 | 102 10.046 0.4988 | 53 7.750 0.5158 | 76 10.919 0.5520
-82 8.942 0.4971 | 85 9.173 0.4989 | 59 8.195 0.5159 | 104 12.987 0.5521
-53 7.198 0.4971 | 114 10.621 0.4989 | 51 7.602 0.5159 | 61 9.674 0.5521
-51 7.062 0.4972 | 61 7.775 0.4989 | 55 7.908 0.5160 | 105 13.058 0.5521
-90 9.369 0.4972 | 125 11.122 0.4989 | 44 7.048 0.5160 | 53 8.953 0.5521
-75 8.558 0.4973 | 70 8.328 0.4989 | 47 7.293 0.5160 | 75 10.845 0.5521
-52 7.133 0.4973 | 36 5.978 0.4990 | 38 6.537 0.5161 | 115 13.732 0.5521
-99 9.827 0.4973 | 98 9.853 0.4990 | 54 7.845 0.5164 | 71 10.523 0.5521
-61 7.725 0.4973 | 63 7.904 0.4990 | 60 8.297 0.5168 | 81 11.319 0.5522
-65 7.973 0.4973 | 107 10.296 0.4990 | 50 7.554 0.5169 | 100 12.717 0.5522
-97 9.734 0.4974 | 103 10.102 0.4990 | 56 8.011 0.5169 | 73 10.689 0.5522
-79 8.789 0.4974 | 118 10.812 0.4990 | 52 7.716 0.5171 | 107 13.202 0.5522
-76 8.623 0.4975 | 115 10.674 0.4990 | 48 7.407 0.5173 | 50 8.676 0.5523
-62 7.793 0.4975 | 58 7.586 0.4990 | 45 7.165 0.5173 | 80 11.248 0.5523
-112 10.460 0.4975 | 128 11.261 0.4990 | 40 6.748 0.5176 | 113 13.613 0.5523
-101 9.935 0.4975 | 53 7.253 0.4990 | 46 7.276 0.5184 | 55 9.146 0.5523
-109 10.322 0.4976 | 94 9.654 0.4991 | 42 6.941 0.5184 | 49 8.583 0.5524
-72 8.398 0.4976 | 69 8.275 0.4991 | 34 6.223 0.5184 | 111 13.484 0.5524
-81 8.909 0.4977 | 92 9.553 0.4991 | 39 6.683 0.5185 | 91 12.084 0.5524
-96 9.699 0.4978 | 120 10.909 0.4991 | 49 7.532 0.5188 | 121 14.145 0.5524
-77 8.694 0.4979 | 113 10.586 0.4991 | 41 6.881 0.5194 | 79 11.178 0.5525
-116 10.667 0.4980 | 96 9.759 0.4991 | 36 6.432 0.5194 | 69 10.373 0.5525
-115 10.622 0.4980 | 66 8.095 0.4992 | 43 7.055 0.5195 | 119 14.019 0.5525
-66 8.057 0.4980 | 73 8.515 0.4992 | 37 6.533 0.5198 | 117 13.889 0.5525
-102 10.008 0.4980 | 84 9.133 0.4992 | 32 6.061 0.5199 | 118 13.956 0.5525
-89 9.351 0.4980 | 116 10.733 0.4993 | 33 6.163 0.5201 | 112 13.561 0.5525
-113 10.533 0.4981 | 100 9.968 0.4993 | 29 5.766 0.5203 | 127 14.536 0.5525
-128 11.210 0.4981 | 54 7.328 0.4993 | 35 6.362 0.5205 | 78 11.104 0.5526
-111 10.443 0.4981 | 95 9.717 0.4993 | 26 5.452 0.5206 | 68 10.294 0.5526
-122 10.950 0.4982 | 121 10.965 0.4993 | 31 5.988 0.5212 | 58 9.429 0.5526
-127 11.176 0.4983 | 122 11.011 0.4993 | 24 5.253 0.5220 | 15 4.466 0.5526
-108 10.313 0.4984 | 117 10.783 0.4994 | 30 5.907 0.5222 | 65 10.042 0.5526
-105 10.170 0.4984 | 104 10.169 0.4994 | 23 5.148 0.5226 | 99 12.671 0.5526
-103 10.073 0.4984 | 79 8.865 0.4994 | 21 4.920 0.5233 | 83 11.495 0.5526
-104 10.124 0.4984 | 65 8.042 0.4994 | 27 5.620 0.5238 | 126 14.478 0.5526
-117 10.740 0.4985 | 71 8.407 0.4995 | 28 5.732 0.5240 | 90 12.023 0.5526
-126 11.145 0.4985 | 109 10.414 0.4995 | 25 5.403 0.5241 | 44 8.096 0.5527
-120 10.878 0.4985 | 99 9.928 0.4995 | 22 5.055 0.5242 | 26 6.060 0.5530
-107 10.274 0.4985 | 49 6.989 0.4996 | 18 4.569 0.5257 | 82 11.463 0.5535
-110 10.417 0.4985 | 97 9.832 0.4996 | 20 4.839 0.5264 | 35 7.164 0.5538
-121 10.925 0.4986 | 93 9.629 0.4997 | 17 4.463 0.5280 | 67 10.270 0.5540
-118 10.790 0.4986 | 75 8.650 0.4997 | 16 4.325 0.5282 | 11 3.778 0.5544
-124 11.060 0.4986 | 124 11.120 0.4997 | 19 4.741 0.5286 | 9 3.382 0.5546
-119 10.836 0.4986 | 87 9.317 0.4998 | 15 4.192 0.5292 | 14 4.324 0.5548
-123 11.016 0.4986 | 126 11.217 0.4999 | 14 4.097 0.5344 | 13 4.154 0.5553
-125 11.105 0.4986 | 123 11.088 0.4999 | 12 3.787 0.5359 | 10 3.602 0.5565
-106 10.234 0.4987 | 127 11.268 0.5000 | 13 3.973 0.5378 | 5 2.477 0.5635
+59 7.469 0.4931 | 27 5.089 0.4937 | 94 10.168 0.5105 | 21 5.324 0.5492
+32 5.526 0.4932 | 26 5.006 0.4944 | 103 10.655 0.5105 | 74 10.650 0.5496
+30 5.361 0.4937 | 7 2.618 0.4946 | 105 10.762 0.5105 | 89 11.788 0.5496
+51 6.972 0.4939 | 32 5.563 0.4952 | 83 9.549 0.5106 | 29 6.365 0.5496
+31 5.453 0.4939 | 52 7.080 0.4954 | 93 10.121 0.5107 | 96 12.293 0.5497
+36 5.872 0.4940 | 50 6.947 0.4955 | 119 11.483 0.5107 | 101 12.654 0.5499
+9 2.962 0.4941 | 34 5.741 0.4956 | 112 11.133 0.5107 | 114 13.530 0.5500
+8 2.795 0.4942 | 82 8.895 0.4960 | 108 10.929 0.5108 | 38 7.396 0.5501
+34 5.715 0.4943 | 35 5.833 0.4960 | 1024 34.487 0.5108 | 57 9.246 0.5501
+70 8.177 0.4946 | 48 6.828 0.4962 | 106 10.831 0.5109 | 59 9.424 0.5502
+39 6.124 0.4946 | 41 6.322 0.4966 | 97 10.354 0.5109 | 33 6.846 0.5502
+93 9.413 0.4947 | 43 6.474 0.4966 | 101 10.578 0.5111 | 37 7.292 0.5502
+41 6.278 0.4947 | 72 8.366 0.4967 | 85 9.691 0.5112 | 31 6.616 0.5502
+60 7.589 0.4950 | 45 6.625 0.4967 | 84 9.634 0.5113 | 97 12.398 0.5503
+38 6.056 0.4951 | 42 6.403 0.4968 | 95 10.275 0.5116 | 27 6.134 0.5503
+69 8.140 0.4952 | 74 8.488 0.4969 | 82 9.531 0.5116 | 41 7.720 0.5504
+49 6.872 0.4952 | 78 8.715 0.4970 | 118 11.484 0.5117 | 36 7.188 0.5504
+58 7.471 0.4953 | 37 6.019 0.4971 | 110 11.084 0.5117 | 16 4.600 0.5504
+82 8.870 0.4953 | 46 6.709 0.4972 | 91 10.063 0.5118 | 108 13.162 0.5505
+48 6.804 0.4953 | 39 6.182 0.4972 | 86 9.779 0.5119 | 122 14.078 0.5505
+81 8.821 0.4954 | 105 10.116 0.4972 | 107 10.937 0.5119 | 43 7.936 0.5507
+103 9.936 0.4954 | 47 6.785 0.4973 | 92 10.124 0.5119 | 54 8.998 0.5508
+64 7.850 0.4955 | 38 6.108 0.4975 | 90 10.013 0.5120 | 52 8.817 0.5509
+56 7.349 0.4955 | 89 9.332 0.4976 | 71 8.877 0.5122 | 66 10.066 0.5512
+42 6.374 0.4956 | 111 10.417 0.4976 | 79 9.381 0.5123 | 70 10.403 0.5513
+63 7.793 0.4956 | 40 6.272 0.4978 | 75 9.137 0.5124 | 106 13.080 0.5513
+73 8.384 0.4956 | 56 7.419 0.4979 | 98 10.481 0.5124 | 45 8.157 0.5514
+40 6.224 0.4956 | 106 10.198 0.4980 | 78 9.336 0.5127 | 62 9.734 0.5514
+83 8.939 0.4957 | 59 7.618 0.4980 | 87 9.875 0.5128 | 12 3.936 0.5514
+67 8.044 0.4959 | 57 7.489 0.4980 | 512 24.510 0.5128 | 34 6.991 0.5515
+76 8.567 0.4960 | 91 9.457 0.4981 | 77 9.278 0.5128 | 85 11.589 0.5515
+85 9.056 0.4960 | 51 7.088 0.4981 | 89 9.998 0.5129 | 125 14.336 0.5515
+92 9.420 0.4960 | 80 8.870 0.4981 | 81 9.529 0.5130 | 88 11.815 0.5515
+55 7.300 0.4961 | 81 8.926 0.4981 | 70 8.849 0.5132 | 64 9.912 0.5515
+53 7.168 0.4961 | 101 9.965 0.4982 | 61 8.247 0.5132 | 46 8.261 0.5515
+105 10.064 0.4961 | 119 10.815 0.4982 | 72 8.986 0.5134 | 72 10.580 0.5516
+52 7.102 0.4961 | 77 8.707 0.4982 | 80 9.493 0.5136 | 92 12.112 0.5516
+104 10.017 0.4962 | 76 8.651 0.4982 | 73 9.061 0.5137 | 60 9.568 0.5516
+50 6.966 0.4962 | 62 7.817 0.4982 | 74 9.134 0.5139 | 124 14.280 0.5516
+65 7.935 0.4962 | 55 7.364 0.4982 | 63 8.414 0.5141 | 103 12.892 0.5516
+71 8.291 0.4962 | 67 8.128 0.4983 | 68 8.755 0.5142 | 123 14.218 0.5516
+47 6.757 0.4962 | 110 10.408 0.4984 | 57 7.998 0.5143 | 56 9.213 0.5517
+45 6.613 0.4962 | 90 9.422 0.4985 | 76 9.274 0.5143 | 98 12.555 0.5518
+100 9.828 0.4962 | 60 7.700 0.4985 | 64 8.501 0.5146 | 48 8.469 0.5519
+44 6.544 0.4964 | 86 9.213 0.4985 | 67 8.715 0.5149 | 128 14.551 0.5519
+57 7.441 0.4964 | 108 10.325 0.4986 | 58 8.103 0.5153 | 120 14.042 0.5519
+46 6.691 0.4965 | 44 6.599 0.4986 | 2048 50.887 0.5154 | 116 13.783 0.5519
+54 7.246 0.4965 | 88 9.324 0.4986 | 62 8.391 0.5154 | 110 13.386 0.5519
+84 9.023 0.4965 | 64 7.957 0.4987 | 69 8.870 0.5155 | 32 6.772 0.5519
+94 9.544 0.4965 | 83 9.061 0.4988 | 65 8.610 0.5157 | 84 11.537 0.5519
+95 9.595 0.4966 | 68 8.204 0.4988 | 66 8.679 0.5158 | 42 7.870 0.5520
+43 6.475 0.4966 | 102 10.046 0.4988 | 53 7.750 0.5158 | 76 10.919 0.5520
+74 8.479 0.4966 | 85 9.173 0.4989 | 59 8.195 0.5159 | 104 12.987 0.5521
+66 8.012 0.4967 | 114 10.621 0.4989 | 51 7.602 0.5159 | 61 9.674 0.5521
+68 8.131 0.4967 | 61 7.775 0.4989 | 55 7.908 0.5160 | 105 13.058 0.5521
+114 10.518 0.4968 | 125 11.122 0.4989 | 44 7.048 0.5160 | 53 8.953 0.5521
+91 9.407 0.4969 | 70 8.328 0.4989 | 47 7.293 0.5160 | 75 10.845 0.5521
+87 9.201 0.4969 | 36 5.978 0.4990 | 38 6.537 0.5161 | 115 13.732 0.5521
+88 9.256 0.4970 | 98 9.853 0.4990 | 54 7.845 0.5164 | 71 10.523 0.5521
+75 8.550 0.4970 | 63 7.904 0.4990 | 60 8.297 0.5168 | 81 11.319 0.5522
+98 9.767 0.4971 | 107 10.296 0.4990 | 50 7.554 0.5169 | 100 12.717 0.5522
+86 9.154 0.4971 | 103 10.102 0.4990 | 56 8.011 0.5169 | 73 10.689 0.5522
+80 8.832 0.4971 | 118 10.812 0.4990 | 52 7.716 0.5171 | 107 13.202 0.5522
+78 8.722 0.4971 | 115 10.674 0.4990 | 48 7.407 0.5173 | 50 8.676 0.5523
+61 7.718 0.4971 | 58 7.586 0.4990 | 45 7.165 0.5173 | 80 11.248 0.5523
+90 9.369 0.4972 | 128 11.261 0.4990 | 40 6.748 0.5176 | 113 13.613 0.5523
+101 9.925 0.4973 | 53 7.253 0.4990 | 46 7.276 0.5184 | 55 9.146 0.5523
+99 9.827 0.4973 | 94 9.654 0.4991 | 42 6.941 0.5184 | 49 8.583 0.5524
+72 8.392 0.4974 | 69 8.275 0.4991 | 34 6.223 0.5184 | 111 13.484 0.5524
+97 9.734 0.4974 | 92 9.553 0.4991 | 39 6.683 0.5185 | 91 12.084 0.5524
+79 8.789 0.4974 | 120 10.909 0.4991 | 49 7.532 0.5188 | 121 14.145 0.5524
+109 10.316 0.4974 | 113 10.586 0.4991 | 41 6.881 0.5194 | 79 11.178 0.5525
+62 7.792 0.4975 | 96 9.759 0.4991 | 36 6.432 0.5194 | 69 10.373 0.5525
+89 9.329 0.4975 | 66 8.095 0.4992 | 43 7.055 0.5195 | 119 14.019 0.5525
+112 10.460 0.4975 | 73 8.515 0.4992 | 37 6.533 0.5198 | 117 13.889 0.5525
+106 10.180 0.4976 | 84 9.133 0.4992 | 32 6.061 0.5199 | 118 13.956 0.5525
+96 9.699 0.4978 | 116 10.733 0.4993 | 33 6.163 0.5201 | 112 13.561 0.5525
+102 10.000 0.4979 | 100 9.968 0.4993 | 29 5.766 0.5203 | 127 14.536 0.5525
+77 8.694 0.4979 | 54 7.328 0.4993 | 35 6.362 0.5205 | 78 11.104 0.5526
+116 10.667 0.4980 | 95 9.717 0.4993 | 26 5.452 0.5206 | 68 10.294 0.5526
+115 10.622 0.4980 | 121 10.965 0.4993 | 31 5.988 0.5212 | 58 9.429 0.5526
+113 10.533 0.4981 | 122 11.011 0.4993 | 24 5.253 0.5220 | 15 4.466 0.5526
+128 11.210 0.4981 | 117 10.783 0.4994 | 30 5.907 0.5222 | 65 10.042 0.5526
+111 10.443 0.4981 | 104 10.169 0.4994 | 23 5.148 0.5226 | 99 12.671 0.5526
+122 10.950 0.4982 | 79 8.865 0.4994 | 21 4.920 0.5233 | 83 11.495 0.5526
+127 11.176 0.4983 | 65 8.042 0.4994 | 27 5.620 0.5238 | 126 14.478 0.5526
+108 10.313 0.4984 | 71 8.407 0.4995 | 28 5.732 0.5240 | 90 12.023 0.5526
+117 10.740 0.4985 | 109 10.414 0.4995 | 25 5.403 0.5241 | 44 8.096 0.5527
+126 11.145 0.4985 | 99 9.928 0.4995 | 22 5.055 0.5242 | 26 6.057 0.5528
+107 10.273 0.4985 | 49 6.989 0.4996 | 18 4.569 0.5257 | 82 11.463 0.5535
+120 10.878 0.4985 | 97 9.832 0.4996 | 20 4.839 0.5264 | 35 7.164 0.5538
+110 10.417 0.4985 | 93 9.629 0.4997 | 17 4.463 0.5280 | 67 10.270 0.5540
+121 10.925 0.4986 | 75 8.650 0.4997 | 16 4.325 0.5282 | 11 3.778 0.5544
+118 10.790 0.4986 | 124 11.120 0.4997 | 19 4.741 0.5286 | 9 3.382 0.5546
+124 11.060 0.4986 | 87 9.317 0.4998 | 15 4.192 0.5292 | 14 4.324 0.5548
+119 10.836 0.4986 | 126 11.217 0.4999 | 14 4.097 0.5344 | 13 4.154 0.5553
+123 11.016 0.4986 | 123 11.088 0.4999 | 12 3.787 0.5359 | 10 3.602 0.5565
+125 11.105 0.4986 | 127 11.268 0.5000 | 13 3.973 0.5378 | 5 2.477 0.5635
7 2.639 0.4988 | 112 10.582 0.5000 | 11 3.656 0.5406 | 4 2.192 0.5662
256 16.061 0.5007 | 3 1.739 0.5035 | 10 3.559 0.5513 | 8 3.263 0.5687
1024 33.411 0.5062 | 512 23.717 0.5075 | 8 3.198 0.5590 | 256 23.955 0.5728
@@ -8880,13 +8868,13 @@ of the genetic algorithm):
<pre class="indented">
-(let ((all (cadr (get-best :all (- n 1))))) ; get the best all-harmonic phases for n - 1
- (let ((new-phases (make-vector n 0.0))) ; place in new phase vector shifted up
- (do ((k 0 (+ k 1)))
- ((= k (- n 1)))
- (set! (new-phases (+ k 1)) (all k)))
- (set! (new-phases 0) 0.0)
- (fpsap 2 n new-phases))) ; search that vicinity for a good set (2 = even harmonics)
+(let* ((all (cadr (get-best :all (- n 1)))) ; get the best all-harmonic phases for n - 1
+ (new-phases (make-vector n 0.0))) ; place in new phase vector shifted up
+ (do ((k 0 (+ k 1)))
+ ((= k (- n 1)))
+ (set! (new-phases (+ k 1)) (all k)))
+ (set! (new-phases 0) 0.0)
+ (fpsap 2 n new-phases)) ; search that vicinity for a good set (2 = even harmonics)
</pre>
@@ -9407,10 +9395,11 @@ argument to pvocoder can be a function.
</p>
<pre class="indented">
-(let ((ind (<a class=quiet href="extsnd.html#opensound">open-sound</a> "oboe.snd"))
- (pv (<em class=red>make-pvocoder</em> 256 4 64))
- (rd (<a class=quiet href="extsnd.html#makesampler">make-sampler</a> 0)))
- (<a class=quiet href="extsnd.html#mapchannel">map-channel</a> (lambda (y) (<em class=red>pvocoder</em> pv rd))))
+(begin
+ (<a class=quiet href="extsnd.html#opensound">open-sound</a> "oboe.snd")
+ (let ((pv (<em class=red>make-pvocoder</em> 256 4 64))
+ (rd (<a class=quiet href="extsnd.html#makesampler">make-sampler</a> 0)))
+ (<a class=quiet href="extsnd.html#mapchannel">map-channel</a> (lambda (y) (<em class=red>pvocoder</em> pv rd)))))
</pre>
<p>
@@ -9487,7 +9476,8 @@ less and less need for these elaborate color names, and less
reason (except perhaps psychophysical) to limit these numbers to bytes.
There is one gotcha in this file — X11 defines a color named "tan"
which is already used by Scheme, so (at the suggestion of Dave Phillips)
-this color is named "tawny" in rgb.scm.
+this color is named "tawny" in rgb.scm. rgb.scm exports only *rgb* which
+is an environment holding all the color names and values.
</p>
@@ -10480,6 +10470,7 @@ each given a name:
which (I think) refers to a trumpet playing the note gs5. The first number is the harmonic,
the second its amplitude, the third the next harmonic, then its amplitude, and so on.
These spectra can be used directly in the instrument <a href="#spectra">spectra</a> in clm-ins.scm.
+spectr.scm exports only *spectr* which is an environment that holds the spectral names and values.
</p>
<div class="seealso">
@@ -11772,9 +11763,8 @@ Here's another example:
</p>
<pre class="indented">
- (<a class=quiet href="#wsdoc">with-sound</a> ()
- (let ((temp-sound (<em class=red>with-temp-sound</em> () (fm-violin 0 1 440 .1))))
- (clm-expsrc 0 2 temp-sound 2.0 1.0 1.0)))
+(<a class=quiet href="#wsdoc">with-sound</a> ()
+ (clm-expsrc 0 2 (<em class=red>with-temp-sound</em> () (fm-violin 0 1 440 .1)) 2.0 1.0 1.0))
</pre>
diff --git a/sndwarp.scm b/sndwarp.scm
index f71de0a..adcf132 100644
--- a/sndwarp.scm
+++ b/sndwarp.scm
@@ -77,8 +77,8 @@
;;; always get a bit of the attack of the sound even
;;; if you try to run the time pointer starting in
;;; the middle or end.
-;;; [NIL = 1st section starts according to time-ptr,
-;;; T = 1st section always starts at time-ptr = 0]
+;;; [NIL = first section starts according to time-ptr,
+;;; T = first section always starts at time-ptr = 0]
;;;
;;; sndwarp-window-offset = Flag to determine how the windows are offset
;;; in time. T = Csound sndwarp style, windows
@@ -147,158 +147,144 @@
(if (number? in) (list 0 in 1 in) in))
(let* ((beg (seconds->samples begtime))
- (end (+ beg (seconds->samples dur))))
+ (end (+ beg (seconds->samples dur)))
+ (stereo-i (= (mus-sound-chans file) 2))
+ (stereo-o #f) ; (= (channels *output*) 2))
+ (f-a (make-readin file :channel 0))
+ (f-b (and stereo-i (make-readin file :channel 1)))
+ (fsr (mus-sound-srate file))
+ ;; (fsize (framples file))
+ (fdur (mus-sound-duration file))
+ (rev-val rev)
+ (loc-env (clmsw-envelope-or-number loc))
+ (srate-env (clmsw-envelope-or-number srate))
+ (time-env (clmsw-envelope-or-number stretch))
+ (wsize-env (clmsw-envelope-or-number wsize))
+ (rdA (make-src :input (lambda (dir) (readin f-a)) :srate 0.0 :width srcwidth))
+ (rdB (and stereo-i (make-src :input (lambda (dir) (readin f-b)) :srate 0.0 :width srcwidth)))
+ (windf (make-oscil))
+ (wsizef (make-env wsize-env :duration dur))
+ (ampf (make-env amp-env :scaler amp :duration dur))
+ (sratef (make-env srate-env :duration dur))
+ (timef (make-env (if (and time-ptr scale-time-ptr)
+ (normalize-envelope time-env (- fdur inputbeg))
+ time-env)
+ :duration dur))
+ (locf (make-env loc-env :duration dur))
+ (writestart 0)
+ (readstart (round (* fsr inputbeg)))
+ (eow-flag #f)
+ (overlap-ratio 0.0)
+ (overlap-ratio-compl 0.0)
+ (outa-val 0.0)
+ (outb-val 0.0))
- (let* ((stereo-i (= (mus-sound-chans file) 2))
- (stereo-o #f) ; (= (channels *output*) 2))
- (f-a (make-readin file :channel 0))
- (f-b (and stereo-i (make-readin file :channel 1)))
- (fsr (mus-sound-srate file))
- ;; (fsize (framples file))
- (fdur (mus-sound-duration file))
- (rev-val rev)
- (loc-env (clmsw-envelope-or-number loc))
- (srate-env (clmsw-envelope-or-number srate))
- (time-env (clmsw-envelope-or-number stretch))
- (wsize-env (clmsw-envelope-or-number wsize))
- (rdA (make-src :input (lambda (dir) (readin f-a)) :srate 0.0 :width srcwidth))
- (rdB (and stereo-i (make-src :input (lambda (dir) (readin f-b)) :srate 0.0 :width srcwidth)))
- (windf (make-oscil))
- (wsizef (make-env wsize-env :duration dur))
- (ampf (make-env amp-env :scaler amp :duration dur))
- (sratef (make-env srate-env :duration dur))
- (timef (make-env (if (and time-ptr scale-time-ptr)
- (normalize-envelope time-env (- fdur inputbeg))
- time-env)
- :duration dur))
- (locf (make-env loc-env :duration dur))
- (writestart 0)
- (readstart (round (* fsr inputbeg)))
- (eow-flag #f)
- (overlap-ratio 0.0)
- (overlap-ratio-compl 0.0)
- (outa-val 0.0)
- (outb-val 0.0))
-
- (do ((overlap 0 (+ 1 overlap)))
- ((or eow-flag (= overlap overlaps)))
- (set! overlap-ratio (/ overlap overlaps))
- (set! overlap-ratio-compl (- 1 overlap-ratio))
- (set! eow-flag #f)
- (set! writestart beg)
- (set! (mus-location ampf) beg)
- (set! (mus-location locf) beg)
- (do ((section 0 (+ 1 section)))
- ((or eow-flag (= overlap overlaps)))
- (set! (mus-location timef) writestart)
- (set! (mus-location sratef) writestart)
- (set! (mus-location wsizef) writestart)
- (set! wsize (env wsizef))
- (let* ((winlen (if (= overlap 0 section) ; first section of first overlap isn't randomized
- wsize
- (+ wsize (random randw))))
- (winsamps (seconds->samples winlen))
- (srate-val (env sratef))
- (time-val (env timef)))
- ;; Even for the 1st section's truncated envelopes, the frequency of the envelope must be as if the envelope were full duration.
- (set! (mus-frequency windf) (* .5 (/ fsr winsamps)))
- ;; Set windowing oscillator to starting phase and appropriate frequency to provide half-sine envelope over window.
- ;; Phase must be altered for 1st envelope of each overlap stream.
- (set! (mus-phase windf)
- (if (= section 0)
- (if (= overlap 0)
- 0.0
- (* .5 clmsw-2pi overlap-ratio-compl))
- 0.0))
- ;; Either use the absolute time pointer or a scaled increment.
- ;; If first section in scaled mode, must initialize section readstart to beginning plus first overlap position.
- ;; In both cases, need to alter readstart and length of first section's windows based on phase of overlap
- (if time-ptr
- ;; TIME-PTR mode
- (if (= section 0)
- ;; initial section
- (let ((overlap-start
- (if window-offset
- ;; Csound style - start each overlap series further into the soundfile
- (if (= overlap 0)
- 0
- (round (* winlen overlap-ratio-compl)))
- ;; Alternative style - start each overlap series at 0
- 0))
- ;; To match csound version, 1st section must start reading at 0. Using zero-start-time-ptr
- ;; flag = #f, however, allows 1st section to start as determined by time-ptr instead.
- (adj-time-val (if zero-start-time-ptr 0.0 time-val)))
- (set! readstart (round (* fsr (+ inputbeg overlap-start adj-time-val))))
- (if (not (= overlap 0)) (set! winsamps (floor (* winsamps overlap-ratio)))))
- ;; remaining sections
- (set! readstart (round (* fsr (+ inputbeg time-val)))))
- ;; STRETCH mode
- (if (= section 0)
- ;; initial section
- (let ((init-read-start
- (if window-offset
- ;; Csound style - start each overlap series further into the soundfile
- (if (= overlap 0)
- 0
- (round (* winlen overlap-ratio-compl)))
- ;; Alternative style - start each overlap series at 0
- 0)))
- (set! readstart (round (* fsr (+ inputbeg init-read-start))))
- (if (not (= overlap 0)) (set! winsamps (floor (* winsamps overlap-ratio)))))
- ;; remaining sections
- (set! readstart (round (+ readstart (* fsr (/ winlen time-val)))))))
- ;; Set readin position and sampling rate
- (set! (mus-location f-a) readstart)
- (set! (mus-increment rdA) srate-val)
- (mus-reset rdA)
- (if stereo-i
- (begin
- (set! (mus-location f-b) readstart)
- (set! (mus-increment rdB) srate-val)
- (mus-reset rdB)))
- ;; Write window out
- (do ((k 0 (+ 1 k))
- (i writestart (+ i 1)))
- ((or eow-flag (= k winsamps)))
- (if (> i end)
- (begin
- (set! eow-flag #t)
- (set! overlap (+ 1 overlaps)))
- (let* ((amp-val (env ampf))
- (loc-val (env locf))
- (win-val (oscil windf))
- (sampa (* (src rdA) win-val))
- (sampb (if stereo-i (* (src rdB) win-val))))
- ;; channel panning
- (if stereo-o
- (let ((apan (sqrt loc-val))
- (bpan (sqrt (- 1 loc-val))))
- (if stereo-i
- (begin
- ;; stereo in and out
- (set! outa-val (* amp-val apan sampa))
- (set! outb-val (* amp-val bpan sampb)))
- (begin
- ;; mono in, stereo out
- (set! outa-val (* amp-val apan sampa))
- (set! outb-val (* amp-val bpan sampa)))))
- ;; stereo in, mono out
- (if stereo-i
- (set! outa-val (* amp-val (+ sampa sampb) .75))
- ;; mono in, mono out
- (set! outa-val (* amp-val sampa))))
- ;; output
- (outa i outa-val)
- (if stereo-o
- (begin
- (outb i outb-val)
- (if *reverb* (outa i (* rev-val outa-val) *reverb*)))))))
- (if (and (not eow-flag) ;; For first section, have to backup readstart
- (= section 0)
- (> overlap 0)
- (not time-ptr))
- (set! readstart (- readstart (round (* fsr winlen overlap-ratio-compl)))))
- (set! writestart (+ writestart winsamps))))))))
-
-
-
+ (do ((overlap 0 (+ 1 overlap)))
+ ((or eow-flag (= overlap overlaps)))
+ (set! overlap-ratio (/ overlap overlaps))
+ (set! overlap-ratio-compl (- 1 overlap-ratio))
+ (set! eow-flag #f)
+ (set! writestart beg)
+ (set! (mus-location ampf) beg)
+ (set! (mus-location locf) beg)
+ (do ((section 0 (+ 1 section)))
+ ((or eow-flag (= overlap overlaps)))
+ (set! (mus-location timef) writestart)
+ (set! (mus-location sratef) writestart)
+ (set! (mus-location wsizef) writestart)
+ (set! wsize (env wsizef))
+ (let* ((winlen (if (= overlap 0 section) ; first section of first overlap isn't randomized
+ wsize
+ (+ wsize (random randw))))
+ (winsamps (seconds->samples winlen))
+ (srate-val (env sratef)))
+ (let ((time-val (env timef)))
+ ;; Even for the first section's truncated envelopes, the frequency of the envelope must be as if the envelope were full duration.
+ (set! (mus-frequency windf) (* .5 (/ fsr winsamps)))
+ ;; Set windowing oscillator to starting phase and appropriate frequency to provide half-sine envelope over window.
+ ;; Phase must be altered for first envelope of each overlap stream.
+ (set! (mus-phase windf)
+ (if (and (= section 0)
+ (not (= overlap 0)))
+ (* .5 clmsw-2pi overlap-ratio-compl)
+ 0.0))
+ ;; Either use the absolute time pointer or a scaled increment.
+ ;; If first section in scaled mode, must initialize section readstart to beginning plus first overlap position.
+ ;; In both cases, need to alter readstart and length of first section's windows based on phase of overlap
+ (if time-ptr
+ ;; TIME-PTR mode
+ (if (= section 0)
+ ;; initial section
+ (let ((overlap-start
+ (if (and window-offset
+ (not (= overlap 0)))
+ ;; Csound style - start each overlap series further into the soundfile
+ (round (* winlen overlap-ratio-compl))
+ ;; Alternative style - start each overlap series at 0
+ 0))
+ ;; To match csound version, first section must start reading at 0. Using zero-start-time-ptr
+ ;; flag = #f, however, allows first section to start as determined by time-ptr instead.
+ (adj-time-val (if zero-start-time-ptr 0.0 time-val)))
+ (set! readstart (round (* fsr (+ inputbeg overlap-start adj-time-val))))
+ (if (not (= overlap 0)) (set! winsamps (floor (* winsamps overlap-ratio)))))
+ ;; remaining sections
+ (set! readstart (round (* fsr (+ inputbeg time-val)))))
+ ;; STRETCH mode
+ (if (= section 0)
+ ;; initial section
+ (let ((init-read-start
+ (if (and window-offset
+ (not (= overlap 0)))
+ ;; Csound style - start each overlap series further into the soundfile
+ (round (* winlen overlap-ratio-compl))
+ ;; Alternative style - start each overlap series at 0
+ 0)))
+ (set! readstart (round (* fsr (+ inputbeg init-read-start))))
+ (if (not (= overlap 0)) (set! winsamps (floor (* winsamps overlap-ratio)))))
+ ;; remaining sections
+ (set! readstart (round (+ readstart (* fsr (/ winlen time-val))))))))
+ ;; Set readin position and sampling rate
+ (set! (mus-location f-a) readstart)
+ (set! (mus-increment rdA) srate-val)
+ (mus-reset rdA)
+ (if stereo-i
+ (begin
+ (set! (mus-location f-b) readstart)
+ (set! (mus-increment rdB) srate-val)
+ (mus-reset rdB)))
+ ;; Write window out
+ (do ((k 0 (+ 1 k))
+ (i writestart (+ i 1)))
+ ((or eow-flag (= k winsamps)))
+ (if (> i end)
+ (begin
+ (set! eow-flag #t)
+ (set! overlap (+ 1 overlaps)))
+ (let* ((amp-val (env ampf))
+ (loc-val (env locf))
+ (win-val (oscil windf))
+ (sampa (* (src rdA) win-val))
+ (sampb (if stereo-i (* (src rdB) win-val))))
+ ;; channel panning
+ (if stereo-o
+ (let ((apan (sqrt loc-val))
+ (bpan (sqrt (- 1 loc-val))))
+ (set! outa-val (* amp-val apan sampa))
+ (set! outb-val (* amp-val bpan (if stereo-i sampb sampa))))
+ ;; stereo in, mono out
+ (set! outa-val (* amp-val (if stereo-i
+ (* (+ sampa sampb) .75)
+ ;; mono in, mono out
+ sampa))))
+ ;; output
+ (outa i outa-val)
+ (if stereo-o
+ (begin
+ (outb i outb-val)
+ (if *reverb* (outa i (* rev-val outa-val) *reverb*)))))))
+ (if (and (not eow-flag) ;; For first section, have to backup readstart
+ (= section 0)
+ (> overlap 0)
+ (not time-ptr))
+ (set! readstart (- readstart (round (* fsr winlen overlap-ratio-compl)))))
+ (set! writestart (+ writestart winsamps)))))))
diff --git a/special-menu.scm b/special-menu.scm
index a2f762b..435e558 100644
--- a/special-menu.scm
+++ b/special-menu.scm
@@ -87,57 +87,50 @@ See the TiMidity home page at http://www.onicos.com/staff/iz/timidity/ for more
(define (cp-play-panned)
(play-panned play-panned-file))
-(if (or (provided? 'xm)
- (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! play-panned-menu-label (add-to-menu special-menu play-panned-label cp-play-panned))
(begin
(define (post-play-panned-dialog)
- (if (not play-panned-dialog)
- (let ((initial-play-panned-file 1)
- (sliders ()))
-
- (set! play-panned-dialog
- (make-effect-dialog
- play-panned-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-play-panned))
- (lambda (w context info) (cp-play-panned)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Play panned"
- "Move the slider to select the file to play with panning envelope."))
- (lambda (w context info)
- (help-dialog "Play panned"
- "Move the slider to select the file to play with panning envelope.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! play-panned-file initial-play-panned-file)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) play-panned-file)
- )
- (lambda (w c i)
- (set! play-panned-file initial-play-panned-file)
- ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) play-panned-file))))))
-
- (set! sliders
- (add-sliders
- play-panned-dialog
- (list (list "soundfile number" 0 initial-play-panned-file 25
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (set! play-panned-file ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info)
- (set! play-panned-file ((*motif* '.value) info))))
- 1))))))
-
+ (unless play-panned-dialog
+ (let ((initial-play-panned-file 1)
+ (sliders ()))
+
+ (set! play-panned-dialog
+ (make-effect-dialog play-panned-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-play-panned))
+ (lambda (w context)
+ (help-dialog "Play panned" "Move the slider to select the file to play with panning envelope."))
+ (lambda (w data)
+ (set! play-panned-file initial-play-panned-file)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) play-panned-file)))
+ (values (lambda (w context info)
+ (cp-play-panned))
+ (lambda (w context info)
+ (help-dialog "Play panned" "Move the slider to select the file to play with panning envelope."))
+ (lambda (w c i)
+ (set! play-panned-file initial-play-panned-file)
+ ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) play-panned-file)))))))
+ (set! sliders
+ (add-sliders
+ play-panned-dialog
+ (list (list "soundfile number" 0 initial-play-panned-file 25
+
+ (if (provided? 'snd-gtk)
+ (lambda (w context)
+ (set! play-panned-file ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info)
+ (set! play-panned-file ((*motif* '.value) info))))
+ 1))))))
+
(activate-dialog play-panned-dialog))
+
+ (set! play-panned-menu-label (add-to-menu special-menu "Play panned" post-play-panned-dialog))))
+
- (set! play-panned-menu-label (add-to-menu special-menu "Play panned" post-play-panned-dialog)))
-
- (set! play-panned-menu-label (add-to-menu special-menu play-panned-label cp-play-panned)))
(set! special-list (cons (lambda ()
(let ((new-label (format #f "Play panned (~D)" play-panned-file)))
@@ -161,59 +154,56 @@ See the TiMidity home page at http://www.onicos.com/staff/iz/timidity/ for more
(save-sound-as "tmp.wav" save-as-mp3-wav-file-number :header-type mus-riff)
(system (format #f "bladeenc tmp.wav tmp-~D.mp3" save-as-mp3-wav-file-number)))
-(if (or (provided? 'xm)
- (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! save-as-mp3-menu-label (add-to-menu special-menu save-as-mp3-label cp-save-as-mp3))
(begin
(define (post-save-as-mp3-dialog)
- (if (not save-as-mp3-dialog)
-
- (let ((initial-save-as-mp3-wav-file-number 0)
- (sliders ()))
- (set! save-as-mp3-dialog
- (make-effect-dialog
- save-as-mp3-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-save-as-mp3))
- (lambda (w context info) (cp-save-as-mp3)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Save as MP3"
- "Move the slider to select the file to save as an MP3. \
+ (unless save-as-mp3-dialog
+
+ (let ((initial-save-as-mp3-wav-file-number 0)
+ (sliders ()))
+ (set! save-as-mp3-dialog
+ (make-effect-dialog save-as-mp3-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-save-as-mp3))
+ (lambda (w context)
+ (help-dialog "Save as MP3"
+ "Move the slider to select the file to save as an MP3. \
The new MP3 will be named tmp-N.mp3 by default. Bladeenc is currently the only supported encoder. \
Please see the Web page at bladeenc.mp3.no for details regarding Bladeenc."))
- (lambda (w context info)
- (help-dialog "Save as MP3"
- "Move the slider to select the file to save as an MP3. \
+ (lambda (w data)
+ (set! save-as-mp3-wav-file-number
+ initial-save-as-mp3-wav-file-number)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders))
+ save-as-mp3-wav-file-number)))
+ (values (lambda (w context info)
+ (cp-save-as-mp3))
+ (lambda (w context info)
+ (help-dialog "Save as MP3"
+ "Move the slider to select the file to save as an MP3. \
The new MP3 will be named tmp-N.mp3 by default. Bladeenc is currently the only supported encoder. \
-Please see the Web page at bladeenc.mp3.no for details regarding Bladeenc.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! save-as-mp3-wav-file-number initial-save-as-mp3-wav-file-number)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) save-as-mp3-wav-file-number)
- )
- (lambda (w c i)
- (set! save-as-mp3-wav-file-number initial-save-as-mp3-wav-file-number)
- ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) save-as-mp3-wav-file-number))))))
-
- (set! sliders
- (add-sliders
- save-as-mp3-dialog
- (list (list "soundfile number" 0 initial-save-as-mp3-wav-file-number 250
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! save-as-mp3-wav-file-number ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info)
- (set! save-as-mp3-wav-file-number ((*motif* '.value) info))))
- 1))))))
+Please see the Web page at bladeenc.mp3.no for details regarding Bladeenc."))
+ (lambda (w c i)
+ (set! save-as-mp3-wav-file-number
+ initial-save-as-mp3-wav-file-number)
+ ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) save-as-mp3-wav-file-number)))))))
+ (set! sliders
+ (add-sliders
+ save-as-mp3-dialog
+ (list (list "soundfile number" 0 initial-save-as-mp3-wav-file-number 250
+ (if (provided? 'snd-gtk)
+ (lambda (w data)
+ (set! save-as-mp3-wav-file-number ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info)
+ (set! save-as-mp3-wav-file-number ((*motif* '.value) info))))
+ 1))))))
(activate-dialog save-as-mp3-dialog))
-
- (set! save-as-mp3-menu-label (add-to-menu special-menu "Save as MP3" post-save-as-mp3-dialog)))
-
- (set! save-as-mp3-menu-label (add-to-menu special-menu save-as-mp3-label cp-save-as-mp3)))
+
+ (set! save-as-mp3-menu-label (add-to-menu special-menu "Save as MP3" post-save-as-mp3-dialog))))
+
(set! special-list (cons (lambda ()
(let ((new-label (format #f "Save as MP3 (~D)" save-as-mp3-wav-file-number)))
@@ -235,60 +225,57 @@ Please see the Web page at bladeenc.mp3.no for details regarding Bladeenc.")))
(save-sound-as "tmp.wav" save-as-ogg-wav-file-number :header-type mus-riff)
(system (format #f "oggenc tmp.wav -o tmp-~D.ogg" save-as-ogg-wav-file-number)))
-(if (or (provided? 'xm)
- (provided? 'xg))
+(if (not (or (provided? 'xm)
+ (provided? 'xg)))
+ (set! save-as-ogg-menu-label (add-to-menu special-menu save-as-ogg-label cp-save-as-ogg))
(begin
(define (post-save-as-ogg-dialog)
- (if (not save-as-ogg-dialog)
-
- (let ((initial-save-as-ogg-wav-file-number 0)
- (sliders ()))
-
- (set! save-as-ogg-dialog
- (make-effect-dialog
- save-as-ogg-label
-
- (if (provided? 'snd-gtk)
- (lambda (w context) (cp-save-as-ogg))
- (lambda (w context info) (cp-save-as-ogg)))
-
- (if (provided? 'snd-gtk)
- (lambda (w context)
- (help-dialog "Save as Ogg file"
- "Move the slider to select the file to save as an Ogg file. \
+ (unless save-as-ogg-dialog
+
+ (let ((initial-save-as-ogg-wav-file-number 0)
+ (sliders ()))
+
+ (set! save-as-ogg-dialog
+ (make-effect-dialog save-as-ogg-label
+ (if (provided? 'snd-gtk)
+ (values (lambda (w context)
+ (cp-save-as-ogg))
+ (lambda (w context)
+ (help-dialog "Save as Ogg file"
+ "Move the slider to select the file to save as an Ogg file. \
The new file will be named tmp-N.ogg by default. Oggenc is currently the only supported Ogg encoder. \
Please see the Web page at www.xiphophorus.org for details regarding the Ogg/Vorbis project."))
- (lambda (w context info)
- (help-dialog "Save as Ogg file"
- "Move the slider to select the file to save as an Ogg file. \
+ (lambda (w data)
+ (set! save-as-ogg-wav-file-number
+ initial-save-as-ogg-wav-file-number)
+ ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders))
+ save-as-ogg-wav-file-number)))
+ (values (lambda (w context info)
+ (cp-save-as-ogg))
+ (lambda (w context info)
+ (help-dialog "Save as Ogg file"
+ "Move the slider to select the file to save as an Ogg file. \
The new file will be named tmp-N.ogg by default. Oggenc is currently the only supported Ogg encoder. \
-Please see the Web page at www.xiphophorus.org for details regarding the Ogg/Vorbis project.")))
-
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! save-as-ogg-wav-file-number initial-save-as-ogg-wav-file-number)
- ((*gtk* 'gtk_adjustment_set_value) ((*gtk* 'GTK_ADJUSTMENT) (car sliders)) save-as-ogg-wav-file-number)
- )
- (lambda (w c i)
- (set! save-as-ogg-wav-file-number initial-save-as-ogg-wav-file-number)
- ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) save-as-ogg-wav-file-number))))))
-
- (set! sliders
- (add-sliders
- save-as-ogg-dialog
- (list (list "soundfile number" 0 initial-save-as-ogg-wav-file-number 250
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! save-as-ogg-wav-file-number ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info)
- (set! save-as-ogg-wav-file-number ((*motif* '.value) info))))
- 1))))))
+Please see the Web page at www.xiphophorus.org for details regarding the Ogg/Vorbis project."))
+ (lambda (w c i)
+ (set! save-as-ogg-wav-file-number
+ initial-save-as-ogg-wav-file-number)
+ ((*motif* 'XtSetValues) (car sliders) (list (*motif* 'XmNvalue) save-as-ogg-wav-file-number)))))))
+ (set! sliders
+ (add-sliders
+ save-as-ogg-dialog
+ (list (list "soundfile number" 0 initial-save-as-ogg-wav-file-number 250
+ (if (provided? 'snd-gtk)
+ (lambda (w data)
+ (set! save-as-ogg-wav-file-number ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info)
+ (set! save-as-ogg-wav-file-number ((*motif* '.value) info))))
+ 1))))))
(activate-dialog save-as-ogg-dialog))
-
- (set! save-as-ogg-menu-label (add-to-menu special-menu "Save as Ogg file" post-save-as-ogg-dialog)))
-
- (set! save-as-ogg-menu-label (add-to-menu special-menu save-as-ogg-label cp-save-as-ogg)))
+
+ (set! save-as-ogg-menu-label (add-to-menu special-menu "Save as Ogg file" post-save-as-ogg-dialog))))
+
(set! special-list (cons (lambda ()
(let ((new-label (format #f "Save as Ogg file (~D)" save-as-ogg-wav-file-number)))
diff --git a/spectr.scm b/spectr.scm
index aee482b..9659a28 100644
--- a/spectr.scm
+++ b/spectr.scm
@@ -6,6 +6,9 @@
(provide 'snd-spectr.scm)
+(define *spectr*
+ (let ()
+
;;; bass clarinet?
(define bc-c2 '( 1.00 .0370 1.98 .0037 2.99 .0862 3.98 .0011 4.97 .0270 5.98 .0030 6.97 .0586
7.95 .0031 8.96 .0363 9.95 .0076 10.93 .0310 11.95 .0097 12.93 .0206 13.92 .0045 14.93 .0044
@@ -3137,8 +3140,4 @@
(define almf-b6 '( 1.00 .0241 2.01 .0417 3.02 .0098 3.99 .0016 4.02 .0016 5.03 .0016 6.04 .0012))
-;;;
-;;;
-;;;
-;;;
-;;;
+(curlet)))
diff --git a/spokenword.scm b/spokenword.scm
index 1c15d19..53b0fc9 100644
--- a/spokenword.scm
+++ b/spokenword.scm
@@ -49,8 +49,7 @@
(define local-peak
(lambda (position)
- (let ((data (local-data position)))
- (float-vector-peak data))))
+ (float-vector-peak (local-data position))))
(define local-smooth
(lambda (position)
@@ -91,9 +90,9 @@
(if (and in-mark
(<= (mark-sample in-mark) position))
(delete-mark in-mark))
- (if (not out-mark)
- (add-mark position 0 0 "Out")
- (set! (mark-sample out-mark) position)))))
+ (if out-mark
+ (set! (mark-sample out-mark) position)
+ (add-mark position 0 0 "Out")))))
(define mark-in
(lambda (position)
@@ -102,9 +101,9 @@
(if (and out-mark
(>= (mark-sample out-mark) position))
(delete-mark out-mark))
- (if (not in-mark)
- (add-mark position 0 0 "In")
- (set! (mark-sample in-mark) position)))))
+ (if in-mark
+ (set! (mark-sample in-mark) position)
+ (add-mark position 0 0 "In")))))
(define delete-from-out-to-in
(lambda ()
@@ -127,8 +126,7 @@
(out-position (if out-mark (mark-sample out-mark) 0)))
(define (play-next reason)
(if (= reason 0)
- (begin
- (play (selected-sound) in-position (+ in-position preview-length)))))
+ (play (selected-sound) in-position (+ in-position preview-length))))
(if (and
in-mark
out-mark)
diff --git a/stochastic.scm b/stochastic.scm
index fac3001..9c06794 100644
--- a/stochastic.scm
+++ b/stochastic.scm
@@ -43,7 +43,7 @@
;;fill xy-array with values from init-array
(do ((iy 0 (+ iy 2));;index for reading values from init-array (a 2-dimensional list)
(jy 0 (+ jy 1)));;index for writing to xy-array (a 1-dimensional float-vector)
- ((= iy xy-array-l) xy-array)
+ ((= iy xy-array-l))
(set! (xy-array iy) ((init-array jy) 0))
(set! (xy-array (+ iy 1))
;;convert signed float y values into signed integers
@@ -52,38 +52,37 @@
(do ((i beg (+ i 1)))
((= i end))
- (if (= dx dt);;when current sample is a breakpoint
- (begin
- (set! dx (floor (xy-array (modulo m xy-array-l))))
- (set! y (xy-array (+ (modulo m xy-array-l) 1)))
- (set! prev-dx (floor (xy-array (modulo (- m 2) xy-array-l))))
- (set! dy (- y oldy))
- (set! oldy y)
- ;;straight uniform distribution for y
- (set! ydev (round (mus-random (* .01 b ywig))))
- ;;gaussian distribution for x
- (set! xdev
- (* xstep (round
- (* xwig
- (sqrt (* -2.0 (log (- 1 (random 1.0))))) ; ??
- (cos (random 6.283185307179586))))))
- (set! (xy-array (modulo m xy-array-l))
- ;;mirror stuff for x
- (cond ((or (< (round xmax) (+ dx xdev))
- (> (round xmin)(+ dx xdev)))
- (max (min ;;this mirror is attentuated
- (round (+ (* xfb prev-dx) (* (- 1 xfb) (+ dx (- xdev)))))
- (round xmax))
- (round xmin)))
- (else (round (+ (* xfb prev-dx)
- (* (- 1 xfb) (+ dx xdev)))))))
- (set! (xy-array (+ (modulo m xy-array-l) 1))
- ;;mirror stuff for y
- (cond ((or (< b (+ y ydev)) (> (- b) (+ y ydev)))
- (max (min (+ y (- ydev)) b) (- b)))
- (else (+ y ydev))))
- (set! m (+ m 2))
- (set! dt 0)))
+ (when (= dx dt);;when current sample is a breakpoint
+ (set! dx (floor (xy-array (modulo m xy-array-l))))
+ (set! y (xy-array (+ (modulo m xy-array-l) 1)))
+ (set! prev-dx (floor (xy-array (modulo (- m 2) xy-array-l))))
+ (set! dy (- y oldy))
+ (set! oldy y)
+ ;;straight uniform distribution for y
+ (set! ydev (round (mus-random (* .01 b ywig))))
+ ;;gaussian distribution for x
+ (set! xdev
+ (* xstep (round
+ (* xwig
+ (sqrt (* -2.0 (log (- 1 (random 1.0))))) ; ??
+ (cos (random 6.283185307179586))))))
+ (set! (xy-array (modulo m xy-array-l))
+ ;;mirror stuff for x
+ (cond ((or (< (round xmax) (+ dx xdev))
+ (> (round xmin)(+ dx xdev)))
+ (max (min ;;this mirror is attentuated
+ (round (+ (* xfb prev-dx) (* (- 1 xfb) (- dx xdev))))
+ (round xmax))
+ (round xmin)))
+ (else (round (+ (* xfb prev-dx)
+ (* (- 1 xfb) (+ dx xdev)))))))
+ (set! (xy-array (+ (modulo m xy-array-l) 1))
+ ;;mirror stuff for y
+ (cond ((or (< b (+ y ydev)) (> (- b) (+ y ydev)))
+ (max (min (- y ydev) b) (- b)))
+ (else (+ y ydev))))
+ (set! m (+ m 2))
+ (set! dt 0))
(set! dt (+ dt 1))
(set! j (+ j (/ dy dx)));linear interpolation
(set! output (/ j b));normalization -1 to 1
diff --git a/strad.scm b/strad.scm
index 5cf02ec..a3a3538 100644
--- a/strad.scm
+++ b/strad.scm
@@ -75,22 +75,21 @@
(b2nt -5.7147560e-002)
(a1nt -1.2158343e+000)
(a2nt 3.2555068e-001)
- (ynb 0.0e0) (ynbt 0.0e0)
- (ynn 0.0e0) (ynnt 0.0e0)
- (ya1nb 0.0e0) (ynba1 0.0e0)
- (y1nb 0.0e0)
- (vh 0.0e0)
- (aa 0.0e0) (bb1 0.0e0) (cc1 0.0e0) (delta1 0.0e0)
- (bb2 0.0e0) (cc2 0.0e0) (delta2 0.0e0)
- (v 0.0e0) (v1 0.0e0) (v2 0.0e0)
+ (ynbt 0.0)
+ (ynn 0.0) (ynnt 0.0)
+ (y1nb 0.0)
+ (vh 0.0)
+ (aa 0.0) (bb1 0.0) (cc1 0.0) (delta1 0.0)
+ (bb2 0.0) (cc2 0.0) (delta2 0.0)
+ (v 0.0) (v1 0.0) (v2 0.0)
(rhs #f) (lhs #f)
- (vtemp 0.0e0)
- (f 0.0e0)
+ (vtemp 0.0)
+ (f 0.0)
(stick 0)
;;(zslope (/ 1 (+ (/ 1 (* 2 stringImpedance)) (/ 1 (* 2 stringImpedancet)))))
(zslope (/ (* 2 stringImpedance stringImpedancet) (+ stringImpedance stringImpedancet)))
- (xnn 0.0e0) (xnb 0.0e0)
- (xnnt 0.0e0) (xnbt 0.0e0)
+ (xnn 0.0) (xnb 0.0)
+ (xnnt 0.0) (xnbt 0.0)
(alphar 0) (alphal 0)
(alphart 0) (alphalt 0)
(del_right (* len bp))
@@ -102,35 +101,31 @@
(samp_lperiodt (floor del_leftt))
(samp_rperiodt (floor del_rightt)))
- (let ((g1 (make-biquad b0b b1b b2b a1b a2b))
- (g2 (make-biquad b0n b1n b2n a1n a2n))
- (g3 (make-biquad b0bt b1bt b2bt a1bt a2bt))
- (g4 (make-biquad b0nt b1nt b2nt a1nt a2nt)))
-
- (define (bowfilt inharmon)
- (set! ynb (filter g1 vib))
- (set! ynn (filter g2 vin))
- (set! ynbt (filter g3 vibt))
- (set! ynnt (filter g4 vint))
- (if (<= inharmon 0.00001) (set! inharmon 0.00001))
- (if (>= inharmon 0.9999) (set! inharmon 0.9999))
- (set! y1nb (+ (* -1 inharmon ynb) ynba1 (* inharmon ya1nb)))
- (set! ya1nb y1nb)
- (set! ynba1 ynb)
- (set! y1nb (- y1nb))
- (set! ynn (- ynn))
- (set! ynbt (- ynbt)))
+ (define bowfilt
+ (let ((g1 (make-biquad b0b b1b b2b a1b a2b))
+ (g2 (make-biquad b0n b1n b2n a1n a2n))
+ (g3 (make-biquad b0bt b1bt b2bt a1bt a2bt))
+ (g4 (make-biquad b0nt b1nt b2nt a1nt a2nt))
+ (ya1nb 0.0) (ynba1 0.0) (ynb 0.0))
+ (lambda (inharmon)
+ (set! ynb (filter g1 vib))
+ (set! ynn (filter g2 vin))
+ (set! ynbt (filter g3 vibt))
+ (set! ynnt (filter g4 vint))
+ (set! inharmon (min 0.9999 (max inharmon 0.00001)))
+ (set! y1nb (- (+ ynba1 (* inharmon ya1nb)) (* inharmon ynb)))
+ (set! ya1nb y1nb)
+ (set! ynba1 ynb)
+ (set! y1nb (- y1nb))
+ (set! ynn (- ynn))
+ (set! ynbt (- ynbt)))))
- (if (< samp_rperiod 0) (set! samp_rperiod 0))
- (if (> samp_rperiod (- bufsize 1)) (set! samp_rperiod (- bufsize 1)))
- (if (< samp_lperiod 0) (set! samp_lperiod 0))
- (if (> samp_lperiod (- bufsize 1)) (set! samp_lperiod (- bufsize 1)))
+ (set! samp_rperiod (min (- bufsize 1) (max samp_rperiod 0)))
+ (set! samp_lperiod (min (- bufsize 1) (max samp_lperiod 0)))
(set! alphar (* 1.0 (- del_right samp_rperiod)))
(set! alphal (* 1.0 (- del_left samp_lperiod)))
- (if (< samp_rperiodt 0)(set! samp_rperiodt 0))
- (if (> samp_rperiodt (- bufsize 1)) (set! samp_rperiodt (- bufsize 1)))
- (if (< samp_lperiodt 0) (set! samp_lperiodt 0))
- (if (> samp_lperiodt (- bufsize 1)) (set! samp_lperiodt (- bufsize 1)))
+ (set! samp_rperiodt (min (- bufsize 1) (max samp_rperiodt 0)))
+ (set! samp_lperiodt (min (- bufsize 1) (max samp_lperiodt 0)))
(set! alphart (* 1.0 (- del_rightt samp_rperiodt)))
(set! alphalt (* 1.0 (- del_leftt samp_lperiodt)))
(set! posr (modulo (floor (+ end posr)) bufsize))
@@ -159,18 +154,26 @@
(do ((i beg (+ i 1)))
((= i end))
- (set! vib (+ (/ (* (vinbridge indexl_2) (- alphal 1) (- alphal 2)) 2)
- (* (vinbridge indexl_1) alphal -1 (- alphal 2))
- (/ (* (vinbridge indexl) alphal (- alphal 1)) 2)))
- (set! vin (+ (/ (* (vinut indexr_2) (- alphar 1) (- alphar 2)) 2)
- (* (vinut indexr_1) alphar -1 (- alphar 2))
- (/ (* (vinut indexr) (- alphar 1) alphar) 2)))
- (set! vibt (+ (/ (* (vinbridget indexlt_2) (- alphalt 1)(- alphalt 2)) 2)
- (* (vinbridget indexlt_1) alphalt -1 (- alphalt 2))
- (/ (* (vinbridget indexlt) alphalt (- alphalt 1)) 2)))
- (set! vint (+ (/ (* (vinutt indexrt_2) (- alphart 1) (- alphart 2)) 2)
- (* (vinutt indexrt_1) alphart -1 (- alphart 2))
- (/ (* (vinutt indexrt) (- alphart 1) alphart) 2)))
+ (set! vib (- (/ (+ (* (vinbridge indexl_2) (- alphal 1) (- alphal 2))
+ (* (vinbridge indexl) alphal (- alphal 1)))
+ 2)
+ (* (vinbridge indexl_1) alphal (- alphal 2))))
+
+ (set! vin (- (/ (+ (* (vinut indexr_2) (- alphar 1) (- alphar 2))
+ (* (vinut indexr) (- alphar 1) alphar))
+ 2)
+ (* (vinut indexr_1) alphar (- alphar 2))))
+
+ (set! vibt (- (/ (+ (* (vinbridget indexlt_2) (- alphalt 1) (- alphalt 2))
+ (* (vinbridget indexlt) alphalt (- alphalt 1)))
+ 2)
+ (* (vinbridget indexlt_1) alphalt (- alphalt 2))))
+
+ (set! vint (- (/ (+ (* (vinutt indexrt_2) (- alphart 1) (- alphart 2))
+ (* (vinutt indexrt) (- alphart 1) alphart))
+ 2)
+ (* (vinutt indexrt_1) alphart (- alphart 2))))
+
(bowfilt inharm)
(set! vh (+ ynn y1nb ynnt ynbt))
@@ -178,7 +181,7 @@
(set! bb1 (- (+ (* 0.2 zslope) (* 0.3 fb)) (* zslope vb) (* zslope vh)))
(set! cc1 (- (+ (* 0.06 fb) (* zslope vh vb)) (* 0.2 zslope vh) (* 0.3 vb fb)))
(set! delta1 (- (* bb1 bb1) (* 4 aa cc1)))
- (set! bb2 (- (- (* -0.2 zslope) (* 0.3 fb)) (* zslope vb) (* zslope vh)))
+ (set! bb2 (- (* -0.2 zslope) (* 0.3 fb) (* zslope vb) (* zslope vh)))
(set! cc2 (+ (* 0.06 fb)
(* zslope vh vb)
(* 0.2 zslope vh)
@@ -201,62 +204,58 @@
(set! rhs #f)
(set! lhs #t)))
(if rhs
- (begin
- (if (< delta1 0)
+ (if (< delta1 0)
+ (begin
+ (set! v vb)
+ (set! stick 1))
+ (if (= stick 1)
+ (begin
+ (set! vtemp vb)
+ (set! f (* 2 zslope (- vtemp vh)))
+ (if (>= f (- (* mus fb)))
+ (set! v vtemp)
+ (begin
+ (set! v1 (/ (- (sqrt delta1) bb1) (* 2 aa)))
+ (set! v2 (/ (- (+ bb1 (sqrt delta1))) (* 2 aa)))
+ (set! v (min v1 v2))
+ (set! stick 0))))
+ (begin
+ (set! v1 (/ (- (sqrt delta1) bb1) (* 2 aa)))
+ (set! v2 (/ (- (+ bb1 (sqrt delta1))) (* 2 aa)))
+ (set! v (min v1 v2))
+ (set! stick 0))))
+ (when lhs
+ (if (< delta2 0)
(begin
(set! v vb)
(set! stick 1))
- (begin
- (if (= stick 1)
- (begin
- (set! vtemp vb)
- (set! f (* 2 zslope (- vtemp vh)))
- (if (>= f (* -1 mus fb))
- (set! v vtemp)
- (begin
- (set! v1 (/ (+ (- bb1) (sqrt delta1)) (* 2 aa)))
- (set! v2 (/ (- (- bb1) (sqrt delta1)) (* 2 aa)))
- (set! v (min v1 v2))
- (set! stick 0))))
- (begin
- (set! v1 (/ (+ (- bb1) (sqrt delta1)) (* 2 aa)))
- (set! v2 (/ (- (- bb1) (sqrt delta1)) (* 2 aa)))
- (set! v (min v1 v2))
- (set! stick 0))))))
- (if lhs
- (begin
- (if (< delta2 0)
- (begin
- (set! v vb)
- (set! stick 1))
+ (if (= stick 1)
(begin
- (if (= stick 1)
+ (set! vtemp vb)
+ (set! f (* zslope (- vtemp vh)))
+ (if (and (<= f (* mus fb)) (> f 0))
+ (set! v vtemp)
(begin
- (set! vtemp vb)
- (set! f (* zslope (- vtemp vh)))
- (if (and (<= f (* mus fb)) (> f 0))
- (set! v vtemp)
+ (set! v1 (/ (- (+ bb2 (sqrt delta2))) (* 2 aa)))
+ (set! v2 (/ (- (sqrt delta2) bb2) (* 2 aa)))
+ (set! vtemp (min v1 v2))
+ (set! stick 0)
+ (if (> vtemp vb)
(begin
- (set! v1 (/ (- (- bb2) (sqrt delta2)) (* 2 aa)))
- (set! v2 (/ (+ (- bb2) (sqrt delta2)) (* 2 aa)))
- (set! vtemp (min v1 v2))
- (set! stick 0)
- (if (> vtemp vb)
- (begin
- (set! v vb)
- (set! stick 1))
- (begin
- (set! v vtemp)
- (set! f (* zslope (- v vh) )))))))
- (begin
- (set! v1 (/ (- (- bb2) (sqrt delta2)) (* 2 aa)))
- (set! v2 (/ (+ (- bb2) (sqrt delta2)) (* 2 aa)))
- (set! v (min v1 v2))
- (set! stick 0)))))
- (if (> v vb)
+ (set! v vb)
+ (set! stick 1))
+ (begin
+ (set! v vtemp)
+ (set! f (* zslope (- v vh) )))))))
(begin
- (set! v vb)
- (set! stick 1))))))))
+ (set! v1 (/ (- (+ bb2 (sqrt delta2))) (* 2 aa)))
+ (set! v2 (/ (- (sqrt delta2) bb2) (* 2 aa)))
+ (set! v (min v1 v2))
+ (set! stick 0))))
+ (if (> v vb)
+ (begin
+ (set! v vb)
+ (set! stick 1)))))))
(set! f (* zslope (- v vh)))
(set! xnn (+ y1nb (/ f (* 2 stringImpedance))))
(set! xnb (+ ynn (/ f (* 2 stringImpedance))))))
@@ -290,7 +289,7 @@
(locsig loc i (* xnb (env ampf)))
(set! lhs #f)
- (set! rhs #f))))))))
+ (set! rhs #f)))))))
;(with-sound (:channels 2) (bow 0 3 400 0.5 :vb 0.15 :fb 0.1 :inharm 0.25))
;(with-sound (:channels 2) (bow 0 2 440 0.5 :fb 0.25))
diff --git a/stuff.scm b/stuff.scm
index 7747b81..04e5e67 100644
--- a/stuff.scm
+++ b/stuff.scm
@@ -3,18 +3,17 @@
(provide 'stuff.scm)
(when (provided? 'pure-s7)
- (define (let->list e) (reverse! (map values e)))
- (define (memq a b) (member a b eq?))
- (define (assq a b) (assoc a b eq?)))
+ (define (let->list e) (reverse! (map values e))))
;;; ----------------
(define empty?
(let ((documentation "(empty? obj) returns #t if obj is an empty sequence"))
(lambda (obj)
- (if (hash-table? obj)
- (zero? (hash-table-entries obj)) ; length here is table size
- (eqv? (length obj) 0)))))
+ (and (not (pair? obj))
+ (if (hash-table? obj)
+ (zero? (hash-table-entries obj)) ; length here is table size
+ (eqv? (length obj) 0))))))
(define applicable? arity)
@@ -28,10 +27,58 @@
(define (ow!)
(call-with-output-string
- (lambda (p)
- (do ((e (outlet (owlet)) (outlet e)))
- ((eq? e (rootlet)))
- (format p "~{~A ~}~%" e)))))
+ (lambda (p)
+ (let ((ow (owlet))
+ (elist (list (rootlet))))
+
+ ;; show current error data
+ (format p "error: ~A" (ow 'error-type))
+ (let ((info (ow 'error-data)))
+ (if (and (pair? info)
+ (string? (car info)))
+ (format p ": ~A" (apply format #f info))
+ (if (not (null? info))
+ (format p ": ~A" info))))
+
+ (format p "~%error-code: ~S~%" (ow 'error-code))
+ (when (ow 'error-line)
+ (format p "~%error-file/line: ~S[~A]~%" (ow 'error-file) (ow 'error-line)))
+
+ ;; show history, if available
+ (when (pair? (ow 'error-history)) ; a circular list, starts at error-code, entries stored backwards
+ (let ((history ())
+ (lines ())
+ (files ())
+ (start (ow 'error-history)))
+ (do ((x (cdr start) (cdr x))
+ (i 0 (+ i 1)))
+ ((or (eq? x start)
+ (null? (car x))
+ (= i (*s7* 'history-size)))
+ (format p "~%error-history:~% ~S" (car start))
+ (do ((x history (cdr x))
+ (line lines (cdr line))
+ (f files (cdr f)))
+ ((null? x))
+ (format p (if (and (integer? (car line))
+ (string? (car f))
+ (not (string=? (car f) "*stdout*")))
+ (values "~% ~S~40T;~A[~A]" (car x) (car f) (car line))
+ (values "~% ~S" (car x)))))
+ (format p "~%"))
+ (set! history (cons (car x) history))
+ (set! lines (cons (pair-line-number (car x)) lines))
+ (set! files (cons (pair-filename (car x)) files)))))
+
+ ;; show the enclosing contexts
+ (let ((old-print-length (*s7* 'print-length)))
+ (set! (*s7* 'print-length) 8)
+ (do ((e (outlet ow) (outlet e)))
+ ((memq e elist)
+ (set! (*s7* 'print-length) old-print-length))
+ (if (> (length e) 0)
+ (format p "~%~{~A~| ~}~%" e))
+ (set! elist (cons e elist))))))))
#|
(set! (hook-functions *error-hook*)
@@ -84,8 +131,8 @@
(let ((documentation "(make-circular-list n init) returns a circular list with n entries initialized to init:\n\
(make-circular-list 3 #f) -> #1=(#f #f #f . #1#)"))
(lambda* (n init)
- (let ((l (make-list n init)))
- (set-cdr! (list-tail l (- n 1)) l)))))
+ (let ((lst (make-list n init)))
+ (set-cdr! (list-tail lst (- n 1)) lst)))))
(define circular-list
(let ((documentation "(circular-list . objs) returns a circular list with objs:\n\
@@ -105,14 +152,12 @@
(let ((documentation " (linearize lst) turns a circular list into normal list:\n\
(linearize (circular-list 1 2)) -> '(1 2)"))
(lambda (lst)
- (define (lin-1 lst result sofar)
- (if (or (not (pair? lst))
- (memq lst sofar))
- (reverse! result)
- (lin-1 (cdr lst)
- (cons (car lst) result)
- (cons lst sofar))))
- (lin-1 lst () ()))))
+ (let lin-1 ((lst lst)
+ (result ())
+ (sofar ()))
+ (if (or (not (pair? lst)) (memq lst sofar))
+ (reverse! result)
+ (lin-1 (cdr lst) (cons (car lst) result) (cons lst sofar)))))))
(define cyclic?
(let ((documentation "(cyclic obj) returns #t if the sequence obj contains any cycles"))
@@ -148,24 +193,36 @@
(else #f)))
+;;; this used to be built into s7.c, but no one uses it.
+(define-macro (multiple-value-set! vars expr . body)
+ (if (pair? vars)
+ (let ((local-vars (map (lambda (n) (gensym)) vars)))
+ `((lambda ,local-vars
+ ,@(map (lambda (n ln) `(set! ,n ,ln)) vars local-vars)
+ , at body)
+ ,expr))
+ (if (and (null? vars) (null? expr))
+ `(begin , at body)
+ (error "multiple-value-set! vars/exprs messed up"))))
+
+
;;; ----------------
(define-macro (fully-macroexpand form)
- (define (expand form)
- (if (pair? form)
- (if (and (symbol? (car form))
- (macro? (symbol->value (car form))))
- (expand (apply macroexpand (list form)))
- (if (and (eq? (car form) 'set!) ; look for (set! (mac ...) ...) and use mac's procedure-setter
- (pair? (cdr form))
- (pair? (cadr form))
- (macro? (symbol->value (caadr form))))
- (expand (apply (eval (procedure-source (procedure-setter (symbol->value (caadr form)))))
- (append (cdadr form) (cddr form))))
- (cons (expand (car form))
- (expand (cdr form)))))
- form))
- (list 'quote (expand form)))
+ (list 'quote
+ (let expand ((form form))
+ (cond ((not (pair? form)) form)
+ ((and (symbol? (car form))
+ (macro? (symbol->value (car form))))
+ (expand (apply macroexpand (list form))))
+ ((and (eq? (car form) 'set!) ; look for (set! (mac ...) ...) and use mac's procedure-setter
+ (pair? (cdr form))
+ (pair? (cadr form))
+ (macro? (symbol->value (caadr form))))
+ (expand (apply (eval (procedure-source (procedure-setter (symbol->value (caadr form)))))
+ (append (cdadr form) (cddr form)))))
+ (else (cons (expand (car form))
+ (expand (cdr form))))))))
(define-macro (define-with-macros name&args . body)
`(apply define ',name&args (list (fully-macroexpand `(begin ,, at body)))))
@@ -198,7 +255,7 @@
(define-macro (rotatef . places)
(let ((tmp (gensym))
- (last (car (list-tail places (- (length places) 1)))))
+ (last (places (- (length places) 1))))
`(let ((,tmp ,(car places)))
,@(map (lambda (a b)
`(set! ,a ,b))
@@ -230,34 +287,68 @@
`(for-each define ',args (iota (length ',args))))
(define-macro (destructuring-bind lst expr . body) ; if only there were some use for this!
- `(let ,(letrec ((flatten (lambda (lst1 lst2 args)
- (cond ((null? lst1) args)
- ((not (pair? lst1))
- (cons (list lst1 lst2) args))
- (#t (flatten (car lst1) (car lst2)
- (flatten (cdr lst1) (cdr lst2) args)))))))
- (flatten lst (eval expr) ()))
+ `(let ,(let flatten ((lst1 lst)
+ (lst2 (eval expr))
+ (args ()))
+ (cond ((null? lst1) args)
+ ((not (pair? lst1)) (cons (list lst1 lst2) args))
+ (else (flatten (car lst1) (car lst2)
+ (flatten (cdr lst1) (cdr lst2) args)))))
, at body))
-(define-macro (and-let* vars . body)
- `(let () ; bind vars, if any is #f stop, else evaluate body with those bindings
- (and ,@(map (lambda (var)
- `(begin
- (apply define ',var)
- ,(car var)))
- vars)
- (begin , at body))))
+(define-macro (and-let* vars . body) ; bind vars, if any is #f stop, else evaluate body with those bindings
+ `(let () (and ,@(map (lambda (v) `(define , at v)) vars) (begin , at body))))
-(define-macro (while test . body) ; while loop with predefined break and continue
+(define-macro (let*-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (with-let orig
+ ,@(map (lambda (v)
+ `(set! ,(car v) ,(cadr v)))
+ vars)
+ , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
+(define-macro (let-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars))
+ :new (#_list ,@(map cadr vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () ; this could be (with-let orig (let ,vars , at body)) but I want to handle stuff like individual vector locations
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1)))))))
+ vars)
+ (with-let orig , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
+(define-macro (while test . body) ; while loop with predefined break and continue
`(call-with-exit
(lambda (break)
- (letrec ((continue (lambda ()
- (if (let () ,test)
- (begin
- (let () , at body)
- (continue))
- (break)))))
- (continue)))))
+ (let continue ()
+ (if (let () ,test)
+ (begin
+ (let () , at body)
+ (continue))
+ (break))))))
(define-macro (do* spec end . body)
`(let* (,@(map (lambda (var)
@@ -283,10 +374,10 @@
(let ((select (gensym)))
`(let ((,select ,key))
(cond ,@(map (lambda (lst)
- (if (pair? (car lst))
+ (if (not (pair? (car lst)))
+ lst
(cons `(member ,select (list ,@(car lst)))
- (cdr lst))
- lst))
+ (cdr lst))))
clauses)))))
@@ -381,12 +472,18 @@ If func approves of one, index-if returns the index that gives that element's po
(define every?
(let ((documentation "(every? func sequence) returns #t if func approves of every member of sequence"))
(lambda (f sequence)
- (not (member #f sequence (lambda (a b) (not (f b))))))))
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (arg) (if (not (f arg)) (return #f))) sequence)
+ #t)))))
(define any?
(let ((documentation "(any? func sequence) returns #t if func approves of any member of sequence"))
(lambda (f sequence)
- (member #f sequence (lambda (a b) (f b))))))
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (arg) (if (f arg) (return #t))) sequence)
+ #f)))))
(define collect-if
(let ((documentation "(collect-if type func sequence) gathers the elements of sequence that satisfy func, and returns them via type:\n\
@@ -419,15 +516,13 @@ If func approves of one, index-if returns the index that gives that element's po
(if (sequence? sequence)
(call-with-exit
(lambda (return)
- (letrec ((full-find-if-1
- (lambda (seq)
- (for-each (lambda (x)
- (if (f x)
- (return x)
- (if (sequence? x)
- (full-find-if-1 x))))
- seq))))
- (full-find-if-1 sequence))
+ (let full-find-if-1 ((seq sequence))
+ (for-each
+ (lambda (x)
+ (if (f x)
+ (return x)
+ (if (sequence? x) (full-find-if-1 x))))
+ seq))
#f))
(error "full-find-if second argument, ~A, is not a sequence" sequence))
(error "full-find-if first argument, ~A, is not a procedure of one argument" f)))))
@@ -473,11 +568,6 @@ If func approves of one, index-if returns the index that gives that element's po
(cycles (cyclic-sequences obj))
(seen-cycles ()))
- (define (iter-memq p q)
- (and (pair? q)
- (or (eq? p (iterator-sequence (car q)))
- (iter-memq p (cdr q)))))
-
(define (make-careful-iterator p)
(if (not (pair? p))
(make-iterator p)
@@ -508,28 +598,35 @@ If func approves of one, index-if returns the index that gives that element's po
(set! cur #<eof>)
result))))))))))
- (let ((iter (make-careful-iterator obj)))
- (let ((iterator? #t))
- (define (iterloop) ; define returns the new value
- (let ((result (iter)))
- (if (length result)
- (if (or (memq result seen-cycles) ; we've dealt with it already, so skip it
- (eq? result (iterator-sequence iter))
- (iter-memq result iters)) ; we're dealing with it the right now
- (iterloop) ; this means the outermost sequence is ignored if encountered during the traversal
- (begin
- (set! iters (cons iter iters))
- (set! iter (make-careful-iterator result))
- result))
- (if (eq? result #<eof>)
- (if (null? iters)
- #<eof>
- (begin
- (set! seen-cycles (cons (iterator-sequence iter) seen-cycles))
- (set! iter (car iters))
- (set! iters (cdr iters))
- (iterloop)))
- result)))))))))
+ (let ((iter (make-careful-iterator obj))
+ (iterator? #t))
+ (define (iterloop) ; define returns the new value
+ (define (iter-memq p q)
+ (and (pair? q)
+ (or (eq? p (iterator-sequence (car q)))
+ (iter-memq p (cdr q)))))
+ (let ((result (iter)))
+ (cond ((length result)
+ (if (or (memq result seen-cycles) ; we've dealt with it already, so skip it
+ (eq? result (iterator-sequence iter))
+ (iter-memq result iters)) ; we're dealing with it the right now
+ (iterloop) ; this means the outermost sequence is ignored if encountered during the traversal
+ (begin
+ (set! iters (cons iter iters))
+ (set! iter (make-careful-iterator result))
+ result)))
+
+ ((not (eq? result #<eof>))
+ result)
+
+ ((null? iters)
+ #<eof>)
+
+ (else
+ (set! seen-cycles (cons (iterator-sequence iter) seen-cycles))
+ (set! iter (car iters))
+ (set! iters (cdr iters))
+ (iterloop)))))))))
(define safe-find-if
@@ -539,10 +636,9 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(let ((iter (make-complete-iterator sequence)))
(let loop ((x (iter)))
(if (f x) x
- (if (and (eq? x #<eof>)
- (iterator-at-end? iter))
- #f
- (loop (iter)))))))))
+ (and (not (and (eq? x #<eof>)
+ (iterator-at-end? iter)))
+ (loop (iter)))))))))
(define (safe-count-if f sequence)
;; currently the complete-iterator above skips repetitions, including the outer sequence,
@@ -584,9 +680,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(if (pair? sequences)
(for-each (lambda (obj)
(if (every? (lambda (seq)
- (find-if (lambda (x)
- (equal? x obj))
- seq))
+ (member? obj seq))
(cdr sequences))
(set! lst (cons obj lst))))
(car sequences)))
@@ -608,24 +702,24 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(let ((documentation "(asymmetric-difference type . sequences) returns the elements in the rest of the sequences that are not in the first:\n\
(asymmetric-difference vector '(1 2 3) #(2 3 4) '(1 5)) -> #(4 5)"))
(lambda (type . sequences) ; complement, elements in B's not in A
- (if (and (pair? sequences)
- (pair? (cdr sequences)))
+ (if (not (and (pair? sequences)
+ (pair? (cdr sequences))))
+ (type)
(collect-if type (lambda (obj)
(not (member obj (car sequences))))
- (apply union list (cdr sequences)))
- (apply type ())))))
+ (apply union list (cdr sequences)))))))
(define cl-set-difference
(let ((documentation "(cl-set-difference type .sequences) returns the elements in the first sequence that are not in the rest of the sequences:\n\
(cl-set-difference vector '(1 2 3) #(2 3 4) '(1 5)) -> #()"))
(lambda (type . sequences) ; CL: elements in A not in B's
- (if (and (pair? sequences)
- (pair? (cdr sequences)))
+ (if (not (and (pair? sequences)
+ (pair? (cdr sequences))))
+ (type)
(let ((others (apply union list (cdr sequences))))
(collect-if type (lambda (obj)
(not (member obj others)))
- (car sequences)))
- (apply type ())))))
+ (car sequences)))))))
(define symmetric-difference
(let ((documentation "(symmetric-difference type .sequences) returns the elements that are in an odd number of the sequences:\n\
@@ -641,16 +735,12 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define power-set
(let ((documentation "(power-set type . sequences) returns the power set of the union of the elements in the sequences."))
(lambda (type . sequences) ; ignoring repeats
- (letrec ((pset (lambda (set)
- (if (null? set)
- '(())
- (let ((rest (pset (cdr set))))
- (append rest (map (lambda (subset)
- (cons (car set) subset))
- rest)))))))
- (apply type (pset (apply union list sequences)))))))
-
-
+ (apply type
+ (let pset ((set (apply union list sequences)))
+ (if (null? set)
+ '(())
+ (let ((rest (pset (cdr set))))
+ (append rest (map (lambda (subset) (cons (car set) subset)) rest)))))))))
;;; ----------------
(define ->predicate
@@ -741,15 +831,14 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define (log-none-of . ints) ; bits on in none of ints
(lognot (apply logior ints)))
-(define (log-all-of . ints) ; bits on in all of ints
- (apply logand ints))
-
-(define (log-any-of . ints) ; bits on in at least 1 of ints
- (apply logior ints))
+(define log-all-of logand) ; bits on in all of ints
+(define log-any-of logior) ; bits on in at least 1 of ints
(define (log-n-of n . ints) ; return the bits on in exactly n of ints
- (if (integer? n)
- (if (every? integer? ints)
+ (if (not (integer? n))
+ (error "log-n-of first argument, ~A, should be an integer" n)
+ (if (not (every? integer? ints))
+ (error "log-n-of ints arguments, ~A, should all be integers" ints)
(let ((len (length ints)))
(cond ((= len 0) (if (= n 0) -1 0))
((= n 0) (lognot (apply logior ints)))
@@ -758,19 +847,19 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(#t
(do ((1s 0)
(prev ints)
+ (nxt (cdr ints))
+ (ln (- len 1))
+ (nn (- n 1))
(i 0 (+ i 1)))
((= i len) 1s)
(let ((cur (ints i)))
(if (= i 0)
- (set! 1s (logior 1s (logand cur (apply log-n-of (- n 1) (cdr ints)))))
- (let* ((mid (cdr prev))
- (nxt (if (= i (- len 1)) () (cdr mid))))
- (set! (cdr prev) nxt)
- (set! 1s (logior 1s (logand cur (apply log-n-of (- n 1) ints))))
+ (set! 1s (logior 1s (logand cur (apply log-n-of nn nxt))))
+ (let ((mid (cdr prev)))
+ (set! (cdr prev) (if (= i ln) () (cdr mid)))
+ (set! 1s (logior 1s (logand cur (apply log-n-of nn ints))))
(set! (cdr prev) mid)
- (set! prev mid))))))))
- (error "log-n-of ints arguments, ~A, should all be integers" ints))
- (error "log-n-of first argument, ~A, should be an integer" n)))
+ (set! prev mid)))))))))))
;; from Rick
(define (byte siz pos) ;; -> cache size, position and mask.
@@ -963,22 +1052,23 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define for-each-subset
(let ((documentation "(for-each-subset func args) forms each subset of args, then applies func to the subsets that fit its arity"))
(lambda (func args)
- (define (subset source dest len)
- (if (null? source)
- (if (aritable? func len) ; does this subset fit?
- (apply func dest))
- (begin
- (subset (cdr source) (cons (car source) dest) (+ len 1))
- (subset (cdr source) dest len))))
- (subset args () 0))))
+ (let subset ((source args)
+ (dest ())
+ (len 0))
+ (if (null? source)
+ (if (aritable? func len)
+ (apply func dest))
+ (begin
+ (subset (cdr source) (cons (car source) dest) (+ len 1))
+ (subset (cdr source) dest len)))))))
(define for-each-permutation
(let ((documentation "(for-each-permutation func vals) applies func to every permutation of vals:\n\
- (for-each-permutation (lambda args (format #t \"~{~A~^ ~}~%\" args)) '(1 2 3))"))
+ (for-each-permutation (lambda args (format () \"~{~A~^ ~}~%\" args)) '(1 2 3))"))
(lambda (func vals)
(define (pinner cur nvals len)
(if (= len 1)
- (apply func (cons (car nvals) cur))
+ (apply func (car nvals) cur)
(do ((i 0 (+ i 1))) ; I suppose a named let would be more Schemish
((= i len))
(let ((start nvals))
@@ -1004,8 +1094,10 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define n-choose-k
(let ((documentation "(n-choose-k n k) returns the binomial coefficient C(N,K)"))
(lambda (n k)
- (if (integer? n)
- (if (integer? k)
+ (if (not (integer? n))
+ (error "n-choose-k 'n argument, ~A, should be an integer" n)
+ (if (not (integer? k))
+ (error "n-choose-k 'k argument, ~A, should be an integer" k)
(let ((mn (min k (- n k))))
(if (or (negative? mn)
(negative? n))
@@ -1016,12 +1108,8 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(cnk (+ 1 mx)))
(do ((i 2 (+ i 1)))
((> i mn) cnk)
- (set! cnk (/ (* cnk (+ mx i)) i)))))))
- (error "n-choose-k 'k argument, ~A, should be an integer" k))
- (error "n-choose-k 'n argument, ~A, should be an integer" n)))))
-
-
-
+ (set! cnk (/ (* cnk (+ mx i)) i))))))))))))
+
;;; ----------------
(define continuable-error
@@ -1071,19 +1159,19 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
;;; ----------------
(define* (flatten-let e (n -1))
- (if (let? e)
- (let ((slots ()))
- (do ((pe e (outlet pe))
- (i 0 (+ i 1)))
- ((or (eq? pe (rootlet))
- (= i n))
- (apply inlet slots))
- (for-each (lambda (slot)
- (if (and (not (assq (car slot) slots))
- (not (constant? (car slot)))) ; immutable symbol
- (set! slots (cons slot slots))))
- pe)))
- (error "flatten-let argument, ~A, is not a let" e)))
+ (if (not (let? e))
+ (error "flatten-let argument, ~A, is not a let" e)
+ (do ((slots ())
+ (pe e (outlet pe))
+ (i 0 (+ i 1)))
+ ((or (eq? pe (rootlet))
+ (= i n))
+ (apply inlet slots))
+ (for-each (lambda (slot)
+ (if (not (or (assq (car slot) slots)
+ (constant? (car slot)))) ; immutable symbol
+ (set! slots (cons slot slots))))
+ pe))))
(define* (owlets (ows 1)) (flatten-let (owlet) ows))
@@ -1131,37 +1219,45 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
;;; ----------------
(define (gather-symbols expr ce lst ignore)
- (define (symbol->let sym ce)
- (if (defined? sym ce #t)
- ce
- (and (not (eq? ce (rootlet)))
- (symbol->let sym (outlet ce)))))
- (if (symbol? expr)
- (if (and (not (memq expr lst))
- (not (memq expr ignore))
- (not (procedure? (symbol->value expr ce)))
- (not (eq? (symbol->let expr ce) (rootlet))))
- (cons expr lst)
- lst)
- (if (pair? expr)
- (if (and (pair? (cdr expr))
- (pair? (cddr expr)))
- (if (pair? (cadr expr))
- (if (memq (car expr) '(let let* letrec letrec* do))
- (gather-symbols (cddr expr) ce lst (append ignore (map car (cadr expr))))
- (if (eq? (car expr) 'lambda)
- (gather-symbols (cddr expr) ce lst (append ignore (cadr expr)))
- (if (eq? (car expr) 'lambda*)
- (gather-symbols (cddr expr) ce lst (append ignore (map (lambda (a) (if (pair? a) (car a) a)) (cadr expr))))
- (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore))))
- (if (and (eq? (car expr) 'lambda)
- (symbol? (cadr expr)))
- (gather-symbols (cddr expr) ce lst (append ignore (list (cadr expr))))
- (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore)))
- (if (eq? (car expr) '_)
- (cons expr lst)
- (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore)))
- lst)))
+ (cond ((symbol? expr)
+ (if (or (memq expr lst)
+ (memq expr ignore)
+ (procedure? (symbol->value expr ce))
+ (eq? (let symbol->let ((sym expr)
+ (ce ce))
+ (if (defined? sym ce #t)
+ ce
+ (and (not (eq? ce (rootlet)))
+ (symbol->let sym (outlet ce)))))
+ (rootlet)))
+ lst
+ (cons expr lst)))
+
+ ((not (pair? expr)) lst)
+
+ ((not (and (pair? (cdr expr)) (pair? (cddr expr))))
+ (if (eq? (car expr) '_)
+ (cons expr lst)
+ (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore)))
+
+ ((pair? (cadr expr))
+ (gather-symbols (case (car expr)
+ ((let let* letrec letrec* do)
+ (values (cddr expr) ce lst (append ignore (map car (cadr expr)))))
+ ((lambda)
+ (values (cddr expr) ce lst (append ignore (cadr expr))))
+ ((lambda*)
+ (values (cddr expr) ce lst (append ignore (map (lambda (a) (if (pair? a) (car a) a)) (cadr expr)))))
+ (else
+ (values (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore)))))
+
+ ((and (eq? (car expr) 'lambda)
+ (symbol? (cadr expr)))
+ (gather-symbols (cddr expr) ce lst (append ignore (list (cadr expr)))))
+
+ (else
+ (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore))))
+
(define-bacro (reactive-set! place value)
(with-let (inlet 'place place ; with-let here gives us control over the names
@@ -1184,10 +1280,10 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(with-let (sublet ,ne ',sym ,nv)
(set! ,place ,value))
,nv)))
- (if (or (not (eq? (car sym) '_))
- (not (pair? (cdr sym)))
- (not (integer? (cadr sym)))
- (not (null? (cddr sym))))
+ (if (not (and (eq? (car sym) '_)
+ (pair? (cdr sym))
+ (integer? (cadr sym))
+ (null? (cddr sym))))
(error 'wrong-type-arg "reactive-vector can't handle: ~S~%" sym)
(let ((index (cadr sym)))
`(set! (_ 'local-set!)
@@ -1313,9 +1409,9 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(if (not (memq sym setters))
(set! setters (cons sym setters)))
(let ((prev (assq sym accessors)))
- (if (not prev)
- (set! accessors (cons (cons sym `((set! ,(car bd) (,fname ,v)))) accessors))
- (set-cdr! prev (append `((set! ,(car bd) (,fname ,v))) (cdr prev)))))))
+ (if prev
+ (set-cdr! prev (append `((set! ,(car bd) (,fname ,v))) (cdr prev)))
+ (set! accessors (cons (cons sym `((set! ,(car bd) (,fname ,v)))) accessors))))))
syms)
(set! bindings (cons bd bindings))))
vars)
@@ -1346,13 +1442,13 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
setters)
(let ,(reverse bindings)
,@(map (lambda (sa)
- (if (not (assq (car sa) bindings))
+ (if (assq (car sa) bindings)
+ (values)
`(set! (symbol-access ',(car sa))
(lambda (,(gensym) ,v)
(,(rlet-symbol (car sa)) ,v)
,@(cdr sa)
- ,v))
- (values)))
+ ,v))))
accessors)
,@(map (lambda (ns)
`(set! (symbol-access ',(car ns))
@@ -1362,12 +1458,11 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define-macro (reactive-let* vars . body)
- (define (add-let v)
+ (let add-let ((v vars))
(if (pair? v)
`(reactive-let ((,(caar v) ,(cadar v)))
,(add-let (cdr v)))
- `(begin , at body)))
- (add-let vars))
+ `(begin , at body))))
;; reactive-letrec is not useful: lambdas already react and anything else is an error (use of #<undefined>)
@@ -1522,11 +1617,10 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
;;; ----------------
(define-macro (catch* clauses . error)
- (define (builder lst)
+ (let builder ((lst clauses))
(if (null? lst)
(apply values error)
- `(catch #t (lambda () ,(car lst)) (lambda args ,(builder (cdr lst))))))
- (builder clauses))
+ `(catch #t (lambda () ,(car lst)) (lambda args ,(builder (cdr lst)))))))
(define* (subsequence obj (start 0) end)
@@ -1534,44 +1628,41 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(new-len (- (min len (or end len)) start)))
(if (negative? new-len)
(error 'out-of-range "end: ~A should be greater than start: ~A" end start))
-
+
(cond ((vector? obj)
(make-shared-vector obj (list new-len) start))
-
- ((string? obj)
- (if end
- (substring obj start end)
- (substring obj start)))
-
- ((pair? obj)
- (if (not end)
- (cdr* obj start)
- (let ((lst (make-list new-len #f)))
- (do ((i 0 (+ i 1)))
- ((= i new-len) lst)
- (set! (lst i) (obj (+ i start)))))))
-
- (else ; (subsequence (inlet 'subsequence (lambda* (obj start end) "subseq")))
- (catch*
- (((obj 'subsequence) obj start end)
- (subsequence (obj 'value) start end))
- #f)))))
+
+ ((string? obj)
+ (if end
+ (substring obj start end)
+ (substring obj start)))
+
+ ((not (pair? obj))
+ (catch* (((obj 'subsequence) obj start end)
+ (subsequence (obj 'value) start end))
+ #f))
+
+ ((not end)
+ (cdr* obj start))
+
+ (else
+ (let ((lst (make-list new-len #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i new-len) lst)
+ (set! (lst i) (obj (+ i start)))))))))
(define (sequence->string val)
- (if (or (not (sequence? val))
- (empty? val))
- (format #f "~S" val)
- (cond ((vector? val)
- (format #f "#(~{~A~| ~})" val))
- ((let? val)
- (format #f "(inlet ~{'~A~| ~})" val))
- ((hash-table? val)
- (format #f "(hash-table ~{'~A~| ~})" val))
- ((string? val)
- (format #f (if (byte-vector? val) "#u8(~{~D~| ~})" "\"~{~A~|~}\"") val))
- (else
- (format #f "(~{~A~| ~})" val)))))
+ (format #f
+ (cond ((or (not (sequence? val))
+ (empty? val)) "~S")
+ ((vector? val) "#(~{~A~| ~})")
+ ((let? val) "(inlet ~{'~A~| ~})")
+ ((hash-table? val) "(hash-table ~{'~A~| ~})")
+ ((not (string? val)) "(~{~A~| ~})")
+ ((byte-vector? val) "#u8(~{~D~| ~})")
+ (else "\"~{~A~|~}\""))
+ val))
;;; ----------------
@@ -1591,8 +1682,8 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
;;; ----------------
-(if (and (not (defined? 'apropos))
- (not (provided? 'snd)))
+(if (not (or (defined? 'apropos)
+ (provided? 'snd)))
(define* (apropos name (port *stdout*) (e (rootlet)))
(let ((ap-name (if (string? name)
name
@@ -1646,14 +1737,6 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(define (prepend-spaces)
(format *display* (format #f "~~~DC" spaces) #\space))
- (define (display-format str . args)
- `(let ((,vlp (*s7* 'print-length)))
- (with-let (funclet Display)
- (set! (*s7* 'print-length) *display-print-length*)
- (prepend-spaces))
- (format (Display-port) ,str , at args)
- (set! (*s7* 'print-length) ,vlp)))
-
(define (display-let le e)
(let ((vlp (*s7* 'print-length)))
(for-each
@@ -1668,11 +1751,11 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(set! (*s7* 'print-length) vlp)))
(define (last lst)
- (let ((len (length lst)))
- (let ((end (list-tail lst (if (negative? len) (abs len) (- len 1)))))
- (if (pair? end)
- (car end)
- end))))
+ (let* ((len (length lst))
+ (end (list-tail lst (if (negative? len) (abs len) (- len 1)))))
+ (if (pair? end)
+ (car end)
+ end)))
(define* (butlast lst (result ()))
(if (or (not (pair? lst))
@@ -1691,23 +1774,32 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(reverse lst)
(append (reverse lst) args))))
- (define (walk-let-body source)
- (let ((previous (butlast source))
- (end (last source)))
- `(begin
- , at previous
- (let ((,result ,end))
- (with-let (funclet Display)
- (prepend-spaces))
- (format (Display-port) " ~A~A) -> ~A~%"
- ,(if (pair? previous) " ... " "")
- ',end
- ,result)
- ,result))))
-
(define (proc-walk source)
- (if (pair? source)
+ (define (display-format str . args)
+ `(let ((,vlp (*s7* 'print-length)))
+ (with-let (funclet Display)
+ (set! (*s7* 'print-length) *display-print-length*)
+ (prepend-spaces))
+ (format (Display-port) ,str , at args)
+ (set! (*s7* 'print-length) ,vlp)))
+
+ (define (walk-let-body source)
+ (let ((previous (butlast source))
+ (end (last source)))
+ `(begin
+ , at previous
+ (let ((,result ,end))
+ (with-let (funclet Display)
+ (prepend-spaces))
+ (format (Display-port) " ~A~A) -> ~A~%"
+ ,(if (pair? previous) " ... " "")
+ ',end
+ ,result)
+ ,result))))
+
+ (if (not (pair? source))
+ source
(case (car source)
((let let* letrec letrec*)
@@ -1727,22 +1819,22 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
((or and)
;; report form that short-circuits the evaluation
- (append (list (car source))
- (let ((ctr -1)
- (len (- (length (cdr source)) 1))
- (eob (if (eq? (car source) 'or) 'when 'unless)))
- (map (lambda (expr)
- (set! ctr (+ ctr 1))
- `(let ((,result ,expr))
- (,eob ,result
- (format (Display-port) " (~A ~A~A~A) -> ~A~%"
- ',(car source)
- ,(if (> ctr 0) " ... " "")
- ',expr
- ,(if (< ctr len) " ... " "")
- ,result))
- ,result))
- (cdr source)))))
+ (cons (car source)
+ (let ((ctr -1)
+ (len (- (length source) 2))
+ (eob (if (eq? (car source) 'or) 'when 'unless)))
+ (map (lambda (expr)
+ (set! ctr (+ ctr 1))
+ `(let ((,result ,expr))
+ (,eob ,result
+ (format (Display-port) " (~A ~A~A~A) -> ~A~%"
+ ',(car source)
+ ,(if (> ctr 0) " ... " "")
+ ',expr
+ ,(if (< ctr len) " ... " "")
+ ,result))
+ ,result))
+ (cdr source)))))
((begin with-let with-baffle)
;; report last form
@@ -1783,7 +1875,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
((cond)
;; report form that satisifies cond
(let ((ctr -1)
- (len (- (length (cdr source)) 1)))
+ (len (- (length source) 2)))
`(cond ,@(map (lambda (clause)
(let ((test (car clause))
(body (cdr clause)))
@@ -1809,7 +1901,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
((case)
;; as in cond but include selector value in [] and report fall throughs
(let ((ctr -1)
- (len (- (length (cddr source)) 1))
+ (len (- (length source) 3))
(default (member '(else #t) (cddr source) (lambda (a b)
(memq (car b) a)))))
`(case ,(cadr source)
@@ -1837,67 +1929,70 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
,result)
,result)))))
(cddr source))
- (if (not default)
+ (if default
+ ()
`((else
(format (Display-port) " (case [~A] falls through~%" ,(cadr source))
- #<unspecified>))
- ())))))
+ #<unspecified>)))))))
((dynamic-wind)
;; here we want to ignore the first and last clauses, and report the last of the second
- (let ((l2 (caddr source)))
- (let* ((body (and (eq? (car l2) 'lambda)
- (cddr l2)))
- (previous (and body (butlast body)))
- (end (and body (last body))))
- (if (not body)
- source
- `(dynamic-wind
- ,(cadr source)
- (lambda ()
- , at previous
- (let ((,result ,end))
- (format (Display-port) "(dynamic-wind ... ~A) -> ~A~%" ',end ,result)
- ,result))
- ,(cadddr source))))))
+ (let* ((p (caddr source))
+ (body (and (eq? (car p) 'lambda)
+ (cddr p)))
+ (previous (and body (butlast body)))
+ (end (and body (last body))))
+ (if (not body)
+ source
+ `(dynamic-wind
+ ,(cadr source)
+ (lambda ()
+ , at previous
+ (let ((,result ,end))
+ (format (Display-port) "(dynamic-wind ... ~A) -> ~A~%" ',end ,result)
+ ,result))
+ ,(cadddr source)))))
(else
(cons (proc-walk (car source))
- (proc-walk (cdr source)))))
- source))
+ (proc-walk (cdr source)))))))
+
(define-macro (Display-1 definition)
- (if (and (pair? definition)
- (memq (car definition) '(define define*))
- (pair? (cdr definition))
- (pair? (cadr definition)))
+ (if (not (and (pair? definition)
+ (memq (car definition) '(define define*))
+ (pair? (cdr definition))
+ (pair? (cadr definition))))
+
+ ;; (Display <anything-else>)
+ (proc-walk definition) ; (Display (+ x 1)) etc
;; (Display (define (f ...) ...)
(let ((func (caadr definition))
(args (cdadr definition))
(body `(begin ,@(proc-walk (cddr definition)))))
;(format *stderr* "~A ~A ~A~%" func args body)
- (let* ((no-noise-args (remove-keys args)) ; omit noise words like :optional
- (arg-names (if (null? args)
- ()
- (if (proper-list? args) ; handle (f x ...), (f (x 1) ...), (f . x), and (f x . z)
- (map (lambda (a)
- (if (symbol? a) a (car a))) ; omit the default values
- no-noise-args)
- (if (pair? args)
- (append (butlast no-noise-args) (list :rest (last args)))
- (list :rest args)))))
- (call-args (if (null? args)
- ()
- (if (proper-list? args)
- (if (memq :rest args)
- (append (butlast (butlast no-noise-args)) ; also omit the :rest
- (list (list '{apply_values} (last args))))
- arg-names) ; (... y x)
- (if (pair? args)
- (append (butlast no-noise-args) ; (... y ({apply_values} x))
- (list (list '{apply_values} (last args))))
- (list (list '{apply_values} args))))))) ; (... ({apply_values} x))
+ (let* ((no-noise-args (remove-keys args)) ; omit noise words like :optional
+ (arg-names (cond ((null? args)
+ ())
+ ((proper-list? args) ; handle (f x ...), (f (x 1) ...), (f . x), and (f x . z)
+ (map (lambda (a)
+ (if (symbol? a) a (car a))) ; omit the default values
+ no-noise-args))
+ ((pair? args)
+ (append (butlast no-noise-args) (list :rest (last args))))
+ (else (list :rest args))))
+ (call-args (cond ((null? args)
+ ())
+ ((proper-list? args)
+ (if (memq :rest args)
+ (append (butlast (butlast no-noise-args)) ; also omit the :rest
+ (list (list '{apply_values} (last args))))
+ arg-names)) ; (... y x)
+ ((pair? args)
+ (append (butlast no-noise-args) ; (... y ({apply_values} x))
+ (list (list '{apply_values} (last args)))))
+ (else (list (list '{apply_values} args)))))) ; (... ({apply_values} x))
`(define ,func
(define-macro* ,(cons (gensym) args) ; args might be a symbol etc
`((lambda* ,(cons ',e ',arg-names) ; prepend added env arg because there might be a rest arg
@@ -1921,10 +2016,8 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(set! spaces (- spaces *display-spacing*)) ; unindent
(prepend-spaces))
(format (Display-port) " -> ~S~%" ,',result)))))
- (curlet) ,, at call-args))))) ; pass in the original args and the curlet
+ (curlet) ,, at call-args))))))) ; pass in the original args and the curlet
- ;; (Display <anything-else>)
- (proc-walk definition))) ; (Display (+ x 1)) etc
(set! Display Display-1)) ; make Display-1 globally accessible
@@ -1979,50 +2072,50 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(let ((dir (opendir name)))
(if (equal? dir NULL)
(error "can't open ~S: ~S" name (strerror (errno)))
- (let ((iterator? #t)
- (dirs ())
- (dir-names ())
- (dir-name name))
- (define* (reader quit) ; returned from with-let
- (if (eq? quit #<eof>) ; caller requests cleanup and early exit
- (begin ; via ((iterator-sequence iter) #<eof>)
- (closedir dir)
- (for-each closedir dirs)
- (set! dirs ())
- quit)
- (let ((file (read_dir dir)))
- (if (zero? (length file)) ; null filename => all done
- (begin
- (closedir dir)
- (if (null? dirs)
- #<eof>
- (begin ; else pop back to outer dir
- (set! dir (car dirs))
- (set! dirs (cdr dirs))
- (set! dir-name (car dir-names))
- (set! dir-names (cdr dir-names))
- (reader))))
- (if (not (member file '("." "..") string=?))
- (let ((full-dir-name (string-append dir-name "/" file)))
- (if (and recursive
- (reader-cond
- ((defined? 'directory?)
- (directory? full-dir-name))
- (#t (let ((buf (stat.make)))
- (let ((result (and (stat full-dir-name buf)
- (S_ISDIR (stat.st_mode buf)))))
- (free buf)
- result)))))
- (let ((new-dir (opendir full-dir-name)))
- (if (equal? new-dir NULL) ; inner directory is unreadable?
- (begin
- (format *stderr* "can't read ~S: ~S" file (strerror (errno)))
- (reader))
- (begin
- (set! dirs (cons dir dirs))
- (set! dir new-dir)
- (set! dir-names (cons dir-name dir-names))
- (set! dir-name full-dir-name)
- (reader))))
- (string-append dir-name "/" file)))
- (reader)))))))))))))
\ No newline at end of file
+ (let ((iterator? #t))
+ (define reader
+ (let ((dirs ())
+ (dir-names ())
+ (dir-name name))
+ (lambda* (quit) ; returned from with-let
+ (if (eq? quit #<eof>) ; caller requests cleanup and early exit
+ (begin ; via ((iterator-sequence iter) #<eof>)
+ (closedir dir)
+ (for-each closedir dirs)
+ (set! dirs ())
+ quit)
+ (let ((file (read_dir dir)))
+ (if (zero? (length file)) ; null filename => all done
+ (begin
+ (closedir dir)
+ (if (null? dirs)
+ #<eof>
+ (begin ; else pop back to outer dir
+ (set! dir (car dirs))
+ (set! dirs (cdr dirs))
+ (set! dir-name (car dir-names))
+ (set! dir-names (cdr dir-names))
+ (reader))))
+ (if (member file '("." "..") string=?)
+ (reader)
+ (let ((full-dir-name (string-append dir-name "/" file)))
+ (if (and recursive
+ (reader-cond
+ ((defined? 'directory?)
+ (directory? full-dir-name))
+ (#t (let* ((buf (stat.make))
+ (result (and (stat full-dir-name buf)
+ (S_ISDIR (stat.st_mode buf)))))
+ (free buf)
+ result))))
+ (let ((new-dir (opendir full-dir-name)))
+ (if (equal? new-dir NULL) ; inner directory is unreadable?
+ (format *stderr* "can't read ~S: ~S" file (strerror (errno)))
+ (begin
+ (set! dirs (cons dir dirs))
+ (set! dir new-dir)
+ (set! dir-names (cons dir-name dir-names))
+ (set! dir-name full-dir-name)))
+ (reader))
+ (string-append dir-name "/" file)))))))))))))))))
+
diff --git a/tools/compsnd b/tools/compsnd
index 27963f3..487d81e 100755
--- a/tools/compsnd
+++ b/tools/compsnd
@@ -13,6 +13,7 @@ fgrep maake *.html
fgrep accomoda *.c
fgrep decrip *.scm
fgrep accomoda *.scm
+fgrep reponse *.[ch]
fgrep -e "the the " *.c
fgrep -e "the the " *.html
fgrep udpate *.c
@@ -58,9 +59,6 @@ gcc s7.c -o repl -Wall -DWITH_MAIN -DUSE_SND=0 -I. -O2 -g3 -Wl,-export-dynamic -
echo '#define WITH_SYSTEM_EXTRAS 0' >mus-config.h
cc -c s7.c -o s7.o -Wall
rm s7.o
-echo '#define WITH_QUASIQUOTE_VECTOR 1' >mus-config.h
-cc -c s7.c -o s7.o -Wall
-rm s7.o
echo '#define WITH_C_LOADER 0' >mus-config.h
cc -c s7.c -o s7.o -Wall
rm s7.o
diff --git a/tools/ffitest.c b/tools/ffitest.c
index 09b3442..96c5df9 100644
--- a/tools/ffitest.c
+++ b/tools/ffitest.c
@@ -844,7 +844,7 @@ int main(int argc, char **argv)
free(s1);
s7_set_car(c1234, s7_make_symbol(sc, "+"));
- p = s7_eval(sc, s7_list(sc, 2, s7_make_symbol(sc, "quote"), c1234), s7_sublet(sc, s7_rootlet(sc), s7_nil(sc)));
+ p = s7_eval(sc, c1234, s7_sublet(sc, s7_rootlet(sc), s7_nil(sc)));
if (s7_integer(p) != 9)
{fprintf(stderr, "%d: (eval '(+ 2 3 4)) is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
p = s7_eval_form(sc, c1234, s7_sublet(sc, s7_rootlet(sc), s7_nil(sc)));
@@ -1236,6 +1236,50 @@ int main(int argc, char **argv)
s7_close_input_port(sc, port);
s7_gc_unprotect_at(sc, gc_loc);
+ /* make sure s7_read does not ignore #<eof> */
+ port = s7_open_input_string(sc, "(define aaa 32)\n(define bbb 33)\n");
+ if (!s7_is_input_port(sc, port))
+ {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
+ gc_loc = s7_gc_protect(sc, port);
+ while(true)
+ {
+ s7_pointer code;
+ code = s7_read(sc, port);
+ if (code == s7_eof_object(sc)) break;
+ s7_eval(sc, code, s7_nil(sc));
+ }
+ s7_close_input_port(sc, port);
+ s7_gc_unprotect_at(sc, gc_loc);
+
+ port = s7_open_input_string(sc, "(define ccc 34)\n(define ddd 35)");
+ if (!s7_is_input_port(sc, port))
+ {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
+ gc_loc = s7_gc_protect(sc, port);
+ while(true)
+ {
+ s7_pointer code;
+ code = s7_read(sc, port);
+ if (code == s7_eof_object(sc)) break;
+ s7_eval(sc, code, s7_nil(sc));
+ }
+ s7_close_input_port(sc, port);
+ s7_gc_unprotect_at(sc, gc_loc);
+ {
+ s7_pointer val;
+ val = s7_name_to_value(sc, "aaa");
+ if ((!s7_is_integer(val)) || (s7_integer(val) != 32))
+ fprintf(stderr, "aaa: %s\n", s7_object_to_c_string(sc, val));
+ val = s7_name_to_value(sc, "bbb");
+ if ((!s7_is_integer(val)) || (s7_integer(val) != 33))
+ fprintf(stderr, "bbb: %s\n", s7_object_to_c_string(sc, val));
+ val = s7_name_to_value(sc, "ccc");
+ if ((!s7_is_integer(val)) || (s7_integer(val) != 34))
+ fprintf(stderr, "ccc: %s\n", s7_object_to_c_string(sc, val));
+ val = s7_name_to_value(sc, "ddd");
+ if ((!s7_is_integer(val)) || (s7_integer(val) != 35))
+ fprintf(stderr, "ddd: %s\n", s7_object_to_c_string(sc, val));
+ }
+
port = s7_open_output_string(sc);
if (!s7_is_output_port(sc, port))
{fprintf(stderr, "%d: %s is not an output port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
@@ -1460,7 +1504,8 @@ int main(int argc, char **argv)
}
{
- s7_pointer old_port, result;
+ int gc_loc1;
+ s7_pointer old_port, result, func;
const char *errmsg = NULL;
s7_define_function(sc, "error-handler", test_error_handler, 1, 0, false, "our error handler");
@@ -1489,6 +1534,54 @@ int main(int argc, char **argv)
s7_set_current_error_port(sc, old_port);
s7_gc_unprotect_at(sc, gc_loc);
+
+ old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
+ gc_loc = s7_gc_protect(sc, old_port);
+
+ func = s7_eval_c_string(sc, "(lambda (x) (+ x 1))");
+ result = s7_call(sc, func, s7_list(sc, 1, s7_make_integer(sc, 2)));
+ if ((!s7_is_integer(result)) || (s7_integer(result) != 3))
+ {fprintf(stderr, "%d: s7_call (x+1) result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
+
+ result = s7_call(sc, func, s7_list(sc, 1, s7_make_vector(sc, 0)));
+ if (result != s7_make_symbol(sc, "our-error"))
+ {fprintf(stderr, "%d: s7_call error hook result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
+ errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
+ if ((errmsg) && (*errmsg))
+ {
+ if (strcmp(errmsg, "error!") != 0)
+ fprintf(stderr, "%d: error: %s\n", __LINE__, errmsg);
+ }
+ else fprintf(stderr, "%d: no error!\n", __LINE__);
+
+ s7_close_output_port(sc, s7_current_error_port(sc));
+ s7_set_current_error_port(sc, old_port);
+ s7_gc_unprotect_at(sc, gc_loc);
+
+
+ old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
+ gc_loc = s7_gc_protect(sc, old_port);
+
+ func = s7_eval_c_string(sc, "(let ((x 0)) (list (lambda () (set! x 1)) (lambda () (set! x (+ x #()))) (lambda () (set! x (+ x 1))) (lambda () x)))");
+ gc_loc1 = s7_gc_protect(sc, func);
+ result = s7_dynamic_wind(sc, s7_car(func), s7_cadr(func), s7_caddr(func));
+
+ if (result != s7_make_symbol(sc, "our-error"))
+ {fprintf(stderr, "%d: s7_dynamic_wind error hook result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
+ errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
+ if ((errmsg) && (*errmsg))
+ {
+ if (strcmp(errmsg, "error!") != 0)
+ fprintf(stderr, "%d: error: %s\n", __LINE__, errmsg);
+ }
+ else fprintf(stderr, "%d: no error!\n", __LINE__);
+
+ s7_close_output_port(sc, s7_current_error_port(sc));
+ s7_set_current_error_port(sc, old_port);
+ s7_gc_unprotect_at(sc, gc_loc);
+ s7_gc_unprotect_at(sc, gc_loc1);
+
+
s7_eval_c_string(sc, "(set! (hook-functions *error-hook*) ())");
}
diff --git a/tools/gdbinit b/tools/gdbinit
index f4ea14e..a6e8862 100644
--- a/tools/gdbinit
+++ b/tools/gdbinit
@@ -1,5 +1,5 @@
define s7print
-print s7_object_to_c_string(sc, $arg0)
+print s7_object_to_c_string(hidden_sc, $arg0)
end
document s7print
interpret the argument as an s7 value and display it
@@ -13,7 +13,7 @@ end
define s7eval
-print s7_object_to_c_string(sc, s7_eval_c_string(sc, $arg0))
+print s7_object_to_c_string(hidden_sc, s7_eval_c_string(hidden_sc, $arg0))
end
document s7eval
eval the argument (a string)
@@ -21,7 +21,7 @@ end
define s7stack
-print s7_object_to_c_string(sc, s7_stacktrace(sc))
+print s7_object_to_c_string(hidden_sc, s7_stacktrace(sc))
end
document s7stack
display the currently active local environments
@@ -29,7 +29,7 @@ end
define s7value
-print s7_object_to_c_string(sc, s7_name_to_value(sc, $arg0))
+print s7_object_to_c_string(hidden_sc, s7_name_to_value(hidden_sc, $arg0))
end
document s7value
print the value of the variable passed by its print name: s7v "*features*"
@@ -69,7 +69,7 @@ define s7cell
set $type = $cell.tf.type_field
set $is_bad_type = (($type <= T_FREE) || ($type >= NUM_TYPES))
- printf "%s\n", describe_type_bits(sc, $cell)
+ printf "%s\n", describe_type_bits(hidden_sc, $cell)
printf "hloc: %d, ", $cell.hloc
printf "fields: %p %p %p %p %p\n",\
diff --git a/tools/gldata.scm b/tools/gldata.scm
index 8a07875..fcc5a3d 100644
--- a/tools/gldata.scm
+++ b/tools/gldata.scm
@@ -1,6 +1,3 @@
-(define (CFNC-multi . args) #f)
-(define (CINT-multi . args) #f)
-
(CFNC-X "XVisualInfo* glXChooseVisual Display* dpy int screen int* attribList")
(CFNC-X "void glXCopyContext Display* dpy GLXContext src GLXContext dst unsigned_long mask")
(CFNC-X "GLXContext glXCreateContext Display* dpy XVisualInfo* vis GLXContext shareList Bool direct")
@@ -472,40 +469,6 @@
(CFNC "void gluTessVertex GLUtesselator* tess GLdouble* location GLvoid* data")
(CFNC "GLint gluUnProject GLdouble winX GLdouble winY GLdouble winZ GLdouble* model GLdouble* proj GLint* view GLdouble* [objX] GLdouble* [objY] GLdouble* [objZ]")
(CFNC "GLint gluUnProject4 GLdouble winX GLdouble winY GLdouble winZ GLdouble clipW GLdouble* model GLdouble* proj GLint* view GLdouble near GLdouble far GLdouble* [objX] GLdouble* [objY] GLdouble* [objZ] GLdouble* [objW]")
-(CFNC-multi "void glActiveTextureARB GLenum texture")
-(CFNC-multi "void glClientActiveTextureARB GLenum texture")
-(CFNC-multi "void glMultiTexCoord1dARB GLenum target GLdouble s")
-(CFNC-multi "void glMultiTexCoord1dvARB GLenum target GLdouble* v")
-(CFNC-multi "void glMultiTexCoord1fARB GLenum target GLfloat s")
-(CFNC-multi "void glMultiTexCoord1fvARB GLenum target GLfloat* v")
-(CFNC-multi "void glMultiTexCoord1iARB GLenum target GLint s")
-(CFNC-multi "void glMultiTexCoord1ivARB GLenum target GLint* v")
-(CFNC-multi "void glMultiTexCoord1sARB GLenum target GLshort s")
-(CFNC-multi "void glMultiTexCoord1svARB GLenum target GLshort* v")
-(CFNC-multi "void glMultiTexCoord2dARB GLenum target GLdouble s GLdouble t")
-(CFNC-multi "void glMultiTexCoord2dvARB GLenum target GLdouble* v")
-(CFNC-multi "void glMultiTexCoord2fARB GLenum target GLfloat s GLfloat t")
-(CFNC-multi "void glMultiTexCoord2fvARB GLenum target GLfloat* v")
-(CFNC-multi "void glMultiTexCoord2iARB GLenum target GLint s GLint t")
-(CFNC-multi "void glMultiTexCoord2ivARB GLenum target GLint* v")
-(CFNC-multi "void glMultiTexCoord2sARB GLenum target GLshort s GLshort t")
-(CFNC-multi "void glMultiTexCoord2svARB GLenum target GLshort* v")
-(CFNC-multi "void glMultiTexCoord3dARB GLenum target GLdouble s GLdouble t GLdouble r")
-(CFNC-multi "void glMultiTexCoord3dvARB GLenum target GLdouble* v")
-(CFNC-multi "void glMultiTexCoord3fARB GLenum target GLfloat s GLfloat t GLfloat r")
-(CFNC-multi "void glMultiTexCoord3fvARB GLenum target GLfloat* v")
-(CFNC-multi "void glMultiTexCoord3iARB GLenum target GLint s GLint t GLint r")
-(CFNC-multi "void glMultiTexCoord3ivARB GLenum target GLint* v")
-(CFNC-multi "void glMultiTexCoord3sARB GLenum target GLshort s GLshort t GLshort r")
-(CFNC-multi "void glMultiTexCoord3svARB GLenum target GLshort* v")
-(CFNC-multi "void glMultiTexCoord4dARB GLenum target GLdouble s GLdouble t GLdouble r GLdouble q")
-(CFNC-multi "void glMultiTexCoord4dvARB GLenum target GLdouble* v")
-(CFNC-multi "void glMultiTexCoord4fARB GLenum target GLfloat s GLfloat t GLfloat r GLfloat q")
-(CFNC-multi "void glMultiTexCoord4fvARB GLenum target GLfloat* v")
-(CFNC-multi "void glMultiTexCoord4iARB GLenum target GLint s GLint t GLint r GLint q")
-(CFNC-multi "void glMultiTexCoord4ivARB GLenum target GLint* v")
-(CFNC-multi "void glMultiTexCoord4sARB GLenum target GLshort s GLshort t GLshort r GLshort q")
-(CFNC-multi "void glMultiTexCoord4svARB GLenum target GLshort* v")
(CINT-X "GLX_USE_GL")
(CINT-X "GLX_BUFFER_SIZE")
@@ -1234,41 +1197,6 @@
(CINT "GL_CLIENT_PIXEL_STORE_BIT")
(CINT "GL_CLIENT_VERTEX_ARRAY_BIT")
;(CINT "GL_ALL_CLIENT_ATTRIB_BITS")
-(CINT-multi "GL_TEXTURE0_ARB")
-(CINT-multi "GL_TEXTURE1_ARB")
-(CINT-multi "GL_TEXTURE2_ARB")
-(CINT-multi "GL_TEXTURE3_ARB")
-(CINT-multi "GL_TEXTURE4_ARB")
-(CINT-multi "GL_TEXTURE5_ARB")
-(CINT-multi "GL_TEXTURE6_ARB")
-(CINT-multi "GL_TEXTURE7_ARB")
-(CINT-multi "GL_TEXTURE8_ARB")
-(CINT-multi "GL_TEXTURE9_ARB")
-(CINT-multi "GL_TEXTURE10_ARB")
-(CINT-multi "GL_TEXTURE11_ARB")
-(CINT-multi "GL_TEXTURE12_ARB")
-(CINT-multi "GL_TEXTURE13_ARB")
-(CINT-multi "GL_TEXTURE14_ARB")
-(CINT-multi "GL_TEXTURE15_ARB")
-(CINT-multi "GL_TEXTURE16_ARB")
-(CINT-multi "GL_TEXTURE17_ARB")
-(CINT-multi "GL_TEXTURE18_ARB")
-(CINT-multi "GL_TEXTURE19_ARB")
-(CINT-multi "GL_TEXTURE20_ARB")
-(CINT-multi "GL_TEXTURE21_ARB")
-(CINT-multi "GL_TEXTURE22_ARB")
-(CINT-multi "GL_TEXTURE23_ARB")
-(CINT-multi "GL_TEXTURE24_ARB")
-(CINT-multi "GL_TEXTURE25_ARB")
-(CINT-multi "GL_TEXTURE26_ARB")
-(CINT-multi "GL_TEXTURE27_ARB")
-(CINT-multi "GL_TEXTURE28_ARB")
-(CINT-multi "GL_TEXTURE29_ARB")
-(CINT-multi "GL_TEXTURE30_ARB")
-(CINT-multi "GL_TEXTURE31_ARB")
-(CINT-multi "GL_ACTIVE_TEXTURE_ARB")
-(CINT-multi "GL_CLIENT_ACTIVE_TEXTURE_ARB")
-(CINT-multi "GL_MAX_TEXTURE_UNITS_ARB")
(CINT "GLU_FALSE")
(CINT "GLU_TRUE")
;(CINT "GLU_VERSION_1_1")
diff --git a/tools/gtk-header-diffs b/tools/gtk-header-diffs
index 7457f24..b7142f2 100755
--- a/tools/gtk-header-diffs
+++ b/tools/gtk-header-diffs
@@ -1,7 +1,7 @@
#!/bin/csh -f
-set gtkolddir = /home/bil/test/gtk+-3.19.2
-set gtknewdir = /home/bil/test/gtk+-3.19.3
+set gtkolddir = /home/bil/test/gtk+-3.20.3
+set gtknewdir = /home/bil/test/gtk+-3.21.1
set pangoolddir = /home/bil/test/pango-1.36.8
set pangonewdir = /home/bil/test/pango-1.36.8
set glibolddir = /home/bil/test/glib-2.39.3
diff --git a/tools/make-index.scm b/tools/make-index.scm
index 40551e0..3d825f7 100644
--- a/tools/make-index.scm
+++ b/tools/make-index.scm
@@ -4,7 +4,7 @@
(if (provided? 'pure-s7)
(define (char-ci=? . chars) (apply char=? (map char-upcase chars))))
-;(set! (hook-functions *load-hook*) (list (lambda (hook) (format #t "loading ~S~%" (hook 'name)))))
+;(set! (hook-functions *load-hook*) (list (lambda (hook) (format () "loading ~S~%" (hook 'name)))))
(set! (hook-functions *unbound-variable-hook*) ())
(define scheme-variable-names
@@ -68,27 +68,18 @@
(define (alphanumeric? c) (or (char-alphabetic? c) (char-numeric? c)))
-(define (find-if pred l)
- (cond ((null? l) #f)
- ((pred (car l)) (car l))
- (else (find-if pred (cdr l)))))
+(define (find-if pred lst)
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (find-if pred (cdr lst)))))
-(define* (make-ind name sortby topic file general indexed char)
- (vector name sortby topic file general indexed char))
+(define* (make-ind name sortby indexed char)
+ (vector name sortby indexed char))
(define-expansion (ind-name obj) `(vector-ref ,obj 0))
(define-expansion (ind-sortby obj) `(vector-ref ,obj 1))
-(define-expansion (ind-topic obj) `(vector-ref ,obj 2))
-(define-expansion (ind-file obj) `(vector-ref ,obj 3))
-(define-expansion (ind-general obj) `(vector-ref ,obj 4))
-(define-expansion (ind-char obj) `(vector-ref ,obj 6))
-(define ind-indexed (dilambda (lambda (obj) (vector-ref obj 5)) (lambda (obj val) (vector-set! obj 5 val))))
-
-
-(define (html-length str)
- (if (char-position #\& str)
- (- (length str) 3)
- (length str)))
+(define-expansion (ind-char obj) `(vector-ref ,obj 3))
+(define ind-indexed (dilambda (lambda (obj) (vector-ref obj 2)) (lambda (obj val) (vector-set! obj 2 val))))
(define (remove-all item sequence)
@@ -133,19 +124,17 @@
(or (= (length a) 0)
(string=? a b)
(if (char=? (string-ref a 0) #\*)
- (if (char=? (string-ref b 0) #\*)
- (string<? a b) ; both start with *
- (string<? (substring a 1) b))
- (if (char=? (string-ref b 0) #\*)
- (string<? a (substring b 1))
- (string<? a b)))))) ; neither starts with *
+ (string<? (if (char=? (string-ref b 0) #\*) ; both start with *
+ a (substring a 1))
+ b)
+ (string<? a (if (char=? (string-ref b 0) #\*) (substring b 1) b))))))
(define (clean-and-downcase-first-char str caps topic file)
(if (char=? (str 0) #\|)
;; this is a main-index entry
(let* ((colonpos (or (char-position #\: str)
- (format #t "no : in ~A~%" str)))
+ (format () "no : in ~A~%" str)))
(line (string-append "<a href=\""
(or file "")
"#"
@@ -154,70 +143,64 @@
(substring str (+ colonpos 1))
"</a>")))
(make-ind :name line
- :topic topic
- :file file
:sortby (string-downcase (substring str (+ colonpos 1)))))
(begin
(let ((def-pos (string-position " class=def" str)))
(when def-pos
- ;(format #t "str: ~S, def-pos: ~A~%" str def-pos)
+ ;(format () "str: ~S, def-pos: ~A~%" str def-pos)
(set! str (string-append "<a "
(if (char=? (str (+ def-pos 10)) #\n)
(substring str (+ def-pos 10))
(values "name=" (substring str (+ def-pos 14))))))))
- (let* ((line (string-append "<a href=\""
+ (let ((line (string-append "<a href=\""
(or file "")
"#"
- (substring str 9)))
- (ipos (string-position "<em" line)))
- (when ipos
- (let ((ispos (string-position "</em>" line)))
- (set! line (string-append (substring line 0 ipos)
- (substring line (+ ipos 14) ispos)
- (substring line (+ ispos 5))))
- (if (not line)
- (format #t "<em...> but no </em> for ~A~%" str))))
+ (substring str 9))))
+ (let ((ipos (string-position "<em" line)))
+ (when ipos
+ (let ((ispos (string-position "</em>" line)))
+ (if (not ispos)
+ (format () "<em...> but no </em> for ~A~%" str)
+ (set! line (string-append (substring line 0 ipos)
+ (substring line (+ ipos 14) ispos)
+ (substring line (+ ispos 5))))))))
(let ((hpos (let ((start (string-position "<h" line)))
- (and start
+ (and (integer? start)
(or (string-position "<h2>" line start)
(string-position "<h1>" line start)
(string-position "<h3>" line start)
(string-position "<h4>" line start))))))
(when hpos
(let ((hspos (let ((start (string-position "</h" line)))
- (and start
+ (and (integer? start)
(or (string-position "</h2>" line start)
(string-position "</h1>" line start)
(string-position "</h3>" line start)
(string-position "</h4>" line start))))))
- (set! line (string-append (substring line 0 hpos)
- (substring line (+ hpos 4) hspos)
- (substring line (+ hspos 5))))
- (if (not line)
- (format #t "<hn> but no </hn> for ~A~%" str)))))
+ (if (not hspos)
+ (format () "<hn> but no </hn> for ~A~%" str)
+ (set! line (string-append (substring line 0 hpos)
+ (substring line (+ hpos 4) hspos)
+ (substring line (+ hspos 5))))))))
- (letrec ((search-caps ; caps is the list of names with upper case chars from the make-index-1 invocation ("AIFF" for example)
- (lambda (ln)
- (and caps
- (do ((cap caps (cdr cap)))
- ((or (null? cap)
- (string-position (car cap) ln))
- (pair? cap)))))))
- (if (not (search-caps line))
+ (if (not (let ((ln line))
+ (and caps ; caps is the list of names with upper case chars from the make-index-1 invocation ("AIFF" for example)
+ (do ((cap caps (cdr cap)))
+ ((or (null? cap)
+ (string-position (car cap) ln))
+ (pair? cap))))))
;; find the first character of the >name< business and downcase it
- (let ((bpos (char-position #\> line)))
- (set! (line (+ bpos 1)) (char-downcase (line (+ bpos 1)))))))
+ (let ((bpos (char-position #\> line)))
+ (set! (line (+ bpos 1)) (char-downcase (line (+ bpos 1))))))
(let ((bpos (char-position #\> line))
(epos (or (string-position "</a>" line)
(string-position "</em>" line)
(string-position "</A>" line))))
(make-ind :name line
- :topic topic
- :file file
:sortby (string-downcase (substring line (+ bpos 1) epos))))))))
@@ -230,67 +213,58 @@
"\"><b>"
(substring str (+ mid 1))
"</b></a>")
- :topic #f
- :file file
- :general #t
:sortby (string-downcase (substring str (+ mid 1))))))
(define (scheme->ruby scheme-name)
- (if (string=? scheme-name "frame*")
- "frame_multiply"
- (if (string=? scheme-name "frame+")
- "frame_add"
- (if (string=? scheme-name "float-vector*")
- "float-vector_multiply"
- (if (string=? scheme-name "float-vector+")
- "float-vector_add"
- (if (string=? scheme-name "mixer*")
- "mixer_multiply"
- (if (string=? scheme-name "mixer+")
- "mixer_add"
- (if (string=? scheme-name "redo")
- "redo_edit"
- (if (string=? scheme-name "in")
- "call_in"
- (let* ((len (length scheme-name))
- (var-case (hash-table-ref scheme-variable-names scheme-name))
- (strlen (if var-case (+ len 1) len))
- (rb-name (make-string strlen #\space))
- (i 0)
- (j 0))
- (if var-case
- (begin
- (set! (rb-name 0) #\$)
- (set! j 1))
- (if (hash-table-ref scheme-constant-names scheme-name)
- (begin
- (set! (rb-name 0) (char-upcase (scheme-name 0)))
- (set! i 1)
- (set! j 1))))
- (do ()
- ((>= i len))
- (let ((c (scheme-name i)))
- (if (or (alphanumeric? c)
- (char=? c #\?)
- (char=? c #\!))
- (begin
- (set! (rb-name j) c)
- (set! i (+ i 1))
- (set! j (+ j 1)))
- (if (and (char=? c #\-)
- (char=? (scheme-name (+ i 1)) #\>))
- (begin
- (set! (rb-name j) #\2)
- (set! j (+ j 1))
- (set! i (+ i 2)))
- (begin
- (set! (rb-name j) #\_)
- (set! i (+ i 1))
- (set! j (+ j 1)))))))
- (if (not (= j strlen))
- (substring rb-name 0 j)
- rb-name)))))))))))
+ (cond ((assoc scheme-name
+ '(("frame*" . "frame_multiply")
+ ("frame+" . "frame_add")
+ ("float-vector*" . "float-vector_multiply")
+ ("float-vector+" . "float-vector_add")
+ ("mixer*" . "mixer_multiply")
+ ("mixer+" . "mixer_add")
+ ("redo" . "redo_edit")
+ ("in" . "call_in"))
+ string=?) => cdr)
+ (else
+ (let* ((len (length scheme-name))
+ (var-case (hash-table-ref scheme-variable-names scheme-name))
+ (strlen (if var-case (+ len 1) len))
+ (rb-name (make-string strlen #\space))
+ (i 0)
+ (j 0))
+ (if var-case
+ (begin
+ (set! (rb-name 0) #\$)
+ (set! j 1))
+ (if (hash-table-ref scheme-constant-names scheme-name)
+ (begin
+ (set! (rb-name 0) (char-upcase (scheme-name 0)))
+ (set! i 1)
+ (set! j 1))))
+ (do ()
+ ((>= i len))
+ (let ((c (scheme-name i)))
+ (if (or (alphanumeric? c)
+ (memv c '(#\? #\!)))
+ (begin
+ (set! (rb-name j) c)
+ (set! i (+ i 1))
+ (set! j (+ j 1)))
+ (if (and (char=? c #\-)
+ (char=? (scheme-name (+ i 1)) #\>))
+ (begin
+ (set! (rb-name j) #\2)
+ (set! j (+ j 1))
+ (set! i (+ i 2)))
+ (begin
+ (set! (rb-name j) #\_)
+ (set! i (+ i 1))
+ (set! j (+ j 1)))))))
+ (if (= j strlen)
+ rb-name
+ (substring rb-name 0 j))))))
(define (clean-up-xref xref file)
(let* ((len (length xref))
@@ -315,13 +289,13 @@
(< href-start leof)
(char-position #\> xref (+ href-start 1))))
(href (and href-start href-end (substring xref (+ href-start href-len) href-end))))
- (if href
- (if (char=? (href 1) #\#)
- (set! url-str (string-append url-str (string #\") file (substring href 1) (format #f ",~% ")))
- (set! url-str (string-append url-str href (format #f ",~% "))))
- (set! url-str (string-append url-str (format #f "NULL,~% "))))
- (set! loc (+ leof 1))
- ))
+ (set! url-str (string-append url-str
+ (if href
+ (if (char=? (href 1) #\#)
+ (values "\"" file (substring href 1) (format #f ",~% "))
+ (values href (format #f ",~% ")))
+ (format #f "NULL,~% "))))
+ (set! loc (+ leof 1))))
(set! (outstr j) #\")
(set! j (+ j 1))
@@ -495,36 +469,35 @@
(load "stuff.scm")
(load "mockery.scm")
;(load "repl.scm")
+(load "profile.scm")
(let ((names (make-hash-table)))
- (define (where-is func)
- (let ((addr (with-let (funclet func) __func__)))
- ;; this misses scheme-side pws because their environment is (probably) the global env
- (and (pair? addr)
- (cadr addr))))
-
(define (apropos-1 e)
(for-each
(lambda (binding)
- (if (pair? binding)
- (let ((symbol (car binding))
- (value (cdr binding)))
- (if (procedure? value)
- (let ((file (where-is value)))
- (if (and file
- (not (member file '("~/.snd_s7" "/home/bil/.snd_s7" "t.scm" "/home/bil/cl/t.scm" "make-index.scm" "/home/bil/cl/make-index.scm"))))
- (let ((pos (char-position #\/ file)))
- (if pos
- (do ((k (char-position #\/ file (+ pos 1)) (char-position #\/ file (+ pos 1))))
- ((not k)
- (set! file (substring file (+ pos 1))))
- (set! pos k)))
- (let ((cur-names (hash-table-ref names file)))
- (if cur-names
- (if (not (memq symbol cur-names))
- (hash-table-set! names file (cons symbol cur-names)))
- (hash-table-set! names file (list symbol)))))))))))
+ (when (pair? binding)
+ (let ((symbol (car binding))
+ (value (cdr binding)))
+ (when (procedure? value)
+ (let ((file (let ((addr (with-let (funclet value) __func__)))
+ ;; this misses scheme-side pws because their environment is (probably) the global env
+ (and (pair? addr)
+ (pair? (cdr addr))
+ (cadr addr)))))
+ (when (and file
+ (not (member file '("~/.snd_s7" "/home/bil/.snd_s7" "t.scm" "/home/bil/cl/t.scm" "make-index.scm" "/home/bil/cl/make-index.scm"))))
+ (let ((pos (char-position #\/ file)))
+ (if pos
+ (do ((k (char-position #\/ file (+ pos 1)) (char-position #\/ file (+ pos 1))))
+ ((not k)
+ (set! file (substring file (+ pos 1))))
+ (set! pos k)))
+ (let ((cur-names (hash-table-ref names file)))
+ (if cur-names
+ (if (not (memq symbol cur-names))
+ (hash-table-set! names file (cons symbol cur-names)))
+ (hash-table-set! names file (list symbol)))))))))))
e))
;; handle the main macros by hand
@@ -536,9 +509,7 @@
(format *stderr* ";~S says it is in ~S which does not exist~%" symbol file))
(let ((cur-names (hash-table-ref names file)))
- (if cur-names
- (hash-table-set! names file (cons symbol cur-names))
- (hash-table-set! names file (list symbol))))))
+ (hash-table-set! names file (if cur-names (cons symbol cur-names) (list symbol))))))
(list
(list '*libm* "libm.scm")
(list '*libgdbm* "libgdbm.scm")
@@ -546,6 +517,8 @@
(list '*libc* "libc.scm")
(list '*libgsl* "libgsl.scm")
(list '*repl* "repl.scm")
+ (list '*rgb* "rgb.scm")
+ (list '*spectr* "spectr.scm")
(list 'with-sound "ws.scm")
(list 'with-mixed-sound "ws.scm")
@@ -792,14 +765,18 @@
(list 'make-box-type "r7rs.scm")
(list 'define-library "r7rs.scm")
(list 'define-record-type "r7rs.scm")
+ (list 'define-values "r7rs.scm")
(list 'c?r "stuff.scm")
(list 'do* "stuff.scm")
(list 'typecase "stuff.scm")
(list 'enum "stuff.scm")
(list 'while "stuff.scm")
+ (list 'let-temporarily "stuff.scm")
(list 'define-class "stuff.scm")
(list 'elambda "stuff.scm")
+ (list 'value->symbol "stuff.scm")
+ (list 'progv "stuff.scm")
(list 'reflective-let "stuff.scm")
(list 'reflective-probe "stuff.scm")
(list 'reactive-let "stuff.scm")
@@ -819,6 +796,8 @@
(list 'lint "lint.scm")
(list 'html-lint "lint.scm")
+ (list 'c-define "cload.scm")
+
(list 'moog? "moog.scm")
(list 'make-moog "moog.scm")
@@ -862,17 +841,17 @@
;; alternate: (autoload sym (lambda (e) (let ((m (load file))) (varlet (rootlet) (cons sym (m sym))))))
(for-each
(lambda (sym&file)
- (let ((e (car sym&file))
- (file (cadr sym&file)))
- (let ((ce (if (not (defined? e)) (load file) (symbol->value e))))
- (let ((flst (or (hash-table-ref names file) ())))
- (for-each
- (lambda (slot)
- (let ((name (car slot)))
- (if (not (defined? name))
- (set! flst (cons name flst)))))
- ce)
- (hash-table-set! names file flst)))))
+ (let* ((e (car sym&file))
+ (file (cadr sym&file))
+ (ce (if (not (defined? e)) (load file) (symbol->value e)))
+ (flst (or (hash-table-ref names file) ())))
+ (for-each
+ (lambda (slot)
+ (let ((name (car slot)))
+ (if (not (defined? name))
+ (set! flst (cons name flst)))))
+ ce)
+ (hash-table-set! names file flst)))
(list
(list '*libm* "libm.scm")
(list '*libgdbm* "libgdbm.scm")
@@ -896,14 +875,14 @@
(for-each
(lambda (symbol)
(set! syms (cons (cons (symbol->string symbol) file) syms)))
- symbols)))
- (set! syms (sort! syms (lambda (a b) (string<? (car a) (car b)))))
- (format p "~%static const char *snd_names[~D] = {" (* size 2))
- (for-each
- (lambda (sf)
- (format p "~% ~S, ~S," (car sf) (cdr sf)))
- syms)
- (format p "~%};~%"))
+ symbols))))
+ (set! syms (sort! syms (lambda (a b) (string<? (car a) (car b)))))
+ (format p "~%static const char *snd_names[~D] = {" (* size 2))
+ (for-each
+ (lambda (sf)
+ (format p "~% ~S, ~S," (car sf) (cdr sf)))
+ syms)
+ (format p "~%};~%")
(format p "~%static void autoload_info(s7_scheme *sc)~%{~% s7_autoload_set_names(sc, snd_names, ~D);~%}~%" size)))
))
@@ -915,14 +894,14 @@
(define (make-vector-name str)
(let ((pos (char-position #\space str)))
- (if pos
+ (if (not pos)
+ str
(let ((len (length str)))
(string-set! str pos #\_)
(do ((i (+ pos 1) (+ i 1)))
((= i len) str)
(if (char=? (string-ref str i) #\space)
- (string-set! str i #\_))))
- str)))
+ (string-set! str i #\_)))))))
(define ids (make-hash-table))
(define n-array-length 2048)
@@ -973,58 +952,58 @@
(let* ((start (- (char-position #\" dline id-pos) id-pos)) ; (substring dline id-pos)))
(end-start (+ id-pos start 2))
(end (- (char-position #\" dline end-start) end-start)) ; (substring dline (+ id-pos start 2))))
- (name (substring dline (+ id-pos start 1) (+ id-pos start 2 end))))
- (let ((sym-name (string->symbol name)))
- (if (not (hash-table-ref ids sym-name))
- (hash-table-set! ids sym-name 0)
- (if (memq sym-name local-ids)
- (format #t "~S: id ~S is set twice~%" file sym-name)))
- (set! local-ids (cons sym-name local-ids)))))
+ (name (substring dline (+ id-pos start 1) (+ id-pos start 2 end)))
+ (sym-name (string->symbol name)))
+ (if (not (hash-table-ref ids sym-name))
+ (hash-table-set! ids sym-name 0)
+ (if (memq sym-name local-ids)
+ (format () "~S: id ~S is set twice~%" file sym-name)))
+ (set! local-ids (cons sym-name local-ids))))
- (if tpos
- (let ((epos (string-position " -->" dline)))
- (if (not epos)
- (format #t "<!-- TOPIC but no --> for ~A~%" dline)
- (set! topic (substring dline (+ tpos 11) epos))))
- (if compos
- (let ((epos (string-position " -->" dline)))
- (if (not epos)
- (format #t "<!-- INDEX but no --> for ~A~%" dline)
- (when (or (not no-bold)
- with-scm)
- (set! current-general g)
- (set! (generals g) (substring dline (+ compos 11) epos))
- (set! (gfiles g) (car file))
- (set! (xrefs g) "")
- (set! g (+ g 1)))))
- (if indpos
- (let ((epos (string-position " -->" dline)))
- (if (not epos)
- (format #t "<!-- main-index but no --> for ~A~%" dline)
- (when (or (not no-bold)
- with-scm)
- (set! (names n) (substring dline (+ indpos 16) epos))
- (set! (files n) (car file))
- (set! n (+ n 1)))))
- (if xpos
- (set! xrefing #t)
- (do ()
- ((not pos))
- (set! dline (substring dline pos))
- (let ((epos (or (string-position "</a>" dline)
- (string-position "</em>" dline)
- (string-position "</A>" dline))))
- (if (not epos)
- (format #t "<a> but no </a> for ~A~%" dline)
- (begin
- (set! (names n) (string-append (substring dline 0 epos) "</a>"))
- (set! (files n) (car file))
- (set! (topics n) topic)
- (set! n (+ n 1))
- (set! dline (substring dline (+ epos 4)))
- (set! pos (string-position "<em class=def id=" dline))
- )))))
- )))
+ (cond (tpos
+ (let ((epos (string-position " -->" dline)))
+ (if (not epos)
+ (format () "<!-- TOPIC but no --> for ~A~%" dline)
+ (set! topic (substring dline (+ tpos 11) epos)))))
+ (compos
+ (let ((epos (string-position " -->" dline)))
+ (if (not epos)
+ (format () "<!-- INDEX but no --> for ~A~%" dline)
+ (when (or (not no-bold)
+ with-scm)
+ (set! current-general g)
+ (set! (generals g) (substring dline (+ compos 11) epos))
+ (set! (gfiles g) (car file))
+ (set! (xrefs g) "")
+ (set! g (+ g 1))))))
+ (indpos
+ (let ((epos (string-position " -->" dline)))
+ (if (not epos)
+ (format () "<!-- main-index but no --> for ~A~%" dline)
+ (when (or (not no-bold)
+ with-scm)
+ (set! (names n) (substring dline (+ indpos 16) epos))
+ (set! (files n) (car file))
+ (set! n (+ n 1))))))
+ (xpos
+ (set! xrefing #t))
+ (else
+ (do ()
+ ((not pos))
+ (set! dline (substring dline pos))
+ (let ((epos (or (string-position "</a>" dline)
+ (string-position "</em>" dline)
+ (string-position "</A>" dline))))
+ (if (not epos)
+ (format () "<a> but no </a> for ~A~%" dline)
+ (begin
+ (set! (names n) (string-append (substring dline 0 epos) "</a>"))
+ (set! (files n) (car file))
+ (set! (topics n) topic)
+ (set! n (+ n 1))
+ (set! dline (substring dline (+ epos 4)))
+ (set! pos (string-position "<em class=def id=" dline))
+ ))))))
(if (and xrefing
(or (not (char=? (dline 0) #\<))
(string-position "<a href" dline)
@@ -1079,13 +1058,13 @@
(if (and last-char
(not (char-ci=? last-char this-char)))
(begin
- (set! (new-names j) (make-ind :name #f :topic #f :file #f :sortby #f))
+ (set! (new-names j) (make-ind :name #f :sortby #f))
(set! j (+ j 1))
(set! (new-names j) (make-ind :name " "
:char (char-upcase this-char)
- :topic #f :file #f :sortby #f))
+ :sortby #f))
(set! j (+ j 1))
- (set! (new-names j) (make-ind :name #f :topic #f :file #f :sortby #f))
+ (set! (new-names j) (make-ind :name #f :sortby #f))
(set! j (+ j 1))))
(set! (new-names j) name)
(set! j (+ j 1))
@@ -1145,15 +1124,15 @@
(do ((i 0 (+ i 1)))
((>= row offset))
(let ((x (+ row (* ctr offset))))
- (if (< x n)
+ (if (>= x n)
+ (format ofil "~%")
(let ((name (tnames x)))
(format ofil
"<td~A>~A~A~A</td>"
- (if (not (ind-name name))
+ (if (or (not (ind-name name))
+ (ind-sortby name))
""
- (if (not (ind-sortby name))
- " class=\"green\""
- ""))
+ " class=\"green\"")
(if (ind-char name)
"<div class=\"centered\">"
"<em class=tab>")
@@ -1171,10 +1150,8 @@
"</em>")
)
(if (ind-indexed name)
- (format #t "~A indexed twice~%" (ind-name name)))
- (set! (ind-indexed name) #t))
- (format ofil "~%")))
-
+ (format () "~A indexed twice~%" (ind-name name)))
+ (set! (ind-indexed name) #t))))
(set! ctr (+ ctr 1))
(when (< ctr cols)
(format ofil "<td></td>"))
@@ -1190,7 +1167,7 @@
(do ((i 0 (+ i 1)))
((= i n))
(if (not (ind-indexed (tnames i)))
- (format #t "unindexed: ~A (~A)~%" (ind-name (tnames i)) i)))
+ (format () "unindexed: ~A (~A)~%" (ind-name (tnames i)) i)))
(do ((i 0 (+ i 1)))
((= i (- n 1)))
@@ -1200,109 +1177,91 @@
(string? (ind-sortby n2))
(string=? (ind-sortby n1) (ind-sortby n2))
(string=? (ind-name n1) (ind-name n2)))
- (format #t "duplicated name: ~A (~A ~A)~%" (ind-sortby n1) (ind-name n1) (ind-name n2)))))
+ (format () "duplicated name: ~A (~A ~A)~%" (ind-sortby n1) (ind-name n1) (ind-name n2)))))
- (if with-scm
- (begin
- (call-with-output-file "test.c"
- (lambda (sfil)
- (let ((help-names ())
- (help-urls ()))
- (format sfil "/* Snd help index (generated by make-index.scm) */~%")
- (do ((i 0 (+ i 1)))
- ((= i n))
- (if (and (tnames i)
- (ind-sortby (tnames i)))
- (let* ((line (substring (ind-name (tnames i)) 8))
- (dpos (char-position #\> line))
- (url (substring line 1 (- dpos 1)))
- (epos (char-position #\< line))
- (ind (substring line (+ dpos 1) epos))
- (gpos (string-position ">" ind)))
- (if gpos
- (set! ind (string-append (substring ind 0 gpos)
- ">"
- (substring ind (+ gpos 4)))))
- (when (and ind
- (string? ind)
- (positive? (length ind)))
- (set! help-names (cons ind help-names))
- (set! help-urls (cons url help-urls))))))
-
- (set! help-names (reverse help-names))
- (set! help-urls (reverse help-urls))
-
- (let ((len (length help-names)))
- (format sfil "#define HELP_NAMES_SIZE ~D~%" len)
- (format sfil "#if HAVE_SCHEME || HAVE_FORTH~%")
- (format sfil "static const char *help_names[HELP_NAMES_SIZE] = {~% ")
- (format sfil "~S" (car help-names))
- (do ((ctr 1 (+ ctr 1))
- (lname (cdr help-names) (cdr lname)))
- ((null? lname))
- (let ((name (car lname)))
- (if (= (modulo ctr 6) 0)
- (format sfil ",~% ~S" name)
- (format sfil ", ~S" name))))
- (format sfil "};~%")
-
- (format sfil "#endif~%#if HAVE_RUBY~%")
- (format sfil "static const char *help_names[HELP_NAMES_SIZE] = {~% ")
- (format sfil "~S" (car help-names))
- (do ((ctr 1 (+ ctr 1))
- (lname (cdr help-names) (cdr lname)))
- ((null? lname))
- (let ((name (car lname)))
- (if (= (modulo ctr 6) 0)
- (format sfil ",~% ~S" (without-dollar-sign (scheme->ruby name)))
- (format sfil ", ~S" (without-dollar-sign (scheme->ruby name))))))
-
- (format sfil "};~%#endif~%")
- (format sfil "#if (!HAVE_EXTENSION_LANGUAGE)~%static const char **help_names = NULL;~%#endif~%")
- (format sfil "static const char *help_urls[HELP_NAMES_SIZE] = {~% ")
- (format sfil "~S" (car help-names))
-
- (do ((ctr 1 (+ ctr 1))
- (lname (cdr help-urls) (cdr lname)))
- ((null? lname))
- (let ((url (car lname)))
- (if (= (modulo ctr 4) 0)
- (format sfil ",~% ~S" url)
- (format sfil ", ~S" url))))
- (format sfil "};~%"))
-
- (do ((i 0 (+ i 1)))
- ((= i g))
- (if (and (xrefs i)
- (> (length (xrefs i)) 1))
- (let ((vals (clean-up-xref (xrefs i) (gfiles i))))
- (format sfil "~%static const char *~A_xrefs[] = {~% ~A,~% NULL};~%"
- (let* ((str (generals i))
- (mid (char-position #\: str)))
- (make-vector-name (substring str (+ mid 1))))
- (car vals))
- (format sfil "~%static const char *~A_urls[] = {~% ~ANULL};~%"
- (let* ((str (generals i))
- (mid (char-position #\: str)))
- (make-vector-name (substring str (+ mid 1))))
- (cadr vals))
- ))
- )
-
- (format sfil "~%~%#if HAVE_SCHEME~%")
- )))
-
- (system "cat indexer.data >> test.c")
- (system "echo '#endif\n\n' >> test.c")
-
- )))))
+ (when with-scm
+ (call-with-output-file "test.c"
+ (lambda (sfil)
+ (let ((help-names ())
+ (help-urls ()))
+ (format sfil "/* Snd help index (generated by make-index.scm) */~%")
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (if (and (tnames i)
+ (ind-sortby (tnames i)))
+ (let* ((line (substring (ind-name (tnames i)) 8))
+ (dpos (char-position #\> line))
+ (url (substring line 1 (- dpos 1)))
+ (epos (char-position #\< line))
+ (ind (substring line (+ dpos 1) epos))
+ (gpos (string-position ">" ind)))
+ (if gpos
+ (set! ind (string-append (substring ind 0 gpos)
+ ">"
+ (substring ind (+ gpos 4)))))
+ (when (positive? (length ind))
+ (set! help-names (cons ind help-names))
+ (set! help-urls (cons url help-urls))))))
+
+ (set! help-names (reverse help-names))
+ (set! help-urls (reverse help-urls))
+
+ (format sfil "#define HELP_NAMES_SIZE ~D~%" (length help-names))
+ (format sfil "#if HAVE_SCHEME || HAVE_FORTH~%")
+ (format sfil "static const char *help_names[HELP_NAMES_SIZE] = {~% ")
+ (format sfil "~S" (car help-names))
+ (do ((ctr 1 (+ ctr 1))
+ (lname (cdr help-names) (cdr lname)))
+ ((null? lname))
+ (format sfil (if (= (modulo ctr 6) 0) ",~% ~S" ", ~S") (car lname)))
+ (format sfil "};~%")
+
+ (format sfil "#endif~%#if HAVE_RUBY~%")
+ (format sfil "static const char *help_names[HELP_NAMES_SIZE] = {~% ")
+ (format sfil "~S" (car help-names))
+ (do ((ctr 1 (+ ctr 1))
+ (lname (cdr help-names) (cdr lname)))
+ ((null? lname))
+ (let ((name (car lname)))
+ (format sfil (if (= (modulo ctr 6) 0) ",~% ~S" ", ~S") (without-dollar-sign (scheme->ruby name)))))
+
+ (format sfil "};~%#endif~%")
+ (format sfil "#if (!HAVE_EXTENSION_LANGUAGE)~%static const char **help_names = NULL;~%#endif~%")
+ (format sfil "static const char *help_urls[HELP_NAMES_SIZE] = {~% ")
+ (format sfil "~S" (car help-names))
+
+ (do ((ctr 1 (+ ctr 1))
+ (lname (cdr help-urls) (cdr lname)))
+ ((null? lname))
+ (let ((url (car lname)))
+ (format sfil (if (= (modulo ctr 4) 0) ",~% ~S" ", ~S") url)))
+ (format sfil "};~%")
+
+ (do ((i 0 (+ i 1)))
+ ((= i g))
+ (if (and (xrefs i)
+ (> (length (xrefs i)) 1))
+ (let ((vals (clean-up-xref (xrefs i) (gfiles i))))
+ (format sfil "~%static const char *~A_xrefs[] = {~% ~A,~% NULL};~%"
+ (let* ((str (generals i))
+ (mid (char-position #\: str)))
+ (make-vector-name (substring str (+ mid 1))))
+ (car vals))
+ (format sfil "~%static const char *~A_urls[] = {~% ~ANULL};~%"
+ (let* ((str (generals i))
+ (mid (char-position #\: str)))
+ (make-vector-name (substring str (+ mid 1))))
+ (cadr vals)))))
+
+ (format sfil "~%~%#if HAVE_SCHEME~%"))))
+
+ (system "cat indexer.data >> test.c")
+ (system "echo '#endif\n\n' >> test.c")))))
;;; --------------------------------------------------------------------------------
;;; html-check
-(define array-size (* 4 8192))
-
;;; (html-check '("sndlib.html" "snd.html" "sndclm.html" "extsnd.html" "grfsnd.html" "sndscm.html" "fm.html" "balance.html" "snd-contents.html" "s7.html"))
(define (html-check files)
@@ -1333,7 +1292,7 @@
in-comment
(string-position " -- " line))))
(when cpos
- (format #t "~A[~D]: possible -- in comment: ~A~%" file linectr line))
+ (format () "~A[~D]: possible -- in comment: ~A~%" file linectr line))
(when opos
;; open/close html entities
(do ((i opos (or (char-position "<>\"(){}&" line (+ i 1)) len)))
@@ -1341,10 +1300,10 @@
(case (string-ref line i)
((#\<)
(unless scripting
- (if (and (not (zero? openctr))
- (not (positive? p-quotes))
- (not in-comment))
- (format #t "~A[~D]: ~A has unclosed <?~%" file linectr line))
+ (if (not (or (zero? openctr)
+ (positive? p-quotes)
+ in-comment))
+ (format () "~A[~D]: ~A has unclosed <?~%" file linectr line))
(set! openctr (+ openctr 1))
(if (and (< i (- len 3))
(char=? (line (+ i 1)) #\!)
@@ -1354,13 +1313,13 @@
(set! comments (+ comments 1))
(if (> comments 1)
(begin
- (format #t "~A[~D]: nested <!--?~%" file linectr)
+ (format () "~A[~D]: nested <!--?~%" file linectr)
(set! comments (- comments 1))))
(set! in-comment #t)))
(if (and (not in-comment)
(< i (- len 1))
(char=? (line (+ i 1)) #\space))
- (format #t "~A[~D]: '< ' in ~A?~%" file linectr line))))
+ (format () "~A[~D]: '< ' in ~A?~%" file linectr line))))
;; else c != <
((#\>)
@@ -1374,12 +1333,12 @@
(set! comments (- comments 1))
(if (< comments 0)
(begin
- (format #t "~A[~D]: extra -->?~%" file linectr)
+ (format () "~A[~D]: extra -->?~%" file linectr)
(set! comments 0))))
- (if (and (not (zero? openctr))
- (not (positive? p-quotes))
- (not in-comment))
- (format #t "~A[~D]: ~A has unmatched >?~%" file linectr line)))
+ (if (not (or (zero? openctr)
+ (positive? p-quotes)
+ in-comment))
+ (format () "~A[~D]: ~A has unmatched >?~%" file linectr line)))
(set! openctr 0)
(if (and (not in-comment)
(>= i 2)
@@ -1387,7 +1346,7 @@
(not (char=? (line (- i 2)) #\-))
(< i (- len 1))
(alphanumeric? (line (+ i 1))))
- (format #t "~A[~D]: untranslated '>': ~A~%" file linectr line))))
+ (format () "~A[~D]: untranslated '>': ~A~%" file linectr line))))
;; else c != < or >
((#\()
@@ -1405,18 +1364,17 @@
(if (and (not in-comment)
(case (string-ref line (+ i 1))
((#\g) (not (string=? ">" (substring line i (min len (+ i 4))))))
- ((#\l) (and (not (string=? "<" (substring line i (min len (+ i 4)))))
- (not (string=? "λ" (substring line i (min len (+ i 8)))))))
+ ((#\l) (not (or (string=? "<" (substring line i (min len (+ i 4))))
+ (string=? "λ" (substring line i (min len (+ i 8)))))))
((#\a) (not (string=? "&" (substring line i (min len (+ i 5))))))
((#\q) (not (string=? """ (substring line i (min len (+ i 6))))))
((#\o) (not (string=? "ö" (substring line i (min len (+ i 6))))))
- ((#\m) (and (not (string=? "—" (substring line i (min len (+ i 7)))))
- (not (string=? "µ" (substring line i (min len (+ i 7)))))))
+ ((#\m) (not (member (substring line i (min len (+ i 7))) '("—" "µ") string=?)))
((#\n) (not (string=? " " (substring line i (min len (+ i 6))))))
((#\&) (not (string=? "&&" (substring line i (min len (+ i 2))))))
((#\space) (not (string=? "& " (substring line i (min len (+ i 2)))))) ; following char -- should skip this
(else #t)))
- (format #t "~A[~D]: unknown escape sequence: ~A~%" file linectr line)))
+ (format () "~A[~D]: unknown escape sequence: ~A~%" file linectr line)))
((#\{)
(set! p-curlys (+ p-curlys 1)))
@@ -1425,159 +1383,156 @@
(set! p-curlys (- p-curlys 1)))))
;; end line scan
- (if (not in-comment)
- (let ((start #f)
- (closing #f)
- (pos (char-position #\< line)))
- (if pos
- (do ((i pos (or (char-position "</! >" line (+ i 1)) len)))
- ((>= i len))
- (case (string-ref line i)
- ((#\space #\>)
- (if start
- (begin
- (if closing
- (let ((closer (string->symbol (substring line (+ start 2) i))))
- (if (eq? closer 'TABLE) (set! closer 'table))
- (if (memq closer '(center big font))
- (format #t "~A[~D]: ~A is obsolete, ~A~%" file linectr closer line)
- (if (eq? closer 'script)
- (set! scripting #f)
- (if (not scripting)
- (if (not (memq closer commands))
- (format #t "~A[~D]: ~A without start? ~A from [~D:~D] (commands: ~A)~%"
- file linectr closer line (+ start 2) i commands)
-
- (if (memq closer '(ul tr td table small sub blockquote p details summary
- a A i b title pre span h1 h2 h3 code body html
- em head h4 sup map smaller bigger th tbody div))
- (begin
- (if (not (eq? (car commands) closer))
- (format #t "~A[~D]: ~A -> ~A?~%" file linectr closer commands))
-
- (if (memq closer '(p td pre))
- (begin
- (if (odd? p-quotes)
- (format #t "~A[~D]: unmatched quote~%" file linectr))
- (set! p-quotes 0)
- (if (= p-curlys 1)
- (format #t "~A[~D]: extra '{'~%" file linectr)
- (if (= p-curlys -1)
- (format #t "~A[~D]: extra '}'~%" file linectr)
- (if (not (= p-curlys 0))
- (format #t "~A[~D]: curlys: ~D~%" file linectr p-curlys))))
- (set! p-curlys 0)
- (if (= p-parens 1)
- (format #t "~A[~D]: extra '('~%" file linectr)
- (if (= p-parens -1)
- (format #t "~A[~D]: extra ')'~%" file linectr)
- (if (not (= p-parens 0))
- (format #t "~A[~D]: parens: ~D~%" file linectr p-parens))))
- (set! p-parens 0)))
- (set! commands (remove-one closer commands))
- (if (not warned)
- (begin
- (if (and (eq? closer 'table)
- (not (memq 'table commands)))
- (begin
- (if (memq 'tr commands)
- (begin
- (set! warned #t)
- (set! commands (remove-all 'tr commands))
- (format #t "~A[~D]: unclosed tr at table (~A)~%" file linectr commands)))
- (if (memq 'td commands)
- (begin
- (set! warned #t)
- (set! commands (remove-all 'td commands))
- (format #t "~A[~D]: unclosed td at table (~A)~%" file linectr commands))))))))
- (set! commands (remove-all closer commands)))))))
- (set! closing #f))
-
- ;; not closing
- (if (not scripting)
- (let ((opener (string->symbol (substring line (+ start 1) i))))
- (if (eq? opener 'TABLE) (set! opener 'table))
- (if (memq opener '(center big font))
- (format #t "~A[~D]: ~A is obsolete, ~A~%" file linectr opener line)
-
- (if (eq? opener 'script)
- (set! scripting #t)
-
- (if (eq? opener 'img)
- (let* ((rest-line (substring line (+ start 4)))
- (alt-pos (string-position "alt=" rest-line))
- (src-pos (string-position "src=" rest-line)))
- (if (not alt-pos)
- (format #t "~A[~D]: img but no alt: ~A~%" file linectr line))
- (if src-pos
- (let ((png-pos (string-position ".png" rest-line)))
- (if png-pos
- (let ((file (substring rest-line (+ src-pos 5) (+ png-pos 4))))
- (if (not (file-exists? file))
- (format #t "~A[~D]: src not found: ~S~%" file linectr file)))))))
-
- (if (and (not (memq opener '(br spacer li hr area
- ul tr td table small sub blockquote)))
- (memq opener commands)
- (= p-quotes 0))
- (format #t "~A[~D]: nested ~A? ~A from: ~A~%" file linectr opener line commands)
- (begin
- (case opener
- ((td)
- (if (not (eq? 'tr (car commands)))
- (format #t "~A[~D]: td without tr?~%" file linectr))
- (if (and (not warned)
- (memq 'td commands)
- (< (count-table commands) 2))
- (begin
- (set! warned #t)
- (set! commands (remove-one 'td commands))
- (format #t "~A[~D]: unclosed td at table~%" file linectr))))
- ((tr)
- (if (and (not (eq? (car commands) 'table))
- (not (eq? (cadr commands) 'table)))
- (format #t "~A[~D]: tr without table?~%" file linectr))
- (if (and (not warned)
- (memq 'tr commands)
- (< (count-table commands) 2))
- (begin
- (set! warned #t)
- (set! commands (remove-one 'tr commands))
- (format #t "~A[~D]: unclosed tr at table~%" file linectr))))
- ((p)
- (if (eq? (car commands) 'table)
- (format #t "~A[~D]: unclosed table?~%" file linectr)))
-
- ((pre br table hr img ul)
- (if (memq 'p commands)
- (format #t "~A[~D]: ~A within <p>?~%" file linectr opener)))
- ((li)
- (if (not (memq 'ul commands))
- (format #t "~A[~D]: li without ul~%" file linectr)))
- ((small)
- (if (memq (car commands) '(pre code))
- (format #t "~A[~D]: small shouldn't follow ~A~%" file linectr (car commands))))
- ((--)
- (format #t "~A[~D]: <-- missing !?~%" file linectr)))
- (if (not (memq opener '(br meta spacer li hr area)))
- (set! commands (cons opener commands)))))))))))
- ;; end if closing
- (set! start #f))))
-
- ((#\<)
- (if start
- (if (and (not scripting)
- (not (positive? p-quotes)))
- (format #t "~A[~D]: nested < ~A~%" file linectr line))
- (set! start i)))
- ((#\/)
- (if (and start (= start (- i 1)))
- (set! closing #t)))
-
- ((#\!)
- (if (and start (= start (- i 1)))
- (set! start #f)))))))
- ) ; if not in-comment...
+ (unless in-comment
+ (let ((start #f)
+ (closing #f)
+ (pos (char-position #\< line)))
+ (when pos
+ (do ((i pos (or (char-position "</! >" line (+ i 1)) len)))
+ ((>= i len))
+ (case (string-ref line i)
+ ((#\space #\>)
+ (when start
+ (if closing
+ (let ((closer (string->symbol (substring line (+ start 2) i))))
+ (if (eq? closer 'TABLE) (set! closer 'table))
+ (cond ((memq closer '(center big font))
+ (format () "~A[~D]: ~A is obsolete, ~A~%" file linectr closer line))
+ ((eq? closer 'script)
+ (set! scripting #f))
+ (scripting)
+ ((not (memq closer commands))
+ (format () "~A[~D]: ~A without start? ~A from [~D:~D] (commands: ~A)~%"
+ file linectr closer line (+ start 2) i commands))
+ ((not (memq closer '(ul tr td table small sub blockquote p details summary
+ a A i b title pre span h1 h2 h3 code body html
+ em head h4 sup map smaller bigger th tbody div)))
+ (set! commands (remove-all closer commands)))
+ (else
+ (if (not (eq? (car commands) closer))
+ (format () "~A[~D]: ~A -> ~A?~%" file linectr closer commands))
+
+ (if (memq closer '(p td pre))
+ (begin
+ (if (odd? p-quotes)
+ (format () "~A[~D]: unmatched quote~%" file linectr))
+ (set! p-quotes 0)
+ (cond ((= p-curlys 1)
+ (format () "~A[~D]: extra '{'~%" file linectr))
+ ((= p-curlys -1)
+ (format () "~A[~D]: extra '}'~%" file linectr))
+ ((not (= p-curlys 0))
+ (format () "~A[~D]: curlys: ~D~%" file linectr p-curlys)))
+ (set! p-curlys 0)
+ (cond ((= p-parens 1)
+ (format () "~A[~D]: extra '('~%" file linectr))
+ ((= p-parens -1)
+ (format () "~A[~D]: extra ')'~%" file linectr))
+ ((not (= p-parens 0))
+ (format () "~A[~D]: parens: ~D~%" file linectr p-parens)))
+ (set! p-parens 0)))
+
+ (set! commands (remove-one closer commands))
+ (when (and (not warned)
+ (eq? closer 'table)
+ (not (memq 'table commands)))
+ (if (memq 'tr commands)
+ (begin
+ (set! warned #t)
+ (set! commands (remove-all 'tr commands))
+ (format () "~A[~D]: unclosed tr at table (~A)~%" file linectr commands)))
+ (if (memq 'td commands)
+ (begin
+ (set! warned #t)
+ (set! commands (remove-all 'td commands))
+ (format () "~A[~D]: unclosed td at table (~A)~%" file linectr commands))))))
+ (set! closing #f))
+
+ ;; not closing
+ (unless scripting
+ (let ((opener (string->symbol (substring line (+ start 1) i))))
+ (if (eq? opener 'TABLE) (set! opener 'table))
+ (cond ((memq opener '(center big font))
+ (format () "~A[~D]: ~A is obsolete, ~A~%" file linectr opener line))
+
+ ((eq? opener 'script)
+ (set! scripting #t))
+
+ ((eq? opener 'img)
+ (let* ((rest-line (substring line (+ start 4)))
+ (alt-pos (string-position "alt=" rest-line))
+ (src-pos (string-position "src=" rest-line)))
+ (if (not alt-pos)
+ (format () "~A[~D]: img but no alt: ~A~%" file linectr line))
+ (if src-pos
+ (let ((png-pos (string-position ".png" rest-line)))
+ (if png-pos
+ (let ((file (substring rest-line (+ src-pos 5) (+ png-pos 4))))
+ (if (not (file-exists? file))
+ (format () "~A[~D]: src not found: ~S~%" file linectr file))))))))
+
+ ((and (not (memq opener '(br spacer li hr area
+ ul tr td table small sub blockquote)))
+ (memq opener commands)
+ (= p-quotes 0))
+ (format () "~A[~D]: nested ~A? ~A from: ~A~%" file linectr opener line commands))
+ (else
+ (case opener
+ ((td)
+ (if (not (eq? 'tr (car commands)))
+ (format () "~A[~D]: td without tr?~%" file linectr))
+ (if (and (not warned)
+ (memq 'td commands)
+ (< (count-table commands) 2))
+ (begin
+ (set! warned #t)
+ (set! commands (remove-one 'td commands))
+ (format () "~A[~D]: unclosed td at table~%" file linectr))))
+ ((tr)
+ (if (not (or (eq? (car commands) 'table)
+ (eq? (cadr commands) 'table)))
+ (format () "~A[~D]: tr without table?~%" file linectr))
+ (if (and (not warned)
+ (memq 'tr commands)
+ (< (count-table commands) 2))
+ (begin
+ (set! warned #t)
+ (set! commands (remove-one 'tr commands))
+ (format () "~A[~D]: unclosed tr at table~%" file linectr))))
+ ((p)
+ (if (eq? (car commands) 'table)
+ (format () "~A[~D]: unclosed table?~%" file linectr)))
+
+ ((pre br table hr img ul)
+ (if (memq 'p commands)
+ (format () "~A[~D]: ~A within <p>?~%" file linectr opener)))
+ ((li)
+ (if (not (memq 'ul commands))
+ (format () "~A[~D]: li without ul~%" file linectr)))
+ ((small)
+ (if (memq (car commands) '(pre code))
+ (format () "~A[~D]: small shouldn't follow ~A~%" file linectr (car commands))))
+ ((--)
+ (format () "~A[~D]: <-- missing !?~%" file linectr)))
+ (if (not (memq opener '(br meta spacer li hr area)))
+ (set! commands (cons opener commands))))))))
+ ;; end if closing
+ (set! start #f)))
+
+ ((#\<)
+ (if start
+ (if (not (or scripting
+ (positive? p-quotes)))
+ (format () "~A[~D]: nested < ~A~%" file linectr line))
+ (set! start i)))
+ ((#\/)
+ (if (and (integer? start) (= start (- i 1)))
+ (set! closing #t)))
+
+ ((#\!)
+ (if (and (integer? start) (= start (- i 1)))
+ (set! start #f)))))))
+ ) ; if not in-comment...
;; search for name
(let* ((dline line)
@@ -1592,16 +1547,17 @@
(string-position "</A>" dline))))
;;actually should look for close double quote
(if (not epos)
- (begin (format #t "~A[~D]: <em...> but no </em> for ~A~%" file linectr dline) (abort))
- (let ((min-epos (char-position #\space dline)))
- (set! epos (char-position #\> dline))
- (if (and (number? min-epos)
- (< min-epos epos))
- (set! epos min-epos))
+ (format () "~A[~D]: <em...> but no </em> for ~A~%" file linectr dline)
+ (begin
+ (let ((min-epos (char-position #\space dline)))
+ (set! epos (char-position #\> dline))
+ (if (and (number? min-epos)
+ (< min-epos epos))
+ (set! epos min-epos)))
(let ((new-name (string-append file "#" (substring dline 0 (- epos 1)))))
(if (hash-table-ref names new-name)
- (format #t "~A[~D]: ambiguous name: ~A~%" file linectr new-name))
+ (format () "~A[~D]: ambiguous name: ~A~%" file linectr new-name))
(hash-table-set! names new-name file))
(set! name (+ name 1))
@@ -1615,54 +1571,54 @@
(pos-len 7))
(do ()
((not pos))
- ;; (format #t "~A dline: ~A~%" pos dline)
+ ;; (format () "~A dline: ~A~%" pos dline)
(if (zero? (length dline)) (exit))
(set! dline (substring dline (+ pos pos-len)))
(let ((epos (char-position #\> dline)))
(if (not epos)
- (format #t "~A[~D]: <a href but no </a> for ~A~%" file linectr dline)
- (let ((cur-href #f))
+ (format () "~A[~D]: <a href but no </a> for ~A~%" file linectr dline)
+ (begin
(set! epos (char-position #\" dline 1))
- (if (char=? (dline 0) #\#)
- (set! cur-href (string-append file (substring dline 0 epos)))
- (begin
- (set! cur-href (substring dline 0 epos))
- (let ((pos (char-position #\# cur-href)))
- (if (and (not pos)
- (> epos 5)
- (not (file-exists? cur-href))
- (not (string=? (substring cur-href 0 4) "ftp:"))
- (not (string=? (substring cur-href 0 5) "http:")))
- (format #t "~A[~D]: reference to missing file ~S~%" file linectr cur-href)))))
-
- ;; cur-href here is the full link: sndclm.html#make-filetosample for example
- ;; it can also be a bare file name
- (let* ((start (char-position #\# cur-href))
- (name (and (number? start)
- (string->symbol (substring cur-href (+ start 1)))))
- (data (and (symbol? name)
- (hash-table-ref ids name))))
- (if name
- (if (not data)
- (format #t ";can't find id ~A~%" name)
- (hash-table-set! ids name (+ data 1)))))
-
+ (let ((cur-href #f))
+ (if (char=? (dline 0) #\#)
+ (set! cur-href (string-append file (substring dline 0 epos)))
+ (begin
+ (set! cur-href (substring dline 0 epos))
+ (let ((pos (char-position #\# cur-href)))
+ (if (not (or pos
+ (<= epos 5)
+ (file-exists? cur-href)
+ (string=? (substring cur-href 0 4) "ftp:")
+ (string=? (substring cur-href 0 5) "http:")))
+ (format () "~A[~D]: reference to missing file ~S~%" file linectr cur-href)))))
+
+ ;; cur-href here is the full link: sndclm.html#make-filetosample for example
+ ;; it can also be a bare file name
+ (let* ((start (char-position #\# cur-href))
+ (name (and (number? start)
+ (string->symbol (substring cur-href (+ start 1)))))
+ (data (and (symbol? name)
+ (hash-table-ref ids name))))
+ (if name
+ (if (not data)
+ (format () ";can't find id ~A~%" name)
+ (hash-table-set! ids name (+ data 1))))))
(set! href (+ href 1))
(set! dline (substring dline epos))
(set! pos (string-position " href=" dline))
(set! pos-len 7))))))))
)
(if (pair? commands)
- (format #t "open directives at end of ~A: ~A~%" file commands))))))
+ (format () "open directives at end of ~A: ~A~%" file commands))))))
files)
;; end file scan
- (format #t "found ~D names and ~D references~%" name href)
+ (format () "found ~D names and ~D references~%" name href)
(for-each
(lambda (data)
(if (zero? (cdr data))
- (format #t ";~A unref'd~%" (car data))))
+ (format () ";~A unref'd~%" (car data))))
ids)
))
diff --git a/tools/makegl.scm b/tools/makegl.scm
index 2c47bec..411ef9f 100755
--- a/tools/makegl.scm
+++ b/tools/makegl.scm
@@ -42,19 +42,15 @@
(set! in-glu #f))))
(define (cadr-str data)
- (let ((sp1 (char-position #\space data)))
- (let ((sp2 (char-position #\space data (+ sp1 1))))
- (if sp2
- (substring data (+ sp1 1) sp2)
- (substring data sp1)))))
+ (let* ((sp1 (char-position #\space data))
+ (sp2 (char-position #\space data (+ sp1 1))))
+ (substring data (if sp2 (values (+ sp1 1) sp2) sp1))))
(define (caddr-str data)
- (let ((sp1 (char-position #\space data)))
- (let ((sp2 (char-position #\space data (+ sp1 1))))
- (let ((sp3 (char-position #\space data (+ sp2 1))))
- (if sp3
- (substring data (+ sp2 1))
- (substring data sp2))))))
+ (let* ((sp1 (char-position #\space data))
+ (sp2 (char-position #\space data (+ sp1 1)))
+ (sp3 (char-position #\space data (+ sp2 1))))
+ (substring data (if sp3 (+ sp2 1) sp2))))
(define (car-str data)
(let ((sp (char-position #\space data)))
@@ -62,12 +58,6 @@
(substring data 0 sp)
data)))
-(define (cdr-str data)
- (let ((sp (char-position #\space data)))
- (if sp
- (substring data (+ sp 1))
- data)))
-
(define (ref-arg? arg)
(and (= (length arg) 3)
(string? (caddr arg))))
@@ -103,25 +93,14 @@
(substring type 0 (- (length type) 1))))
(define (deref-name arg)
- (let ((name (cadr arg)))
- (string-append "ref_" name)))
-
-(define (derefable type)
- (let ((len (length type)))
- (call-with-exit
- (lambda (return)
- (do ((i (- len 1) (- i 1))
- (ctr 0 (+ 1 ctr)))
- ((= i 0) #f)
- (if (not (char=? (type i) #\*))
- (return (> ctr 1))))))))
+ (string-append "ref_" (cadr arg)))
(define (has-stars type)
(let ((len (length type)))
(call-with-exit
(lambda (return)
(do ((i (- len 1) (- i 1)))
- ((= i 0) #f)
+ ((= i 0))
(if (char=? (type i) #\*)
(return #t)))
#f))))
@@ -138,16 +117,6 @@
(if (char=? (val i) #\*)
(set! (val i) #\_)))))))
-(define (no-arg-or-stars name)
- (let ((len (length name)))
- (call-with-exit
- (lambda (return)
- (do ((i 0 (+ i 1)))
- ((= i len) name)
- (if (or (char=? (name i) #\()
- (char=? (name i) #\*))
- (return (substring name 0 i))))))))
-
(define* (parse-args args x)
(let ((data ())
(sp -1)
@@ -158,41 +127,29 @@
(do ((i 0 (+ i 1)))
((= i len) (reverse data))
(let ((ch (args i)))
- (if (or (char=? ch #\space)
- (= i (- len 1)))
- (begin
- (if type
- (let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i)))
- (reftype #f))
- (if (char=? (given-name 0) #\@)
- (set! data (cons (list type
- (substring given-name 1 (length given-name))
- 'null)
- data))
- (if (char=? (given-name 0) #\#)
- (set! data (cons (list type
- (substring given-name 1 (length given-name))
- 'opt)
- data))
- (if (char=? (given-name 0) #\[)
- (begin
- (set! reftype (deref-type (list type)))
- (set! data (cons (list type
- (substring given-name 1 (- (length given-name) 1))
- given-name)
- data)))
- (set! data (cons (list type given-name) data)))))
- (if reftype (set! type reftype))
- (if (eq? x 'x)
- (if (not (member type x-types))
- (set! x-types (cons type x-types)))
- (if (and (not (eq? x 'g))
- (not (member type types)))
- (set! types (cons type types))))
- (set! type #f))
- (if (> i (+ 1 sp))
- (set! type (substring args (+ 1 sp) i))))
- (set! sp i))))))))
+ (when (or (char=? ch #\space)
+ (= i (- len 1)))
+ (if type
+ (let ((reftype #f))
+ (let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i))))
+ (case (given-name 0)
+ ((#\@) (set! data (cons (list type (substring given-name 1 (length given-name)) 'null) data)))
+ ((#\#) (set! data (cons (list type (substring given-name 1 (length given-name)) 'opt) data)))
+ ((#\[)
+ (set! reftype (deref-type (list type)))
+ (set! data (cons (list type (substring given-name 1 (- (length given-name) 1)) given-name) data)))
+ (else (set! data (cons (list type given-name) data)))))
+ (if reftype (set! type reftype))
+ (if (eq? x 'x)
+ (if (not (member type x-types))
+ (set! x-types (cons type x-types)))
+ (if (not (or (eq? x 'g)
+ (member type types)))
+ (set! types (cons type types))))
+ (set! type #f))
+ (if (> i (+ 1 sp))
+ (set! type (substring args (+ 1 sp) i))))
+ (set! sp i)))))))
(define (helpify name type args)
(let* ((initial (format #f " #define H_~A \"~A ~A(" name type name))
@@ -218,8 +175,7 @@
(set! line-len (+ 1 line-len))
(heyc " ")
(set! typed #t)))
- (if (and (not (char=? ch #\@))
- (not (char=? ch #\#)))
+ (if (not (memv ch '(#\@ #\#)))
(begin
(set! line-len (+ 1 line-len))
(heyc ch))))))
@@ -262,108 +218,101 @@
"gluTessNormal" "gluTessProperty" "gluNewTess"))
(define (c-to-xen-macro-name typ str)
- (if (string=? str "INT") "C_int_to_Xen_integer"
- (if (string=? str "DOUBLE") "C_double_to_Xen_real"
- (if (string=? str "BOOLEAN") "C_bool_to_Xen_boolean"
- (if (string=? str "ULONG") "C_ulong_to_Xen_ulong"
- (if (string-ci=? str "String")
- (if (string=? (car typ) "guchar*")
- "C_to_Xen_String"
- "C_string_to_Xen_string")
- (format #f "~A unknown" str)))))))
+ (cond ((assoc str '(("INT" . "C_int_to_Xen_integer")
+ ("DOUBLE" . "C_double_to_Xen_real")
+ ("BOOLEAN" . "C_bool_to_Xen_boolean")
+ ("ULONG" . "C_ulong_to_Xen_ulong"))
+ string=?) => cdr)
+ ((not (string-ci=? str "String"))
+ (format #f "~A unknown" str))
+ ((string=? (car typ) "guchar*")
+ "C_to_Xen_String")
+ (else "C_string_to_Xen_string")))
(define (xen-to-c-macro-name str)
- (if (string=? str "INT") "Xen_integer_to_C_int"
- (if (string=? str "DOUBLE") "Xen_real_to_C_double"
- (if (string=? str "BOOLEAN") "Xen_boolean_to_C_bool"
- (if (string=? str "ULONG") "Xen_ulong_to_C_ulong"
- (if (string-ci=? str "String")
- "Xen_string_to_C_string"
- (format #f "~A unknown" str)))))))
+ (cond ((assoc str '(("INT" . "Xen_integer_to_C_int")
+ ("DOUBLE" . "Xen_real_to_C_double")
+ ("BOOLEAN" . "Xen_boolean_to_C_bool")
+ ("ULONG" . "Xen_ulong_to_C_ulong"))
+ string=?) => cdr)
+ ((string-ci=? str "String") "Xen_string_to_C_string")
+ (else (format #f "~A unknown" str))))
(define (type-it type)
- (let ((typ (assoc type direct-types)))
- (if typ
- (if (cdr typ)
- (begin
- (if (string? (cdr typ))
- (begin
- (if (not (member (car typ)
- (list "Display*" "XVisualInfo*" "int*" "Pixmap" "Font" "GLubyte*"
- "GLdouble*" "GLfloat*" "GLvoid*" "GLuint*"
- "GLboolean*" "void*" "GLint*" "GLshort*"
- "GLsizei" "GLclampd" "GLclampf" "GLbitfield" "GLshort" "GLbyte"
- "unsigned_long"
- "void**")))
- (if (string=? (car typ) "constchar*")
- (hey "#define C_to_Xen_~A(Arg) C_string_to_Xen_string((char *)(Arg))~%" (no-stars (car typ)))
- (hey "#define C_to_Xen_~A(Arg) ~A(Arg)~%" (no-stars (car typ)) (c-to-xen-macro-name typ (cdr typ)))))
-
- (if (not (string=? (car typ) "constchar*"))
- (hey "#define Xen_to_C_~A(Arg) (~A)(~A(Arg))~%" (no-stars (car typ)) (car typ) (xen-to-c-macro-name (cdr typ))))
-
- (if (not (string=? (car typ) "constchar*"))
- (hey "#define Xen_is_~A(Arg) Xen_is_~A(Arg)~%"
- (no-stars (car typ))
- (if (string=? (cdr typ) "INT")
- "integer"
- (if (string=? (cdr typ) "ULONG")
- "ulong"
- (if (string=? (cdr typ) "DOUBLE")
- "number"
- (apply string (map char-downcase (cdr typ)))))))))
- (begin
- (hey "#define Xen_is_~A(Arg) 1~%" (no-stars (car typ)))
- (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars (car typ)))))))
-
- (if (not (or (string=? type "Display*") ; why are these 2 handled specially?
- (string=? type "XVisualInfo*")
- (string=? type "GLXContext"))) ; Snd g_snd_gl_context (snd-motif.c) calls this a pointer
- (begin
- (if (member type glu-1-2)
- (hey "#ifdef GLU_VERSION_1_2~%")
- (if (member type (list "GLUnurbs*" "GLUtesselator*" "GLUquadric*" "_GLUfuncptr"))
- (hey "#if HAVE_GLU~%")))
- (hey "XL_TYPE~A~A(~A, ~A)~%"
- (if (has-stars type) "_PTR" "")
- (if (member type (list "int*" "Pixmap" "Font" "GLubyte*"
- "GLdouble*" "GLfloat*" "GLvoid*"
- "GLuint*" "GLboolean*" "GLint*" "GLshort*"
- "PangoFontDescription*" "GtkWidget*" "GdkGLConfigMode"
- ))
- "_1"
- (if (member type (list "GdkVisual*" "PangoFont*" "GdkColormap*"))
- "_2"
- ""))
- (no-stars type)
- type)
- (if (or (member type glu-1-2)
- (member type (list "GLUnurbs*" "GLUtesselator*" "GLUquadric*" "_GLUfuncptr")))
- (hey "#endif~%")))
- (if (string=? type "Display*")
- (hey "XL_TYPE_PTR(Display, Display*)~%")
- (if (string=? type "XVisualInfo*")
- (hey "XL_TYPE_PTR(XVisualInfo, XVisualInfo*)~%")
- (hey "XL_TYPE_PTR(GLXContext, GLXContext)~%")
- ))))))
+ (cond ((assoc type direct-types) =>
+ (lambda (typ)
+ (when (cdr typ)
+ (if (string? (cdr typ))
+ (begin
+ (if (not (member type
+ '("Display*" "XVisualInfo*" "int*" "Pixmap" "Font" "GLubyte*"
+ "GLdouble*" "GLfloat*" "GLvoid*" "GLuint*"
+ "GLboolean*" "void*" "GLint*" "GLshort*"
+ "GLsizei" "GLclampd" "GLclampf" "GLbitfield" "GLshort" "GLbyte"
+ "unsigned_long"
+ "void**")))
+ (if (string=? type "constchar*")
+ (hey "#define C_to_Xen_~A(Arg) C_string_to_Xen_string((char *)(Arg))~%" (no-stars type))
+ (hey "#define C_to_Xen_~A(Arg) ~A(Arg)~%" (no-stars type) (c-to-xen-macro-name typ (cdr typ)))))
+
+ (unless (string=? type "constchar*")
+ (hey "#define Xen_to_C_~A(Arg) (~A)(~A(Arg))~%" (no-stars type) type (xen-to-c-macro-name (cdr typ)))
+ (hey "#define Xen_is_~A(Arg) Xen_is_~A(Arg)~%"
+ (no-stars type)
+ (cond ((assoc (cdr typ) '(("INT" . "integer")
+ ("ULONG" . "ulong")
+ ("DOUBLE" . "number")) string=?)
+ => cdr)
+ (else (apply string (map char-downcase (cdr typ))))))))
+ (begin
+ (hey "#define Xen_is_~A(Arg) 1~%" (no-stars type))
+ (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars type)))))))
+
+ ((not (member type '("Display*" "XVisualInfo*" "GLXContext") string=?))
+ ;; Snd g_snd_gl_context (snd-motif.c) calls GLXContext a pointer
+ (if (member type glu-1-2)
+ (hey "#ifdef GLU_VERSION_1_2~%")
+ (if (member type '("GLUnurbs*" "GLUtesselator*" "GLUquadric*" "_GLUfuncptr"))
+ (hey "#if HAVE_GLU~%")))
+ (hey "XL_TYPE~A~A(~A, ~A)~%"
+ (if (has-stars type) "_PTR" "")
+ (if (member type '("int*" "Pixmap" "Font" "GLubyte*"
+ "GLdouble*" "GLfloat*" "GLvoid*"
+ "GLuint*" "GLboolean*" "GLint*" "GLshort*"
+ "PangoFontDescription*" "GtkWidget*" "GdkGLConfigMode"))
+ "_1"
+ (if (member type '("GdkVisual*" "PangoFont*" "GdkColormap*"))
+ "_2"
+ ""))
+ (no-stars type)
+ type)
+ (if (or (member type glu-1-2)
+ (member type '("GLUnurbs*" "GLUtesselator*" "GLUquadric*" "_GLUfuncptr")))
+ (hey "#endif~%")))
+
+ ((string=? type "Display*")
+ (hey "XL_TYPE_PTR(Display, Display*)~%"))
+
+ ((string=? type "XVisualInfo*")
+ (hey "XL_TYPE_PTR(XVisualInfo, XVisualInfo*)~%"))
+
+ (else (hey "XL_TYPE_PTR(GLXContext, GLXContext)~%"))))
(define* (CFNC data spec spec-name)
(let ((name (cadr-str data))
(args (caddr-str data)))
(if (assoc name names)
- (format #t "~A CFNC~%" name)
+ (format () "~A CFNC~%" name)
(let ((type (car-str data)))
(if (not (member type types))
(set! types (cons type types)))
(let ((strs (parse-args args)))
- (if spec
- (set! funcs (cons (list name type strs args spec spec-name) funcs))
- (set! funcs (cons (list name type strs args) funcs)))
+ (set! funcs (cons (list name type strs (if spec (values args spec spec-name) args)) funcs))
(set! names (cons (cons name 'fnc) names)))))))
(define* (CINT name type)
(if (assoc name names)
- (format #t "~A CINT~%" name)
+ (format () "~A CINT~%" name)
(begin
(set! ints (cons name ints))
(set! names (cons (cons name 'int) names)))))
@@ -372,32 +321,21 @@
(let ((name (cadr-str data))
(args (caddr-str data)))
(if (assoc name names)
- (format #t "~A CFNC-X~%" name)
+ (format () "~A CFNC-X~%" name)
(let ((type (car-str data)))
(if (not (member type x-types))
(set! x-types (cons type x-types)))
(let ((strs (parse-args args 'x)))
- (if spec
- (set! x-funcs (cons (list name type strs args spec spec-name) x-funcs))
- (set! x-funcs (cons (list name type strs args) x-funcs)))
+ (set! x-funcs (cons (list name type strs (if spec (values args spec spec-name) args)) x-funcs))
(set! names (cons (cons name 'fnc) names)))))))
(define* (CINT-X name type)
(if (assoc name names)
- (format #t "~A CINT-X~%" name)
+ (format () "~A CINT-X~%" name)
(begin
(set! x-ints (cons name x-ints))
(set! names (cons (cons name 'int) names)))))
-(define (no-arg name)
- (let ((len (length name)))
- (call-with-exit
- (lambda (return)
- (do ((i 0 (+ i 1)))
- ((= i len) name)
- (if (char=? (name i) #\()
- (return (substring name 0 i))))))))
-
;;; ---------------------------------------- read data ----------------------------------------
(load "gldata.scm")
@@ -568,14 +506,14 @@
(let* ((name (car data))
(return-type (cadr data))
(args (caddr data))
+ (argslen (length args))
(cargs (length args))
(refargs (ref-args args))
(xgargs (- cargs refargs))
(argstr (cadddr data))
;(lambda-type (cdr (assoc name names)))
(arg-start 0)
- (line-len 0)
- (line-max 120))
+ (line-len 0))
(define (hey-start)
;; start of checked line
@@ -595,12 +533,9 @@
;; cr ok after arg
(set! line-len (+ line-len (length arg)))
(heyc arg)
- (if (> line-len line-max)
+ (if (> line-len 120)
(begin
- (hey "~%")
- (do ((i 0 (+ i 1)))
- ((= i arg-start))
- (heyc " "))
+ (format gl-file "~%~NC" arg-start #\space)
(set! line-len arg-start))))
(check-glu name)
@@ -610,9 +545,9 @@
(eq? (data 4) 'if))
(hey "#if HAVE_~A~%" (string-upcase (symbol->string (data 5)))))
(hey "static Xen gxg_~A(" name)
- (if (= (length args) 0)
+ (if (null? args)
(heyc "void")
- (if (>= (length args) max-args)
+ (if (>= argslen max-args)
(heyc "Xen arglist")
(let ((previous-arg #f))
(for-each
@@ -634,7 +569,7 @@
(hey " ~A ~A[16];~%" (deref-type arg) (deref-name arg))
(hey " ~A ~A[1];~%" (deref-type arg) (deref-name arg)))))
args))
- (if (and (>= (length args) max-args)
+ (if (and (>= argslen max-args)
(> xgargs 0))
(let ((previous-arg #f))
(heyc " Xen ")
@@ -654,7 +589,7 @@
(hey " ~A = Xen_list_ref(arglist, ~D);~%" (cadr arg) ctr))
(set! ctr (+ 1 ctr)))
args))))
- (if (> (length args) 0)
+ (if (> argslen 0)
(let ((ctr 1))
(for-each
(lambda (arg)
@@ -673,23 +608,23 @@
(no-stars argtype) argname argname ctr name argtype))))
(set! ctr (+ 1 ctr))))
args)))
- (let ((using-result #f))
- (set! using-result (and (> refargs 0)
- (not (string=? return-type "void"))))
+ (let ((using-result (and (> refargs 0)
+ (not (string=? return-type "void")))))
(if using-result
(begin
(hey " {~%")
(hey " Xen result;~%")))
(hey-start)
- (if (not (string=? return-type "void"))
- (if (= refargs 0)
- (hey-on " return(C_to_Xen_~A(" (no-stars return-type))
- (hey-on " result = C_to_Xen_~A(" (no-stars return-type)))
- (hey-on " "))
+ (if (string=? return-type "void")
+ (hey-on " ")
+ (hey-on (if (= refargs 0)
+ " return(C_to_Xen_~A("
+ " result = C_to_Xen_~A(")
+ (no-stars return-type)))
(hey-on "~A(" name)
(hey-mark)
- (if (> (length args) 0)
+ (if (> argslen 0)
(let ((previous-arg #f))
(for-each
(lambda (arg)
@@ -717,13 +652,13 @@
(hey " {~%")
(if (not using-result)
(hey " Xen result;~%"))
- (hey " int i, vals;~%")
- (hey " vals = how_many_vals(Xen_to_C_GLenum(pname));~%")
- (hey " result = Xen_empty_list;~%")
- (hey " for (i = 0; i < vals; i++)~%")
+ (hey " int i, vals;~% ~
+ vals = how_many_vals(Xen_to_C_GLenum(pname));~% ~
+ result = Xen_empty_list;~% ~
+ for (i = 0; i < vals; i++)~%")
(hey " result = Xen_cons(C_to_Xen_~A(~A[i]), result);~%"
- (no-stars (deref-type (args (- (length args) 1))))
- (deref-name (args (- (length args) 1))))
+ (no-stars (deref-type (args (- argslen 1))))
+ (deref-name (args (- argslen 1))))
(hey " return(result);~%")
(hey " }~%"))
(begin
@@ -763,21 +698,22 @@
(define (argify-func func)
(let ((cargs (length (caddr func)))
- (name (car func))
(refargs (+ (ref-args (caddr func)) (opt-args (caddr func))))
;(args (- cargs refargs))
(if-fnc (and (> (length func) 4)
(eq? (func 4) 'if))))
- (check-glu name)
- (if (member name glu-1-2) (hey "#ifdef GLU_VERSION_1_2~%"))
+ (let ((name (car func)))
+ (check-glu name)
+ (if (member name glu-1-2) (hey "#ifdef GLU_VERSION_1_2~%")))
(if if-fnc
(hey "#if HAVE_~A~%" (string-upcase (symbol->string (func 5)))))
(hey "Xen_wrap_~A(gxg_~A_w, gxg_~A)~%"
(if (>= cargs max-args)
"any_args"
- (if (> refargs 0)
- (format #f "~D_optional_arg~A" cargs (if (= cargs 1) "" "s"))
- (format #f "~A_arg~A" (if (zero? cargs) "no" (number->string cargs)) (if (= cargs 1) "" "s"))))
+ (format #f (values (if (> refargs 0)
+ (values "~D_optional_arg~A" cargs)
+ (values "~A_arg~A" (if (zero? cargs) "no" (number->string cargs))))
+ (if (= cargs 1) "" "s"))))
(car func) (car func))
(if if-fnc
(hey "#endif~%"))
@@ -796,23 +732,23 @@
(define (gtk-type->s7-type gtk)
(let ((dt (assoc gtk direct-types)))
- (if (and (pair? dt)
- (string? (cdr dt)))
+ (or (not (and (pair? dt)
+ (string? (cdr dt))))
(let ((direct (cdr dt)))
(cond ((member direct '("INT" "ULONG") string=?) 'integer?)
- ((string=? direct "BOOLEAN") 'boolean?)
- ((string=? direct "DOUBLE") 'real?)
- ((string=? direct "CHAR") 'char?)
- ((string=? direct "String") 'string?)
- (#t #t)))
- #t)))
+ ((assoc direct '(("BOOLEAN" . boolean?)
+ ("DOUBLE" . real?)
+ ("CHAR" . char?)
+ ("String" . string?))
+ string=?) => cdr)
+ (#t #t))))))
(define (make-signature fnc)
(define (compress sig)
(if (and (pair? sig)
(pair? (cdr sig))
- (or (not (eq? (car sig) 'pair?))
- (not (null? (cddr sig))))
+ (not (and (eq? (car sig) 'pair?)
+ (null? (cddr sig))))
(eq? (car sig) (cadr sig)))
(compress (cdr sig))
sig))
@@ -830,9 +766,7 @@
(let ((sig (make-signature f)))
(if (pair? sig)
(let ((count (signatures sig)))
- (if (not count)
- (set! (signatures sig) 0)
- (set! (signatures sig) (+ count 1)))))))
+ (set! (signatures sig) (if (not count) 0 (+ count 1)))))))
lst))
(make-signatures funcs)
@@ -915,14 +849,14 @@
(if (member name glu-1-2) (hey "#ifdef GLU_VERSION_1_2~%"))
(hey " gl_define_procedure(~A, gxg_~A_w, ~D, ~D, ~D, H_~A, ~A);~%"
- (car func) (car func)
+ name name
(if (>= cargs max-args) 0 args)
(if (>= cargs max-args) 0 refargs) ; optional ignored
(if (>= cargs max-args) 1 0)
- (car func)
+ name
(sig-name (make-signature func)))
- (if (member (car func) glu-1-2) (hey "#endif~%"))
+ (if (member name glu-1-2) (hey "#endif~%"))
))
(hey "#if USE_MOTIF~%")
@@ -964,11 +898,7 @@
(hey " DEFINE_INTEGER(~A);~%" val))
(reverse ints))
-(if in-glu
- (begin
- (hey "#endif~%")
- (set! in-glu #f)))
-
+(uncheck-glu)
(hey "}~%~%")
diff --git a/tools/makexg.scm b/tools/makexg.scm
index a33444c..c18caab 100755
--- a/tools/makexg.scm
+++ b/tools/makexg.scm
@@ -32,9 +32,11 @@
))
(define no-c-to-xen
- (list "CellLayoutDataFunc" "GClosureNotify" "GDestroyNotify" "GError**" "GParamSpec*" "GQuark*" "GSignalAccumulator"
+ (list "CellLayoutDataFunc" "GClosureNotify" "GDestroyNotify" "GError**" "GParamSpec*" "GQuark*"
+ "GSignalAccumulator"
"GSignalCMarshaller" "GSignalEmissionHook" "GSignalQuery*" "GSourceFunc" "GString*" "GTimeVal*" "GType*"
- "GdkBitmap**" "GdkDragProtocol*" "GdkEventButton*" "GdkEventConfigure*" "GdkEventCrossing*" "GdkEventDND*"
+ "GdkBitmap**" ;"GdkDragProtocol*"
+ "GdkEventButton*" "GdkEventConfigure*" "GdkEventCrossing*" "GdkEventDND*"
"GdkEventExpose*" "GdkEventFocus*" "GdkEventMotion*" "GdkEventNoExpose*" "GdkEventProperty*" "GdkEventProximity*"
"GdkEventScroll*" "GdkEventSelection*" "GdkEventSetting*" "GdkEventVisibility*" "GdkEventWindowState*" "GdkGCValues*"
"GdkGeometry*" "GdkInterpType" "GdkModifierType*" "GdkPixbufDestroyNotify" "GdkScreen**" "GdkSegment*" "GdkWChar*"
@@ -52,21 +54,27 @@
"GtkScale*" "GtkScrolledWindow*" "GtkSeparatorToolItem*" "GtkSettingsValue*" "GtkSocket*" "GtkSortType*" "GtkSpinButton*"
"GtkStatusbar*" "GtkTable*" "GtkTextCharPredicate" "GtkTextTagTableForeach" "GtkTextView*"
"GtkToggleActionEntry*" "GtkToggleButton*" "GtkToggleToolButton*" "GtkToolButton*" "GtkToolbar*" "GtkTreeDragDest*"
- "GtkTreeDragSource*" "GtkTreeModel**" "GtkTreeModelFilter*" "GtkTreeModelSort*" "GtkTreeSortable*" "GtkUIManagerItemType"
+ "GtkTreeDragSource*" "GtkTreeModel**" "GtkTreeModelFilter*" "GtkTreeModelSort*" "GtkTreeSortable*" ;"GtkUIManagerItemType"
"GtkViewport*" "PangoAnalysis*" "PangoAttrList**" "PangoFontDescription**" "PangoRectangle*"
- "gchar***" "gfloat*" "gint8*" "gssize" "guint16*" "gunichar*" "GtkFileChooserButton*" "GtkPathPriorityType"
+ "gchar***" "gfloat*" "gint8*" "gssize" "guint16*" "gunichar*" "GtkFileChooserButton*" ;"GtkPathPriorityType"
"GtkCellView*" "GValue*" "GtkAboutDialog*" "PangoAttrFilterFunc" "PangoScript*" "GtkMenuToolButton*"
"GtkClipboardImageReceivedFunc" "PangoMatrix*" "GdkTrapezoid*" "GdkPangoRenderer*" "PangoRenderPart"
"GLogFunc" "GError*" "guint32*"
"GConnectFlags" "GSignalFlags" "GSignalMatchType"
;"GdkAxisUse"
- "GdkFillRule" "GdkGCValuesMask"
- "GdkPropMode" "GdkRgbDither" "GdkWMFunction" "GdkWindowEdge" "GdkWindowHints" "GtkAccelFlags" ; "GtkArrowType"
- "GtkAttachOptions" "GtkCellRendererState" "GtkCurveType" "GtkDestDefaults" "GtkDestroyNotify" "GtkDialogFlags"
- "GtkDirectionType" "GtkExpanderStyle" "GtkIconLookupFlags" ;"GtkMenuPositionFunc"
+ ;"GdkFillRule"
+ ;"GdkGCValuesMask"
+ "GdkPropMode" ;"GdkRgbDither"
+ "GdkWMFunction" "GdkWindowEdge" "GdkWindowHints" "GtkAccelFlags" ; "GtkArrowType"
+ ;"GtkAttachOptions"
+ "GtkCellRendererState" ;"GtkCurveType"
+ "GtkDestDefaults" "GtkDestroyNotify" "GtkDialogFlags"
+ "GtkDirectionType" ;"GtkExpanderStyle"
+ "GtkIconLookupFlags" ;"GtkMenuPositionFunc"
"GtkPathType" "GtkSpinType"
- "GtkTextSearchFlags" "GtkTreeIterCompareFunc" "GtkTreeSelectionFunc" "GtkUIManagerItemType" "GtkWindowPosition"
+ "GtkTextSearchFlags" "GtkTreeIterCompareFunc" "GtkTreeSelectionFunc" ;"GtkUIManagerItemType"
+ "GtkWindowPosition"
"PangoGlyph" "PangoUnderline" "gssize"
"GtkMenuBar*" "GtkTranslateFunc" ;"GtkMenuPositionFunc"
@@ -84,12 +92,14 @@
"GtkPrintOperationAction"
"GtkTooltip*" "GtkCalendarDetailFunc" "GtkScaleButton*" "GtkEntryIconPosition"
- "GdkDragAction" "GdkImageType"
+ "GdkDragAction" ;"GdkImageType"
- "gdouble*" "GdkFill" "GdkSubwindowMode" "GdkLineStyle" "GdkCapStyle" "GdkJoinStyle"
+ "gdouble*" ;"GdkFill"
+ ;"GdkSubwindowMode" ;"GdkLineStyle" "GdkCapStyle" "GdkJoinStyle"
"GtkInfoBar*" "GtkSpinner*" "GtkToolShell*" "GtkToolPalette*" "GtkToolPaletteDragTargets"
- "GdkFunction" "GtkWrapBoxPacking" "GtkLinkButton*" "GtkActivatable*" "GtkOrientable*" "GtkCellArea*"
- "GdkNativeWindow"
+ ;"GdkFunction" ;"GtkWrapBoxPacking"
+ "GtkLinkButton*" "GtkActivatable*" "GtkOrientable*" "GtkCellArea*"
+ ;"GdkNativeWindow"
"GdkRectangle*" "PangoRenderer*" "cairo_glyph_t**" "cairo_text_cluster_t**"
; "cairo_text_cluster_flags_t"
; "cairo_rectangle_int_t"
@@ -125,7 +135,8 @@
"GValue*" "GdkByteOrder" "GdkCrossingMode" "GdkEventType" "GdkGrabStatus" "GdkNotifyType"
;"GdkOverlapType"
- "GdkScrollDirection" "GdkSettingAction" "GdkVisibilityState" "GdkWindowState" "GdkWindowType"
+ "GdkScrollDirection" "GdkSettingAction" ;"GdkVisibilityState"
+ "GdkWindowState" "GdkWindowType"
"GtkImageType" "GtkTreeModelFlags" "gint8" "gshort" "guint8" "lambda" "gboolean*"
"time_t" ;"GtkWindowGroup*"
@@ -147,7 +158,8 @@
"GValue*" "GdkByteOrder" "GdkCrossingMode" "GdkEventType" "GdkGrabStatus" "GdkNotifyType"
;"GdkOverlapType"
- "GdkScrollDirection" "GdkSettingAction" "GdkVisibilityState" "GdkWindowState" "GdkWindowType"
+ "GdkScrollDirection" "GdkSettingAction" ;"GdkVisibilityState"
+ "GdkWindowState" "GdkWindowType"
"GtkImageType" "GtkTreeModelFlags" "etc" "gshort" "gboolean*"
;"GtkWindowGroup*"
@@ -163,19 +175,15 @@
))
(define (cadr-str data)
- (let ((sp1 (char-position #\space data)))
- (let ((sp2 (char-position #\space data (+ sp1 1))))
- (if sp2
- (substring data (+ sp1 1) sp2)
- (substring data sp1)))))
+ (let* ((sp1 (char-position #\space data))
+ (sp2 (char-position #\space data (+ sp1 1))))
+ (substring data (if sp2 (values (+ sp1 1) sp2) sp1))))
(define (caddr-str data)
- (let ((sp1 (char-position #\space data)))
- (let ((sp2 (char-position #\space data (+ sp1 1))))
- (let ((sp3 (char-position #\space data (+ sp2 1))))
- (if sp3
- (substring data (+ sp2 1))
- (substring data sp2))))))
+ (let* ((sp1 (char-position #\space data))
+ (sp2 (char-position #\space data (+ sp1 1)))
+ (sp3 (char-position #\space data (+ sp2 1))))
+ (substring data (if sp3 (+ sp2 1) sp2))))
(define (car-str data)
(let ((sp (char-position #\space data)))
@@ -183,17 +191,11 @@
(substring data 0 sp)
data)))
-(define (cdr-str data)
- (let ((sp (char-position #\space data)))
- (if sp
- (substring data (+ sp 1))
- data)))
-
-(define (remove-if p l)
- (cond ((null? l) ())
- ((p (car l)) (remove-if p (cdr l)))
- (else (cons (car l)
- (remove-if p (cdr l))))))
+(define (remove-if p lst)
+ (cond ((null? lst) ())
+ ((p (car lst)) (remove-if p (cdr lst)))
+ (else (cons (car lst)
+ (remove-if p (cdr lst))))))
(define (ref-arg? arg)
(and (= (length arg) 3)
@@ -207,10 +209,6 @@
(and (= (length arg) 3)
(eq? (caddr arg) 'opt)))
-(define (settable-field? arg)
- (and (= (length arg) 3)
- (eq? (caddr arg) 'set)))
-
(define (ref-args args)
(let ((ctr 0))
(for-each
@@ -238,8 +236,7 @@
(substring type 0 (- (length type) 2))))
(define (deref-name arg)
- (let ((name (cadr arg)))
- (string-append "ref_" name)))
+ (string-append "ref_" (cadr arg)))
(define (derefable type)
(let ((st (char-position #\* type)))
@@ -256,12 +253,6 @@
(if (char=? (val i) #\*)
(set! (val i) #\_)))))
-(define (no-arg-or-stars name)
- (let ((pos (char-position "(*" name)))
- (if pos
- (substring name 0 pos)
- name)))
-
(define (parse-args args extra)
(let ((data ())
(sp -1)
@@ -272,299 +263,49 @@
(do ((i 0 (+ i 1)))
((= i len) (reverse data))
(let ((ch (args i)))
- (if (or (char=? ch #\space)
- (= i (- len 1)))
- (begin
- (if type
- (let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i)))
- (reftype #f))
- (if (char=? (given-name 0) #\@)
- (set! data (cons (list type
- (substring given-name 1 (length given-name))
- 'null)
- data))
- (if (char=? (given-name 0) #\#)
- (set! data (cons (list type
- (substring given-name 1 (length given-name))
- 'opt)
- data))
- (if (or (char=? (given-name 0) #\[)
- (char=? (given-name 0) #\{)
- (char=? (given-name 0) #\|))
- (begin
- (set! reftype (deref-type (list type)))
- (set! data (cons (list type
- (substring given-name 1 (- (length given-name) 1))
- given-name)
- data)))
- (if (char=? (given-name 0) #\&)
- (set! data (cons (list type
- (substring given-name 1 (length given-name))
- 'set)
- data))
- (set! data (cons (list type given-name) data))))))
- (if reftype (set! type reftype))
-
- (if (not (member type all-types))
- (begin
- (set! all-types (cons type all-types))
- (case extra
- ((g-2.14) (set! types-2.14 (cons type types-2.14)))
- ((g-2.16) (set! types-2.16 (cons type types-2.16)))
- ((g-2.18) (set! types-2.18 (cons type types-2.18)))
- ((g-2.20) (set! types-2.20 (cons type types-2.20)))
- ((g-3.0) (set! types-3.0 (cons type types-3.0)))
- ((g-3.2) (set! types-3.2 (cons type types-3.2)))
- ((g-3.4) (set! types-3.4 (cons type types-3.4)))
- ((g-3.6) (set! types-3.6 (cons type types-3.6)))
- ((g-3.8) (set! types-3.8 (cons type types-3.8)))
- ((g-3.10) (set! types-3.10 (cons type types-3.10)))
- ((g-3.12) (set! types-3.12 (cons type types-3.12)))
- ((g-3.14) (set! types-3.14 (cons type types-3.14)))
- ((g-3.16) (set! types-3.16 (cons type types-3.16)))
- ((g-3.18) (set! types-3.18 (cons type types-3.18)))
- ((g-3.20) (set! types-3.20 (cons type types-3.20)))
- ((cairo) (set! cairo-types (cons type cairo-types)))
- ((cairo-810) (set! cairo-types-810 (cons type cairo-types-810)))
- ((cairo-912) (set! cairo-types-912 (cons type cairo-types-912)))
- (else (if (not (member type types))
- (set! types (cons type types)))))))
- (set! type #f))
- (if (> i (+ 1 sp))
- (set! type (substring args (+ 1 sp) i))))
- (set! sp i))))))))
-
-(define callbacks (list
- ; (list 'lambda2 ; unnamed gdk_window_invalidate_maybe_recurse argument (2.90.6 now)
- ; "gboolean"
- ; "child_func"
- ; (parse-args "GdkWindow* window lambda_data func_info" 'callback)
- ; 'temporary)
- (list 'lambda3 ; unnamed gtk_accel_group_find argument
- "gboolean"
- "find_func"
- (parse-args "GtkAccelKey* key GClosure* closure lambda_data func_info" 'callback)
- 'temporary) ; ??
- (list 'GtkCallback
- "void"
- "func2"
- (parse-args "GtkWidget* w lambda_data func_info" 'callback)
- 'temporary)
- (list 'GSourceFunc
- "gboolean"
- "timer_func"
- (parse-args "lambda_data func_info" 'callback)
- 'semi-permanent)
- (list 'GtkDestroyNotify
- "void"
- "destroy_func"
- (parse-args "lambda_data func_info" 'callback)
- 'permanent)
- (list 'GdkFilterFunc
- "GdkFilterReturn"
- "filter_func"
- (parse-args "GdkXEvent* xevent GdkEvent* event lambda_data func_info" 'callback)
- 'permanent)
- (list 'GdkEventFunc
- "void"
- "event_func"
- (parse-args "GdkEvent* event lambda_data func_info" 'callback)
- 'permanent)
- ; (list 'GdkSpanFunc
- ; "void"
- ; "span_func"
- ; (parse-args "GdkSpan* span lambda_data func_info" 'callback)
- ; 'temporary)
- ; (list 'GtkFunction
- ; "gboolean"
- ; "func1"
- ; (parse-args "lambda_data func_info" 'callback)
- ; 'semi-permanent)
- ; (list 'GtkKeySnoopFunc
- ; "gint"
- ; "snoop_func"
- ; (parse-args "GtkWidget* widget GdkEventKey* event lambda_data func_info" 'callback)
- ; 'semi-permanent)
- (list 'GtkMenuPositionFunc
- "void"
- "menu_position_func"
- (parse-args "GtkMenu* menu gint* [x] gint* [y] gboolean* [push] lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkTextTagTableForeach
- "void"
- "text_tag_table_foreach"
- (parse-args "GtkTextTag* tag lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkAccelMapForeach
- "void"
- "accel_map_foreach"
- (parse-args "lambda_data func_info gchar* accel_path guint accel_key GdkModifierType accel_mods gboolean changed" 'callback)
- 'temporary)
- (list 'GtkTreeModelForeachFunc
- "gboolean"
- "model_func"
- (parse-args "GtkTreeModel* model GtkTreePath* path GtkTreeIter* iter lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkTreeSelectionForeachFunc
- "void"
- "tree_selection_func"
- (parse-args "GtkTreeModel* model GtkTreePath* path GtkTreeIter* iter lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkClipboardReceivedFunc
- "void"
- "clip_received"
- (parse-args "GtkClipboard* clipboard GtkSelectionData* selection_data lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkClipboardTextReceivedFunc
- "void"
- "clip_text_received"
- (parse-args "GtkClipboard* clipboard gchar* text lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkClipboardTargetsReceivedFunc
- "void"
- "clip_targets_received"
- (parse-args "GtkClipboard* clipboard GdkAtom* atoms gint n_atoms lambda_data func_info" 'callback)
- 'temporary)
- ; (list 'GtkMenuDetachFunc
- ; "void"
- ; "menu_detach_func"
- ; (parse-args "GtkWidget* attach_widget GtkMenu* menu" 'callback)
- ; 'permanent)
-;;; detach func is not passed user-data, so it would have to be implemented by hand
- (list 'GtkTextCharPredicate
- "gboolean"
- "text_char_predicate"
- (parse-args "gunichar ch lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkTreeViewColumnDropFunc
- "gboolean"
- "tree_column"
- (parse-args "GtkTreeView* tree_view GtkTreeViewColumn* column GtkTreeViewColumn* prev_column GtkTreeViewColumn* next_column lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkTreeViewMappingFunc
- "void"
- "tree_mapping"
- (parse-args "GtkTreeView* tree_view GtkTreePath* path lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkTreeViewSearchEqualFunc
- "gboolean"
- "tree_search"
- (parse-args "GtkTreeModel* model gint column gchar* key GtkTreeIter* iter lambda_data func_info" 'callback)
- 'temporary)
- (list 'GtkTreeCellDataFunc
- "void"
- "cell_data"
- (parse-args "GtkTreeViewColumn* tree_column GtkCellRenderer* cell GtkTreeModel* tree_model GtkTreeIter* iter lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkTreeIterCompareFunc
- "gint"
- "iter_compare"
- (parse-args "GtkTreeModel* model GtkTreeIter* a GtkTreeIter* b lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkTreeSelectionFunc
- "gboolean"
- "tree_selection"
- (parse-args "GtkTreeSelection* selection GtkTreeModel* model GtkTreePath* path gboolean path_currently_selected lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkClipboardGetFunc
- "void"
- "clip_get"
- (parse-args "GtkClipboard* clipboard GtkSelectionData* selection_data guint info lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkClipboardClearFunc
- "void"
- "clip_clear"
- (parse-args "GtkClipboard* clipboard lambda_data func_info" 'callback)
- 'permanent)
-
- ; GCallback 'lambda can be whatever is indicated by caller (2 or more args)
-
- (list 'GtkFileFilterFunc
- "gboolean"
- "file_filter"
- (parse-args "GtkFileFilterInfo* info lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkEntryCompletionMatchFunc
- "gboolean"
- "entry_completion_match"
- (parse-args "GtkEntryCompletion* completion gchar* key GtkTreeIter* iter lambda_data func_info" 'callback)
- 'permanent)
-
- (list 'GtkTreeViewRowSeparatorFunc
- "gboolean"
- "row_separator"
- (parse-args "GtkTreeModel* model GtkTreeIter* iter lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkIconViewForeachFunc
- "void"
- "icon_view_foreach"
- (parse-args "GtkIconView* icon_view GtkTreePath* path lambda_data func_info" 'callback)
- 'permanent)
-
- (list 'GtkClipboardImageReceivedFunc
- "void"
- "clip_image_received"
- (parse-args "GtkClipboard* clipboard GdkPixbuf* pixbuf lambda_data func_info" 'callback) ; 'callback)
- ;; these arg types are not new in 256, but this parse-args precedes the basic ones, so comment out the callback
- ;; the problem here (and below callback) is that parse-args sees a new type (new to it so far),
- ;; and chooses which type list to put it on based on the "extra" arg -- since these types
- ;; are not new in version 2.5.6, we don't want the callback flag to sequester them
- ;; on the 256-type list.
- 'permanent)
- (list 'GLogFunc
- "void"
- "g_message_log_func"
- (parse-args "gchar* domain GLogLevelFlags log_level gchar* message lambda_data func_info" 'callback)
- 'permanent)
-
- (list 'GtkClipboardRichTextReceivedFunc
- "void"
- "clip_rich_text_received"
- (parse-args "GtkClipboard* clipboard GdkAtom format guint8* text gsize length lambda_data func_info" 'callback); 'callback)
- ;; guint8* is const
- 'permanent-gcc)
-; (list 'GtkRecentFilterFunc
-; "gboolean"
-; "recent_filter"
-; (parse-args "GtkRecentFilterInfo* filter_info lambda_data func_info" 'callback)
-; ;; const filter info
-; 'permanent-gcc)
- (list 'GtkTreeViewSearchPositionFunc
- "void"
- "search_position"
- (parse-args "GtkTreeView* tree_view GtkWidget* search_dialog lambda_data func_info" 'callback)
- 'permanent)
- (list 'GtkAssistantPageFunc
- "gint"
- "page_func"
- (parse-args "gint current_page lambda_data func_info" 'callback)
- 'permanent)
- ; (list 'GtkLinkButtonUriFunc
- ; "void"
- ; "link_button_uri"
- ; (parse-args "GtkLinkButton* button gchar* link lambda_data func_info" 'callback)
- ; ;; const gchar *link
- ; 'permanent)
- (list 'GtkRecentSortFunc
- "gint"
- "recent_sort"
- (parse-args "GtkRecentInfo* a GtkRecentInfo* b lambda_data func_info" 'callback)
- 'permanent)
- ))
-
-
-(define callback-name car)
-(define callback-type cadr)
-(define callback-func caddr)
-(define callback-args cadddr)
-(define (callback-gc func) (func 4))
-
-(define (find-callback test)
- (define (find-callback-1 test funcs)
- (and (pair? funcs)
- (or (test (car funcs))
- (find-callback-1 test (cdr funcs)))))
- (find-callback-1 test callbacks))
+ (when (or (char=? ch #\space)
+ (= i (- len 1)))
+ (if (not type)
+ (if (> i (+ 1 sp))
+ (set! type (substring args (+ 1 sp) i)))
+ (let ((reftype #f))
+ (let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i))))
+ (case (given-name 0)
+ ((#\@) (set! data (cons (list type (substring given-name 1 (length given-name)) 'null) data)))
+ ((#\#) (set! data (cons (list type (substring given-name 1 (length given-name)) 'opt) data)))
+ ((#\&) (set! data (cons (list type (substring given-name 1 (length given-name)) 'set) data)))
+ ((#\[ #\{ #\|)
+ (set! reftype (deref-type (list type)))
+ (set! data (cons (list type (substring given-name 1 (- (length given-name) 1)) given-name) data)))
+ (else (set! data (cons (list type given-name) data)))))
+ (if reftype (set! type reftype))
+
+ (unless (member type all-types)
+ (set! all-types (cons type all-types))
+ (case extra
+ ((g-2.14) (set! types-2.14 (cons type types-2.14)))
+ ((g-2.16) (set! types-2.16 (cons type types-2.16)))
+ ((g-2.18) (set! types-2.18 (cons type types-2.18)))
+ ((g-2.20) (set! types-2.20 (cons type types-2.20)))
+ ((g-3.0) (set! types-3.0 (cons type types-3.0)))
+ ((g-3.2) (set! types-3.2 (cons type types-3.2)))
+ ((g-3.4) (set! types-3.4 (cons type types-3.4)))
+ ((g-3.6) (set! types-3.6 (cons type types-3.6)))
+ ((g-3.8) (set! types-3.8 (cons type types-3.8)))
+ ((g-3.10) (set! types-3.10 (cons type types-3.10)))
+ ((g-3.12) (set! types-3.12 (cons type types-3.12)))
+ ((g-3.14) (set! types-3.14 (cons type types-3.14)))
+ ((g-3.16) (set! types-3.16 (cons type types-3.16)))
+ ((g-3.18) (set! types-3.18 (cons type types-3.18)))
+ ((g-3.20) (set! types-3.20 (cons type types-3.20)))
+ ((g-3.22) (set! types-3.22 (cons type types-3.22)))
+ ((cairo) (set! cairo-types (cons type cairo-types)))
+ ((cairo-810) (set! cairo-types-810 (cons type cairo-types-810)))
+ ((cairo-912) (set! cairo-types-912 (cons type cairo-types-912)))
+ (else (if (not (member type types))
+ (set! types (cons type types))))))
+ (set! type #f)))
+ (set! sp i)))))))
(define direct-types
(list (cons "void" #f)
@@ -608,30 +349,30 @@
(cons "GConnectFlags" "INT")
(cons "GSignalMatchType" "INT")
(cons "GSignalFlags" "INT")
- (cons "GdkInputCondition" "INT")
+ ;(cons "GdkInputCondition" "INT")
(cons "GdkCursorType" "INT")
(cons "GdkDragAction" "INT")
- (cons "GdkDragProtocol" "INT")
+ ;(cons "GdkDragProtocol" "INT")
;(cons "GdkAxisUse" "INT")
- (cons "GdkGCValuesMask" "INT")
- (cons "GdkFill" "INT")
- (cons "GdkFunction" "INT")
- (cons "GdkLineStyle" "INT")
- (cons "GdkCapStyle" "INT")
- (cons "GdkJoinStyle" "INT")
+ ;(cons "GdkGCValuesMask" "INT")
+ ;(cons "GdkFill" "INT")
+ ;(cons "GdkFunction" "INT")
+ ;(cons "GdkLineStyle" "INT")
+ ;(cons "GdkCapStyle" "INT")
+ ;(cons "GdkJoinStyle" "INT")
(cons "GdkGrabStatus" "INT")
(cons "GdkEventMask" "INT")
- (cons "GdkImageType" "INT")
+ ;(cons "GdkImageType" "INT")
;(cons "GdkInputSource" "INT")
;(cons "GdkInputMode" "INT")
- (cons "GdkNativeWindow" "ULONG")
+ ;(cons "GdkNativeWindow" "ULONG")
(cons "GdkModifierType" "INT")
;(cons "GdkExtensionMode" "INT")
(cons "PangoDirection" "INT")
- (cons "GdkRgbDither" "INT")
+ ;(cons "GdkRgbDither" "INT")
(cons "GdkPixbufAlphaMode" "INT")
(cons "GdkPropMode" "INT")
- (cons "GdkFillRule" "INT")
+ ;(cons "GdkFillRule" "INT")
;(cons "GdkOverlapType" "INT")
(cons "GdkVisualType" "INT")
(cons "GdkWindowType" "INT")
@@ -640,39 +381,39 @@
(cons "GdkWMFunction" "INT")
(cons "GdkWindowEdge" "INT")
(cons "GtkAccelFlags" "INT")
- (cons "GtkArrowType" "INT")
+ ;(cons "GtkArrowType" "INT")
(cons "GtkShadowType" "INT")
(cons "GtkButtonBoxStyle" "INT")
- (cons "GtkPathType" "INT")
- (cons "GtkPathPriorityType" "INT")
+ ;(cons "GtkPathType" "INT")
+ ;(cons "GtkPathPriorityType" "INT")
(cons "GtkPackType" "INT")
(cons "GtkReliefStyle" "INT")
(cons "GtkCalendarDisplayOptions" "INT")
(cons "GtkCellRendererState" "INT")
(cons "GtkResizeMode" "INT")
- (cons "GtkCurveType" "INT")
+ ;(cons "GtkCurveType" "INT")
(cons "GtkDialogFlags" "INT")
(cons "GtkDestDefaults" "INT")
(cons "GtkPositionType" "INT")
(cons "GtkTextDirection" "INT")
(cons "GtkStateFlags" "INT")
(cons "GtkImageType" "INT")
-; (cons "GtkIconSize" "INT")
+ ;(cons "GtkIconSize" "INT")
(cons "GtkJustification" "INT")
(cons "GtkMessageType" "INT")
(cons "GtkButtonsType" "INT")
(cons "GtkTargetFlags" "INT")
;(cons "GtkProgressBarOrientation" "INT")
- (cons "GtkUpdateType" "INT")
- (cons "GtkMetricType" "INT")
+ ;(cons "GtkUpdateType" "INT")
+ ;(cons "GtkMetricType" "INT")
(cons "GtkPolicyType" "INT")
(cons "GtkCornerType" "INT")
(cons "GtkSizeGroupMode" "INT")
(cons "GtkSpinButtonUpdatePolicy" "INT")
(cons "GtkSpinType" "INT")
(cons "GtkOrientation" "INT")
- (cons "GtkExpanderStyle" "INT")
- (cons "GtkAttachOptions" "INT")
+ ;(cons "GtkExpanderStyle" "INT")
+ ;(cons "GtkAttachOptions" "INT")
(cons "GtkTextSearchFlags" "INT")
(cons "GtkTextWindowType" "INT")
(cons "GtkWrapMode" "INT")
@@ -708,7 +449,7 @@
(cons "PangoScript" "INT")
(cons "GdkEventType" "INT")
- (cons "GdkVisibilityState" "INT")
+ ;(cons "GdkVisibilityState" "INT")
(cons "GdkScrollDirection" "INT")
(cons "GdkCrossingMode" "INT")
(cons "GdkNotifyType" "INT")
@@ -716,7 +457,7 @@
(cons "GdkByteOrder" "INT")
;(cons "GdkWChar" "ULONG")
(cons "GtkFileChooserAction" "INT")
- (cons "GtkUIManagerItemType" "INT")
+ ;(cons "GtkUIManagerItemType" "INT")
(cons "GtkFileFilterFlags" "INT")
(cons "GtkIconLookupFlags" "INT")
(cons "GtkIconThemeError" "INT")
@@ -725,13 +466,13 @@
(cons "GtkPackDirection" "INT")
(cons "GtkIconViewDropPosition" "INT")
(cons "GtkFileChooserConfirmation" "INT")
- (cons "GtkFileChooserProp" "INT")
+ ;(cons "GtkFileChooserProp" "INT")
(cons "GtkFileChooserError" "INT")
- (cons "GtkLicense" "INT")
+ ;(cons "GtkLicense" "INT")
- (cons "GtkWrapAllocationMode" "INT")
- (cons "GtkWrapBoxSpreading" "INT")
- (cons "GtkWrapBoxPacking" "INT")
+ ;(cons "GtkWrapAllocationMode" "INT")
+ ;(cons "GtkWrapBoxSpreading" "INT")
+ ;(cons "GtkWrapBoxPacking" "INT")
(cons "GtkSensitivityType" "INT")
(cons "GtkTextBufferTargetInfo" "INT")
@@ -739,7 +480,7 @@
(cons "GtkCellRendererAccelMode" "INT")
(cons "GtkRecentSortType" "INT")
(cons "GtkRecentChooserError" "INT")
- (cons "GtkRecentFilterFlags" "INT")
+ ;(cons "GtkRecentFilterFlags" "INT")
(cons "GtkRecentManagerError" "INT")
(cons "GtkTreeViewGridLines" "INT")
@@ -796,9 +537,9 @@
;(cons "PangoRenderPart" "INT")
(cons "PangoTabAlign" "INT")
- (cons "GtkWidgetHelpType" "INT")
- (cons "GtkWidgetFlags" "INT")
- (cons "GtkRcTokenType" "INT")
+ ;(cons "GtkWidgetHelpType" "INT")
+ ;(cons "GtkWidgetFlags" "INT")
+ ;(cons "GtkRcTokenType" "INT")
(cons "GtkTextExtendSelection" "INT")
;(cons "GtkNotebookTab" "INT")
(cons "GtkScrollType" "INT")
@@ -812,99 +553,94 @@
(cons "GdkWindowAttributesType" "INT")
;(cons "GdkWindowClass" "INT")
(cons "GdkStatus" "INT")
- (cons "GdkSubwindowMode" "INT")
+ ;(cons "GdkSubwindowMode" "INT")
(cons "GdkPropertyState" "INT")
(cons "GtkScrollablePolicy" "INT")
(cons "GdkModifierIntent" "INT")
(cons "GtkAlign" "INT")
- (cons "GdkGLFlags" "INT")
+ ;(cons "GdkGLFlags" "INT")
(cons "GtkShortcutType" "INT")
+ (cons "GtkPopoverConstraint" "INT")
+ (cons "GdkSeatCapabilities" "INT")
+ (cons "GdkDragCancelReason" "INT")
+ (cons "GdkAxisUse" "INT")
+ (cons "GdkAxisFlags" "INT")
+ (cons "GdkDeviceToolType" "INT")
))
-(define (c-to-xen-macro-name typ str)
- (if (string=? str "INT") "C_int_to_Xen_integer"
- (if (string=? str "DOUBLE") "C_double_to_Xen_real"
- (if (string=? str "BOOLEAN") "C_bool_to_Xen_boolean"
- (if (string=? str "ULONG") "C_ulong_to_Xen_ulong"
- (if (string=? str "String")
- (if (string=? (car typ) "guchar*")
- "C_to_Xen_String"
- "C_string_to_Xen_string")
- (format #f "~A unknown" str)))))))
+(define (c-to-xen-macro-name type str)
+ (cond ((assoc str '(("INT" . "C_int_to_Xen_integer")
+ ("DOUBLE" . "C_double_to_Xen_real")
+ ("BOOLEAN" . "C_bool_to_Xen_boolean")
+ ("ULONG" . "C_ulong_to_Xen_ulong"))
+ string=?) => cdr)
+ ((not (string=? str "String")) (format #f "~A unknown" str))
+ ((string=? type "guchar*") "C_to_Xen_String")
+ (else "C_string_to_Xen_string")))
(define (xen-to-c-macro-name str)
- (if (string=? str "INT") "Xen_integer_to_C_int"
- (if (string=? str "DOUBLE") "Xen_real_to_C_double"
- (if (string=? str "BOOLEAN") "Xen_boolean_to_C_bool"
- (if (string=? str "ULONG") "Xen_ulong_to_C_ulong"
- (if (string=? str "String") "Xen_string_to_C_string"
- (format #f "~A unknown" str)))))))
+ (cond ((assoc str '(("INT" . "Xen_integer_to_C_int")
+ ("DOUBLE" . "Xen_real_to_C_double")
+ ("BOOLEAN" . "Xen_boolean_to_C_bool")
+ ("ULONG" . "Xen_ulong_to_C_ulong")
+ ("String" . "Xen_string_to_C_string"))
+ string=?) => cdr)
+ (else (format #f "~A unknown" str))))
(define (type-it type)
- (let ((typ (assoc type direct-types)))
- (if typ
- (when (cdr typ)
- (if (string? (cdr typ))
- (begin
- (if (not (member type no-c-to-xen))
- (hey "#define C_to_Xen_~A(Arg) ~A(Arg)~%" (no-stars (car typ)) (c-to-xen-macro-name typ (cdr typ))))
- (if (not (member type no-xen-to-c))
- (hey "#define Xen_to_C_~A(Arg) (~A)(~A(Arg))~%" (no-stars (car typ)) (car typ) (xen-to-c-macro-name (cdr typ))))
- (if (not (member type no-xen-p))
- (hey "#define Xen_is_~A(Arg) Xen_is_~A(Arg)~%"
- (no-stars (car typ))
- (if (string=? (cdr typ) "INT")
- "integer"
- (if (string=? (cdr typ) "DOUBLE")
- "number"
- (if (string=? (cdr typ) "ULONG")
- "ulong"
- (apply string (map char-downcase (cdr typ)))))))))
- (if (not (cdr typ)) ; void special case
- (begin
+ (let ((typ (assoc type direct-types)))
+ (if typ
+ (when (cdr typ)
+ (let ((c-name (cdr typ))) ; might be #f (see void case below)
+ (cond ((string? c-name)
+ (if (not (member type no-c-to-xen))
+ (hey "#define C_to_Xen_~A(Arg) ~A(Arg)~%" (no-stars type) (c-to-xen-macro-name type c-name)))
+ (if (not (member type no-xen-to-c))
+ (hey "#define Xen_to_C_~A(Arg) (~A)(~A(Arg))~%" (no-stars type) type (xen-to-c-macro-name c-name)))
+ (if (not (member type no-xen-p))
+ (hey "#define Xen_is_~A(Arg) Xen_is_~A(Arg)~%"
+ (no-stars type)
+ (cond ((assoc c-name '(("INT" . "integer")
+ ("DOUBLE" . "number")
+ ("ULONG" . "ulong"))
+ string=?) => cdr)
+ (else (apply string (map char-downcase c-name)))))))
+ ((not c-name) ; void special case
(if (not (member type no-xen-p))
- (hey "#define Xen_is_~A(Arg) 1~%" (no-stars (car typ))))
+ (hey "#define Xen_is_~A(Arg) 1~%" (no-stars type)))
(if (not (member type no-xen-to-c))
- (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars (car typ)))))
- (if (string=? type "etc") ; xen special case
- (hey "#define Xen_is_etc(Arg) (Xen_is_list(Arg))~%")
- (begin
- (if (not (member type no-xen-p))
- (hey "#define Xen_is_~A(Arg) ((Xen_is_list(Arg)) && (Xen_list_length(Arg) > 2))~%" (no-stars (car typ))))
- (if (not (member type no-xen-to-c))
- (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars (car typ)))))))))
-
- (if (and (not (string=? type "lambda"))
- (not (string=? type "lambda_data"))
- (not (string=? type "GError*"))
- (not (find-callback
+ (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars type))))
+ ((string=? type "etc") ; xen special case
+ (hey "#define Xen_is_etc(Arg) (Xen_is_list(Arg))~%"))
+ (else
+ (if (not (member type no-xen-p))
+ (hey "#define Xen_is_~A(Arg) ((Xen_is_list(Arg)) && (Xen_list_length(Arg) > 2))~%" (no-stars type)))
+ (if (not (member type no-xen-to-c))
+ (hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars type)))))))
+
+ (if (not (or (member type '("lambda" "lambda_data" "GError*") string=?)
+ (find-callback
(lambda (func)
- (string=? type (symbol->string (car func))))))
- (not (string=? type "GCallback")))
- (hey "Xm_type~A(~A, ~A)~%"
- (if (or (has-stars type)
- (string=? type "gpointer")
- (string=? type "GClosureNotify"))
- (if (member type no-c-to-xen)
- "_Ptr_1"
- (if (member type no-xen-p)
- (if (member type no-xen-to-c)
- "_Ptr_2"
- "_Ptr_no_P")
- (if (or (string=? type "guint8*")
- (string=? type "GtkRecentFilterInfo*"))
- "_Ptr_const"
- "_Ptr")))
- (if (member type no-c-to-xen)
- "_1"
- (if (member type no-xen-p)
- (if (member type no-xen-to-c)
- "_no_p_2"
- "_no_p")
- "")))
- (no-stars type)
- type)))))
+ (string=? type (symbol->string (car func)))))
+ (string=? type "GCallback")))
+ (hey "Xm_type~A(~A, ~A)~%"
+ (cond ((or (has-stars type)
+ (member type '("gpointer" "GClosureNotify") string=?))
+ (cond ((member type no-c-to-xen)
+ "_Ptr_1")
+ ((member type no-xen-p)
+ (if (member type no-xen-to-c) "_Ptr_2" "_Ptr_no_P"))
+ ((member type '("guint8*" "GtkRecentFilterInfo*") string=?)
+ "_Ptr_const")
+ (else "_Ptr")))
+ ((member type no-c-to-xen)
+ "_1")
+ ((not (member type no-xen-p)) "")
+ ((member type no-xen-to-c) "_no_p_2")
+ (else "_no_p"))
+ (no-stars type)
+ type)))))
(define (func-type strs)
(call-with-exit
@@ -915,17 +651,14 @@
(lambda (func)
(and (string=? (car arg) (symbol->string (callback-name func)))
func)))))
- (if callb
- (return (callback-name callb))
- (if (string=? (car arg) "lambda")
- (return 'lambda)
- (if (string=? (car arg) "GCallback")
- (return 'GCallback))))))
+ (cond (callb (return (callback-name callb)))
+ ((string=? (car arg) "lambda") (return 'lambda))
+ ((string=? (car arg) "GCallback") (return 'GCallback)))))
strs)
'fnc)))
(define (no-way str arg)
- (format #t str arg))
+ (format () str arg))
(define-macro (make-fnc vname)
@@ -958,7 +691,7 @@
(let ((name (cadr-str data))
(args (caddr-str data)))
(if (hash-table-ref names name)
- (format #t "~A: ~A ~A~%" ',cfnc name data)
+ (format () "~A: ~A ~A~%" ',cfnc name data)
(let ((type (car-str data)))
(if (not (member type all-types))
(begin
@@ -972,31 +705,31 @@
(define (,strfnc name) ; CSTR-2.12
(if (assoc name ,names)
- (format #t "~A ~A~%" name ',strfnc)
+ (format () "~A ~A~%" name ',strfnc)
(begin
(set! ,strings (cons name ,strings))
(set! ,names (cons (cons name 'string) ,names)))))
(define* (,intfnc name type) ; CINT-2.12
- (save-declared-type type)
+ (save-declared-type name type ,vname)
(if (and type (not (assoc type direct-types)))
(format *stderr* "could be direct int: ~S (~S)~%" type name))
(if (hash-table-ref names name)
- (format #t "~A ~A~%" name ',intfnc)
+ (format () "~A ~A~%" name ',intfnc)
(begin
(set! ,ints (cons name ,ints))
(hash-table-set! names name 'int))))
(define (,castfnc name type) ; CCAST-2.12
(if (hash-table-ref names name)
- (format #t "~A ~A~%" name ',castfnc)
+ (format () "~A ~A~%" name ',castfnc)
(begin
(set! ,casts (cons (list name type) ,casts))
(hash-table-set! names name 'def))))
(define (,chkfnc name type) ; CCHK-2.12
(if (hash-table-ref names name)
- (format #t "~A ~A~%" name ',chkfnc)
+ (format () "~A ~A~%" name ',chkfnc)
(begin
(set! ,checks (cons (list name type) ,checks))
(hash-table-set! names name 'def))))
@@ -1024,6 +757,7 @@
(make-fnc "3.16")
(make-fnc "3.18")
(make-fnc "3.20")
+(make-fnc "3.22")
(define cairo-funcs ())
(define cairo-png-funcs ())
@@ -1038,7 +772,247 @@
(define cairo-ints-912 ())
(define cairo-types-912 ())
(define cairo-strings-912 ())
-(define cairo-names-912 ())
+
+(define callbacks
+ (list
+ ; (list 'lambda2 ; unnamed gdk_window_invalidate_maybe_recurse argument (2.90.6 now)
+ ; "gboolean"
+ ; "child_func"
+ ; (parse-args "GdkWindow* window lambda_data func_info" 'callback)
+ ; 'temporary)
+ (list 'lambda3 ; unnamed gtk_accel_group_find argument
+ "gboolean"
+ "find_func"
+ (parse-args "GtkAccelKey* key GClosure* closure lambda_data func_info" 'callback)
+ 'temporary) ; ??
+ (list 'GtkCallback
+ "void"
+ "func2"
+ (parse-args "GtkWidget* w lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GSourceFunc
+ "gboolean"
+ "timer_func"
+ (parse-args "lambda_data func_info" 'callback)
+ 'semi-permanent)
+ (list 'GtkDestroyNotify
+ "void"
+ "destroy_func"
+ (parse-args "lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GdkFilterFunc
+ "GdkFilterReturn"
+ "filter_func"
+ (parse-args "GdkXEvent* xevent GdkEvent* event lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GdkEventFunc
+ "void"
+ "event_func"
+ (parse-args "GdkEvent* event lambda_data func_info" 'callback)
+ 'permanent)
+ ; (list 'GdkSpanFunc
+ ; "void"
+ ; "span_func"
+ ; (parse-args "GdkSpan* span lambda_data func_info" 'callback)
+ ; 'temporary)
+ ; (list 'GtkFunction
+ ; "gboolean"
+ ; "func1"
+ ; (parse-args "lambda_data func_info" 'callback)
+ ; 'semi-permanent)
+ ; (list 'GtkKeySnoopFunc
+ ; "gint"
+ ; "snoop_func"
+ ; (parse-args "GtkWidget* widget GdkEventKey* event lambda_data func_info" 'callback)
+ ; 'semi-permanent)
+ (list 'GtkMenuPositionFunc
+ "void"
+ "menu_position_func"
+ (parse-args "GtkMenu* menu gint* [x] gint* [y] gboolean* [push] lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkTextTagTableForeach
+ "void"
+ "text_tag_table_foreach"
+ (parse-args "GtkTextTag* tag lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkAccelMapForeach
+ "void"
+ "accel_map_foreach"
+ (parse-args "lambda_data func_info gchar* accel_path guint accel_key GdkModifierType accel_mods gboolean changed" 'callback)
+ 'temporary)
+ (list 'GtkTreeModelForeachFunc
+ "gboolean"
+ "model_func"
+ (parse-args "GtkTreeModel* model GtkTreePath* path GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkTreeSelectionForeachFunc
+ "void"
+ "tree_selection_func"
+ (parse-args "GtkTreeModel* model GtkTreePath* path GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkClipboardReceivedFunc
+ "void"
+ "clip_received"
+ (parse-args "GtkClipboard* clipboard GtkSelectionData* selection_data lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkClipboardTextReceivedFunc
+ "void"
+ "clip_text_received"
+ (parse-args "GtkClipboard* clipboard gchar* text lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkClipboardTargetsReceivedFunc
+ "void"
+ "clip_targets_received"
+ (parse-args "GtkClipboard* clipboard GdkAtom* atoms gint n_atoms lambda_data func_info" 'callback)
+ 'temporary)
+ ; (list 'GtkMenuDetachFunc
+ ; "void"
+ ; "menu_detach_func"
+ ; (parse-args "GtkWidget* attach_widget GtkMenu* menu" 'callback)
+ ; 'permanent)
+;;; detach func is not passed user-data, so it would have to be implemented by hand
+ (list 'GtkTextCharPredicate
+ "gboolean"
+ "text_char_predicate"
+ (parse-args "gunichar ch lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkTreeViewColumnDropFunc
+ "gboolean"
+ "tree_column"
+ (parse-args "GtkTreeView* tree_view GtkTreeViewColumn* column GtkTreeViewColumn* prev_column GtkTreeViewColumn* next_column lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkTreeViewMappingFunc
+ "void"
+ "tree_mapping"
+ (parse-args "GtkTreeView* tree_view GtkTreePath* path lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkTreeViewSearchEqualFunc
+ "gboolean"
+ "tree_search"
+ (parse-args "GtkTreeModel* model gint column gchar* key GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'temporary)
+ (list 'GtkTreeCellDataFunc
+ "void"
+ "cell_data"
+ (parse-args "GtkTreeViewColumn* tree_column GtkCellRenderer* cell GtkTreeModel* tree_model GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkTreeIterCompareFunc
+ "gint"
+ "iter_compare"
+ (parse-args "GtkTreeModel* model GtkTreeIter* a GtkTreeIter* b lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkTreeSelectionFunc
+ "gboolean"
+ "tree_selection"
+ (parse-args "GtkTreeSelection* selection GtkTreeModel* model GtkTreePath* path gboolean path_currently_selected lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkClipboardGetFunc
+ "void"
+ "clip_get"
+ (parse-args "GtkClipboard* clipboard GtkSelectionData* selection_data guint info lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkClipboardClearFunc
+ "void"
+ "clip_clear"
+ (parse-args "GtkClipboard* clipboard lambda_data func_info" 'callback)
+ 'permanent)
+
+ ; GCallback 'lambda can be whatever is indicated by caller (2 or more args)
+
+ (list 'GtkFileFilterFunc
+ "gboolean"
+ "file_filter"
+ (parse-args "GtkFileFilterInfo* info lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkEntryCompletionMatchFunc
+ "gboolean"
+ "entry_completion_match"
+ (parse-args "GtkEntryCompletion* completion gchar* key GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'permanent)
+
+ (list 'GtkTreeViewRowSeparatorFunc
+ "gboolean"
+ "row_separator"
+ (parse-args "GtkTreeModel* model GtkTreeIter* iter lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkIconViewForeachFunc
+ "void"
+ "icon_view_foreach"
+ (parse-args "GtkIconView* icon_view GtkTreePath* path lambda_data func_info" 'callback)
+ 'permanent)
+
+ (list 'GtkClipboardImageReceivedFunc
+ "void"
+ "clip_image_received"
+ (parse-args "GtkClipboard* clipboard GdkPixbuf* pixbuf lambda_data func_info" 'callback) ; 'callback)
+ ;; these arg types are not new in 256, but this parse-args precedes the basic ones, so comment out the callback
+ ;; the problem here (and below callback) is that parse-args sees a new type (new to it so far),
+ ;; and chooses which type list to put it on based on the "extra" arg -- since these types
+ ;; are not new in version 2.5.6, we don't want the callback flag to sequester them
+ ;; on the 256-type list.
+ 'permanent)
+ (list 'GLogFunc
+ "void"
+ "g_message_log_func"
+ (parse-args "gchar* domain GLogLevelFlags log_level gchar* message lambda_data func_info" 'callback)
+ 'permanent)
+
+ (list 'GtkClipboardRichTextReceivedFunc
+ "void"
+ "clip_rich_text_received"
+ (parse-args "GtkClipboard* clipboard GdkAtom format guint8* text gsize length lambda_data func_info" 'callback); 'callback)
+ ;; guint8* is const
+ 'permanent-gcc)
+ ; (list 'GtkRecentFilterFunc
+ ; "gboolean"
+ ; "recent_filter"
+ ; (parse-args "GtkRecentFilterInfo* filter_info lambda_data func_info" 'callback)
+ ; ;; const filter info
+ ; 'permanent-gcc)
+ (list 'GtkTreeViewSearchPositionFunc
+ "void"
+ "search_position"
+ (parse-args "GtkTreeView* tree_view GtkWidget* search_dialog lambda_data func_info" 'callback)
+ 'permanent)
+ (list 'GtkAssistantPageFunc
+ "gint"
+ "page_func"
+ (parse-args "gint current_page lambda_data func_info" 'callback)
+ 'permanent)
+ ; (list 'GtkLinkButtonUriFunc
+ ; "void"
+ ; "link_button_uri"
+ ; (parse-args "GtkLinkButton* button gchar* link lambda_data func_info" 'callback)
+ ; ;; const gchar *link
+ ; 'permanent)
+ (list 'GtkRecentSortFunc
+ "gint"
+ "recent_sort"
+ (parse-args "GtkRecentInfo* a GtkRecentInfo* b lambda_data func_info" 'callback)
+ 'permanent)
+
+ (list 'GdkSeatGrabPrepareFunc
+ "void"
+ "prepare_func"
+ (parse-args "GdkSeat* seat GdkWindow* window lambda_data func_info" 'g-3.20)
+ 'permanent
+ "3.20")
+ ))
+
+
+(define callback-name car)
+(define callback-type cadr)
+(define callback-func caddr)
+(define callback-args cadddr)
+(define (callback-gc func) (func 4))
+(define (callback-version func) (and (> (length func) 5) (func 5)))
+
+(define (find-callback test)
+ (let find-callback-1 ((test test)
+ (funcs callbacks))
+ (and (pair? funcs)
+ (or (test (car funcs))
+ (find-callback-1 test (cdr funcs))))))
(define* (CFNC data spec spec-data) ; 'const -> const for arg cast, 'etc for ... args, 'free -> must free C val before return
(let ((name (cadr-str data))
@@ -1050,17 +1024,16 @@
(if (not (member type types))
(set! types (cons type types)))
(let ((strs (parse-args args 'ok)))
- (if spec
- (set! funcs (cons (list name type strs args spec spec-data) funcs))
- (set! funcs (cons (list name type strs args) funcs)))
+ (set! funcs
+ (cons (if spec
+ (list name type strs args spec spec-data)
+ (list name type strs args))
+ funcs))
(hash-table-set! names name (func-type strs)))))))
(define (CFNC-PA data min-len max-len types)
(CFNC data 'etc (list min-len max-len types)))
-(define (CFNC-23-PA data min-len max-len types)
- (CFNC data 'etc (list min-len max-len types)))
-
(define* (CAIRO-FUNC data spec)
(let ((name (cadr-str data))
(args (caddr-str data)))
@@ -1072,9 +1045,11 @@
(set! all-types (cons type all-types))
(set! cairo-types (cons type cairo-types))))
(let ((strs (parse-args args 'cairo)))
- (if spec
- (set! cairo-funcs (cons (list name type strs args spec) cairo-funcs))
- (set! cairo-funcs (cons (list name type strs args) cairo-funcs)))
+ (set! cairo-funcs
+ (cons (if spec
+ (list name type strs args spec)
+ (list name type strs args))
+ cairo-funcs))
(hash-table-set! names name (func-type strs)))))))
(define* (CAIRO-PNG-FUNC data spec)
@@ -1088,9 +1063,11 @@
(set! all-types (cons type all-types))
(set! cairo-types (cons type cairo-types))))
(let ((strs (parse-args args 'cairo)))
- (if spec
- (set! cairo-png-funcs (cons (list name type strs args spec) cairo-png-funcs))
- (set! cairo-png-funcs (cons (list name type strs args) cairo-png-funcs)))
+ (set! cairo-png-funcs
+ (cons (if spec
+ (list name type strs args spec)
+ (list name type strs args))
+ cairo-png-funcs))
(hash-table-set! names name (func-type strs)))))))
(define* (CAIRO-FUNC-810 data spec)
@@ -1104,9 +1081,11 @@
(set! all-types (cons type all-types))
(set! cairo-types-810 (cons type cairo-types-810))))
(let ((strs (parse-args args 'cairo-810)))
- (if spec
- (set! cairo-funcs-810 (cons (list name type strs args spec) cairo-funcs-810))
- (set! cairo-funcs-810 (cons (list name type strs args) cairo-funcs-810)))
+ (set! cairo-funcs-810
+ (cons (if spec
+ (list name type strs args spec)
+ (list name type strs args))
+ cairo-funcs-810))
(hash-table-set! names name (func-type strs)))))))
(define* (CAIRO-FUNC-912 data spec)
@@ -1120,9 +1099,11 @@
(set! all-types (cons type all-types))
(set! cairo-types-912 (cons type cairo-types-912))))
(let ((strs (parse-args args 'cairo-912)))
- (if spec
- (set! cairo-funcs-912 (cons (list name type strs args spec) cairo-funcs-912))
- (set! cairo-funcs-912 (cons (list name type strs args) cairo-funcs-912)))
+ (set! cairo-funcs-912
+ (cons (if spec
+ (list name type strs args spec)
+ (list name type strs args))
+ cairo-funcs-912))
(hash-table-set! names name (func-type strs)))))))
@@ -1150,8 +1131,7 @@
(set! line-len (+ 1 line-len))
(heyc " ")
(set! typed #t)))
- (if (and (not (char=? ch #\@))
- (not (char=? ch #\#)))
+ (if (not (memv ch '(#\@ #\#)))
(begin
(set! line-len (+ 1 line-len))
(heyc ch))))))
@@ -1180,14 +1160,19 @@
(set! dbls (cons name dbls))
(hash-table-set! names name 'dbl))))
-(define declared-types ())
-(define (save-declared-type type)
- (if (and type
- (not (member type declared-types)))
- (set! declared-types (cons type declared-types))))
+(define declared-types ()) ; list of string type names
+(define declared-names ()) ; list of (enum-name type-name version-string)
+
+(define (save-declared-type name type version)
+ (when (string? type)
+ (if (not (member type declared-types))
+ (set! declared-types (cons type declared-types)))
+ (if (or (memv (type 0) '(#\G #\P))
+ (char=? (name 0) #\C))
+ (set! declared-names (cons (list name type version) declared-names)))))
(define* (CINT name type)
- (save-declared-type type)
+ (save-declared-type name type "2.0")
(if (and type (not (assoc type direct-types)))
(format *stderr* "could be direct int: ~S (~S)~%" type name))
(if (hash-table-ref names name)
@@ -1198,7 +1183,7 @@
(define* (CAIRO-INT name type)
- (save-declared-type type)
+ (save-declared-type name type "2.0")
(if (hash-table-ref names name)
(no-way "~A CAIRO-INT~%" name)
(begin
@@ -1206,7 +1191,7 @@
(hash-table-set! names name 'int))))
(define* (CAIRO-INT-810 name type)
- (save-declared-type type)
+ ;(save-declared-type name type)
(if (hash-table-ref names name)
(no-way "~A CAIRO-INT-810~%" name)
(begin
@@ -1214,7 +1199,7 @@
(hash-table-set! names name 'int))))
(define* (CAIRO-INT-912 name type)
- (save-declared-type type)
+ ;(save-declared-type name type)
(if (hash-table-ref names name)
(no-way "~A CAIRO-INT-912~%" name)
(begin
@@ -1296,45 +1281,46 @@
(define all-ntypes (list types-2.14 types-2.16 types-2.18 types-2.20
- types-3.0 types-3.2 types-3.4 types-3.6 types-3.8 types-3.10 types-3.12 types-3.14 types-3.16 types-3.18 types-3.20
+ types-3.0 types-3.2 types-3.4 types-3.6 types-3.8 types-3.10 types-3.12 types-3.14 types-3.16 types-3.18 types-3.20 types-3.22
cairo-types cairo-types-810 cairo-types-912))
(define all-ntype-withs (list with-2.14 with-2.16 with-2.18 with-2.20
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
with-cairo with-cairo-810 with-cairo-912))
(define all-funcs (list funcs-2.14 funcs-2.16 funcs-2.18 funcs-2.20
- funcs-3.0 funcs-3.2 funcs-3.4 funcs-3.6 funcs-3.8 funcs-3.10 funcs-3.12 funcs-3.14 funcs-3.16 funcs-3.18 funcs-3.20
+ funcs-3.0 funcs-3.2 funcs-3.4 funcs-3.6 funcs-3.8 funcs-3.10 funcs-3.12 funcs-3.14 funcs-3.16 funcs-3.18 funcs-3.20 funcs-3.22
cairo-funcs cairo-png-funcs cairo-funcs-810 cairo-funcs-912))
(define all-func-withs (list with-2.14 with-2.16 with-2.18 with-2.20
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
with-cairo with-cairo-png with-cairo-810 with-cairo-912))
(define all-ints (list ints-2.14 ints-2.16 ints-2.18
- ints-3.0 ints-3.2 ints-3.4 ints-3.6 ints-3.8 ints-3.10 ints-3.12 ints-3.14 ints-3.16 ints-3.18 ints-3.20
+ ints-3.0 ints-3.2 ints-3.4 ints-3.6 ints-3.8 ints-3.10 ints-3.12 ints-3.14 ints-3.16 ints-3.18 ints-3.20 ints-3.22
cairo-ints cairo-ints-810 cairo-ints-912))
(define all-int-withs (list with-2.14 with-2.16 with-2.18
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
with-cairo with-cairo-810 with-cairo-912))
(define all-casts (list casts-2.14 casts-2.16 casts-2.18 casts-2.20
- casts-3.0 casts-3.2 casts-3.4 casts-3.6 casts-3.8 casts-3.10 casts-3.12 casts-3.14 casts-3.16 casts-3.18 casts-3.20
+ casts-3.0 casts-3.2 casts-3.4 casts-3.6 casts-3.8 casts-3.10 casts-3.12 casts-3.14 casts-3.16 casts-3.18 casts-3.20 casts-3.22
))
(define all-cast-withs (list with-2.14 with-2.16 with-2.18 with-2.20
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
))
(define all-checks (list checks-2.14 checks-2.16 checks-2.18 checks-2.20
- checks-3.0 checks-3.2 checks-3.4 checks-3.6 checks-3.8 checks-3.10 checks-3.12 checks-3.14 checks-3.16 checks-3.18 checks-3.20
+ checks-3.0 checks-3.2 checks-3.4 checks-3.6 checks-3.8 checks-3.10 checks-3.12 checks-3.14 checks-3.16 checks-3.18 checks-3.20 checks-3.22
))
(define all-check-withs (list with-2.14 with-2.16 with-2.18 with-2.20
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
))
(define all-strings (list strings-2.14 strings-2.16
strings-3.0 strings-3.2 strings-3.4 strings-3.6 strings-3.8 strings-3.10 strings-3.12 strings-3.14 strings-3.16 strings-3.18 strings-3.20
+ strings-3.22
cairo-strings-912))
(define all-string-withs (list with-2.14 with-2.16
- with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20
+ with-3.0 with-3.2 with-3.4 with-3.6 with-3.8 with-3.10 with-3.12 with-3.14 with-3.16 with-3.18 with-3.20 with-3.22
with-cairo-912))
@@ -1367,6 +1353,8 @@
(hey " *~%")
(hey " * HISTORY:~%")
(hey " *~%")
+(hey " * 17-Mar-16: gtk_enum_t for better signature checks.~%")
+(hey " * --------~%")
(hey " * 29-Oct: removed ->string.~%")
(hey " * 21-Aug-15: procedure-signature changes.~%")
(hey " * --------~%")
@@ -1460,7 +1448,7 @@
(hey "#endif~%")
(hey "#include <glib-object.h>~%")
(hey "#include <pango/pango.h>~%")
-(with-cairo hey (lambda () (hey "#include <cairo/cairo.h>~%")))
+(with-cairo #f (lambda () (hey "#include <cairo/cairo.h>~%")))
(hey "#if USE_SND~%")
(hey " /* USE_SND causes xm to use Snd's error handlers which are much smarter than xen's fallback versions */~%")
@@ -1728,91 +1716,97 @@
(hey "~%~%/* ---------------------------------------- callback handlers ---------------------------------------- */~%~%")
-(let ((funcs-done ()))
- (let ((xc (lambda (func)
- (let* ((name (callback-func func))
- (type (callback-type func))
- (args (callback-args func))
- (gctype (callback-gc func))
- (fname (callback-name func))
- (void? (string=? type "void")))
- (if (not (member name funcs-done))
- (begin
- (set! funcs-done (cons name funcs-done))
- (hey "static ~A gxg_~A("
- type
- name)
- (let ((previous-arg #f)
- (ctr 0))
- (for-each
- (lambda (arg)
- (if previous-arg (hey ", "))
- ;; ctr is 0-based here
- (if (or (and (memq fname '(GtkClipboardTextReceivedFunc GtkAccelMapForeach GtkEntryCompletionMatchFunc))
- (= ctr 1))
- (and (memq fname '(GtkTreeViewSearchEqualFunc GLogFunc GtkClipboardRichTextReceivedFunc))
- (= ctr 2))
- (and (memq fname '(GtkFileFilterFunc GtkRecentFilterFunc GLogFunc))
- (= ctr 0)))
- (hey "const "))
- (set! ctr (+ ctr 1))
- (set! previous-arg #t)
- (hey "~A ~A"
- (if (not (string=? (car arg) "lambda_data"))
- (car arg)
- "gpointer")
- (cadr arg)))
- args)
- (hey ")~%"))
- (hey "{~% ")
- ;; I tried to use Xen_error here but it was a no-op for some reason??
- (hey "if (!Xen_is_list((Xen)func_info)) return~A;~% "
- (if void?
- ""
- (format #f "((~A)0)" (no-stars type))))
- (if (eq? gctype 'permanent-gcc)
- (hey "#if (!(defined(__cplusplus)))~% ")) ; const arg conversion causes trouble if g++
- (let ((castlen (+ 12 (if (not void?)
- (+ 2 (length (format #f "return(Xen_to_C_~A" (no-stars type))))
- 1))))
- (if (not void?)
- (hey "return(Xen_to_C_~A("
- (no-stars type)))
- (hey "Xen_call_with_~A_arg~A(~A((Xen)func_info),~%"
- (if (zero? (length args)) "no" (length args))
- (if (= (length args) 1) "" "s")
- (if (eq? fname 'GtkClipboardClearFunc)
- "Xen_caddr"
- (if (eq? fname 'GtkDestroyNotify)
- "Xen_cadddr"
- "Xen_car")))
- (for-each
- (lambda (arg)
- (hey (substring " " 0 castlen))
- (if (not (string=? (car arg) "lambda_data"))
- (hey "C_to_Xen_~A(~A~A),~%"
- (no-stars (car arg))
- (if (string=? (car arg) "GtkFileFilterInfo*")
- "(GtkFileFilterInfo *)"
- "")
- (cadr arg))
- (hey "Xen_cadr((Xen)func_info),~%")))
- args)
- (hey (substring " " 0 castlen))
- (hey "__func__)")
- (if void?
- (hey ";~%")
- (hey "));~%")))
- (if (eq? gctype 'permanent-gcc)
- (begin
- (if (not void?)
- (begin
- (hey " #else~%")
- (hey " return((~A)0);~%" (no-stars type))))
- (hey " #endif~%")))
- (hey "}~%~%")))))))
+(let* ((funcs-done ())
+ (xc (lambda (func)
+ (let* ((name (callback-func func))
+ (type (callback-type func))
+ (args (callback-args func))
+ (gctype (callback-gc func))
+ (fname (callback-name func))
+ (void? (string=? type "void")))
+ (unless (member name funcs-done)
+ (set! funcs-done (cons name funcs-done))
+ (if (callback-version func)
+ (hey (string-append "#if GTK_CHECK_VERSION(" (substring (callback-version func) 0 1) ", " (substring (callback-version func) 2) ", 0)~%")))
+
+ (hey "static ~A gxg_~A("
+ type
+ name)
+ (let ((previous-arg #f)
+ (ctr 0))
+ (for-each
+ (lambda (arg)
+ (if previous-arg (hey ", "))
+ ;; ctr is 0-based here
+ (if (or (and (memq fname '(GtkClipboardTextReceivedFunc GtkAccelMapForeach GtkEntryCompletionMatchFunc))
+ (= ctr 1))
+ (and (memq fname '(GtkTreeViewSearchEqualFunc GLogFunc GtkClipboardRichTextReceivedFunc))
+ (= ctr 2))
+ (and (memq fname '(GtkFileFilterFunc GtkRecentFilterFunc GLogFunc))
+ (= ctr 0)))
+ (hey "const "))
+ (set! ctr (+ ctr 1))
+ (set! previous-arg #t)
+ (hey "~A ~A"
+ (if (string=? (car arg) "lambda_data")
+ "gpointer"
+ (car arg))
+ (cadr arg)))
+ args)
+ (hey ")~%"))
+ (hey "{~% ")
+ ;; I tried to use Xen_error here but it was a no-op for some reason??
+ (hey "if (!Xen_is_list((Xen)func_info)) return~A;~% "
+ (if void?
+ ""
+ (format #f "((~A)0)" (no-stars type))))
+ (if (eq? gctype 'permanent-gcc)
+ (hey "#if (!(defined(__cplusplus)))~% ")) ; const arg conversion causes trouble if g++
+ (let ((castlen (+ 12 (if void?
+ 1
+ (+ 2 (length (format #f "return(Xen_to_C_~A" (no-stars type))))))))
+ (if (not void?)
+ (hey "return(Xen_to_C_~A("
+ (no-stars type)))
+ (hey "Xen_call_with_~A_arg~A(~A((Xen)func_info),~%"
+ (if (null? args) "no" (length args))
+ (if (and (pair? args) (null? (cdr args))) "" "s")
+ (if (eq? fname 'GtkClipboardClearFunc)
+ "Xen_caddr"
+ (if (eq? fname 'GtkDestroyNotify)
+ "Xen_cadddr"
+ "Xen_car")))
+ (for-each
+ (lambda (arg)
+ (hey (substring " " 0 castlen))
+ (if (string=? (car arg) "lambda_data")
+ (hey "Xen_cadr((Xen)func_info),~%")
+ (hey "C_to_Xen_~A(~A~A),~%"
+ (no-stars (car arg))
+ (if (string=? (car arg) "GtkFileFilterInfo*")
+ "(GtkFileFilterInfo *)"
+ "")
+ (cadr arg))))
+ args)
+ (hey (substring " " 0 castlen))
+ (hey "__func__)")
+ (if void?
+ (hey ";~%")
+ (hey "));~%")))
+ (if (eq? gctype 'permanent-gcc)
+ (begin
+ (if (not void?)
+ (begin
+ (hey " #else~%")
+ (hey " return((~A)0);~%" (no-stars type))))
+ (hey " #endif~%")))
+ (hey "}~%")
+ (when (callback-version func)
+ (hey "#endif~%"))
+ (hey "~%")
+ )))))
(for-each xc callbacks)
- ))
+ )
(hey "~%static gboolean gxg_func3(GtkWidget *w, GdkEventAny *ev, gpointer data)~%")
(hey "{~%")
@@ -1841,6 +1835,7 @@
(lambda (data)
(let* ((name (car data))
(return-type (cadr data))
+ (return-type-void (string=? return-type "void"))
(args (caddr data))
(cargs (length args))
(refargs (ref-args args))
@@ -1853,10 +1848,9 @@
(and (eq? (callback-name func) lambda-type)
func)))))
(spec (and (> (length data) 4) (data 4)))
- (spec-data (and (> (length data) 5) (data 5)))
+ (spec-data (and (> (length data) 5) (data 5))) ; also callback-version
(arg-start 0)
- (line-len 0)
- (line-max 120))
+ (line-len 0))
(define (hey-start)
;; start of checked line
@@ -1876,16 +1870,13 @@
;; cr ok after arg
(set! line-len (+ line-len (length arg)))
(heyc arg)
- (if (> line-len line-max)
+ (if (> line-len 120) ; line-max originally
(begin
- (hey "~%")
- (do ((i 0 (+ i 1)))
- ((= i arg-start))
- (heyc " "))
+ (format xg-file "~%~NC" arg-start #\space)
(set! line-len arg-start))))
(hey "static Xen gxg_~A(" name)
- (if (= (length args) 0)
+ (if (null? args)
(heyc "void")
(if (>= (length args) max-args)
(heyc "Xen arglist")
@@ -1898,7 +1889,7 @@
(if previous-arg (heyc ", "))
(set! previous-arg #t)
(if (and (ref-arg? arg)
- (not (member name (list "gdk_init" "gdk_init_check" "gtk_init" "gtk_init_check" "gtk_parse_args"))))
+ (not (member name '("gdk_init" "gdk_init_check" "gtk_init" "gtk_init_check" "gtk_parse_args"))))
(hey "Xen ignore_~A" argname)
(hey "Xen ~A" argname))))
args))))
@@ -1932,54 +1923,82 @@
(hey " ~A = Xen_list_ref(arglist, ~D);~%" (cadr arg) ctr))
(set! ctr (+ ctr 1)))
args))))
- (if (> (length args) 0)
- (let ((ctr 1)
- (argc #f))
- (for-each
- (lambda (arg)
- (let ((argname (cadr arg))
- (argtype (car arg)))
- (if (not (ref-arg? arg))
- (if (null-arg? arg)
- (hey " Xen_check_type(Xen_is_~A(~A) || Xen_is_false(~A), ~A, ~D, ~S, ~S);~%"
- (no-stars argtype) argname argname argname ctr name argtype)
- (if (opt-arg? arg)
- (begin
- (hey " if (!Xen_is_bound(~A)) ~A = Xen_false; ~%" argname argname)
- (hey " else Xen_check_type(Xen_is_~A(~A), ~A, ~D, ~S, ~S);~%"
- (no-stars argtype) argname argname ctr name argtype))
- (hey " Xen_check_type(Xen_is_~A(~A), ~A, ~D, ~S, ~S);~%"
- (no-stars argtype) argname argname ctr name argtype)))
- (if (>= (length arg) 3)
- (if (char=? ((arg 2) 0) #\{)
- (begin
- (set! argc (deref-name arg))
- (hey " ~A = Xen_to_C_~A(~A);~%" (deref-name arg) (deref-type arg) argname))
- (if (char=? ((arg 2) 0) #\|)
- (begin
- (hey " ~A = (~A)calloc(~A, sizeof(~A));~%"
- (deref-name arg)
- (deref-type arg)
- argc
- (deref-element-type arg))
- (hey " {~% int i;~% Xen lst;~% lst = Xen_copy_arg(~A);~%" argname)
- (hey " for (i = 0; i < ~A; i++, lst = Xen_cdr(lst)) ~A[i] = Xen_to_C_~A(Xen_car(lst));~%"
- argc
- (deref-name arg)
- (no-stars (deref-element-type arg)))
- (hey " }~%"))))))
- (set! ctr (+ ctr 1))))
+ (when (pair? args)
+ (let ((ctr 1)
+ (argc #f))
+ (for-each
+ (lambda (arg)
+ (let ((argname (cadr arg))
+ (argtype (car arg)))
+ (if (not (ref-arg? arg))
+ (if (null-arg? arg)
+ (hey " Xen_check_type(Xen_is_~A(~A) || Xen_is_false(~A), ~A, ~D, ~S, ~S);~%"
+ (no-stars argtype) argname argname argname ctr name argtype)
+ (if (opt-arg? arg)
+ (begin
+ (hey " if (!Xen_is_bound(~A)) ~A = Xen_false; ~%" argname argname)
+ (hey " else Xen_check_type(Xen_is_~A(~A), ~A, ~D, ~S, ~S);~%"
+ (no-stars argtype) argname argname ctr name argtype))
+ (hey " Xen_check_type(Xen_is_~A(~A), ~A, ~D, ~S, ~S);~%"
+ (no-stars argtype) argname argname ctr name argtype)))
+ (if (>= (length arg) 3)
+ (if (char=? ((arg 2) 0) #\{)
+ (begin
+ (set! argc (deref-name arg))
+ (hey " ~A = Xen_to_C_~A(~A);~%" (deref-name arg) (deref-type arg) argname))
+ (if (char=? ((arg 2) 0) #\|)
+ (begin
+ (hey " ~A = (~A)calloc(~A, sizeof(~A));~%"
+ (deref-name arg)
+ (deref-type arg)
+ argc
+ (deref-element-type arg))
+ (hey " {~% int i;~% Xen lst;~% lst = Xen_copy_arg(~A);~%" argname)
+ (hey " for (i = 0; i < ~A; i++, lst = Xen_cdr(lst)) ~A[i] = Xen_to_C_~A(Xen_car(lst));~%"
+ argc
+ (deref-name arg)
+ (no-stars (deref-element-type arg)))
+ (hey " }~%"))))))
+ (set! ctr (+ ctr 1))))
args)))
- (let ((using-result #f)
- (using-loc #f))
- (if (not (eq? lambda-type 'fnc))
- (begin
- (set! using-loc (or (eq? lambda-type 'GCallback)
- (and callback-data
- (or (eq? (callback-gc callback-data) 'temporary)
- (eq? (callback-gc callback-data) 'semi-permanent)))))
- (set! using-result (and (not (string=? return-type "void"))
- (not (eq? lambda-type 'lambda))))
+ (let ((using-result #f))
+ (if (eq? lambda-type 'fnc)
+ (begin
+ (set! using-result (and (> refargs 0)
+ (not return-type-void)))
+ (if using-result
+ (begin
+ (hey " {~%")
+ (hey " Xen result;~%")))
+ (hey-start)
+
+ (if (not (eq? spec 'etc))
+
+ (cond (return-type-void
+ (hey-on " "))
+
+ ((not (= refargs 0))
+ (hey-on " result = C_to_Xen_~A(" (no-stars return-type)))
+
+ ((eq? spec 'free)
+ (hey-on " {~% ~A result;~% Xen rtn;~% result = " return-type))
+
+ ((eq? spec 'const-return)
+ (hey " return(C_to_Xen_~A((~A)" (no-stars return-type) return-type))
+
+ (else
+ (if (member name idlers)
+ (begin
+ (hey " xm_unprotect_at(Xen_integer_to_C_int(Xen_caddr(~A)));~%" (cadar args))
+ (set! idlers (remove-if (lambda (x) (string=? x name)) idlers))))
+ (hey-on " return(C_to_Xen_~A(" (no-stars return-type))))))
+
+ (let ((using-loc (or (eq? lambda-type 'GCallback)
+ (and callback-data
+ (memq (callback-gc callback-data) '(temporary semi-permanent))))))
+ ;; lambda-type != 'fnc
+ (set! using-result (not (or return-type-void
+ (eq? lambda-type 'lambda))))
(hey " {~%")
(if using-result (hey " Xen result;~%"))
(if using-loc (hey " int loc;~%"))
@@ -1996,12 +2015,13 @@
args)
"Xen_false")))
(if using-loc
- (hey " loc = xm_protect(gxg_ptr);~%")
- (hey " xm_protect(gxg_ptr);~%"))
- (if using-loc
- (hey " Xen_list_set(gxg_ptr, 2, C_int_to_Xen_integer(loc));~%")
- (if (eq? lambda-type 'GtkClipboardGetFunc)
- (hey " Xen_list_set(gxg_ptr, 2, clear_func);~%")))
+ (begin
+ (hey " loc = xm_protect(gxg_ptr);~%")
+ (hey " Xen_list_set(gxg_ptr, 2, C_int_to_Xen_integer(loc));~%"))
+ (begin
+ (hey " xm_protect(gxg_ptr);~%")
+ (if (eq? lambda-type 'GtkClipboardGetFunc)
+ (hey " Xen_list_set(gxg_ptr, 2, clear_func);~%"))))
(for-each
(lambda (arg)
(let ((argname (cadr arg))
@@ -2012,31 +2032,7 @@
(hey-start)
(if using-result
(hey-on " result = C_to_Xen_~A(" (no-stars return-type))
- (heyc " ")))
- (begin ; lambda-type = 'fnc
- (set! using-result (and (> refargs 0)
- (not (string=? return-type "void"))))
- (if using-result
- (begin
- (hey " {~%")
- (hey " Xen result;~%")))
- (hey-start)
-
- (if (not (eq? spec 'etc))
- (if (not (string=? return-type "void"))
- (if (= refargs 0)
- (if (eq? spec 'free)
- (hey-on " {~% ~A result;~% Xen rtn;~% result = " return-type)
- (if (eq? spec 'const-return)
- (hey " return(C_to_Xen_~A((~A)" (no-stars return-type) return-type)
- (begin
- (if (member name idlers)
- (begin
- (hey " xm_unprotect_at(Xen_integer_to_C_int(Xen_caddr(~A)));~%" (cadar args))
- (set! idlers (remove-if (lambda (x) (string=? x name)) idlers))))
- (hey-on " return(C_to_Xen_~A(" (no-stars return-type)))))
- (hey-on " result = C_to_Xen_~A(" (no-stars return-type)))
- (hey-on " ")))))
+ (heyc " "))))
;; pass args
(if (eq? spec 'etc)
@@ -2047,15 +2043,15 @@
(min-len (car spec-data))
(max-len (cadr spec-data))
(types (caddr spec-data))
- (with-minus-one (or (string=? name "gtk_list_store_set")
- (string=? name "gtk_tree_store_set")))
- (with-null (and (not with-minus-one)
- (not (and (= (length types) 1)
- (string=? (car types) "GType")))))
+ (with-minus-one (member name '("gtk_list_store_set" "gtk_tree_store_set") string=?))
+ (with-null (not (or with-minus-one
+ (and (pair? types)
+ (null? (cdr types))
+ (string=? (car types) "GType")))))
(modlen (length types)))
(hey " {~%")
(hey " int etc_len = 0;~%")
- (if (not (string=? return-type "void"))
+ (if (not return-type-void)
(hey " ~A result = ~A;~%" return-type (if (has-stars return-type) "NULL" "0")))
(do ((i 0 (+ i 1)))
((= i (- cargs 1)))
@@ -2076,55 +2072,95 @@
(hey " p_arg~D = Xen_to_C_~A(~A);~%" i (no-stars (car arg)) (cadr arg))))
(hey " switch (etc_len)~%")
(hey " {~%")
- (do ((i min-len (+ i modlen)))
- ((> i max-len))
- (if (not (string=? return-type "void"))
- (hey " case ~D: result = ~A(" i name)
- (hey " case ~D: ~A(" i name))
- (do ((j 0 (+ 1 j)))
- ((= j (- cargs 1)))
- (let () ;(arg (args j)))
- (hey "p_arg~D, " j)))
- ;; assume ending null for now
- (let ((modctr 0))
+ (let ((name-is-file-chooser (string=? name "gtk_file_chooser_dialog_new")))
+ (do ((i min-len (+ i modlen)))
+ ((> i max-len))
+ (if (not return-type-void)
+ (hey " case ~D: result = ~A(" i name)
+ (hey " case ~D: ~A(" i name))
(do ((j 0 (+ 1 j)))
- ((= j i))
- (let ((type (types modctr)))
- (set! modctr (+ 1 modctr))
- (if (>= modctr modlen) (set! modctr 0))
- (if (string=? type "int")
- (hey "XLI(")
- (if (string=? type "gchar*")
- (hey "XLS(")
- (if (string=? type "GtkTextTag*")
- (hey "XLT(")
- (if (string=? type "GType")
- (hey "XLG(")
- (hey "XLA("))))))
- (hey "~A, ~D)" list-name j)
- (if (or with-null with-minus-one (< j (- i 1)))
- (hey ", "))))
- (if with-null
- (if (and (= i 0)
- (string=? name "gtk_file_chooser_dialog_new"))
- (hey "NULL, NULL); break;~%") ; extra NULL needed I guess for the valist pass-through -- gcc 4.1 grumbles about it
- (hey "NULL); break;~%"))
- (if with-minus-one
- (hey "-1); break;~%")
- (hey "); break;~%"))))
+ ((= j (- cargs 1)))
+ (hey "p_arg~D, " j))
+ ;; assume ending null for now
+ (let ((modctr 0))
+ (do ((j 0 (+ 1 j)))
+ ((= j i))
+ (let ((type (types modctr)))
+ (set! modctr (+ 1 modctr))
+ (if (>= modctr modlen) (set! modctr 0))
+ (hey (cond ((assoc type '(("int" . "XLI(")
+ ("gchar*" . "XLS(")
+ ("GtkTextTag*" . "XLT(")
+ ("GType" . "XLG("))
+ string=?) => cdr)
+ (else "XLA("))))
+ (hey "~A, ~D)" list-name j)
+ (if (or with-null with-minus-one (< j (- i 1)))
+ (hey ", "))))
+ (if with-null
+ (if (and (= i 0)
+ name-is-file-chooser)
+ (hey "NULL, NULL); break;~%") ; extra NULL needed I guess for the valist pass-through -- gcc 4.1 grumbles about it
+ (hey "NULL); break;~%"))
+ (if with-minus-one
+ (hey "-1); break;~%")
+ (hey "); break;~%")))))
(hey " }~%")
-
- (if (not (string=? return-type "void"))
- (hey " return(C_to_Xen_~A(result));~%" (no-stars return-type))
- (hey " return(Xen_false);~%"))
+
+ (if return-type-void
+ (hey " return(Xen_false);~%")
+ (hey " return(C_to_Xen_~A(result));~%" (no-stars return-type)))
(hey " }~%")
))
+
(begin
- (if (not (eq? lambda-type 'lambda))
+
+ (if (eq? lambda-type 'lambda)
+ (begin ; 'lambda (see line 1846)
+ (hey "if (Xen_is_aritable(func, 2))~%")
+ (hey-start)
+ (if return-type-void
+ (hey-on " ~A(" name)
+ (hey-on " return(C_to_Xen_~A(~A(" (no-stars return-type) name))
+ (hey-mark)
+ (let ((previous-arg #f))
+ (for-each
+ (lambda (arg)
+ (let ((argname (cadr arg))
+ (argtype (car arg)))
+ (if previous-arg (hey-ok ", "))
+ (set! previous-arg #t)
+ (hey-on "Xen_to_C_~A(~A)" (no-stars argtype) argname)))
+ args))
+ (if return-type-void
+ (hey ");~%")
+ (hey ")));~%"))
+ (hey " else~%")
+ (hey-start)
+ (if return-type-void
+ (hey-on " ~A(" name)
+ (hey-on " return(C_to_Xen_~A(~A(" (no-stars return-type) name))
+ (hey-mark)
+ (let ((previous-arg #f))
+ (for-each
+ (lambda (arg)
+ (let ((argname (cadr arg))
+ (argtype (car arg)))
+ (if previous-arg (hey-ok ", "))
+ (set! previous-arg #t)
+ (hey-on "Xen_to_C_~A(~A)" (no-stars argtype) argname)))
+ args))
+ (if return-type-void
+ (begin
+ (hey ");~%")
+ (hey " return(Xen_false);~%"))
+ (hey ")));~%"))
+ (hey " }~%")) ;'lambda
+
(begin
(hey-on "~A(" name)
(hey-mark)
- (if (> (length args) 0)
+ (if (pair? args)
(let ((previous-arg #f))
(for-each
(lambda (arg)
@@ -2139,13 +2175,12 @@
(hey-on "&~A" (deref-name arg))
(hey-on "Xen_to_C_~A(~A)" (no-stars argtype) argname))))
args)))
- (if (not (eq? lambda-type 'fnc))
- (if (not (string=? return-type "void"))
- (heyc ")"))
- (if (not (string=? return-type "void"))
- (if (= refargs 0)
- (if (not (eq? spec 'free)) (heyc "))"))
- (heyc ")"))))
+ (if (not return-type-void)
+ (if (not (and (eq? lambda-type 'fnc)
+ (= refargs 0)))
+ (heyc ")")
+ (if (not (eq? spec 'free))
+ (heyc "))"))))
(hey ");~%")
(if (not (eq? lambda-type 'fnc))
(begin
@@ -2155,7 +2190,7 @@
(if (and callback-data
(eq? (callback-gc callback-data) 'semi-permanent))
(hey " Xen_list_set(gxg_ptr, 2, Xen_list_3(xg_idler_symbol, ~A, C_int_to_Xen_integer(loc)));~%"
- (if (string=? return-type "void") "Xen_false" "result")))
+ (if return-type-void "Xen_false" "result")))
(if using-result
(hey " return(result);~%")
(hey " return(Xen_false);~%"))
@@ -2192,48 +2227,8 @@
(begin
(if (member name idlers)
(hey " xm_unprotect_at(Xen_integer_to_C_int(Xen_caddr(~A)));~%" (cadar args)))
- (if (string=? return-type "void")
+ (if return-type-void
(hey " return(Xen_false);~%")))))))
- (begin ; 'lambda (see line 1846)
- (hey "if (Xen_is_aritable(func, 2))~%")
- (hey-start)
- (if (not (string=? return-type "void"))
- (hey-on " return(C_to_Xen_~A(~A(" (no-stars return-type) name)
- (hey-on " ~A(" name))
- (hey-mark)
- (let ((previous-arg #f))
- (for-each
- (lambda (arg)
- (let ((argname (cadr arg))
- (argtype (car arg)))
- (if previous-arg (hey-ok ", "))
- (set! previous-arg #t)
- (hey-on "Xen_to_C_~A(~A)" (no-stars argtype) argname)))
- args))
- (if (not (string=? return-type "void"))
- (hey ")));~%")
- (hey ");~%"))
- (hey " else~%")
- (hey-start)
- (if (not (string=? return-type "void"))
- (hey-on " return(C_to_Xen_~A(~A(" (no-stars return-type) name)
- (hey-on " ~A(" name))
- (hey-mark)
- (let ((previous-arg #f))
- (for-each
- (lambda (arg)
- (let ((argname (cadr arg))
- (argtype (car arg)))
- (if previous-arg (hey-ok ", "))
- (set! previous-arg #t)
- (hey-on "Xen_to_C_~A(~A)" (no-stars argtype) argname)))
- args))
- (if (string=? return-type "void")
- (begin
- (hey ");~%")
- (hey " return(Xen_false);~%"))
- (hey ")));~%"))
- (hey " }~%")) ;'lambda
))) ; 'begin
(if (eq? spec 'free)
(hey " rtn = C_to_Xen_~A(result);~% g_free(result);~% return(rtn);~% }~%" (no-stars return-type)))
@@ -2504,6 +2499,43 @@
(hey "}~%")
(hey "#endif~%~%")
+;;; these changed from void to gboolean
+(hey "static Xen gxg_gtk_text_view_get_iter_at_position(Xen text_view, Xen iter, Xen ignore_trailing, Xen x, Xen y)~%")
+(hey "{~%")
+(hey " #define H_gtk_text_view_get_iter_at_position \"gboolean gtk_text_view_get_iter_at_position(GtkTextView* text_view, GtkTextIter* iter, gint* [trailing], gint x, gint y)\"~%")
+(hey " gint ref_trailing;~%")
+(hey " Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, \"gtk_text_view_get_iter_at_position\", \"GtkTextView*\");~%")
+(hey " Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, \"gtk_text_view_get_iter_at_position\", \"GtkTextIter*\");~%")
+(hey " Xen_check_type(Xen_is_gint(x), x, 4, \"gtk_text_view_get_iter_at_position\", \"gint\");~%")
+(hey " Xen_check_type(Xen_is_gint(y), y, 5, \"gtk_text_view_get_iter_at_position\", \"gint\");~%")
+(hey "#if GTK_CHECK_VERSION(3, 20, 0)~%")
+(hey " {~%")
+(hey " Xen result;~%")
+(hey " result = C_to_Xen_gboolean(gtk_text_view_get_iter_at_position(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), ~%")
+(hey " &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y)));~%")
+(hey " return(Xen_list_2(result, C_to_Xen_gint(ref_trailing)));~%")
+(hey " }~%")
+(hey "#else~%")
+(hey " gtk_text_view_get_iter_at_position(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y));~%")
+(hey " return(Xen_list_1(C_to_Xen_gint(ref_trailing)));~%")
+(hey "#endif~%")
+(hey "}~%~%")
+(hey "static Xen gxg_gtk_text_view_get_iter_at_location(Xen text_view, Xen iter, Xen x, Xen y)~%")
+(hey "{~%")
+(hey " #define H_gtk_text_view_get_iter_at_location \"gboolean gtk_text_view_get_iter_at_location(GtkTextView* text_view, GtkTextIter* iter, gint x, gint y)\"~%")
+(hey " Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, \"gtk_text_view_get_iter_at_location\", \"GtkTextView*\");~%")
+(hey " Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, \"gtk_text_view_get_iter_at_location\", \"GtkTextIter*\");~%")
+(hey " Xen_check_type(Xen_is_gint(x), x, 3, \"gtk_text_view_get_iter_at_location\", \"gint\");~%")
+(hey " Xen_check_type(Xen_is_gint(y), y, 4, \"gtk_text_view_get_iter_at_location\", \"gint\");~%")
+(hey "#if GTK_CHECK_VERSION(3, 20, 0)~%")
+(hey " return(C_to_Xen_gboolean(gtk_text_view_get_iter_at_location(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), Xen_to_C_gint(x), Xen_to_C_gint(y))));~%")
+(hey "#else~%")
+(hey " gtk_text_view_get_iter_at_location(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), Xen_to_C_gint(x), Xen_to_C_gint(y));~%")
+(hey " return(Xen_false);~%")
+(hey "#endif~%")
+(hey "}~%~%")
+
+
(hey "#if HAVE_SCHEME~%")
(hey " #define Xg_define_procedure(Name, Value, A1, A2, A3, Help, Sig) s7_define_typed_function(s7, Xg_pre #Name Xg_post, Value, A1, A2, A3, Help, Sig)~%")
(hey "#else~%")
@@ -2515,6 +2547,8 @@
(hey "Xen_wrap_no_args(gxg_make_GtkTreeIter_w, gxg_make_GtkTreeIter)~%")
(hey "Xen_wrap_no_args(gxg_make_PangoRectangle_w, gxg_make_PangoRectangle)~%")
(hey "Xen_wrap_no_args(gxg_make_cairo_matrix_t_w, gxg_make_cairo_matrix_t)~%")
+(hey "Xen_wrap_4_args(gxg_gtk_text_view_get_iter_at_location_w, gxg_gtk_text_view_get_iter_at_location)~%")
+(hey "Xen_wrap_5_optional_args(gxg_gtk_text_view_get_iter_at_position_w, gxg_gtk_text_view_get_iter_at_position)~%")
(hey "#if GTK_CHECK_VERSION(3, 0, 0)~%")
(hey "Xen_wrap_no_args(gxg_make_GdkRGBA_w, gxg_make_GdkRGBA)~%")
(hey "#endif~%")
@@ -2525,6 +2559,8 @@
(hey " Xg_define_procedure(GtkTreeIter, gxg_make_GtkTreeIter_w, 0, 0, 0, \"(GtkTreeIter): a new GtkTreeIter struct\", NULL);~%")
(hey " Xg_define_procedure(PangoRectangle, gxg_make_PangoRectangle_w, 0, 0, 0, \"(PangoRectangle): a new PangoRectangle struct\", NULL);~%")
(hey " Xg_define_procedure(cairo_matrix_t, gxg_make_cairo_matrix_t_w, 0, 0, 0, \"(cairo_matrix_t): a new cairo_matrix_t struct\", NULL);~%")
+(hey " Xg_define_procedure(gtk_text_view_get_iter_at_location, gxg_gtk_text_view_get_iter_at_location_w, 4, 0, 0, H_gtk_text_view_get_iter_at_location, NULL);~%")
+(hey " Xg_define_procedure(gtk_text_view_get_iter_at_position, gxg_gtk_text_view_get_iter_at_position_w, 4, 1, 0, H_gtk_text_view_get_iter_at_position, NULL);~%")
(hey "#if GTK_CHECK_VERSION(3, 0, 0)~%")
(hey " Xg_define_procedure(GdkRGBA, gxg_make_GdkRGBA_w, 0, 0, 0, \"(GdkRGBA): a new GdkRGBA struct\", NULL);~%")
(hey "#endif~%")
@@ -2542,18 +2578,15 @@
(hey "Xen_wrap_~A(gxg_~A_w, gxg_~A)~%"
(if (>= cargs max-args)
"any_args"
- (if (> refargs 0)
- (format #f "~D_optional_arg~A" cargs (if (= cargs 1) "" "s"))
- (format #f "~A_arg~A" (if (zero? cargs) "no" (number->string cargs)) (if (= cargs 1) "" "s"))))
+ (format #f (if (> refargs 0)
+ (values "~D_optional_arg~A" cargs (if (= cargs 1) "" "s"))
+ (values "~A_arg~A" (if (zero? cargs) "no" (number->string cargs)) (if (= cargs 1) "" "s")))))
(car func) (car func))))
-
+#|
(define (unargify-func func)
- (let (;(cargs (length (caddr func)))
- ;(refargs (+ (ref-args (caddr func)) (opt-args (caddr func))))
- ;(args (- cargs refargs))
- )
- (hey "#define gxg_~A_w gxg_~A~%"
- (car func) (car func))))
+ (hey "#define gxg_~A_w gxg_~A~%"
+ (car func) (car func)))
+|#
(for-each argify-func (reverse funcs))
(for-each
@@ -2584,7 +2617,8 @@
(for-each ruby-cast (reverse cast-list))))))
all-casts all-cast-withs)
-(define (ruby-check func) (hey "Xen_wrap_1_arg(gxg_~A_w, gxg_~A)~%" (no-arg (car func)) (no-arg (car func))))
+;;(define (ruby-check func) (hey "Xen_wrap_1_arg(gxg_~A_w, gxg_~A)~%" (no-arg (car func)) (no-arg (car func))))
+(define ruby-check ruby-cast)
(for-each ruby-check (reverse checks))
(for-each
(lambda (check-list check-func)
@@ -2598,23 +2632,26 @@
(hey "#if HAVE_SCHEME~%")
(define (gtk-type->s7-type gtk)
- (let ((dt (assoc gtk direct-types)))
- (if (and (pair? dt)
- (string? (cdr dt)))
- (let ((direct (cdr dt)))
- (cond ((member direct '("INT" "ULONG") string=?) 'integer?)
- ((string=? direct "BOOLEAN") 'boolean?)
- ((string=? direct "DOUBLE") 'real?)
- ((string=? direct "String") 'string?)
- (#t #t)))
- (or (not (has-stars gtk)) 'pair?))))
+ (cond ((member gtk declared-names (lambda (a b)
+ (string=? a (cadr b))))
+ 'gtk_enum_t?)
+ ((assoc gtk direct-types) => (lambda (dt)
+ (or (not (string? (cdr dt)))
+ (let ((direct (cdr dt)))
+ (cond ((member direct '("INT" "ULONG") string=?) 'integer?)
+ ((assoc direct '(("BOOLEAN" . boolean?)
+ ("DOUBLE" . real?)
+ ("String" . string?)) string=?)
+ => cdr)
+ (else #t))))))
+ (else (or (not (has-stars gtk)) 'pair?))))
(define (make-signature fnc)
(define (compress sig)
(if (and (pair? sig)
(pair? (cdr sig))
- (or (not (eq? (car sig) 'pair?))
- (not (null? (cddr sig))))
+ (not (and (eq? (car sig) 'pair?)
+ (null? (cddr sig))))
(eq? (car sig) (cadr sig)))
(compress (cdr sig))
sig))
@@ -2632,9 +2669,7 @@
(let ((sig (make-signature f)))
(if (pair? sig)
(let ((count (signatures sig)))
- (if (not count)
- (set! (signatures sig) 0)
- (set! (signatures sig) (+ count 1)))))))
+ (set! (signatures sig) (if (not count) 0 (+ count 1)))))))
lst))
(make-signatures funcs)
@@ -2642,7 +2677,7 @@
;(format *stderr* "~D entries, ~D funcs~%" (hash-table-entries signatures) (length funcs))
-(hey "static s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_pair_false;~%")
+(hey "static s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_gtk_enum_t, s_pair_false;~%")
(hey "static s7_pointer ")
(define (sig-name sig)
@@ -2650,22 +2685,24 @@
(lambda (p)
(display "pl_" p)
(display (case (car sig)
- ((integer?) "i")
- ((boolean?) "b")
- ((real?) "d")
- ((string?) "s")
- ((pair?) "p")
- (else "t"))
+ ((integer?) "i")
+ ((boolean?) "b")
+ ((real?) "d")
+ ((string?) "s")
+ ((pair?) "p")
+ ((gtk_enum_t?) "g")
+ (else "t"))
p)
(for-each
(lambda (typ)
(display (case typ
- ((integer?) "i")
- ((boolean?) "b")
- ((real?) "r")
- ((string?) "s")
- ((pair?) "u") ; because we're stupidly using #f=null
- (else "t"))
+ ((integer?) "i")
+ ((boolean?) "b")
+ ((real?) "r")
+ ((string?) "s")
+ ((pair?) "u") ; because we're stupidly using #f=null
+ ((gtk_enum_t?) "g")
+ (else "t"))
p))
(cdr sig)))))
@@ -2675,7 +2712,7 @@
(hey (sig-name sig))
(hey ", ")))
signatures)
-(hey "pl_unused;~%")
+(hey "pl_bpt;~%")
(hey "#endif~%~%")
;;; --------------------------------------------------------------------------------
@@ -2696,6 +2733,7 @@
(hey " s_string = s7_make_symbol(s7, \"string?\");~%")
(hey " s_pair = s7_make_symbol(s7, \"pair?\");~%")
(hey " s_pair_false = s7_make_signature(s7, 2, s_pair, s_boolean);~%")
+(hey " s_gtk_enum_t = s7_make_symbol(s7, \"gtk_enum_t?\");~%")
(hey " s_any = s7_t(s7);~%~%")
(for-each
@@ -2710,28 +2748,30 @@
(hey (number->string len))
(hey ", ")
(hey (case (car sig)
- ((integer?) "s_integer")
- ((boolean?) "s_boolean")
- ((real?) "s_float")
- ((string?) "s_string")
- ((pair?) "s_pair")
- (else "s_any")))
+ ((integer?) "s_integer")
+ ((boolean?) "s_boolean")
+ ((real?) "s_float")
+ ((string?) "s_string")
+ ((pair?) "s_pair")
+ ((gtk_enum_t?) "s_gtk_enum_t")
+ (else "s_any")))
(if (> len 1) (hey ", "))
(do ((i 1 (+ i 1))
(s (cdr sig) (cdr s)))
((= i len))
(let ((typ (car s)))
(hey (case typ
- ((integer?) "s_integer")
- ((boolean?) "s_boolean")
- ((real?) "s_real")
- ((string?) "s_string")
- ((pair?) "s_pair_false")
+ ((integer?) "s_integer")
+ ((boolean?) "s_boolean")
+ ((real?) "s_real")
+ ((string?) "s_string")
+ ((pair?) "s_pair_false")
+ ((gtk_enum_t?) "s_gtk_enum_t")
(else "s_any"))))
(if (< i (- len 1)) (hey ", "))))
(hey ");~%")))
signatures)
-(hey "pl_unused = NULL;~%")
+(hey " pl_bpt = s7_make_signature(s7, 2, s_pair_false, s_any);~%")
(hey "#endif~%~%")
(define (defun func)
@@ -2759,7 +2799,7 @@
all-funcs all-func-withs)
(define (cast-out func)
- (hey " Xg_define_procedure(~A, gxg_~A_w, 1, 0, 0, \"(~A obj) casts obj to ~A\", NULL);~%"
+ (hey " Xg_define_procedure(~A, gxg_~A_w, 1, 0, 0, \"(~A obj) casts obj to ~A\", pl_bpt);~%"
(no-arg (car func))
(no-arg (car func))
(no-arg (car func))
@@ -2787,9 +2827,10 @@
(hey " Xg_define_procedure(gtk_init_check, gxg_gtk_init_check_w, 0, 2, 0, H_gtk_init_check, NULL);~%")
(define (check-out func)
- (hey " Xg_define_procedure(~A, gxg_~A_w, 1, 0, 0, \"(~A obj): \" PROC_TRUE \" if obj is a ~A\", NULL);~%"
+ (hey " Xg_define_procedure(~A, gxg_~A_w, 1, 0, 0,~%~NC\"(~A obj): \" PROC_TRUE \" if obj is a ~A\", pl_bt);~%"
(no-arg (car func))
(no-arg (car func))
+ 22 #\space
(no-arg (car func))
(no-arg (car func))))
@@ -2891,6 +2932,137 @@
(hey "}~%~%")
+
+(hey "/* -------------------------------- lint -------------------------------- */~%")
+(hey "~%")
+(hey "#if HAVE_SCHEME~%")
+(hey "typedef struct {const char *name, *type; long long int value;} enummer_t;~%")
+(hey "static enummer_t enum_info[] = {~%")
+(set! declared-names (sort! declared-names (lambda (a b)
+ (string<? (caddr a) (caddr b)))))
+(let ((version ""))
+ (do ((names declared-names (cdr names)))
+ ((null? names)
+ (hey "#endif~%~NC{NULL, NULL, 0}};~%~%" 8 #\space)) ; end marker
+ (unless (string=? (caddar names) version)
+ (if (> (length version) 0)
+ (hey "#endif~%"))
+ (set! version (caddar names))
+ (hey (string-append "#if GTK_CHECK_VERSION(" (substring version 0 1) ", " (substring version 2) ", 0)~%")))
+ (hey "~NC{~S, ~S, ~A},~%" 8 #\space (caar names) (cadar names) (caar names))))
+
+(hey "static s7_pointer enum_value_to_name(s7_scheme *sc, long long int val, const char *type) ~%")
+(hey "{ ~%")
+(hey " int k; ~%")
+(hey " long long int range_min = 0, range_max = 0; ~%")
+(hey " bool range_set = false; ~%")
+(hey " for (k = 0; ; k++) ~%")
+(hey " { ~%")
+(hey " enummer_t nt; ~%")
+(hey " nt = enum_info[k]; ~%")
+(hey " if (!nt.name) ~%")
+(hey " break; ~%")
+(hey " if (strcmp(nt.type, type) == 0) ~%")
+(hey " { ~%")
+(hey " if (nt.value == val) /* ... value should be <nt.name> */ ~%")
+(hey " return(s7_make_string(sc, nt.name)); ~%")
+(hey " if (!range_set) ~%")
+(hey " { ~%")
+(hey " range_min = nt.value; ~%")
+(hey " range_max = nt.value; ~%")
+(hey " range_set = true; ~%")
+(hey " } ~%")
+(hey " else ~%")
+(hey " { ~%")
+(hey " if (range_min > nt.value) range_min = nt.value; ~%")
+(hey " if (range_max < nt.value) range_max = nt.value; ~%")
+(hey " } ~%")
+(hey " } ~%")
+(hey " } ~%")
+(hey " if (range_set) /* here we found a matching name, its type is wrong, and it's out of range */ ~%")
+(hey " { ~%")
+(hey " char *range_string; ~%")
+(hey " s7_pointer str; ~%")
+(hey " range_string = (char *)malloc(256 * sizeof(char)); ~%")
+(hey " snprintf(range_string, 256, \"between %lld and %lld\", range_min, range_max); ~%")
+(hey " str = s7_make_string(sc, range_string); ~%")
+(hey " free(range_string); ~%")
+(hey " return(str); /* ... value should be between <min> and <max> */ ~%")
+(hey " } ~%")
+(hey " return(s_integer); ~%")
+(hey "}~%~%")
+
+(hey "static s7_pointer g_gtk_enum_t(s7_scheme *sc, s7_pointer args) ~%")
+(hey "{ ~%")
+(hey " s7_pointer form, argn, func, arg; ~%")
+(hey " const char *doc_string, *p; ~%")
+(hey " int arg_number; ~%")
+(hey " form = s7_car(args); ~%")
+(hey " argn = s7_cadr(args); ~%")
+(hey " arg_number = s7_integer(argn); ~%")
+(hey " arg = s7_list_ref(sc, form, arg_number); ~%")
+(hey " if ((!s7_is_integer(arg)) && ~%")
+(hey " (!s7_is_symbol(arg))) ~%")
+(hey " return(s_integer); ~%")
+(hey " func = s7_car(form); ~%")
+(hey " doc_string = s7_procedure_documentation(sc, func); ~%")
+(hey " p = strchr(doc_string, (int)'('); ~%")
+(hey " if (p) ~%")
+(hey " { ~%")
+(hey " int i; ~%")
+(hey " for (i = 1; i < arg_number; i++) ~%")
+(hey " p = strchr((char *)(p + 1), (int)','); ~%")
+(hey " if (p) ~%")
+(hey " { ~%")
+(hey " const char *e; ~%")
+(hey " p += 2; /* past comma and space */ ~%")
+(hey " e = strchr(p, (int)' '); ~%")
+(hey " if (e) ~%")
+(hey " { ~%")
+(hey " int len; ~%")
+(hey " char *type; ~%")
+(hey " len = e - p + 1; ~%")
+(hey " type = (char *)malloc(len * sizeof(char)); ~%")
+(hey " for (i = 0; i < len; i++) type[i] = p[i]; ~%")
+(hey " type[len - 1] = '\\0'; ~%")
+(hey " if (s7_is_symbol(arg)) ~%")
+(hey " { ~%")
+(hey " const char *arg_name; ~%")
+(hey " arg_name = s7_symbol_name(arg); /* no free */ ~%")
+(hey " for (i = 0; ; i++) ~%")
+(hey " { ~%")
+(hey " enummer_t et; ~%")
+(hey " et = enum_info[i]; ~%")
+(hey " if (!et.name) ~%")
+(hey " break; ~%")
+(hey " if (strcmp(et.name, arg_name) == 0) ~%")
+(hey " { ~%")
+(hey " if (strcmp(et.type, type) == 0) /* success -- name and type match */ ~%")
+(hey " { ~%")
+(hey " free(type); ~%")
+(hey " return(s7_t(sc)); ~%")
+(hey " } ~%")
+(hey " return(enum_value_to_name(sc, et.value, type)); /* here the type is wrong, so try to find the correct name */ ~%")
+(hey " } ~%")
+(hey " } ~%")
+(hey " return(s_integer); /* here we got no matches, so return 'integer? */ ~%")
+(hey " } ~%")
+(hey " return(enum_value_to_name(sc, s7_integer(arg), type)); /* here arg is an integer */ ~%")
+(hey " } ~%")
+(hey " } ~%")
+(hey " } ~%")
+(hey " return(s_integer); ~%")
+(hey "}~%~%")
+
+(hey "static void define_lint(void)~%")
+(hey "{~%")
+(hey " s7_define_typed_function(s7, \"gtk_enum_t?\", g_gtk_enum_t, 2, 0, 0, \"lint helper\", pl_bti);~%")
+(hey "}~%")
+(hey "#endif~%")
+
+(hey "~%~%")
+
+
(hey "/* -------------------------------- initialization -------------------------------- */~%~%")
(hey "static bool xg_already_inited = false;~%~%")
(hey "void Init_libxg(void);~%")
@@ -2906,6 +3078,9 @@
(hey " define_atoms();~%")
(hey " define_strings();~%")
(hey " define_structs();~%")
+(hey " #if HAVE_SCHEME~%")
+(hey " define_lint();~%")
+(hey " #endif~%")
(hey " Xen_provide_feature(\"xg\");~%")
(hey " #if GTK_CHECK_VERSION(3, 0, 0)~%")
(hey " Xen_provide_feature(\"gtk3\");~%")
@@ -2947,17 +3122,19 @@
(close-output-port xg-file)
+;(format *stderr* "declared types: ~A ~A~%" (length declared-types) (length declared-names)) 157 1288
#|
(for-each
(lambda (type)
(if (not (assoc type direct-types))
- (format #t ";not direct: ~A~%" type)))
+ (format *stderr* ";not direct: ~A~%" type)))
declared-types)
+(format *stderr* "~%")
(for-each
(lambda (v)
(if (not (member (car v) declared-types))
- (format #t "~A " (car v))))
+ (format *stderr* "~A~%" (car v))))
direct-types)
|#
diff --git a/tools/profile.h b/tools/profile.h
deleted file mode 100644
index a054ff8..0000000
--- a/tools/profile.h
+++ /dev/null
@@ -1,218 +0,0 @@
-#if 0
-#if 1
-#define NUM_COUNTS 65536
-static int counts[NUM_COUNTS];
-static void clear_counts(void) {int i; for (i = 0; i < NUM_COUNTS; i++) counts[i] = 0;}
-void tick(int this) {counts[this]++;}
-static void report_counts(s7_scheme *sc)
-{
- int i, mx, mxi, total = 0;
- bool happy = true;
-
- for (i = 0; i < NUM_COUNTS; i++)
- total += counts[i];
-
- fprintf(stderr, "total: %d\n", total);
- while (happy)
- {
- mx = 0;
- for (i = 0; i < NUM_COUNTS; i++)
- {
- if (counts[i] > mx)
- {
- mx = counts[i];
- mxi = i;
- }
- }
- if (mx > 0)
- {
- /* if (mx > total/100) */
- fprintf(stderr, "%d: %d (%f)\n", mxi, mx, 100.0*mx/(float)total);
- counts[mxi] = 0;
- }
- else happy = false;
- }
-}
-#else
-
-#if 1
-#define NUM_COUNTS 500
-static int counts[70000][NUM_COUNTS];
-static void clear_counts(void) {int i, j; for (i = 0; i < NUM_COUNTS; i++) for (j = 0; j < NUM_COUNTS; j++) counts[i][j] = 0;}
-static void tick(int line, int op) {counts[line][op]++; }
-
-static void report_counts(s7_scheme *sc)
-{
- int j, mx, mxi, mxj;
- fprintf(stderr, "\n");
-
- for (mxi = 0; mxi < 70000; mxi++)
- {
- int k, ctotal = 0;
- for (k = 0; k < 500; k++) ctotal += counts[mxi][k];
- if (ctotal > 0)
- {
- mx = 0;
- for (j = 0; j < NUM_COUNTS; j++)
- {
- if (counts[mxi][j] > mx)
- {
- mx = counts[mxi][j];
- mxj = j;
- }
- }
- fprintf(stderr, "%d: %d %d of %d\n", mxi, mxj, counts[mxi][mxj], ctotal);
- }
- }
-#if 0
- {
- int i;
- bool happy = true;
- while (happy)
- {
- mx = 0;
- for (i = 0; i < 70000; i++)
- for (j = 0; j < NUM_COUNTS; j++)
- {
- if (counts[i][j] > mx)
- {
- mx = counts[i][j];
- mxi = i;
- mxj = j;
- }
- }
- if (mx > 0)
- {
- int k, ctotal = 0;
- for (k = 0; k < 500; k++) ctotal += counts[mxi][k];
-
- fprintf(stderr, "%d: %d %d of %d\n", mxi, mxj, counts[mxi][mxj], ctotal);
- counts[mxi][mxj] = 0;
- }
- else happy = false;
- }
- }
-#endif
-}
-
-#else
-#define NUM_COUNTS 1000
-static int counts[NUM_COUNTS];
-static void clear_counts(void) {int i; for (i = 0; i < NUM_COUNTS; i++) counts[i] = 0;}
-static void tick(int op) {counts[op]++;}
-static void report_counts(s7_scheme *sc)
-{
- int k, i, mx;
- bool happy = true;
- fprintf(stderr, "\n");
- while (happy)
- {
- mx = 0;
- for (k = 0; k < OP_MAX_DEFINED; k++)
- {
- if (counts[k] > mx)
- {
- mx = counts[k];
- i = k;
- }
- }
- if (mx > 0)
- {
- fprintf(stderr, "%d: %d\n", i, counts[i]);
- counts[i] = 0;
- }
- else happy = false;
- }
- /* fprintf(stderr, "\n"); */
-}
-#endif
-#endif
-
-static void init_hashes(s7_scheme *sc) {}
-
-#else
-
-void clear_counts(void) {}
-static s7_pointer hashes;
-void add_expr(s7_scheme *sc, s7_pointer expr);
-void add_expr(s7_scheme *sc, s7_pointer expr)
-{
- s7_pointer val;
- /* expr = sc->cur_code; */
- val = s7_hash_table_ref(sc, hashes, expr);
- if (val == sc->F)
- {
- if (!is_any_closure(expr))
- s7_hash_table_set(sc, hashes, expr, s7_make_integer(sc, 1));
- }
- else
- {
- s7_hash_table_set(sc, hashes, expr, s7_make_integer(sc, 1 + s7_integer(val)));
- }
-}
-static void init_hashes(s7_scheme *sc)
-{
- hashes = s7_make_hash_table(sc, 65536);
- s7_gc_protect(sc, hashes);
-}
-
-typedef struct {
- s7_int count;
- s7_pointer expr;
-} datum;
-
-static datum *new_datum(s7_int ctr, s7_pointer e)
-{
- datum *d;
- d = calloc(1, sizeof(datum));
- d->count = ctr;
- d->expr = e;
- return(d);
-}
-static int sort_data(const void *v1, const void *v2)
-{
- datum *d1 = *(datum **)v1;
- datum *d2 = *(datum **)v2;
- if (d1->count > d2->count)
- return(-1);
- return(1);
-}
-static void report_counts(s7_scheme *sc)
-{
- int len, i, loc = 0, entries;
- hash_entry_t **elements;
- datum **data;
-
- len = hash_table_length(hashes);
- elements = hash_table_elements(hashes);
- entries = hash_table_entries(hashes);
- if (entries == 0)
- {
- fprintf(stderr, "no counts\n");
- return;
- }
- data = (datum **)calloc(entries, sizeof(datum *));
-
- for (i = 0; i < len; i++)
- {
- hash_entry_t *x;
- for (x = elements[i]; x; x = x->next)
- data[loc++] = new_datum(s7_integer(x->value), x->key);
- }
-
- qsort((void *)data, loc, sizeof(datum *), sort_data);
- if (loc > 400) loc = 400;
- fprintf(stderr, "\n");
- for (i = 0; i < loc; i++)
- if (data[i]->count > 0)
- fprintf(stderr, "%lld: %s\n", data[i]->count, DISPLAY_80(data[i]->expr));
-
- free(data);
-}
-void add_code(s7_scheme *sc);
-void add_code(s7_scheme *sc)
-{
- add_expr(sc, sc->code);
-}
-/* use xen.h and s7 here */
-#endif
diff --git a/tools/sarchive b/tools/sarchive
index 583fc28..6faaaee 100755
--- a/tools/sarchive
+++ b/tools/sarchive
@@ -58,6 +58,19 @@ foreach file (*)
end
+chdir /home/bil/dist/snd/s7webserver
+foreach file (*)
+ if (-e /home/bil/cl/s7webserver/$file) then
+ diff -bcw /home/bil/cl/s7webserver/$file /home/bil/dist/snd/s7webserver/$file >> /home/bil/cl/hi
+ find /home/bil/cl/s7webserver/$file -newer /home/bil/dist/snd/s7webserver/$file -exec echo ' updating ' snd/s7webserver/$file \;
+ find /home/bil/cl/s7webserver/$file -newer /home/bil/dist/snd/s7webserver/$file -exec cp /home/bil/dist/snd/s7webserver/$file /home/bil/old-dist \;
+ find /home/bil/cl/s7webserver/$file -newer /home/bil/dist/snd/s7webserver/$file -exec cp /home/bil/cl/s7webserver/$file /home/bil/dist/snd/s7webserver \;
+ else
+ echo $file '(snd s7webserver) does not exist in /home/bil/cl/s7webserver'
+ endif
+end
+
+
chdir /home/bil/dist/snd/sndins
foreach file (*.h *.c *.in README)
if (-e /home/bil/cl/sndins/$file) then
diff --git a/tools/t101.scm b/tools/t101.scm
index f58afb4..a7aff4f 100644
--- a/tools/t101.scm
+++ b/tools/t101.scm
@@ -101,7 +101,7 @@
(system "./snd makegl.scm")
(format *stderr* "~NC lg ~NC~%" 20 #\- 20 #\-)
-(system "./snd lg.scm")
+(system "./repl lg.scm")
(format *stderr* "~NC tgen ~NC~%" 20 #\- 20 #\-)
(system "./snd tgen.scm")
diff --git a/tools/table.scm b/tools/table.scm
index 11abd53..16ba6fb 100755
--- a/tools/table.scm
+++ b/tools/table.scm
@@ -1,6 +1,6 @@
(define (no-dashes-or-cr str)
(let ((len (length str))
- (newstr (make-string 0))
+ (newstr "")
(last-ch #\-))
(do ((i 0 (+ i 1)))
((= i (- len 1)))
@@ -23,7 +23,7 @@
(if (and (> len 30)
(string=? ";;; ---------------- test "
(substring line 0 26)))
- (format #t "~A ~48,1T[~D]~%" (no-dashes-or-cr line) ctr))
+ (format () "~A ~48,1T[~D]~%" (no-dashes-or-cr line) ctr))
(loop (read-line file #t))))))))
(exit)
diff --git a/tools/tauto.scm b/tools/tauto.scm
index e531fe7..334ef6a 100644
--- a/tools/tauto.scm
+++ b/tools/tauto.scm
@@ -155,11 +155,10 @@
(procedure? (car lst)))
lst
(begin
- (if (symbol? (car lst))
- (set-car! lst (symbol->value (car lst)))
- (if (pair? (car lst))
- (set-car! lst (apply lambda '(x) `((or (,(caar lst) x) (,(cadar lst) x)))))
- (set-car! lst #f)))
+ (set-car! lst (if (symbol? (car lst))
+ (symbol->value (car lst))
+ (and (pair? (car lst))
+ (apply lambda '(x) `((or (,(caar lst) x) (,(cadar lst) x)))))))
(map-values (cdr lst)))))
(define baddies '(exit emergency-exit abort autotest
@@ -169,7 +168,7 @@
throw symbol-table load
global-environment current-environment make-procedure-with-setter procedure-with-setter? make-rectangular
- copy fill! hash-table-set! vector-set! let-set! hash-table-size
+ copy fill! hash-table-set! vector-set! let-set!
mock-number mock-pair mock-string mock-char mock-vector
mock-symbol mock-port mock-hash-table m
@@ -195,10 +194,10 @@
;(format *stderr* ";~A...~%" sym)
(set! low bottom)
(if (positive? (cdr argn))
- (let ((sig (if (eq? sym 'append)
- (let ((lst (list 'list?)))
- (set-cdr! lst lst))
- (copy (procedure-signature f)))))
+ (let ((sig (cond ((eq? sym 'append)
+ (let ((lst (list 'list?)))
+ (set-cdr! lst lst)))
+ ((procedure-signature f) => copy))))
(map-values sig)
(autotest f () 0 top (if (pair? sig) (cdr sig) ()))))))))))))
diff --git a/tools/teq.scm b/tools/teq.scm
index 3e62f13..ba9457b 100644
--- a/tools/teq.scm
+++ b/tools/teq.scm
@@ -27,13 +27,12 @@
z))))
(define vect-3 (let ((x '(1 2)))
(let ((y (list x x)))
- (let ((z (vector x y)))
- z))))
-(define vect-4 (let ((v (vector 1 2 3 4)))
- (let ((lst (list 1 2)))
- (set-cdr! (cdr lst) lst)
- (set! (v 0) v)
- (set! (v 3) lst))))
+ (vector x y))))
+(define vect-4 (let ((v (vector 1 2 3 4))
+ (lst (list 1 2)))
+ (set-cdr! (cdr lst) lst)
+ (set! (v 0) v)
+ (set! (v 3) lst)))
(define hash-2 (let ((h1 (make-hash-table 11)))
(hash-table-set! h1 "hi" h1)))
(define list-4 (let ()
diff --git a/tools/testsnd b/tools/testsnd
index bc50f22..8ec1bd0 100755
--- a/tools/testsnd
+++ b/tools/testsnd
@@ -127,7 +127,7 @@ echo ' -------------------------------- without-gui CC=g++ --disable-deprecated
make allclean
rm -f snd
rm -f config.cache
-./configure --quiet CFLAGS="-Wall -DWITH_EXTRA_EXPONENT_MARKERS=1 -DWITH_QUASIQUOTE_VECTOR=1" --without-gui --disable-deprecated CC=g++
+./configure --quiet CFLAGS="-Wall -DWITH_EXTRA_EXPONENT_MARKERS=1" --without-gui --disable-deprecated CC=g++
make
echo ' '
echo ' '
diff --git a/tools/tgen.scm b/tools/tgen.scm
index 57efa4a..7e25d3f 100644
--- a/tools/tgen.scm
+++ b/tools/tgen.scm
@@ -1,5 +1,5 @@
-(if (and (not (provided? 'snd))
- (not (provided? 'sndlib)))
+(if (not (or (provided? 'snd)
+ (provided? 'sndlib)))
(begin
(format *stderr* "tgen depends on sndlib...~%")
(system "./snd -noinit tgen.scm")
@@ -158,10 +158,10 @@
;(define vequal morally-equal?)
(define-constant (checkout str V v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12)
- (if (or (not (vequal V v1))
- (not (vequal v1 v2))
- (not (vequal v1 v3))
- (not (vequal v1 v4)))
+ (if (not (and (vequal V v1)
+ (vequal v1 v2)
+ (vequal v1 v3)
+ (vequal v1 v4)))
(format *stderr* "~S:~% no do: ~A~% fv-set: ~A~% outa->v:~A~% outa: ~A~% list: ~A~%" str V v1 v2 v3 v4))
(if (not (vequal v5 v6)) (format *stderr* "dox ~S:~% fv-set: ~A~% outa->v:~A~%" str v5 v6))
(if (not (vequal v7 v8)) (format *stderr* "let ~S:~% ~A~% ~A~%" str v7 v8))
@@ -169,10 +169,10 @@
(if (not (vequal v11 v12)) (format *stderr* "letx ~S:~% ~A~% ~A~%" str v11 v12)))
(define-constant (checkout-1 str V v1 v2 v3 v4 v5 v6 v11 v12)
- (if (or (not (vequal V v1))
- (not (vequal v1 v2))
- (not (vequal v1 v3))
- (not (vequal v1 v4)))
+ (if (not (and (vequal V v1)
+ (vequal v1 v2)
+ (vequal v1 v3)
+ (vequal v1 v4)))
(format *stderr* "~S:~% no do: ~A~% fv-set: ~A~% outa->v:~A~% outa: ~A~% list: ~A~%" str V v1 v2 v3 v4))
(if (not (vequal v5 v6)) (format *stderr* "dox ~S:~% fv-set: ~A~% outa->v:~A~%" str v5 v6))
(if (not (vequal v11 v12)) (format *stderr* "letx ~S:~% ~A~% ~A~%" str v11 v12)))
diff --git a/tools/thash.scm b/tools/thash.scm
index 94e8628..fa01de5 100644
--- a/tools/thash.scm
+++ b/tools/thash.scm
@@ -171,8 +171,8 @@
(set! counts (reader))
-(if (or (not (string=? (car (counts 0)) "the"))
- (not (= (cdr (counts 0)) 62063)))
+(if (not (and (string=? (car (counts 0)) "the")
+ (= (cdr (counts 0)) 62063)))
(do ((i 0 (+ i 1)))
((= i 40))
(format *stderr* "~A: ~A~%" (car (counts i)) (cdr (counts i)))))
diff --git a/tools/titer.scm b/tools/titer.scm
index 38fb5ef..d462277 100644
--- a/tools/titer.scm
+++ b/tools/titer.scm
@@ -77,13 +77,12 @@
(find-if-b (make-iterator lt p))
(find-if-c (make-iterator lt p))
(find-if-d (make-iterator lt p)))))
- (h (if with-blocks
- (let ((blk (make-block size)))
- (list (find-if-a (make-iterator blk))
- (find-if-b (make-iterator blk))
- (find-if-c (make-iterator blk))
- (find-if-d (make-iterator blk))))
- #f)))
+ (h (and with-blocks
+ (let ((blk (make-block size)))
+ (list (find-if-a (make-iterator blk))
+ (find-if-b (make-iterator blk))
+ (find-if-c (make-iterator blk))
+ (find-if-d (make-iterator blk)))))))
(if (not (equal? a '(#f #f #f #f))) (format *stderr* "a: ~A " a))
(if (not (equal? b '(#f #f #f #f))) (format *stderr* "b: ~A " b))
diff --git a/tools/va.scm b/tools/va.scm
index 53931c4..c00333b 100755
--- a/tools/va.scm
+++ b/tools/va.scm
@@ -1,9 +1,9 @@
;;; various lint-like checks
-(define (find-if pred l)
- (cond ((null? l) #f)
- ((pred (car l)) (car l))
- (else (find-if pred (cdr l)))))
+(define (find-if pred lst)
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (find-if pred (cdr lst)))))
(define (va)
(for-each
@@ -29,23 +29,21 @@
((#\=)
(set! count 0))
(else
- (if (and (< i (- len 2))
- (string=? (substring line i (+ i 2)) "/*"))
- (return #f)
- (if (and (< i (- len flen))
- (string=? (substring line i (+ i flen)) func))
- (begin
- (set! precount count)
- (set! count 0))
- (if (and (< i (- len 6))
- (string=? (substring line i (+ i 6)) "sizeof"))
- (begin
- (set! ok #t)
- (set! count 0))))))))))
+ (cond ((and (< i (- len 2))
+ (string=? (substring line i (+ i 2)) "/*"))
+ (return #f))
+ ((and (< i (- len flen))
+ (string=? (substring line i (+ i flen)) func))
+ (set! precount count)
+ (set! count 0))
+ ((and (< i (- len 6))
+ (string=? (substring line i (+ i 6)) "sizeof"))
+ (set! ok #t)
+ (set! count 0))))))))
(if (and ok
(not (= precount count 0))
(not (= count (- precount 1))))
- (format #t "calloc ~D->~D: ~A~%" precount count line))
+ (format () "calloc ~D->~D: ~A~%" precount count line))
(loop (read-line file #t))))))))
(list "calloc" "malloc" "realloc"))
@@ -54,38 +52,36 @@
(for-each
(lambda (filename)
- (if (and (provided? 'gtk3)
- (provided? 'xg))
- (call-with-input-file filename
- (lambda (file)
- (let ((line-number 0))
- (let loop ((line (read-line file #t)))
- (or (eof-object? line)
- (let ((len (length line)))
- (set! line-number (+ line-number 1))
- (if (> len 8)
- (let ((start 0))
- (do ((i 1 (+ i 1)))
- ((>= i len))
- (let ((chr (line i)))
- (if (or (char-whitespace? chr)
- (char=? chr #\)))
- (let* ((name (substring line (+ 1 start) i))
- (name-len (length name)))
- (if (and (or (and (> name-len 4)
- (or (string-ci=? "gtk_" (substring name 0 4))
- (string-ci=? "gdk_" (substring name 0 4))))
- (and (> name-len 6)
- (or (string-ci=? "pango_" (substring name 0 6))
- (string-ci=? "cairo_" (substring name 0 6)))))
- (not (defined? (string->symbol name) *gtk*)))
- (format #t "~A (~A[~D]) is not defined~%" name filename line-number))))
- (if (and (not (char=? chr #\_))
- (not (char-alphabetic? chr))
- (not (char-numeric? chr)))
- (set! start i))))))
- (loop (read-line file #t)))))))))
-
+ (when (and (provided? 'gtk3)
+ (provided? 'xg))
+ (call-with-input-file filename
+ (lambda (file)
+ (let ((line-number 0))
+ (let loop ((line (read-line file #t)))
+ (or (eof-object? line)
+ (let ((len (length line)))
+ (set! line-number (+ line-number 1))
+ (if (> len 8)
+ (let ((start 0))
+ (do ((i 1 (+ i 1)))
+ ((>= i len))
+ (let ((chr (line i)))
+ (if (or (char-whitespace? chr)
+ (char=? chr #\)))
+ (let* ((name (substring line (+ 1 start) i))
+ (name-len (length name)))
+ (if (and (or (and (> name-len 4)
+ (member (substring name 0 4) '("gtk_" "gdk_") string-ci=?))
+ (and (> name-len 6)
+ (member (substring name 0 6) '("pango_" "cairo_") string-ci=?)))
+ (not (defined? (string->symbol name) *gtk*)))
+ (format () "~A (~A[~D]) is not defined~%" name filename line-number))))
+ (if (not (or (char=? chr #\_)
+ (char-alphabetic? chr)
+ (char-numeric? chr)))
+ (set! start i))))))
+ (loop (read-line file #t)))))))))
+
; (if (string=? (substring filename (- (length filename) 3)) "scm")
; (lint filename))
)
@@ -211,11 +207,10 @@
(if start
(let* ((name (substring line start i))
(name-len (length name)))
- ;(format #t "~C: ~A~%" chr name)
(if (and (> name-len 0)
(char-alphabetic? (name 0))
(string=? name last-name))
- (format #t ";~A[~D]: ~A repeats in ~A~%" filename line-number name line))
+ (format () ";~A[~D]: ~A repeats in ~A~%" filename line-number name line))
(set! last-name name)
(set! start #f))))))))
(loop (read-line file #t)))))))))
@@ -233,7 +228,7 @@
#|
-(format #t "--------------------------------------------------------------------------------~%")
+(format () "--------------------------------------------------------------------------------~%")
(let ((png-files (directory->list "/home/bil/cl/pix"))
(baddies ()))
(for-each
@@ -244,9 +239,9 @@
png-files)
(if (not (null? baddies))
(begin
- (format #t "--------------------------------------------------------------------------------~%")
- (format #t ";unused pix/png: ~{~A ~}~%" baddies)
- (format #t "--------------------------------------------------------------------------------~%"))))
+ (format () "--------------------------------------------------------------------------------~%")
+ (format () ";unused pix/png: ~{~A ~}~%" baddies)
+ (format () "--------------------------------------------------------------------------------~%"))))
|#
#|
diff --git a/tools/valcall.scm b/tools/valcall.scm
index aa237d1..0e8a11d 100644
--- a/tools/valcall.scm
+++ b/tools/valcall.scm
@@ -60,8 +60,8 @@
(call-valgrind)
(when (file-exists? "test.table")
- (system "mv test.table old-test.table")
- (load "compare-calls.scm")
- (combine-latest))
+ (system "mv test.table old-test.table"))
+(load "compare-calls.scm")
+(combine-latest)
(exit)
\ No newline at end of file
diff --git a/tools/xgdata.scm b/tools/xgdata.scm
index 6dd207d..f6f8374 100644
--- a/tools/xgdata.scm
+++ b/tools/xgdata.scm
@@ -3173,7 +3173,7 @@
(CFNC "GSList* gtk_text_iter_get_marks GtkTextIter* iter")
(CFNC "GtkTextChildAnchor* gtk_text_iter_get_child_anchor GtkTextIter* iter")
(CFNC "GSList* gtk_text_iter_get_toggled_tags GtkTextIter* iter gboolean toggled_on")
-(CFNC "gboolean gtk_text_iter_begins_tag GtkTextIter* iter GtkTextTag* @tag")
+;;; 3.19.5 (CFNC "gboolean gtk_text_iter_begins_tag GtkTextIter* iter GtkTextTag* @tag")
(CFNC "gboolean gtk_text_iter_ends_tag GtkTextIter* iter GtkTextTag* @tag")
(CFNC "gboolean gtk_text_iter_toggles_tag GtkTextIter* iter GtkTextTag* @tag")
(CFNC "gboolean gtk_text_iter_has_tag GtkTextIter* iter GtkTextTag* tag")
@@ -3293,7 +3293,8 @@
(CFNC "void gtk_text_view_set_cursor_visible GtkTextView* text_view gboolean setting")
(CFNC "gboolean gtk_text_view_get_cursor_visible GtkTextView* text_view")
(CFNC "void gtk_text_view_get_iter_location GtkTextView* text_view GtkTextIter* iter GdkRectangle* location")
-(CFNC "void gtk_text_view_get_iter_at_location GtkTextView* text_view GtkTextIter* iter gint x gint y")
+;;; (CFNC "void gtk_text_view_get_iter_at_location GtkTextView* text_view GtkTextIter* iter gint x gint y")
+;;; gboolean return in 3.20
(CFNC "void gtk_text_view_get_line_yrange GtkTextView* text_view GtkTextIter* iter gint* [y] gint* [height]")
(CFNC "void gtk_text_view_get_line_at_y GtkTextView* text_view GtkTextIter* target_iter gint y gint* [line_top]")
(CFNC "void gtk_text_view_buffer_to_window_coords GtkTextView* text_view GtkTextWindowType win gint buffer_x gint buffer_y gint* [window_x] gint* [window_y]")
@@ -3949,7 +3950,7 @@
(CFNC "void gtk_window_get_size GtkWindow* window gint* [width] gint* [height]")
(CFNC "void gtk_window_move GtkWindow* window gint x gint y")
(CFNC "void gtk_window_get_position GtkWindow* window gint* [root_x] gint* [root_y]")
-(CFNC "gboolean gtk_window_parse_geometry GtkWindow* window gchar* geometry")
+;;; 3.19.8 (CFNC "gboolean gtk_window_parse_geometry GtkWindow* window gchar* geometry")
;;; (CFNC "void gtk_window_reshow_with_initial_size GtkWindow* window")
;;; (CFNC-gtk2 "void gtk_window_remove_embedded_xid GtkWindow* window guint xid")
@@ -4761,7 +4762,7 @@
(CINT "GTK_FILE_CHOOSER_ACTION_OPEN" "GtkFileChooserAction")
(CINT "GTK_FILE_CHOOSER_ACTION_SAVE" "GtkFileChooserAction")
-(CFNC-23-PA "GtkWidget* gtk_file_chooser_dialog_new gchar* title GtkWindow* @parent GtkFileChooserAction action etc #buttons" 0 10 '("gchar*" "int"))
+(CFNC-PA "GtkWidget* gtk_file_chooser_dialog_new gchar* title GtkWindow* @parent GtkFileChooserAction action etc #buttons" 0 10 '("gchar*" "int"))
;;;;(CFNC "GType gtk_file_chooser_dialog_get_type void")
;;;;(CFNC "GType gtk_file_chooser_widget_get_type void")
@@ -4953,7 +4954,7 @@
(CFNC "void gtk_cell_layout_pack_start GtkCellLayout* cell_layout GtkCellRenderer* cell gboolean expand")
(CFNC "void gtk_cell_layout_pack_end GtkCellLayout* cell_layout GtkCellRenderer* cell gboolean expand")
(CFNC "void gtk_cell_layout_clear GtkCellLayout* cell_layout")
-(CFNC-23-PA "void gtk_cell_layout_set_attributes GtkCellLayout* cell_layout GtkCellRenderer* cell etc attributes" 2 10 '("gchar*" "int"))
+(CFNC-PA "void gtk_cell_layout_set_attributes GtkCellLayout* cell_layout GtkCellRenderer* cell etc attributes" 2 10 '("gchar*" "int"))
(CFNC "void gtk_cell_layout_add_attribute GtkCellLayout* cell_layout GtkCellRenderer* cell gchar* attribute gint column")
(CFNC "void gtk_cell_layout_set_cell_data_func GtkCellLayout* cell_layout GtkCellRenderer* cell GtkCellLayoutDataFunc func lambda_data func_info GtkDestroyNotify destroy")
(CFNC "void gtk_cell_layout_clear_attributes GtkCellLayout* cell_layout GtkCellRenderer* cell")
@@ -5579,7 +5580,8 @@
(CFNC "void gtk_list_store_insert_with_valuesv GtkListStore* list_store GtkTreeIter* iter gint position gint* columns GValue* values gint n_values")
;;; (CFNC "void gtk_text_layout_get_iter_at_position GtkTextLayout* layout GtkTextIter* iter gint* [trailing] gint x gint y")
;;; apparently buggy
-(CFNC "void gtk_text_view_get_iter_at_position GtkTextView* text_view GtkTextIter* iter gint* [trailing] gint x gint y")
+;;; (CFNC "void gtk_text_view_get_iter_at_position GtkTextView* text_view GtkTextIter* iter gint* [trailing] gint x gint y")
+;;; gboolean in 3.20
(CFNC "PangoAttribute* pango_attr_size_new_absolute int size")
(CFNC "void pango_font_description_set_absolute_size PangoFontDescription* desc double size")
@@ -7300,8 +7302,8 @@
;;; 2.91.2 (CFNC-2.20 "GdkWindow* gtk_entry_get_icon_window GtkEntry* entry GtkEntryIconPosition icon_pos")
(CFNC-2.20 "void gtk_range_set_slider_size_fixed GtkRange* range gboolean size_fixed")
(CFNC-2.20 "gboolean gtk_range_get_slider_size_fixed GtkRange* range")
-(CFNC-2.20 "void gtk_range_set_min_slider_size GtkRange* range gboolean min_size")
-(CFNC-2.20 "gint gtk_range_get_min_slider_size GtkRange* range")
+;;; 3.20 (CFNC-2.20 "void gtk_range_set_min_slider_size GtkRange* range gboolean min_size")
+;;; 3.20 (CFNC-2.20 "gint gtk_range_get_min_slider_size GtkRange* range")
(CFNC-2.20 "void gtk_range_get_range_rect GtkRange* range GdkRectangle* range_rect")
(CFNC-2.20 "void gtk_range_get_slider_range GtkRange* range gint* [slider_start] gint* [slider_end]")
;;; 3.14.0 (CFNC-2.20 "void gtk_status_icon_set_name GtkStatusIcon* status_icon gchar* name") ; const gchar
@@ -7334,7 +7336,7 @@
;;; 2.99.0 (CFNC-3.0 "void gdk_display_get_device_state GdkDisplay* display GdkDevice* device GdkScreen** [screen] gint* [x] gint* [y] GdkModifierType* [mask]")
;;; 2.99.0 (CFNC-3.0 "GdkWindow* gdk_display_get_window_at_device_position GdkDisplay* display GdkDevice* device gint* [win_x] gint* [win_y]")
;;; 2.91.7 (CFNC-3.0 "void gdk_display_warp_device GdkDisplay* display GdkDevice* device GdkScreen* screen gint x gint y")
-(CFNC-3.0 "GdkDeviceManager* gdk_display_get_device_manager GdkDisplay* display")
+;;; 3.19.5 (CFNC-3.0 "GdkDeviceManager* gdk_display_get_device_manager GdkDisplay* display")
(CFNC-3.0 "void gdk_drag_context_set_device GdkDragContext* context GdkDevice* device")
(CFNC-3.0 "GdkDevice* gdk_drag_context_get_device GdkDragContext* context")
(CFNC-3.0 "GList* gdk_drag_context_list_targets GdkDragContext* context")
@@ -7402,7 +7404,7 @@
;;; 2.90.4
;;; 2.90.6 (CFNC-3.0 "gpointer gdk_image_get_pixels GdkImage* image")
-;(CFNC-3.0 "GdkDevice* gdk_device_manager_get_client_pointer GdkDeviceManager* device_manager")
+;;; 3.19.5 ;(CFNC-3.0 "GdkDevice* gdk_device_manager_get_client_pointer GdkDeviceManager* device_manager")
(CFNC-3.0 "void gtk_accessible_set_widget GtkAccessible* accessible GtkWidget* widget")
(CFNC-3.0 "GdkWindow* gtk_button_get_event_window GtkButton* button")
;;; 3.1.12 (CFNC-3.0 "GtkWidget* gtk_font_selection_dialog_get_font_selection GtkFontSelectionDialog* fsd")
@@ -7698,8 +7700,8 @@
(CFNC-3.0 "void gtk_widget_set_vexpand_set GtkWidget* widget gboolean set")
(CFNC-3.0 "void gtk_widget_queue_compute_expand GtkWidget* widget")
(CFNC-3.0 "gboolean gtk_widget_compute_expand GtkWidget* widget GtkOrientation orientation")
-(CFNC-3.0 "void gtk_window_set_default_geometry GtkWindow* window gint width gint height")
-(CFNC-3.0 "void gtk_window_resize_to_geometry GtkWindow* window gint width gint height")
+;;; 3.19.8 (CFNC-3.0 "void gtk_window_set_default_geometry GtkWindow* window gint width gint height")
+;;; 3.19.4 (CFNC-3.0 "void gtk_window_resize_to_geometry GtkWindow* window gint width gint height")
;;; 3.13.4 (CFNC-3.0 "void gtk_window_set_has_resize_grip GtkWindow* window gboolean value")
;;; 3.13.4 (CFNC-3.0 "gboolean gtk_window_get_has_resize_grip GtkWindow* window")
;;; 3.13.4 (CFNC-3.0 "gboolean gtk_window_resize_grip_is_visible GtkWindow* window")
@@ -7978,7 +7980,7 @@
;;; (CFNC-3.0 "char* gtk_im_multicontext_get_context_id GtkIMMulticontext* context" 'const-return)
;;; (CFNC-3.0 "void gtk_im_multicontext_set_context_id GtkIMMulticontext* context char* context_id" 'const)
-(CINT-3.0 "GTK_FILE_CHOOSER_ERROR" "GtkFileChooserError")
+; -- this is a "quark" apparently (CINT-3.0 "GTK_FILE_CHOOSER_ERROR" "GtkFileChooserError")
(CINT-3.0 "GTK_FILE_CHOOSER_ERROR_NONEXISTENT" "GtkFileChooserError")
(CINT-3.0 "GTK_FILE_CHOOSER_ERROR_BAD_FILENAME" "GtkFileChooserError")
(CINT-3.0 "GTK_FILE_CHOOSER_ERROR_ALREADY_EXISTS" "GtkFileChooserError")
@@ -9222,7 +9224,7 @@
;;; 3.19.1:
(CFNC-3.20 "gboolean gdk_gl_context_is_legacy GdkGLContext* context")
-(CFNC-3.20 "gboolean gdk_rectangle_equal GdkRectangle* rect1 GdkRectangle*rect2" 'const)
+(CFNC-3.20 "gboolean gdk_rectangle_equal GdkRectangle* rect1 GdkRectangle* rect2" 'const)
(CFNC-3.20 "void gtk_application_window_set_help_overlay GtkApplicationWindow* window GtkShortcutsWindow* help_overlay")
;;; (CFNC-3.20 "GtkShortcutsWindow* gtk_application_window_get_help_overlay GtkApplicationWindow* window")
(CFNC-3.20 "void gtk_settings_reset_property GtkSettings* settings gchar* name" 'const)
@@ -9252,3 +9254,133 @@
(CINT-3.20 "GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_RIGHT" "GtkShortcutType")
(CINT-3.20 "GTK_SHORTCUT_GESTURE" "GtkShortcutType")
+;;; 3.19.4:
+
+(CFNC-3.20 "GdkWindow* gdk_drag_context_get_drag_window GdkDragContext* context")
+(CFNC-3.20 "void gtk_popover_set_constrain_to GtkPopover* popover GtkPopoverConstraint constraint")
+(CFNC-3.20 "GtkPopoverConstraint gtk_popover_get_constrain_to GtkPopover* popover")
+;;; 3-19.6 (CINT-3.20 "GTK_STATE_FLAG_DND" "GtkStateFlags")
+(CINT-3.20 "GTK_POPOVER_CONSTRAINT_NONE" "GtkPopoverConstraint")
+(CINT-3.20 "GTK_POPOVER_CONSTRAINT_WINDOW" "GtkPopoverConstraint")
+
+;;; 3.19.5:
+
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_SPLASHSCREEN" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_UTILITY" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_DOCK" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_DESKTOP" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_DROPDOWN_MENU" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_POPUP_MENU" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_TOOLTIP" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_NOTIFICATION" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_COMBO" "GdkWindowTypeHint")
+(CINT-3.20 "GDK_WINDOW_TYPE_HINT_DND" "GdkWindowTypeHint")
+
+(CFNC-3.20 "gboolean gtk_text_iter_starts_tag GtkTextIter* iter GtkTextTag* @tag")
+
+(CCAST-3.20 "GDK_SEAT(object)" "GdkSeat*")
+(CCHK-3.20 "GDK_IS_SEAT(object)" "GdkSeat*")
+
+(CINT-3.20 "GDK_SEAT_CAPABILITY_NONE" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_POINTER" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_TOUCH" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_TABLET_STYLUS" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_KEYBOARD" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_ALL_POINTING" "GdkSeatCapabilities")
+(CINT-3.20 "GDK_SEAT_CAPABILITY_ALL" "GdkSeatCapabilities")
+
+(CFNC-3.20 "GdkSeat* gdk_device_get_seat GdkDevice* device")
+(CFNC-3.20 "GdkSeat* gdk_display_get_default_seat GdkDisplay* display")
+(CFNC-3.20 "GList* gdk_display_list_seats GdkDisplay* display")
+(CFNC-3.20 "GdkDragContext* gdk_drag_begin_from_point GdkWindow* window GdkDevice* device GList* targets gint x_root gint y_root")
+(CFNC-3.20 "void gdk_drag_drop_done GdkDragContext* context gboolean success")
+(CFNC-3.20 "void gdk_drag_context_set_hotspot GdkDragContext* context gint hot_x gint hot_y")
+(CFNC-3.20 "GdkGrabStatus gdk_seat_grab GdkSeat* seat GdkWindow* window GdkSeatCapabilities capabilities gboolean owner_events GdkCursor* cursor const GdkEvent* event GdkSeatGrabPrepareFunc prepare_func lambda_data #prepare_func_data")
+(CFNC-3.20 "void gdk_seat_ungrab GdkSeat* seat")
+(CFNC-3.20 "GdkDisplay* gdk_seat_get_display GdkSeat* seat")
+(CFNC-3.20 "GdkSeatCapabilities gdk_seat_get_capabilities GdkSeat* seat")
+(CFNC-3.20 "GList* gdk_seat_get_slaves GdkSeat* seat GdkSeatCapabilities capabilities")
+(CFNC-3.20 "GdkDevice* gdk_seat_get_pointer GdkSeat* seat")
+(CFNC-3.20 "GdkDevice* gdk_seat_get_keyboard GdkSeat* seat")
+
+
+;;; 3.19.6:
+
+(CINT-3.20 "GTK_STATE_FLAG_DROP_ACTIVE" "GtkStateFlags")
+
+;;; 3.19.7:
+
+(CFNC-3.20 "gboolean gdk_drag_context_manage_dnd GdkDragContext* context GdkWindow* ipc_window GdkDragAction actions")
+(CFNC-3.20 "gboolean gdk_event_is_scroll_stop_event GdkEvent* event" 'const)
+(CFNC-3.20 "void gtk_text_view_reset_cursor_blink GtkTextView* text_view")
+
+;;; 3.19.8:
+
+(CFNC-3.20 "void gtk_render_background_get_clip GtkStyleContext* context gdouble x gdouble y gdouble width gdouble height GdkRectangle* [out_clip]")
+
+
+;;; 3.19.9:
+
+(CSTR-3.20 "GTK_LEVEL_BAR_OFFSET_FULL")
+(CINT-3.20 "GDK_DRAG_CANCEL_NO_TARGET" "GdkDragCancelReason")
+(CINT-3.20 "GDK_DRAG_CANCEL_USER_CANCELLED" "GdkDragCancelReason")
+(CINT-3.20 "GDK_DRAG_CANCEL_ERROR" "GdkDragCancelReason")
+
+(CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_pixel GtkTextLayout* layout GtkTextIter* iter gint x gint y")
+(CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_position GtkTextLayout* layout GtkTextIter* iter gint* [trailing] gint x gint y")
+
+;;; these two used to return void so we do them by hand in makexg.scm
+;;; (CFNC-3.20 "gboolean gtk_text_view_get_iter_at_position GtkTextView* text_view GtkTextIter* iter gint* [trailing] gint x gint y")
+;;; (CFNC-3.20 "gboolean gtk_text_view_get_iter_at_location GtkTextView* text_view GtkTextIter* iter gint x gint y")
+
+
+;;; 3.19.10 -- nothing new
+;;; 3.19.11 -- same
+;;; 3.19.12 -- same
+;;; 3.20.0|1|2|3 -- same
+
+;;; 3.21.1:
+
+(CINT-3.22 "GDK_AXIS_IGNORE" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_X" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_Y" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_PRESSURE" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_XTILT" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_YTILT" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_WHEEL" "GdkAxisUse")
+(CINT-3.22 "GDK_AXIS_LAST" "GdkAxisUse")
+
+(CINT-3.22 "GDK_AXIS_FLAG_X" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_Y" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_PRESSURE" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_XTILT" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_YTILT" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_WHEEL" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_DISTANCE" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_ROTATION" "GdkAxisFlags")
+(CINT-3.22 "GDK_AXIS_FLAG_SLIDER" "GdkAxisFlags")
+
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_UNKNOWN" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_PEN" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_ERASER" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_BRUSH" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_PENCIL" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_AIRBRUSH" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_MOUSE" "GdkDeviceToolType")
+(CINT-3.22 "GDK_DEVICE_TOOL_TYPE_LENS" "GdkDeviceToolType")
+
+(CCAST-3.22 "GDK_DEVICE_TOOL(object)" "GdkDeviceTool*")
+(CCHK-3.22 "GDK_IS_DEVICE_TOOL(object)" "GdkDeviceTool*")
+
+(CFNC-3.22 "GdkAxisFlags gdk_device_get_axes GdkDevice* device")
+(CFNC-3.22 "GdkDeviceTool* gdk_event_get_device_tool GdkEvent* event")
+(CFNC-3.22 "void gdk_event_set_device_tool GdkEvent* event GdkDeviceTool* tool")
+(CFNC-3.22 "int gdk_event_get_scancode GdkEvent* event")
+(CFNC-3.22 "void gdk_gl_context_set_use_es GdkGLContext* context gboolean use_es")
+(CFNC-3.22 "gboolean gdk_gl_context_get_use_es GdkGLContext* context")
+(CFNC-3.22 "PangoContext* gdk_pango_context_get_for_display GdkDisplay* display")
+(CFNC-3.22 "GdkAtom gtk_clipboard_get_selection GtkClipboard* clipboard")
+(CFNC-3.22 "void gtk_gl_area_set_use_es GtkGLArea* area gboolean use_es")
+(CFNC-3.22 "gboolean gtk_gl_area_get_use_es GtkGLArea* area")
+(CFNC-3.22 "guint gdk_device_tool_get_serial GdkDeviceTool* tool")
+
diff --git a/write.scm b/write.scm
index 2cca91f..23f91d0 100644
--- a/write.scm
+++ b/write.scm
@@ -6,61 +6,70 @@
(let ((*pretty-print-length* 100)
(*pretty-print-spacing* 2)
- (*pretty-print-float-format* "~,4F"))
+ (*pretty-print-float-format* "~,4F")
+ (*pretty-print-left-margin* 0))
+ (define (any? f sequence) ; this and every? ought to be built-in!
+ (member #f sequence (lambda (a b) (f b))))
+
(lambda* (obj (port (current-output-port)) (column 0))
-
+
+ (define newlines 0)
+
(define (pretty-print-1 obj port column)
(define (spaces n)
- (write-char #\newline port)
- (do ((i 0 (+ i 1))) ((= i n)) (write-char #\space port)))
-
+ (set! newlines (+ newlines 1))
+ (format port "~%~NC" (+ n *pretty-print-left-margin*) #\space))
+
(define (stacked-list lst col)
- (do ((l1 lst (cdr l1)))
- ((not (pair? l1)))
+ (do ((p lst (cdr p)))
+ ((not (pair? p)))
(let ((added 0))
- (if (not (eq? l1 lst)) (spaces col))
- (let* ((str (object->string (car l1)))
+ (if (not (eq? p lst)) (spaces col))
+ (let* ((str (object->string (car p)))
(len (length str)))
- (if (and (keyword? (car l1))
- (pair? (cdr l1)))
+ (if (and (keyword? (car p))
+ (pair? (cdr p)))
(begin
- (write (car l1) port)
+ (write (car p) port)
(write-char #\space port)
(set! added (+ 1 len))
- (set! l1 (cdr l1))))
- (if (pair? l1)
- (if (and (pair? (car l1))
- (pair? (cdar l1))
- (null? (cddar l1))
+ (set! p (cdr p))))
+ (if (not (pair? p))
+ (format port " . ~S" p)
+ (if (and (pair? (car p))
+ (pair? (cdar p))
+ (null? (cddar p))
(> len (/ *pretty-print-length* 2)))
(begin
- (write-char #\( port)
- (pretty-print-1 (caar l1) port col)
- (spaces (+ col 1))
- (pretty-print-1 (cadar l1) port (+ col 1))
- (write-char #\) port))
- (pretty-print-1 (car l1) port (+ col added)))
- (format port " . ~S" l1)))
- (set! added 0))))
+ (if (eq? (caar p) 'quote)
+ (write-char #\' port)
+ (begin
+ (write-char #\( port)
+ (pretty-print-1 (caar p) port col)
+ (spaces (+ col 1))))
+ (pretty-print-1 (cadar p) port (+ col 1))
+ (if (not (eq? (caar p) 'quote))
+ (write-char #\) port)))
+ (pretty-print-1 (car p) port (+ col added))))))))
(define (stacked-split-list lst col)
- (if (pair? lst)
- (do ((l1 lst (cdr l1)))
- ((not (pair? l1)))
- (if (not (eq? l1 lst)) (spaces col))
+ (if (not (pair? lst))
+ (write lst port)
+ (do ((p lst (cdr p)))
+ ((not (pair? p)))
+ (if (not (eq? p lst)) (spaces col))
(write-char #\( port)
- (if (pair? (car l1))
+ (if (pair? (car p))
(begin
- (write (caar l1) port)
+ (write (caar p) port)
(write-char #\space port)
- (if (and (pair? (cdar l1))
- (symbol? (caar l1)))
- (pretty-print-1 (cadar l1) port (+ col (length (symbol->string (caar l1))) 2))
- (write (cdar l1) port)))
- (write (car l1) port))
- (write-char #\) port))
- (write lst port)))
+ (if (and (pair? (cdar p))
+ (symbol? (caar p)))
+ (pretty-print-1 (cadar p) port (+ col (length (symbol->string (caar p))) 2))
+ (write (cdar p) port)))
+ (write (car p) port))
+ (write-char #\) port))))
(define (messy-number z)
(if (real? z)
@@ -70,7 +79,7 @@
(if (= z pi)
"pi"
(format #f *pretty-print-float-format* z)))
- (format "~A~A~Ai"
+ (format #f "~A~A~Ai"
(messy-number (real-part z))
(if (negative? (imag-part z)) "-" "+")
(messy-number (abs (imag-part z))))))
@@ -86,62 +95,62 @@
(display (messy-number obj) port)))
((pair? obj)
- (let ((cobj (if (symbol? (car obj)) (string->symbol (symbol->string (car obj))) (car obj)))) ; this clears out some optimization confusion
- (case cobj
-
- ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let when unless
- call-with-input-string call-with-input-file call-with-output-file
- with-input-from-file with-input-from-string with-output-to-file)
- (if (or (not (pair? (cdr obj))) ; (when) or (when . #t)
- (not (pair? (cddr obj))))
- (write obj port)
- (begin
- (format port "(~A ~A" (car obj) (cadr obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))))
-
- ((defmacro defmacro*)
- (if (or (not (pair? (cdr obj)))
- (not (pair? (cddr obj))))
- (write obj port)
- (begin
- (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))))
-
- ((define)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(~A ~A " (car obj) (cadr obj))
- (if (pair? (cadr obj))
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
- (begin
- (if (pair? (cddr obj))
- (let ((str (object->string (caddr obj))))
- (if (> (length str) 60)
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (pretty-print-1 (caddr obj) port (+ column *pretty-print-spacing*)))
- (write (caddr obj) port)))
- (write (cddr obj) port))))
- (write-char #\) port))))
-
- ((do)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(do (")
- (if (pair? (cadr obj))
- (stacked-list (cadr obj) (+ column 5)))
- (write-char #\) port)
- (if (pair? (cddr obj))
+ (case (car obj)
+
+ ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let
+ call-with-input-string call-with-input-file call-with-output-file
+ with-input-from-file with-input-from-string with-output-to-file)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
+ (format port "(~A ~A" (car obj) (cadr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))))
+
+ ((defmacro defmacro*)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
+ (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))))
+
+ ((define)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(~A ~A " (car obj) (cadr obj))
+ (if (pair? (cadr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
+ (if (pair? (cddr obj))
+ (let ((str (object->string (caddr obj))))
+ (if (> (length str) 60)
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (pretty-print-1 (caddr obj) port (+ column *pretty-print-spacing*)))
+ (write (caddr obj) port)))
+ (write (cddr obj) port)))
+ (write-char #\) port))))
+
+ ((do)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(do (")
+ (if (pair? (cadr obj))
+ (stacked-list (cadr obj) (+ column 5)))
+ (write-char #\) port)
+ (if (not (pair? (cddr obj)))
+ (write-char #\) port)
+ (begin
+ (spaces (+ column 4))
(let ((end (caddr obj)))
- (spaces (+ column 4))
(if (< (length (object->string end)) (- *pretty-print-length* column))
(write end port)
(begin
@@ -149,101 +158,161 @@
(pretty-print-1 (car end) port (+ column 4))
(spaces (+ column 5))
(stacked-list (cdr end) (+ column 5))
- (write-char #\) port)))
+ (write-char #\) port))))
+ (when (pair? (cdddr obj))
(spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))
- (write-char #\) port)))))
-
- ((cond)
- (format port "(cond ")
- (stacked-list (cdr obj) (+ column 6))
- (write-char #\) port))
-
- ((or and)
- (if (> (length (object->string obj)) 40)
- (begin
- (format port "(~A " (car obj))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj)))))
- (write-char #\) port))
- (write obj port)))
-
- ((case)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(case ~A" (cadr obj)) ; send out the selector
- (do ((lst (cddr obj) (cdr lst)))
- ((not (pair? lst)))
- (spaces (+ column *pretty-print-spacing*))
- (if (not (pair? (car lst)))
- (write (car lst) port)
+ (stacked-list (cdddr obj) (+ column *pretty-print-spacing*)))
+ (write-char #\) port))))))
+
+ ((cond)
+ (format port "(cond ")
+ (do ((lst (cdr obj) (cdr lst)))
+ ((not (pair? lst)))
+ (if (not (eq? lst (cdr obj)))
+ (spaces (+ column 6)))
+ (if (not (pair? (car lst)))
+ (write (car lst) port)
+ (let* ((has=> (and (pair? (cdar lst))
+ (eq? (cadar lst) '=>)))
+ (extras (and (pair? (cdar lst))
+ (pair? (cddar lst))
+ (or (not has=>)
+ (pair? (cdddar lst)))))
+ (too-long (> (length (object->string (cdar lst))) 50)))
+ (write-char #\( port)
+ (let ((oldlines newlines))
+ (pretty-print-1 (caar lst) port (+ column 7))
+ (if (or extras
+ (not (= oldlines newlines))
+ too-long)
+ (spaces (+ column 7))
+ (if (and (pair? (cdar lst))
+ (or (not has=>)
+ (= oldlines newlines)))
+ (write-char #\space port)))
+ (if (and (pair? (cdar lst))
+ (not extras)
+ (not too-long))
(begin
- (write-char #\( port)
- (if (not (pair? (caar lst)))
- (write (caar lst) port)
- (let ((len (length (caar lst))))
- (if (< len 6)
- (write (caar lst) port)
- (let ((p (caar lst)))
- (write-char #\( port)
- (do ((i 0 (+ i 6)))
- ((>= i len))
- (do ((j 0 (+ j 1)))
- ((or (= j 6)
- (null? p))
- (if (pair? p) (spaces (+ column 4))))
- (write (car p) port)
- (set! p (cdr p))
- (if (pair? p) (write-char #\space port))))
- (write-char #\) port)))))
- (if (and (pair? (cdar lst))
- (null? (cddar lst))
- (< (length (object->string (cadar lst))) 60))
- (begin
- (write-char #\space port)
- (write (cadar lst) port))
- (begin
- (spaces (+ column 3))
- (stacked-list (cdar lst) (+ column 3))))
- (write-char #\) port))))
+ (write (cadar lst) port)
+ (when has=>
+ (write-char #\space port)
+ (write (caddar lst) port)))
+ (if (not (null? (cdar lst)))
+ (stacked-list (cdar lst) (+ column 7)))))
(write-char #\) port))))
-
- ((begin call-with-exit call/cc call-with-current-continuation with-baffle with-output-to-string call-with-output-string
- map for-each)
- (format port "(~A" (car obj))
- (if (pair? (cdr obj))
- (begin
+ (write-char #\) port))
+
+ ((or and)
+ (if (> (length (object->string obj)) 40)
+ (begin
+ (format port "(~A " (car obj))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj)))))
+ (write-char #\) port))
+ (write obj port)))
+
+ ((case)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(case ~A" (cadr obj)) ; send out the selector
+ (do ((lst (cddr obj) (cdr lst)))
+ ((not (pair? lst)))
(spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
- (write-char #\) port))
-
- ((dynamic-wind)
- (format port "(dynamic-wind")
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))
-
- ((if)
- (let ((objstr (object->string obj))
- (ifcol (+ column 4)))
- (if (< (length objstr) 40)
- (display objstr port)
- (begin
- (format port "(if ")
- (pretty-print-1 (cadr obj) port ifcol)
- (spaces (+ column 4))
+ (if (not (pair? (car lst)))
+ (write (car lst) port)
+ (begin
+ (write-char #\( port)
+ (if (not (pair? (caar lst)))
+ (write (caar lst) port)
+ (let ((len (length (caar lst))))
+ (if (< len 6)
+ (write (caar lst) port)
+ (let ((p (caar lst)))
+ (write-char #\( port)
+ (do ((i 0 (+ i 6)))
+ ((>= i len))
+ (do ((j 0 (+ j 1)))
+ ((or (= j 6)
+ (null? p))
+ (if (pair? p) (spaces (+ column 4))))
+ (write (car p) port)
+ (set! p (cdr p))
+ (if (pair? p) (write-char #\space port))))
+ (write-char #\) port)))))
+ (if (not (null? (cdar lst))) ; null here is a bug in the input case statement
+ (if (and (pair? (cdar lst))
+ (null? (cddar lst))
+ (< (length (object->string (cadar lst))) 60))
+ (begin
+ (write-char #\space port)
+ (write (cadar lst) port))
+ (begin
+ (spaces (+ column 3))
+ (stacked-list (cdar lst) (+ column 3)))))
+ (write-char #\) port))))
+ (write-char #\) port))))
+
+ ((begin call-with-exit call/cc call-with-current-continuation with-baffle with-output-to-string call-with-output-string)
+ (format port "(~A" (car obj))
+ (if (pair? (cdr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
+ (write-char #\) port))
+
+ ((map for-each)
+ (let* ((objstr (object->string obj))
+ (strlen (length objstr)))
+ (if (< (+ column strlen) *pretty-print-length*)
+ (display objstr port)
+ (begin
+ (format port "(~A" (car obj))
+ (if (pair? (cdr obj))
+ (begin
+ (write-char #\space port)
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
+ (write-char #\) port)))))
+
+ ((dynamic-wind call-with-values)
+ (format port "(~A" (car obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))
+
+ ((if)
+ (let ((objstr (object->string obj))
+ (ifcol (+ column 4)))
+ (if (< (length objstr) 40)
+ (display objstr port)
+ (begin
+ (format port "(if ")
+ (pretty-print-1 (cadr obj) port ifcol)
+ (when (pair? (cddr obj)) ; might be a messed-up if
+ (spaces ifcol)
(pretty-print-1 (caddr obj) port ifcol)
- (if (pair? (cdddr obj))
- (begin
- (spaces (+ column 4))
- (pretty-print-1 (cadddr obj) port ifcol)))
- (write-char #\) port)))))
-
- ((let let* letrec letrec*)
- (if (or (not (pair? (cdr obj)))
- (not (pair? (cddr obj))))
- (write obj port)
+ (when (pair? (cdddr obj))
+ (spaces ifcol)
+ (pretty-print-1 (cadddr obj) port ifcol)))
+ (write-char #\) port)))))
+
+ ((when unless)
+ (let ((objstr (object->string obj)))
+ (if (< (length objstr) 40)
+ (display objstr port)
+ (begin
+ (format port "(~A " (car obj))
+ (pretty-print-1 (cadr obj) port (+ column (if (eq? (car obj) 'when) 6 8)))
+ (spaces (+ column *pretty-print-spacing*))
+ (when (pair? (cddr obj))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
+ (write-char #\) port)))))
+
+ ((let let* letrec letrec*)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
(let ((head-len (length (symbol->string (car obj)))))
(if (symbol? (cadr obj))
(begin
@@ -251,111 +320,125 @@
(if (pair? (cddr obj))
(if (pair? (caddr obj)) ; (let x () ...)
(stacked-split-list (caddr obj) (+ column head-len (length (symbol->string (cadr obj))) 4))
- (write (caddr obj) port))
+ (if (not (null? (caddr obj)))
+ (write (caddr obj) port))) ; () is already being written
(if (not (null? (cddr obj)))
(format port " . ~S" (cddr obj)))))
(begin
(format port "(~A (" (car obj))
(if (pair? (cadr obj))
- (stacked-split-list (cadr obj) (+ column head-len 3)))))
- (write-char #\) port)
- (spaces (+ column *pretty-print-spacing*))
- (if (pair? ((if (symbol? (cadr obj)) cdddr cddr) obj))
- (stacked-list ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*)))
- (write-char #\) port))))
-
- ((inlet)
- (format port "(inlet")
- (if (pair? (cdr obj))
- (do ((lst (cdr obj) (cddr lst)))
- ((or (not (pair? lst))
- (not (pair? (cdr lst)))))
- (spaces (+ column *pretty-print-spacing*))
- (if (pair? (cdr lst))
+ (stacked-split-list (cadr obj) (+ column head-len 3))))))
+ (write-char #\) port)
+ (spaces (+ column *pretty-print-spacing*))
+ (if (pair? ((if (symbol? (cadr obj)) cdddr cddr) obj))
+ (stacked-list ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*)))
+ (write-char #\) port))))
+
+ ((inlet)
+ (format port "(inlet ")
+ (if (pair? (cdr obj))
+ (do ((lst (cdr obj) (cddr lst)))
+ ((not (and (pair? lst)
+ (pair? (cdr lst)))))
+ (if (not (eq? lst (cdr obj)))
+ (spaces (+ column *pretty-print-spacing*)))
+ (if (pair? (cdr lst))
+ (begin
+ (write (car lst) port)
+ (write-char #\space port)
+ (pretty-print-1 (cadr lst) port (+ column *pretty-print-spacing* (length (object->string (car lst))))))
+ (write lst port))))
+ (write-char #\) port))
+
+ ((set!)
+ (let ((str (object->string obj)))
+ (if (<= (length str) 60)
+ (display str port)
+ (let ((settee (object->string (cadr obj))))
+ (format port "(set! ~A" settee)
+ (if (> (length settee) 20)
+ (begin
+ (spaces (+ column 6))
+ (pretty-print-1 (caddr obj) port (+ column 6)))
(begin
- (write (car lst) port)
(write-char #\space port)
- (pretty-print-1 (cadr lst) port (+ column *pretty-print-spacing* (length (object->string (car lst))))))
- (write lst port))))
- (write-char #\) port))
-
- ((set!)
- (let ((str (object->string obj)))
- (if (> (length str) 60)
- (let ((settee (object->string (cadr obj))))
- (format port "(set! ~A" settee)
- (if (> (length settee) 20)
- (begin
- (spaces (+ column 6))
- (pretty-print-1 (caddr obj) port (+ column 6)))
- (begin
- (write-char #\space port)
- (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))
- (write-char #\) port))
- (display str port))))
-
- ((quote)
- (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
- (write obj port)
- (begin
- (write-char #\' port)
- (pretty-print-1 (cadr obj) port column))))
-
- (else
- (let* ((objstr (object->string obj))
- (strlen (length objstr)))
- (if (< (+ column strlen) *pretty-print-length*)
- (display objstr port)
- (let ((lstlen (length obj)))
- (if (or (infinite? lstlen)
- (< lstlen 2))
- (display objstr port)
- (if (and (pair? (car obj))
- (member (caar obj) '(lambda lambda*) eq?))
- (begin
- (write-char #\( port)
- (pretty-print-1 (car obj) port column)
- (spaces (+ column 1))
- (display (cadr obj) port)
- (write-char #\) port))
- (let* ((carstr (object->string (car obj)))
- (carstrlen (length carstr)))
- (if (eq? (car obj) 'quote)
- (write-char #\' port)
- (format port "(~A" carstr))
- (if (any-keyword? (cdr obj))
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*)))
- (let ((line-len (ceiling (/ (- strlen carstrlen) 40)))
- (line-start (+ column *pretty-print-spacing* carstrlen)))
- (if (= lstlen 2)
- (begin
- (write-char #\space port)
- (pretty-print-1 (cadr obj) port line-start))
- (if (< lstlen 5)
- (begin
- (write-char #\space port)
- (stacked-list (cdr obj) line-start))
- (let ((lst (cdr obj)))
- (do ((i 1 (+ i line-len)))
- ((>= i lstlen))
- (do ((k 0 (+ k 1)))
- ((or (null? lst)
- (= k line-len)))
- (let ((str (format #f "~S" (car lst))))
- (if (> (length str) (- *pretty-print-length* line-start))
- (begin
- (if (not (zero? k)) (spaces line-start))
- (pretty-print-1 (car lst) port line-start))
- (begin
- (if (or (not (zero? k)) (= i 1)) (write-char #\space port))
- (display str port))))
- (set! lst (cdr lst)))
- (if (pair? lst)
- (spaces line-start))))))))
- (if (not (eq? (car obj) 'quote))
- (write-char #\) port))))))))))))
+ (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))
+ (write-char #\) port)))))
+
+ ((quote)
+ (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
+ (write obj port)
+ (begin
+ (write-char #\' port)
+ (pretty-print-1 (cadr obj) port column))))
+
+ ((catch)
+ (format port "(~A ~S" catch (cadr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))
+
+ (else
+ (let* ((objstr (object->string obj))
+ (strlen (length objstr)))
+ (if (< (+ column strlen) *pretty-print-length*)
+ (display objstr port)
+ (let ((lstlen (length obj)))
+ (if (or (infinite? lstlen)
+ (< lstlen 2))
+ (display objstr port)
+ (if (and (pair? (car obj))
+ (memq (caar obj) '(lambda lambda* let let* letrec letrec*)))
+ (begin
+ (write-char #\( port)
+ (pretty-print-1 (car obj) port column)
+ (spaces (+ column 1))
+ (stacked-list (cdr obj) (+ column 1)) ; the args?
+ (write-char #\) port))
+ (let* ((carstr (object->string (car obj)))
+ (carstrlen (length carstr)))
+ (if (eq? (car obj) 'quote)
+ (write-char #\' port)
+ (format port "(~A" carstr))
+ (if (any-keyword? (cdr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*)))
+ (let ((line-start (+ column *pretty-print-spacing*
+ (if (or (> carstrlen 16)
+ (pair? (cadr obj)))
+ 0
+ carstrlen))))
+ (if (= lstlen 2)
+ (begin
+ (write-char #\space port)
+ (pretty-print-1 (cadr obj) port line-start))
+ (if (< lstlen 4)
+ (begin
+ (write-char #\space port)
+ (stacked-list (cdr obj) line-start))
+ (let ((obj-start line-start))
+ (do ((lst (cdr obj) (cdr lst)))
+ ((null? lst))
+ (let* ((str (format #f "~S" (car lst)))
+ (strlen1 (length str)))
+ (if (and (> strlen1 (- *pretty-print-length* obj-start))
+ (not (eq? lst (cdr obj))))
+ (begin
+ (set! obj-start (+ line-start 1 strlen1))
+ (spaces line-start)
+ (pretty-print-1 (car lst) port line-start))
+ (begin
+ (set! obj-start (+ obj-start 1 strlen1))
+ (if (> strlen1 40)
+ (begin
+ (spaces line-start)
+ (pretty-print-1 (car lst) port line-start))
+ (begin
+ (write-char #\space port)
+ (display str port))))))))))))
+ (if (not (eq? (car obj) 'quote))
+ (write-char #\) port)))))))))))
(else
(write obj port))))
@@ -364,13 +447,13 @@
(set! port (open-output-string)))
(pretty-print-1 obj port column)
(flush-output-port port)
- (if (boolean? old-port)
+ (if (not (boolean? old-port))
+ (values)
(let ((str (get-output-string port)))
(close-output-port port)
(if (eq? old-port #t)
(display str))
- str)
- (values))))))
+ str))))))
(define (pp obj)
(call-with-output-string
diff --git a/ws.scm b/ws.scm
index 969c359..0b5e3c5 100644
--- a/ws.scm
+++ b/ws.scm
@@ -48,9 +48,7 @@
(for-each
(lambda (a)
(if (not (keyword? a))
- (if (symbol? a)
- (set! arg-names (cons a arg-names))
- (set! arg-names (cons (car a) arg-names)))))
+ (set! arg-names (cons (if (symbol? a) a (car a)) arg-names))))
targs)
(reverse arg-names))))
(if (string? (car body))
@@ -122,28 +120,27 @@
(set! (locsig-type) *clm-locsig-type*)
(set! *mus-array-print-length* *clm-array-print-length*)
(set! *auto-update-interval* 0.0)
- (if (eq? clipped 'unset)
- (if (and (or scaled-by scaled-to)
- (member sample-type (list mus-bfloat mus-lfloat mus-bdouble mus-ldouble)))
- (set! (mus-clipping) #f)
- (set! (mus-clipping) *clm-clipped*))
- (set! (mus-clipping) clipped))
+ (set! (mus-clipping)
+ (if (not (eq? clipped 'unset))
+ clipped
+ (and (not (and (or scaled-by scaled-to)
+ (member sample-type (list mus-bfloat mus-lfloat mus-bdouble mus-ldouble))))
+ *clm-clipped*)))
(set! *clm-srate* srate))
(lambda ()
(if output-to-file
- (begin
- (if continue-old-file
- (begin
- (set! *output* (continue-sample->file output-1))
- (set! *clm-srate* (mus-sound-srate output-1)) ; "srate" arg shadows the generic func
- (let ((ind (find-sound output-1)))
- (if (sound? ind)
- (close-sound ind))))
- (begin
- (if (file-exists? output-1)
- (delete-file output-1))
- (set! *output* (make-sample->file output-1 channels sample-type header-type comment)))))
+ (if continue-old-file
+ (begin
+ (set! *output* (continue-sample->file output-1))
+ (set! *clm-srate* (mus-sound-srate output-1)) ; "srate" arg shadows the generic func
+ (let ((ind (find-sound output-1)))
+ (if (sound? ind)
+ (close-sound ind))))
+ (begin
+ (if (file-exists? output-1)
+ (delete-file output-1))
+ (set! *output* (make-sample->file output-1 channels sample-type header-type comment))))
(begin
(if (and (not continue-old-file)
(vector? output-1))
@@ -152,18 +149,17 @@
(if reverb
(if reverb-to-file
- (begin
- (if continue-old-file
- (set! *reverb* (continue-sample->file reverb-1))
- (begin
- (if (file-exists? reverb-1)
- (delete-file reverb-1))
- (set! *reverb* (make-sample->file reverb-1
- reverb-channels
- (if (mus-header-writable header-type mus-ldouble)
- mus-ldouble
- sample-type)
- header-type)))))
+ (if continue-old-file
+ (set! *reverb* (continue-sample->file reverb-1))
+ (begin
+ (if (file-exists? reverb-1)
+ (delete-file reverb-1))
+ (set! *reverb* (make-sample->file reverb-1
+ reverb-channels
+ (if (mus-header-writable header-type mus-ldouble)
+ mus-ldouble
+ sample-type)
+ header-type))))
(begin
(if (and (not continue-old-file)
(vector? reverb-1))
@@ -171,46 +167,46 @@
(set! *reverb* reverb-1))))
(let ((start (if statistics (get-internal-real-time)))
- (flush-reverb #f)
(cycles 0)
(revmax #f))
- (catch 'mus-error
-
- (lambda ()
- (catch 'with-sound-interrupt
- thunk
- (lambda args
- (snd-print (format #f "with-sound interrupted: ~{~A~^ ~}" (cdr args)))
- (set! flush-reverb #t)
- args)))
-
- (lambda args
- ;; hit mus-error, for example:
- ;; (with-sound () (fm-violin 0 1 440 .1 :amp-env '(0 0 1 1 1 2 3 0)))
-
- ;; user might have listener closed, or no listener so...
- (format #t ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args))
-
- ;; now try to get something to listener, since there may be no stdout
- (snd-print (format #f ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args)))
- (set! flush-reverb #t)))
-
- (if (and reverb
- (not flush-reverb)) ; i.e. not interrupted by error and trying to jump out
- (begin
- (if reverb-to-file
- (mus-close *reverb*))
- (if (and statistics
- (or reverb-to-file
- (vector? reverb-1)))
- (set! revmax (maxamp reverb-1)))
- (if reverb-to-file
- (set! *reverb* (make-file->sample reverb-1)))
- (apply reverb reverb-data) ; here is the reverb call(!)
- (if reverb-to-file
- (mus-close *reverb*))
- (if (and reverb-to-file *clm-delete-reverb*)
- (delete-file reverb-1))))
+ (let ((flush-reverb #f))
+ (catch 'mus-error
+
+ (lambda ()
+ (catch 'with-sound-interrupt
+ thunk
+ (lambda args
+ (snd-print (format #f "with-sound interrupted: ~{~A~^ ~}" (cdr args)))
+ (set! flush-reverb #t)
+ args)))
+
+ (lambda args
+ ;; hit mus-error, for example:
+ ;; (with-sound () (fm-violin 0 1 440 .1 :amp-env '(0 0 1 1 1 2 3 0)))
+
+ ;; user might have listener closed, or no listener so...
+ (format () ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args))
+
+ ;; now try to get something to listener, since there may be no stdout
+ (snd-print (format #f ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args)))
+ (set! flush-reverb #t)))
+
+ (if (and reverb
+ (not flush-reverb)) ; i.e. not interrupted by error and trying to jump out
+ (begin
+ (if reverb-to-file
+ (mus-close *reverb*))
+ (if (and statistics
+ (or reverb-to-file
+ (vector? reverb-1)))
+ (set! revmax (maxamp reverb-1)))
+ (if reverb-to-file
+ (set! *reverb* (make-file->sample reverb-1)))
+ (apply reverb reverb-data) ; here is the reverb call(!)
+ (when reverb-to-file
+ (mus-close *reverb*)
+ (if *clm-delete-reverb*
+ (delete-file reverb-1))))))
(if output-to-file
(mus-close *output*))
@@ -223,12 +219,12 @@
(if (and to-snd output-to-file)
(let ((cur (find-sound output-1)))
(set! cur-sync (and cur (sync cur)))
- (if cur
- (set! snd-output (update-sound cur))
- (if (= header-type mus-raw)
- (set! snd-output (open-raw-sound output-1 channels (floor srate) sample-type))
- ;; open-sound here would either ask for raw settings or use possibly irrelevant defaults
- (set! snd-output (open-sound output-1))))
+ (set! snd-output (if cur
+ (update-sound cur)
+ (if (= header-type mus-raw)
+ (open-raw-sound output-1 channels (floor srate) sample-type)
+ ;; open-sound here would either ask for raw settings or use possibly irrelevant defaults
+ (open-sound output-1))))
(set! (sync snd-output) #t)))
(if statistics
@@ -260,36 +256,41 @@
(if revmax (format #f " rev max: ~,4F~%" revmax) "")
cycles)))
- (if (or scaled-to scaled-by)
- (if output-to-file
- (let* ((scale-output (or snd-output (open-sound output-1)))
- (old-sync (sync scale-output)))
- (set! (sync scale-output) (+ (sync-max) 1)) ; make sure scaling doesn't follow sync
- (if scaled-to
- (scale-to scaled-to scale-output)
- (scale-by scaled-by scale-output))
- (set! (sync scale-output) old-sync)
- (save-sound scale-output)
- (if (not to-snd)
- (close-sound scale-output)))
- (if (float-vector? output-1)
- (if scaled-to
- (let ((pk (float-vector-peak output-1)))
- (if (> pk 0.0)
- (float-vector-scale! output-1 (/ scaled-to pk))))
- (float-vector-scale! output-1 scaled-by))
- (if (vector? output-1)
- (if scaled-to
- (let ((pk (maxamp output-1)))
- (if (> pk 0.0)
- (let ((scl (/ scaled-to pk)))
- (do ((i 0 (+ i 1)))
- ((= i (length output-1)))
- (set! (output-1 i) (* scl (output-1 i)))))))
- (do ((i 0 (+ i 1)))
- ((= i (length output-1)))
- (set! (output-1 i) (* scaled-by (output-1 i)))))))))
-
+ (when (or scaled-to scaled-by)
+ (cond (output-to-file
+ (let* ((scale-output (or snd-output (open-sound output-1)))
+ (old-sync (sync scale-output)))
+ (set! (sync scale-output) (+ (sync-max) 1)) ; make sure scaling doesn't follow sync
+ (if scaled-to
+ (scale-to scaled-to scale-output)
+ (scale-by scaled-by scale-output))
+ (set! (sync scale-output) old-sync)
+ (save-sound scale-output)
+ (if (not to-snd)
+ (close-sound scale-output))))
+
+ ((float-vector? output-1)
+ (if scaled-to
+ (let ((pk (float-vector-peak output-1)))
+ (if (> pk 0.0)
+ (float-vector-scale! output-1 (/ scaled-to pk))))
+ (float-vector-scale! output-1 scaled-by)))
+
+ ((not (vector? output-1)))
+
+ (scaled-to
+ (let ((pk (maxamp output-1)))
+ (if (> pk 0.0)
+ (let ((scl (/ scaled-to pk)))
+ (do ((i 0 (+ i 1)))
+ ((= i (length output-1)))
+ (set! (output-1 i) (* scl (output-1 i))))))))
+
+ (else
+ (do ((i 0 (+ i 1)))
+ ((= i (length output-1)))
+ (set! (output-1 i) (* scaled-by (output-1 i)))))))
+
(if (and play output-to-file)
(if to-snd
(if *clm-player*
@@ -377,10 +378,10 @@
(define (with-mixed-sound-mix-info id snd)
- (define (find-if pred l)
- (cond ((null? l) #f)
- ((pred (car l)) (car l))
- (else (find-if pred (cdr l)))))
+ (define (find-if pred lst)
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (find-if pred (cdr lst)))))
(let ((all-info (sound-property 'with-mixed-sound-info snd)))
;; each entry is '(mx-id beg chans note)
@@ -484,12 +485,12 @@
(let ((info (with-mixed-sound-mix-info id snd)))
(if info
(let ((call (cadddr info)))
- (if (not (= (cadr info) (mix-position id)))
- (format oput " (~A ~,3F~{ ~A~})~%"
- (car call)
- (/ (mix-position id) (* 1.0 (srate snd)))
- (cddr call))
- (format oput " ~A~%" call)))
+ (format oput (if (= (cadr info) (mix-position id))
+ (values " ~A~%" call)
+ (values " (~A ~,3F~{ ~A~})~%"
+ (car call)
+ (/ (mix-position id) (* 1.0 (srate snd)))
+ (cddr call)))))
(status-report "can't find note associated with mix ~A" id))))
cur-mixes)
(format oput ")~%")
@@ -632,31 +633,33 @@
start)))
(define (finish-with-sound wsd)
- (if (eq? (car wsd) 'with-sound-data)
+ (if (not (eq? (car wsd) 'with-sound-data))
+ (error 'wrong-type-arg (list "finish-with-sound" wsd))
(let ((cycles 0)
(output (wsd 1))
- (reverb (wsd 2))
- (revfile (wsd 3))
(old-srate (wsd 4))
(statistics (wsd 5))
(to-snd (wsd 6))
(scaled-to (wsd 7))
(scaled-by (wsd 8))
(play (wsd 9))
- (reverb-data (wsd 10))
(start (wsd 11)))
- (if reverb
- (begin
- (mus-close *reverb*)
- (if (string? revfile)
- (set! *reverb* (make-file->sample revfile))
- (set! *reverb* revfile))
- (apply reverb reverb-data)
- (mus-close *reverb*)))
+ (let ((reverb (wsd 2))
+ (revfile (wsd 3))
+ (reverb-data (wsd 10)))
+ (if reverb
+ (begin
+ (mus-close *reverb*)
+ (set! *reverb* (if (string? revfile)
+ (make-file->sample revfile)
+ revfile))
+ (apply reverb reverb-data)
+ (mus-close *reverb*))))
+
(if (mus-output? *output*)
(mus-close *output*))
-
+
(if statistics
(set! cycles (/ (- (get-internal-real-time) start) 100)))
(if (and to-snd (string? output))
@@ -678,9 +681,7 @@
(if play (*default-player* snd-output))
(update-time-graph snd-output)))
(set! *clm-srate* old-srate)
- output)
- (error 'wrong-type-arg
- (list "finish-with-sound" wsd))))
+ output)))
(define wsdat-play ; for cm
@@ -717,20 +718,21 @@
(format fd " (set! *clm-header-type* ~A)))~%" (mus-header-type->string *clm-header-type*))
(close-appending fd))))))
-(if (not (member ws-save-state (hook-functions after-save-state-hook) eq?))
+(if (not (memq ws-save-state (hook-functions after-save-state-hook)))
(set! (hook-functions after-save-state-hook) (list ws-save-state)))
;;; -------- ->frequency --------
(define ->frequency
- (let ((main-pitch (/ 440.0 (expt 2.0 (/ 57 12)))) ; a4 = 440Hz is pitch 57 in our numbering
- (last-octave 0) ; octave number can be omitted
+ (let ((main-pitch (/ 440.0 (expt 2.0 19/4))) ;(/ 57 12) ; a4 = 440Hz is pitch 57 in our numbering
+ (last-octave 0) ; octave number can be omitted
(ratios (vector 1.0 256/243 9/8 32/27 81/64 4/3 1024/729 3/2 128/81 27/16 16/9 243/128 2.0))
(documentation "(->frequency pitch pythagorean) returns the frequency (Hz) of the 'pitch', a CLM/CM style note name as a \
symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small-integer ratios, rather than equal-tempered tuning."))
(lambda* (pitch pythagorean) ; pitch can be pitch name or actual frequency
- (if (symbol? pitch)
+ (if (not (symbol? pitch))
+ pitch
(let* ((name (string-downcase (symbol->string pitch)))
(base-char (name 0))
(sign-char (and (> (length name) 1)
@@ -749,10 +751,9 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(base-pitch (+ sign (case base ((0) 0) ((1) 2) ((2) 4) ((3) 5) ((4) 7) ((5) 9) ((6) 11))))
(et-pitch (+ base-pitch (* 12 octave))))
(set! last-octave octave)
- (if pythagorean
- (* main-pitch (expt 2 octave) (ratios base-pitch))
- (* main-pitch (expt 2.0 (/ et-pitch 12)))))
- pitch))))
+ (* main-pitch (if pythagorean
+ (* (expt 2 octave) (ratios base-pitch))
+ (expt 2.0 (/ et-pitch 12)))))))))
;;; -------- ->sample --------
@@ -772,18 +773,18 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(define-macro (defgenerator struct-name . fields)
(define (list->bindings lst)
- (let ((len (length lst)))
- (let ((nlst (make-list (* len 2))))
- (do ((old lst (cdr old))
- (nsym nlst (cddr nsym)))
- ((null? old) nlst)
- (if (pair? (car old))
- (begin
- (set-car! (cdr nsym) (caar old))
- (set-car! nsym (list 'quote (caar old))))
- (begin
- (set-car! (cdr nsym) (car old))
- (set-car! nsym (list 'quote (car old)))))))))
+ (let* ((len (length lst))
+ (nlst (make-list (* len 2))))
+ (do ((old lst (cdr old))
+ (nsym nlst (cddr nsym)))
+ ((null? old) nlst)
+ (if (pair? (car old))
+ (begin
+ (list-set! nsym 1 (caar old))
+ (list-set! nsym 0 (list 'quote (caar old))))
+ (begin
+ (list-set! nsym 1 (car old))
+ (list-set! nsym 0 (list 'quote (car old))))))))
(let* ((name (if (pair? struct-name)
(car struct-name)
@@ -907,9 +908,9 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(let ((old-output *output*))
(dynamic-wind
(lambda ()
- (if (string? output)
- (set! *output* (make-sample->file output channels sample-type header-type "with-simple-sound output"))
- (set! *output* output)))
+ (set! *output* (if (string? output)
+ (make-sample->file output channels sample-type header-type "with-simple-sound output")
+ output)))
(lambda ()
(thunk)
output)
diff --git a/xen.c b/xen.c
index 1ba78ba..1b001f3 100644
--- a/xen.c
+++ b/xen.c
@@ -1282,6 +1282,10 @@ void xen_initialize(void)
#if HAVE_SCHEME
#include "s7.h"
+#if ENABLE_WEBSERVER
+ #include "s7webserver/s7webserver.h"
+#endif
+
s7_scheme *s7;
Xen xen_false, xen_true, xen_nil, xen_undefined, xen_zero;
@@ -1643,6 +1647,17 @@ Xen_wrap_1_arg(g_ftell_w, g_ftell)
Xen_wrap_no_args(g_gc_off_w, g_gc_off)
Xen_wrap_no_args(g_gc_on_w, g_gc_on)
+#if ENABLE_WEBSERVER
+ #if USE_MOTIF
+ #include "snd.h"
+ static idle_func_t called_periodically(any_pointer_t pet)
+ {
+ s7webserver_call_very_often();
+ return(BACKGROUND_CONTINUE);
+ }
+ #endif
+#endif
+
s7_scheme *s7_xen_initialize(s7_scheme *sc)
{
@@ -1655,6 +1670,18 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
fprintf(stderr, "Can't initialize s7!\n");
return(NULL);
}
+#if ENABLE_WEBSERVER
+ {
+ s7webserver_t *s7webserver;
+ s7webserver = s7webserver_create(s7, 6080, true);
+ if (!s7webserver)
+ fprintf(stderr, "Unable to start web server. Port 6080 may be in use\n");
+ else fprintf(stdout, "Started s7 webserver at port %d\n", s7webserver_get_portnumber(s7webserver));
+#if USE_MOTIF
+ BACKGROUND_ADD(called_periodically, NULL);
+#endif
+ }
+#endif
}
else s7 = sc;
diff --git a/xg.c b/xg.c
index 64cbd48..b2ee3c4 100644
--- a/xg.c
+++ b/xg.c
@@ -25,6 +25,8 @@
*
* HISTORY:
*
+ * 17-Mar-16: gtk_enum_t for better signature checks.
+ * --------
* 29-Oct: removed ->string.
* 21-Aug-15: procedure-signature changes.
* --------
@@ -198,7 +200,7 @@ static void define_xm_obj(void)
#define Xg_field_pre "F"
#endif
-static Xen xg_GtkAllocation_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkSearchEntry__symbol, xg_GtkPopoverMenu__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkPropagationPhase_symbol, xg_GtkEventController__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_GtkPlacesSidebar__symbol, xg_GtkPlacesOpenFlags_symbol, xg_GtkBaselinePosition_symbol, xg_GdkFullscreenMode_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_GdkScreen___symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GtkInvisible__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_GtkContainerClass__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_GdkDeviceManager__symbol, xg_GtkAccessible__symbol, xg_GdkModifierType__symbol, xg_GtkToolPaletteDragTargets_symbol, xg_GtkToolItemGroup__symbol, xg_GtkToolPalette__symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GIcon__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__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_GtkPrintOperationPreview__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_GtkTextBufferDeserializeFunc_symbol, xg_GtkTextBufferSerializeFunc_symbol, xg_time_t_symbol, xg_GtkRecentChooserMenu__symbol, xg_GtkRecentManager__symbol, xg_GtkRecentFilter__symbol, xg_GtkRecentSortFunc_symbol, xg_GtkRecentSortType_symbol, xg_GtkRecentChooser__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkSensitivityType_symbol, xg_GtkClipboardRichTextReceivedFunc_symbol, xg_GtkMenuBar__symbol, xg_GtkPackDirection_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkClipboardImageReceivedFunc_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_GtkClipboardTargetsReceivedFunc_symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__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_GtkEventBox__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkScreen__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_GdkGravity_symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkAllocation__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_GtkTextAttributes__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_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_GtkMenuItem__symbol, xg_GtkMenuPositionFunc_symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_GtkLayout__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_PangoLayout__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_GtkTargetList__symbol, xg_GtkDestDefaults_symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkClipboardTextReceivedFunc_symbol, xg_GtkClipboardReceivedFunc_symbol, xg_GtkClipboardClearFunc_symbol, xg_GtkClipboardGetFunc_symbol, xg_GtkTargetEntry__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_GtkPackType_symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkButtonBox__symbol, xg_GtkButtonBoxStyle_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_GTimeVal__symbol, xg_GdkPixbufAnimationIter__symbol, xg_GdkPixbufAnimation__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_int_symbol, xg_GdkColorspace_symbol, xg_GdkWindowTypeHint_symbol, xg_GdkWindowHints_symbol, xg_GdkGeometry__symbol, xg_GdkWindowEdge_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkEventMask_symbol, xg_GdkWindowState_symbol, xg_GdkFilterFunc_symbol, xg_GdkWindowType_symbol, xg_GdkWindowAttr__symbol, xg_GdkVisualType__symbol, xg_gint__symbol, xg_GdkVisualType_symbol, xg_GdkPropMode_symbol, xg_guchar__symbol, xg_PangoContext__symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_char__symbol, xg_gchar___symbol, xg_GdkEventFunc_symbol, xg_gdouble_symbol, xg_GList__symbol, xg_GdkWindow__symbol, xg_guint32_symbol, xg_GdkDragAction_symbol, xg_GdkDragContext__symbol, xg_GdkCursorType_symbol, xg_GdkDisplay__symbol, xg_GdkCursor__symbol, xg_GdkVisual__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_gunichar__symbol, xg_void_symbol, xg_GtkRecentInfo__symbol, xg_gsize_symbol, xg_guint8__symbol, xg_GdkAtom_symbol, xg_GLogLevelFlags_symbol, xg_GdkPixbuf__symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GdkAtom__symbol, xg_GtkSelectionData__symbol, xg_GtkClipboard__symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_gboolean_symbol, xg_gint_symbol, xg_GtkMenu__symbol, xg_GdkXEvent__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_idler_symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingArea__symbol, xg_GtkScrollbar__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventScroll__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_GtkRecentChooserDialog__symbol, xg_GtkRecentChooserWidget__symbol, xg_GtkCellRendererSpinner__symbol, xg_gboolean__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorChooserWidget__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__symbol;
+static Xen xg_GdkDeviceTool__symbol, xg_GdkAxisFlags_symbol, xg_GtkTextLayout__symbol, xg_GdkRectangle_symbol, xg_prepare_func_symbol, xg_event_symbol, xg_const_symbol, xg_GdkSeatCapabilities_symbol, xg_GdkGrabStatus_symbol, xg_GtkPopoverConstraint_symbol, xg_GtkAllocation_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkSearchEntry__symbol, xg_GtkPopoverMenu__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkPropagationPhase_symbol, xg_GtkEventController__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_GtkPlacesSidebar__symbol, xg_GtkPlacesOpenFlags_symbol, xg_GtkBaselinePosition_symbol, xg_GdkFullscreenMode_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_GdkScreen___symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GtkInvisible__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_GtkContainerClass__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_GtkToolPaletteDragTargets_symbol, xg_GtkToolItemGroup__symbol, xg_GtkToolPalette__symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GIcon__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__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_GtkPrintOperationPreview__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_GtkTextBufferDeserializeFunc_symbol, xg_GtkTextBufferSerializeFunc_symbol, xg_time_t_symbol, xg_GtkRecentChooserMenu__symbol, xg_GtkRecentManager__symbol, xg_GtkRecentFilter__symbol, xg_GtkRecentSortFunc_symbol, xg_GtkRecentSortType_symbol, xg_GtkRecentChooser__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkSensitivityType_symbol, xg_GtkClipboardRichTextReceivedFunc_symbol, xg_GtkMenuBar__symbol, xg_GtkPackDirection_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkClipboardImageReceivedFunc_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_GtkClipboardTargetsReceivedFunc_symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__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_GtkEventBox__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkScreen__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_GdkGravity_symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkAllocation__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_GtkTextAttributes__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_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_GtkMenuItem__symbol, xg_GtkMenuPositionFunc_symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_GtkLayout__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_PangoLayout__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_GtkTargetList__symbol, xg_GtkDestDefaults_symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkClipboardTextReceivedFunc_symbol, xg_GtkClipboardReceivedFunc_symbol, xg_GtkClipboardClearFunc_symbol, xg_GtkClipboardGetFunc_symbol, xg_GtkTargetEntry__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_GtkPackType_symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkButtonBox__symbol, xg_GtkButtonBoxStyle_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_GTimeVal__symbol, xg_GdkPixbufAnimationIter__symbol, xg_GdkPixbufAnimation__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_int_symbol, xg_GdkColorspace_symbol, xg_GdkWindowTypeHint_symbol, xg_GdkWindowHints_symbol, xg_GdkGeometry__symbol, xg_GdkWindowEdge_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkEventMask_symbol, xg_GdkWindowState_symbol, xg_GdkFilterFunc_symbol, xg_GdkWindowType_symbol, xg_GdkWindowAttr__symbol, xg_GdkVisualType__symbol, xg_gint__symbol, xg_GdkVisualType_symbol, xg_GdkPropMode_symbol, xg_guchar__symbol, xg_PangoContext__symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_char__symbol, xg_gchar___symbol, xg_GdkEventFunc_symbol, xg_gdouble_symbol, xg_GList__symbol, xg_guint32_symbol, xg_GdkDragAction_symbol, xg_GdkDragContext__symbol, xg_GdkCursorType_symbol, xg_GdkDisplay__symbol, xg_GdkCursor__symbol, xg_GdkVisual__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_gunichar__symbol, xg_void_symbol, xg_GdkWindow__symbol, xg_GdkSeat__symbol, xg_GtkRecentInfo__symbol, xg_gsize_symbol, xg_guint8__symbol, xg_GdkAtom_symbol, xg_GLogLevelFlags_symbol, xg_GdkPixbuf__symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GdkAtom__symbol, xg_GtkSelectionData__symbol, xg_GtkClipboard__symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_gboolean_symbol, xg_gint_symbol, xg_GtkMenu__symbol, xg_GdkXEvent__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_idler_symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingArea__symbol, xg_GtkScrollbar__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventScroll__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_GtkRecentChooserDialog__symbol, xg_GtkRecentChooserWidget__symbol, xg_GtkCellRendererSpinner__symbol, xg_gboolean__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorChooserWidget__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__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))
@@ -266,6 +268,7 @@ static Xen xg_GtkAllocation_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSi
#define Xen_is_GtkTreeViewSearchPositionFunc(Arg) Xen_is_false(Arg) || (Xen_is_procedure(Arg) && (Xen_is_aritable(Arg, 3)))
#define Xen_is_GtkAssistantPageFunc(Arg) Xen_is_false(Arg) || (Xen_is_procedure(Arg) && (Xen_is_aritable(Arg, 2)))
#define Xen_is_GtkRecentSortFunc(Arg) Xen_is_false(Arg) || (Xen_is_procedure(Arg) && (Xen_is_aritable(Arg, 3)))
+#define Xen_is_GdkSeatGrabPrepareFunc(Arg) Xen_is_false(Arg) || (Xen_is_procedure(Arg) && (Xen_is_aritable(Arg, 3)))
#define Xen_is_GCallback(Arg) (Xen_is_procedure(Arg) && ((Xen_is_aritable(Arg, 2)) || (Xen_is_aritable(Arg, 3)) || (Xen_is_aritable(Arg, 4))))
#define Xen_to_C_lambda3(Arg) Xen_is_false(Arg) ? NULL : gxg_find_func
#define Xen_to_C_GtkCallback(Arg) Xen_is_false(Arg) ? NULL : gxg_func2
@@ -300,6 +303,7 @@ static Xen xg_GtkAllocation_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSi
#define Xen_to_C_GtkTreeViewSearchPositionFunc(Arg) Xen_is_false(Arg) ? NULL : gxg_search_position
#define Xen_to_C_GtkAssistantPageFunc(Arg) Xen_is_false(Arg) ? NULL : gxg_page_func
#define Xen_to_C_GtkRecentSortFunc(Arg) Xen_is_false(Arg) ? NULL : gxg_recent_sort
+#define Xen_to_C_GdkSeatGrabPrepareFunc(Arg) Xen_is_false(Arg) ? NULL : gxg_prepare_func
#define Xen_to_C_GCallback(Arg) ((Xen_is_aritable(Arg, 4)) ? (GCallback)gxg_func4 : ((Xen_is_aritable(Arg, 3)) ? (GCallback)gxg_func3 : (GCallback)gxg_func2))
#define Xen_to_C_lambda_data(Arg) (gpointer)gxg_ptr
#define Xen_is_lambda_data(Arg) 1
@@ -420,7 +424,6 @@ Xm_type_Ptr(GdkDragContext_, GdkDragContext*)
#define C_to_Xen_guint32(Arg) C_ulong_to_Xen_ulong(Arg)
#define Xen_to_C_guint32(Arg) (guint32)(Xen_ulong_to_C_ulong(Arg))
#define Xen_is_guint32(Arg) Xen_is_ulong(Arg)
-Xm_type_Ptr(GdkWindow_, GdkWindow*)
Xm_type_Ptr(GList_, GList*)
#define C_to_Xen_gdouble(Arg) C_double_to_Xen_real(Arg)
#define Xen_to_C_gdouble(Arg) (gdouble)(Xen_real_to_C_double(Arg))
@@ -441,6 +444,7 @@ Xm_type_Ptr(PangoContext_, PangoContext*)
#define Xen_is_guchar_(Arg) Xen_is_string(Arg)
#define Xen_to_C_GdkPropMode(Arg) (GdkPropMode)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkPropMode(Arg) Xen_is_integer(Arg)
+Xm_type_Ptr(GdkWindow_, GdkWindow*)
#define C_to_Xen_GdkVisualType(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GdkVisualType(Arg) (GdkVisualType)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkVisualType(Arg) Xen_is_integer(Arg)
@@ -819,7 +823,6 @@ Xm_type_Ptr(GtkToolItemGroup_, GtkToolItemGroup*)
#if GTK_CHECK_VERSION(3, 0, 0)
Xm_type_Ptr_1(GdkModifierType_, GdkModifierType*)
Xm_type_Ptr_1(GtkAccessible_, GtkAccessible*)
-Xm_type_Ptr_2(GdkDeviceManager_, GdkDeviceManager*)
Xm_type_Ptr(GdkDevice_, GdkDevice*)
Xm_type_Ptr_1(GtkMessageDialog_, GtkMessageDialog*)
Xm_type_Ptr(cairo_region_t_, cairo_region_t*)
@@ -941,8 +944,29 @@ Xm_type_Ptr_1(GtkStackSidebar_, GtkStackSidebar*)
#endif
#if GTK_CHECK_VERSION(3, 20, 0)
+Xm_type_Ptr(GdkSeat_, GdkSeat*)
+Xm_type_Ptr(GdkWindow_, GdkWindow*)
Xm_type_Ptr(GtkShortcutsWindow_, GtkShortcutsWindow*)
Xm_type(GtkAllocation, GtkAllocation)
+#define C_to_Xen_GtkPopoverConstraint(Arg) C_int_to_Xen_integer(Arg)
+#define Xen_to_C_GtkPopoverConstraint(Arg) (GtkPopoverConstraint)(Xen_integer_to_C_int(Arg))
+#define Xen_is_GtkPopoverConstraint(Arg) Xen_is_integer(Arg)
+#define C_to_Xen_GdkGrabStatus(Arg) C_int_to_Xen_integer(Arg)
+#define C_to_Xen_GdkSeatCapabilities(Arg) C_int_to_Xen_integer(Arg)
+#define Xen_to_C_GdkSeatCapabilities(Arg) (GdkSeatCapabilities)(Xen_integer_to_C_int(Arg))
+#define Xen_is_GdkSeatCapabilities(Arg) Xen_is_integer(Arg)
+Xm_type(const, const)
+Xm_type(event, event)
+Xm_type(prepare_func, prepare_func)
+Xm_type(GdkRectangle, GdkRectangle)
+Xm_type_Ptr(GtkTextLayout_, GtkTextLayout*)
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+#define C_to_Xen_GdkAxisFlags(Arg) C_int_to_Xen_integer(Arg)
+#define Xen_to_C_GdkAxisFlags(Arg) (GdkAxisFlags)(Xen_integer_to_C_int(Arg))
+#define Xen_is_GdkAxisFlags(Arg) Xen_is_integer(Arg)
+Xm_type_Ptr(GdkDeviceTool_, GdkDeviceTool*)
#endif
Xm_type_Ptr(cairo_surface_t_, cairo_surface_t*)
@@ -1425,6 +1449,18 @@ static gint gxg_recent_sort(GtkRecentInfo* a, GtkRecentInfo* b, gpointer func_in
__func__)));
}
+#if GTK_CHECK_VERSION(3, 20, 0)
+static void gxg_prepare_func(GdkSeat* seat, GdkWindow* window, gpointer func_info)
+{
+ if (!Xen_is_list((Xen)func_info)) return;
+ Xen_call_with_3_args(Xen_car((Xen)func_info),
+ C_to_Xen_GdkSeat_(seat),
+ C_to_Xen_GdkWindow_(window),
+ Xen_cadr((Xen)func_info),
+ __func__);
+}
+#endif
+
static gboolean gxg_func3(GtkWidget *w, GdkEventAny *ev, gpointer data)
{
@@ -8761,14 +8797,6 @@ gboolean toggled_on)"
return(C_to_Xen_GSList_(gtk_text_iter_get_toggled_tags(Xen_to_C_GtkTextIter_(iter), Xen_to_C_gboolean(toggled_on))));
}
-static Xen gxg_gtk_text_iter_begins_tag(Xen iter, Xen tag)
-{
- #define H_gtk_text_iter_begins_tag "gboolean gtk_text_iter_begins_tag(GtkTextIter* iter, GtkTextTag* tag)"
- Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 1, "gtk_text_iter_begins_tag", "GtkTextIter*");
- Xen_check_type(Xen_is_GtkTextTag_(tag) || Xen_is_false(tag), tag, 2, "gtk_text_iter_begins_tag", "GtkTextTag*");
- return(C_to_Xen_gboolean(gtk_text_iter_begins_tag(Xen_to_C_GtkTextIter_(iter), Xen_to_C_GtkTextTag_(tag))));
-}
-
static Xen gxg_gtk_text_iter_ends_tag(Xen iter, Xen tag)
{
#define H_gtk_text_iter_ends_tag "gboolean gtk_text_iter_ends_tag(GtkTextIter* iter, GtkTextTag* tag)"
@@ -9565,18 +9593,6 @@ GtkTextIter* iter, GdkRectangle* location)"
return(Xen_false);
}
-static Xen gxg_gtk_text_view_get_iter_at_location(Xen text_view, Xen iter, Xen x, Xen y)
-{
- #define H_gtk_text_view_get_iter_at_location "void gtk_text_view_get_iter_at_location(GtkTextView* text_view, \
-GtkTextIter* iter, gint x, gint y)"
- Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, "gtk_text_view_get_iter_at_location", "GtkTextView*");
- Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_view_get_iter_at_location", "GtkTextIter*");
- Xen_check_type(Xen_is_gint(x), x, 3, "gtk_text_view_get_iter_at_location", "gint");
- Xen_check_type(Xen_is_gint(y), y, 4, "gtk_text_view_get_iter_at_location", "gint");
- gtk_text_view_get_iter_at_location(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), Xen_to_C_gint(x), Xen_to_C_gint(y));
- return(Xen_false);
-}
-
static Xen gxg_gtk_text_view_get_line_yrange(Xen text_view, Xen iter, Xen ignore_y, Xen ignore_height)
{
#define H_gtk_text_view_get_line_yrange "void gtk_text_view_get_line_yrange(GtkTextView* text_view, \
@@ -13140,14 +13156,6 @@ gint* [root_y])"
return(Xen_list_2(C_to_Xen_gint(ref_root_x), C_to_Xen_gint(ref_root_y)));
}
-static Xen gxg_gtk_window_parse_geometry(Xen window, Xen geometry)
-{
- #define H_gtk_window_parse_geometry "gboolean gtk_window_parse_geometry(GtkWindow* window, gchar* geometry)"
- Xen_check_type(Xen_is_GtkWindow_(window), window, 1, "gtk_window_parse_geometry", "GtkWindow*");
- Xen_check_type(Xen_is_gchar_(geometry), geometry, 2, "gtk_window_parse_geometry", "gchar*");
- return(C_to_Xen_gboolean(gtk_window_parse_geometry(Xen_to_C_GtkWindow_(window), Xen_to_C_gchar_(geometry))));
-}
-
static Xen gxg_pango_color_copy(Xen src)
{
#define H_pango_color_copy "PangoColor* pango_color_copy(PangoColor* src)"
@@ -19265,20 +19273,6 @@ GtkTreeIter* iter, gint position, gint* columns, GValue* values, gint n_values)"
return(Xen_false);
}
-static Xen gxg_gtk_text_view_get_iter_at_position(Xen text_view, Xen iter, Xen ignore_trailing, Xen x, Xen y)
-{
- #define H_gtk_text_view_get_iter_at_position "void gtk_text_view_get_iter_at_position(GtkTextView* text_view, \
-GtkTextIter* iter, gint* [trailing], gint x, gint y)"
- gint ref_trailing;
- Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, "gtk_text_view_get_iter_at_position", "GtkTextView*");
- Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_view_get_iter_at_position", "GtkTextIter*");
- Xen_check_type(Xen_is_gint(x), x, 4, "gtk_text_view_get_iter_at_position", "gint");
- Xen_check_type(Xen_is_gint(y), y, 5, "gtk_text_view_get_iter_at_position", "gint");
- gtk_text_view_get_iter_at_position(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), &ref_trailing, Xen_to_C_gint(x),
- Xen_to_C_gint(y));
- return(Xen_list_1(C_to_Xen_gint(ref_trailing)));
-}
-
static Xen gxg_pango_attr_size_new_absolute(Xen size)
{
#define H_pango_attr_size_new_absolute "PangoAttribute* pango_attr_size_new_absolute(int size)"
@@ -24902,22 +24896,6 @@ static Xen gxg_gtk_range_get_slider_size_fixed(Xen range)
return(C_to_Xen_gboolean(gtk_range_get_slider_size_fixed(Xen_to_C_GtkRange_(range))));
}
-static Xen gxg_gtk_range_set_min_slider_size(Xen range, Xen min_size)
-{
- #define H_gtk_range_set_min_slider_size "void gtk_range_set_min_slider_size(GtkRange* range, gboolean min_size)"
- Xen_check_type(Xen_is_GtkRange_(range), range, 1, "gtk_range_set_min_slider_size", "GtkRange*");
- Xen_check_type(Xen_is_gboolean(min_size), min_size, 2, "gtk_range_set_min_slider_size", "gboolean");
- gtk_range_set_min_slider_size(Xen_to_C_GtkRange_(range), Xen_to_C_gboolean(min_size));
- return(Xen_false);
-}
-
-static Xen gxg_gtk_range_get_min_slider_size(Xen range)
-{
- #define H_gtk_range_get_min_slider_size "gint gtk_range_get_min_slider_size(GtkRange* range)"
- Xen_check_type(Xen_is_GtkRange_(range), range, 1, "gtk_range_get_min_slider_size", "GtkRange*");
- return(C_to_Xen_gint(gtk_range_get_min_slider_size(Xen_to_C_GtkRange_(range))));
-}
-
static Xen gxg_gtk_range_get_range_rect(Xen range, Xen range_rect)
{
#define H_gtk_range_get_range_rect "void gtk_range_get_range_rect(GtkRange* range, GdkRectangle* range_rect)"
@@ -25066,13 +25044,6 @@ static Xen gxg_gtk_widget_send_focus_change(Xen widget, Xen event)
return(C_to_Xen_gboolean(gtk_widget_send_focus_change(Xen_to_C_GtkWidget_(widget), Xen_to_C_GdkEvent_(event))));
}
-static Xen gxg_gdk_display_get_device_manager(Xen display)
-{
- #define H_gdk_display_get_device_manager "GdkDeviceManager* gdk_display_get_device_manager(GdkDisplay* display)"
- Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_device_manager", "GdkDisplay*");
- return(C_to_Xen_GdkDeviceManager_(gdk_display_get_device_manager(Xen_to_C_GdkDisplay_(display))));
-}
-
static Xen gxg_gdk_drag_context_set_device(Xen context, Xen device)
{
#define H_gdk_drag_context_set_device "void gdk_drag_context_set_device(GdkDragContext* context, GdkDevice* device)"
@@ -26183,28 +26154,6 @@ static Xen gxg_gtk_widget_compute_expand(Xen widget, Xen orientation)
return(C_to_Xen_gboolean(gtk_widget_compute_expand(Xen_to_C_GtkWidget_(widget), Xen_to_C_GtkOrientation(orientation))));
}
-static Xen gxg_gtk_window_set_default_geometry(Xen window, Xen width, Xen height)
-{
- #define H_gtk_window_set_default_geometry "void gtk_window_set_default_geometry(GtkWindow* window, \
-gint width, gint height)"
- Xen_check_type(Xen_is_GtkWindow_(window), window, 1, "gtk_window_set_default_geometry", "GtkWindow*");
- Xen_check_type(Xen_is_gint(width), width, 2, "gtk_window_set_default_geometry", "gint");
- Xen_check_type(Xen_is_gint(height), height, 3, "gtk_window_set_default_geometry", "gint");
- gtk_window_set_default_geometry(Xen_to_C_GtkWindow_(window), Xen_to_C_gint(width), Xen_to_C_gint(height));
- return(Xen_false);
-}
-
-static Xen gxg_gtk_window_resize_to_geometry(Xen window, Xen width, Xen height)
-{
- #define H_gtk_window_resize_to_geometry "void gtk_window_resize_to_geometry(GtkWindow* window, gint width, \
-gint height)"
- Xen_check_type(Xen_is_GtkWindow_(window), window, 1, "gtk_window_resize_to_geometry", "GtkWindow*");
- Xen_check_type(Xen_is_gint(width), width, 2, "gtk_window_resize_to_geometry", "gint");
- Xen_check_type(Xen_is_gint(height), height, 3, "gtk_window_resize_to_geometry", "gint");
- gtk_window_resize_to_geometry(Xen_to_C_GtkWindow_(window), Xen_to_C_gint(width), Xen_to_C_gint(height));
- return(Xen_false);
-}
-
static Xen gxg_gtk_combo_box_text_new(void)
{
#define H_gtk_combo_box_text_new "GtkWidget* gtk_combo_box_text_new( void)"
@@ -32020,11 +31969,12 @@ static Xen gxg_gdk_gl_context_is_legacy(Xen context)
return(C_to_Xen_gboolean(gdk_gl_context_is_legacy(Xen_to_C_GdkGLContext_(context))));
}
-static Xen gxg_gdk_rectangle_equal(Xen rect1)
+static Xen gxg_gdk_rectangle_equal(Xen rect1, Xen rect2)
{
- #define H_gdk_rectangle_equal "gboolean gdk_rectangle_equal(GdkRectangle* rect1, GdkRectangle*rect2)"
+ #define H_gdk_rectangle_equal "gboolean gdk_rectangle_equal(GdkRectangle* rect1, GdkRectangle* rect2)"
Xen_check_type(Xen_is_GdkRectangle_(rect1), rect1, 1, "gdk_rectangle_equal", "GdkRectangle*");
- return(C_to_Xen_gboolean(gdk_rectangle_equal(Xen_to_C_GdkRectangle_(rect1))));
+ Xen_check_type(Xen_is_GdkRectangle_(rect2), rect2, 2, "gdk_rectangle_equal", "GdkRectangle*");
+ return(C_to_Xen_gboolean(gdk_rectangle_equal(Xen_to_C_GdkRectangle_(rect1), Xen_to_C_GdkRectangle_(rect2))));
}
static Xen gxg_gtk_application_window_set_help_overlay(Xen window, Xen help_overlay)
@@ -32110,6 +32060,318 @@ int* [baseline])"
return(Xen_list_2(C_to_Xen_GtkAllocation(ref_allocation), C_to_Xen_int(ref_baseline)));
}
+static Xen gxg_gdk_drag_context_get_drag_window(Xen context)
+{
+ #define H_gdk_drag_context_get_drag_window "GdkWindow* gdk_drag_context_get_drag_window(GdkDragContext* context)"
+ Xen_check_type(Xen_is_GdkDragContext_(context), context, 1, "gdk_drag_context_get_drag_window", "GdkDragContext*");
+ return(C_to_Xen_GdkWindow_(gdk_drag_context_get_drag_window(Xen_to_C_GdkDragContext_(context))));
+}
+
+static Xen gxg_gtk_popover_set_constrain_to(Xen popover, Xen constraint)
+{
+ #define H_gtk_popover_set_constrain_to "void gtk_popover_set_constrain_to(GtkPopover* popover, GtkPopoverConstraint constraint)"
+ Xen_check_type(Xen_is_GtkPopover_(popover), popover, 1, "gtk_popover_set_constrain_to", "GtkPopover*");
+ Xen_check_type(Xen_is_GtkPopoverConstraint(constraint), constraint, 2, "gtk_popover_set_constrain_to", "GtkPopoverConstraint");
+ gtk_popover_set_constrain_to(Xen_to_C_GtkPopover_(popover), Xen_to_C_GtkPopoverConstraint(constraint));
+ return(Xen_false);
+}
+
+static Xen gxg_gtk_popover_get_constrain_to(Xen popover)
+{
+ #define H_gtk_popover_get_constrain_to "GtkPopoverConstraint gtk_popover_get_constrain_to(GtkPopover* popover)"
+ Xen_check_type(Xen_is_GtkPopover_(popover), popover, 1, "gtk_popover_get_constrain_to", "GtkPopover*");
+ return(C_to_Xen_GtkPopoverConstraint(gtk_popover_get_constrain_to(Xen_to_C_GtkPopover_(popover))));
+}
+
+static Xen gxg_gtk_text_iter_starts_tag(Xen iter, Xen tag)
+{
+ #define H_gtk_text_iter_starts_tag "gboolean gtk_text_iter_starts_tag(GtkTextIter* iter, GtkTextTag* tag)"
+ Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 1, "gtk_text_iter_starts_tag", "GtkTextIter*");
+ Xen_check_type(Xen_is_GtkTextTag_(tag) || Xen_is_false(tag), tag, 2, "gtk_text_iter_starts_tag", "GtkTextTag*");
+ return(C_to_Xen_gboolean(gtk_text_iter_starts_tag(Xen_to_C_GtkTextIter_(iter), Xen_to_C_GtkTextTag_(tag))));
+}
+
+static Xen gxg_gdk_device_get_seat(Xen device)
+{
+ #define H_gdk_device_get_seat "GdkSeat* gdk_device_get_seat(GdkDevice* device)"
+ Xen_check_type(Xen_is_GdkDevice_(device), device, 1, "gdk_device_get_seat", "GdkDevice*");
+ return(C_to_Xen_GdkSeat_(gdk_device_get_seat(Xen_to_C_GdkDevice_(device))));
+}
+
+static Xen gxg_gdk_display_get_default_seat(Xen display)
+{
+ #define H_gdk_display_get_default_seat "GdkSeat* gdk_display_get_default_seat(GdkDisplay* display)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_default_seat", "GdkDisplay*");
+ return(C_to_Xen_GdkSeat_(gdk_display_get_default_seat(Xen_to_C_GdkDisplay_(display))));
+}
+
+static Xen gxg_gdk_display_list_seats(Xen display)
+{
+ #define H_gdk_display_list_seats "GList* gdk_display_list_seats(GdkDisplay* display)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_list_seats", "GdkDisplay*");
+ return(C_to_Xen_GList_(gdk_display_list_seats(Xen_to_C_GdkDisplay_(display))));
+}
+
+static Xen gxg_gdk_drag_begin_from_point(Xen window, Xen device, Xen targets, Xen x_root, Xen y_root)
+{
+ #define H_gdk_drag_begin_from_point "GdkDragContext* gdk_drag_begin_from_point(GdkWindow* window, GdkDevice* device, \
+GList* targets, gint x_root, gint y_root)"
+ Xen_check_type(Xen_is_GdkWindow_(window), window, 1, "gdk_drag_begin_from_point", "GdkWindow*");
+ Xen_check_type(Xen_is_GdkDevice_(device), device, 2, "gdk_drag_begin_from_point", "GdkDevice*");
+ Xen_check_type(Xen_is_GList_(targets), targets, 3, "gdk_drag_begin_from_point", "GList*");
+ Xen_check_type(Xen_is_gint(x_root), x_root, 4, "gdk_drag_begin_from_point", "gint");
+ Xen_check_type(Xen_is_gint(y_root), y_root, 5, "gdk_drag_begin_from_point", "gint");
+ return(C_to_Xen_GdkDragContext_(gdk_drag_begin_from_point(Xen_to_C_GdkWindow_(window), Xen_to_C_GdkDevice_(device), Xen_to_C_GList_(targets),
+ Xen_to_C_gint(x_root), Xen_to_C_gint(y_root))));
+}
+
+static Xen gxg_gdk_drag_drop_done(Xen context, Xen success)
+{
+ #define H_gdk_drag_drop_done "void gdk_drag_drop_done(GdkDragContext* context, gboolean success)"
+ Xen_check_type(Xen_is_GdkDragContext_(context), context, 1, "gdk_drag_drop_done", "GdkDragContext*");
+ Xen_check_type(Xen_is_gboolean(success), success, 2, "gdk_drag_drop_done", "gboolean");
+ gdk_drag_drop_done(Xen_to_C_GdkDragContext_(context), Xen_to_C_gboolean(success));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_drag_context_set_hotspot(Xen context, Xen hot_x, Xen hot_y)
+{
+ #define H_gdk_drag_context_set_hotspot "void gdk_drag_context_set_hotspot(GdkDragContext* context, \
+gint hot_x, gint hot_y)"
+ Xen_check_type(Xen_is_GdkDragContext_(context), context, 1, "gdk_drag_context_set_hotspot", "GdkDragContext*");
+ Xen_check_type(Xen_is_gint(hot_x), hot_x, 2, "gdk_drag_context_set_hotspot", "gint");
+ Xen_check_type(Xen_is_gint(hot_y), hot_y, 3, "gdk_drag_context_set_hotspot", "gint");
+ gdk_drag_context_set_hotspot(Xen_to_C_GdkDragContext_(context), Xen_to_C_gint(hot_x), Xen_to_C_gint(hot_y));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_seat_grab(Xen arglist)
+{
+ #define H_gdk_seat_grab "GdkGrabStatus gdk_seat_grab(GdkSeat* seat, GdkWindow* window, GdkSeatCapabilities capabilities, \
+gboolean owner_events, GdkCursor* cursor, const GdkEvent*, event GdkSeatGrabPrepareFunc, prepare_func lambda_data, \
+prepare_func_data)"
+ Xen seat, window, capabilities, owner_events, cursor, GdkEvent*, GdkSeatGrabPrepareFunc, lambda_data;
+ seat = Xen_list_ref(arglist, 0);
+ window = Xen_list_ref(arglist, 1);
+ capabilities = Xen_list_ref(arglist, 2);
+ owner_events = Xen_list_ref(arglist, 3);
+ cursor = Xen_list_ref(arglist, 4);
+ GdkEvent* = Xen_list_ref(arglist, 5);
+ GdkSeatGrabPrepareFunc = Xen_list_ref(arglist, 6);
+ lambda_data = Xen_list_ref(arglist, 7);
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_grab", "GdkSeat*");
+ Xen_check_type(Xen_is_GdkWindow_(window), window, 2, "gdk_seat_grab", "GdkWindow*");
+ Xen_check_type(Xen_is_GdkSeatCapabilities(capabilities), capabilities, 3, "gdk_seat_grab", "GdkSeatCapabilities");
+ Xen_check_type(Xen_is_gboolean(owner_events), owner_events, 4, "gdk_seat_grab", "gboolean");
+ Xen_check_type(Xen_is_GdkCursor_(cursor), cursor, 5, "gdk_seat_grab", "GdkCursor*");
+ Xen_check_type(Xen_is_const(GdkEvent*), GdkEvent*, 6, "gdk_seat_grab", "const");
+ Xen_check_type(Xen_is_event(GdkSeatGrabPrepareFunc), GdkSeatGrabPrepareFunc, 7, "gdk_seat_grab", "event");
+ Xen_check_type(Xen_is_prepare_func(lambda_data), lambda_data, 8, "gdk_seat_grab", "prepare_func");
+ return(C_to_Xen_GdkGrabStatus(gdk_seat_grab(Xen_to_C_GdkSeat_(seat), Xen_to_C_GdkWindow_(window), Xen_to_C_GdkSeatCapabilities(capabilities),
+ Xen_to_C_gboolean(owner_events), Xen_to_C_GdkCursor_(cursor), Xen_to_C_const(GdkEvent*),
+ Xen_to_C_event(GdkSeatGrabPrepareFunc), Xen_to_C_prepare_func(lambda_data))));
+}
+
+static Xen gxg_gdk_seat_ungrab(Xen seat)
+{
+ #define H_gdk_seat_ungrab "void gdk_seat_ungrab(GdkSeat* seat)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_ungrab", "GdkSeat*");
+ gdk_seat_ungrab(Xen_to_C_GdkSeat_(seat));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_seat_get_display(Xen seat)
+{
+ #define H_gdk_seat_get_display "GdkDisplay* gdk_seat_get_display(GdkSeat* seat)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_get_display", "GdkSeat*");
+ return(C_to_Xen_GdkDisplay_(gdk_seat_get_display(Xen_to_C_GdkSeat_(seat))));
+}
+
+static Xen gxg_gdk_seat_get_capabilities(Xen seat)
+{
+ #define H_gdk_seat_get_capabilities "GdkSeatCapabilities gdk_seat_get_capabilities(GdkSeat* seat)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_get_capabilities", "GdkSeat*");
+ return(C_to_Xen_GdkSeatCapabilities(gdk_seat_get_capabilities(Xen_to_C_GdkSeat_(seat))));
+}
+
+static Xen gxg_gdk_seat_get_slaves(Xen seat, Xen capabilities)
+{
+ #define H_gdk_seat_get_slaves "GList* gdk_seat_get_slaves(GdkSeat* seat, GdkSeatCapabilities capabilities)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_get_slaves", "GdkSeat*");
+ Xen_check_type(Xen_is_GdkSeatCapabilities(capabilities), capabilities, 2, "gdk_seat_get_slaves", "GdkSeatCapabilities");
+ return(C_to_Xen_GList_(gdk_seat_get_slaves(Xen_to_C_GdkSeat_(seat), Xen_to_C_GdkSeatCapabilities(capabilities))));
+}
+
+static Xen gxg_gdk_seat_get_pointer(Xen seat)
+{
+ #define H_gdk_seat_get_pointer "GdkDevice* gdk_seat_get_pointer(GdkSeat* seat)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_get_pointer", "GdkSeat*");
+ return(C_to_Xen_GdkDevice_(gdk_seat_get_pointer(Xen_to_C_GdkSeat_(seat))));
+}
+
+static Xen gxg_gdk_seat_get_keyboard(Xen seat)
+{
+ #define H_gdk_seat_get_keyboard "GdkDevice* gdk_seat_get_keyboard(GdkSeat* seat)"
+ Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_get_keyboard", "GdkSeat*");
+ return(C_to_Xen_GdkDevice_(gdk_seat_get_keyboard(Xen_to_C_GdkSeat_(seat))));
+}
+
+static Xen gxg_gdk_drag_context_manage_dnd(Xen context, Xen ipc_window, Xen actions)
+{
+ #define H_gdk_drag_context_manage_dnd "gboolean gdk_drag_context_manage_dnd(GdkDragContext* context, \
+GdkWindow* ipc_window, GdkDragAction actions)"
+ Xen_check_type(Xen_is_GdkDragContext_(context), context, 1, "gdk_drag_context_manage_dnd", "GdkDragContext*");
+ Xen_check_type(Xen_is_GdkWindow_(ipc_window), ipc_window, 2, "gdk_drag_context_manage_dnd", "GdkWindow*");
+ Xen_check_type(Xen_is_GdkDragAction(actions), actions, 3, "gdk_drag_context_manage_dnd", "GdkDragAction");
+ return(C_to_Xen_gboolean(gdk_drag_context_manage_dnd(Xen_to_C_GdkDragContext_(context), Xen_to_C_GdkWindow_(ipc_window),
+ Xen_to_C_GdkDragAction(actions))));
+}
+
+static Xen gxg_gdk_event_is_scroll_stop_event(Xen event)
+{
+ #define H_gdk_event_is_scroll_stop_event "gboolean gdk_event_is_scroll_stop_event(GdkEvent* event)"
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 1, "gdk_event_is_scroll_stop_event", "GdkEvent*");
+ return(C_to_Xen_gboolean(gdk_event_is_scroll_stop_event(Xen_to_C_GdkEvent_(event))));
+}
+
+static Xen gxg_gtk_text_view_reset_cursor_blink(Xen text_view)
+{
+ #define H_gtk_text_view_reset_cursor_blink "void gtk_text_view_reset_cursor_blink(GtkTextView* text_view)"
+ Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, "gtk_text_view_reset_cursor_blink", "GtkTextView*");
+ gtk_text_view_reset_cursor_blink(Xen_to_C_GtkTextView_(text_view));
+ return(Xen_false);
+}
+
+static Xen gxg_gtk_render_background_get_clip(Xen context, Xen x, Xen y, Xen width, Xen height, Xen ignore_out_clip)
+{
+ #define H_gtk_render_background_get_clip "void gtk_render_background_get_clip(GtkStyleContext* context, \
+gdouble x, gdouble y, gdouble width, gdouble height, GdkRectangle* [out_clip])"
+ GdkRectangle ref_out_clip;
+ Xen_check_type(Xen_is_GtkStyleContext_(context), context, 1, "gtk_render_background_get_clip", "GtkStyleContext*");
+ Xen_check_type(Xen_is_gdouble(x), x, 2, "gtk_render_background_get_clip", "gdouble");
+ Xen_check_type(Xen_is_gdouble(y), y, 3, "gtk_render_background_get_clip", "gdouble");
+ Xen_check_type(Xen_is_gdouble(width), width, 4, "gtk_render_background_get_clip", "gdouble");
+ Xen_check_type(Xen_is_gdouble(height), height, 5, "gtk_render_background_get_clip", "gdouble");
+ gtk_render_background_get_clip(Xen_to_C_GtkStyleContext_(context), Xen_to_C_gdouble(x), Xen_to_C_gdouble(y), Xen_to_C_gdouble(width),
+ Xen_to_C_gdouble(height), &ref_out_clip);
+ return(Xen_list_1(C_to_Xen_GdkRectangle(ref_out_clip)));
+}
+
+static Xen gxg_gtk_text_layout_get_iter_at_pixel(Xen layout, Xen iter, Xen x, Xen y)
+{
+ #define H_gtk_text_layout_get_iter_at_pixel "gboolean gtk_text_layout_get_iter_at_pixel(GtkTextLayout* layout, \
+GtkTextIter* iter, gint x, gint y)"
+ Xen_check_type(Xen_is_GtkTextLayout_(layout), layout, 1, "gtk_text_layout_get_iter_at_pixel", "GtkTextLayout*");
+ Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_layout_get_iter_at_pixel", "GtkTextIter*");
+ Xen_check_type(Xen_is_gint(x), x, 3, "gtk_text_layout_get_iter_at_pixel", "gint");
+ Xen_check_type(Xen_is_gint(y), y, 4, "gtk_text_layout_get_iter_at_pixel", "gint");
+ return(C_to_Xen_gboolean(gtk_text_layout_get_iter_at_pixel(Xen_to_C_GtkTextLayout_(layout), Xen_to_C_GtkTextIter_(iter),
+ Xen_to_C_gint(x), Xen_to_C_gint(y))));
+}
+
+static Xen gxg_gtk_text_layout_get_iter_at_position(Xen layout, Xen iter, Xen ignore_trailing, Xen x, Xen y)
+{
+ #define H_gtk_text_layout_get_iter_at_position "gboolean gtk_text_layout_get_iter_at_position(GtkTextLayout* layout, \
+GtkTextIter* iter, gint* [trailing], gint x, gint y)"
+ gint ref_trailing;
+ Xen_check_type(Xen_is_GtkTextLayout_(layout), layout, 1, "gtk_text_layout_get_iter_at_position", "GtkTextLayout*");
+ Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_layout_get_iter_at_position", "GtkTextIter*");
+ Xen_check_type(Xen_is_gint(x), x, 4, "gtk_text_layout_get_iter_at_position", "gint");
+ Xen_check_type(Xen_is_gint(y), y, 5, "gtk_text_layout_get_iter_at_position", "gint");
+ {
+ Xen result;
+ result = C_to_Xen_gboolean(gtk_text_layout_get_iter_at_position(Xen_to_C_GtkTextLayout_(layout), Xen_to_C_GtkTextIter_(iter),
+ &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y)));
+ return(Xen_list_2(result, C_to_Xen_gint(ref_trailing)));
+ }
+}
+
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+static Xen gxg_gdk_device_get_axes(Xen device)
+{
+ #define H_gdk_device_get_axes "GdkAxisFlags gdk_device_get_axes(GdkDevice* device)"
+ Xen_check_type(Xen_is_GdkDevice_(device), device, 1, "gdk_device_get_axes", "GdkDevice*");
+ return(C_to_Xen_GdkAxisFlags(gdk_device_get_axes(Xen_to_C_GdkDevice_(device))));
+}
+
+static Xen gxg_gdk_event_get_device_tool(Xen event)
+{
+ #define H_gdk_event_get_device_tool "GdkDeviceTool* gdk_event_get_device_tool(GdkEvent* event)"
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 1, "gdk_event_get_device_tool", "GdkEvent*");
+ return(C_to_Xen_GdkDeviceTool_(gdk_event_get_device_tool(Xen_to_C_GdkEvent_(event))));
+}
+
+static Xen gxg_gdk_event_set_device_tool(Xen event, Xen tool)
+{
+ #define H_gdk_event_set_device_tool "void gdk_event_set_device_tool(GdkEvent* event, GdkDeviceTool* tool)"
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 1, "gdk_event_set_device_tool", "GdkEvent*");
+ Xen_check_type(Xen_is_GdkDeviceTool_(tool), tool, 2, "gdk_event_set_device_tool", "GdkDeviceTool*");
+ gdk_event_set_device_tool(Xen_to_C_GdkEvent_(event), Xen_to_C_GdkDeviceTool_(tool));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_event_get_scancode(Xen event)
+{
+ #define H_gdk_event_get_scancode "int gdk_event_get_scancode(GdkEvent* event)"
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 1, "gdk_event_get_scancode", "GdkEvent*");
+ return(C_to_Xen_int(gdk_event_get_scancode(Xen_to_C_GdkEvent_(event))));
+}
+
+static Xen gxg_gdk_gl_context_set_use_es(Xen context, Xen use_es)
+{
+ #define H_gdk_gl_context_set_use_es "void gdk_gl_context_set_use_es(GdkGLContext* context, gboolean use_es)"
+ Xen_check_type(Xen_is_GdkGLContext_(context), context, 1, "gdk_gl_context_set_use_es", "GdkGLContext*");
+ Xen_check_type(Xen_is_gboolean(use_es), use_es, 2, "gdk_gl_context_set_use_es", "gboolean");
+ gdk_gl_context_set_use_es(Xen_to_C_GdkGLContext_(context), Xen_to_C_gboolean(use_es));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_gl_context_get_use_es(Xen context)
+{
+ #define H_gdk_gl_context_get_use_es "gboolean gdk_gl_context_get_use_es(GdkGLContext* context)"
+ Xen_check_type(Xen_is_GdkGLContext_(context), context, 1, "gdk_gl_context_get_use_es", "GdkGLContext*");
+ return(C_to_Xen_gboolean(gdk_gl_context_get_use_es(Xen_to_C_GdkGLContext_(context))));
+}
+
+static Xen gxg_gdk_pango_context_get_for_display(Xen display)
+{
+ #define H_gdk_pango_context_get_for_display "PangoContext* gdk_pango_context_get_for_display(GdkDisplay* display)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_pango_context_get_for_display", "GdkDisplay*");
+ return(C_to_Xen_PangoContext_(gdk_pango_context_get_for_display(Xen_to_C_GdkDisplay_(display))));
+}
+
+static Xen gxg_gtk_clipboard_get_selection(Xen clipboard)
+{
+ #define H_gtk_clipboard_get_selection "GdkAtom gtk_clipboard_get_selection(GtkClipboard* clipboard)"
+ Xen_check_type(Xen_is_GtkClipboard_(clipboard), clipboard, 1, "gtk_clipboard_get_selection", "GtkClipboard*");
+ return(C_to_Xen_GdkAtom(gtk_clipboard_get_selection(Xen_to_C_GtkClipboard_(clipboard))));
+}
+
+static Xen gxg_gtk_gl_area_set_use_es(Xen area, Xen use_es)
+{
+ #define H_gtk_gl_area_set_use_es "void gtk_gl_area_set_use_es(GtkGLArea* area, gboolean use_es)"
+ Xen_check_type(Xen_is_GtkGLArea_(area), area, 1, "gtk_gl_area_set_use_es", "GtkGLArea*");
+ Xen_check_type(Xen_is_gboolean(use_es), use_es, 2, "gtk_gl_area_set_use_es", "gboolean");
+ gtk_gl_area_set_use_es(Xen_to_C_GtkGLArea_(area), Xen_to_C_gboolean(use_es));
+ return(Xen_false);
+}
+
+static Xen gxg_gtk_gl_area_get_use_es(Xen area)
+{
+ #define H_gtk_gl_area_get_use_es "gboolean gtk_gl_area_get_use_es(GtkGLArea* area)"
+ Xen_check_type(Xen_is_GtkGLArea_(area), area, 1, "gtk_gl_area_get_use_es", "GtkGLArea*");
+ return(C_to_Xen_gboolean(gtk_gl_area_get_use_es(Xen_to_C_GtkGLArea_(area))));
+}
+
+static Xen gxg_gdk_device_tool_get_serial(Xen tool)
+{
+ #define H_gdk_device_tool_get_serial "guint gdk_device_tool_get_serial(GdkDeviceTool* tool)"
+ Xen_check_type(Xen_is_GdkDeviceTool_(tool), tool, 1, "gdk_device_tool_get_serial", "GdkDeviceTool*");
+ return(C_to_Xen_guint(gdk_device_tool_get_serial(Xen_to_C_GdkDeviceTool_(tool))));
+}
+
#endif
static Xen gxg_cairo_create(Xen target)
@@ -34762,6 +35024,14 @@ static Xen gxg_GTK_POPOVER_MENU(Xen obj) {return((Xen_is_wrapped_object(obj)) ?
static Xen gxg_GTK_STACK_SIDEBAR(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list_2(xg_GtkStackSidebar__symbol, Xen_cadr(obj)) : Xen_false);}
#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+static Xen gxg_GDK_SEAT(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list_2(xg_GdkSeat__symbol, Xen_cadr(obj)) : Xen_false);}
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+static Xen gxg_GDK_DEVICE_TOOL(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list_2(xg_GdkDeviceTool__symbol, Xen_cadr(obj)) : Xen_false);}
+#endif
+
static Xen gxg_GDK_IS_DRAG_CONTEXT(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_DRAG_CONTEXT((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
static Xen gxg_GDK_IS_DEVICE(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_DEVICE((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
static Xen gxg_GDK_IS_KEYMAP(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_KEYMAP((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
@@ -34970,6 +35240,14 @@ static Xen gxg_GTK_IS_POPOVER_MENU(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is
static Xen gxg_GTK_IS_STACK_SIDEBAR(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GTK_IS_STACK_SIDEBAR((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+static Xen gxg_GDK_IS_SEAT(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_SEAT((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+static Xen gxg_GDK_IS_DEVICE_TOOL(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_DEVICE_TOOL((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
+#endif
+
/* ---------------------------------------- special functions ---------------------------------------- */
@@ -35351,6 +35629,42 @@ static Xen gxg_make_GdkRGBA(void)
}
#endif
+static Xen gxg_gtk_text_view_get_iter_at_position(Xen text_view, Xen iter, Xen ignore_trailing, Xen x, Xen y)
+{
+ #define H_gtk_text_view_get_iter_at_position "gboolean gtk_text_view_get_iter_at_position(GtkTextView* text_view, GtkTextIter* iter, gint* [trailing], gint x, gint y)"
+ gint ref_trailing;
+ Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, "gtk_text_view_get_iter_at_position", "GtkTextView*");
+ Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_view_get_iter_at_position", "GtkTextIter*");
+ Xen_check_type(Xen_is_gint(x), x, 4, "gtk_text_view_get_iter_at_position", "gint");
+ Xen_check_type(Xen_is_gint(y), y, 5, "gtk_text_view_get_iter_at_position", "gint");
+#if GTK_CHECK_VERSION(3, 20, 0)
+ {
+ Xen result;
+ result = C_to_Xen_gboolean(gtk_text_view_get_iter_at_position(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter),
+ &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y)));
+ return(Xen_list_2(result, C_to_Xen_gint(ref_trailing)));
+ }
+#else
+ gtk_text_view_get_iter_at_position(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y));
+ return(Xen_list_1(C_to_Xen_gint(ref_trailing)));
+#endif
+}
+
+static Xen gxg_gtk_text_view_get_iter_at_location(Xen text_view, Xen iter, Xen x, Xen y)
+{
+ #define H_gtk_text_view_get_iter_at_location "gboolean gtk_text_view_get_iter_at_location(GtkTextView* text_view, GtkTextIter* iter, gint x, gint y)"
+ Xen_check_type(Xen_is_GtkTextView_(text_view), text_view, 1, "gtk_text_view_get_iter_at_location", "GtkTextView*");
+ Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_view_get_iter_at_location", "GtkTextIter*");
+ Xen_check_type(Xen_is_gint(x), x, 3, "gtk_text_view_get_iter_at_location", "gint");
+ Xen_check_type(Xen_is_gint(y), y, 4, "gtk_text_view_get_iter_at_location", "gint");
+#if GTK_CHECK_VERSION(3, 20, 0)
+ return(C_to_Xen_gboolean(gtk_text_view_get_iter_at_location(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), Xen_to_C_gint(x), Xen_to_C_gint(y))));
+#else
+ gtk_text_view_get_iter_at_location(Xen_to_C_GtkTextView_(text_view), Xen_to_C_GtkTextIter_(iter), Xen_to_C_gint(x), Xen_to_C_gint(y));
+ return(Xen_false);
+#endif
+}
+
#if HAVE_SCHEME
#define Xg_define_procedure(Name, Value, A1, A2, A3, Help, Sig) s7_define_typed_function(s7, Xg_pre #Name Xg_post, Value, A1, A2, A3, Help, Sig)
#else
@@ -35361,6 +35675,8 @@ Xen_wrap_no_args(gxg_make_GtkTextIter_w, gxg_make_GtkTextIter)
Xen_wrap_no_args(gxg_make_GtkTreeIter_w, gxg_make_GtkTreeIter)
Xen_wrap_no_args(gxg_make_PangoRectangle_w, gxg_make_PangoRectangle)
Xen_wrap_no_args(gxg_make_cairo_matrix_t_w, gxg_make_cairo_matrix_t)
+Xen_wrap_4_args(gxg_gtk_text_view_get_iter_at_location_w, gxg_gtk_text_view_get_iter_at_location)
+Xen_wrap_5_optional_args(gxg_gtk_text_view_get_iter_at_position_w, gxg_gtk_text_view_get_iter_at_position)
#if GTK_CHECK_VERSION(3, 0, 0)
Xen_wrap_no_args(gxg_make_GdkRGBA_w, gxg_make_GdkRGBA)
#endif
@@ -35372,6 +35688,8 @@ static void define_structs(void)
Xg_define_procedure(GtkTreeIter, gxg_make_GtkTreeIter_w, 0, 0, 0, "(GtkTreeIter): a new GtkTreeIter struct", NULL);
Xg_define_procedure(PangoRectangle, gxg_make_PangoRectangle_w, 0, 0, 0, "(PangoRectangle): a new PangoRectangle struct", NULL);
Xg_define_procedure(cairo_matrix_t, gxg_make_cairo_matrix_t_w, 0, 0, 0, "(cairo_matrix_t): a new cairo_matrix_t struct", NULL);
+ Xg_define_procedure(gtk_text_view_get_iter_at_location, gxg_gtk_text_view_get_iter_at_location_w, 4, 0, 0, H_gtk_text_view_get_iter_at_location, NULL);
+ Xg_define_procedure(gtk_text_view_get_iter_at_position, gxg_gtk_text_view_get_iter_at_position_w, 4, 1, 0, H_gtk_text_view_get_iter_at_position, NULL);
#if GTK_CHECK_VERSION(3, 0, 0)
Xg_define_procedure(GdkRGBA, gxg_make_GdkRGBA_w, 0, 0, 0, "(GdkRGBA): a new GdkRGBA struct", NULL);
#endif
@@ -36140,7 +36458,6 @@ Xen_wrap_1_arg(gxg_gtk_text_iter_get_pixbuf_w, gxg_gtk_text_iter_get_pixbuf)
Xen_wrap_1_arg(gxg_gtk_text_iter_get_marks_w, gxg_gtk_text_iter_get_marks)
Xen_wrap_1_arg(gxg_gtk_text_iter_get_child_anchor_w, gxg_gtk_text_iter_get_child_anchor)
Xen_wrap_2_args(gxg_gtk_text_iter_get_toggled_tags_w, gxg_gtk_text_iter_get_toggled_tags)
-Xen_wrap_2_args(gxg_gtk_text_iter_begins_tag_w, gxg_gtk_text_iter_begins_tag)
Xen_wrap_2_args(gxg_gtk_text_iter_ends_tag_w, gxg_gtk_text_iter_ends_tag)
Xen_wrap_2_args(gxg_gtk_text_iter_toggles_tag_w, gxg_gtk_text_iter_toggles_tag)
Xen_wrap_2_args(gxg_gtk_text_iter_has_tag_w, gxg_gtk_text_iter_has_tag)
@@ -36233,7 +36550,6 @@ Xen_wrap_2_args(gxg_gtk_text_view_get_visible_rect_w, gxg_gtk_text_view_get_visi
Xen_wrap_2_args(gxg_gtk_text_view_set_cursor_visible_w, gxg_gtk_text_view_set_cursor_visible)
Xen_wrap_1_arg(gxg_gtk_text_view_get_cursor_visible_w, gxg_gtk_text_view_get_cursor_visible)
Xen_wrap_3_args(gxg_gtk_text_view_get_iter_location_w, gxg_gtk_text_view_get_iter_location)
-Xen_wrap_4_args(gxg_gtk_text_view_get_iter_at_location_w, gxg_gtk_text_view_get_iter_at_location)
Xen_wrap_4_optional_args(gxg_gtk_text_view_get_line_yrange_w, gxg_gtk_text_view_get_line_yrange)
Xen_wrap_4_optional_args(gxg_gtk_text_view_get_line_at_y_w, gxg_gtk_text_view_get_line_at_y)
Xen_wrap_6_optional_args(gxg_gtk_text_view_buffer_to_window_coords_w, gxg_gtk_text_view_buffer_to_window_coords)
@@ -36605,7 +36921,6 @@ Xen_wrap_3_args(gxg_gtk_window_resize_w, gxg_gtk_window_resize)
Xen_wrap_3_optional_args(gxg_gtk_window_get_size_w, gxg_gtk_window_get_size)
Xen_wrap_3_args(gxg_gtk_window_move_w, gxg_gtk_window_move)
Xen_wrap_3_optional_args(gxg_gtk_window_get_position_w, gxg_gtk_window_get_position)
-Xen_wrap_2_args(gxg_gtk_window_parse_geometry_w, gxg_gtk_window_parse_geometry)
Xen_wrap_1_arg(gxg_pango_color_copy_w, gxg_pango_color_copy)
Xen_wrap_1_arg(gxg_pango_color_free_w, gxg_pango_color_free)
Xen_wrap_2_args(gxg_pango_color_parse_w, gxg_pango_color_parse)
@@ -37287,7 +37602,6 @@ Xen_wrap_2_args(gxg_gtk_label_set_max_width_chars_w, gxg_gtk_label_set_max_width
Xen_wrap_1_arg(gxg_gtk_label_get_max_width_chars_w, gxg_gtk_label_get_max_width_chars)
Xen_wrap_3_args(gxg_gtk_list_store_insert_with_values_w, gxg_gtk_list_store_insert_with_values)
Xen_wrap_6_args(gxg_gtk_list_store_insert_with_valuesv_w, gxg_gtk_list_store_insert_with_valuesv)
-Xen_wrap_5_optional_args(gxg_gtk_text_view_get_iter_at_position_w, gxg_gtk_text_view_get_iter_at_position)
Xen_wrap_1_arg(gxg_pango_attr_size_new_absolute_w, gxg_pango_attr_size_new_absolute)
Xen_wrap_2_args(gxg_pango_font_description_set_absolute_size_w, gxg_pango_font_description_set_absolute_size)
Xen_wrap_1_arg(gxg_pango_layout_get_font_description_w, gxg_pango_layout_get_font_description)
@@ -37913,8 +38227,6 @@ Xen_wrap_2_args(gxg_gtk_window_set_mnemonics_visible_w, gxg_gtk_window_set_mnemo
Xen_wrap_1_arg(gxg_gtk_window_get_mnemonics_visible_w, gxg_gtk_window_get_mnemonics_visible)
Xen_wrap_2_args(gxg_gtk_range_set_slider_size_fixed_w, gxg_gtk_range_set_slider_size_fixed)
Xen_wrap_1_arg(gxg_gtk_range_get_slider_size_fixed_w, gxg_gtk_range_get_slider_size_fixed)
-Xen_wrap_2_args(gxg_gtk_range_set_min_slider_size_w, gxg_gtk_range_set_min_slider_size)
-Xen_wrap_1_arg(gxg_gtk_range_get_min_slider_size_w, gxg_gtk_range_get_min_slider_size)
Xen_wrap_2_args(gxg_gtk_range_get_range_rect_w, gxg_gtk_range_get_range_rect)
Xen_wrap_3_optional_args(gxg_gtk_range_get_slider_range_w, gxg_gtk_range_get_slider_range)
Xen_wrap_1_arg(gxg_gtk_paned_get_handle_window_w, gxg_gtk_paned_get_handle_window)
@@ -37934,7 +38246,6 @@ Xen_wrap_1_arg(gxg_gdk_window_get_effective_parent_w, gxg_gdk_window_get_effecti
Xen_wrap_1_arg(gxg_gdk_window_get_effective_toplevel_w, gxg_gdk_window_get_effective_toplevel)
Xen_wrap_1_arg(gxg_gtk_accessible_get_widget_w, gxg_gtk_accessible_get_widget)
Xen_wrap_2_args(gxg_gtk_widget_send_focus_change_w, gxg_gtk_widget_send_focus_change)
-Xen_wrap_1_arg(gxg_gdk_display_get_device_manager_w, gxg_gdk_display_get_device_manager)
Xen_wrap_2_args(gxg_gdk_drag_context_set_device_w, gxg_gdk_drag_context_set_device)
Xen_wrap_1_arg(gxg_gdk_drag_context_get_device_w, gxg_gdk_drag_context_get_device)
Xen_wrap_1_arg(gxg_gdk_drag_context_list_targets_w, gxg_gdk_drag_context_list_targets)
@@ -38059,8 +38370,6 @@ Xen_wrap_1_arg(gxg_gtk_widget_get_vexpand_set_w, gxg_gtk_widget_get_vexpand_set)
Xen_wrap_2_args(gxg_gtk_widget_set_vexpand_set_w, gxg_gtk_widget_set_vexpand_set)
Xen_wrap_1_arg(gxg_gtk_widget_queue_compute_expand_w, gxg_gtk_widget_queue_compute_expand)
Xen_wrap_2_args(gxg_gtk_widget_compute_expand_w, gxg_gtk_widget_compute_expand)
-Xen_wrap_3_args(gxg_gtk_window_set_default_geometry_w, gxg_gtk_window_set_default_geometry)
-Xen_wrap_3_args(gxg_gtk_window_resize_to_geometry_w, gxg_gtk_window_resize_to_geometry)
Xen_wrap_no_args(gxg_gtk_combo_box_text_new_w, gxg_gtk_combo_box_text_new)
Xen_wrap_no_args(gxg_gtk_combo_box_text_new_with_entry_w, gxg_gtk_combo_box_text_new_with_entry)
Xen_wrap_2_args(gxg_gtk_combo_box_text_append_text_w, gxg_gtk_combo_box_text_append_text)
@@ -38743,7 +39052,7 @@ Xen_wrap_1_arg(gxg_gtk_text_view_get_bottom_margin_w, gxg_gtk_text_view_get_bott
#if GTK_CHECK_VERSION(3, 20, 0)
Xen_wrap_1_arg(gxg_gdk_gl_context_is_legacy_w, gxg_gdk_gl_context_is_legacy)
-Xen_wrap_1_arg(gxg_gdk_rectangle_equal_w, gxg_gdk_rectangle_equal)
+Xen_wrap_2_args(gxg_gdk_rectangle_equal_w, gxg_gdk_rectangle_equal)
Xen_wrap_2_args(gxg_gtk_application_window_set_help_overlay_w, gxg_gtk_application_window_set_help_overlay)
Xen_wrap_2_args(gxg_gtk_settings_reset_property_w, gxg_gtk_settings_reset_property)
Xen_wrap_2_args(gxg_gtk_text_tag_changed_w, gxg_gtk_text_tag_changed)
@@ -38753,6 +39062,43 @@ Xen_wrap_1_arg(gxg_gtk_widget_queue_allocate_w, gxg_gtk_widget_queue_allocate)
Xen_wrap_2_args(gxg_gtk_widget_set_focus_on_click_w, gxg_gtk_widget_set_focus_on_click)
Xen_wrap_1_arg(gxg_gtk_widget_get_focus_on_click_w, gxg_gtk_widget_get_focus_on_click)
Xen_wrap_3_optional_args(gxg_gtk_widget_get_allocated_size_w, gxg_gtk_widget_get_allocated_size)
+Xen_wrap_1_arg(gxg_gdk_drag_context_get_drag_window_w, gxg_gdk_drag_context_get_drag_window)
+Xen_wrap_2_args(gxg_gtk_popover_set_constrain_to_w, gxg_gtk_popover_set_constrain_to)
+Xen_wrap_1_arg(gxg_gtk_popover_get_constrain_to_w, gxg_gtk_popover_get_constrain_to)
+Xen_wrap_2_args(gxg_gtk_text_iter_starts_tag_w, gxg_gtk_text_iter_starts_tag)
+Xen_wrap_1_arg(gxg_gdk_device_get_seat_w, gxg_gdk_device_get_seat)
+Xen_wrap_1_arg(gxg_gdk_display_get_default_seat_w, gxg_gdk_display_get_default_seat)
+Xen_wrap_1_arg(gxg_gdk_display_list_seats_w, gxg_gdk_display_list_seats)
+Xen_wrap_5_args(gxg_gdk_drag_begin_from_point_w, gxg_gdk_drag_begin_from_point)
+Xen_wrap_2_args(gxg_gdk_drag_drop_done_w, gxg_gdk_drag_drop_done)
+Xen_wrap_3_args(gxg_gdk_drag_context_set_hotspot_w, gxg_gdk_drag_context_set_hotspot)
+Xen_wrap_any_args(gxg_gdk_seat_grab_w, gxg_gdk_seat_grab)
+Xen_wrap_1_arg(gxg_gdk_seat_ungrab_w, gxg_gdk_seat_ungrab)
+Xen_wrap_1_arg(gxg_gdk_seat_get_display_w, gxg_gdk_seat_get_display)
+Xen_wrap_1_arg(gxg_gdk_seat_get_capabilities_w, gxg_gdk_seat_get_capabilities)
+Xen_wrap_2_args(gxg_gdk_seat_get_slaves_w, gxg_gdk_seat_get_slaves)
+Xen_wrap_1_arg(gxg_gdk_seat_get_pointer_w, gxg_gdk_seat_get_pointer)
+Xen_wrap_1_arg(gxg_gdk_seat_get_keyboard_w, gxg_gdk_seat_get_keyboard)
+Xen_wrap_3_args(gxg_gdk_drag_context_manage_dnd_w, gxg_gdk_drag_context_manage_dnd)
+Xen_wrap_1_arg(gxg_gdk_event_is_scroll_stop_event_w, gxg_gdk_event_is_scroll_stop_event)
+Xen_wrap_1_arg(gxg_gtk_text_view_reset_cursor_blink_w, gxg_gtk_text_view_reset_cursor_blink)
+Xen_wrap_6_optional_args(gxg_gtk_render_background_get_clip_w, gxg_gtk_render_background_get_clip)
+Xen_wrap_4_args(gxg_gtk_text_layout_get_iter_at_pixel_w, gxg_gtk_text_layout_get_iter_at_pixel)
+Xen_wrap_5_optional_args(gxg_gtk_text_layout_get_iter_at_position_w, gxg_gtk_text_layout_get_iter_at_position)
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+Xen_wrap_1_arg(gxg_gdk_device_get_axes_w, gxg_gdk_device_get_axes)
+Xen_wrap_1_arg(gxg_gdk_event_get_device_tool_w, gxg_gdk_event_get_device_tool)
+Xen_wrap_2_args(gxg_gdk_event_set_device_tool_w, gxg_gdk_event_set_device_tool)
+Xen_wrap_1_arg(gxg_gdk_event_get_scancode_w, gxg_gdk_event_get_scancode)
+Xen_wrap_2_args(gxg_gdk_gl_context_set_use_es_w, gxg_gdk_gl_context_set_use_es)
+Xen_wrap_1_arg(gxg_gdk_gl_context_get_use_es_w, gxg_gdk_gl_context_get_use_es)
+Xen_wrap_1_arg(gxg_gdk_pango_context_get_for_display_w, gxg_gdk_pango_context_get_for_display)
+Xen_wrap_1_arg(gxg_gtk_clipboard_get_selection_w, gxg_gtk_clipboard_get_selection)
+Xen_wrap_2_args(gxg_gtk_gl_area_set_use_es_w, gxg_gtk_gl_area_set_use_es)
+Xen_wrap_1_arg(gxg_gtk_gl_area_get_use_es_w, gxg_gtk_gl_area_get_use_es)
+Xen_wrap_1_arg(gxg_gdk_device_tool_get_serial_w, gxg_gdk_device_tool_get_serial)
#endif
Xen_wrap_1_arg(gxg_cairo_create_w, gxg_cairo_create)
@@ -39257,6 +39603,14 @@ Xen_wrap_1_arg(gxg_GTK_POPOVER_MENU_w, gxg_GTK_POPOVER_MENU)
Xen_wrap_1_arg(gxg_GTK_STACK_SIDEBAR_w, gxg_GTK_STACK_SIDEBAR)
#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+Xen_wrap_1_arg(gxg_GDK_SEAT_w, gxg_GDK_SEAT)
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+Xen_wrap_1_arg(gxg_GDK_DEVICE_TOOL_w, gxg_GDK_DEVICE_TOOL)
+#endif
+
Xen_wrap_1_arg(gxg_GDK_IS_DRAG_CONTEXT_w, gxg_GDK_IS_DRAG_CONTEXT)
Xen_wrap_1_arg(gxg_GDK_IS_DEVICE_w, gxg_GDK_IS_DEVICE)
Xen_wrap_1_arg(gxg_GDK_IS_KEYMAP_w, gxg_GDK_IS_KEYMAP)
@@ -39465,9 +39819,17 @@ Xen_wrap_1_arg(gxg_GTK_IS_POPOVER_MENU_w, gxg_GTK_IS_POPOVER_MENU)
Xen_wrap_1_arg(gxg_GTK_IS_STACK_SIDEBAR_w, gxg_GTK_IS_STACK_SIDEBAR)
#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+Xen_wrap_1_arg(gxg_GDK_IS_SEAT_w, gxg_GDK_IS_SEAT)
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+Xen_wrap_1_arg(gxg_GDK_IS_DEVICE_TOOL_w, gxg_GDK_IS_DEVICE_TOOL)
+#endif
+
#if HAVE_SCHEME
-static s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_pair_false;
-static s7_pointer pl_tsb, pl_st, pl_tsu, pl_ts, pl_tsi, pl_tsiu, pl_tsiiuui, pl_tsiuui, pl_t, pl_psibiiiit, pl_psrrrb, pl_sui, pl_psu, pl_psb, pl_su, pl_sus, pl_ps, pl_psi, pl_psuit, pl_psut, pl_suuub, pl_p, pl_tts, pl_tti, pl_tusiuiuit, pl_tubu, pl_tuurru, pl_tuurrrrir, pl_tuurrrri, pl_tuuur, pl_tuuuui, pl_tuusb, pl_turru, pl_tuuuub, pl_tuttti, pl_tuuttti, pl_tuisi, pl_turis, pl_tubi, pl_tuttiisi, pl_tuiiiiui, pl_tuurb, pl_tuuiiiirrrri, pl_turrrb, pl_tuubbi, pl_pt, pl_tuuti, pl_tubbi, pl_tusiu, pl_tuuutti, pl_tuti, pl_tutti, pl_tutui, pl_tutisi, pl_tuuri, pl_tusr, pl_tusrt, pl_tusi, pl_turt, pl_tuui, pl_tut, pl_tuur, pl_tur, pl_tub, pl_tui, pl_tu, pl_tus, pl_tuiiu, pl_tusb, pl_tuuut, pl_tutb, pl_tust, pl_tuub, pl_tuus, pl_tuibu, pl_tuut, pl_tuiui, pl_tuubr, pl_tuuub, pl_tuuui, pl_tuuiuui, pl_tuiu, pl_tuuir, pl_tuir, pl_tuib, pl_tusu, pl_tuusi, pl_tuit, pl_tuis, pl_tubiiiu, pl_tusiis, pl_tusiuiu, pl_tusiuibu, pl_tusiiu, pl_tusui, pl_tuuubr, pl_tuiiiu, pl_tuuiu, pl_tuurbr, pl_tuusit, pl_pur, pl_puiu, pl_pusiiiu, pl_pusiiuiu, pl_puur, pl_puiiui, pl_pubi, pl_puiiu, pl_puuusuui, pl_pu, pl_puutu, pl_pui, pl_pusu, pl_pus, pl_put, pl_pusiiu, pl_pusi, pl_puui, pl_pub, pl_pust, pl_pusub, pl_puri, pl_bi, pl_bsiu, pl_bsiuub, pl_bsu, pl_bsiib, pl_bsiiuusu, pl_b, pl_btiib, pl_bti, pl_bt, pl_tb, pl_bur, pl_buut, pl_buuti, pl_buttiiiu, pl_butib, pl_buiui, pl_buuusuui, pl_buuit, pl_butu, pl_buti, pl_butti, pl_busi, pl_busu, pl_bui, pl_bu, pl_buuubu, pl_bus, pl_buutuuiu, pl_but, pl_bussu, pl_buib, pl_buiu, pl_buiiu, pl_bub, pl_buub, pl_pb, pl_buuiiu, pl_buui, pl_buuui, pl_buus, pl_buurbr, pl_busiu, pl_buttu, pl_buuub, pl_buuuub, pl_busib, pl_buusib, pl_iiit, pl_iit, pl_isiiutttiiu, pl_isi, pl_isit, pl_si, pl_is, pl_i, pl_itiiub, pl_itsub, pl_itsttti, pl_itiiiut, pl_tiu, pl_it, pl_ti, pl_iur, pl_iussitu, pl_iurrsiu, pl_iuut, pl_iuuut, pl_pir, pl_iuisi, pl_pibi, pl_iuuui, pl_iuuuui, pl_ius, pl_iusi, pl_iu, pl_iuiu, pl_iuui, pl_pi, pl_iui, pl_iuisut, pl_piu, pl_pit, pl_iuis, pl_trrru, pl_dusr, pl_dust, pl_dut, pl_du, pl_dus, pl_pr, pl_ssi, pl_s, pl_unused;
+static s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_gtk_enum_t, s_pair_false;
+static s7_pointer pl_iur, pl_iuisi, pl_pig, pl_iuuui, pl_iuuuui, pl_iuis, pl_iug, pl_ius, pl_iusi, pl_iu, pl_iuui, pl_pi, pl_iui, pl_iuisut, pl_piu, pl_pit, pl_t, pl_tts, pl_tti, pl_dust, pl_dut, pl_du, pl_dusr, pl_dus, pl_pr, pl_s, pl_tsb, pl_st, pl_tsu, pl_tsig, pl_ts, pl_tsi, pl_tsiu, pl_tsiiuui, pl_tsiuui, pl_p, pl_igi, pl_gi, pl_ssig, pl_ssi, pl_tusiuiuit, pl_turrrru, pl_tubu, pl_tuurru, pl_tuurrrrgr, pl_tuurrrrg, pl_tuuur, pl_tusg, pl_tuuuui, pl_tuusb, pl_tugui, pl_turru, pl_tuuugi, pl_tuuuub, pl_tuttti, pl_tuuttti, pl_tuisi, pl_tugb, pl_tugs, pl_tugug, pl_turgs, pl_tubi, pl_tuttigsi, pl_tuiiiiui, pl_tuurb, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_tuiggu, pl_turrrb, pl_tuubbi, pl_tuubbig, pl_pt, pl_tuuti, pl_tubbi, pl_tusiu, pl_tuuutti, pl_tuti, pl_tutti, pl_tutui, pl_tutisi, pl_tuuri, pl_tuusit, pl_tuurbr, pl_tuuiu, pl_tugiiu, pl_tuugi, pl_tuit, pl_tusr, pl_tusrt, pl_tusi, pl_turt, pl_tuui, pl_tut, pl_tuur, pl_tuig, pl_tur, pl_tub, pl_tui, pl_tu, pl_tus, pl_tuiiu, pl_tusb, pl_tuuut, pl_tug, pl_tutb, pl_tust, pl_tuub, pl_tuus, pl_tuug, pl_tuibu, pl_tuut, pl_tuuig, pl_tuguig, pl_tuubr, pl_tuuub, pl_tuuiuui, pl_tugu, pl_tuuir, pl_tugr, pl_tugi, pl_tuuui, pl_tuib, pl_tusu, pl_tuusi, pl_tugt, pl_tuis, pl_tuiu, pl_tubiiiu, pl_tusiis, pl_tusiuiu, pl_tusiuibu, pl_tusiiu, pl_tuuug, pl_tusuig, pl_tuuubr, pl_psgi, pl_suiig, pl_sug, pl_psgbiiiit, pl_psrrrb, pl_sui, pl_suuub, pl_psu, pl_psb, pl_su, pl_sus, pl_ps, pl_psg, pl_psi, pl_psugt, pl_psut, pl_g, pl_pur, pl_puuui, pl_puiu, pl_pusiig, pl_pusiigu, pl_pusiiugu, pl_puuiig, pl_puur, pl_puiiui, pl_pugi, pl_puuig, pl_pubi, pl_puiig, pl_puiigi, pl_puigu, pl_puuusuug, pl_pusi, pl_puri, pl_pusub, pl_pust, pl_pub, pl_pu, pl_puutu, pl_pui, pl_pusu, pl_pus, pl_pug, pl_put, pl_pusigu, pl_pusig, pl_puui, pl_pusiiu, pl_tg, pl_sg, pl_gs, pl_gussitu, pl_gurrsiu, pl_gus, pl_guut, pl_guuut, pl_guiu, pl_guugbut, pl_pgr, pl_pgu, pl_pgi, pl_gug, pl_pgbi, pl_gu, pl_gugu, pl_pg, pl_gui, pl_big, pl_bi, pl_b, pl_btiib, pl_bti, pl_bt, pl_tb, pl_bsiu, pl_bsiuub, pl_bsu, pl_bsigb, pl_bsiiuusu, pl_bur, pl_buug, pl_buut, pl_buigu, pl_busiu, pl_buuti, pl_buttiiiu, pl_butib, pl_buiuig, pl_buuusuug, pl_buuit, pl_butu, pl_buti, pl_butti, pl_busi, pl_buusib, pl_busib, pl_buuuub, pl_buuub, pl_buttu, pl_busgu, pl_buurbr, pl_buui, pl_buus, pl_buuui, pl_busu, pl_bug, pl_bu, pl_buuubu, pl_bus, pl_bui, pl_buutuuiu, pl_but, pl_bussu, pl_buib, pl_buiu, pl_buiiu, pl_bub, pl_buub, pl_pb, pl_buig, pl_buuiiu, pl_buuig, pl_iiit, pl_iit, pl_i, pl_itiiub, pl_itsub, pl_itstttg, pl_itgiiut, pl_tiu, pl_ti, pl_it, pl_isigutttiiu, pl_isi, pl_isgt, pl_sig, pl_si, pl_is, pl_trrru, pl_bpt;
#endif
static void define_functions(void)
@@ -39486,53 +39848,80 @@ static void define_functions(void)
s_string = s7_make_symbol(s7, "string?");
s_pair = s7_make_symbol(s7, "pair?");
s_pair_false = s7_make_signature(s7, 2, s_pair, s_boolean);
+ s_gtk_enum_t = s7_make_symbol(s7, "gtk_enum_t?");
s_any = s7_t(s7);
+ pl_iur = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_real);
+ pl_iuisi = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_integer, s_string, s_integer);
+ pl_pig = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_gtk_enum_t);
+ pl_iuuui = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_pair_false, s_pair_false, 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_iuis = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_integer, s_string);
+ pl_iug = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_gtk_enum_t);
+ pl_ius = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_string);
+ pl_iusi = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_string, s_integer);
+ pl_iu = s7_make_circular_signature(s7, 1, 2, s_integer, s_pair_false);
+ pl_iuui = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_pair_false, s_integer);
+ pl_pi = s7_make_circular_signature(s7, 1, 2, s_pair, s_integer);
+ pl_iui = s7_make_circular_signature(s7, 2, 3, s_integer, 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_piu = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_pair_false);
+ pl_pit = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_any);
+ pl_t = s7_make_circular_signature(s7, 0, 1, s_any);
+ pl_tts = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_string);
+ pl_tti = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_integer);
+ pl_dust = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_any);
+ pl_dut = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_any);
+ pl_du = s7_make_circular_signature(s7, 1, 2, s_float, s_pair_false);
+ pl_dusr = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_real);
+ pl_dus = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_string);
+ pl_pr = s7_make_circular_signature(s7, 1, 2, s_pair, s_real);
+ pl_s = s7_make_circular_signature(s7, 0, 1, s_string);
pl_tsb = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_boolean);
pl_st = s7_make_circular_signature(s7, 1, 2, s_string, s_any);
pl_tsu = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_pair_false);
+ pl_tsig = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, 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_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_tsiuui = s7_make_circular_signature(s7, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer);
- pl_t = s7_make_circular_signature(s7, 0, 1, s_any);
- pl_psibiiiit = s7_make_circular_signature(s7, 8, 9, s_pair, s_string, s_integer, s_boolean, s_integer, s_integer, s_integer, s_integer, s_any);
- pl_psrrrb = s7_make_circular_signature(s7, 5, 6, s_pair, s_string, s_real, s_real, s_real, s_boolean);
- pl_sui = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_integer);
- pl_psu = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_pair_false);
- pl_psb = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_boolean);
- pl_su = s7_make_circular_signature(s7, 1, 2, s_string, s_pair_false);
- pl_sus = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_string);
- pl_ps = s7_make_circular_signature(s7, 1, 2, s_pair, s_string);
- pl_psi = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_integer);
- pl_psuit = s7_make_circular_signature(s7, 4, 5, s_pair, s_string, s_pair_false, s_integer, s_any);
- pl_psut = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_pair_false, s_any);
- pl_suuub = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_pair_false, s_pair_false, s_boolean);
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_igi = s7_make_circular_signature(s7, 2, 3, s_integer, s_gtk_enum_t, s_integer);
+ pl_gi = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_integer);
+ pl_ssig = s7_make_circular_signature(s7, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t);
+ pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, s_integer);
pl_tusiuiuit = s7_make_circular_signature(s7, 8, 9, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false, s_integer, s_any);
+ pl_turrrru = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_real, s_real, s_real, s_real, s_pair_false);
pl_tubu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_boolean, s_pair_false);
pl_tuurru = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_real, s_pair_false);
- pl_tuurrrrir = s7_make_circular_signature(s7, 8, 9, s_any, s_pair_false, s_pair_false, s_real, s_real, s_real, s_real, s_integer, s_real);
- pl_tuurrrri = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_pair_false, s_real, s_real, s_real, s_real, s_integer);
+ pl_tuurrrrgr = s7_make_circular_signature(s7, 8, 9, s_any, s_pair_false, s_pair_false, s_real, s_real, s_real, s_real, s_gtk_enum_t, s_real);
+ pl_tuurrrrg = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_pair_false, s_real, s_real, s_real, s_real, s_gtk_enum_t);
pl_tuuur = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_real);
+ pl_tusg = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_gtk_enum_t);
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_tuusb = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_boolean);
+ pl_tugui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_gtk_enum_t, s_pair_false, s_integer);
pl_turru = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_real, s_real, s_pair_false);
+ pl_tuuugi = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
pl_tuuuub = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean);
pl_tuttti = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_any, s_any, s_any, s_integer);
pl_tuuttti = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_pair_false, s_any, s_any, s_any, s_integer);
pl_tuisi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_string, s_integer);
- pl_turis = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_real, s_integer, s_string);
+ 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_tugug = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
+ pl_turgs = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_real, s_gtk_enum_t, s_string);
pl_tubi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_boolean, s_integer);
- pl_tuttiisi = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_any, s_any, s_integer, s_integer, s_string, s_integer);
+ pl_tuttigsi = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_any, s_any, s_integer, s_gtk_enum_t, s_string, 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_tuurb = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_boolean);
- pl_tuuiiiirrrri = 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_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_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_tuubbi = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_boolean, s_boolean, s_integer);
+ pl_tuubbig = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_pair_false, s_boolean, s_boolean, s_integer, s_gtk_enum_t);
pl_pt = s7_make_circular_signature(s7, 1, 2, s_pair, s_any);
pl_tuuti = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_any, s_integer);
pl_tubbi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_boolean, s_boolean, s_integer);
@@ -39543,6 +39932,12 @@ static void define_functions(void)
pl_tutui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_any, s_pair_false, s_integer);
pl_tutisi = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_any, s_integer, s_string, s_integer);
pl_tuuri = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_integer);
+ 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_tuuiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
+ pl_tugiiu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_gtk_enum_t, s_integer, s_integer, s_pair_false);
+ pl_tuugi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_tuit = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_any);
pl_tusr = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_real);
pl_tusrt = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_string, s_real, s_any);
pl_tusi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_integer);
@@ -39550,6 +39945,7 @@ static void define_functions(void)
pl_tuui = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_integer);
pl_tut = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_any);
pl_tuur = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_real);
+ pl_tuig = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_gtk_enum_t);
pl_tur = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_real);
pl_tub = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_boolean);
pl_tui = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_integer);
@@ -39558,86 +39954,149 @@ static void define_functions(void)
pl_tuiiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_integer, s_pair_false);
pl_tusb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_boolean);
pl_tuuut = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_any);
+ pl_tug = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_gtk_enum_t);
pl_tutb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_any, s_boolean);
pl_tust = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_any);
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_tuug = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_gtk_enum_t);
pl_tuibu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_boolean, s_pair_false);
pl_tuut = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_any);
- pl_tuiui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_pair_false, s_integer);
+ pl_tuuig = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t);
+ pl_tuguig = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_gtk_enum_t, s_pair_false, s_integer, s_gtk_enum_t);
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_tuuui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_integer);
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_tuiu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
+ pl_tugu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_pair_false);
pl_tuuir = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_real);
- pl_tuir = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_real);
+ 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_tuuui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, 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_tusu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_pair_false);
pl_tuusi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_integer);
- pl_tuit = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, 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_tuiu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
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_tusiis = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_string);
pl_tusiuiu = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false);
pl_tusiuibu = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_boolean, s_pair_false);
pl_tusiiu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_pair_false);
- pl_tusui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_string, s_pair_false, s_integer);
+ pl_tuuug = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t);
+ 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_tuiiiu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_integer, s_integer, s_integer, s_pair_false);
- pl_tuuiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
- pl_tuurbr = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
- pl_tuusit = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_string, s_integer, s_any);
+ pl_psgi = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_gtk_enum_t, s_integer);
+ pl_suiig = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_integer, s_integer, s_gtk_enum_t);
+ pl_sug = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_gtk_enum_t);
+ pl_psgbiiiit = s7_make_circular_signature(s7, 8, 9, s_pair, s_string, s_gtk_enum_t, s_boolean, s_integer, s_integer, s_integer, s_integer, s_any);
+ pl_psrrrb = s7_make_circular_signature(s7, 5, 6, s_pair, s_string, s_real, s_real, s_real, s_boolean);
+ pl_sui = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_integer);
+ pl_suuub = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_pair_false, s_pair_false, s_boolean);
+ pl_psu = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_pair_false);
+ pl_psb = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_boolean);
+ pl_su = s7_make_circular_signature(s7, 1, 2, s_string, s_pair_false);
+ pl_sus = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_string);
+ pl_ps = s7_make_circular_signature(s7, 1, 2, s_pair, s_string);
+ pl_psg = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_gtk_enum_t);
+ pl_psi = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_integer);
+ pl_psugt = s7_make_circular_signature(s7, 4, 5, s_pair, s_string, s_pair_false, s_gtk_enum_t, s_any);
+ pl_psut = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_pair_false, s_any);
+ pl_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t);
pl_pur = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_real);
+ pl_puuui = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_pair_false, s_pair_false, s_integer);
pl_puiu = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_integer, s_pair_false);
- pl_pusiiiu = s7_make_circular_signature(s7, 6, 7, s_pair, s_pair_false, s_string, s_integer, s_integer, s_integer, s_pair_false);
- pl_pusiiuiu = s7_make_circular_signature(s7, 7, 8, s_pair, s_pair_false, s_string, s_integer, s_integer, s_pair_false, s_integer, s_pair_false);
+ 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_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_pusiiugu = s7_make_circular_signature(s7, 7, 8, s_pair, s_pair_false, s_string, s_integer, s_integer, s_pair_false, s_gtk_enum_t, s_pair_false);
+ 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_puur = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_pair_false, s_real);
pl_puiiui = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_integer, s_integer, s_pair_false, s_integer);
+ pl_pugi = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_puuig = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t);
pl_pubi = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_boolean, s_integer);
- pl_puiiu = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_integer, s_integer, s_pair_false);
- pl_puuusuui = 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_integer);
+ pl_puiig = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_integer, s_integer, s_gtk_enum_t);
+ pl_puiigi = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_integer, s_integer, s_gtk_enum_t, s_integer);
+ pl_puigu = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_integer, s_gtk_enum_t, 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_pusi = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_string, s_integer);
+ pl_puri = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_real, s_integer);
+ pl_pusub = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_string, s_pair_false, s_boolean);
+ pl_pust = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_string, s_any);
+ pl_pub = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_boolean);
pl_pu = s7_make_circular_signature(s7, 1, 2, s_pair, s_pair_false);
pl_puutu = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_pair_false, s_any, s_pair_false);
pl_pui = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_integer);
pl_pusu = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_string, s_pair_false);
pl_pus = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_string);
+ pl_pug = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_gtk_enum_t);
pl_put = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_any);
- pl_pusiiu = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_string, s_integer, s_integer, s_pair_false);
- pl_pusi = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_string, s_integer);
+ pl_pusigu = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_string, s_integer, s_gtk_enum_t, s_pair_false);
+ pl_pusig = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_string, s_integer, s_gtk_enum_t);
pl_puui = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_pair_false, s_integer);
- pl_pub = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_boolean);
- pl_pust = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_string, s_any);
- pl_pusub = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_string, s_pair_false, s_boolean);
- pl_puri = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_real, s_integer);
+ pl_pusiiu = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_string, 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_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_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_gus = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_string);
+ pl_guut = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any);
+ 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_guiu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_integer, s_pair_false);
+ pl_guugbut = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_pair_false, s_gtk_enum_t, s_boolean, s_pair_false, s_any);
+ pl_pgr = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_real);
+ pl_pgu = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_pair_false);
+ pl_pgi = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_integer);
+ pl_gug = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
+ pl_pgbi = s7_make_circular_signature(s7, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer);
+ pl_gu = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_pair_false);
+ pl_gugu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_gtk_enum_t, s_pair_false);
+ pl_pg = s7_make_circular_signature(s7, 1, 2, s_pair, s_gtk_enum_t);
+ pl_gui = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_integer);
+ pl_big = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_gtk_enum_t);
pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer);
- pl_bsiu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_string, s_integer, s_pair_false);
- pl_bsiuub = s7_make_circular_signature(s7, 5, 6, s_boolean, s_string, s_integer, s_pair_false, s_pair_false, s_boolean);
- pl_bsu = s7_make_circular_signature(s7, 2, 3, s_boolean, s_string, s_pair_false);
- pl_bsiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_string, s_integer, s_integer, s_boolean);
- pl_bsiiuusu = s7_make_circular_signature(s7, 7, 8, s_boolean, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_string, s_pair_false);
pl_b = s7_make_circular_signature(s7, 0, 1, s_boolean);
pl_btiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean);
pl_bti = s7_make_circular_signature(s7, 2, 3, s_boolean, s_any, 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_bsiu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_string, s_integer, s_pair_false);
+ pl_bsiuub = s7_make_circular_signature(s7, 5, 6, s_boolean, s_string, s_integer, s_pair_false, s_pair_false, s_boolean);
+ pl_bsu = s7_make_circular_signature(s7, 2, 3, s_boolean, s_string, s_pair_false);
+ pl_bsigb = s7_make_circular_signature(s7, 4, 5, s_boolean, s_string, s_integer, s_gtk_enum_t, s_boolean);
+ pl_bsiiuusu = s7_make_circular_signature(s7, 7, 8, s_boolean, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_string, s_pair_false);
pl_bur = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_real);
+ pl_buug = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_gtk_enum_t);
pl_buut = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_any);
+ pl_buigu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_gtk_enum_t, s_pair_false);
+ pl_busiu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_pair_false);
pl_buuti = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_any, s_integer);
pl_buttiiiu = s7_make_circular_signature(s7, 7, 8, s_boolean, s_pair_false, s_any, s_any, s_integer, s_integer, s_integer, s_pair_false);
pl_butib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_any, s_integer, s_boolean);
- pl_buiui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_pair_false, s_integer);
- pl_buuusuui = 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_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_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_buuit = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_any);
pl_butu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_any, s_pair_false);
pl_buti = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_any, s_integer);
pl_butti = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_integer);
pl_busi = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_integer);
+ pl_buusib = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean);
+ pl_busib = s7_make_circular_signature(s7, 4, 5, s_boolean, 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_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_buurbr = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
+ 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_buuui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer);
pl_busu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_pair_false);
- pl_bui = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_integer);
+ pl_bug = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_gtk_enum_t);
pl_bu = s7_make_circular_signature(s7, 1, 2, s_boolean, s_pair_false);
pl_buuubu = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_boolean, s_pair_false);
pl_bus = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_string);
+ pl_bui = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_integer);
pl_buutuuiu = s7_make_circular_signature(s7, 7, 8, s_boolean, s_pair_false, s_pair_false, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
pl_but = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_any);
pl_bussu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_string, s_pair_false);
@@ -39647,63 +40106,27 @@ static void define_functions(void)
pl_bub = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_boolean);
pl_buub = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_boolean);
pl_pb = s7_make_circular_signature(s7, 1, 2, s_pair, s_boolean);
+ pl_buig = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_gtk_enum_t);
pl_buuiiu = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_integer, s_integer, s_pair_false);
- pl_buui = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_integer);
- pl_buuui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, 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_buurbr = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
- pl_busiu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_pair_false);
- pl_buttu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_pair_false);
- pl_buuub = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, 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_busib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_boolean);
- pl_buusib = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean);
+ pl_buuig = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t);
pl_iiit = s7_make_circular_signature(s7, 3, 4, s_integer, s_integer, s_integer, s_any);
pl_iit = s7_make_circular_signature(s7, 2, 3, s_integer, s_integer, s_any);
- pl_isiiutttiiu = s7_make_circular_signature(s7, 10, 11, s_integer, s_string, s_integer, s_integer, s_pair_false, s_any, s_any, s_any, s_integer, s_integer, s_pair_false);
- pl_isi = s7_make_circular_signature(s7, 2, 3, s_integer, s_string, s_integer);
- pl_isit = s7_make_circular_signature(s7, 3, 4, s_integer, s_string, s_integer, s_any);
- 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_i = s7_make_circular_signature(s7, 0, 1, s_integer);
pl_itiiub = s7_make_circular_signature(s7, 5, 6, s_integer, s_any, s_integer, s_integer, s_pair_false, s_boolean);
pl_itsub = s7_make_circular_signature(s7, 4, 5, s_integer, s_any, s_string, s_pair_false, s_boolean);
- pl_itsttti = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_string, s_any, s_any, s_any, s_integer);
- pl_itiiiut = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_integer, s_integer, s_integer, s_pair_false, s_any);
+ 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_tiu = s7_make_circular_signature(s7, 2, 3, s_any, s_integer, s_pair_false);
- pl_it = s7_make_circular_signature(s7, 1, 2, s_integer, s_any);
pl_ti = s7_make_circular_signature(s7, 1, 2, s_any, s_integer);
- pl_iur = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_real);
- pl_iussitu = s7_make_circular_signature(s7, 6, 7, s_integer, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false);
- pl_iurrsiu = s7_make_circular_signature(s7, 6, 7, s_integer, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false);
- pl_iuut = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_pair_false, s_any);
- pl_iuuut = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_pair_false, s_pair_false, s_any);
- pl_pir = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_real);
- pl_iuisi = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_integer, s_string, s_integer);
- pl_pibi = s7_make_circular_signature(s7, 3, 4, s_pair, s_integer, s_boolean, s_integer);
- pl_iuuui = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_pair_false, s_pair_false, 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_ius = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_string);
- pl_iusi = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_string, s_integer);
- pl_iu = s7_make_circular_signature(s7, 1, 2, s_integer, s_pair_false);
- pl_iuiu = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_integer, s_pair_false);
- pl_iuui = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_pair_false, s_integer);
- pl_pi = s7_make_circular_signature(s7, 1, 2, s_pair, s_integer);
- pl_iui = s7_make_circular_signature(s7, 2, 3, s_integer, 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_piu = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_pair_false);
- pl_pit = s7_make_circular_signature(s7, 2, 3, s_pair, s_integer, s_any);
- pl_iuis = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_integer, s_string);
+ pl_it = s7_make_circular_signature(s7, 1, 2, s_integer, 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_isi = s7_make_circular_signature(s7, 2, 3, s_integer, s_string, s_integer);
+ pl_isgt = s7_make_circular_signature(s7, 3, 4, s_integer, s_string, s_gtk_enum_t, s_any);
+ pl_sig = s7_make_circular_signature(s7, 2, 3, s_string, s_integer, s_gtk_enum_t);
+ 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_trrru = s7_make_circular_signature(s7, 4, 5, s_any, s_real, s_real, s_real, s_pair_false);
- pl_dusr = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_real);
- pl_dust = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_any);
- pl_dut = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_any);
- pl_du = s7_make_circular_signature(s7, 1, 2, s_float, s_pair_false);
- pl_dus = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_string);
- pl_pr = s7_make_circular_signature(s7, 1, 2, s_pair, s_real);
- pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, s_integer);
- pl_s = s7_make_circular_signature(s7, 0, 1, s_string);
-pl_unused = NULL;
+ pl_bpt = s7_make_signature(s7, 2, s_pair_false, s_any);
#endif
Xg_define_procedure(g_unichar_validate, gxg_g_unichar_validate_w, 1, 0, 0, H_g_unichar_validate, pl_bi);
@@ -39744,12 +40167,12 @@ pl_unused = NULL;
Xg_define_procedure(g_utf8_strup, gxg_g_utf8_strup_w, 2, 0, 0, H_g_utf8_strup, pl_ssi);
Xg_define_procedure(g_utf8_strdown, gxg_g_utf8_strdown_w, 2, 0, 0, H_g_utf8_strdown, pl_ssi);
Xg_define_procedure(g_utf8_casefold, gxg_g_utf8_casefold_w, 2, 0, 0, H_g_utf8_casefold, pl_ssi);
- Xg_define_procedure(g_utf8_normalize, gxg_g_utf8_normalize_w, 3, 0, 0, H_g_utf8_normalize, pl_ssi);
+ Xg_define_procedure(g_utf8_normalize, gxg_g_utf8_normalize_w, 3, 0, 0, H_g_utf8_normalize, pl_ssig);
Xg_define_procedure(g_utf8_collate, gxg_g_utf8_collate_w, 2, 0, 0, H_g_utf8_collate, pl_is);
Xg_define_procedure(g_utf8_collate_key, gxg_g_utf8_collate_key_w, 2, 0, 0, H_g_utf8_collate_key, pl_ssi);
Xg_define_procedure(g_utf8_collate_key_for_filename, gxg_g_utf8_collate_key_for_filename_w, 2, 0, 0, H_g_utf8_collate_key_for_filename, pl_ssi);
Xg_define_procedure(g_cclosure_new, gxg_g_cclosure_new_w, 3, 0, 0, H_g_cclosure_new, pl_pt);
- Xg_define_procedure(g_signal_newv, gxg_g_signal_newv_w, 0, 0, 1, H_g_signal_newv, pl_isiiutttiiu);
+ Xg_define_procedure(g_signal_newv, gxg_g_signal_newv_w, 0, 0, 1, H_g_signal_newv, pl_isigutttiiu);
Xg_define_procedure(g_signal_lookup, gxg_g_signal_lookup_w, 2, 0, 0, H_g_signal_lookup, pl_isi);
Xg_define_procedure(g_signal_name, gxg_g_signal_name_w, 1, 0, 0, H_g_signal_name, pl_si);
Xg_define_procedure(g_signal_query, gxg_g_signal_query_w, 2, 0, 0, H_g_signal_query, pl_tiu);
@@ -39763,22 +40186,22 @@ pl_unused = NULL;
Xg_define_procedure(g_signal_has_handler_pending, gxg_g_signal_has_handler_pending_w, 4, 0, 0, H_g_signal_has_handler_pending, pl_btiib);
Xg_define_procedure(g_signal_connect_closure_by_id, gxg_g_signal_connect_closure_by_id_w, 5, 0, 0, H_g_signal_connect_closure_by_id, pl_itiiub);
Xg_define_procedure(g_signal_connect_closure, gxg_g_signal_connect_closure_w, 4, 0, 0, H_g_signal_connect_closure, pl_itsub);
- Xg_define_procedure(g_signal_connect_data, gxg_g_signal_connect_data_w, 6, 0, 0, H_g_signal_connect_data, pl_itsttti);
+ Xg_define_procedure(g_signal_connect_data, gxg_g_signal_connect_data_w, 6, 0, 0, H_g_signal_connect_data, pl_itstttg);
Xg_define_procedure(g_signal_handler_block, gxg_g_signal_handler_block_w, 2, 0, 0, H_g_signal_handler_block, pl_tti);
Xg_define_procedure(g_signal_handler_unblock, gxg_g_signal_handler_unblock_w, 2, 0, 0, H_g_signal_handler_unblock, pl_tti);
Xg_define_procedure(g_signal_handler_disconnect, gxg_g_signal_handler_disconnect_w, 2, 0, 0, H_g_signal_handler_disconnect, pl_tti);
Xg_define_procedure(g_signal_handler_is_connected, gxg_g_signal_handler_is_connected_w, 2, 0, 0, H_g_signal_handler_is_connected, pl_bti);
- Xg_define_procedure(g_signal_handler_find, gxg_g_signal_handler_find_w, 7, 0, 0, H_g_signal_handler_find, pl_itiiiut);
- Xg_define_procedure(g_signal_handlers_block_matched, gxg_g_signal_handlers_block_matched_w, 7, 0, 0, H_g_signal_handlers_block_matched, pl_itiiiut);
- Xg_define_procedure(g_signal_handlers_unblock_matched, gxg_g_signal_handlers_unblock_matched_w, 7, 0, 0, H_g_signal_handlers_unblock_matched, pl_itiiiut);
- Xg_define_procedure(g_signal_handlers_disconnect_matched, gxg_g_signal_handlers_disconnect_matched_w, 7, 0, 0, H_g_signal_handlers_disconnect_matched, pl_itiiiut);
+ Xg_define_procedure(g_signal_handler_find, gxg_g_signal_handler_find_w, 7, 0, 0, H_g_signal_handler_find, pl_itgiiut);
+ Xg_define_procedure(g_signal_handlers_block_matched, gxg_g_signal_handlers_block_matched_w, 7, 0, 0, H_g_signal_handlers_block_matched, pl_itgiiut);
+ Xg_define_procedure(g_signal_handlers_unblock_matched, gxg_g_signal_handlers_unblock_matched_w, 7, 0, 0, H_g_signal_handlers_unblock_matched, pl_itgiiut);
+ Xg_define_procedure(g_signal_handlers_disconnect_matched, gxg_g_signal_handlers_disconnect_matched_w, 7, 0, 0, H_g_signal_handlers_disconnect_matched, pl_itgiiut);
Xg_define_procedure(g_signal_handlers_destroy, gxg_g_signal_handlers_destroy_w, 1, 0, 0, H_g_signal_handlers_destroy, pl_t);
Xg_define_procedure(g_object_ref, gxg_g_object_ref_w, 1, 0, 0, H_g_object_ref, pl_t);
Xg_define_procedure(g_object_unref, gxg_g_object_unref_w, 1, 0, 0, H_g_object_unref, pl_t);
Xg_define_procedure(gdk_visual_get_system, gxg_gdk_visual_get_system_w, 0, 0, 0, H_gdk_visual_get_system, pl_p);
- Xg_define_procedure(gdk_cursor_new_for_display, gxg_gdk_cursor_new_for_display_w, 2, 0, 0, H_gdk_cursor_new_for_display, pl_pui);
+ Xg_define_procedure(gdk_cursor_new_for_display, gxg_gdk_cursor_new_for_display_w, 2, 0, 0, H_gdk_cursor_new_for_display, pl_pug);
Xg_define_procedure(gdk_cursor_get_display, gxg_gdk_cursor_get_display_w, 1, 0, 0, H_gdk_cursor_get_display, pl_pu);
- Xg_define_procedure(gdk_drag_status, gxg_gdk_drag_status_w, 3, 0, 0, H_gdk_drag_status, pl_tui);
+ Xg_define_procedure(gdk_drag_status, gxg_gdk_drag_status_w, 3, 0, 0, H_gdk_drag_status, pl_tugi);
Xg_define_procedure(gdk_drop_reply, gxg_gdk_drop_reply_w, 3, 0, 0, H_gdk_drop_reply, pl_tubi);
Xg_define_procedure(gdk_drop_finish, gxg_gdk_drop_finish_w, 3, 0, 0, H_gdk_drop_finish, pl_tubi);
Xg_define_procedure(gdk_drag_get_selection, gxg_gdk_drag_get_selection_w, 1, 0, 0, H_gdk_drag_get_selection, pl_tu);
@@ -39819,7 +40242,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_keymap_lookup_key, gxg_gdk_keymap_lookup_key_w, 2, 0, 0, H_gdk_keymap_lookup_key, pl_iu);
Xg_define_procedure(gdk_keymap_get_entries_for_keyval, gxg_gdk_keymap_get_entries_for_keyval_w, 2, 2, 0, H_gdk_keymap_get_entries_for_keyval, pl_buiu);
Xg_define_procedure(gdk_keymap_get_entries_for_keycode, gxg_gdk_keymap_get_entries_for_keycode_w, 2, 3, 0, H_gdk_keymap_get_entries_for_keycode, pl_buiu);
- Xg_define_procedure(gdk_keymap_get_direction, gxg_gdk_keymap_get_direction_w, 1, 0, 0, H_gdk_keymap_get_direction, pl_iu);
+ Xg_define_procedure(gdk_keymap_get_direction, gxg_gdk_keymap_get_direction_w, 1, 0, 0, H_gdk_keymap_get_direction, pl_gu);
Xg_define_procedure(gdk_keyval_name, gxg_gdk_keyval_name_w, 1, 0, 0, H_gdk_keyval_name, pl_si);
Xg_define_procedure(gdk_keyval_from_name, gxg_gdk_keyval_from_name_w, 1, 0, 0, H_gdk_keyval_from_name, pl_is);
Xg_define_procedure(gdk_keyval_convert_case, gxg_gdk_keyval_convert_case_w, 1, 2, 0, H_gdk_keyval_convert_case, pl_tiu);
@@ -39833,7 +40256,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_atom_intern, gxg_gdk_atom_intern_w, 2, 0, 0, H_gdk_atom_intern, pl_tsb);
Xg_define_procedure(gdk_atom_name, gxg_gdk_atom_name_w, 1, 0, 0, H_gdk_atom_name, pl_st);
Xg_define_procedure(gdk_property_get, gxg_gdk_property_get_w, 0, 0, 1, H_gdk_property_get, pl_buttiiiu);
- Xg_define_procedure(gdk_property_change, gxg_gdk_property_change_w, 7, 0, 0, H_gdk_property_change, pl_tuttiisi);
+ Xg_define_procedure(gdk_property_change, gxg_gdk_property_change_w, 7, 0, 0, H_gdk_property_change, pl_tuttigsi);
Xg_define_procedure(gdk_property_delete, gxg_gdk_property_delete_w, 2, 0, 0, H_gdk_property_delete, pl_tut);
Xg_define_procedure(gdk_utf8_to_string_target, gxg_gdk_utf8_to_string_target_w, 1, 0, 0, H_gdk_utf8_to_string_target, pl_s);
Xg_define_procedure(gdk_selection_owner_set, gxg_gdk_selection_owner_set_w, 4, 0, 0, H_gdk_selection_owner_set, pl_butib);
@@ -39841,17 +40264,17 @@ pl_unused = NULL;
Xg_define_procedure(gdk_selection_convert, gxg_gdk_selection_convert_w, 4, 0, 0, H_gdk_selection_convert, pl_tutti);
Xg_define_procedure(gdk_selection_property_get, gxg_gdk_selection_property_get_w, 1, 3, 0, H_gdk_selection_property_get, pl_bu);
Xg_define_procedure(gdk_visual_get_best_depth, gxg_gdk_visual_get_best_depth_w, 0, 0, 0, H_gdk_visual_get_best_depth, pl_i);
- Xg_define_procedure(gdk_visual_get_best_type, gxg_gdk_visual_get_best_type_w, 0, 0, 0, H_gdk_visual_get_best_type, pl_i);
+ Xg_define_procedure(gdk_visual_get_best_type, gxg_gdk_visual_get_best_type_w, 0, 0, 0, H_gdk_visual_get_best_type, pl_g);
Xg_define_procedure(gdk_visual_get_best, gxg_gdk_visual_get_best_w, 0, 0, 0, H_gdk_visual_get_best, pl_p);
Xg_define_procedure(gdk_visual_get_best_with_depth, gxg_gdk_visual_get_best_with_depth_w, 1, 0, 0, H_gdk_visual_get_best_with_depth, pl_pi);
- Xg_define_procedure(gdk_visual_get_best_with_type, gxg_gdk_visual_get_best_with_type_w, 1, 0, 0, H_gdk_visual_get_best_with_type, pl_pi);
- Xg_define_procedure(gdk_visual_get_best_with_both, gxg_gdk_visual_get_best_with_both_w, 2, 0, 0, H_gdk_visual_get_best_with_both, pl_pi);
+ Xg_define_procedure(gdk_visual_get_best_with_type, gxg_gdk_visual_get_best_with_type_w, 1, 0, 0, H_gdk_visual_get_best_with_type, pl_pg);
+ Xg_define_procedure(gdk_visual_get_best_with_both, gxg_gdk_visual_get_best_with_both_w, 2, 0, 0, H_gdk_visual_get_best_with_both, pl_pig);
Xg_define_procedure(gdk_query_depths, gxg_gdk_query_depths_w, 0, 2, 0, H_gdk_query_depths, pl_tu);
Xg_define_procedure(gdk_query_visual_types, gxg_gdk_query_visual_types_w, 0, 2, 0, H_gdk_query_visual_types, pl_tu);
Xg_define_procedure(gdk_list_visuals, gxg_gdk_list_visuals_w, 0, 0, 0, H_gdk_list_visuals, pl_p);
Xg_define_procedure(gdk_window_new, gxg_gdk_window_new_w, 3, 0, 0, H_gdk_window_new, pl_puui);
Xg_define_procedure(gdk_window_destroy, gxg_gdk_window_destroy_w, 1, 0, 0, H_gdk_window_destroy, pl_tu);
- Xg_define_procedure(gdk_window_get_window_type, gxg_gdk_window_get_window_type_w, 1, 0, 0, H_gdk_window_get_window_type, pl_iu);
+ Xg_define_procedure(gdk_window_get_window_type, gxg_gdk_window_get_window_type_w, 1, 0, 0, H_gdk_window_get_window_type, pl_gu);
Xg_define_procedure(gdk_window_show, gxg_gdk_window_show_w, 1, 0, 0, H_gdk_window_show, pl_tu);
Xg_define_procedure(gdk_window_hide, gxg_gdk_window_hide_w, 1, 0, 0, H_gdk_window_hide, pl_tu);
Xg_define_procedure(gdk_window_withdraw, gxg_gdk_window_withdraw_w, 1, 0, 0, H_gdk_window_withdraw, pl_tu);
@@ -39872,21 +40295,21 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_merge_child_shapes, gxg_gdk_window_merge_child_shapes_w, 1, 0, 0, H_gdk_window_merge_child_shapes, pl_tu);
Xg_define_procedure(gdk_window_is_visible, gxg_gdk_window_is_visible_w, 1, 0, 0, H_gdk_window_is_visible, pl_bu);
Xg_define_procedure(gdk_window_is_viewable, gxg_gdk_window_is_viewable_w, 1, 0, 0, H_gdk_window_is_viewable, pl_bu);
- Xg_define_procedure(gdk_window_get_state, gxg_gdk_window_get_state_w, 1, 0, 0, H_gdk_window_get_state, pl_iu);
+ Xg_define_procedure(gdk_window_get_state, gxg_gdk_window_get_state_w, 1, 0, 0, H_gdk_window_get_state, pl_gu);
Xg_define_procedure(gdk_window_get_root_origin, gxg_gdk_window_get_root_origin_w, 1, 2, 0, H_gdk_window_get_root_origin, pl_tu);
Xg_define_procedure(gdk_window_get_frame_extents, gxg_gdk_window_get_frame_extents_w, 2, 0, 0, H_gdk_window_get_frame_extents, pl_tu);
Xg_define_procedure(gdk_window_get_parent, gxg_gdk_window_get_parent_w, 1, 0, 0, H_gdk_window_get_parent, pl_pu);
Xg_define_procedure(gdk_window_get_toplevel, gxg_gdk_window_get_toplevel_w, 1, 0, 0, H_gdk_window_get_toplevel, pl_pu);
Xg_define_procedure(gdk_window_get_children, gxg_gdk_window_get_children_w, 1, 0, 0, H_gdk_window_get_children, pl_pu);
Xg_define_procedure(gdk_window_peek_children, gxg_gdk_window_peek_children_w, 1, 0, 0, H_gdk_window_peek_children, pl_pu);
- Xg_define_procedure(gdk_window_get_events, gxg_gdk_window_get_events_w, 1, 0, 0, H_gdk_window_get_events, pl_iu);
- Xg_define_procedure(gdk_window_set_events, gxg_gdk_window_set_events_w, 2, 0, 0, H_gdk_window_set_events, pl_tui);
+ Xg_define_procedure(gdk_window_get_events, gxg_gdk_window_get_events_w, 1, 0, 0, H_gdk_window_get_events, pl_gu);
+ Xg_define_procedure(gdk_window_set_events, gxg_gdk_window_set_events_w, 2, 0, 0, H_gdk_window_set_events, pl_tug);
Xg_define_procedure(gdk_window_set_icon_list, gxg_gdk_window_set_icon_list_w, 2, 0, 0, H_gdk_window_set_icon_list, pl_tu);
Xg_define_procedure(gdk_window_set_icon_name, gxg_gdk_window_set_icon_name_w, 2, 0, 0, H_gdk_window_set_icon_name, pl_tus);
Xg_define_procedure(gdk_window_set_group, gxg_gdk_window_set_group_w, 2, 0, 0, H_gdk_window_set_group, pl_tu);
- Xg_define_procedure(gdk_window_set_decorations, gxg_gdk_window_set_decorations_w, 2, 0, 0, H_gdk_window_set_decorations, pl_tui);
+ Xg_define_procedure(gdk_window_set_decorations, gxg_gdk_window_set_decorations_w, 2, 0, 0, H_gdk_window_set_decorations, pl_tug);
Xg_define_procedure(gdk_window_get_decorations, gxg_gdk_window_get_decorations_w, 1, 1, 0, H_gdk_window_get_decorations, pl_bu);
- Xg_define_procedure(gdk_window_set_functions, gxg_gdk_window_set_functions_w, 2, 0, 0, H_gdk_window_set_functions, pl_tui);
+ Xg_define_procedure(gdk_window_set_functions, gxg_gdk_window_set_functions_w, 2, 0, 0, H_gdk_window_set_functions, pl_tug);
Xg_define_procedure(gdk_window_iconify, gxg_gdk_window_iconify_w, 1, 0, 0, H_gdk_window_iconify, pl_tu);
Xg_define_procedure(gdk_window_deiconify, gxg_gdk_window_deiconify_w, 1, 0, 0, H_gdk_window_deiconify, pl_tu);
Xg_define_procedure(gdk_window_stick, gxg_gdk_window_stick_w, 1, 0, 0, H_gdk_window_stick, pl_tu);
@@ -39894,7 +40317,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_maximize, gxg_gdk_window_maximize_w, 1, 0, 0, H_gdk_window_maximize, pl_tu);
Xg_define_procedure(gdk_window_unmaximize, gxg_gdk_window_unmaximize_w, 1, 0, 0, H_gdk_window_unmaximize, pl_tu);
Xg_define_procedure(gdk_window_register_dnd, gxg_gdk_window_register_dnd_w, 1, 0, 0, H_gdk_window_register_dnd, pl_tu);
- Xg_define_procedure(gdk_window_begin_resize_drag, gxg_gdk_window_begin_resize_drag_w, 6, 0, 0, H_gdk_window_begin_resize_drag, pl_tui);
+ Xg_define_procedure(gdk_window_begin_resize_drag, gxg_gdk_window_begin_resize_drag_w, 6, 0, 0, H_gdk_window_begin_resize_drag, pl_tugi);
Xg_define_procedure(gdk_window_begin_move_drag, gxg_gdk_window_begin_move_drag_w, 5, 0, 0, H_gdk_window_begin_move_drag, pl_tui);
Xg_define_procedure(gdk_window_invalidate_rect, gxg_gdk_window_invalidate_rect_w, 3, 0, 0, H_gdk_window_invalidate_rect, pl_tuub);
Xg_define_procedure(gdk_window_freeze_updates, gxg_gdk_window_freeze_updates_w, 1, 0, 0, H_gdk_window_freeze_updates, pl_tu);
@@ -39902,10 +40325,10 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_process_all_updates, gxg_gdk_window_process_all_updates_w, 0, 0, 0, H_gdk_window_process_all_updates, pl_t);
Xg_define_procedure(gdk_window_process_updates, gxg_gdk_window_process_updates_w, 2, 0, 0, H_gdk_window_process_updates, pl_tub);
Xg_define_procedure(gdk_window_set_debug_updates, gxg_gdk_window_set_debug_updates_w, 1, 0, 0, H_gdk_window_set_debug_updates, pl_tb);
- Xg_define_procedure(gdk_window_constrain_size, gxg_gdk_window_constrain_size_w, 4, 2, 0, H_gdk_window_constrain_size, pl_tuiiiu);
- Xg_define_procedure(gdk_window_set_type_hint, gxg_gdk_window_set_type_hint_w, 2, 0, 0, H_gdk_window_set_type_hint, pl_tui);
+ Xg_define_procedure(gdk_window_constrain_size, gxg_gdk_window_constrain_size_w, 4, 2, 0, H_gdk_window_constrain_size, pl_tugiiu);
+ Xg_define_procedure(gdk_window_set_type_hint, gxg_gdk_window_set_type_hint_w, 2, 0, 0, H_gdk_window_set_type_hint, pl_tug);
Xg_define_procedure(gdk_window_set_modal_hint, gxg_gdk_window_set_modal_hint_w, 2, 0, 0, H_gdk_window_set_modal_hint, pl_tub);
- Xg_define_procedure(gdk_window_set_geometry_hints, gxg_gdk_window_set_geometry_hints_w, 3, 0, 0, H_gdk_window_set_geometry_hints, pl_tuui);
+ Xg_define_procedure(gdk_window_set_geometry_hints, gxg_gdk_window_set_geometry_hints_w, 3, 0, 0, H_gdk_window_set_geometry_hints, pl_tuug);
Xg_define_procedure(gdk_window_begin_paint_rect, gxg_gdk_window_begin_paint_rect_w, 2, 0, 0, H_gdk_window_begin_paint_rect, pl_tu);
Xg_define_procedure(gdk_window_end_paint, gxg_gdk_window_end_paint_w, 1, 0, 0, H_gdk_window_end_paint, pl_tu);
Xg_define_procedure(gdk_window_set_title, gxg_gdk_window_set_title_w, 2, 0, 0, H_gdk_window_set_title, pl_tus);
@@ -39917,7 +40340,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_get_origin, gxg_gdk_window_get_origin_w, 1, 2, 0, H_gdk_window_get_origin, pl_iu);
Xg_define_procedure(gdk_get_default_root_window, gxg_gdk_get_default_root_window_w, 0, 0, 0, H_gdk_get_default_root_window, pl_p);
Xg_define_procedure(gdk_pixbuf_error_quark, gxg_gdk_pixbuf_error_quark_w, 0, 0, 0, H_gdk_pixbuf_error_quark, pl_i);
- Xg_define_procedure(gdk_pixbuf_get_colorspace, gxg_gdk_pixbuf_get_colorspace_w, 1, 0, 0, H_gdk_pixbuf_get_colorspace, pl_iu);
+ Xg_define_procedure(gdk_pixbuf_get_colorspace, gxg_gdk_pixbuf_get_colorspace_w, 1, 0, 0, H_gdk_pixbuf_get_colorspace, pl_gu);
Xg_define_procedure(gdk_pixbuf_get_n_channels, gxg_gdk_pixbuf_get_n_channels_w, 1, 0, 0, H_gdk_pixbuf_get_n_channels, pl_iu);
Xg_define_procedure(gdk_pixbuf_get_has_alpha, gxg_gdk_pixbuf_get_has_alpha_w, 1, 0, 0, H_gdk_pixbuf_get_has_alpha, pl_bu);
Xg_define_procedure(gdk_pixbuf_get_bits_per_sample, gxg_gdk_pixbuf_get_bits_per_sample_w, 1, 0, 0, H_gdk_pixbuf_get_bits_per_sample, pl_iu);
@@ -39925,22 +40348,22 @@ pl_unused = NULL;
Xg_define_procedure(gdk_pixbuf_get_width, gxg_gdk_pixbuf_get_width_w, 1, 0, 0, H_gdk_pixbuf_get_width, pl_iu);
Xg_define_procedure(gdk_pixbuf_get_height, gxg_gdk_pixbuf_get_height_w, 1, 0, 0, H_gdk_pixbuf_get_height, pl_iu);
Xg_define_procedure(gdk_pixbuf_get_rowstride, gxg_gdk_pixbuf_get_rowstride_w, 1, 0, 0, H_gdk_pixbuf_get_rowstride, pl_iu);
- Xg_define_procedure(gdk_pixbuf_new, gxg_gdk_pixbuf_new_w, 5, 0, 0, H_gdk_pixbuf_new, pl_pibi);
+ Xg_define_procedure(gdk_pixbuf_new, gxg_gdk_pixbuf_new_w, 5, 0, 0, H_gdk_pixbuf_new, pl_pgbi);
Xg_define_procedure(gdk_pixbuf_copy, gxg_gdk_pixbuf_copy_w, 1, 0, 0, H_gdk_pixbuf_copy, pl_pu);
Xg_define_procedure(gdk_pixbuf_new_subpixbuf, gxg_gdk_pixbuf_new_subpixbuf_w, 5, 0, 0, H_gdk_pixbuf_new_subpixbuf, pl_pui);
Xg_define_procedure(gdk_pixbuf_new_from_file, gxg_gdk_pixbuf_new_from_file_w, 1, 1, 0, H_gdk_pixbuf_new_from_file, pl_psu);
- Xg_define_procedure(gdk_pixbuf_new_from_data, gxg_gdk_pixbuf_new_from_data_w, 0, 0, 1, H_gdk_pixbuf_new_from_data, pl_psibiiiit);
+ Xg_define_procedure(gdk_pixbuf_new_from_data, gxg_gdk_pixbuf_new_from_data_w, 0, 0, 1, H_gdk_pixbuf_new_from_data, pl_psgbiiiit);
Xg_define_procedure(gdk_pixbuf_new_from_xpm_data, gxg_gdk_pixbuf_new_from_xpm_data_w, 1, 0, 0, H_gdk_pixbuf_new_from_xpm_data, pl_pu);
Xg_define_procedure(gdk_pixbuf_fill, gxg_gdk_pixbuf_fill_w, 2, 0, 0, H_gdk_pixbuf_fill, pl_tui);
Xg_define_procedure(gdk_pixbuf_savev, gxg_gdk_pixbuf_savev_w, 5, 1, 0, H_gdk_pixbuf_savev, pl_bussu);
Xg_define_procedure(gdk_pixbuf_add_alpha, gxg_gdk_pixbuf_add_alpha_w, 5, 0, 0, H_gdk_pixbuf_add_alpha, pl_pubi);
Xg_define_procedure(gdk_pixbuf_copy_area, gxg_gdk_pixbuf_copy_area_w, 0, 0, 1, H_gdk_pixbuf_copy_area, pl_tuiiiiui);
Xg_define_procedure(gdk_pixbuf_saturate_and_pixelate, gxg_gdk_pixbuf_saturate_and_pixelate_w, 4, 0, 0, H_gdk_pixbuf_saturate_and_pixelate, pl_tuurb);
- Xg_define_procedure(gdk_pixbuf_scale, gxg_gdk_pixbuf_scale_w, 0, 0, 1, H_gdk_pixbuf_scale, pl_tuuiiiirrrri);
- Xg_define_procedure(gdk_pixbuf_composite, gxg_gdk_pixbuf_composite_w, 0, 0, 1, H_gdk_pixbuf_composite, pl_tuuiiiirrrri);
- Xg_define_procedure(gdk_pixbuf_composite_color, gxg_gdk_pixbuf_composite_color_w, 0, 0, 1, H_gdk_pixbuf_composite_color, pl_tuuiiiirrrri);
- Xg_define_procedure(gdk_pixbuf_scale_simple, gxg_gdk_pixbuf_scale_simple_w, 4, 0, 0, H_gdk_pixbuf_scale_simple, pl_pui);
- Xg_define_procedure(gdk_pixbuf_composite_color_simple, gxg_gdk_pixbuf_composite_color_simple_w, 0, 0, 1, H_gdk_pixbuf_composite_color_simple, pl_pui);
+ Xg_define_procedure(gdk_pixbuf_scale, gxg_gdk_pixbuf_scale_w, 0, 0, 1, H_gdk_pixbuf_scale, pl_tuuiiiirrrrg);
+ Xg_define_procedure(gdk_pixbuf_composite, gxg_gdk_pixbuf_composite_w, 0, 0, 1, H_gdk_pixbuf_composite, pl_tuuiiiirrrrgi);
+ Xg_define_procedure(gdk_pixbuf_composite_color, gxg_gdk_pixbuf_composite_color_w, 0, 0, 1, H_gdk_pixbuf_composite_color, pl_tuuiiiirrrrgi);
+ Xg_define_procedure(gdk_pixbuf_scale_simple, gxg_gdk_pixbuf_scale_simple_w, 4, 0, 0, H_gdk_pixbuf_scale_simple, pl_puiig);
+ Xg_define_procedure(gdk_pixbuf_composite_color_simple, gxg_gdk_pixbuf_composite_color_simple_w, 0, 0, 1, H_gdk_pixbuf_composite_color_simple, pl_puiigi);
Xg_define_procedure(gdk_pixbuf_animation_new_from_file, gxg_gdk_pixbuf_animation_new_from_file_w, 1, 1, 0, H_gdk_pixbuf_animation_new_from_file, pl_psu);
Xg_define_procedure(gdk_pixbuf_animation_get_width, gxg_gdk_pixbuf_animation_get_width_w, 1, 0, 0, H_gdk_pixbuf_animation_get_width, pl_iu);
Xg_define_procedure(gdk_pixbuf_animation_get_height, gxg_gdk_pixbuf_animation_get_height_w, 1, 0, 0, H_gdk_pixbuf_animation_get_height, pl_iu);
@@ -39955,29 +40378,29 @@ pl_unused = NULL;
Xg_define_procedure(gtk_accel_group_new, gxg_gtk_accel_group_new_w, 0, 0, 0, H_gtk_accel_group_new, pl_p);
Xg_define_procedure(gtk_accel_group_lock, gxg_gtk_accel_group_lock_w, 1, 0, 0, H_gtk_accel_group_lock, pl_tu);
Xg_define_procedure(gtk_accel_group_unlock, gxg_gtk_accel_group_unlock_w, 1, 0, 0, H_gtk_accel_group_unlock, pl_tu);
- Xg_define_procedure(gtk_accel_group_connect, gxg_gtk_accel_group_connect_w, 5, 0, 0, H_gtk_accel_group_connect, pl_tuiiiu);
+ Xg_define_procedure(gtk_accel_group_connect, gxg_gtk_accel_group_connect_w, 5, 0, 0, H_gtk_accel_group_connect, pl_tuiggu);
Xg_define_procedure(gtk_accel_group_connect_by_path, gxg_gtk_accel_group_connect_by_path_w, 3, 0, 0, H_gtk_accel_group_connect_by_path, pl_tusu);
Xg_define_procedure(gtk_accel_group_disconnect, gxg_gtk_accel_group_disconnect_w, 2, 0, 0, H_gtk_accel_group_disconnect, pl_bu);
- Xg_define_procedure(gtk_accel_group_disconnect_key, gxg_gtk_accel_group_disconnect_key_w, 3, 0, 0, H_gtk_accel_group_disconnect_key, pl_bui);
- Xg_define_procedure(gtk_accel_groups_activate, gxg_gtk_accel_groups_activate_w, 3, 0, 0, H_gtk_accel_groups_activate, pl_bui);
+ Xg_define_procedure(gtk_accel_group_disconnect_key, gxg_gtk_accel_group_disconnect_key_w, 3, 0, 0, H_gtk_accel_group_disconnect_key, pl_buig);
+ Xg_define_procedure(gtk_accel_groups_activate, gxg_gtk_accel_groups_activate_w, 3, 0, 0, H_gtk_accel_groups_activate, pl_buig);
Xg_define_procedure(gtk_accel_groups_from_object, gxg_gtk_accel_groups_from_object_w, 1, 0, 0, H_gtk_accel_groups_from_object, pl_pu);
Xg_define_procedure(gtk_accel_group_find, gxg_gtk_accel_group_find_w, 2, 1, 0, H_gtk_accel_group_find, pl_put);
Xg_define_procedure(gtk_accel_group_from_accel_closure, gxg_gtk_accel_group_from_accel_closure_w, 1, 0, 0, H_gtk_accel_group_from_accel_closure, pl_pu);
- Xg_define_procedure(gtk_accelerator_valid, gxg_gtk_accelerator_valid_w, 2, 0, 0, H_gtk_accelerator_valid, pl_bi);
+ Xg_define_procedure(gtk_accelerator_valid, gxg_gtk_accelerator_valid_w, 2, 0, 0, H_gtk_accelerator_valid, pl_big);
Xg_define_procedure(gtk_accelerator_parse, gxg_gtk_accelerator_parse_w, 1, 2, 0, H_gtk_accelerator_parse, pl_tsu);
- Xg_define_procedure(gtk_accelerator_name, gxg_gtk_accelerator_name_w, 2, 0, 0, H_gtk_accelerator_name, pl_si);
- Xg_define_procedure(gtk_accelerator_set_default_mod_mask, gxg_gtk_accelerator_set_default_mod_mask_w, 1, 0, 0, H_gtk_accelerator_set_default_mod_mask, pl_ti);
- Xg_define_procedure(gtk_accel_group_query, gxg_gtk_accel_group_query_w, 3, 1, 0, H_gtk_accel_group_query, pl_puiiu);
- Xg_define_procedure(gtk_accel_group_activate, gxg_gtk_accel_group_activate_w, 5, 0, 0, H_gtk_accel_group_activate, pl_buiui);
+ Xg_define_procedure(gtk_accelerator_name, gxg_gtk_accelerator_name_w, 2, 0, 0, H_gtk_accelerator_name, pl_sig);
+ Xg_define_procedure(gtk_accelerator_set_default_mod_mask, gxg_gtk_accelerator_set_default_mod_mask_w, 1, 0, 0, H_gtk_accelerator_set_default_mod_mask, pl_tg);
+ Xg_define_procedure(gtk_accel_group_query, gxg_gtk_accel_group_query_w, 3, 1, 0, H_gtk_accel_group_query, pl_puigu);
+ Xg_define_procedure(gtk_accel_group_activate, gxg_gtk_accel_group_activate_w, 5, 0, 0, H_gtk_accel_group_activate, pl_buiuig);
Xg_define_procedure(gtk_accel_label_new, gxg_gtk_accel_label_new_w, 1, 0, 0, H_gtk_accel_label_new, pl_ps);
Xg_define_procedure(gtk_accel_label_get_accel_widget, gxg_gtk_accel_label_get_accel_widget_w, 1, 0, 0, H_gtk_accel_label_get_accel_widget, pl_pu);
Xg_define_procedure(gtk_accel_label_get_accel_width, gxg_gtk_accel_label_get_accel_width_w, 1, 0, 0, H_gtk_accel_label_get_accel_width, pl_iu);
Xg_define_procedure(gtk_accel_label_set_accel_widget, gxg_gtk_accel_label_set_accel_widget_w, 2, 0, 0, H_gtk_accel_label_set_accel_widget, pl_tu);
Xg_define_procedure(gtk_accel_label_set_accel_closure, gxg_gtk_accel_label_set_accel_closure_w, 2, 0, 0, H_gtk_accel_label_set_accel_closure, pl_tu);
Xg_define_procedure(gtk_accel_label_refetch, gxg_gtk_accel_label_refetch_w, 1, 0, 0, H_gtk_accel_label_refetch, pl_bu);
- Xg_define_procedure(gtk_accel_map_add_entry, gxg_gtk_accel_map_add_entry_w, 3, 0, 0, H_gtk_accel_map_add_entry, pl_tsi);
+ Xg_define_procedure(gtk_accel_map_add_entry, gxg_gtk_accel_map_add_entry_w, 3, 0, 0, H_gtk_accel_map_add_entry, pl_tsig);
Xg_define_procedure(gtk_accel_map_lookup_entry, gxg_gtk_accel_map_lookup_entry_w, 2, 0, 0, H_gtk_accel_map_lookup_entry, pl_bsu);
- Xg_define_procedure(gtk_accel_map_change_entry, gxg_gtk_accel_map_change_entry_w, 4, 0, 0, H_gtk_accel_map_change_entry, pl_bsiib);
+ Xg_define_procedure(gtk_accel_map_change_entry, gxg_gtk_accel_map_change_entry_w, 4, 0, 0, H_gtk_accel_map_change_entry, pl_bsigb);
Xg_define_procedure(gtk_accel_map_load, gxg_gtk_accel_map_load_w, 1, 0, 0, H_gtk_accel_map_load, pl_ts);
Xg_define_procedure(gtk_accel_map_save, gxg_gtk_accel_map_save_w, 1, 0, 0, H_gtk_accel_map_save, pl_ts);
Xg_define_procedure(gtk_accel_map_foreach, gxg_gtk_accel_map_foreach_w, 2, 0, 0, H_gtk_accel_map_foreach, pl_t);
@@ -39990,13 +40413,13 @@ pl_unused = NULL;
Xg_define_procedure(gtk_adjustment_set_value, gxg_gtk_adjustment_set_value_w, 2, 0, 0, H_gtk_adjustment_set_value, pl_tur);
Xg_define_procedure(gtk_aspect_frame_new, gxg_gtk_aspect_frame_new_w, 5, 0, 0, H_gtk_aspect_frame_new, pl_psrrrb);
Xg_define_procedure(gtk_aspect_frame_set, gxg_gtk_aspect_frame_set_w, 5, 0, 0, H_gtk_aspect_frame_set, pl_turrrb);
- Xg_define_procedure(gtk_button_box_get_layout, gxg_gtk_button_box_get_layout_w, 1, 0, 0, H_gtk_button_box_get_layout, pl_iu);
- Xg_define_procedure(gtk_button_box_set_layout, gxg_gtk_button_box_set_layout_w, 2, 0, 0, H_gtk_button_box_set_layout, pl_tui);
+ Xg_define_procedure(gtk_button_box_get_layout, gxg_gtk_button_box_get_layout_w, 1, 0, 0, H_gtk_button_box_get_layout, pl_gu);
+ Xg_define_procedure(gtk_button_box_set_layout, gxg_gtk_button_box_set_layout_w, 2, 0, 0, H_gtk_button_box_set_layout, pl_tug);
Xg_define_procedure(gtk_button_box_set_child_secondary, gxg_gtk_button_box_set_child_secondary_w, 3, 0, 0, H_gtk_button_box_set_child_secondary, pl_tuub);
Xg_define_procedure(gtk_binding_set_new, gxg_gtk_binding_set_new_w, 1, 0, 0, H_gtk_binding_set_new, pl_ps);
Xg_define_procedure(gtk_binding_set_by_class, gxg_gtk_binding_set_by_class_w, 1, 0, 0, H_gtk_binding_set_by_class, pl_pt);
Xg_define_procedure(gtk_binding_set_find, gxg_gtk_binding_set_find_w, 1, 0, 0, H_gtk_binding_set_find, pl_ps);
- Xg_define_procedure(gtk_binding_entry_remove, gxg_gtk_binding_entry_remove_w, 3, 0, 0, H_gtk_binding_entry_remove, pl_tui);
+ Xg_define_procedure(gtk_binding_entry_remove, gxg_gtk_binding_entry_remove_w, 3, 0, 0, H_gtk_binding_entry_remove, pl_tuig);
Xg_define_procedure(gtk_bin_get_child, gxg_gtk_bin_get_child_w, 1, 0, 0, H_gtk_bin_get_child, pl_pu);
Xg_define_procedure(gtk_box_pack_start, gxg_gtk_box_pack_start_w, 5, 0, 0, H_gtk_box_pack_start, pl_tuubbi);
Xg_define_procedure(gtk_box_pack_end, gxg_gtk_box_pack_end_w, 5, 0, 0, H_gtk_box_pack_end, pl_tuubbi);
@@ -40006,13 +40429,13 @@ pl_unused = NULL;
Xg_define_procedure(gtk_box_get_spacing, gxg_gtk_box_get_spacing_w, 1, 0, 0, H_gtk_box_get_spacing, pl_iu);
Xg_define_procedure(gtk_box_reorder_child, gxg_gtk_box_reorder_child_w, 3, 0, 0, H_gtk_box_reorder_child, pl_tuui);
Xg_define_procedure(gtk_box_query_child_packing, gxg_gtk_box_query_child_packing_w, 2, 4, 0, H_gtk_box_query_child_packing, pl_tu);
- Xg_define_procedure(gtk_box_set_child_packing, gxg_gtk_box_set_child_packing_w, 6, 0, 0, H_gtk_box_set_child_packing, pl_tuubbi);
+ Xg_define_procedure(gtk_box_set_child_packing, gxg_gtk_box_set_child_packing_w, 6, 0, 0, H_gtk_box_set_child_packing, pl_tuubbig);
Xg_define_procedure(gtk_button_new, gxg_gtk_button_new_w, 0, 0, 0, H_gtk_button_new, pl_p);
Xg_define_procedure(gtk_button_new_with_label, gxg_gtk_button_new_with_label_w, 1, 0, 0, H_gtk_button_new_with_label, pl_ps);
Xg_define_procedure(gtk_button_new_with_mnemonic, gxg_gtk_button_new_with_mnemonic_w, 1, 0, 0, H_gtk_button_new_with_mnemonic, pl_ps);
Xg_define_procedure(gtk_button_clicked, gxg_gtk_button_clicked_w, 1, 0, 0, H_gtk_button_clicked, pl_tu);
- Xg_define_procedure(gtk_button_set_relief, gxg_gtk_button_set_relief_w, 2, 0, 0, H_gtk_button_set_relief, pl_tui);
- Xg_define_procedure(gtk_button_get_relief, gxg_gtk_button_get_relief_w, 1, 0, 0, H_gtk_button_get_relief, pl_iu);
+ Xg_define_procedure(gtk_button_set_relief, gxg_gtk_button_set_relief_w, 2, 0, 0, H_gtk_button_set_relief, pl_tug);
+ Xg_define_procedure(gtk_button_get_relief, gxg_gtk_button_get_relief_w, 1, 0, 0, H_gtk_button_get_relief, pl_gu);
Xg_define_procedure(gtk_button_set_label, gxg_gtk_button_set_label_w, 2, 0, 0, H_gtk_button_set_label, pl_tus);
Xg_define_procedure(gtk_button_get_label, gxg_gtk_button_get_label_w, 1, 0, 0, H_gtk_button_get_label, pl_su);
Xg_define_procedure(gtk_button_set_use_underline, gxg_gtk_button_set_use_underline_w, 2, 0, 0, H_gtk_button_set_use_underline, pl_tub);
@@ -40024,8 +40447,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_cell_editable_start_editing, gxg_gtk_cell_editable_start_editing_w, 2, 0, 0, H_gtk_cell_editable_start_editing, pl_tu);
Xg_define_procedure(gtk_cell_editable_editing_done, gxg_gtk_cell_editable_editing_done_w, 1, 0, 0, H_gtk_cell_editable_editing_done, pl_tu);
Xg_define_procedure(gtk_cell_editable_remove_widget, gxg_gtk_cell_editable_remove_widget_w, 1, 0, 0, H_gtk_cell_editable_remove_widget, pl_tu);
- Xg_define_procedure(gtk_cell_renderer_activate, gxg_gtk_cell_renderer_activate_w, 7, 0, 0, H_gtk_cell_renderer_activate, pl_buuusuui);
- Xg_define_procedure(gtk_cell_renderer_start_editing, gxg_gtk_cell_renderer_start_editing_w, 7, 0, 0, H_gtk_cell_renderer_start_editing, pl_puuusuui);
+ Xg_define_procedure(gtk_cell_renderer_activate, gxg_gtk_cell_renderer_activate_w, 7, 0, 0, H_gtk_cell_renderer_activate, pl_buuusuug);
+ Xg_define_procedure(gtk_cell_renderer_start_editing, gxg_gtk_cell_renderer_start_editing_w, 7, 0, 0, H_gtk_cell_renderer_start_editing, pl_puuusuug);
Xg_define_procedure(gtk_cell_renderer_set_fixed_size, gxg_gtk_cell_renderer_set_fixed_size_w, 3, 0, 0, H_gtk_cell_renderer_set_fixed_size, pl_tui);
Xg_define_procedure(gtk_cell_renderer_get_fixed_size, gxg_gtk_cell_renderer_get_fixed_size_w, 1, 2, 0, H_gtk_cell_renderer_get_fixed_size, pl_tu);
Xg_define_procedure(gtk_cell_renderer_pixbuf_new, gxg_gtk_cell_renderer_pixbuf_new_w, 0, 0, 0, H_gtk_cell_renderer_pixbuf_new, pl_p);
@@ -40077,12 +40500,12 @@ pl_unused = NULL;
Xg_define_procedure(gtk_drag_get_source_widget, gxg_gtk_drag_get_source_widget_w, 1, 0, 0, H_gtk_drag_get_source_widget, pl_pu);
Xg_define_procedure(gtk_drag_highlight, gxg_gtk_drag_highlight_w, 1, 0, 0, H_gtk_drag_highlight, pl_tu);
Xg_define_procedure(gtk_drag_unhighlight, gxg_gtk_drag_unhighlight_w, 1, 0, 0, H_gtk_drag_unhighlight, pl_tu);
- Xg_define_procedure(gtk_drag_dest_set, gxg_gtk_drag_dest_set_w, 5, 0, 0, H_gtk_drag_dest_set, pl_tuiui);
+ Xg_define_procedure(gtk_drag_dest_set, gxg_gtk_drag_dest_set_w, 5, 0, 0, H_gtk_drag_dest_set, pl_tuguig);
Xg_define_procedure(gtk_drag_dest_unset, gxg_gtk_drag_dest_unset_w, 1, 0, 0, H_gtk_drag_dest_unset, pl_tu);
Xg_define_procedure(gtk_drag_dest_find_target, gxg_gtk_drag_dest_find_target_w, 3, 0, 0, H_gtk_drag_dest_find_target, pl_tu);
Xg_define_procedure(gtk_drag_dest_get_target_list, gxg_gtk_drag_dest_get_target_list_w, 1, 0, 0, H_gtk_drag_dest_get_target_list, pl_pu);
Xg_define_procedure(gtk_drag_dest_set_target_list, gxg_gtk_drag_dest_set_target_list_w, 2, 0, 0, H_gtk_drag_dest_set_target_list, pl_tu);
- Xg_define_procedure(gtk_drag_source_set, gxg_gtk_drag_source_set_w, 5, 0, 0, H_gtk_drag_source_set, pl_tuiui);
+ Xg_define_procedure(gtk_drag_source_set, gxg_gtk_drag_source_set_w, 5, 0, 0, H_gtk_drag_source_set, pl_tuguig);
Xg_define_procedure(gtk_drag_source_unset, gxg_gtk_drag_source_unset_w, 1, 0, 0, H_gtk_drag_source_unset, pl_tu);
Xg_define_procedure(gtk_drag_source_set_icon_pixbuf, gxg_gtk_drag_source_set_icon_pixbuf_w, 2, 0, 0, H_gtk_drag_source_set_icon_pixbuf, pl_tu);
Xg_define_procedure(gtk_drag_set_icon_widget, gxg_gtk_drag_set_icon_widget_w, 4, 0, 0, H_gtk_drag_set_icon_widget, pl_tuui);
@@ -40131,8 +40554,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_frame_get_label_widget, gxg_gtk_frame_get_label_widget_w, 1, 0, 0, H_gtk_frame_get_label_widget, pl_pu);
Xg_define_procedure(gtk_frame_set_label_align, gxg_gtk_frame_set_label_align_w, 3, 0, 0, H_gtk_frame_set_label_align, pl_tur);
Xg_define_procedure(gtk_frame_get_label_align, gxg_gtk_frame_get_label_align_w, 1, 2, 0, H_gtk_frame_get_label_align, pl_tu);
- Xg_define_procedure(gtk_frame_set_shadow_type, gxg_gtk_frame_set_shadow_type_w, 2, 0, 0, H_gtk_frame_set_shadow_type, pl_tui);
- Xg_define_procedure(gtk_frame_get_shadow_type, gxg_gtk_frame_get_shadow_type_w, 1, 0, 0, H_gtk_frame_get_shadow_type, pl_iu);
+ Xg_define_procedure(gtk_frame_set_shadow_type, gxg_gtk_frame_set_shadow_type_w, 2, 0, 0, H_gtk_frame_set_shadow_type, pl_tug);
+ Xg_define_procedure(gtk_frame_get_shadow_type, gxg_gtk_frame_get_shadow_type_w, 1, 0, 0, H_gtk_frame_get_shadow_type, pl_gu);
Xg_define_procedure(gtk_image_new, gxg_gtk_image_new_w, 0, 0, 0, H_gtk_image_new, pl_p);
Xg_define_procedure(gtk_image_new_from_file, gxg_gtk_image_new_from_file_w, 1, 0, 0, H_gtk_image_new_from_file, pl_ps);
Xg_define_procedure(gtk_image_new_from_pixbuf, gxg_gtk_image_new_from_pixbuf_w, 1, 0, 0, H_gtk_image_new_from_pixbuf, pl_pu);
@@ -40140,7 +40563,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_image_set_from_file, gxg_gtk_image_set_from_file_w, 2, 0, 0, H_gtk_image_set_from_file, pl_tus);
Xg_define_procedure(gtk_image_set_from_pixbuf, gxg_gtk_image_set_from_pixbuf_w, 2, 0, 0, H_gtk_image_set_from_pixbuf, pl_tu);
Xg_define_procedure(gtk_image_set_from_animation, gxg_gtk_image_set_from_animation_w, 2, 0, 0, H_gtk_image_set_from_animation, pl_tu);
- Xg_define_procedure(gtk_image_get_storage_type, gxg_gtk_image_get_storage_type_w, 1, 0, 0, H_gtk_image_get_storage_type, pl_iu);
+ Xg_define_procedure(gtk_image_get_storage_type, gxg_gtk_image_get_storage_type_w, 1, 0, 0, H_gtk_image_get_storage_type, pl_gu);
Xg_define_procedure(gtk_image_get_pixbuf, gxg_gtk_image_get_pixbuf_w, 1, 0, 0, H_gtk_image_get_pixbuf, pl_pu);
Xg_define_procedure(gtk_image_get_animation, gxg_gtk_image_get_animation_w, 1, 0, 0, H_gtk_image_get_animation, pl_pu);
Xg_define_procedure(gtk_im_context_set_client_window, gxg_gtk_im_context_set_client_window_w, 2, 0, 0, H_gtk_im_context_set_client_window, pl_tu);
@@ -40175,8 +40598,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_label_set_mnemonic_widget, gxg_gtk_label_set_mnemonic_widget_w, 2, 0, 0, H_gtk_label_set_mnemonic_widget, pl_tu);
Xg_define_procedure(gtk_label_get_mnemonic_widget, gxg_gtk_label_get_mnemonic_widget_w, 1, 0, 0, H_gtk_label_get_mnemonic_widget, pl_pu);
Xg_define_procedure(gtk_label_set_text_with_mnemonic, gxg_gtk_label_set_text_with_mnemonic_w, 2, 0, 0, H_gtk_label_set_text_with_mnemonic, pl_tus);
- Xg_define_procedure(gtk_label_set_justify, gxg_gtk_label_set_justify_w, 2, 0, 0, H_gtk_label_set_justify, pl_tui);
- Xg_define_procedure(gtk_label_get_justify, gxg_gtk_label_get_justify_w, 1, 0, 0, H_gtk_label_get_justify, pl_iu);
+ Xg_define_procedure(gtk_label_set_justify, gxg_gtk_label_set_justify_w, 2, 0, 0, H_gtk_label_set_justify, pl_tug);
+ Xg_define_procedure(gtk_label_get_justify, gxg_gtk_label_get_justify_w, 1, 0, 0, H_gtk_label_get_justify, pl_gu);
Xg_define_procedure(gtk_label_set_pattern, gxg_gtk_label_set_pattern_w, 2, 0, 0, H_gtk_label_set_pattern, pl_tus);
Xg_define_procedure(gtk_label_set_line_wrap, gxg_gtk_label_set_line_wrap_w, 2, 0, 0, H_gtk_label_set_line_wrap, pl_tub);
Xg_define_procedure(gtk_label_get_line_wrap, gxg_gtk_label_get_line_wrap_w, 1, 0, 0, H_gtk_label_get_line_wrap, pl_bu);
@@ -40265,8 +40688,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_notebook_get_show_border, gxg_gtk_notebook_get_show_border_w, 1, 0, 0, H_gtk_notebook_get_show_border, pl_bu);
Xg_define_procedure(gtk_notebook_set_show_tabs, gxg_gtk_notebook_set_show_tabs_w, 2, 0, 0, H_gtk_notebook_set_show_tabs, pl_tub);
Xg_define_procedure(gtk_notebook_get_show_tabs, gxg_gtk_notebook_get_show_tabs_w, 1, 0, 0, H_gtk_notebook_get_show_tabs, pl_bu);
- Xg_define_procedure(gtk_notebook_set_tab_pos, gxg_gtk_notebook_set_tab_pos_w, 2, 0, 0, H_gtk_notebook_set_tab_pos, pl_tui);
- Xg_define_procedure(gtk_notebook_get_tab_pos, gxg_gtk_notebook_get_tab_pos_w, 1, 0, 0, H_gtk_notebook_get_tab_pos, pl_iu);
+ Xg_define_procedure(gtk_notebook_set_tab_pos, gxg_gtk_notebook_set_tab_pos_w, 2, 0, 0, H_gtk_notebook_set_tab_pos, pl_tug);
+ Xg_define_procedure(gtk_notebook_get_tab_pos, gxg_gtk_notebook_get_tab_pos_w, 1, 0, 0, H_gtk_notebook_get_tab_pos, pl_gu);
Xg_define_procedure(gtk_notebook_set_scrollable, gxg_gtk_notebook_set_scrollable_w, 2, 0, 0, H_gtk_notebook_set_scrollable, pl_tub);
Xg_define_procedure(gtk_notebook_get_scrollable, gxg_gtk_notebook_get_scrollable_w, 1, 0, 0, H_gtk_notebook_get_scrollable, pl_bu);
Xg_define_procedure(gtk_notebook_popup_enable, gxg_gtk_notebook_popup_enable_w, 1, 0, 0, H_gtk_notebook_popup_enable, pl_tu);
@@ -40325,19 +40748,19 @@ pl_unused = NULL;
Xg_define_procedure(gtk_scale_get_digits, gxg_gtk_scale_get_digits_w, 1, 0, 0, H_gtk_scale_get_digits, pl_iu);
Xg_define_procedure(gtk_scale_set_draw_value, gxg_gtk_scale_set_draw_value_w, 2, 0, 0, H_gtk_scale_set_draw_value, pl_tub);
Xg_define_procedure(gtk_scale_get_draw_value, gxg_gtk_scale_get_draw_value_w, 1, 0, 0, H_gtk_scale_get_draw_value, pl_bu);
- Xg_define_procedure(gtk_scale_set_value_pos, gxg_gtk_scale_set_value_pos_w, 2, 0, 0, H_gtk_scale_set_value_pos, pl_tui);
- Xg_define_procedure(gtk_scale_get_value_pos, gxg_gtk_scale_get_value_pos_w, 1, 0, 0, H_gtk_scale_get_value_pos, pl_iu);
+ Xg_define_procedure(gtk_scale_set_value_pos, gxg_gtk_scale_set_value_pos_w, 2, 0, 0, H_gtk_scale_set_value_pos, pl_tug);
+ Xg_define_procedure(gtk_scale_get_value_pos, gxg_gtk_scale_get_value_pos_w, 1, 0, 0, H_gtk_scale_get_value_pos, pl_gu);
Xg_define_procedure(gtk_scrolled_window_new, gxg_gtk_scrolled_window_new_w, 2, 0, 0, H_gtk_scrolled_window_new, pl_pu);
Xg_define_procedure(gtk_scrolled_window_set_hadjustment, gxg_gtk_scrolled_window_set_hadjustment_w, 2, 0, 0, H_gtk_scrolled_window_set_hadjustment, pl_tu);
Xg_define_procedure(gtk_scrolled_window_set_vadjustment, gxg_gtk_scrolled_window_set_vadjustment_w, 2, 0, 0, H_gtk_scrolled_window_set_vadjustment, pl_tu);
Xg_define_procedure(gtk_scrolled_window_get_hadjustment, gxg_gtk_scrolled_window_get_hadjustment_w, 1, 0, 0, H_gtk_scrolled_window_get_hadjustment, pl_pu);
Xg_define_procedure(gtk_scrolled_window_get_vadjustment, gxg_gtk_scrolled_window_get_vadjustment_w, 1, 0, 0, H_gtk_scrolled_window_get_vadjustment, pl_pu);
- Xg_define_procedure(gtk_scrolled_window_set_policy, gxg_gtk_scrolled_window_set_policy_w, 3, 0, 0, H_gtk_scrolled_window_set_policy, pl_tui);
+ Xg_define_procedure(gtk_scrolled_window_set_policy, gxg_gtk_scrolled_window_set_policy_w, 3, 0, 0, H_gtk_scrolled_window_set_policy, pl_tug);
Xg_define_procedure(gtk_scrolled_window_get_policy, gxg_gtk_scrolled_window_get_policy_w, 1, 2, 0, H_gtk_scrolled_window_get_policy, pl_tu);
- Xg_define_procedure(gtk_scrolled_window_set_placement, gxg_gtk_scrolled_window_set_placement_w, 2, 0, 0, H_gtk_scrolled_window_set_placement, pl_tui);
- Xg_define_procedure(gtk_scrolled_window_get_placement, gxg_gtk_scrolled_window_get_placement_w, 1, 0, 0, H_gtk_scrolled_window_get_placement, pl_iu);
- Xg_define_procedure(gtk_scrolled_window_set_shadow_type, gxg_gtk_scrolled_window_set_shadow_type_w, 2, 0, 0, H_gtk_scrolled_window_set_shadow_type, pl_tui);
- Xg_define_procedure(gtk_scrolled_window_get_shadow_type, gxg_gtk_scrolled_window_get_shadow_type_w, 1, 0, 0, H_gtk_scrolled_window_get_shadow_type, pl_iu);
+ Xg_define_procedure(gtk_scrolled_window_set_placement, gxg_gtk_scrolled_window_set_placement_w, 2, 0, 0, H_gtk_scrolled_window_set_placement, pl_tug);
+ Xg_define_procedure(gtk_scrolled_window_get_placement, gxg_gtk_scrolled_window_get_placement_w, 1, 0, 0, H_gtk_scrolled_window_get_placement, pl_gu);
+ Xg_define_procedure(gtk_scrolled_window_set_shadow_type, gxg_gtk_scrolled_window_set_shadow_type_w, 2, 0, 0, H_gtk_scrolled_window_set_shadow_type, pl_tug);
+ Xg_define_procedure(gtk_scrolled_window_get_shadow_type, gxg_gtk_scrolled_window_get_shadow_type_w, 1, 0, 0, H_gtk_scrolled_window_get_shadow_type, pl_gu);
Xg_define_procedure(gtk_target_list_new, gxg_gtk_target_list_new_w, 2, 0, 0, H_gtk_target_list_new, pl_pui);
Xg_define_procedure(gtk_target_list_unref, gxg_gtk_target_list_unref_w, 1, 0, 0, H_gtk_target_list_unref, pl_tu);
Xg_define_procedure(gtk_target_list_add, gxg_gtk_target_list_add_w, 4, 0, 0, H_gtk_target_list_add, pl_tuti);
@@ -40359,9 +40782,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_selection_data_free, gxg_gtk_selection_data_free_w, 1, 0, 0, H_gtk_selection_data_free, pl_tu);
Xg_define_procedure(gtk_separator_menu_item_new, gxg_gtk_separator_menu_item_new_w, 0, 0, 0, H_gtk_separator_menu_item_new, pl_p);
Xg_define_procedure(gtk_settings_get_default, gxg_gtk_settings_get_default_w, 0, 0, 0, H_gtk_settings_get_default, pl_p);
- Xg_define_procedure(gtk_size_group_new, gxg_gtk_size_group_new_w, 1, 0, 0, H_gtk_size_group_new, pl_pi);
- Xg_define_procedure(gtk_size_group_set_mode, gxg_gtk_size_group_set_mode_w, 2, 0, 0, H_gtk_size_group_set_mode, pl_tui);
- Xg_define_procedure(gtk_size_group_get_mode, gxg_gtk_size_group_get_mode_w, 1, 0, 0, H_gtk_size_group_get_mode, pl_iu);
+ Xg_define_procedure(gtk_size_group_new, gxg_gtk_size_group_new_w, 1, 0, 0, H_gtk_size_group_new, pl_pg);
+ Xg_define_procedure(gtk_size_group_set_mode, gxg_gtk_size_group_set_mode_w, 2, 0, 0, H_gtk_size_group_set_mode, pl_tug);
+ Xg_define_procedure(gtk_size_group_get_mode, gxg_gtk_size_group_get_mode_w, 1, 0, 0, H_gtk_size_group_get_mode, pl_gu);
Xg_define_procedure(gtk_size_group_add_widget, gxg_gtk_size_group_add_widget_w, 2, 0, 0, H_gtk_size_group_add_widget, pl_tu);
Xg_define_procedure(gtk_size_group_remove_widget, gxg_gtk_size_group_remove_widget_w, 2, 0, 0, H_gtk_size_group_remove_widget, pl_tu);
Xg_define_procedure(gtk_spin_button_configure, gxg_gtk_spin_button_configure_w, 4, 0, 0, H_gtk_spin_button_configure, pl_tuuri);
@@ -40378,11 +40801,11 @@ pl_unused = NULL;
Xg_define_procedure(gtk_spin_button_get_value, gxg_gtk_spin_button_get_value_w, 1, 0, 0, H_gtk_spin_button_get_value, pl_du);
Xg_define_procedure(gtk_spin_button_get_value_as_int, gxg_gtk_spin_button_get_value_as_int_w, 1, 0, 0, H_gtk_spin_button_get_value_as_int, pl_iu);
Xg_define_procedure(gtk_spin_button_set_value, gxg_gtk_spin_button_set_value_w, 2, 0, 0, H_gtk_spin_button_set_value, pl_tur);
- Xg_define_procedure(gtk_spin_button_set_update_policy, gxg_gtk_spin_button_set_update_policy_w, 2, 0, 0, H_gtk_spin_button_set_update_policy, pl_tui);
- Xg_define_procedure(gtk_spin_button_get_update_policy, gxg_gtk_spin_button_get_update_policy_w, 1, 0, 0, H_gtk_spin_button_get_update_policy, pl_iu);
+ Xg_define_procedure(gtk_spin_button_set_update_policy, gxg_gtk_spin_button_set_update_policy_w, 2, 0, 0, H_gtk_spin_button_set_update_policy, pl_tug);
+ Xg_define_procedure(gtk_spin_button_get_update_policy, gxg_gtk_spin_button_get_update_policy_w, 1, 0, 0, H_gtk_spin_button_get_update_policy, pl_gu);
Xg_define_procedure(gtk_spin_button_set_numeric, gxg_gtk_spin_button_set_numeric_w, 2, 0, 0, H_gtk_spin_button_set_numeric, pl_tub);
Xg_define_procedure(gtk_spin_button_get_numeric, gxg_gtk_spin_button_get_numeric_w, 1, 0, 0, H_gtk_spin_button_get_numeric, pl_bu);
- Xg_define_procedure(gtk_spin_button_spin, gxg_gtk_spin_button_spin_w, 3, 0, 0, H_gtk_spin_button_spin, pl_tuir);
+ Xg_define_procedure(gtk_spin_button_spin, gxg_gtk_spin_button_spin_w, 3, 0, 0, H_gtk_spin_button_spin, pl_tugr);
Xg_define_procedure(gtk_spin_button_set_wrap, gxg_gtk_spin_button_set_wrap_w, 2, 0, 0, H_gtk_spin_button_set_wrap, pl_tub);
Xg_define_procedure(gtk_spin_button_get_wrap, gxg_gtk_spin_button_get_wrap_w, 1, 0, 0, H_gtk_spin_button_get_wrap, pl_bu);
Xg_define_procedure(gtk_spin_button_set_snap_to_ticks, gxg_gtk_spin_button_set_snap_to_ticks_w, 2, 0, 0, H_gtk_spin_button_set_snap_to_ticks, pl_tub);
@@ -40469,7 +40892,6 @@ pl_unused = NULL;
Xg_define_procedure(gtk_text_iter_get_marks, gxg_gtk_text_iter_get_marks_w, 1, 0, 0, H_gtk_text_iter_get_marks, pl_pu);
Xg_define_procedure(gtk_text_iter_get_child_anchor, gxg_gtk_text_iter_get_child_anchor_w, 1, 0, 0, H_gtk_text_iter_get_child_anchor, pl_pu);
Xg_define_procedure(gtk_text_iter_get_toggled_tags, gxg_gtk_text_iter_get_toggled_tags_w, 2, 0, 0, H_gtk_text_iter_get_toggled_tags, pl_pub);
- Xg_define_procedure(gtk_text_iter_begins_tag, gxg_gtk_text_iter_begins_tag_w, 2, 0, 0, H_gtk_text_iter_begins_tag, pl_bu);
Xg_define_procedure(gtk_text_iter_ends_tag, gxg_gtk_text_iter_ends_tag_w, 2, 0, 0, H_gtk_text_iter_ends_tag, pl_bu);
Xg_define_procedure(gtk_text_iter_toggles_tag, gxg_gtk_text_iter_toggles_tag_w, 2, 0, 0, H_gtk_text_iter_toggles_tag, pl_bu);
Xg_define_procedure(gtk_text_iter_has_tag, gxg_gtk_text_iter_has_tag_w, 2, 0, 0, H_gtk_text_iter_has_tag, pl_bu);
@@ -40523,8 +40945,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_text_iter_backward_to_tag_toggle, gxg_gtk_text_iter_backward_to_tag_toggle_w, 2, 0, 0, H_gtk_text_iter_backward_to_tag_toggle, pl_bu);
Xg_define_procedure(gtk_text_iter_forward_find_char, gxg_gtk_text_iter_forward_find_char_w, 4, 0, 0, H_gtk_text_iter_forward_find_char, pl_buttu);
Xg_define_procedure(gtk_text_iter_backward_find_char, gxg_gtk_text_iter_backward_find_char_w, 4, 0, 0, H_gtk_text_iter_backward_find_char, pl_buttu);
- Xg_define_procedure(gtk_text_iter_forward_search, gxg_gtk_text_iter_forward_search_w, 6, 0, 0, H_gtk_text_iter_forward_search, pl_busiu);
- Xg_define_procedure(gtk_text_iter_backward_search, gxg_gtk_text_iter_backward_search_w, 6, 0, 0, H_gtk_text_iter_backward_search, pl_busiu);
+ Xg_define_procedure(gtk_text_iter_forward_search, gxg_gtk_text_iter_forward_search_w, 6, 0, 0, H_gtk_text_iter_forward_search, pl_busgu);
+ Xg_define_procedure(gtk_text_iter_backward_search, gxg_gtk_text_iter_backward_search_w, 6, 0, 0, H_gtk_text_iter_backward_search, pl_busgu);
Xg_define_procedure(gtk_text_iter_equal, gxg_gtk_text_iter_equal_w, 2, 0, 0, H_gtk_text_iter_equal, pl_bu);
Xg_define_procedure(gtk_text_iter_compare, gxg_gtk_text_iter_compare_w, 2, 0, 0, H_gtk_text_iter_compare, pl_iu);
Xg_define_procedure(gtk_text_iter_in_range, gxg_gtk_text_iter_in_range_w, 3, 0, 0, H_gtk_text_iter_in_range, pl_bu);
@@ -40562,15 +40984,14 @@ pl_unused = NULL;
Xg_define_procedure(gtk_text_view_set_cursor_visible, gxg_gtk_text_view_set_cursor_visible_w, 2, 0, 0, H_gtk_text_view_set_cursor_visible, pl_tub);
Xg_define_procedure(gtk_text_view_get_cursor_visible, gxg_gtk_text_view_get_cursor_visible_w, 1, 0, 0, H_gtk_text_view_get_cursor_visible, pl_bu);
Xg_define_procedure(gtk_text_view_get_iter_location, gxg_gtk_text_view_get_iter_location_w, 3, 0, 0, H_gtk_text_view_get_iter_location, pl_tu);
- Xg_define_procedure(gtk_text_view_get_iter_at_location, gxg_gtk_text_view_get_iter_at_location_w, 4, 0, 0, H_gtk_text_view_get_iter_at_location, pl_tuui);
Xg_define_procedure(gtk_text_view_get_line_yrange, gxg_gtk_text_view_get_line_yrange_w, 2, 2, 0, H_gtk_text_view_get_line_yrange, pl_tu);
Xg_define_procedure(gtk_text_view_get_line_at_y, gxg_gtk_text_view_get_line_at_y_w, 3, 1, 0, H_gtk_text_view_get_line_at_y, pl_tuuiu);
- Xg_define_procedure(gtk_text_view_buffer_to_window_coords, gxg_gtk_text_view_buffer_to_window_coords_w, 4, 2, 0, H_gtk_text_view_buffer_to_window_coords, pl_tuiiiu);
- Xg_define_procedure(gtk_text_view_window_to_buffer_coords, gxg_gtk_text_view_window_to_buffer_coords_w, 4, 2, 0, H_gtk_text_view_window_to_buffer_coords, pl_tuiiiu);
- Xg_define_procedure(gtk_text_view_get_window, gxg_gtk_text_view_get_window_w, 2, 0, 0, H_gtk_text_view_get_window, pl_pui);
- Xg_define_procedure(gtk_text_view_get_window_type, gxg_gtk_text_view_get_window_type_w, 2, 0, 0, H_gtk_text_view_get_window_type, pl_iu);
- Xg_define_procedure(gtk_text_view_set_border_window_size, gxg_gtk_text_view_set_border_window_size_w, 3, 0, 0, H_gtk_text_view_set_border_window_size, pl_tui);
- Xg_define_procedure(gtk_text_view_get_border_window_size, gxg_gtk_text_view_get_border_window_size_w, 2, 0, 0, H_gtk_text_view_get_border_window_size, pl_iui);
+ Xg_define_procedure(gtk_text_view_buffer_to_window_coords, gxg_gtk_text_view_buffer_to_window_coords_w, 4, 2, 0, H_gtk_text_view_buffer_to_window_coords, pl_tugiiu);
+ Xg_define_procedure(gtk_text_view_window_to_buffer_coords, gxg_gtk_text_view_window_to_buffer_coords_w, 4, 2, 0, H_gtk_text_view_window_to_buffer_coords, pl_tugiiu);
+ Xg_define_procedure(gtk_text_view_get_window, gxg_gtk_text_view_get_window_w, 2, 0, 0, H_gtk_text_view_get_window, pl_pug);
+ Xg_define_procedure(gtk_text_view_get_window_type, gxg_gtk_text_view_get_window_type_w, 2, 0, 0, H_gtk_text_view_get_window_type, pl_gu);
+ Xg_define_procedure(gtk_text_view_set_border_window_size, gxg_gtk_text_view_set_border_window_size_w, 3, 0, 0, H_gtk_text_view_set_border_window_size, pl_tugi);
+ Xg_define_procedure(gtk_text_view_get_border_window_size, gxg_gtk_text_view_get_border_window_size_w, 2, 0, 0, H_gtk_text_view_get_border_window_size, pl_iug);
Xg_define_procedure(gtk_text_view_forward_display_line, gxg_gtk_text_view_forward_display_line_w, 2, 0, 0, H_gtk_text_view_forward_display_line, pl_bu);
Xg_define_procedure(gtk_text_view_backward_display_line, gxg_gtk_text_view_backward_display_line_w, 2, 0, 0, H_gtk_text_view_backward_display_line, pl_bu);
Xg_define_procedure(gtk_text_view_forward_display_line_end, gxg_gtk_text_view_forward_display_line_end_w, 2, 0, 0, H_gtk_text_view_forward_display_line_end, pl_bu);
@@ -40578,10 +40999,10 @@ pl_unused = NULL;
Xg_define_procedure(gtk_text_view_starts_display_line, gxg_gtk_text_view_starts_display_line_w, 2, 0, 0, H_gtk_text_view_starts_display_line, pl_bu);
Xg_define_procedure(gtk_text_view_move_visually, gxg_gtk_text_view_move_visually_w, 3, 0, 0, H_gtk_text_view_move_visually, pl_buui);
Xg_define_procedure(gtk_text_view_add_child_at_anchor, gxg_gtk_text_view_add_child_at_anchor_w, 3, 0, 0, H_gtk_text_view_add_child_at_anchor, pl_tu);
- Xg_define_procedure(gtk_text_view_add_child_in_window, gxg_gtk_text_view_add_child_in_window_w, 5, 0, 0, H_gtk_text_view_add_child_in_window, pl_tuui);
+ Xg_define_procedure(gtk_text_view_add_child_in_window, gxg_gtk_text_view_add_child_in_window_w, 5, 0, 0, H_gtk_text_view_add_child_in_window, pl_tuugi);
Xg_define_procedure(gtk_text_view_move_child, gxg_gtk_text_view_move_child_w, 4, 0, 0, H_gtk_text_view_move_child, pl_tuui);
- Xg_define_procedure(gtk_text_view_set_wrap_mode, gxg_gtk_text_view_set_wrap_mode_w, 2, 0, 0, H_gtk_text_view_set_wrap_mode, pl_tui);
- Xg_define_procedure(gtk_text_view_get_wrap_mode, gxg_gtk_text_view_get_wrap_mode_w, 1, 0, 0, H_gtk_text_view_get_wrap_mode, pl_iu);
+ Xg_define_procedure(gtk_text_view_set_wrap_mode, gxg_gtk_text_view_set_wrap_mode_w, 2, 0, 0, H_gtk_text_view_set_wrap_mode, pl_tug);
+ Xg_define_procedure(gtk_text_view_get_wrap_mode, gxg_gtk_text_view_get_wrap_mode_w, 1, 0, 0, H_gtk_text_view_get_wrap_mode, pl_gu);
Xg_define_procedure(gtk_text_view_set_editable, gxg_gtk_text_view_set_editable_w, 2, 0, 0, H_gtk_text_view_set_editable, pl_tub);
Xg_define_procedure(gtk_text_view_get_editable, gxg_gtk_text_view_get_editable_w, 1, 0, 0, H_gtk_text_view_get_editable, pl_bu);
Xg_define_procedure(gtk_text_view_set_pixels_above_lines, gxg_gtk_text_view_set_pixels_above_lines_w, 2, 0, 0, H_gtk_text_view_set_pixels_above_lines, pl_tui);
@@ -40590,8 +41011,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_text_view_get_pixels_below_lines, gxg_gtk_text_view_get_pixels_below_lines_w, 1, 0, 0, H_gtk_text_view_get_pixels_below_lines, pl_iu);
Xg_define_procedure(gtk_text_view_set_pixels_inside_wrap, gxg_gtk_text_view_set_pixels_inside_wrap_w, 2, 0, 0, H_gtk_text_view_set_pixels_inside_wrap, pl_tui);
Xg_define_procedure(gtk_text_view_get_pixels_inside_wrap, gxg_gtk_text_view_get_pixels_inside_wrap_w, 1, 0, 0, H_gtk_text_view_get_pixels_inside_wrap, pl_iu);
- Xg_define_procedure(gtk_text_view_set_justification, gxg_gtk_text_view_set_justification_w, 2, 0, 0, H_gtk_text_view_set_justification, pl_tui);
- Xg_define_procedure(gtk_text_view_get_justification, gxg_gtk_text_view_get_justification_w, 1, 0, 0, H_gtk_text_view_get_justification, pl_iu);
+ Xg_define_procedure(gtk_text_view_set_justification, gxg_gtk_text_view_set_justification_w, 2, 0, 0, H_gtk_text_view_set_justification, pl_tug);
+ Xg_define_procedure(gtk_text_view_get_justification, gxg_gtk_text_view_get_justification_w, 1, 0, 0, H_gtk_text_view_get_justification, pl_gu);
Xg_define_procedure(gtk_text_view_set_left_margin, gxg_gtk_text_view_set_left_margin_w, 2, 0, 0, H_gtk_text_view_set_left_margin, pl_tui);
Xg_define_procedure(gtk_text_view_get_left_margin, gxg_gtk_text_view_get_left_margin_w, 1, 0, 0, H_gtk_text_view_get_left_margin, pl_iu);
Xg_define_procedure(gtk_text_view_set_right_margin, gxg_gtk_text_view_set_right_margin_w, 2, 0, 0, H_gtk_text_view_set_right_margin, pl_tui);
@@ -40612,9 +41033,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_toggle_button_set_inconsistent, gxg_gtk_toggle_button_set_inconsistent_w, 2, 0, 0, H_gtk_toggle_button_set_inconsistent, pl_tub);
Xg_define_procedure(gtk_toggle_button_get_inconsistent, gxg_gtk_toggle_button_get_inconsistent_w, 1, 0, 0, H_gtk_toggle_button_get_inconsistent, pl_bu);
Xg_define_procedure(gtk_toolbar_new, gxg_gtk_toolbar_new_w, 0, 0, 0, H_gtk_toolbar_new, pl_p);
- Xg_define_procedure(gtk_toolbar_set_style, gxg_gtk_toolbar_set_style_w, 2, 0, 0, H_gtk_toolbar_set_style, pl_tui);
+ Xg_define_procedure(gtk_toolbar_set_style, gxg_gtk_toolbar_set_style_w, 2, 0, 0, H_gtk_toolbar_set_style, pl_tug);
Xg_define_procedure(gtk_toolbar_unset_style, gxg_gtk_toolbar_unset_style_w, 1, 0, 0, H_gtk_toolbar_unset_style, pl_tu);
- Xg_define_procedure(gtk_toolbar_get_style, gxg_gtk_toolbar_get_style_w, 1, 0, 0, H_gtk_toolbar_get_style, pl_iu);
+ Xg_define_procedure(gtk_toolbar_get_style, gxg_gtk_toolbar_get_style_w, 1, 0, 0, H_gtk_toolbar_get_style, pl_gu);
Xg_define_procedure(gtk_tree_drag_source_row_draggable, gxg_gtk_tree_drag_source_row_draggable_w, 2, 0, 0, H_gtk_tree_drag_source_row_draggable, pl_bu);
Xg_define_procedure(gtk_tree_drag_source_drag_data_delete, gxg_gtk_tree_drag_source_drag_data_delete_w, 2, 0, 0, H_gtk_tree_drag_source_drag_data_delete, pl_bu);
Xg_define_procedure(gtk_tree_drag_source_drag_data_get, gxg_gtk_tree_drag_source_drag_data_get_w, 3, 0, 0, H_gtk_tree_drag_source_drag_data_get, pl_bu);
@@ -40649,7 +41070,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_row_reference_reordered, gxg_gtk_tree_row_reference_reordered_w, 4, 0, 0, H_gtk_tree_row_reference_reordered, pl_tu);
Xg_define_procedure(gtk_tree_iter_copy, gxg_gtk_tree_iter_copy_w, 1, 0, 0, H_gtk_tree_iter_copy, pl_pu);
Xg_define_procedure(gtk_tree_iter_free, gxg_gtk_tree_iter_free_w, 1, 0, 0, H_gtk_tree_iter_free, pl_tu);
- Xg_define_procedure(gtk_tree_model_get_flags, gxg_gtk_tree_model_get_flags_w, 1, 0, 0, H_gtk_tree_model_get_flags, pl_iu);
+ Xg_define_procedure(gtk_tree_model_get_flags, gxg_gtk_tree_model_get_flags_w, 1, 0, 0, H_gtk_tree_model_get_flags, pl_gu);
Xg_define_procedure(gtk_tree_model_get_n_columns, gxg_gtk_tree_model_get_n_columns_w, 1, 0, 0, H_gtk_tree_model_get_n_columns, pl_iu);
Xg_define_procedure(gtk_tree_model_get_column_type, gxg_gtk_tree_model_get_column_type_w, 2, 0, 0, H_gtk_tree_model_get_column_type, pl_iui);
Xg_define_procedure(gtk_tree_model_get_iter, gxg_gtk_tree_model_get_iter_w, 3, 0, 0, H_gtk_tree_model_get_iter, pl_bu);
@@ -40678,8 +41099,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_model_sort_convert_iter_to_child_iter, gxg_gtk_tree_model_sort_convert_iter_to_child_iter_w, 3, 0, 0, H_gtk_tree_model_sort_convert_iter_to_child_iter, pl_tu);
Xg_define_procedure(gtk_tree_model_sort_reset_default_sort_func, gxg_gtk_tree_model_sort_reset_default_sort_func_w, 1, 0, 0, H_gtk_tree_model_sort_reset_default_sort_func, pl_tu);
Xg_define_procedure(gtk_tree_model_sort_clear_cache, gxg_gtk_tree_model_sort_clear_cache_w, 1, 0, 0, H_gtk_tree_model_sort_clear_cache, pl_tu);
- Xg_define_procedure(gtk_tree_selection_set_mode, gxg_gtk_tree_selection_set_mode_w, 2, 0, 0, H_gtk_tree_selection_set_mode, pl_tui);
- Xg_define_procedure(gtk_tree_selection_get_mode, gxg_gtk_tree_selection_get_mode_w, 1, 0, 0, H_gtk_tree_selection_get_mode, pl_iu);
+ Xg_define_procedure(gtk_tree_selection_set_mode, gxg_gtk_tree_selection_set_mode_w, 2, 0, 0, H_gtk_tree_selection_set_mode, pl_tug);
+ Xg_define_procedure(gtk_tree_selection_get_mode, gxg_gtk_tree_selection_get_mode_w, 1, 0, 0, H_gtk_tree_selection_get_mode, pl_gu);
Xg_define_procedure(gtk_tree_selection_set_select_function, gxg_gtk_tree_selection_set_select_function_w, 4, 0, 0, H_gtk_tree_selection_set_select_function, pl_tut);
Xg_define_procedure(gtk_tree_selection_get_user_data, gxg_gtk_tree_selection_get_user_data_w, 1, 0, 0, H_gtk_tree_selection_get_user_data, pl_tu);
Xg_define_procedure(gtk_tree_selection_get_tree_view, gxg_gtk_tree_selection_get_tree_view_w, 1, 0, 0, H_gtk_tree_selection_get_tree_view, pl_pu);
@@ -40696,7 +41117,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_selection_select_range, gxg_gtk_tree_selection_select_range_w, 3, 0, 0, H_gtk_tree_selection_select_range, pl_tu);
Xg_define_procedure(gtk_tree_sortable_sort_column_changed, gxg_gtk_tree_sortable_sort_column_changed_w, 1, 0, 0, H_gtk_tree_sortable_sort_column_changed, pl_tu);
Xg_define_procedure(gtk_tree_sortable_get_sort_column_id, gxg_gtk_tree_sortable_get_sort_column_id_w, 1, 2, 0, H_gtk_tree_sortable_get_sort_column_id, pl_bu);
- Xg_define_procedure(gtk_tree_sortable_set_sort_column_id, gxg_gtk_tree_sortable_set_sort_column_id_w, 3, 0, 0, H_gtk_tree_sortable_set_sort_column_id, pl_tui);
+ Xg_define_procedure(gtk_tree_sortable_set_sort_column_id, gxg_gtk_tree_sortable_set_sort_column_id_w, 3, 0, 0, H_gtk_tree_sortable_set_sort_column_id, pl_tuig);
Xg_define_procedure(gtk_tree_sortable_set_sort_func, gxg_gtk_tree_sortable_set_sort_func_w, 5, 0, 0, H_gtk_tree_sortable_set_sort_func, pl_tuit);
Xg_define_procedure(gtk_tree_sortable_set_default_sort_func, gxg_gtk_tree_sortable_set_default_sort_func_w, 4, 0, 0, H_gtk_tree_sortable_set_default_sort_func, pl_tut);
Xg_define_procedure(gtk_tree_sortable_has_default_sort_func, gxg_gtk_tree_sortable_has_default_sort_func_w, 1, 0, 0, H_gtk_tree_sortable_has_default_sort_func, pl_bu);
@@ -40728,8 +41149,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_view_column_get_visible, gxg_gtk_tree_view_column_get_visible_w, 1, 0, 0, H_gtk_tree_view_column_get_visible, pl_bu);
Xg_define_procedure(gtk_tree_view_column_set_resizable, gxg_gtk_tree_view_column_set_resizable_w, 2, 0, 0, H_gtk_tree_view_column_set_resizable, pl_tub);
Xg_define_procedure(gtk_tree_view_column_get_resizable, gxg_gtk_tree_view_column_get_resizable_w, 1, 0, 0, H_gtk_tree_view_column_get_resizable, pl_bu);
- Xg_define_procedure(gtk_tree_view_column_set_sizing, gxg_gtk_tree_view_column_set_sizing_w, 2, 0, 0, H_gtk_tree_view_column_set_sizing, pl_tui);
- Xg_define_procedure(gtk_tree_view_column_get_sizing, gxg_gtk_tree_view_column_get_sizing_w, 1, 0, 0, H_gtk_tree_view_column_get_sizing, pl_iu);
+ Xg_define_procedure(gtk_tree_view_column_set_sizing, gxg_gtk_tree_view_column_set_sizing_w, 2, 0, 0, H_gtk_tree_view_column_set_sizing, pl_tug);
+ Xg_define_procedure(gtk_tree_view_column_get_sizing, gxg_gtk_tree_view_column_get_sizing_w, 1, 0, 0, H_gtk_tree_view_column_get_sizing, pl_gu);
Xg_define_procedure(gtk_tree_view_column_get_width, gxg_gtk_tree_view_column_get_width_w, 1, 0, 0, H_gtk_tree_view_column_get_width, pl_iu);
Xg_define_procedure(gtk_tree_view_column_get_fixed_width, gxg_gtk_tree_view_column_get_fixed_width_w, 1, 0, 0, H_gtk_tree_view_column_get_fixed_width, pl_iu);
Xg_define_procedure(gtk_tree_view_column_set_fixed_width, gxg_gtk_tree_view_column_set_fixed_width_w, 2, 0, 0, H_gtk_tree_view_column_set_fixed_width, pl_tui);
@@ -40752,8 +41173,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_view_column_get_sort_column_id, gxg_gtk_tree_view_column_get_sort_column_id_w, 1, 0, 0, H_gtk_tree_view_column_get_sort_column_id, pl_iu);
Xg_define_procedure(gtk_tree_view_column_set_sort_indicator, gxg_gtk_tree_view_column_set_sort_indicator_w, 2, 0, 0, H_gtk_tree_view_column_set_sort_indicator, pl_tub);
Xg_define_procedure(gtk_tree_view_column_get_sort_indicator, gxg_gtk_tree_view_column_get_sort_indicator_w, 1, 0, 0, H_gtk_tree_view_column_get_sort_indicator, pl_bu);
- Xg_define_procedure(gtk_tree_view_column_set_sort_order, gxg_gtk_tree_view_column_set_sort_order_w, 2, 0, 0, H_gtk_tree_view_column_set_sort_order, pl_tui);
- Xg_define_procedure(gtk_tree_view_column_get_sort_order, gxg_gtk_tree_view_column_get_sort_order_w, 1, 0, 0, H_gtk_tree_view_column_get_sort_order, pl_iu);
+ Xg_define_procedure(gtk_tree_view_column_set_sort_order, gxg_gtk_tree_view_column_set_sort_order_w, 2, 0, 0, H_gtk_tree_view_column_set_sort_order, pl_tug);
+ Xg_define_procedure(gtk_tree_view_column_get_sort_order, gxg_gtk_tree_view_column_get_sort_order_w, 1, 0, 0, H_gtk_tree_view_column_get_sort_order, pl_gu);
Xg_define_procedure(gtk_tree_view_column_cell_set_cell_data, gxg_gtk_tree_view_column_cell_set_cell_data_w, 5, 0, 0, H_gtk_tree_view_column_cell_set_cell_data, pl_tuuub);
Xg_define_procedure(gtk_tree_view_column_cell_get_size, gxg_gtk_tree_view_column_cell_get_size_w, 2, 4, 0, H_gtk_tree_view_column_cell_get_size, pl_tu);
Xg_define_procedure(gtk_tree_view_column_cell_is_visible, gxg_gtk_tree_view_column_cell_is_visible_w, 1, 0, 0, H_gtk_tree_view_column_cell_is_visible, pl_bu);
@@ -40796,11 +41217,11 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_view_get_cell_area, gxg_gtk_tree_view_get_cell_area_w, 4, 0, 0, H_gtk_tree_view_get_cell_area, pl_tu);
Xg_define_procedure(gtk_tree_view_get_background_area, gxg_gtk_tree_view_get_background_area_w, 4, 0, 0, H_gtk_tree_view_get_background_area, pl_tu);
Xg_define_procedure(gtk_tree_view_get_visible_rect, gxg_gtk_tree_view_get_visible_rect_w, 2, 0, 0, H_gtk_tree_view_get_visible_rect, pl_tu);
- Xg_define_procedure(gtk_tree_view_enable_model_drag_source, gxg_gtk_tree_view_enable_model_drag_source_w, 5, 0, 0, H_gtk_tree_view_enable_model_drag_source, pl_tuiui);
- Xg_define_procedure(gtk_tree_view_enable_model_drag_dest, gxg_gtk_tree_view_enable_model_drag_dest_w, 4, 0, 0, H_gtk_tree_view_enable_model_drag_dest, pl_tuui);
+ Xg_define_procedure(gtk_tree_view_enable_model_drag_source, gxg_gtk_tree_view_enable_model_drag_source_w, 5, 0, 0, H_gtk_tree_view_enable_model_drag_source, pl_tuguig);
+ Xg_define_procedure(gtk_tree_view_enable_model_drag_dest, gxg_gtk_tree_view_enable_model_drag_dest_w, 4, 0, 0, H_gtk_tree_view_enable_model_drag_dest, pl_tuuig);
Xg_define_procedure(gtk_tree_view_unset_rows_drag_source, gxg_gtk_tree_view_unset_rows_drag_source_w, 1, 0, 0, H_gtk_tree_view_unset_rows_drag_source, pl_tu);
Xg_define_procedure(gtk_tree_view_unset_rows_drag_dest, gxg_gtk_tree_view_unset_rows_drag_dest_w, 1, 0, 0, H_gtk_tree_view_unset_rows_drag_dest, pl_tu);
- Xg_define_procedure(gtk_tree_view_set_drag_dest_row, gxg_gtk_tree_view_set_drag_dest_row_w, 3, 0, 0, H_gtk_tree_view_set_drag_dest_row, pl_tuui);
+ Xg_define_procedure(gtk_tree_view_set_drag_dest_row, gxg_gtk_tree_view_set_drag_dest_row_w, 3, 0, 0, H_gtk_tree_view_set_drag_dest_row, pl_tuug);
Xg_define_procedure(gtk_tree_view_get_drag_dest_row, gxg_gtk_tree_view_get_drag_dest_row_w, 1, 2, 0, H_gtk_tree_view_get_drag_dest_row, pl_tu);
Xg_define_procedure(gtk_tree_view_get_dest_row_at_pos, gxg_gtk_tree_view_get_dest_row_at_pos_w, 3, 2, 0, H_gtk_tree_view_get_dest_row_at_pos, pl_buiiu);
Xg_define_procedure(gtk_tree_view_set_enable_search, gxg_gtk_tree_view_set_enable_search_w, 2, 0, 0, H_gtk_tree_view_set_enable_search, pl_tub);
@@ -40810,8 +41231,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_view_get_search_equal_func, gxg_gtk_tree_view_get_search_equal_func_w, 1, 0, 0, H_gtk_tree_view_get_search_equal_func, pl_tu);
Xg_define_procedure(gtk_tree_view_set_search_equal_func, gxg_gtk_tree_view_set_search_equal_func_w, 4, 0, 0, H_gtk_tree_view_set_search_equal_func, pl_tut);
Xg_define_procedure(gtk_viewport_new, gxg_gtk_viewport_new_w, 2, 0, 0, H_gtk_viewport_new, pl_pu);
- Xg_define_procedure(gtk_viewport_set_shadow_type, gxg_gtk_viewport_set_shadow_type_w, 2, 0, 0, H_gtk_viewport_set_shadow_type, pl_tui);
- Xg_define_procedure(gtk_viewport_get_shadow_type, gxg_gtk_viewport_get_shadow_type_w, 1, 0, 0, H_gtk_viewport_get_shadow_type, pl_iu);
+ Xg_define_procedure(gtk_viewport_set_shadow_type, gxg_gtk_viewport_set_shadow_type_w, 2, 0, 0, H_gtk_viewport_set_shadow_type, pl_tug);
+ Xg_define_procedure(gtk_viewport_get_shadow_type, gxg_gtk_viewport_get_shadow_type_w, 1, 0, 0, H_gtk_viewport_get_shadow_type, pl_gu);
Xg_define_procedure(gtk_widget_destroy, gxg_gtk_widget_destroy_w, 1, 0, 0, H_gtk_widget_destroy, pl_tu);
Xg_define_procedure(gtk_widget_destroyed, gxg_gtk_widget_destroyed_w, 1, 1, 0, H_gtk_widget_destroyed, pl_tu);
Xg_define_procedure(gtk_widget_unparent, gxg_gtk_widget_unparent_w, 1, 0, 0, H_gtk_widget_unparent, pl_tu);
@@ -40827,8 +41248,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_queue_draw_area, gxg_gtk_widget_queue_draw_area_w, 5, 0, 0, H_gtk_widget_queue_draw_area, pl_tui);
Xg_define_procedure(gtk_widget_queue_resize, gxg_gtk_widget_queue_resize_w, 1, 0, 0, H_gtk_widget_queue_resize, pl_tu);
Xg_define_procedure(gtk_widget_size_allocate, gxg_gtk_widget_size_allocate_w, 2, 0, 0, H_gtk_widget_size_allocate, pl_tu);
- Xg_define_procedure(gtk_widget_add_accelerator, gxg_gtk_widget_add_accelerator_w, 6, 0, 0, H_gtk_widget_add_accelerator, pl_tusui);
- Xg_define_procedure(gtk_widget_remove_accelerator, gxg_gtk_widget_remove_accelerator_w, 4, 0, 0, H_gtk_widget_remove_accelerator, pl_buui);
+ Xg_define_procedure(gtk_widget_add_accelerator, gxg_gtk_widget_add_accelerator_w, 6, 0, 0, H_gtk_widget_add_accelerator, pl_tusuig);
+ Xg_define_procedure(gtk_widget_remove_accelerator, gxg_gtk_widget_remove_accelerator_w, 4, 0, 0, H_gtk_widget_remove_accelerator, pl_buuig);
Xg_define_procedure(gtk_widget_list_accel_closures, gxg_gtk_widget_list_accel_closures_w, 1, 0, 0, H_gtk_widget_list_accel_closures, pl_pu);
Xg_define_procedure(gtk_widget_mnemonic_activate, gxg_gtk_widget_mnemonic_activate_w, 2, 0, 0, H_gtk_widget_mnemonic_activate, pl_bub);
Xg_define_procedure(gtk_widget_event, gxg_gtk_widget_event_w, 2, 0, 0, H_gtk_widget_event, pl_bu);
@@ -40853,7 +41274,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_get_child_visible, gxg_gtk_widget_get_child_visible_w, 1, 0, 0, H_gtk_widget_get_child_visible, pl_bu);
Xg_define_procedure(gtk_widget_get_parent, gxg_gtk_widget_get_parent_w, 1, 0, 0, H_gtk_widget_get_parent, pl_pu);
Xg_define_procedure(gtk_widget_get_parent_window, gxg_gtk_widget_get_parent_window_w, 1, 0, 0, H_gtk_widget_get_parent_window, pl_pu);
- Xg_define_procedure(gtk_widget_child_focus, gxg_gtk_widget_child_focus_w, 2, 0, 0, H_gtk_widget_child_focus, pl_bui);
+ Xg_define_procedure(gtk_widget_child_focus, gxg_gtk_widget_child_focus_w, 2, 0, 0, H_gtk_widget_child_focus, pl_bug);
Xg_define_procedure(gtk_widget_set_size_request, gxg_gtk_widget_set_size_request_w, 3, 0, 0, H_gtk_widget_set_size_request, pl_tui);
Xg_define_procedure(gtk_widget_get_size_request, gxg_gtk_widget_get_size_request_w, 1, 2, 0, H_gtk_widget_get_size_request, pl_tu);
Xg_define_procedure(gtk_widget_set_events, gxg_gtk_widget_set_events_w, 2, 0, 0, H_gtk_widget_set_events, pl_tui);
@@ -40870,14 +41291,14 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_create_pango_context, gxg_gtk_widget_create_pango_context_w, 1, 0, 0, H_gtk_widget_create_pango_context, pl_pu);
Xg_define_procedure(gtk_widget_get_pango_context, gxg_gtk_widget_get_pango_context_w, 1, 0, 0, H_gtk_widget_get_pango_context, pl_pu);
Xg_define_procedure(gtk_widget_create_pango_layout, gxg_gtk_widget_create_pango_layout_w, 2, 0, 0, H_gtk_widget_create_pango_layout, pl_pus);
- Xg_define_procedure(gtk_widget_set_direction, gxg_gtk_widget_set_direction_w, 2, 0, 0, H_gtk_widget_set_direction, pl_tui);
- Xg_define_procedure(gtk_widget_get_direction, gxg_gtk_widget_get_direction_w, 1, 0, 0, H_gtk_widget_get_direction, pl_iu);
- Xg_define_procedure(gtk_widget_set_default_direction, gxg_gtk_widget_set_default_direction_w, 1, 0, 0, H_gtk_widget_set_default_direction, pl_ti);
- Xg_define_procedure(gtk_widget_get_default_direction, gxg_gtk_widget_get_default_direction_w, 0, 0, 0, H_gtk_widget_get_default_direction, pl_i);
+ Xg_define_procedure(gtk_widget_set_direction, gxg_gtk_widget_set_direction_w, 2, 0, 0, H_gtk_widget_set_direction, pl_tug);
+ Xg_define_procedure(gtk_widget_get_direction, gxg_gtk_widget_get_direction_w, 1, 0, 0, H_gtk_widget_get_direction, pl_gu);
+ Xg_define_procedure(gtk_widget_set_default_direction, gxg_gtk_widget_set_default_direction_w, 1, 0, 0, H_gtk_widget_set_default_direction, pl_tg);
+ Xg_define_procedure(gtk_widget_get_default_direction, gxg_gtk_widget_get_default_direction_w, 0, 0, 0, H_gtk_widget_get_default_direction, pl_g);
Xg_define_procedure(gtk_widget_can_activate_accel, gxg_gtk_widget_can_activate_accel_w, 2, 0, 0, H_gtk_widget_can_activate_accel, pl_bui);
Xg_define_procedure(gtk_window_is_active, gxg_gtk_window_is_active_w, 1, 0, 0, H_gtk_window_is_active, pl_bu);
Xg_define_procedure(gtk_window_has_toplevel_focus, gxg_gtk_window_has_toplevel_focus_w, 1, 0, 0, H_gtk_window_has_toplevel_focus, pl_bu);
- Xg_define_procedure(gtk_window_new, gxg_gtk_window_new_w, 1, 0, 0, H_gtk_window_new, pl_pi);
+ Xg_define_procedure(gtk_window_new, gxg_gtk_window_new_w, 1, 0, 0, H_gtk_window_new, pl_pg);
Xg_define_procedure(gtk_window_set_title, gxg_gtk_window_set_title_w, 2, 0, 0, H_gtk_window_set_title, pl_tus);
Xg_define_procedure(gtk_window_set_auto_startup_notification, gxg_gtk_window_set_auto_startup_notification_w, 1, 0, 0, H_gtk_window_set_auto_startup_notification, pl_tb);
Xg_define_procedure(gtk_window_get_title, gxg_gtk_window_get_title_w, 1, 0, 0, H_gtk_window_get_title, pl_su);
@@ -40886,7 +41307,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_get_role, gxg_gtk_window_get_role_w, 1, 0, 0, H_gtk_window_get_role, pl_su);
Xg_define_procedure(gtk_window_add_accel_group, gxg_gtk_window_add_accel_group_w, 2, 0, 0, H_gtk_window_add_accel_group, pl_tu);
Xg_define_procedure(gtk_window_remove_accel_group, gxg_gtk_window_remove_accel_group_w, 2, 0, 0, H_gtk_window_remove_accel_group, pl_tu);
- Xg_define_procedure(gtk_window_set_position, gxg_gtk_window_set_position_w, 2, 0, 0, H_gtk_window_set_position, pl_tui);
+ Xg_define_procedure(gtk_window_set_position, gxg_gtk_window_set_position_w, 2, 0, 0, H_gtk_window_set_position, pl_tug);
Xg_define_procedure(gtk_window_activate_focus, gxg_gtk_window_activate_focus_w, 1, 0, 0, H_gtk_window_activate_focus, pl_bu);
Xg_define_procedure(gtk_window_set_focus, gxg_gtk_window_set_focus_w, 2, 0, 0, H_gtk_window_set_focus, pl_tu);
Xg_define_procedure(gtk_window_get_focus, gxg_gtk_window_get_focus_w, 1, 0, 0, H_gtk_window_get_focus, pl_pu);
@@ -40894,15 +41315,15 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_activate_default, gxg_gtk_window_activate_default_w, 1, 0, 0, H_gtk_window_activate_default, pl_bu);
Xg_define_procedure(gtk_window_set_transient_for, gxg_gtk_window_set_transient_for_w, 2, 0, 0, H_gtk_window_set_transient_for, pl_tu);
Xg_define_procedure(gtk_window_get_transient_for, gxg_gtk_window_get_transient_for_w, 1, 0, 0, H_gtk_window_get_transient_for, pl_pu);
- Xg_define_procedure(gtk_window_set_type_hint, gxg_gtk_window_set_type_hint_w, 2, 0, 0, H_gtk_window_set_type_hint, pl_tui);
- Xg_define_procedure(gtk_window_get_type_hint, gxg_gtk_window_get_type_hint_w, 1, 0, 0, H_gtk_window_get_type_hint, pl_iu);
+ Xg_define_procedure(gtk_window_set_type_hint, gxg_gtk_window_set_type_hint_w, 2, 0, 0, H_gtk_window_set_type_hint, pl_tug);
+ Xg_define_procedure(gtk_window_get_type_hint, gxg_gtk_window_get_type_hint_w, 1, 0, 0, H_gtk_window_get_type_hint, pl_gu);
Xg_define_procedure(gtk_window_set_destroy_with_parent, gxg_gtk_window_set_destroy_with_parent_w, 2, 0, 0, H_gtk_window_set_destroy_with_parent, pl_tub);
Xg_define_procedure(gtk_window_get_destroy_with_parent, gxg_gtk_window_get_destroy_with_parent_w, 1, 0, 0, H_gtk_window_get_destroy_with_parent, pl_bu);
Xg_define_procedure(gtk_window_set_resizable, gxg_gtk_window_set_resizable_w, 2, 0, 0, H_gtk_window_set_resizable, pl_tub);
Xg_define_procedure(gtk_window_get_resizable, gxg_gtk_window_get_resizable_w, 1, 0, 0, H_gtk_window_get_resizable, pl_bu);
- Xg_define_procedure(gtk_window_set_gravity, gxg_gtk_window_set_gravity_w, 2, 0, 0, H_gtk_window_set_gravity, pl_tui);
- Xg_define_procedure(gtk_window_get_gravity, gxg_gtk_window_get_gravity_w, 1, 0, 0, H_gtk_window_get_gravity, pl_iu);
- Xg_define_procedure(gtk_window_set_geometry_hints, gxg_gtk_window_set_geometry_hints_w, 4, 0, 0, H_gtk_window_set_geometry_hints, pl_tuuui);
+ Xg_define_procedure(gtk_window_set_gravity, gxg_gtk_window_set_gravity_w, 2, 0, 0, H_gtk_window_set_gravity, pl_tug);
+ Xg_define_procedure(gtk_window_get_gravity, gxg_gtk_window_get_gravity_w, 1, 0, 0, H_gtk_window_get_gravity, pl_gu);
+ Xg_define_procedure(gtk_window_set_geometry_hints, gxg_gtk_window_set_geometry_hints_w, 4, 0, 0, H_gtk_window_set_geometry_hints, pl_tuuug);
Xg_define_procedure(gtk_window_set_decorated, gxg_gtk_window_set_decorated_w, 2, 0, 0, H_gtk_window_set_decorated, pl_tub);
Xg_define_procedure(gtk_window_get_decorated, gxg_gtk_window_get_decorated_w, 1, 0, 0, H_gtk_window_get_decorated, pl_bu);
Xg_define_procedure(gtk_window_set_icon_list, gxg_gtk_window_set_icon_list_w, 2, 0, 0, H_gtk_window_set_icon_list, pl_tu);
@@ -40916,9 +41337,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_list_toplevels, gxg_gtk_window_list_toplevels_w, 0, 0, 0, H_gtk_window_list_toplevels, pl_p);
Xg_define_procedure(gtk_window_add_mnemonic, gxg_gtk_window_add_mnemonic_w, 3, 0, 0, H_gtk_window_add_mnemonic, pl_tuiu);
Xg_define_procedure(gtk_window_remove_mnemonic, gxg_gtk_window_remove_mnemonic_w, 3, 0, 0, H_gtk_window_remove_mnemonic, pl_tuiu);
- Xg_define_procedure(gtk_window_mnemonic_activate, gxg_gtk_window_mnemonic_activate_w, 3, 0, 0, H_gtk_window_mnemonic_activate, pl_bui);
- Xg_define_procedure(gtk_window_set_mnemonic_modifier, gxg_gtk_window_set_mnemonic_modifier_w, 2, 0, 0, H_gtk_window_set_mnemonic_modifier, pl_tui);
- Xg_define_procedure(gtk_window_get_mnemonic_modifier, gxg_gtk_window_get_mnemonic_modifier_w, 1, 0, 0, H_gtk_window_get_mnemonic_modifier, pl_iu);
+ Xg_define_procedure(gtk_window_mnemonic_activate, gxg_gtk_window_mnemonic_activate_w, 3, 0, 0, H_gtk_window_mnemonic_activate, pl_buig);
+ Xg_define_procedure(gtk_window_set_mnemonic_modifier, gxg_gtk_window_set_mnemonic_modifier_w, 2, 0, 0, H_gtk_window_set_mnemonic_modifier, pl_tug);
+ Xg_define_procedure(gtk_window_get_mnemonic_modifier, gxg_gtk_window_get_mnemonic_modifier_w, 1, 0, 0, H_gtk_window_get_mnemonic_modifier, pl_gu);
Xg_define_procedure(gtk_window_present, gxg_gtk_window_present_w, 1, 0, 0, H_gtk_window_present, pl_tu);
Xg_define_procedure(gtk_window_iconify, gxg_gtk_window_iconify_w, 1, 0, 0, H_gtk_window_iconify, pl_tu);
Xg_define_procedure(gtk_window_deiconify, gxg_gtk_window_deiconify_w, 1, 0, 0, H_gtk_window_deiconify, pl_tu);
@@ -40926,7 +41347,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_unstick, gxg_gtk_window_unstick_w, 1, 0, 0, H_gtk_window_unstick, pl_tu);
Xg_define_procedure(gtk_window_maximize, gxg_gtk_window_maximize_w, 1, 0, 0, H_gtk_window_maximize, pl_tu);
Xg_define_procedure(gtk_window_unmaximize, gxg_gtk_window_unmaximize_w, 1, 0, 0, H_gtk_window_unmaximize, pl_tu);
- Xg_define_procedure(gtk_window_begin_resize_drag, gxg_gtk_window_begin_resize_drag_w, 6, 0, 0, H_gtk_window_begin_resize_drag, pl_tui);
+ Xg_define_procedure(gtk_window_begin_resize_drag, gxg_gtk_window_begin_resize_drag_w, 6, 0, 0, H_gtk_window_begin_resize_drag, pl_tugi);
Xg_define_procedure(gtk_window_begin_move_drag, gxg_gtk_window_begin_move_drag_w, 5, 0, 0, H_gtk_window_begin_move_drag, pl_tui);
Xg_define_procedure(gtk_window_set_default_size, gxg_gtk_window_set_default_size_w, 3, 0, 0, H_gtk_window_set_default_size, pl_tui);
Xg_define_procedure(gtk_window_get_default_size, gxg_gtk_window_get_default_size_w, 1, 2, 0, H_gtk_window_get_default_size, pl_tu);
@@ -40934,11 +41355,10 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_get_size, gxg_gtk_window_get_size_w, 1, 2, 0, H_gtk_window_get_size, pl_tu);
Xg_define_procedure(gtk_window_move, gxg_gtk_window_move_w, 3, 0, 0, H_gtk_window_move, pl_tui);
Xg_define_procedure(gtk_window_get_position, gxg_gtk_window_get_position_w, 1, 2, 0, H_gtk_window_get_position, pl_tu);
- Xg_define_procedure(gtk_window_parse_geometry, gxg_gtk_window_parse_geometry_w, 2, 0, 0, H_gtk_window_parse_geometry, pl_bus);
Xg_define_procedure(pango_color_copy, gxg_pango_color_copy_w, 1, 0, 0, H_pango_color_copy, pl_pu);
Xg_define_procedure(pango_color_free, gxg_pango_color_free_w, 1, 0, 0, H_pango_color_free, pl_tu);
Xg_define_procedure(pango_color_parse, gxg_pango_color_parse_w, 2, 0, 0, H_pango_color_parse, pl_bus);
- Xg_define_procedure(pango_attr_type_register, gxg_pango_attr_type_register_w, 1, 0, 0, H_pango_attr_type_register, pl_is);
+ Xg_define_procedure(pango_attr_type_register, gxg_pango_attr_type_register_w, 1, 0, 0, H_pango_attr_type_register, pl_gs);
Xg_define_procedure(pango_attribute_copy, gxg_pango_attribute_copy_w, 1, 0, 0, H_pango_attribute_copy, pl_pu);
Xg_define_procedure(pango_attribute_destroy, gxg_pango_attribute_destroy_w, 1, 0, 0, H_pango_attribute_destroy, pl_tu);
Xg_define_procedure(pango_attribute_equal, gxg_pango_attribute_equal_w, 2, 0, 0, H_pango_attribute_equal, pl_bu);
@@ -40947,12 +41367,12 @@ pl_unused = NULL;
Xg_define_procedure(pango_attr_foreground_new, gxg_pango_attr_foreground_new_w, 3, 0, 0, H_pango_attr_foreground_new, pl_pi);
Xg_define_procedure(pango_attr_background_new, gxg_pango_attr_background_new_w, 3, 0, 0, H_pango_attr_background_new, pl_pi);
Xg_define_procedure(pango_attr_size_new, gxg_pango_attr_size_new_w, 1, 0, 0, H_pango_attr_size_new, pl_pi);
- Xg_define_procedure(pango_attr_style_new, gxg_pango_attr_style_new_w, 1, 0, 0, H_pango_attr_style_new, pl_pi);
- Xg_define_procedure(pango_attr_weight_new, gxg_pango_attr_weight_new_w, 1, 0, 0, H_pango_attr_weight_new, pl_pi);
- Xg_define_procedure(pango_attr_variant_new, gxg_pango_attr_variant_new_w, 1, 0, 0, H_pango_attr_variant_new, pl_pi);
- Xg_define_procedure(pango_attr_stretch_new, gxg_pango_attr_stretch_new_w, 1, 0, 0, H_pango_attr_stretch_new, pl_pi);
+ Xg_define_procedure(pango_attr_style_new, gxg_pango_attr_style_new_w, 1, 0, 0, H_pango_attr_style_new, pl_pg);
+ Xg_define_procedure(pango_attr_weight_new, gxg_pango_attr_weight_new_w, 1, 0, 0, H_pango_attr_weight_new, pl_pg);
+ Xg_define_procedure(pango_attr_variant_new, gxg_pango_attr_variant_new_w, 1, 0, 0, H_pango_attr_variant_new, pl_pg);
+ Xg_define_procedure(pango_attr_stretch_new, gxg_pango_attr_stretch_new_w, 1, 0, 0, H_pango_attr_stretch_new, pl_pg);
Xg_define_procedure(pango_attr_font_desc_new, gxg_pango_attr_font_desc_new_w, 1, 0, 0, H_pango_attr_font_desc_new, pl_pu);
- Xg_define_procedure(pango_attr_underline_new, gxg_pango_attr_underline_new_w, 1, 0, 0, H_pango_attr_underline_new, pl_pi);
+ Xg_define_procedure(pango_attr_underline_new, gxg_pango_attr_underline_new_w, 1, 0, 0, H_pango_attr_underline_new, pl_pg);
Xg_define_procedure(pango_attr_strikethrough_new, gxg_pango_attr_strikethrough_new_w, 1, 0, 0, H_pango_attr_strikethrough_new, pl_pb);
Xg_define_procedure(pango_attr_rise_new, gxg_pango_attr_rise_new_w, 1, 0, 0, H_pango_attr_rise_new, pl_pi);
Xg_define_procedure(pango_attr_shape_new, gxg_pango_attr_shape_new_w, 2, 0, 0, H_pango_attr_shape_new, pl_pu);
@@ -40969,7 +41389,7 @@ pl_unused = NULL;
Xg_define_procedure(pango_attr_iterator_next, gxg_pango_attr_iterator_next_w, 1, 0, 0, H_pango_attr_iterator_next, pl_bu);
Xg_define_procedure(pango_attr_iterator_copy, gxg_pango_attr_iterator_copy_w, 1, 0, 0, H_pango_attr_iterator_copy, pl_pu);
Xg_define_procedure(pango_attr_iterator_destroy, gxg_pango_attr_iterator_destroy_w, 1, 0, 0, H_pango_attr_iterator_destroy, pl_tu);
- Xg_define_procedure(pango_attr_iterator_get, gxg_pango_attr_iterator_get_w, 2, 0, 0, H_pango_attr_iterator_get, pl_pui);
+ 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_tu);
Xg_define_procedure(pango_parse_markup, gxg_pango_parse_markup_w, 6, 1, 0, H_pango_parse_markup, pl_bsiiuusu);
Xg_define_procedure(pango_break, gxg_pango_break_w, 5, 0, 0, H_pango_break, pl_tsiuui);
@@ -40983,15 +41403,15 @@ pl_unused = NULL;
Xg_define_procedure(pango_context_get_font_description, gxg_pango_context_get_font_description_w, 1, 0, 0, H_pango_context_get_font_description, pl_pu);
Xg_define_procedure(pango_context_get_language, gxg_pango_context_get_language_w, 1, 0, 0, H_pango_context_get_language, pl_pu);
Xg_define_procedure(pango_context_set_language, gxg_pango_context_set_language_w, 2, 0, 0, H_pango_context_set_language, pl_tu);
- Xg_define_procedure(pango_context_set_base_dir, gxg_pango_context_set_base_dir_w, 2, 0, 0, H_pango_context_set_base_dir, pl_tui);
- Xg_define_procedure(pango_context_get_base_dir, gxg_pango_context_get_base_dir_w, 1, 0, 0, H_pango_context_get_base_dir, pl_iu);
+ Xg_define_procedure(pango_context_set_base_dir, gxg_pango_context_set_base_dir_w, 2, 0, 0, H_pango_context_set_base_dir, pl_tug);
+ Xg_define_procedure(pango_context_get_base_dir, gxg_pango_context_get_base_dir_w, 1, 0, 0, H_pango_context_get_base_dir, pl_gu);
Xg_define_procedure(pango_itemize, gxg_pango_itemize_w, 6, 0, 0, H_pango_itemize, pl_pusiiu);
Xg_define_procedure(pango_coverage_new, gxg_pango_coverage_new_w, 0, 0, 0, H_pango_coverage_new, pl_p);
Xg_define_procedure(pango_coverage_ref, gxg_pango_coverage_ref_w, 1, 0, 0, H_pango_coverage_ref, pl_pu);
Xg_define_procedure(pango_coverage_unref, gxg_pango_coverage_unref_w, 1, 0, 0, H_pango_coverage_unref, pl_tu);
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_iui);
- Xg_define_procedure(pango_coverage_set, gxg_pango_coverage_set_w, 3, 0, 0, H_pango_coverage_set, pl_tui);
+ 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_tu);
Xg_define_procedure(pango_coverage_from_bytes, gxg_pango_coverage_from_bytes_w, 2, 0, 0, H_pango_coverage_from_bytes, pl_psi);
@@ -41005,18 +41425,18 @@ pl_unused = NULL;
Xg_define_procedure(pango_font_description_set_family, gxg_pango_font_description_set_family_w, 2, 0, 0, H_pango_font_description_set_family, pl_tus);
Xg_define_procedure(pango_font_description_set_family_static, gxg_pango_font_description_set_family_static_w, 2, 0, 0, H_pango_font_description_set_family_static, pl_tus);
Xg_define_procedure(pango_font_description_get_family, gxg_pango_font_description_get_family_w, 1, 0, 0, H_pango_font_description_get_family, pl_su);
- Xg_define_procedure(pango_font_description_set_style, gxg_pango_font_description_set_style_w, 2, 0, 0, H_pango_font_description_set_style, pl_tui);
- Xg_define_procedure(pango_font_description_get_style, gxg_pango_font_description_get_style_w, 1, 0, 0, H_pango_font_description_get_style, pl_iu);
- Xg_define_procedure(pango_font_description_set_variant, gxg_pango_font_description_set_variant_w, 2, 0, 0, H_pango_font_description_set_variant, pl_tui);
- Xg_define_procedure(pango_font_description_get_variant, gxg_pango_font_description_get_variant_w, 1, 0, 0, H_pango_font_description_get_variant, pl_iu);
- Xg_define_procedure(pango_font_description_set_weight, gxg_pango_font_description_set_weight_w, 2, 0, 0, H_pango_font_description_set_weight, pl_tui);
- Xg_define_procedure(pango_font_description_get_weight, gxg_pango_font_description_get_weight_w, 1, 0, 0, H_pango_font_description_get_weight, pl_iu);
- Xg_define_procedure(pango_font_description_set_stretch, gxg_pango_font_description_set_stretch_w, 2, 0, 0, H_pango_font_description_set_stretch, pl_tui);
- Xg_define_procedure(pango_font_description_get_stretch, gxg_pango_font_description_get_stretch_w, 1, 0, 0, H_pango_font_description_get_stretch, pl_iu);
+ Xg_define_procedure(pango_font_description_set_style, gxg_pango_font_description_set_style_w, 2, 0, 0, H_pango_font_description_set_style, pl_tug);
+ Xg_define_procedure(pango_font_description_get_style, gxg_pango_font_description_get_style_w, 1, 0, 0, H_pango_font_description_get_style, pl_gu);
+ Xg_define_procedure(pango_font_description_set_variant, gxg_pango_font_description_set_variant_w, 2, 0, 0, H_pango_font_description_set_variant, pl_tug);
+ Xg_define_procedure(pango_font_description_get_variant, gxg_pango_font_description_get_variant_w, 1, 0, 0, H_pango_font_description_get_variant, pl_gu);
+ Xg_define_procedure(pango_font_description_set_weight, gxg_pango_font_description_set_weight_w, 2, 0, 0, H_pango_font_description_set_weight, pl_tug);
+ Xg_define_procedure(pango_font_description_get_weight, gxg_pango_font_description_get_weight_w, 1, 0, 0, H_pango_font_description_get_weight, pl_gu);
+ Xg_define_procedure(pango_font_description_set_stretch, gxg_pango_font_description_set_stretch_w, 2, 0, 0, H_pango_font_description_set_stretch, pl_tug);
+ Xg_define_procedure(pango_font_description_get_stretch, gxg_pango_font_description_get_stretch_w, 1, 0, 0, H_pango_font_description_get_stretch, pl_gu);
Xg_define_procedure(pango_font_description_set_size, gxg_pango_font_description_set_size_w, 2, 0, 0, H_pango_font_description_set_size, pl_tui);
Xg_define_procedure(pango_font_description_get_size, gxg_pango_font_description_get_size_w, 1, 0, 0, H_pango_font_description_get_size, pl_iu);
- Xg_define_procedure(pango_font_description_get_set_fields, gxg_pango_font_description_get_set_fields_w, 1, 0, 0, H_pango_font_description_get_set_fields, pl_iu);
- Xg_define_procedure(pango_font_description_unset_fields, gxg_pango_font_description_unset_fields_w, 2, 0, 0, H_pango_font_description_unset_fields, pl_tui);
+ Xg_define_procedure(pango_font_description_get_set_fields, gxg_pango_font_description_get_set_fields_w, 1, 0, 0, H_pango_font_description_get_set_fields, pl_gu);
+ Xg_define_procedure(pango_font_description_unset_fields, gxg_pango_font_description_unset_fields_w, 2, 0, 0, H_pango_font_description_unset_fields, pl_tug);
Xg_define_procedure(pango_font_description_merge, gxg_pango_font_description_merge_w, 3, 0, 0, H_pango_font_description_merge, pl_tuub);
Xg_define_procedure(pango_font_description_merge_static, gxg_pango_font_description_merge_static_w, 3, 0, 0, H_pango_font_description_merge_static, pl_tuub);
Xg_define_procedure(pango_font_description_better_match, gxg_pango_font_description_better_match_w, 3, 0, 0, H_pango_font_description_better_match, pl_bu);
@@ -41067,16 +41487,16 @@ pl_unused = NULL;
Xg_define_procedure(pango_layout_set_font_description, gxg_pango_layout_set_font_description_w, 2, 0, 0, H_pango_layout_set_font_description, pl_tu);
Xg_define_procedure(pango_layout_set_width, gxg_pango_layout_set_width_w, 2, 0, 0, H_pango_layout_set_width, pl_tui);
Xg_define_procedure(pango_layout_get_width, gxg_pango_layout_get_width_w, 1, 0, 0, H_pango_layout_get_width, pl_iu);
- Xg_define_procedure(pango_layout_set_wrap, gxg_pango_layout_set_wrap_w, 2, 0, 0, H_pango_layout_set_wrap, pl_tui);
- Xg_define_procedure(pango_layout_get_wrap, gxg_pango_layout_get_wrap_w, 1, 0, 0, H_pango_layout_get_wrap, pl_iu);
+ Xg_define_procedure(pango_layout_set_wrap, gxg_pango_layout_set_wrap_w, 2, 0, 0, H_pango_layout_set_wrap, pl_tug);
+ Xg_define_procedure(pango_layout_get_wrap, gxg_pango_layout_get_wrap_w, 1, 0, 0, H_pango_layout_get_wrap, pl_gu);
Xg_define_procedure(pango_layout_set_indent, gxg_pango_layout_set_indent_w, 2, 0, 0, H_pango_layout_set_indent, pl_tui);
Xg_define_procedure(pango_layout_get_indent, gxg_pango_layout_get_indent_w, 1, 0, 0, H_pango_layout_get_indent, pl_iu);
Xg_define_procedure(pango_layout_set_spacing, gxg_pango_layout_set_spacing_w, 2, 0, 0, H_pango_layout_set_spacing, pl_tui);
Xg_define_procedure(pango_layout_get_spacing, gxg_pango_layout_get_spacing_w, 1, 0, 0, H_pango_layout_get_spacing, pl_iu);
Xg_define_procedure(pango_layout_set_justify, gxg_pango_layout_set_justify_w, 2, 0, 0, H_pango_layout_set_justify, pl_tub);
Xg_define_procedure(pango_layout_get_justify, gxg_pango_layout_get_justify_w, 1, 0, 0, H_pango_layout_get_justify, pl_bu);
- Xg_define_procedure(pango_layout_set_alignment, gxg_pango_layout_set_alignment_w, 2, 0, 0, H_pango_layout_set_alignment, pl_tui);
- Xg_define_procedure(pango_layout_get_alignment, gxg_pango_layout_get_alignment_w, 1, 0, 0, H_pango_layout_get_alignment, pl_iu);
+ Xg_define_procedure(pango_layout_set_alignment, gxg_pango_layout_set_alignment_w, 2, 0, 0, H_pango_layout_set_alignment, pl_tug);
+ Xg_define_procedure(pango_layout_get_alignment, gxg_pango_layout_get_alignment_w, 1, 0, 0, H_pango_layout_get_alignment, pl_gu);
Xg_define_procedure(pango_layout_set_tabs, gxg_pango_layout_set_tabs_w, 2, 0, 0, H_pango_layout_set_tabs, pl_tu);
Xg_define_procedure(pango_layout_get_tabs, gxg_pango_layout_get_tabs_w, 1, 0, 0, H_pango_layout_get_tabs, pl_pu);
Xg_define_procedure(pango_layout_set_single_paragraph_mode, gxg_pango_layout_set_single_paragraph_mode_w, 2, 0, 0, H_pango_layout_set_single_paragraph_mode, pl_tub);
@@ -41186,8 +41606,8 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_set_keep_above, gxg_gdk_window_set_keep_above_w, 2, 0, 0, H_gdk_window_set_keep_above, pl_tub);
Xg_define_procedure(gdk_window_set_keep_below, gxg_gdk_window_set_keep_below_w, 2, 0, 0, H_gdk_window_set_keep_below, pl_tub);
Xg_define_procedure(gtk_button_box_get_child_secondary, gxg_gtk_button_box_get_child_secondary_w, 2, 0, 0, H_gtk_button_box_get_child_secondary, pl_bu);
- Xg_define_procedure(gtk_calendar_set_display_options, gxg_gtk_calendar_set_display_options_w, 2, 0, 0, H_gtk_calendar_set_display_options, pl_tui);
- Xg_define_procedure(gtk_calendar_get_display_options, gxg_gtk_calendar_get_display_options_w, 1, 0, 0, H_gtk_calendar_get_display_options, pl_iu);
+ Xg_define_procedure(gtk_calendar_set_display_options, gxg_gtk_calendar_set_display_options_w, 2, 0, 0, H_gtk_calendar_set_display_options, pl_tug);
+ Xg_define_procedure(gtk_calendar_get_display_options, gxg_gtk_calendar_get_display_options_w, 1, 0, 0, H_gtk_calendar_get_display_options, pl_gu);
Xg_define_procedure(gtk_check_menu_item_set_draw_as_radio, gxg_gtk_check_menu_item_set_draw_as_radio_w, 2, 0, 0, H_gtk_check_menu_item_set_draw_as_radio, pl_tub);
Xg_define_procedure(gtk_check_menu_item_get_draw_as_radio, gxg_gtk_check_menu_item_get_draw_as_radio_w, 1, 0, 0, H_gtk_check_menu_item_get_draw_as_radio, pl_bu);
Xg_define_procedure(gtk_entry_set_completion, gxg_gtk_entry_set_completion_w, 2, 0, 0, H_gtk_entry_set_completion, pl_tu);
@@ -41208,7 +41628,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_toolbar_get_nth_item, gxg_gtk_toolbar_get_nth_item_w, 2, 0, 0, H_gtk_toolbar_get_nth_item, pl_pui);
Xg_define_procedure(gtk_toolbar_set_show_arrow, gxg_gtk_toolbar_set_show_arrow_w, 2, 0, 0, H_gtk_toolbar_set_show_arrow, pl_tub);
Xg_define_procedure(gtk_toolbar_get_show_arrow, gxg_gtk_toolbar_get_show_arrow_w, 1, 0, 0, H_gtk_toolbar_get_show_arrow, pl_bu);
- Xg_define_procedure(gtk_toolbar_get_relief_style, gxg_gtk_toolbar_get_relief_style_w, 1, 0, 0, H_gtk_toolbar_get_relief_style, pl_iu);
+ Xg_define_procedure(gtk_toolbar_get_relief_style, gxg_gtk_toolbar_get_relief_style_w, 1, 0, 0, H_gtk_toolbar_get_relief_style, pl_gu);
Xg_define_procedure(gtk_toolbar_get_drop_index, gxg_gtk_toolbar_get_drop_index_w, 3, 0, 0, H_gtk_toolbar_get_drop_index, pl_iui);
Xg_define_procedure(gtk_tree_view_column_set_expand, gxg_gtk_tree_view_column_set_expand_w, 2, 0, 0, H_gtk_tree_view_column_set_expand, pl_tub);
Xg_define_procedure(gtk_tree_view_column_get_expand, gxg_gtk_tree_view_column_get_expand_w, 1, 0, 0, H_gtk_tree_view_column_get_expand, pl_bu);
@@ -41218,8 +41638,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_set_default_icon, gxg_gtk_window_set_default_icon_w, 1, 0, 0, H_gtk_window_set_default_icon, pl_tu);
Xg_define_procedure(gtk_window_set_keep_above, gxg_gtk_window_set_keep_above_w, 2, 0, 0, H_gtk_window_set_keep_above, pl_tub);
Xg_define_procedure(gtk_window_set_keep_below, gxg_gtk_window_set_keep_below_w, 2, 0, 0, H_gtk_window_set_keep_below, pl_tub);
- Xg_define_procedure(gtk_file_chooser_dialog_new, gxg_gtk_file_chooser_dialog_new_w, 3, 1, 0, H_gtk_file_chooser_dialog_new, pl_psuit);
- Xg_define_procedure(gtk_file_chooser_widget_new, gxg_gtk_file_chooser_widget_new_w, 1, 0, 0, H_gtk_file_chooser_widget_new, pl_pi);
+ Xg_define_procedure(gtk_file_chooser_dialog_new, gxg_gtk_file_chooser_dialog_new_w, 3, 1, 0, H_gtk_file_chooser_dialog_new, pl_psugt);
+ Xg_define_procedure(gtk_file_chooser_widget_new, gxg_gtk_file_chooser_widget_new_w, 1, 0, 0, H_gtk_file_chooser_widget_new, pl_pg);
Xg_define_procedure(gtk_tree_model_filter_new, gxg_gtk_tree_model_filter_new_w, 2, 0, 0, H_gtk_tree_model_filter_new, pl_pu);
Xg_define_procedure(gtk_tree_model_filter_set_visible_column, gxg_gtk_tree_model_filter_set_visible_column_w, 2, 0, 0, H_gtk_tree_model_filter_set_visible_column, pl_tui);
Xg_define_procedure(gtk_tree_model_filter_get_model, gxg_gtk_tree_model_filter_get_model_w, 1, 0, 0, H_gtk_tree_model_filter_get_model, pl_pu);
@@ -41300,8 +41720,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_file_filter_get_name, gxg_gtk_file_filter_get_name_w, 1, 0, 0, H_gtk_file_filter_get_name, pl_su);
Xg_define_procedure(gtk_file_filter_add_mime_type, gxg_gtk_file_filter_add_mime_type_w, 2, 0, 0, H_gtk_file_filter_add_mime_type, pl_tus);
Xg_define_procedure(gtk_file_filter_add_pattern, gxg_gtk_file_filter_add_pattern_w, 2, 0, 0, H_gtk_file_filter_add_pattern, pl_tus);
- Xg_define_procedure(gtk_file_filter_add_custom, gxg_gtk_file_filter_add_custom_w, 5, 0, 0, H_gtk_file_filter_add_custom, pl_tuit);
- Xg_define_procedure(gtk_file_filter_get_needed, gxg_gtk_file_filter_get_needed_w, 1, 0, 0, H_gtk_file_filter_get_needed, pl_iu);
+ Xg_define_procedure(gtk_file_filter_add_custom, gxg_gtk_file_filter_add_custom_w, 5, 0, 0, H_gtk_file_filter_add_custom, pl_tugt);
+ Xg_define_procedure(gtk_file_filter_get_needed, gxg_gtk_file_filter_get_needed_w, 1, 0, 0, H_gtk_file_filter_get_needed, pl_gu);
Xg_define_procedure(gtk_file_filter_filter, gxg_gtk_file_filter_filter_w, 2, 0, 0, H_gtk_file_filter_filter, pl_bu);
Xg_define_procedure(gtk_cell_layout_pack_start, gxg_gtk_cell_layout_pack_start_w, 3, 0, 0, H_gtk_cell_layout_pack_start, pl_tuub);
Xg_define_procedure(gtk_cell_layout_pack_end, gxg_gtk_cell_layout_pack_end_w, 3, 0, 0, H_gtk_cell_layout_pack_end, pl_tuub);
@@ -41310,8 +41730,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_cell_layout_add_attribute, gxg_gtk_cell_layout_add_attribute_w, 4, 0, 0, H_gtk_cell_layout_add_attribute, pl_tuusi);
Xg_define_procedure(gtk_cell_layout_set_cell_data_func, gxg_gtk_cell_layout_set_cell_data_func_w, 5, 0, 0, H_gtk_cell_layout_set_cell_data_func, pl_tuut);
Xg_define_procedure(gtk_cell_layout_clear_attributes, gxg_gtk_cell_layout_clear_attributes_w, 2, 0, 0, H_gtk_cell_layout_clear_attributes, pl_tu);
- Xg_define_procedure(gtk_file_chooser_set_action, gxg_gtk_file_chooser_set_action_w, 2, 0, 0, H_gtk_file_chooser_set_action, pl_tui);
- Xg_define_procedure(gtk_file_chooser_get_action, gxg_gtk_file_chooser_get_action_w, 1, 0, 0, H_gtk_file_chooser_get_action, pl_iu);
+ Xg_define_procedure(gtk_file_chooser_set_action, gxg_gtk_file_chooser_set_action_w, 2, 0, 0, H_gtk_file_chooser_set_action, pl_tug);
+ Xg_define_procedure(gtk_file_chooser_get_action, gxg_gtk_file_chooser_get_action_w, 1, 0, 0, H_gtk_file_chooser_get_action, pl_gu);
Xg_define_procedure(gtk_file_chooser_set_local_only, gxg_gtk_file_chooser_set_local_only_w, 2, 0, 0, H_gtk_file_chooser_set_local_only, pl_tub);
Xg_define_procedure(gtk_file_chooser_get_local_only, gxg_gtk_file_chooser_get_local_only_w, 1, 0, 0, H_gtk_file_chooser_get_local_only, pl_bu);
Xg_define_procedure(gtk_file_chooser_set_select_multiple, gxg_gtk_file_chooser_set_select_multiple_w, 2, 0, 0, H_gtk_file_chooser_set_select_multiple, pl_tub);
@@ -41361,8 +41781,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_icon_theme_prepend_search_path, gxg_gtk_icon_theme_prepend_search_path_w, 2, 0, 0, H_gtk_icon_theme_prepend_search_path, pl_tus);
Xg_define_procedure(gtk_icon_theme_set_custom_theme, gxg_gtk_icon_theme_set_custom_theme_w, 2, 0, 0, H_gtk_icon_theme_set_custom_theme, pl_tus);
Xg_define_procedure(gtk_icon_theme_has_icon, gxg_gtk_icon_theme_has_icon_w, 2, 0, 0, H_gtk_icon_theme_has_icon, pl_bus);
- Xg_define_procedure(gtk_icon_theme_lookup_icon, gxg_gtk_icon_theme_lookup_icon_w, 4, 0, 0, H_gtk_icon_theme_lookup_icon, pl_pusi);
- Xg_define_procedure(gtk_icon_theme_load_icon, gxg_gtk_icon_theme_load_icon_w, 4, 1, 0, H_gtk_icon_theme_load_icon, pl_pusiiu);
+ Xg_define_procedure(gtk_icon_theme_lookup_icon, gxg_gtk_icon_theme_lookup_icon_w, 4, 0, 0, H_gtk_icon_theme_lookup_icon, pl_pusig);
+ Xg_define_procedure(gtk_icon_theme_load_icon, gxg_gtk_icon_theme_load_icon_w, 4, 1, 0, H_gtk_icon_theme_load_icon, pl_pusigu);
Xg_define_procedure(gtk_icon_theme_list_icons, gxg_gtk_icon_theme_list_icons_w, 2, 0, 0, H_gtk_icon_theme_list_icons, pl_pus);
Xg_define_procedure(gtk_icon_theme_get_example_icon_name, gxg_gtk_icon_theme_get_example_icon_name_w, 1, 0, 0, H_gtk_icon_theme_get_example_icon_name, pl_su);
Xg_define_procedure(gtk_icon_theme_rescan_if_needed, gxg_gtk_icon_theme_rescan_if_needed_w, 1, 0, 0, H_gtk_icon_theme_rescan_if_needed, pl_bu);
@@ -41391,9 +41811,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tool_item_get_visible_vertical, gxg_gtk_tool_item_get_visible_vertical_w, 1, 0, 0, H_gtk_tool_item_get_visible_vertical, pl_bu);
Xg_define_procedure(gtk_tool_item_get_is_important, gxg_gtk_tool_item_get_is_important_w, 1, 0, 0, H_gtk_tool_item_get_is_important, pl_bu);
Xg_define_procedure(gtk_tool_item_set_is_important, gxg_gtk_tool_item_set_is_important_w, 2, 0, 0, H_gtk_tool_item_set_is_important, pl_tub);
- Xg_define_procedure(gtk_tool_item_get_orientation, gxg_gtk_tool_item_get_orientation_w, 1, 0, 0, H_gtk_tool_item_get_orientation, pl_iu);
- Xg_define_procedure(gtk_tool_item_get_toolbar_style, gxg_gtk_tool_item_get_toolbar_style_w, 1, 0, 0, H_gtk_tool_item_get_toolbar_style, pl_iu);
- Xg_define_procedure(gtk_tool_item_get_relief_style, gxg_gtk_tool_item_get_relief_style_w, 1, 0, 0, H_gtk_tool_item_get_relief_style, pl_iu);
+ Xg_define_procedure(gtk_tool_item_get_orientation, gxg_gtk_tool_item_get_orientation_w, 1, 0, 0, H_gtk_tool_item_get_orientation, pl_gu);
+ Xg_define_procedure(gtk_tool_item_get_toolbar_style, gxg_gtk_tool_item_get_toolbar_style_w, 1, 0, 0, H_gtk_tool_item_get_toolbar_style, pl_gu);
+ Xg_define_procedure(gtk_tool_item_get_relief_style, gxg_gtk_tool_item_get_relief_style_w, 1, 0, 0, H_gtk_tool_item_get_relief_style, pl_gu);
Xg_define_procedure(gtk_tool_item_retrieve_proxy_menu_item, gxg_gtk_tool_item_retrieve_proxy_menu_item_w, 1, 0, 0, H_gtk_tool_item_retrieve_proxy_menu_item, pl_pu);
Xg_define_procedure(gtk_tool_item_get_proxy_menu_item, gxg_gtk_tool_item_get_proxy_menu_item_w, 2, 0, 0, H_gtk_tool_item_get_proxy_menu_item, pl_pus);
Xg_define_procedure(gtk_tool_item_set_proxy_menu_item, gxg_gtk_tool_item_set_proxy_menu_item_w, 3, 0, 0, H_gtk_tool_item_set_proxy_menu_item, pl_tusu);
@@ -41496,8 +41916,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_icon_view_get_pixbuf_column, gxg_gtk_icon_view_get_pixbuf_column_w, 1, 0, 0, H_gtk_icon_view_get_pixbuf_column, pl_iu);
Xg_define_procedure(gtk_icon_view_get_path_at_pos, gxg_gtk_icon_view_get_path_at_pos_w, 3, 0, 0, H_gtk_icon_view_get_path_at_pos, pl_pui);
Xg_define_procedure(gtk_icon_view_selected_foreach, gxg_gtk_icon_view_selected_foreach_w, 2, 1, 0, H_gtk_icon_view_selected_foreach, pl_tut);
- Xg_define_procedure(gtk_icon_view_set_selection_mode, gxg_gtk_icon_view_set_selection_mode_w, 2, 0, 0, H_gtk_icon_view_set_selection_mode, pl_tui);
- Xg_define_procedure(gtk_icon_view_get_selection_mode, gxg_gtk_icon_view_get_selection_mode_w, 1, 0, 0, H_gtk_icon_view_get_selection_mode, pl_iu);
+ Xg_define_procedure(gtk_icon_view_set_selection_mode, gxg_gtk_icon_view_set_selection_mode_w, 2, 0, 0, H_gtk_icon_view_set_selection_mode, pl_tug);
+ Xg_define_procedure(gtk_icon_view_get_selection_mode, gxg_gtk_icon_view_get_selection_mode_w, 1, 0, 0, H_gtk_icon_view_get_selection_mode, pl_gu);
Xg_define_procedure(gtk_icon_view_select_path, gxg_gtk_icon_view_select_path_w, 2, 0, 0, H_gtk_icon_view_select_path, pl_tu);
Xg_define_procedure(gtk_icon_view_unselect_path, gxg_gtk_icon_view_unselect_path_w, 2, 0, 0, H_gtk_icon_view_unselect_path, pl_tu);
Xg_define_procedure(gtk_icon_view_path_is_selected, gxg_gtk_icon_view_path_is_selected_w, 2, 0, 0, H_gtk_icon_view_path_is_selected, pl_bu);
@@ -41508,8 +41928,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_cell_renderer_combo_new, gxg_gtk_cell_renderer_combo_new_w, 0, 0, 0, H_gtk_cell_renderer_combo_new, pl_p);
Xg_define_procedure(gtk_cell_renderer_progress_new, gxg_gtk_cell_renderer_progress_new_w, 0, 0, 0, H_gtk_cell_renderer_progress_new, pl_p);
Xg_define_procedure(gtk_combo_box_set_row_separator_func, gxg_gtk_combo_box_set_row_separator_func_w, 4, 0, 0, H_gtk_combo_box_set_row_separator_func, pl_tut);
- Xg_define_procedure(gtk_label_set_ellipsize, gxg_gtk_label_set_ellipsize_w, 2, 0, 0, H_gtk_label_set_ellipsize, pl_tui);
- Xg_define_procedure(gtk_label_get_ellipsize, gxg_gtk_label_get_ellipsize_w, 1, 0, 0, H_gtk_label_get_ellipsize, pl_iu);
+ Xg_define_procedure(gtk_label_set_ellipsize, gxg_gtk_label_set_ellipsize_w, 2, 0, 0, H_gtk_label_set_ellipsize, pl_tug);
+ Xg_define_procedure(gtk_label_get_ellipsize, gxg_gtk_label_get_ellipsize_w, 1, 0, 0, H_gtk_label_get_ellipsize, pl_gu);
Xg_define_procedure(pango_attr_fallback_new, gxg_pango_attr_fallback_new_w, 1, 0, 0, H_pango_attr_fallback_new, pl_pb);
Xg_define_procedure(pango_attr_letter_spacing_new, gxg_pango_attr_letter_spacing_new_w, 1, 0, 0, H_pango_attr_letter_spacing_new, pl_pi);
Xg_define_procedure(pango_attr_list_filter, gxg_pango_attr_list_filter_w, 3, 0, 0, H_pango_attr_list_filter, pl_put);
@@ -41522,7 +41942,7 @@ pl_unused = NULL;
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_tu);
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_i);
+ 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_tu);
Xg_define_procedure(pango_script_iter_next, gxg_pango_script_iter_next_w, 1, 0, 0, H_pango_script_iter_next, pl_bu);
@@ -41544,7 +41964,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_display_supports_clipboard_persistence, gxg_gdk_display_supports_clipboard_persistence_w, 1, 0, 0, H_gdk_display_supports_clipboard_persistence, pl_bu);
Xg_define_procedure(gtk_about_dialog_get_logo_icon_name, gxg_gtk_about_dialog_get_logo_icon_name_w, 1, 0, 0, H_gtk_about_dialog_get_logo_icon_name, pl_su);
Xg_define_procedure(gtk_about_dialog_set_logo_icon_name, gxg_gtk_about_dialog_set_logo_icon_name_w, 2, 0, 0, H_gtk_about_dialog_set_logo_icon_name, pl_tus);
- Xg_define_procedure(gtk_accelerator_get_label, gxg_gtk_accelerator_get_label_w, 2, 0, 0, H_gtk_accelerator_get_label, pl_si);
+ Xg_define_procedure(gtk_accelerator_get_label, gxg_gtk_accelerator_get_label_w, 2, 0, 0, H_gtk_accelerator_get_label, pl_sig);
Xg_define_procedure(gtk_clipboard_wait_is_target_available, gxg_gtk_clipboard_wait_is_target_available_w, 2, 0, 0, H_gtk_clipboard_wait_is_target_available, pl_but);
Xg_define_procedure(gtk_clipboard_set_can_store, gxg_gtk_clipboard_set_can_store_w, 3, 0, 0, H_gtk_clipboard_set_can_store, pl_tuui);
Xg_define_procedure(gtk_clipboard_store, gxg_gtk_clipboard_store_w, 1, 0, 0, H_gtk_clipboard_store, pl_tu);
@@ -41573,8 +41993,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_file_filter_add_pixbuf_formats, gxg_gtk_file_filter_add_pixbuf_formats_w, 1, 0, 0, H_gtk_file_filter_add_pixbuf_formats, pl_tu);
Xg_define_procedure(gtk_label_set_single_line_mode, gxg_gtk_label_set_single_line_mode_w, 2, 0, 0, H_gtk_label_set_single_line_mode, pl_tub);
Xg_define_procedure(gtk_label_get_single_line_mode, gxg_gtk_label_get_single_line_mode_w, 1, 0, 0, H_gtk_label_get_single_line_mode, pl_bu);
- Xg_define_procedure(gtk_progress_bar_set_ellipsize, gxg_gtk_progress_bar_set_ellipsize_w, 2, 0, 0, H_gtk_progress_bar_set_ellipsize, pl_tui);
- Xg_define_procedure(gtk_progress_bar_get_ellipsize, gxg_gtk_progress_bar_get_ellipsize_w, 1, 0, 0, H_gtk_progress_bar_get_ellipsize, pl_iu);
+ Xg_define_procedure(gtk_progress_bar_set_ellipsize, gxg_gtk_progress_bar_set_ellipsize_w, 2, 0, 0, H_gtk_progress_bar_set_ellipsize, pl_tug);
+ Xg_define_procedure(gtk_progress_bar_get_ellipsize, gxg_gtk_progress_bar_get_ellipsize_w, 1, 0, 0, H_gtk_progress_bar_get_ellipsize, pl_gu);
Xg_define_procedure(gtk_selection_data_targets_include_image, gxg_gtk_selection_data_targets_include_image_w, 2, 0, 0, H_gtk_selection_data_targets_include_image, pl_bub);
Xg_define_procedure(gtk_button_set_image, gxg_gtk_button_set_image_w, 2, 0, 0, H_gtk_button_set_image, pl_tu);
Xg_define_procedure(gtk_button_get_image, gxg_gtk_button_get_image_w, 1, 0, 0, H_gtk_button_get_image, pl_pu);
@@ -41586,20 +42006,20 @@ pl_unused = NULL;
Xg_define_procedure(pango_renderer_draw_layout, gxg_pango_renderer_draw_layout_w, 4, 0, 0, H_pango_renderer_draw_layout, pl_tuui);
Xg_define_procedure(pango_renderer_draw_layout_line, gxg_pango_renderer_draw_layout_line_w, 4, 0, 0, H_pango_renderer_draw_layout_line, pl_tuui);
Xg_define_procedure(pango_renderer_draw_glyphs, gxg_pango_renderer_draw_glyphs_w, 5, 0, 0, H_pango_renderer_draw_glyphs, pl_tuuui);
- Xg_define_procedure(pango_renderer_draw_rectangle, gxg_pango_renderer_draw_rectangle_w, 6, 0, 0, H_pango_renderer_draw_rectangle, pl_tui);
+ Xg_define_procedure(pango_renderer_draw_rectangle, gxg_pango_renderer_draw_rectangle_w, 6, 0, 0, H_pango_renderer_draw_rectangle, pl_tugi);
Xg_define_procedure(pango_renderer_draw_error_underline, gxg_pango_renderer_draw_error_underline_w, 5, 0, 0, H_pango_renderer_draw_error_underline, pl_tui);
- Xg_define_procedure(pango_renderer_draw_trapezoid, gxg_pango_renderer_draw_trapezoid_w, 0, 0, 1, H_pango_renderer_draw_trapezoid, pl_tuir);
+ Xg_define_procedure(pango_renderer_draw_trapezoid, gxg_pango_renderer_draw_trapezoid_w, 0, 0, 1, H_pango_renderer_draw_trapezoid, pl_tugr);
Xg_define_procedure(pango_renderer_draw_glyph, gxg_pango_renderer_draw_glyph_w, 5, 0, 0, H_pango_renderer_draw_glyph, pl_tuuir);
Xg_define_procedure(pango_renderer_activate, gxg_pango_renderer_activate_w, 1, 0, 0, H_pango_renderer_activate, pl_tu);
Xg_define_procedure(pango_renderer_deactivate, gxg_pango_renderer_deactivate_w, 1, 0, 0, H_pango_renderer_deactivate, pl_tu);
- Xg_define_procedure(pango_renderer_part_changed, gxg_pango_renderer_part_changed_w, 2, 0, 0, H_pango_renderer_part_changed, pl_tui);
- Xg_define_procedure(pango_renderer_set_color, gxg_pango_renderer_set_color_w, 3, 0, 0, H_pango_renderer_set_color, pl_tuiu);
- Xg_define_procedure(pango_renderer_get_color, gxg_pango_renderer_get_color_w, 2, 0, 0, H_pango_renderer_get_color, pl_pui);
+ Xg_define_procedure(pango_renderer_part_changed, gxg_pango_renderer_part_changed_w, 2, 0, 0, H_pango_renderer_part_changed, pl_tug);
+ Xg_define_procedure(pango_renderer_set_color, gxg_pango_renderer_set_color_w, 3, 0, 0, H_pango_renderer_set_color, pl_tugu);
+ Xg_define_procedure(pango_renderer_get_color, gxg_pango_renderer_get_color_w, 2, 0, 0, H_pango_renderer_get_color, pl_pug);
Xg_define_procedure(pango_renderer_set_matrix, gxg_pango_renderer_set_matrix_w, 2, 0, 0, H_pango_renderer_set_matrix, pl_tu);
- Xg_define_procedure(g_log_set_handler, gxg_g_log_set_handler_w, 3, 1, 0, H_g_log_set_handler, pl_isit);
+ Xg_define_procedure(g_log_set_handler, gxg_g_log_set_handler_w, 3, 1, 0, H_g_log_set_handler, pl_isgt);
Xg_define_procedure(g_log_remove_handler, gxg_g_log_remove_handler_w, 2, 0, 0, H_g_log_remove_handler, pl_tsi);
Xg_define_procedure(gtk_cell_renderer_stop_editing, gxg_gtk_cell_renderer_stop_editing_w, 2, 0, 0, H_gtk_cell_renderer_stop_editing, pl_tub);
- Xg_define_procedure(gtk_file_chooser_button_new, gxg_gtk_file_chooser_button_new_w, 2, 0, 0, H_gtk_file_chooser_button_new, pl_psi);
+ Xg_define_procedure(gtk_file_chooser_button_new, gxg_gtk_file_chooser_button_new_w, 2, 0, 0, H_gtk_file_chooser_button_new, pl_psg);
Xg_define_procedure(gtk_icon_view_set_columns, gxg_gtk_icon_view_set_columns_w, 2, 0, 0, H_gtk_icon_view_set_columns, pl_tui);
Xg_define_procedure(gtk_icon_view_get_columns, gxg_gtk_icon_view_get_columns_w, 1, 0, 0, H_gtk_icon_view_get_columns, pl_iu);
Xg_define_procedure(gtk_icon_view_set_item_width, gxg_gtk_icon_view_set_item_width_w, 2, 0, 0, H_gtk_icon_view_set_item_width, pl_tui);
@@ -41616,7 +42036,6 @@ pl_unused = NULL;
Xg_define_procedure(gtk_label_get_max_width_chars, gxg_gtk_label_get_max_width_chars_w, 1, 0, 0, H_gtk_label_get_max_width_chars, pl_iu);
Xg_define_procedure(gtk_list_store_insert_with_values, gxg_gtk_list_store_insert_with_values_w, 3, 0, 0, H_gtk_list_store_insert_with_values, pl_tuui);
Xg_define_procedure(gtk_list_store_insert_with_valuesv, gxg_gtk_list_store_insert_with_valuesv_w, 6, 0, 0, H_gtk_list_store_insert_with_valuesv, pl_tuuiuui);
- Xg_define_procedure(gtk_text_view_get_iter_at_position, gxg_gtk_text_view_get_iter_at_position_w, 4, 1, 0, H_gtk_text_view_get_iter_at_position, pl_tuuui);
Xg_define_procedure(pango_attr_size_new_absolute, gxg_pango_attr_size_new_absolute_w, 1, 0, 0, H_pango_attr_size_new_absolute, pl_pi);
Xg_define_procedure(pango_font_description_set_absolute_size, gxg_pango_font_description_set_absolute_size_w, 2, 0, 0, H_pango_font_description_set_absolute_size, pl_tur);
Xg_define_procedure(pango_layout_get_font_description, gxg_pango_layout_get_font_description_w, 1, 0, 0, H_pango_layout_get_font_description, pl_pu);
@@ -41636,20 +42055,20 @@ pl_unused = NULL;
Xg_define_procedure(gtk_icon_view_set_cursor, gxg_gtk_icon_view_set_cursor_w, 4, 0, 0, H_gtk_icon_view_set_cursor, pl_tuuub);
Xg_define_procedure(gtk_icon_view_get_cursor, gxg_gtk_icon_view_get_cursor_w, 1, 2, 0, H_gtk_icon_view_get_cursor, pl_bu);
Xg_define_procedure(gtk_icon_view_scroll_to_path, gxg_gtk_icon_view_scroll_to_path_w, 5, 0, 0, H_gtk_icon_view_scroll_to_path, pl_tuubr);
- Xg_define_procedure(gtk_icon_view_enable_model_drag_source, gxg_gtk_icon_view_enable_model_drag_source_w, 5, 0, 0, H_gtk_icon_view_enable_model_drag_source, pl_tuiui);
- Xg_define_procedure(gtk_icon_view_enable_model_drag_dest, gxg_gtk_icon_view_enable_model_drag_dest_w, 4, 0, 0, H_gtk_icon_view_enable_model_drag_dest, pl_tuui);
+ Xg_define_procedure(gtk_icon_view_enable_model_drag_source, gxg_gtk_icon_view_enable_model_drag_source_w, 5, 0, 0, H_gtk_icon_view_enable_model_drag_source, pl_tuguig);
+ Xg_define_procedure(gtk_icon_view_enable_model_drag_dest, gxg_gtk_icon_view_enable_model_drag_dest_w, 4, 0, 0, H_gtk_icon_view_enable_model_drag_dest, pl_tuuig);
Xg_define_procedure(gtk_icon_view_unset_model_drag_source, gxg_gtk_icon_view_unset_model_drag_source_w, 1, 0, 0, H_gtk_icon_view_unset_model_drag_source, pl_tu);
Xg_define_procedure(gtk_icon_view_unset_model_drag_dest, gxg_gtk_icon_view_unset_model_drag_dest_w, 1, 0, 0, H_gtk_icon_view_unset_model_drag_dest, pl_tu);
Xg_define_procedure(gtk_icon_view_set_reorderable, gxg_gtk_icon_view_set_reorderable_w, 2, 0, 0, H_gtk_icon_view_set_reorderable, pl_tub);
Xg_define_procedure(gtk_icon_view_get_reorderable, gxg_gtk_icon_view_get_reorderable_w, 1, 0, 0, H_gtk_icon_view_get_reorderable, pl_bu);
- Xg_define_procedure(gtk_icon_view_set_drag_dest_item, gxg_gtk_icon_view_set_drag_dest_item_w, 3, 0, 0, H_gtk_icon_view_set_drag_dest_item, pl_tuui);
+ Xg_define_procedure(gtk_icon_view_set_drag_dest_item, gxg_gtk_icon_view_set_drag_dest_item_w, 3, 0, 0, H_gtk_icon_view_set_drag_dest_item, pl_tuug);
Xg_define_procedure(gtk_icon_view_get_drag_dest_item, gxg_gtk_icon_view_get_drag_dest_item_w, 1, 2, 0, H_gtk_icon_view_get_drag_dest_item, pl_tu);
Xg_define_procedure(gtk_icon_view_get_dest_item_at_pos, gxg_gtk_icon_view_get_dest_item_at_pos_w, 3, 2, 0, H_gtk_icon_view_get_dest_item_at_pos, pl_buiiu);
Xg_define_procedure(gtk_image_clear, gxg_gtk_image_clear_w, 1, 0, 0, H_gtk_image_clear, pl_tu);
- Xg_define_procedure(gtk_menu_bar_get_pack_direction, gxg_gtk_menu_bar_get_pack_direction_w, 1, 0, 0, H_gtk_menu_bar_get_pack_direction, pl_iu);
- Xg_define_procedure(gtk_menu_bar_set_pack_direction, gxg_gtk_menu_bar_set_pack_direction_w, 2, 0, 0, H_gtk_menu_bar_set_pack_direction, pl_tui);
- Xg_define_procedure(gtk_menu_bar_get_child_pack_direction, gxg_gtk_menu_bar_get_child_pack_direction_w, 1, 0, 0, H_gtk_menu_bar_get_child_pack_direction, pl_iu);
- Xg_define_procedure(gtk_menu_bar_set_child_pack_direction, gxg_gtk_menu_bar_set_child_pack_direction_w, 2, 0, 0, H_gtk_menu_bar_set_child_pack_direction, pl_tui);
+ Xg_define_procedure(gtk_menu_bar_get_pack_direction, gxg_gtk_menu_bar_get_pack_direction_w, 1, 0, 0, H_gtk_menu_bar_get_pack_direction, pl_gu);
+ Xg_define_procedure(gtk_menu_bar_set_pack_direction, gxg_gtk_menu_bar_set_pack_direction_w, 2, 0, 0, H_gtk_menu_bar_set_pack_direction, pl_tug);
+ Xg_define_procedure(gtk_menu_bar_get_child_pack_direction, gxg_gtk_menu_bar_get_child_pack_direction_w, 1, 0, 0, H_gtk_menu_bar_get_child_pack_direction, pl_gu);
+ Xg_define_procedure(gtk_menu_bar_set_child_pack_direction, gxg_gtk_menu_bar_set_child_pack_direction_w, 2, 0, 0, H_gtk_menu_bar_set_child_pack_direction, pl_tug);
Xg_define_procedure(gtk_menu_shell_get_take_focus, gxg_gtk_menu_shell_get_take_focus_w, 1, 0, 0, H_gtk_menu_shell_get_take_focus, pl_bu);
Xg_define_procedure(gtk_menu_shell_set_take_focus, gxg_gtk_menu_shell_set_take_focus_w, 2, 0, 0, H_gtk_menu_shell_set_take_focus, pl_tub);
Xg_define_procedure(gtk_size_group_set_ignore_hidden, gxg_gtk_size_group_set_ignore_hidden_w, 2, 0, 0, H_gtk_size_group_set_ignore_hidden, pl_tub);
@@ -41680,7 +42099,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_screen_get_resolution, gxg_gdk_screen_get_resolution_w, 1, 0, 0, H_gdk_screen_get_resolution, pl_du);
Xg_define_procedure(gdk_screen_get_active_window, gxg_gdk_screen_get_active_window_w, 1, 0, 0, H_gdk_screen_get_active_window, pl_pu);
Xg_define_procedure(gdk_screen_get_window_stack, gxg_gdk_screen_get_window_stack_w, 1, 0, 0, H_gdk_screen_get_window_stack, pl_pu);
- Xg_define_procedure(gdk_window_get_type_hint, gxg_gdk_window_get_type_hint_w, 1, 0, 0, H_gdk_window_get_type_hint, pl_iu);
+ Xg_define_procedure(gdk_window_get_type_hint, gxg_gdk_window_get_type_hint_w, 1, 0, 0, H_gdk_window_get_type_hint, pl_gu);
Xg_define_procedure(gtk_clipboard_request_rich_text, gxg_gtk_clipboard_request_rich_text_w, 3, 1, 0, H_gtk_clipboard_request_rich_text, pl_tuut);
Xg_define_procedure(gtk_clipboard_wait_for_rich_text, gxg_gtk_clipboard_wait_for_rich_text_w, 3, 1, 0, H_gtk_clipboard_wait_for_rich_text, pl_pu);
Xg_define_procedure(gtk_clipboard_wait_is_rich_text_available, gxg_gtk_clipboard_wait_is_rich_text_available_w, 2, 0, 0, H_gtk_clipboard_wait_is_rich_text_available, pl_bu);
@@ -41690,10 +42109,10 @@ pl_unused = NULL;
Xg_define_procedure(gtk_notebook_set_tab_reorderable, gxg_gtk_notebook_set_tab_reorderable_w, 3, 0, 0, H_gtk_notebook_set_tab_reorderable, pl_tuub);
Xg_define_procedure(gtk_notebook_get_tab_detachable, gxg_gtk_notebook_get_tab_detachable_w, 2, 0, 0, H_gtk_notebook_get_tab_detachable, pl_bu);
Xg_define_procedure(gtk_notebook_set_tab_detachable, gxg_gtk_notebook_set_tab_detachable_w, 3, 0, 0, H_gtk_notebook_set_tab_detachable, pl_tuub);
- Xg_define_procedure(gtk_range_set_lower_stepper_sensitivity, gxg_gtk_range_set_lower_stepper_sensitivity_w, 2, 0, 0, H_gtk_range_set_lower_stepper_sensitivity, pl_tui);
- Xg_define_procedure(gtk_range_get_lower_stepper_sensitivity, gxg_gtk_range_get_lower_stepper_sensitivity_w, 1, 0, 0, H_gtk_range_get_lower_stepper_sensitivity, pl_iu);
- Xg_define_procedure(gtk_range_set_upper_stepper_sensitivity, gxg_gtk_range_set_upper_stepper_sensitivity_w, 2, 0, 0, H_gtk_range_set_upper_stepper_sensitivity, pl_tui);
- Xg_define_procedure(gtk_range_get_upper_stepper_sensitivity, gxg_gtk_range_get_upper_stepper_sensitivity_w, 1, 0, 0, H_gtk_range_get_upper_stepper_sensitivity, pl_iu);
+ Xg_define_procedure(gtk_range_set_lower_stepper_sensitivity, gxg_gtk_range_set_lower_stepper_sensitivity_w, 2, 0, 0, H_gtk_range_set_lower_stepper_sensitivity, pl_tug);
+ Xg_define_procedure(gtk_range_get_lower_stepper_sensitivity, gxg_gtk_range_get_lower_stepper_sensitivity_w, 1, 0, 0, H_gtk_range_get_lower_stepper_sensitivity, pl_gu);
+ Xg_define_procedure(gtk_range_set_upper_stepper_sensitivity, gxg_gtk_range_set_upper_stepper_sensitivity_w, 2, 0, 0, H_gtk_range_set_upper_stepper_sensitivity, pl_tug);
+ Xg_define_procedure(gtk_range_get_upper_stepper_sensitivity, gxg_gtk_range_get_upper_stepper_sensitivity_w, 1, 0, 0, H_gtk_range_get_upper_stepper_sensitivity, pl_gu);
Xg_define_procedure(gtk_scrolled_window_unset_placement, gxg_gtk_scrolled_window_unset_placement_w, 1, 0, 0, H_gtk_scrolled_window_unset_placement, pl_tu);
Xg_define_procedure(gtk_target_list_add_rich_text_targets, gxg_gtk_target_list_add_rich_text_targets_w, 4, 0, 0, H_gtk_target_list_add_rich_text_targets, pl_tuibu);
Xg_define_procedure(gtk_target_table_new_from_list, gxg_gtk_target_table_new_from_list_w, 1, 1, 0, H_gtk_target_table_new_from_list, pl_pu);
@@ -41725,8 +42144,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_assistant_append_page, gxg_gtk_assistant_append_page_w, 2, 0, 0, H_gtk_assistant_append_page, pl_iu);
Xg_define_procedure(gtk_assistant_insert_page, gxg_gtk_assistant_insert_page_w, 3, 0, 0, H_gtk_assistant_insert_page, pl_iuui);
Xg_define_procedure(gtk_assistant_set_forward_page_func, gxg_gtk_assistant_set_forward_page_func_w, 3, 1, 0, H_gtk_assistant_set_forward_page_func, pl_tut);
- Xg_define_procedure(gtk_assistant_set_page_type, gxg_gtk_assistant_set_page_type_w, 3, 0, 0, H_gtk_assistant_set_page_type, pl_tuui);
- Xg_define_procedure(gtk_assistant_get_page_type, gxg_gtk_assistant_get_page_type_w, 2, 0, 0, H_gtk_assistant_get_page_type, pl_iu);
+ Xg_define_procedure(gtk_assistant_set_page_type, gxg_gtk_assistant_set_page_type_w, 3, 0, 0, H_gtk_assistant_set_page_type, pl_tuug);
+ Xg_define_procedure(gtk_assistant_get_page_type, gxg_gtk_assistant_get_page_type_w, 2, 0, 0, H_gtk_assistant_get_page_type, pl_gu);
Xg_define_procedure(gtk_assistant_set_page_title, gxg_gtk_assistant_set_page_title_w, 3, 0, 0, H_gtk_assistant_set_page_title, pl_tuus);
Xg_define_procedure(gtk_assistant_get_page_title, gxg_gtk_assistant_get_page_title_w, 2, 0, 0, H_gtk_assistant_get_page_title, pl_su);
Xg_define_procedure(gtk_assistant_set_page_complete, gxg_gtk_assistant_set_page_complete_w, 3, 0, 0, H_gtk_assistant_set_page_complete, pl_tuub);
@@ -41755,8 +42174,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_recent_chooser_get_show_tips, gxg_gtk_recent_chooser_get_show_tips_w, 1, 0, 0, H_gtk_recent_chooser_get_show_tips, pl_bu);
Xg_define_procedure(gtk_recent_chooser_set_show_icons, gxg_gtk_recent_chooser_set_show_icons_w, 2, 0, 0, H_gtk_recent_chooser_set_show_icons, pl_tub);
Xg_define_procedure(gtk_recent_chooser_get_show_icons, gxg_gtk_recent_chooser_get_show_icons_w, 1, 0, 0, H_gtk_recent_chooser_get_show_icons, pl_bu);
- Xg_define_procedure(gtk_recent_chooser_set_sort_type, gxg_gtk_recent_chooser_set_sort_type_w, 2, 0, 0, H_gtk_recent_chooser_set_sort_type, pl_tui);
- Xg_define_procedure(gtk_recent_chooser_get_sort_type, gxg_gtk_recent_chooser_get_sort_type_w, 1, 0, 0, H_gtk_recent_chooser_get_sort_type, pl_iu);
+ Xg_define_procedure(gtk_recent_chooser_set_sort_type, gxg_gtk_recent_chooser_set_sort_type_w, 2, 0, 0, H_gtk_recent_chooser_set_sort_type, pl_tug);
+ Xg_define_procedure(gtk_recent_chooser_get_sort_type, gxg_gtk_recent_chooser_get_sort_type_w, 1, 0, 0, H_gtk_recent_chooser_get_sort_type, pl_gu);
Xg_define_procedure(gtk_recent_chooser_set_sort_func, gxg_gtk_recent_chooser_set_sort_func_w, 3, 1, 0, H_gtk_recent_chooser_set_sort_func, pl_tut);
Xg_define_procedure(gtk_recent_chooser_set_current_uri, gxg_gtk_recent_chooser_set_current_uri_w, 2, 1, 0, H_gtk_recent_chooser_set_current_uri, pl_busu);
Xg_define_procedure(gtk_recent_chooser_get_current_uri, gxg_gtk_recent_chooser_get_current_uri_w, 1, 0, 0, H_gtk_recent_chooser_get_current_uri, pl_su);
@@ -41833,12 +42252,12 @@ pl_unused = NULL;
Xg_define_procedure(gtk_recent_manager_add_item, gxg_gtk_recent_manager_add_item_w, 2, 0, 0, H_gtk_recent_manager_add_item, pl_bus);
Xg_define_procedure(gtk_recent_manager_add_full, gxg_gtk_recent_manager_add_full_w, 3, 0, 0, H_gtk_recent_manager_add_full, pl_busu);
Xg_define_procedure(gtk_tree_model_filter_convert_child_iter_to_iter, gxg_gtk_tree_model_filter_convert_child_iter_to_iter_w, 3, 0, 0, H_gtk_tree_model_filter_convert_child_iter_to_iter, pl_bu);
- Xg_define_procedure(gtk_tree_view_get_grid_lines, gxg_gtk_tree_view_get_grid_lines_w, 1, 0, 0, H_gtk_tree_view_get_grid_lines, pl_iu);
- Xg_define_procedure(gtk_tree_view_set_grid_lines, gxg_gtk_tree_view_set_grid_lines_w, 2, 0, 0, H_gtk_tree_view_set_grid_lines, pl_tui);
+ Xg_define_procedure(gtk_tree_view_get_grid_lines, gxg_gtk_tree_view_get_grid_lines_w, 1, 0, 0, H_gtk_tree_view_get_grid_lines, pl_gu);
+ Xg_define_procedure(gtk_tree_view_set_grid_lines, gxg_gtk_tree_view_set_grid_lines_w, 2, 0, 0, H_gtk_tree_view_set_grid_lines, pl_tug);
Xg_define_procedure(gtk_tree_view_get_enable_tree_lines, gxg_gtk_tree_view_get_enable_tree_lines_w, 1, 0, 0, H_gtk_tree_view_get_enable_tree_lines, pl_bu);
Xg_define_procedure(gtk_tree_view_set_enable_tree_lines, gxg_gtk_tree_view_set_enable_tree_lines_w, 2, 0, 0, H_gtk_tree_view_set_enable_tree_lines, pl_tub);
- Xg_define_procedure(gtk_label_set_line_wrap_mode, gxg_gtk_label_set_line_wrap_mode_w, 2, 0, 0, H_gtk_label_set_line_wrap_mode, pl_tui);
- Xg_define_procedure(gtk_label_get_line_wrap_mode, gxg_gtk_label_get_line_wrap_mode_w, 1, 0, 0, H_gtk_label_get_line_wrap_mode, pl_iu);
+ Xg_define_procedure(gtk_label_set_line_wrap_mode, gxg_gtk_label_set_line_wrap_mode_w, 2, 0, 0, H_gtk_label_set_line_wrap_mode, pl_tug);
+ Xg_define_procedure(gtk_label_get_line_wrap_mode, gxg_gtk_label_get_line_wrap_mode_w, 1, 0, 0, H_gtk_label_get_line_wrap_mode, pl_gu);
Xg_define_procedure(gtk_print_context_get_cairo_context, gxg_gtk_print_context_get_cairo_context_w, 1, 0, 0, H_gtk_print_context_get_cairo_context, pl_pu);
Xg_define_procedure(gtk_print_context_get_page_setup, gxg_gtk_print_context_get_page_setup_w, 1, 0, 0, H_gtk_print_context_get_page_setup, pl_pu);
Xg_define_procedure(gtk_print_context_get_width, gxg_gtk_print_context_get_width_w, 1, 0, 0, H_gtk_print_context_get_width, pl_du);
@@ -41863,9 +42282,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_print_operation_set_show_progress, gxg_gtk_print_operation_set_show_progress_w, 2, 0, 0, H_gtk_print_operation_set_show_progress, pl_tub);
Xg_define_procedure(gtk_print_operation_set_allow_async, gxg_gtk_print_operation_set_allow_async_w, 2, 0, 0, H_gtk_print_operation_set_allow_async, pl_tub);
Xg_define_procedure(gtk_print_operation_set_custom_tab_label, gxg_gtk_print_operation_set_custom_tab_label_w, 2, 0, 0, H_gtk_print_operation_set_custom_tab_label, pl_tus);
- Xg_define_procedure(gtk_print_operation_run, gxg_gtk_print_operation_run_w, 3, 1, 0, H_gtk_print_operation_run, pl_iuiu);
+ Xg_define_procedure(gtk_print_operation_run, gxg_gtk_print_operation_run_w, 3, 1, 0, H_gtk_print_operation_run, pl_gugu);
Xg_define_procedure(gtk_print_operation_get_error, gxg_gtk_print_operation_get_error_w, 1, 1, 0, H_gtk_print_operation_get_error, pl_tu);
- Xg_define_procedure(gtk_print_operation_get_status, gxg_gtk_print_operation_get_status_w, 1, 0, 0, H_gtk_print_operation_get_status, pl_iu);
+ Xg_define_procedure(gtk_print_operation_get_status, gxg_gtk_print_operation_get_status_w, 1, 0, 0, H_gtk_print_operation_get_status, pl_gu);
Xg_define_procedure(gtk_print_operation_get_status_string, gxg_gtk_print_operation_get_status_string_w, 1, 0, 0, H_gtk_print_operation_get_status_string, pl_su);
Xg_define_procedure(gtk_print_operation_is_finished, gxg_gtk_print_operation_is_finished_w, 1, 0, 0, H_gtk_print_operation_is_finished, pl_bu);
Xg_define_procedure(gtk_print_operation_cancel, gxg_gtk_print_operation_cancel_w, 1, 0, 0, H_gtk_print_operation_cancel, pl_tu);
@@ -41962,7 +42381,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_set_startup_id, gxg_gdk_window_set_startup_id_w, 2, 0, 0, H_gdk_window_set_startup_id, pl_tus);
Xg_define_procedure(gdk_window_beep, gxg_gdk_window_beep_w, 1, 0, 0, H_gdk_window_beep, pl_tu);
Xg_define_procedure(gdk_window_set_opacity, gxg_gdk_window_set_opacity_w, 2, 0, 0, H_gdk_window_set_opacity, pl_tur);
- Xg_define_procedure(gtk_binding_entry_skip, gxg_gtk_binding_entry_skip_w, 3, 0, 0, H_gtk_binding_entry_skip, pl_tui);
+ Xg_define_procedure(gtk_binding_entry_skip, gxg_gtk_binding_entry_skip_w, 3, 0, 0, H_gtk_binding_entry_skip, pl_tuig);
Xg_define_procedure(gtk_cell_layout_get_cells, gxg_gtk_cell_layout_get_cells_w, 1, 0, 0, H_gtk_cell_layout_get_cells, pl_pu);
Xg_define_procedure(gtk_entry_completion_set_inline_selection, gxg_gtk_entry_completion_set_inline_selection_w, 2, 0, 0, H_gtk_entry_completion_set_inline_selection, pl_tub);
Xg_define_procedure(gtk_entry_completion_get_inline_selection, gxg_gtk_entry_completion_get_inline_selection_w, 1, 0, 0, H_gtk_entry_completion_get_inline_selection, pl_bu);
@@ -41982,7 +42401,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_view_get_show_expanders, gxg_gtk_tree_view_get_show_expanders_w, 1, 0, 0, H_gtk_tree_view_get_show_expanders, pl_bu);
Xg_define_procedure(gtk_tree_view_set_level_indentation, gxg_gtk_tree_view_set_level_indentation_w, 2, 0, 0, H_gtk_tree_view_set_level_indentation, pl_tui);
Xg_define_procedure(gtk_tree_view_get_level_indentation, gxg_gtk_tree_view_get_level_indentation_w, 1, 0, 0, H_gtk_tree_view_get_level_indentation, pl_iu);
- Xg_define_procedure(gtk_widget_keynav_failed, gxg_gtk_widget_keynav_failed_w, 2, 0, 0, H_gtk_widget_keynav_failed, pl_bui);
+ Xg_define_procedure(gtk_widget_keynav_failed, gxg_gtk_widget_keynav_failed_w, 2, 0, 0, H_gtk_widget_keynav_failed, pl_bug);
Xg_define_procedure(gtk_widget_error_bell, gxg_gtk_widget_error_bell_w, 1, 0, 0, H_gtk_widget_error_bell, pl_tu);
Xg_define_procedure(gtk_widget_set_tooltip_window, gxg_gtk_widget_set_tooltip_window_w, 2, 0, 0, H_gtk_widget_set_tooltip_window, pl_tu);
Xg_define_procedure(gtk_widget_get_tooltip_window, gxg_gtk_widget_get_tooltip_window_w, 1, 0, 0, H_gtk_widget_get_tooltip_window, pl_pu);
@@ -42048,7 +42467,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_selection_data_get_format, gxg_gtk_selection_data_get_format_w, 1, 0, 0, H_gtk_selection_data_get_format, pl_iu);
Xg_define_procedure(gtk_selection_data_get_display, gxg_gtk_selection_data_get_display_w, 1, 0, 0, H_gtk_selection_data_get_display, pl_pu);
Xg_define_procedure(gtk_widget_get_window, gxg_gtk_widget_get_window_w, 1, 0, 0, H_gtk_widget_get_window, pl_pu);
- Xg_define_procedure(gtk_accel_group_get_modifier_mask, gxg_gtk_accel_group_get_modifier_mask_w, 1, 0, 0, H_gtk_accel_group_get_modifier_mask, pl_iu);
+ Xg_define_procedure(gtk_accel_group_get_modifier_mask, gxg_gtk_accel_group_get_modifier_mask_w, 1, 0, 0, H_gtk_accel_group_get_modifier_mask, pl_gu);
Xg_define_procedure(gdk_threads_add_timeout_seconds_full, gxg_gdk_threads_add_timeout_seconds_full_w, 5, 0, 0, H_gdk_threads_add_timeout_seconds_full, pl_iiit);
Xg_define_procedure(gdk_threads_add_timeout_seconds, gxg_gdk_threads_add_timeout_seconds_w, 2, 1, 0, H_gdk_threads_add_timeout_seconds, pl_iit);
Xg_define_procedure(gtk_adjustment_get_lower, gxg_gtk_adjustment_get_lower_w, 1, 0, 0, H_gtk_adjustment_get_lower, pl_du);
@@ -42062,8 +42481,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_adjustment_get_page_size, gxg_gtk_adjustment_get_page_size_w, 1, 0, 0, H_gtk_adjustment_get_page_size, pl_du);
Xg_define_procedure(gtk_adjustment_set_page_size, gxg_gtk_adjustment_set_page_size_w, 2, 0, 0, H_gtk_adjustment_set_page_size, pl_tur);
Xg_define_procedure(gtk_adjustment_configure, gxg_gtk_adjustment_configure_w, 7, 0, 0, H_gtk_adjustment_configure, pl_tur);
- Xg_define_procedure(gtk_combo_box_set_button_sensitivity, gxg_gtk_combo_box_set_button_sensitivity_w, 2, 0, 0, H_gtk_combo_box_set_button_sensitivity, pl_tui);
- Xg_define_procedure(gtk_combo_box_get_button_sensitivity, gxg_gtk_combo_box_get_button_sensitivity_w, 1, 0, 0, H_gtk_combo_box_get_button_sensitivity, pl_iu);
+ Xg_define_procedure(gtk_combo_box_set_button_sensitivity, gxg_gtk_combo_box_set_button_sensitivity_w, 2, 0, 0, H_gtk_combo_box_set_button_sensitivity, pl_tug);
+ Xg_define_procedure(gtk_combo_box_get_button_sensitivity, gxg_gtk_combo_box_get_button_sensitivity_w, 1, 0, 0, H_gtk_combo_box_get_button_sensitivity, pl_gu);
Xg_define_procedure(gtk_file_chooser_get_file, gxg_gtk_file_chooser_get_file_w, 1, 0, 0, H_gtk_file_chooser_get_file, pl_pu);
Xg_define_procedure(gtk_file_chooser_set_file, gxg_gtk_file_chooser_set_file_w, 2, 1, 0, H_gtk_file_chooser_set_file, pl_bu);
Xg_define_procedure(gtk_file_chooser_select_file, gxg_gtk_file_chooser_select_file_w, 2, 1, 0, H_gtk_file_chooser_select_file, pl_bu);
@@ -42086,27 +42505,27 @@ pl_unused = NULL;
Xg_define_procedure(gtk_entry_set_progress_pulse_step, gxg_gtk_entry_set_progress_pulse_step_w, 2, 0, 0, H_gtk_entry_set_progress_pulse_step, pl_tur);
Xg_define_procedure(gtk_entry_get_progress_pulse_step, gxg_gtk_entry_get_progress_pulse_step_w, 1, 0, 0, H_gtk_entry_get_progress_pulse_step, pl_du);
Xg_define_procedure(gtk_entry_progress_pulse, gxg_gtk_entry_progress_pulse_w, 1, 0, 0, H_gtk_entry_progress_pulse, pl_tu);
- Xg_define_procedure(gtk_entry_set_icon_from_pixbuf, gxg_gtk_entry_set_icon_from_pixbuf_w, 3, 0, 0, H_gtk_entry_set_icon_from_pixbuf, pl_tuiu);
- Xg_define_procedure(gtk_entry_set_icon_from_icon_name, gxg_gtk_entry_set_icon_from_icon_name_w, 3, 0, 0, H_gtk_entry_set_icon_from_icon_name, pl_tuis);
- Xg_define_procedure(gtk_entry_set_icon_from_gicon, gxg_gtk_entry_set_icon_from_gicon_w, 3, 0, 0, H_gtk_entry_set_icon_from_gicon, pl_tuiu);
- Xg_define_procedure(gtk_entry_get_icon_name, gxg_gtk_entry_get_icon_name_w, 2, 0, 0, H_gtk_entry_get_icon_name, pl_sui);
- Xg_define_procedure(gtk_entry_set_icon_activatable, gxg_gtk_entry_set_icon_activatable_w, 3, 0, 0, H_gtk_entry_set_icon_activatable, pl_tuib);
- Xg_define_procedure(gtk_entry_get_icon_activatable, gxg_gtk_entry_get_icon_activatable_w, 2, 0, 0, H_gtk_entry_get_icon_activatable, pl_bui);
- Xg_define_procedure(gtk_entry_set_icon_sensitive, gxg_gtk_entry_set_icon_sensitive_w, 3, 0, 0, H_gtk_entry_set_icon_sensitive, pl_tuib);
- Xg_define_procedure(gtk_entry_get_icon_sensitive, gxg_gtk_entry_get_icon_sensitive_w, 2, 0, 0, H_gtk_entry_get_icon_sensitive, pl_bui);
+ Xg_define_procedure(gtk_entry_set_icon_from_pixbuf, gxg_gtk_entry_set_icon_from_pixbuf_w, 3, 0, 0, H_gtk_entry_set_icon_from_pixbuf, pl_tugu);
+ Xg_define_procedure(gtk_entry_set_icon_from_icon_name, gxg_gtk_entry_set_icon_from_icon_name_w, 3, 0, 0, H_gtk_entry_set_icon_from_icon_name, pl_tugs);
+ Xg_define_procedure(gtk_entry_set_icon_from_gicon, gxg_gtk_entry_set_icon_from_gicon_w, 3, 0, 0, H_gtk_entry_set_icon_from_gicon, pl_tugu);
+ Xg_define_procedure(gtk_entry_get_icon_name, gxg_gtk_entry_get_icon_name_w, 2, 0, 0, H_gtk_entry_get_icon_name, pl_sug);
+ Xg_define_procedure(gtk_entry_set_icon_activatable, gxg_gtk_entry_set_icon_activatable_w, 3, 0, 0, H_gtk_entry_set_icon_activatable, pl_tugb);
+ Xg_define_procedure(gtk_entry_get_icon_activatable, gxg_gtk_entry_get_icon_activatable_w, 2, 0, 0, H_gtk_entry_get_icon_activatable, pl_bug);
+ Xg_define_procedure(gtk_entry_set_icon_sensitive, gxg_gtk_entry_set_icon_sensitive_w, 3, 0, 0, H_gtk_entry_set_icon_sensitive, pl_tugb);
+ Xg_define_procedure(gtk_entry_get_icon_sensitive, gxg_gtk_entry_get_icon_sensitive_w, 2, 0, 0, H_gtk_entry_get_icon_sensitive, pl_bug);
Xg_define_procedure(gtk_entry_get_icon_at_pos, gxg_gtk_entry_get_icon_at_pos_w, 3, 0, 0, H_gtk_entry_get_icon_at_pos, pl_iui);
- Xg_define_procedure(gtk_entry_set_icon_tooltip_text, gxg_gtk_entry_set_icon_tooltip_text_w, 3, 0, 0, H_gtk_entry_set_icon_tooltip_text, pl_tuis);
- Xg_define_procedure(gtk_entry_set_icon_tooltip_markup, gxg_gtk_entry_set_icon_tooltip_markup_w, 3, 0, 0, H_gtk_entry_set_icon_tooltip_markup, pl_tuis);
- Xg_define_procedure(gtk_entry_set_icon_drag_source, gxg_gtk_entry_set_icon_drag_source_w, 4, 0, 0, H_gtk_entry_set_icon_drag_source, pl_tuiui);
+ Xg_define_procedure(gtk_entry_set_icon_tooltip_text, gxg_gtk_entry_set_icon_tooltip_text_w, 3, 0, 0, H_gtk_entry_set_icon_tooltip_text, pl_tugs);
+ Xg_define_procedure(gtk_entry_set_icon_tooltip_markup, gxg_gtk_entry_set_icon_tooltip_markup_w, 3, 0, 0, H_gtk_entry_set_icon_tooltip_markup, pl_tugs);
+ Xg_define_procedure(gtk_entry_set_icon_drag_source, gxg_gtk_entry_set_icon_drag_source_w, 4, 0, 0, H_gtk_entry_set_icon_drag_source, pl_tugug);
Xg_define_procedure(gtk_entry_get_current_icon_drag_source, gxg_gtk_entry_get_current_icon_drag_source_w, 1, 0, 0, H_gtk_entry_get_current_icon_drag_source, pl_iu);
Xg_define_procedure(gtk_menu_item_set_label, gxg_gtk_menu_item_set_label_w, 2, 0, 0, H_gtk_menu_item_set_label, pl_tus);
Xg_define_procedure(gtk_menu_item_get_label, gxg_gtk_menu_item_get_label_w, 1, 0, 0, H_gtk_menu_item_get_label, pl_su);
Xg_define_procedure(gtk_menu_item_set_use_underline, gxg_gtk_menu_item_set_use_underline_w, 2, 0, 0, H_gtk_menu_item_set_use_underline, pl_tub);
Xg_define_procedure(gtk_menu_item_get_use_underline, gxg_gtk_menu_item_get_use_underline_w, 1, 0, 0, H_gtk_menu_item_get_use_underline, pl_bu);
Xg_define_procedure(gtk_selection_data_get_selection, gxg_gtk_selection_data_get_selection_w, 1, 0, 0, H_gtk_selection_data_get_selection, pl_tu);
- Xg_define_procedure(gtk_entry_get_icon_tooltip_text, gxg_gtk_entry_get_icon_tooltip_text_w, 2, 0, 0, H_gtk_entry_get_icon_tooltip_text, pl_sui);
- Xg_define_procedure(gtk_entry_get_icon_tooltip_markup, gxg_gtk_entry_get_icon_tooltip_markup_w, 2, 0, 0, H_gtk_entry_get_icon_tooltip_markup, pl_sui);
- Xg_define_procedure(gtk_scale_add_mark, gxg_gtk_scale_add_mark_w, 4, 0, 0, H_gtk_scale_add_mark, pl_turis);
+ Xg_define_procedure(gtk_entry_get_icon_tooltip_text, gxg_gtk_entry_get_icon_tooltip_text_w, 2, 0, 0, H_gtk_entry_get_icon_tooltip_text, pl_sug);
+ Xg_define_procedure(gtk_entry_get_icon_tooltip_markup, gxg_gtk_entry_get_icon_tooltip_markup_w, 2, 0, 0, H_gtk_entry_get_icon_tooltip_markup, pl_sug);
+ Xg_define_procedure(gtk_scale_add_mark, gxg_gtk_scale_add_mark_w, 4, 0, 0, H_gtk_scale_add_mark, pl_turgs);
Xg_define_procedure(gtk_scale_clear_marks, gxg_gtk_scale_clear_marks_w, 1, 0, 0, H_gtk_scale_clear_marks, pl_tu);
#endif
@@ -42121,8 +42540,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_info_bar_set_response_sensitive, gxg_gtk_info_bar_set_response_sensitive_w, 3, 0, 0, H_gtk_info_bar_set_response_sensitive, pl_tuib);
Xg_define_procedure(gtk_info_bar_set_default_response, gxg_gtk_info_bar_set_default_response_w, 2, 0, 0, H_gtk_info_bar_set_default_response, pl_tui);
Xg_define_procedure(gtk_info_bar_response, gxg_gtk_info_bar_response_w, 2, 0, 0, H_gtk_info_bar_response, pl_tui);
- Xg_define_procedure(gtk_info_bar_set_message_type, gxg_gtk_info_bar_set_message_type_w, 2, 0, 0, H_gtk_info_bar_set_message_type, pl_tui);
- Xg_define_procedure(gtk_info_bar_get_message_type, gxg_gtk_info_bar_get_message_type_w, 1, 0, 0, H_gtk_info_bar_get_message_type, pl_iu);
+ Xg_define_procedure(gtk_info_bar_set_message_type, gxg_gtk_info_bar_set_message_type_w, 2, 0, 0, H_gtk_info_bar_set_message_type, pl_tug);
+ Xg_define_procedure(gtk_info_bar_get_message_type, gxg_gtk_info_bar_get_message_type_w, 1, 0, 0, H_gtk_info_bar_get_message_type, pl_gu);
Xg_define_procedure(gdk_window_ensure_native, gxg_gdk_window_ensure_native_w, 1, 0, 0, H_gdk_window_ensure_native, pl_bu);
Xg_define_procedure(gdk_window_get_root_coords, gxg_gdk_window_get_root_coords_w, 3, 2, 0, H_gdk_window_get_root_coords, pl_tuiiu);
Xg_define_procedure(gdk_offscreen_window_set_embedder, gxg_gdk_offscreen_window_set_embedder_w, 2, 0, 0, H_gdk_offscreen_window_set_embedder, pl_tu);
@@ -42195,12 +42614,12 @@ pl_unused = NULL;
Xg_define_procedure(gtk_spinner_start, gxg_gtk_spinner_start_w, 1, 0, 0, H_gtk_spinner_start, pl_tu);
Xg_define_procedure(gtk_spinner_stop, gxg_gtk_spinner_stop_w, 1, 0, 0, H_gtk_spinner_stop, pl_tu);
Xg_define_procedure(gtk_cell_renderer_spinner_new, gxg_gtk_cell_renderer_spinner_new_w, 0, 0, 0, H_gtk_cell_renderer_spinner_new, pl_p);
- Xg_define_procedure(gtk_notebook_get_action_widget, gxg_gtk_notebook_get_action_widget_w, 2, 0, 0, H_gtk_notebook_get_action_widget, pl_pui);
- Xg_define_procedure(gtk_notebook_set_action_widget, gxg_gtk_notebook_set_action_widget_w, 3, 0, 0, H_gtk_notebook_set_action_widget, pl_tuui);
+ Xg_define_procedure(gtk_notebook_get_action_widget, gxg_gtk_notebook_get_action_widget_w, 2, 0, 0, H_gtk_notebook_get_action_widget, pl_pug);
+ Xg_define_procedure(gtk_notebook_set_action_widget, gxg_gtk_notebook_set_action_widget_w, 3, 0, 0, H_gtk_notebook_set_action_widget, pl_tuug);
Xg_define_procedure(gtk_statusbar_get_message_area, gxg_gtk_statusbar_get_message_area_w, 1, 0, 0, H_gtk_statusbar_get_message_area, pl_pu);
- Xg_define_procedure(gtk_tool_item_get_ellipsize_mode, gxg_gtk_tool_item_get_ellipsize_mode_w, 1, 0, 0, H_gtk_tool_item_get_ellipsize_mode, pl_iu);
+ Xg_define_procedure(gtk_tool_item_get_ellipsize_mode, gxg_gtk_tool_item_get_ellipsize_mode_w, 1, 0, 0, H_gtk_tool_item_get_ellipsize_mode, pl_gu);
Xg_define_procedure(gtk_tool_item_get_text_alignment, gxg_gtk_tool_item_get_text_alignment_w, 1, 0, 0, H_gtk_tool_item_get_text_alignment, pl_du);
- Xg_define_procedure(gtk_tool_item_get_text_orientation, gxg_gtk_tool_item_get_text_orientation_w, 1, 0, 0, H_gtk_tool_item_get_text_orientation, pl_iu);
+ Xg_define_procedure(gtk_tool_item_get_text_orientation, gxg_gtk_tool_item_get_text_orientation_w, 1, 0, 0, H_gtk_tool_item_get_text_orientation, pl_gu);
Xg_define_procedure(gtk_tool_item_get_text_size_group, gxg_gtk_tool_item_get_text_size_group_w, 1, 0, 0, H_gtk_tool_item_get_text_size_group, pl_pu);
Xg_define_procedure(gtk_tool_palette_new, gxg_gtk_tool_palette_new_w, 0, 0, 0, H_gtk_tool_palette_new, pl_p);
Xg_define_procedure(gtk_tool_palette_set_group_position, gxg_gtk_tool_palette_set_group_position_w, 3, 0, 0, H_gtk_tool_palette_set_group_position, pl_tuui);
@@ -42210,27 +42629,27 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tool_palette_get_exclusive, gxg_gtk_tool_palette_get_exclusive_w, 2, 0, 0, H_gtk_tool_palette_get_exclusive, pl_bu);
Xg_define_procedure(gtk_tool_palette_get_expand, gxg_gtk_tool_palette_get_expand_w, 2, 0, 0, H_gtk_tool_palette_get_expand, pl_bu);
Xg_define_procedure(gtk_tool_palette_unset_icon_size, gxg_gtk_tool_palette_unset_icon_size_w, 1, 0, 0, H_gtk_tool_palette_unset_icon_size, pl_tu);
- Xg_define_procedure(gtk_tool_palette_set_style, gxg_gtk_tool_palette_set_style_w, 2, 0, 0, H_gtk_tool_palette_set_style, pl_tui);
+ Xg_define_procedure(gtk_tool_palette_set_style, gxg_gtk_tool_palette_set_style_w, 2, 0, 0, H_gtk_tool_palette_set_style, pl_tug);
Xg_define_procedure(gtk_tool_palette_unset_style, gxg_gtk_tool_palette_unset_style_w, 1, 0, 0, H_gtk_tool_palette_unset_style, pl_tu);
- Xg_define_procedure(gtk_tool_palette_get_style, gxg_gtk_tool_palette_get_style_w, 1, 0, 0, H_gtk_tool_palette_get_style, pl_iu);
+ Xg_define_procedure(gtk_tool_palette_get_style, gxg_gtk_tool_palette_get_style_w, 1, 0, 0, H_gtk_tool_palette_get_style, pl_gu);
Xg_define_procedure(gtk_tool_palette_get_drop_item, gxg_gtk_tool_palette_get_drop_item_w, 3, 0, 0, H_gtk_tool_palette_get_drop_item, pl_pui);
Xg_define_procedure(gtk_tool_palette_get_drop_group, gxg_gtk_tool_palette_get_drop_group_w, 3, 0, 0, H_gtk_tool_palette_get_drop_group, pl_pui);
Xg_define_procedure(gtk_tool_palette_get_drag_item, gxg_gtk_tool_palette_get_drag_item_w, 2, 0, 0, H_gtk_tool_palette_get_drag_item, pl_pu);
- Xg_define_procedure(gtk_tool_palette_set_drag_source, gxg_gtk_tool_palette_set_drag_source_w, 2, 0, 0, H_gtk_tool_palette_set_drag_source, pl_tui);
- Xg_define_procedure(gtk_tool_palette_add_drag_dest, gxg_gtk_tool_palette_add_drag_dest_w, 5, 0, 0, H_gtk_tool_palette_add_drag_dest, pl_tuui);
+ Xg_define_procedure(gtk_tool_palette_set_drag_source, gxg_gtk_tool_palette_set_drag_source_w, 2, 0, 0, H_gtk_tool_palette_set_drag_source, pl_tug);
+ Xg_define_procedure(gtk_tool_palette_add_drag_dest, gxg_gtk_tool_palette_add_drag_dest_w, 5, 0, 0, H_gtk_tool_palette_add_drag_dest, pl_tuug);
Xg_define_procedure(gtk_tool_palette_get_drag_target_item, gxg_gtk_tool_palette_get_drag_target_item_w, 0, 0, 0, H_gtk_tool_palette_get_drag_target_item, pl_p);
Xg_define_procedure(gtk_tool_palette_get_drag_target_group, gxg_gtk_tool_palette_get_drag_target_group_w, 0, 0, 0, H_gtk_tool_palette_get_drag_target_group, pl_p);
Xg_define_procedure(gtk_tool_item_group_new, gxg_gtk_tool_item_group_new_w, 1, 0, 0, H_gtk_tool_item_group_new, pl_ps);
Xg_define_procedure(gtk_tool_item_group_set_label, gxg_gtk_tool_item_group_set_label_w, 2, 0, 0, H_gtk_tool_item_group_set_label, pl_tus);
Xg_define_procedure(gtk_tool_item_group_set_label_widget, gxg_gtk_tool_item_group_set_label_widget_w, 2, 0, 0, H_gtk_tool_item_group_set_label_widget, pl_tu);
Xg_define_procedure(gtk_tool_item_group_set_collapsed, gxg_gtk_tool_item_group_set_collapsed_w, 2, 0, 0, H_gtk_tool_item_group_set_collapsed, pl_tub);
- Xg_define_procedure(gtk_tool_item_group_set_ellipsize, gxg_gtk_tool_item_group_set_ellipsize_w, 2, 0, 0, H_gtk_tool_item_group_set_ellipsize, pl_tui);
- Xg_define_procedure(gtk_tool_item_group_set_header_relief, gxg_gtk_tool_item_group_set_header_relief_w, 2, 0, 0, H_gtk_tool_item_group_set_header_relief, pl_tui);
+ Xg_define_procedure(gtk_tool_item_group_set_ellipsize, gxg_gtk_tool_item_group_set_ellipsize_w, 2, 0, 0, H_gtk_tool_item_group_set_ellipsize, pl_tug);
+ Xg_define_procedure(gtk_tool_item_group_set_header_relief, gxg_gtk_tool_item_group_set_header_relief_w, 2, 0, 0, H_gtk_tool_item_group_set_header_relief, pl_tug);
Xg_define_procedure(gtk_tool_item_group_get_label, gxg_gtk_tool_item_group_get_label_w, 1, 0, 0, H_gtk_tool_item_group_get_label, pl_su);
Xg_define_procedure(gtk_tool_item_group_get_label_widget, gxg_gtk_tool_item_group_get_label_widget_w, 1, 0, 0, H_gtk_tool_item_group_get_label_widget, pl_pu);
Xg_define_procedure(gtk_tool_item_group_get_collapsed, gxg_gtk_tool_item_group_get_collapsed_w, 1, 0, 0, H_gtk_tool_item_group_get_collapsed, pl_bu);
- Xg_define_procedure(gtk_tool_item_group_get_ellipsize, gxg_gtk_tool_item_group_get_ellipsize_w, 1, 0, 0, H_gtk_tool_item_group_get_ellipsize, pl_iu);
- Xg_define_procedure(gtk_tool_item_group_get_header_relief, gxg_gtk_tool_item_group_get_header_relief_w, 1, 0, 0, H_gtk_tool_item_group_get_header_relief, pl_iu);
+ Xg_define_procedure(gtk_tool_item_group_get_ellipsize, gxg_gtk_tool_item_group_get_ellipsize_w, 1, 0, 0, H_gtk_tool_item_group_get_ellipsize, pl_gu);
+ Xg_define_procedure(gtk_tool_item_group_get_header_relief, gxg_gtk_tool_item_group_get_header_relief_w, 1, 0, 0, H_gtk_tool_item_group_get_header_relief, pl_gu);
Xg_define_procedure(gtk_tool_item_group_insert, gxg_gtk_tool_item_group_insert_w, 3, 0, 0, H_gtk_tool_item_group_insert, pl_tuui);
Xg_define_procedure(gtk_tool_item_group_set_item_position, gxg_gtk_tool_item_group_set_item_position_w, 3, 0, 0, H_gtk_tool_item_group_set_item_position, pl_tuui);
Xg_define_procedure(gtk_tool_item_group_get_item_position, gxg_gtk_tool_item_group_get_item_position_w, 2, 0, 0, H_gtk_tool_item_group_get_item_position, pl_iu);
@@ -42242,8 +42661,6 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_get_mnemonics_visible, gxg_gtk_window_get_mnemonics_visible_w, 1, 0, 0, H_gtk_window_get_mnemonics_visible, pl_bu);
Xg_define_procedure(gtk_range_set_slider_size_fixed, gxg_gtk_range_set_slider_size_fixed_w, 2, 0, 0, H_gtk_range_set_slider_size_fixed, pl_tub);
Xg_define_procedure(gtk_range_get_slider_size_fixed, gxg_gtk_range_get_slider_size_fixed_w, 1, 0, 0, H_gtk_range_get_slider_size_fixed, pl_bu);
- Xg_define_procedure(gtk_range_set_min_slider_size, gxg_gtk_range_set_min_slider_size_w, 2, 0, 0, H_gtk_range_set_min_slider_size, pl_tub);
- Xg_define_procedure(gtk_range_get_min_slider_size, gxg_gtk_range_get_min_slider_size_w, 1, 0, 0, H_gtk_range_get_min_slider_size, pl_iu);
Xg_define_procedure(gtk_range_get_range_rect, gxg_gtk_range_get_range_rect_w, 2, 0, 0, H_gtk_range_get_range_rect, pl_tu);
Xg_define_procedure(gtk_range_get_slider_range, gxg_gtk_range_get_slider_range_w, 1, 2, 0, H_gtk_range_get_slider_range, pl_tu);
Xg_define_procedure(gtk_paned_get_handle_window, gxg_gtk_paned_get_handle_window_w, 1, 0, 0, H_gtk_paned_get_handle_window, pl_pu);
@@ -42263,7 +42680,6 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_get_effective_toplevel, gxg_gdk_window_get_effective_toplevel_w, 1, 0, 0, H_gdk_window_get_effective_toplevel, pl_pu);
Xg_define_procedure(gtk_accessible_get_widget, gxg_gtk_accessible_get_widget_w, 1, 0, 0, H_gtk_accessible_get_widget, pl_pu);
Xg_define_procedure(gtk_widget_send_focus_change, gxg_gtk_widget_send_focus_change_w, 2, 0, 0, H_gtk_widget_send_focus_change, pl_bu);
- Xg_define_procedure(gdk_display_get_device_manager, gxg_gdk_display_get_device_manager_w, 1, 0, 0, H_gdk_display_get_device_manager, pl_pu);
Xg_define_procedure(gdk_drag_context_set_device, gxg_gdk_drag_context_set_device_w, 2, 0, 0, H_gdk_drag_context_set_device, pl_tu);
Xg_define_procedure(gdk_drag_context_get_device, gxg_gdk_drag_context_get_device_w, 1, 0, 0, H_gdk_drag_context_get_device, pl_pu);
Xg_define_procedure(gdk_drag_context_list_targets, gxg_gdk_drag_context_list_targets_w, 1, 0, 0, H_gdk_drag_context_list_targets, pl_pu);
@@ -42280,23 +42696,23 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_set_device_cursor, gxg_gdk_window_set_device_cursor_w, 3, 0, 0, H_gdk_window_set_device_cursor, pl_tu);
Xg_define_procedure(gdk_window_get_device_cursor, gxg_gdk_window_get_device_cursor_w, 2, 0, 0, H_gdk_window_get_device_cursor, pl_pu);
Xg_define_procedure(gdk_window_get_device_position, gxg_gdk_window_get_device_position_w, 2, 3, 0, H_gdk_window_get_device_position, pl_pu);
- Xg_define_procedure(gdk_window_set_device_events, gxg_gdk_window_set_device_events_w, 3, 0, 0, H_gdk_window_set_device_events, pl_tuui);
- Xg_define_procedure(gdk_window_get_device_events, gxg_gdk_window_get_device_events_w, 2, 0, 0, H_gdk_window_get_device_events, pl_iu);
+ Xg_define_procedure(gdk_window_set_device_events, gxg_gdk_window_set_device_events_w, 3, 0, 0, H_gdk_window_set_device_events, pl_tuug);
+ Xg_define_procedure(gdk_window_get_device_events, gxg_gdk_window_get_device_events_w, 2, 0, 0, H_gdk_window_get_device_events, pl_gu);
Xg_define_procedure(gtk_combo_box_popup_for_device, gxg_gtk_combo_box_popup_for_device_w, 2, 0, 0, H_gtk_combo_box_popup_for_device, pl_tu);
Xg_define_procedure(gtk_device_grab_add, gxg_gtk_device_grab_add_w, 3, 0, 0, H_gtk_device_grab_add, pl_tuub);
Xg_define_procedure(gtk_device_grab_remove, gxg_gtk_device_grab_remove_w, 2, 0, 0, H_gtk_device_grab_remove, pl_tu);
Xg_define_procedure(gtk_get_current_event_device, gxg_gtk_get_current_event_device_w, 0, 0, 0, H_gtk_get_current_event_device, pl_p);
- Xg_define_procedure(gtk_paned_new, gxg_gtk_paned_new_w, 1, 0, 0, H_gtk_paned_new, pl_pi);
- Xg_define_procedure(gtk_scale_new, gxg_gtk_scale_new_w, 2, 0, 0, H_gtk_scale_new, pl_piu);
- Xg_define_procedure(gtk_scale_new_with_range, gxg_gtk_scale_new_with_range_w, 4, 0, 0, H_gtk_scale_new_with_range, pl_pir);
- Xg_define_procedure(gtk_scrollbar_new, gxg_gtk_scrollbar_new_w, 2, 0, 0, H_gtk_scrollbar_new, pl_piu);
- Xg_define_procedure(gtk_separator_new, gxg_gtk_separator_new_w, 1, 0, 0, H_gtk_separator_new, pl_pi);
+ Xg_define_procedure(gtk_paned_new, gxg_gtk_paned_new_w, 1, 0, 0, H_gtk_paned_new, pl_pg);
+ Xg_define_procedure(gtk_scale_new, gxg_gtk_scale_new_w, 2, 0, 0, H_gtk_scale_new, pl_pgu);
+ Xg_define_procedure(gtk_scale_new_with_range, gxg_gtk_scale_new_with_range_w, 4, 0, 0, H_gtk_scale_new_with_range, pl_pgr);
+ Xg_define_procedure(gtk_scrollbar_new, gxg_gtk_scrollbar_new_w, 2, 0, 0, H_gtk_scrollbar_new, pl_pgu);
+ Xg_define_procedure(gtk_separator_new, gxg_gtk_separator_new_w, 1, 0, 0, H_gtk_separator_new, pl_pg);
Xg_define_procedure(gtk_widget_device_is_shadowed, gxg_gtk_widget_device_is_shadowed_w, 2, 0, 0, H_gtk_widget_device_is_shadowed, pl_bu);
- Xg_define_procedure(gtk_widget_set_device_events, gxg_gtk_widget_set_device_events_w, 3, 0, 0, H_gtk_widget_set_device_events, pl_tuui);
- Xg_define_procedure(gtk_widget_add_device_events, gxg_gtk_widget_add_device_events_w, 3, 0, 0, H_gtk_widget_add_device_events, pl_tuui);
+ Xg_define_procedure(gtk_widget_set_device_events, gxg_gtk_widget_set_device_events_w, 3, 0, 0, H_gtk_widget_set_device_events, pl_tuug);
+ Xg_define_procedure(gtk_widget_add_device_events, gxg_gtk_widget_add_device_events_w, 3, 0, 0, H_gtk_widget_add_device_events, pl_tuug);
Xg_define_procedure(gtk_widget_get_support_multidevice, gxg_gtk_widget_get_support_multidevice_w, 1, 0, 0, H_gtk_widget_get_support_multidevice, pl_bu);
Xg_define_procedure(gtk_widget_set_support_multidevice, gxg_gtk_widget_set_support_multidevice_w, 2, 0, 0, H_gtk_widget_set_support_multidevice, pl_tub);
- Xg_define_procedure(gtk_widget_get_device_events, gxg_gtk_widget_get_device_events_w, 2, 0, 0, H_gtk_widget_get_device_events, pl_iu);
+ Xg_define_procedure(gtk_widget_get_device_events, gxg_gtk_widget_get_device_events_w, 2, 0, 0, H_gtk_widget_get_device_events, pl_gu);
Xg_define_procedure(gtk_icon_view_get_item_row, gxg_gtk_icon_view_get_item_row_w, 2, 0, 0, H_gtk_icon_view_get_item_row, pl_iu);
Xg_define_procedure(gtk_icon_view_get_item_column, gxg_gtk_icon_view_get_item_column_w, 2, 0, 0, H_gtk_icon_view_get_item_column, pl_iu);
Xg_define_procedure(gtk_statusbar_remove_all, gxg_gtk_statusbar_remove_all_w, 2, 0, 0, H_gtk_statusbar_remove_all, pl_tui);
@@ -42319,10 +42735,10 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_move_region, gxg_gdk_window_move_region_w, 4, 0, 0, H_gdk_window_move_region, pl_tuui);
Xg_define_procedure(gdk_keymap_get_num_lock_state, gxg_gdk_keymap_get_num_lock_state_w, 1, 0, 0, H_gdk_keymap_get_num_lock_state, pl_bu);
Xg_define_procedure(gdk_window_has_native, gxg_gdk_window_has_native_w, 1, 0, 0, H_gdk_window_has_native, pl_bu);
- Xg_define_procedure(gdk_cursor_get_cursor_type, gxg_gdk_cursor_get_cursor_type_w, 1, 0, 0, H_gdk_cursor_get_cursor_type, pl_iu);
+ Xg_define_procedure(gdk_cursor_get_cursor_type, gxg_gdk_cursor_get_cursor_type_w, 1, 0, 0, H_gdk_cursor_get_cursor_type, pl_gu);
Xg_define_procedure(gdk_display_is_closed, gxg_gdk_display_is_closed_w, 1, 0, 0, H_gdk_display_is_closed, pl_bu);
Xg_define_procedure(gdk_window_get_background_pattern, gxg_gdk_window_get_background_pattern_w, 1, 0, 0, H_gdk_window_get_background_pattern, pl_pu);
- Xg_define_procedure(gdk_window_create_similar_surface, gxg_gdk_window_create_similar_surface_w, 4, 0, 0, H_gdk_window_create_similar_surface, pl_pui);
+ Xg_define_procedure(gdk_window_create_similar_surface, gxg_gdk_window_create_similar_surface_w, 4, 0, 0, H_gdk_window_create_similar_surface, pl_pugi);
Xg_define_procedure(gtk_expander_set_label_fill, gxg_gtk_expander_set_label_fill_w, 2, 0, 0, H_gtk_expander_set_label_fill, pl_tub);
Xg_define_procedure(gtk_expander_get_label_fill, gxg_gtk_expander_get_label_fill_w, 1, 0, 0, H_gtk_expander_get_label_fill, pl_bu);
Xg_define_procedure(gtk_calendar_get_day_is_marked, gxg_gtk_calendar_get_day_is_marked_w, 2, 0, 0, H_gtk_calendar_get_day_is_marked, pl_bui);
@@ -42330,8 +42746,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_progress_bar_get_inverted, gxg_gtk_progress_bar_get_inverted_w, 1, 0, 0, H_gtk_progress_bar_get_inverted, pl_bu);
Xg_define_procedure(gtk_radio_button_join_group, gxg_gtk_radio_button_join_group_w, 2, 0, 0, H_gtk_radio_button_join_group, pl_tu);
Xg_define_procedure(gtk_adjustment_new, gxg_gtk_adjustment_new_w, 6, 0, 0, H_gtk_adjustment_new, pl_pr);
- Xg_define_procedure(gtk_binding_set_activate, gxg_gtk_binding_set_activate_w, 4, 0, 0, H_gtk_binding_set_activate, pl_buiiu);
- Xg_define_procedure(gtk_bindings_activate, gxg_gtk_bindings_activate_w, 3, 0, 0, H_gtk_bindings_activate, pl_bui);
+ Xg_define_procedure(gtk_binding_set_activate, gxg_gtk_binding_set_activate_w, 4, 0, 0, H_gtk_binding_set_activate, pl_buigu);
+ Xg_define_procedure(gtk_bindings_activate, gxg_gtk_bindings_activate_w, 3, 0, 0, H_gtk_bindings_activate, pl_buig);
Xg_define_procedure(gtk_icon_view_create_drag_icon, gxg_gtk_icon_view_create_drag_icon_w, 2, 0, 0, H_gtk_icon_view_create_drag_icon, pl_pu);
Xg_define_procedure(gtk_tree_view_create_row_drag_icon, gxg_gtk_tree_view_create_row_drag_icon_w, 2, 0, 0, H_gtk_tree_view_create_row_drag_icon, pl_pu);
Xg_define_procedure(gdk_cairo_get_clip_rectangle, gxg_gdk_cairo_get_clip_rectangle_w, 2, 0, 0, H_gdk_cairo_get_clip_rectangle, pl_bu);
@@ -42341,7 +42757,7 @@ pl_unused = NULL;
Xg_define_procedure(gdk_window_get_display, gxg_gdk_window_get_display_w, 1, 0, 0, H_gdk_window_get_display, pl_pu);
Xg_define_procedure(gdk_window_get_width, gxg_gdk_window_get_width_w, 1, 0, 0, H_gdk_window_get_width, pl_iu);
Xg_define_procedure(gdk_window_get_height, gxg_gdk_window_get_height_w, 1, 0, 0, H_gdk_window_get_height, pl_iu);
- Xg_define_procedure(gtk_cell_renderer_get_request_mode, gxg_gtk_cell_renderer_get_request_mode_w, 1, 0, 0, H_gtk_cell_renderer_get_request_mode, pl_iu);
+ Xg_define_procedure(gtk_cell_renderer_get_request_mode, gxg_gtk_cell_renderer_get_request_mode_w, 1, 0, 0, H_gtk_cell_renderer_get_request_mode, pl_gu);
Xg_define_procedure(gtk_cell_renderer_get_preferred_width, gxg_gtk_cell_renderer_get_preferred_width_w, 2, 2, 0, H_gtk_cell_renderer_get_preferred_width, pl_tu);
Xg_define_procedure(gtk_cell_renderer_get_preferred_height_for_width, gxg_gtk_cell_renderer_get_preferred_height_for_width_w, 3, 2, 0, H_gtk_cell_renderer_get_preferred_height_for_width, pl_tuuiu);
Xg_define_procedure(gtk_cell_renderer_get_preferred_height, gxg_gtk_cell_renderer_get_preferred_height_w, 2, 2, 0, H_gtk_cell_renderer_get_preferred_height, pl_tu);
@@ -42351,7 +42767,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_notebook_set_group_name, gxg_gtk_notebook_set_group_name_w, 2, 0, 0, H_gtk_notebook_set_group_name, pl_tus);
Xg_define_procedure(gtk_notebook_get_group_name, gxg_gtk_notebook_get_group_name_w, 1, 0, 0, H_gtk_notebook_get_group_name, pl_su);
Xg_define_procedure(gtk_widget_draw, gxg_gtk_widget_draw_w, 2, 0, 0, H_gtk_widget_draw, pl_tu);
- Xg_define_procedure(gtk_widget_get_request_mode, gxg_gtk_widget_get_request_mode_w, 1, 0, 0, H_gtk_widget_get_request_mode, pl_iu);
+ Xg_define_procedure(gtk_widget_get_request_mode, gxg_gtk_widget_get_request_mode_w, 1, 0, 0, H_gtk_widget_get_request_mode, pl_gu);
Xg_define_procedure(gtk_widget_get_preferred_width, gxg_gtk_widget_get_preferred_width_w, 1, 2, 0, H_gtk_widget_get_preferred_width, pl_tu);
Xg_define_procedure(gtk_widget_get_preferred_height_for_width, gxg_gtk_widget_get_preferred_height_for_width_w, 2, 2, 0, H_gtk_widget_get_preferred_height_for_width, pl_tuiu);
Xg_define_procedure(gtk_widget_get_preferred_height, gxg_gtk_widget_get_preferred_height_w, 1, 2, 0, H_gtk_widget_get_preferred_height, pl_tu);
@@ -42359,10 +42775,10 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_get_allocated_width, gxg_gtk_widget_get_allocated_width_w, 1, 0, 0, H_gtk_widget_get_allocated_width, pl_iu);
Xg_define_procedure(gtk_widget_get_allocated_height, gxg_gtk_widget_get_allocated_height_w, 1, 0, 0, H_gtk_widget_get_allocated_height, pl_iu);
Xg_define_procedure(gtk_widget_set_visual, gxg_gtk_widget_set_visual_w, 2, 0, 0, H_gtk_widget_set_visual, pl_tu);
- Xg_define_procedure(gtk_widget_get_halign, gxg_gtk_widget_get_halign_w, 1, 0, 0, H_gtk_widget_get_halign, pl_iu);
- Xg_define_procedure(gtk_widget_set_halign, gxg_gtk_widget_set_halign_w, 2, 0, 0, H_gtk_widget_set_halign, pl_tui);
- Xg_define_procedure(gtk_widget_get_valign, gxg_gtk_widget_get_valign_w, 1, 0, 0, H_gtk_widget_get_valign, pl_iu);
- Xg_define_procedure(gtk_widget_set_valign, gxg_gtk_widget_set_valign_w, 2, 0, 0, H_gtk_widget_set_valign, pl_tui);
+ Xg_define_procedure(gtk_widget_get_halign, gxg_gtk_widget_get_halign_w, 1, 0, 0, H_gtk_widget_get_halign, pl_gu);
+ Xg_define_procedure(gtk_widget_set_halign, gxg_gtk_widget_set_halign_w, 2, 0, 0, H_gtk_widget_set_halign, pl_tug);
+ Xg_define_procedure(gtk_widget_get_valign, gxg_gtk_widget_get_valign_w, 1, 0, 0, H_gtk_widget_get_valign, pl_gu);
+ Xg_define_procedure(gtk_widget_set_valign, gxg_gtk_widget_set_valign_w, 2, 0, 0, H_gtk_widget_set_valign, pl_tug);
Xg_define_procedure(gtk_widget_get_margin_top, gxg_gtk_widget_get_margin_top_w, 1, 0, 0, H_gtk_widget_get_margin_top, pl_iu);
Xg_define_procedure(gtk_widget_set_margin_top, gxg_gtk_widget_set_margin_top_w, 2, 0, 0, H_gtk_widget_set_margin_top, pl_tui);
Xg_define_procedure(gtk_widget_get_margin_bottom, gxg_gtk_widget_get_margin_bottom_w, 1, 0, 0, H_gtk_widget_get_margin_bottom, pl_iu);
@@ -42387,9 +42803,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_get_vexpand_set, gxg_gtk_widget_get_vexpand_set_w, 1, 0, 0, H_gtk_widget_get_vexpand_set, pl_bu);
Xg_define_procedure(gtk_widget_set_vexpand_set, gxg_gtk_widget_set_vexpand_set_w, 2, 0, 0, H_gtk_widget_set_vexpand_set, pl_tub);
Xg_define_procedure(gtk_widget_queue_compute_expand, gxg_gtk_widget_queue_compute_expand_w, 1, 0, 0, H_gtk_widget_queue_compute_expand, pl_tu);
- Xg_define_procedure(gtk_widget_compute_expand, gxg_gtk_widget_compute_expand_w, 2, 0, 0, H_gtk_widget_compute_expand, pl_bui);
- Xg_define_procedure(gtk_window_set_default_geometry, gxg_gtk_window_set_default_geometry_w, 3, 0, 0, H_gtk_window_set_default_geometry, pl_tui);
- Xg_define_procedure(gtk_window_resize_to_geometry, gxg_gtk_window_resize_to_geometry_w, 3, 0, 0, H_gtk_window_resize_to_geometry, pl_tui);
+ Xg_define_procedure(gtk_widget_compute_expand, gxg_gtk_widget_compute_expand_w, 2, 0, 0, H_gtk_widget_compute_expand, pl_bug);
Xg_define_procedure(gtk_combo_box_text_new, gxg_gtk_combo_box_text_new_w, 0, 0, 0, H_gtk_combo_box_text_new, pl_p);
Xg_define_procedure(gtk_combo_box_text_new_with_entry, gxg_gtk_combo_box_text_new_with_entry_w, 0, 0, 0, H_gtk_combo_box_text_new_with_entry, pl_p);
Xg_define_procedure(gtk_combo_box_text_append_text, gxg_gtk_combo_box_text_append_text_w, 2, 0, 0, H_gtk_combo_box_text_append_text, pl_tus);
@@ -42409,7 +42823,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_scrolled_window_set_min_content_height, gxg_gtk_scrolled_window_set_min_content_height_w, 2, 0, 0, H_gtk_scrolled_window_set_min_content_height, pl_tui);
Xg_define_procedure(gtk_grid_new, gxg_gtk_grid_new_w, 0, 0, 0, H_gtk_grid_new, pl_p);
Xg_define_procedure(gtk_grid_attach, gxg_gtk_grid_attach_w, 6, 0, 0, H_gtk_grid_attach, pl_tuui);
- Xg_define_procedure(gtk_grid_attach_next_to, gxg_gtk_grid_attach_next_to_w, 6, 0, 0, H_gtk_grid_attach_next_to, pl_tuuui);
+ Xg_define_procedure(gtk_grid_attach_next_to, gxg_gtk_grid_attach_next_to_w, 6, 0, 0, H_gtk_grid_attach_next_to, pl_tuuugi);
Xg_define_procedure(gtk_grid_set_row_homogeneous, gxg_gtk_grid_set_row_homogeneous_w, 2, 0, 0, H_gtk_grid_set_row_homogeneous, pl_tub);
Xg_define_procedure(gtk_grid_get_row_homogeneous, gxg_gtk_grid_get_row_homogeneous_w, 1, 0, 0, H_gtk_grid_get_row_homogeneous, pl_bu);
Xg_define_procedure(gtk_grid_set_row_spacing, gxg_gtk_grid_set_row_spacing_w, 2, 0, 0, H_gtk_grid_set_row_spacing, pl_tui);
@@ -42425,10 +42839,10 @@ pl_unused = NULL;
Xg_define_procedure(gtk_assistant_next_page, gxg_gtk_assistant_next_page_w, 1, 0, 0, H_gtk_assistant_next_page, pl_tu);
Xg_define_procedure(gtk_assistant_previous_page, gxg_gtk_assistant_previous_page_w, 1, 0, 0, H_gtk_assistant_previous_page, pl_tu);
Xg_define_procedure(gtk_combo_box_new_with_model_and_entry, gxg_gtk_combo_box_new_with_model_and_entry_w, 1, 0, 0, H_gtk_combo_box_new_with_model_and_entry, pl_pu);
- Xg_define_procedure(gtk_scrollable_get_hscroll_policy, gxg_gtk_scrollable_get_hscroll_policy_w, 1, 0, 0, H_gtk_scrollable_get_hscroll_policy, pl_iu);
- Xg_define_procedure(gtk_scrollable_set_hscroll_policy, gxg_gtk_scrollable_set_hscroll_policy_w, 2, 0, 0, H_gtk_scrollable_set_hscroll_policy, pl_tui);
- Xg_define_procedure(gtk_scrollable_get_vscroll_policy, gxg_gtk_scrollable_get_vscroll_policy_w, 1, 0, 0, H_gtk_scrollable_get_vscroll_policy, pl_iu);
- Xg_define_procedure(gtk_scrollable_set_vscroll_policy, gxg_gtk_scrollable_set_vscroll_policy_w, 2, 0, 0, H_gtk_scrollable_set_vscroll_policy, pl_tui);
+ Xg_define_procedure(gtk_scrollable_get_hscroll_policy, gxg_gtk_scrollable_get_hscroll_policy_w, 1, 0, 0, H_gtk_scrollable_get_hscroll_policy, pl_gu);
+ Xg_define_procedure(gtk_scrollable_set_hscroll_policy, gxg_gtk_scrollable_set_hscroll_policy_w, 2, 0, 0, H_gtk_scrollable_set_hscroll_policy, pl_tug);
+ Xg_define_procedure(gtk_scrollable_get_vscroll_policy, gxg_gtk_scrollable_get_vscroll_policy_w, 1, 0, 0, H_gtk_scrollable_get_vscroll_policy, pl_gu);
+ Xg_define_procedure(gtk_scrollable_set_vscroll_policy, gxg_gtk_scrollable_set_vscroll_policy_w, 2, 0, 0, H_gtk_scrollable_set_vscroll_policy, pl_tug);
Xg_define_procedure(gtk_switch_new, gxg_gtk_switch_new_w, 0, 0, 0, H_gtk_switch_new, pl_p);
Xg_define_procedure(gtk_switch_set_active, gxg_gtk_switch_set_active_w, 2, 0, 0, H_gtk_switch_set_active, pl_tub);
Xg_define_procedure(gtk_switch_get_active, gxg_gtk_switch_get_active_w, 1, 0, 0, H_gtk_switch_get_active, pl_bu);
@@ -42443,8 +42857,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_combo_box_text_insert, gxg_gtk_combo_box_text_insert_w, 4, 0, 0, H_gtk_combo_box_text_insert, pl_tuis);
Xg_define_procedure(gtk_combo_box_text_append, gxg_gtk_combo_box_text_append_w, 3, 0, 0, H_gtk_combo_box_text_append, pl_tus);
Xg_define_procedure(gtk_combo_box_text_prepend, gxg_gtk_combo_box_text_prepend_w, 3, 0, 0, H_gtk_combo_box_text_prepend, pl_tus);
- Xg_define_procedure(gtk_button_box_new, gxg_gtk_button_box_new_w, 1, 0, 0, H_gtk_button_box_new, pl_pi);
- Xg_define_procedure(gtk_box_new, gxg_gtk_box_new_w, 2, 0, 0, H_gtk_box_new, pl_pi);
+ Xg_define_procedure(gtk_button_box_new, gxg_gtk_button_box_new_w, 1, 0, 0, H_gtk_button_box_new, pl_pg);
+ Xg_define_procedure(gtk_box_new, gxg_gtk_box_new_w, 2, 0, 0, H_gtk_box_new, pl_pgi);
Xg_define_procedure(gtk_tree_view_set_cursor_on_cell, gxg_gtk_tree_view_set_cursor_on_cell_w, 5, 0, 0, H_gtk_tree_view_set_cursor_on_cell, pl_tuuuub);
Xg_define_procedure(gtk_tree_view_set_rubber_banding, gxg_gtk_tree_view_set_rubber_banding_w, 2, 0, 0, H_gtk_tree_view_set_rubber_banding, pl_tub);
Xg_define_procedure(gtk_tree_view_get_rubber_banding, gxg_gtk_tree_view_get_rubber_banding_w, 1, 0, 0, H_gtk_tree_view_get_rubber_banding, pl_bu);
@@ -42452,8 +42866,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tooltip_set_icon, gxg_gtk_tooltip_set_icon_w, 2, 0, 0, H_gtk_tooltip_set_icon, pl_tu);
Xg_define_procedure(gtk_tooltip_set_custom, gxg_gtk_tooltip_set_custom_w, 2, 0, 0, H_gtk_tooltip_set_custom, pl_tu);
Xg_define_procedure(gtk_tooltip_trigger_tooltip_query, gxg_gtk_tooltip_trigger_tooltip_query_w, 1, 0, 0, H_gtk_tooltip_trigger_tooltip_query, pl_tu);
- Xg_define_procedure(gtk_button_set_image_position, gxg_gtk_button_set_image_position_w, 2, 0, 0, H_gtk_button_set_image_position, pl_tui);
- Xg_define_procedure(gtk_button_get_image_position, gxg_gtk_button_get_image_position_w, 1, 0, 0, H_gtk_button_get_image_position, pl_iu);
+ Xg_define_procedure(gtk_button_set_image_position, gxg_gtk_button_set_image_position_w, 2, 0, 0, H_gtk_button_set_image_position, pl_tug);
+ Xg_define_procedure(gtk_button_get_image_position, gxg_gtk_button_get_image_position_w, 1, 0, 0, H_gtk_button_get_image_position, pl_gu);
Xg_define_procedure(gtk_show_uri, gxg_gtk_show_uri_w, 3, 1, 0, H_gtk_show_uri, pl_busiu);
Xg_define_procedure(gtk_tree_view_column_new_with_area, gxg_gtk_tree_view_column_new_with_area_w, 1, 0, 0, H_gtk_tree_view_column_new_with_area, pl_pu);
Xg_define_procedure(gtk_tree_view_column_get_button, gxg_gtk_tree_view_column_get_button_w, 1, 0, 0, H_gtk_tree_view_column_get_button, pl_pu);
@@ -42461,8 +42875,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_clipboard_wait_is_uris_available, gxg_gtk_clipboard_wait_is_uris_available_w, 1, 0, 0, H_gtk_clipboard_wait_is_uris_available, pl_bu);
Xg_define_procedure(gtk_toolbar_set_drop_highlight_item, gxg_gtk_toolbar_set_drop_highlight_item_w, 3, 0, 0, H_gtk_toolbar_set_drop_highlight_item, pl_tuui);
Xg_define_procedure(gtk_tool_item_toolbar_reconfigured, gxg_gtk_tool_item_toolbar_reconfigured_w, 1, 0, 0, H_gtk_tool_item_toolbar_reconfigured, pl_tu);
- Xg_define_procedure(gtk_orientable_set_orientation, gxg_gtk_orientable_set_orientation_w, 2, 0, 0, H_gtk_orientable_set_orientation, pl_tui);
- Xg_define_procedure(gtk_orientable_get_orientation, gxg_gtk_orientable_get_orientation_w, 1, 0, 0, H_gtk_orientable_get_orientation, pl_iu);
+ Xg_define_procedure(gtk_orientable_set_orientation, gxg_gtk_orientable_set_orientation_w, 2, 0, 0, H_gtk_orientable_set_orientation, pl_tug);
+ Xg_define_procedure(gtk_orientable_get_orientation, gxg_gtk_orientable_get_orientation_w, 1, 0, 0, H_gtk_orientable_get_orientation, pl_gu);
Xg_define_procedure(gtk_parse_args, gxg_gtk_parse_args_w, 0, 2, 0, H_gtk_parse_args, pl_tu);
Xg_define_procedure(gtk_get_major_version, gxg_gtk_get_major_version_w, 0, 0, 0, H_gtk_get_major_version, pl_i);
Xg_define_procedure(gtk_get_minor_version, gxg_gtk_get_minor_version_w, 0, 0, 0, H_gtk_get_minor_version, pl_i);
@@ -42474,9 +42888,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_invisible_new_for_screen, gxg_gtk_invisible_new_for_screen_w, 1, 0, 0, H_gtk_invisible_new_for_screen, pl_pu);
Xg_define_procedure(gtk_invisible_set_screen, gxg_gtk_invisible_set_screen_w, 2, 0, 0, H_gtk_invisible_set_screen, pl_tu);
Xg_define_procedure(gtk_invisible_get_screen, gxg_gtk_invisible_get_screen_w, 1, 0, 0, H_gtk_invisible_get_screen, pl_pu);
- Xg_define_procedure(gtk_entry_get_icon_storage_type, gxg_gtk_entry_get_icon_storage_type_w, 2, 0, 0, H_gtk_entry_get_icon_storage_type, pl_iui);
- Xg_define_procedure(gtk_entry_get_icon_pixbuf, gxg_gtk_entry_get_icon_pixbuf_w, 2, 0, 0, H_gtk_entry_get_icon_pixbuf, pl_pui);
- Xg_define_procedure(gtk_entry_get_icon_gicon, gxg_gtk_entry_get_icon_gicon_w, 2, 0, 0, H_gtk_entry_get_icon_gicon, pl_pui);
+ Xg_define_procedure(gtk_entry_get_icon_storage_type, gxg_gtk_entry_get_icon_storage_type_w, 2, 0, 0, H_gtk_entry_get_icon_storage_type, pl_gug);
+ Xg_define_procedure(gtk_entry_get_icon_pixbuf, gxg_gtk_entry_get_icon_pixbuf_w, 2, 0, 0, H_gtk_entry_get_icon_pixbuf, pl_pug);
+ Xg_define_procedure(gtk_entry_get_icon_gicon, gxg_gtk_entry_get_icon_gicon_w, 2, 0, 0, H_gtk_entry_get_icon_gicon, pl_pug);
Xg_define_procedure(gtk_container_propagate_draw, gxg_gtk_container_propagate_draw_w, 3, 0, 0, H_gtk_container_propagate_draw, pl_tu);
Xg_define_procedure(gtk_container_set_focus_chain, gxg_gtk_container_set_focus_chain_w, 2, 0, 0, H_gtk_container_set_focus_chain, pl_tu);
Xg_define_procedure(gtk_container_get_focus_chain, gxg_gtk_container_get_focus_chain_w, 1, 1, 0, H_gtk_container_get_focus_chain, pl_bu);
@@ -42497,7 +42911,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_set_default_icon_from_file, gxg_gtk_window_set_default_icon_from_file_w, 1, 1, 0, H_gtk_window_set_default_icon_from_file, pl_bsu);
Xg_define_procedure(gtk_window_fullscreen, gxg_gtk_window_fullscreen_w, 1, 0, 0, H_gtk_window_fullscreen, pl_tu);
Xg_define_procedure(gtk_window_unfullscreen, gxg_gtk_window_unfullscreen_w, 1, 0, 0, H_gtk_window_unfullscreen, pl_tu);
- Xg_define_procedure(gtk_window_get_window_type, gxg_gtk_window_get_window_type_w, 1, 0, 0, H_gtk_window_get_window_type, pl_iu);
+ Xg_define_procedure(gtk_window_get_window_type, gxg_gtk_window_get_window_type_w, 1, 0, 0, H_gtk_window_get_window_type, pl_gu);
Xg_define_procedure(gtk_window_group_add_window, gxg_gtk_window_group_add_window_w, 2, 0, 0, H_gtk_window_group_add_window, pl_tu);
Xg_define_procedure(gtk_window_group_remove_window, gxg_gtk_window_group_remove_window_w, 2, 0, 0, H_gtk_window_group_remove_window, pl_tu);
Xg_define_procedure(gtk_window_group_new, gxg_gtk_window_group_new_w, 0, 0, 0, H_gtk_window_group_new, pl_p);
@@ -42507,20 +42921,20 @@ pl_unused = NULL;
Xg_define_procedure(gtk_window_group_get_current_grab, gxg_gtk_window_group_get_current_grab_w, 1, 0, 0, H_gtk_window_group_get_current_grab, pl_pu);
Xg_define_procedure(gtk_selection_data_get_data, gxg_gtk_selection_data_get_data_w, 1, 0, 0, H_gtk_selection_data_get_data, pl_su);
Xg_define_procedure(gtk_selection_owner_set_for_display, gxg_gtk_selection_owner_set_for_display_w, 4, 0, 0, H_gtk_selection_owner_set_for_display, pl_buuti);
- Xg_define_procedure(gtk_tool_shell_get_text_orientation, gxg_gtk_tool_shell_get_text_orientation_w, 1, 0, 0, H_gtk_tool_shell_get_text_orientation, pl_iu);
+ Xg_define_procedure(gtk_tool_shell_get_text_orientation, gxg_gtk_tool_shell_get_text_orientation_w, 1, 0, 0, H_gtk_tool_shell_get_text_orientation, pl_gu);
Xg_define_procedure(gtk_tool_shell_get_text_alignment, gxg_gtk_tool_shell_get_text_alignment_w, 1, 0, 0, H_gtk_tool_shell_get_text_alignment, pl_du);
- Xg_define_procedure(gtk_tool_shell_get_ellipsize_mode, gxg_gtk_tool_shell_get_ellipsize_mode_w, 1, 0, 0, H_gtk_tool_shell_get_ellipsize_mode, pl_iu);
+ Xg_define_procedure(gtk_tool_shell_get_ellipsize_mode, gxg_gtk_tool_shell_get_ellipsize_mode_w, 1, 0, 0, H_gtk_tool_shell_get_ellipsize_mode, pl_gu);
Xg_define_procedure(gtk_tool_shell_get_text_size_group, gxg_gtk_tool_shell_get_text_size_group_w, 1, 0, 0, H_gtk_tool_shell_get_text_size_group, pl_pu);
- Xg_define_procedure(gtk_tool_shell_get_orientation, gxg_gtk_tool_shell_get_orientation_w, 1, 0, 0, H_gtk_tool_shell_get_orientation, pl_iu);
- Xg_define_procedure(gtk_tool_shell_get_style, gxg_gtk_tool_shell_get_style_w, 1, 0, 0, H_gtk_tool_shell_get_style, pl_iu);
- Xg_define_procedure(gtk_tool_shell_get_relief_style, gxg_gtk_tool_shell_get_relief_style_w, 1, 0, 0, H_gtk_tool_shell_get_relief_style, pl_iu);
+ Xg_define_procedure(gtk_tool_shell_get_orientation, gxg_gtk_tool_shell_get_orientation_w, 1, 0, 0, H_gtk_tool_shell_get_orientation, pl_gu);
+ Xg_define_procedure(gtk_tool_shell_get_style, gxg_gtk_tool_shell_get_style_w, 1, 0, 0, H_gtk_tool_shell_get_style, pl_gu);
+ Xg_define_procedure(gtk_tool_shell_get_relief_style, gxg_gtk_tool_shell_get_relief_style_w, 1, 0, 0, H_gtk_tool_shell_get_relief_style, pl_gu);
Xg_define_procedure(gtk_tool_shell_rebuild_menu, gxg_gtk_tool_shell_rebuild_menu_w, 1, 0, 0, H_gtk_tool_shell_rebuild_menu, pl_tu);
Xg_define_procedure(gtk_accel_map_lock_path, gxg_gtk_accel_map_lock_path_w, 1, 0, 0, H_gtk_accel_map_lock_path, pl_ts);
Xg_define_procedure(gtk_accel_map_unlock_path, gxg_gtk_accel_map_unlock_path_w, 1, 0, 0, H_gtk_accel_map_unlock_path, pl_ts);
- Xg_define_procedure(gtk_icon_theme_lookup_by_gicon, gxg_gtk_icon_theme_lookup_by_gicon_w, 4, 0, 0, H_gtk_icon_theme_lookup_by_gicon, pl_puui);
+ Xg_define_procedure(gtk_icon_theme_lookup_by_gicon, gxg_gtk_icon_theme_lookup_by_gicon_w, 4, 0, 0, H_gtk_icon_theme_lookup_by_gicon, pl_puuig);
Xg_define_procedure(gtk_icon_info_new_for_pixbuf, gxg_gtk_icon_info_new_for_pixbuf_w, 2, 0, 0, H_gtk_icon_info_new_for_pixbuf, pl_pu);
- Xg_define_procedure(gtk_icon_view_set_item_orientation, gxg_gtk_icon_view_set_item_orientation_w, 2, 0, 0, H_gtk_icon_view_set_item_orientation, pl_tui);
- Xg_define_procedure(gtk_icon_view_get_item_orientation, gxg_gtk_icon_view_get_item_orientation_w, 1, 0, 0, H_gtk_icon_view_get_item_orientation, pl_iu);
+ Xg_define_procedure(gtk_icon_view_set_item_orientation, gxg_gtk_icon_view_set_item_orientation_w, 2, 0, 0, H_gtk_icon_view_set_item_orientation, pl_tug);
+ Xg_define_procedure(gtk_icon_view_get_item_orientation, gxg_gtk_icon_view_get_item_orientation_w, 1, 0, 0, H_gtk_icon_view_get_item_orientation, pl_gu);
Xg_define_procedure(gtk_text_view_im_context_filter_keypress, gxg_gtk_text_view_im_context_filter_keypress_w, 2, 0, 0, H_gtk_text_view_im_context_filter_keypress, pl_bu);
Xg_define_procedure(gtk_text_view_reset_im_context, gxg_gtk_text_view_reset_im_context_w, 1, 0, 0, H_gtk_text_view_reset_im_context, pl_tu);
Xg_define_procedure(gdk_device_get_position, gxg_gdk_device_get_position_w, 2, 2, 0, H_gdk_device_get_position, pl_tu);
@@ -42548,9 +42962,9 @@ pl_unused = NULL;
Xg_define_procedure(gdk_rgba_free, gxg_gdk_rgba_free_w, 1, 0, 0, H_gdk_rgba_free, pl_tu);
Xg_define_procedure(gdk_rgba_parse, gxg_gdk_rgba_parse_w, 2, 0, 0, H_gdk_rgba_parse, pl_bus);
Xg_define_procedure(gdk_rgba_to_string, gxg_gdk_rgba_to_string_w, 1, 0, 0, H_gdk_rgba_to_string, pl_su);
- Xg_define_procedure(gtk_widget_set_state_flags, gxg_gtk_widget_set_state_flags_w, 3, 0, 0, H_gtk_widget_set_state_flags, pl_tuib);
- Xg_define_procedure(gtk_widget_unset_state_flags, gxg_gtk_widget_unset_state_flags_w, 2, 0, 0, H_gtk_widget_unset_state_flags, pl_tui);
- Xg_define_procedure(gtk_widget_get_state_flags, gxg_gtk_widget_get_state_flags_w, 1, 0, 0, H_gtk_widget_get_state_flags, pl_iu);
+ Xg_define_procedure(gtk_widget_set_state_flags, gxg_gtk_widget_set_state_flags_w, 3, 0, 0, H_gtk_widget_set_state_flags, pl_tugb);
+ Xg_define_procedure(gtk_widget_unset_state_flags, gxg_gtk_widget_unset_state_flags_w, 2, 0, 0, H_gtk_widget_unset_state_flags, pl_tug);
+ Xg_define_procedure(gtk_widget_get_state_flags, gxg_gtk_widget_get_state_flags_w, 1, 0, 0, H_gtk_widget_get_state_flags, pl_gu);
#endif
#if GTK_CHECK_VERSION(3, 2, 0)
@@ -42571,7 +42985,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_adjustment_get_minimum_increment, gxg_gtk_adjustment_get_minimum_increment_w, 1, 0, 0, H_gtk_adjustment_get_minimum_increment, pl_du);
Xg_define_procedure(gtk_grid_insert_row, gxg_gtk_grid_insert_row_w, 2, 0, 0, H_gtk_grid_insert_row, pl_tui);
Xg_define_procedure(gtk_grid_insert_column, gxg_gtk_grid_insert_column_w, 2, 0, 0, H_gtk_grid_insert_column, pl_tui);
- Xg_define_procedure(gtk_grid_insert_next_to, gxg_gtk_grid_insert_next_to_w, 3, 0, 0, H_gtk_grid_insert_next_to, pl_tuui);
+ Xg_define_procedure(gtk_grid_insert_next_to, gxg_gtk_grid_insert_next_to_w, 3, 0, 0, H_gtk_grid_insert_next_to, pl_tuug);
Xg_define_procedure(gtk_text_iter_assign, gxg_gtk_text_iter_assign_w, 2, 0, 0, H_gtk_text_iter_assign, pl_tu);
Xg_define_procedure(gtk_widget_has_visible_focus, gxg_gtk_widget_has_visible_focus_w, 1, 0, 0, H_gtk_widget_has_visible_focus, pl_bu);
Xg_define_procedure(gtk_window_set_focus_visible, gxg_gtk_window_set_focus_visible_w, 2, 0, 0, H_gtk_window_set_focus_visible, pl_tub);
@@ -42598,12 +43012,12 @@ pl_unused = NULL;
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
- Xg_define_procedure(gdk_keymap_get_modifier_mask, gxg_gdk_keymap_get_modifier_mask_w, 2, 0, 0, H_gdk_keymap_get_modifier_mask, pl_iui);
- Xg_define_procedure(gdk_window_begin_resize_drag_for_device, gxg_gdk_window_begin_resize_drag_for_device_w, 7, 0, 0, H_gdk_window_begin_resize_drag_for_device, pl_tuiui);
+ Xg_define_procedure(gdk_keymap_get_modifier_mask, gxg_gdk_keymap_get_modifier_mask_w, 2, 0, 0, H_gdk_keymap_get_modifier_mask, pl_gug);
+ Xg_define_procedure(gdk_window_begin_resize_drag_for_device, gxg_gdk_window_begin_resize_drag_for_device_w, 7, 0, 0, H_gdk_window_begin_resize_drag_for_device, pl_tugui);
Xg_define_procedure(gdk_window_begin_move_drag_for_device, gxg_gdk_window_begin_move_drag_for_device_w, 6, 0, 0, H_gdk_window_begin_move_drag_for_device, pl_tuui);
Xg_define_procedure(gtk_accelerator_parse_with_keycode, gxg_gtk_accelerator_parse_with_keycode_w, 4, 0, 0, H_gtk_accelerator_parse_with_keycode, pl_tsu);
- Xg_define_procedure(gtk_accelerator_name_with_keycode, gxg_gtk_accelerator_name_with_keycode_w, 4, 0, 0, H_gtk_accelerator_name_with_keycode, pl_sui);
- Xg_define_procedure(gtk_accelerator_get_label_with_keycode, gxg_gtk_accelerator_get_label_with_keycode_w, 4, 0, 0, H_gtk_accelerator_get_label_with_keycode, pl_sui);
+ Xg_define_procedure(gtk_accelerator_name_with_keycode, gxg_gtk_accelerator_name_with_keycode_w, 4, 0, 0, H_gtk_accelerator_name_with_keycode, pl_suiig);
+ Xg_define_procedure(gtk_accelerator_get_label_with_keycode, gxg_gtk_accelerator_get_label_with_keycode_w, 4, 0, 0, H_gtk_accelerator_get_label_with_keycode, pl_suiig);
Xg_define_procedure(gdk_screen_get_monitor_workarea, gxg_gdk_screen_get_monitor_workarea_w, 3, 0, 0, H_gdk_screen_get_monitor_workarea, pl_tuiu);
Xg_define_procedure(gtk_application_get_app_menu, gxg_gtk_application_get_app_menu_w, 1, 0, 0, H_gtk_application_get_app_menu, pl_pu);
Xg_define_procedure(gtk_application_set_app_menu, gxg_gtk_application_set_app_menu_w, 2, 0, 0, H_gtk_application_set_app_menu, pl_tu);
@@ -42635,7 +43049,7 @@ pl_unused = NULL;
#if GTK_CHECK_VERSION(3, 6, 0)
Xg_define_procedure(gdk_event_get_scroll_deltas, gxg_gdk_event_get_scroll_deltas_w, 1, 2, 0, H_gdk_event_get_scroll_deltas, pl_bu);
- Xg_define_procedure(gtk_color_chooser_add_palette, gxg_gtk_color_chooser_add_palette_w, 5, 0, 0, H_gtk_color_chooser_add_palette, pl_tuiiiu);
+ Xg_define_procedure(gtk_color_chooser_add_palette, gxg_gtk_color_chooser_add_palette_w, 5, 0, 0, H_gtk_color_chooser_add_palette, pl_tugiiu);
Xg_define_procedure(gtk_button_set_always_show_image, gxg_gtk_button_set_always_show_image_w, 2, 0, 0, H_gtk_button_set_always_show_image, pl_tub);
Xg_define_procedure(gtk_button_get_always_show_image, gxg_gtk_button_get_always_show_image_w, 1, 0, 0, H_gtk_button_get_always_show_image, pl_bu);
Xg_define_procedure(gtk_tree_view_get_n_columns, gxg_gtk_tree_view_get_n_columns_w, 1, 0, 0, H_gtk_tree_view_get_n_columns, pl_iu);
@@ -42647,8 +43061,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_search_entry_new, gxg_gtk_search_entry_new_w, 0, 0, 0, H_gtk_search_entry_new, pl_p);
Xg_define_procedure(gtk_level_bar_new, gxg_gtk_level_bar_new_w, 0, 0, 0, H_gtk_level_bar_new, pl_p);
Xg_define_procedure(gtk_level_bar_new_for_interval, gxg_gtk_level_bar_new_for_interval_w, 2, 0, 0, H_gtk_level_bar_new_for_interval, pl_pr);
- Xg_define_procedure(gtk_level_bar_set_mode, gxg_gtk_level_bar_set_mode_w, 2, 0, 0, H_gtk_level_bar_set_mode, pl_tui);
- Xg_define_procedure(gtk_level_bar_get_mode, gxg_gtk_level_bar_get_mode_w, 1, 0, 0, H_gtk_level_bar_get_mode, pl_iu);
+ Xg_define_procedure(gtk_level_bar_set_mode, gxg_gtk_level_bar_set_mode_w, 2, 0, 0, H_gtk_level_bar_set_mode, pl_tug);
+ Xg_define_procedure(gtk_level_bar_get_mode, gxg_gtk_level_bar_get_mode_w, 1, 0, 0, H_gtk_level_bar_get_mode, pl_gu);
Xg_define_procedure(gtk_level_bar_set_value, gxg_gtk_level_bar_set_value_w, 2, 0, 0, H_gtk_level_bar_set_value, pl_tur);
Xg_define_procedure(gtk_level_bar_get_value, gxg_gtk_level_bar_get_value_w, 1, 0, 0, H_gtk_level_bar_get_value, pl_du);
Xg_define_procedure(gtk_level_bar_set_min_value, gxg_gtk_level_bar_set_min_value_w, 2, 0, 0, H_gtk_level_bar_set_min_value, pl_tur);
@@ -42659,18 +43073,18 @@ pl_unused = NULL;
Xg_define_procedure(gtk_level_bar_remove_offset_value, gxg_gtk_level_bar_remove_offset_value_w, 2, 0, 0, H_gtk_level_bar_remove_offset_value, pl_tus);
Xg_define_procedure(gtk_level_bar_get_offset_value, gxg_gtk_level_bar_get_offset_value_w, 2, 1, 0, H_gtk_level_bar_get_offset_value, pl_busu);
Xg_define_procedure(gtk_application_get_active_window, gxg_gtk_application_get_active_window_w, 1, 0, 0, H_gtk_application_get_active_window, pl_pu);
- Xg_define_procedure(gtk_entry_set_input_purpose, gxg_gtk_entry_set_input_purpose_w, 2, 0, 0, H_gtk_entry_set_input_purpose, pl_tui);
- Xg_define_procedure(gtk_entry_get_input_purpose, gxg_gtk_entry_get_input_purpose_w, 1, 0, 0, H_gtk_entry_get_input_purpose, pl_iu);
- Xg_define_procedure(gtk_entry_set_input_hints, gxg_gtk_entry_set_input_hints_w, 2, 0, 0, H_gtk_entry_set_input_hints, pl_tui);
- Xg_define_procedure(gtk_entry_get_input_hints, gxg_gtk_entry_get_input_hints_w, 1, 0, 0, H_gtk_entry_get_input_hints, pl_iu);
+ Xg_define_procedure(gtk_entry_set_input_purpose, gxg_gtk_entry_set_input_purpose_w, 2, 0, 0, H_gtk_entry_set_input_purpose, pl_tug);
+ Xg_define_procedure(gtk_entry_get_input_purpose, gxg_gtk_entry_get_input_purpose_w, 1, 0, 0, H_gtk_entry_get_input_purpose, pl_gu);
+ Xg_define_procedure(gtk_entry_set_input_hints, gxg_gtk_entry_set_input_hints_w, 2, 0, 0, H_gtk_entry_set_input_hints, pl_tug);
+ Xg_define_procedure(gtk_entry_get_input_hints, gxg_gtk_entry_get_input_hints_w, 1, 0, 0, H_gtk_entry_get_input_hints, pl_gu);
Xg_define_procedure(gtk_menu_button_get_popup, gxg_gtk_menu_button_get_popup_w, 1, 0, 0, H_gtk_menu_button_get_popup, pl_pu);
- Xg_define_procedure(gtk_text_view_set_input_purpose, gxg_gtk_text_view_set_input_purpose_w, 2, 0, 0, H_gtk_text_view_set_input_purpose, pl_tui);
- Xg_define_procedure(gtk_text_view_get_input_purpose, gxg_gtk_text_view_get_input_purpose_w, 1, 0, 0, H_gtk_text_view_get_input_purpose, pl_iu);
- Xg_define_procedure(gtk_text_view_set_input_hints, gxg_gtk_text_view_set_input_hints_w, 2, 0, 0, H_gtk_text_view_set_input_hints, pl_tui);
- Xg_define_procedure(gtk_text_view_get_input_hints, gxg_gtk_text_view_get_input_hints_w, 1, 0, 0, H_gtk_text_view_get_input_hints, pl_iu);
+ Xg_define_procedure(gtk_text_view_set_input_purpose, gxg_gtk_text_view_set_input_purpose_w, 2, 0, 0, H_gtk_text_view_set_input_purpose, pl_tug);
+ Xg_define_procedure(gtk_text_view_get_input_purpose, gxg_gtk_text_view_get_input_purpose_w, 1, 0, 0, H_gtk_text_view_get_input_purpose, pl_gu);
+ Xg_define_procedure(gtk_text_view_set_input_hints, gxg_gtk_text_view_set_input_hints_w, 2, 0, 0, H_gtk_text_view_set_input_hints, pl_tug);
+ Xg_define_procedure(gtk_text_view_get_input_hints, gxg_gtk_text_view_get_input_hints_w, 1, 0, 0, H_gtk_text_view_get_input_hints, pl_gu);
Xg_define_procedure(gtk_entry_set_attributes, gxg_gtk_entry_set_attributes_w, 2, 0, 0, H_gtk_entry_set_attributes, pl_tu);
Xg_define_procedure(gtk_entry_get_attributes, gxg_gtk_entry_get_attributes_w, 1, 0, 0, H_gtk_entry_get_attributes, pl_pu);
- Xg_define_procedure(gtk_accel_label_set_accel, gxg_gtk_accel_label_set_accel_w, 3, 0, 0, H_gtk_accel_label_set_accel, pl_tui);
+ Xg_define_procedure(gtk_accel_label_set_accel, gxg_gtk_accel_label_set_accel_w, 3, 0, 0, H_gtk_accel_label_set_accel, pl_tuig);
Xg_define_procedure(gtk_menu_shell_bind_model, gxg_gtk_menu_shell_bind_model_w, 4, 0, 0, H_gtk_menu_shell_bind_model, pl_tuusb);
#endif
@@ -42678,8 +43092,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_level_bar_set_inverted, gxg_gtk_level_bar_set_inverted_w, 2, 0, 0, H_gtk_level_bar_set_inverted, pl_tub);
Xg_define_procedure(gtk_level_bar_get_inverted, gxg_gtk_level_bar_get_inverted_w, 1, 0, 0, H_gtk_level_bar_get_inverted, pl_bu);
Xg_define_procedure(gtk_widget_is_visible, gxg_gtk_widget_is_visible_w, 1, 0, 0, H_gtk_widget_is_visible, pl_bu);
- Xg_define_procedure(gdk_window_set_fullscreen_mode, gxg_gdk_window_set_fullscreen_mode_w, 2, 0, 0, H_gdk_window_set_fullscreen_mode, pl_tui);
- Xg_define_procedure(gdk_window_get_fullscreen_mode, gxg_gdk_window_get_fullscreen_mode_w, 1, 0, 0, H_gdk_window_get_fullscreen_mode, pl_iu);
+ Xg_define_procedure(gdk_window_set_fullscreen_mode, gxg_gdk_window_set_fullscreen_mode_w, 2, 0, 0, H_gdk_window_set_fullscreen_mode, pl_tug);
+ Xg_define_procedure(gdk_window_get_fullscreen_mode, gxg_gdk_window_get_fullscreen_mode_w, 1, 0, 0, H_gdk_window_get_fullscreen_mode, pl_gu);
Xg_define_procedure(gtk_icon_view_set_activate_on_single_click, gxg_gtk_icon_view_set_activate_on_single_click_w, 2, 0, 0, H_gtk_icon_view_set_activate_on_single_click, pl_tub);
Xg_define_procedure(gtk_icon_view_get_activate_on_single_click, gxg_gtk_icon_view_get_activate_on_single_click_w, 1, 0, 0, H_gtk_icon_view_get_activate_on_single_click, pl_bu);
Xg_define_procedure(gtk_tree_view_get_activate_on_single_click, gxg_gtk_tree_view_get_activate_on_single_click_w, 1, 0, 0, H_gtk_tree_view_get_activate_on_single_click, pl_bu);
@@ -42693,23 +43107,23 @@ pl_unused = NULL;
#if GTK_CHECK_VERSION(3, 10, 0)
Xg_define_procedure(gdk_set_allowed_backends, gxg_gdk_set_allowed_backends_w, 1, 0, 0, H_gdk_set_allowed_backends, pl_ts);
- Xg_define_procedure(gtk_box_set_baseline_position, gxg_gtk_box_set_baseline_position_w, 2, 0, 0, H_gtk_box_set_baseline_position, pl_tui);
- Xg_define_procedure(gtk_box_get_baseline_position, gxg_gtk_box_get_baseline_position_w, 1, 0, 0, H_gtk_box_get_baseline_position, pl_iu);
+ Xg_define_procedure(gtk_box_set_baseline_position, gxg_gtk_box_set_baseline_position_w, 2, 0, 0, H_gtk_box_set_baseline_position, pl_tug);
+ Xg_define_procedure(gtk_box_get_baseline_position, gxg_gtk_box_get_baseline_position_w, 1, 0, 0, H_gtk_box_get_baseline_position, pl_gu);
Xg_define_procedure(gtk_grid_remove_row, gxg_gtk_grid_remove_row_w, 2, 0, 0, H_gtk_grid_remove_row, pl_tui);
Xg_define_procedure(gtk_grid_remove_column, gxg_gtk_grid_remove_column_w, 2, 0, 0, H_gtk_grid_remove_column, pl_tui);
- Xg_define_procedure(gtk_grid_set_row_baseline_position, gxg_gtk_grid_set_row_baseline_position_w, 3, 0, 0, H_gtk_grid_set_row_baseline_position, pl_tui);
- Xg_define_procedure(gtk_grid_get_row_baseline_position, gxg_gtk_grid_get_row_baseline_position_w, 2, 0, 0, H_gtk_grid_get_row_baseline_position, pl_iui);
+ Xg_define_procedure(gtk_grid_set_row_baseline_position, gxg_gtk_grid_set_row_baseline_position_w, 3, 0, 0, H_gtk_grid_set_row_baseline_position, pl_tuig);
+ Xg_define_procedure(gtk_grid_get_row_baseline_position, gxg_gtk_grid_get_row_baseline_position_w, 2, 0, 0, H_gtk_grid_get_row_baseline_position, pl_gui);
Xg_define_procedure(gtk_grid_set_baseline_row, gxg_gtk_grid_set_baseline_row_w, 2, 0, 0, H_gtk_grid_set_baseline_row, pl_tui);
Xg_define_procedure(gtk_grid_get_baseline_row, gxg_gtk_grid_get_baseline_row_w, 1, 0, 0, H_gtk_grid_get_baseline_row, pl_iu);
Xg_define_procedure(gtk_widget_size_allocate_with_baseline, gxg_gtk_widget_size_allocate_with_baseline_w, 3, 0, 0, H_gtk_widget_size_allocate_with_baseline, pl_tuui);
Xg_define_procedure(gtk_widget_get_preferred_height_and_baseline_for_width, gxg_gtk_widget_get_preferred_height_and_baseline_for_width_w, 2, 4, 0, H_gtk_widget_get_preferred_height_and_baseline_for_width, pl_tuiu);
Xg_define_procedure(gtk_widget_get_allocated_baseline, gxg_gtk_widget_get_allocated_baseline_w, 1, 0, 0, H_gtk_widget_get_allocated_baseline, pl_iu);
- Xg_define_procedure(gtk_widget_get_valign_with_baseline, gxg_gtk_widget_get_valign_with_baseline_w, 1, 0, 0, H_gtk_widget_get_valign_with_baseline, pl_iu);
+ Xg_define_procedure(gtk_widget_get_valign_with_baseline, gxg_gtk_widget_get_valign_with_baseline_w, 1, 0, 0, H_gtk_widget_get_valign_with_baseline, pl_gu);
Xg_define_procedure(gtk_widget_init_template, gxg_gtk_widget_init_template_w, 1, 0, 0, H_gtk_widget_init_template, pl_tu);
Xg_define_procedure(gtk_window_set_titlebar, gxg_gtk_window_set_titlebar_w, 2, 0, 0, H_gtk_window_set_titlebar, pl_tu);
Xg_define_procedure(gtk_places_sidebar_new, gxg_gtk_places_sidebar_new_w, 0, 0, 0, H_gtk_places_sidebar_new, pl_p);
- Xg_define_procedure(gtk_places_sidebar_get_open_flags, gxg_gtk_places_sidebar_get_open_flags_w, 1, 0, 0, H_gtk_places_sidebar_get_open_flags, pl_iu);
- Xg_define_procedure(gtk_places_sidebar_set_open_flags, gxg_gtk_places_sidebar_set_open_flags_w, 2, 0, 0, H_gtk_places_sidebar_set_open_flags, pl_tui);
+ Xg_define_procedure(gtk_places_sidebar_get_open_flags, gxg_gtk_places_sidebar_get_open_flags_w, 1, 0, 0, H_gtk_places_sidebar_get_open_flags, pl_gu);
+ Xg_define_procedure(gtk_places_sidebar_set_open_flags, gxg_gtk_places_sidebar_set_open_flags_w, 2, 0, 0, H_gtk_places_sidebar_set_open_flags, pl_tug);
Xg_define_procedure(gtk_places_sidebar_get_location, gxg_gtk_places_sidebar_get_location_w, 1, 0, 0, H_gtk_places_sidebar_get_location, pl_pu);
Xg_define_procedure(gtk_places_sidebar_set_location, gxg_gtk_places_sidebar_set_location_w, 2, 0, 0, H_gtk_places_sidebar_set_location, pl_tu);
Xg_define_procedure(gtk_places_sidebar_get_show_desktop, gxg_gtk_places_sidebar_get_show_desktop_w, 1, 0, 0, H_gtk_places_sidebar_get_show_desktop, pl_bu);
@@ -42728,21 +43142,21 @@ pl_unused = NULL;
Xg_define_procedure(gtk_stack_get_visible_child, gxg_gtk_stack_get_visible_child_w, 1, 0, 0, H_gtk_stack_get_visible_child, pl_pu);
Xg_define_procedure(gtk_stack_set_visible_child_name, gxg_gtk_stack_set_visible_child_name_w, 2, 0, 0, H_gtk_stack_set_visible_child_name, pl_tus);
Xg_define_procedure(gtk_stack_get_visible_child_name, gxg_gtk_stack_get_visible_child_name_w, 1, 0, 0, H_gtk_stack_get_visible_child_name, pl_su);
- Xg_define_procedure(gtk_stack_set_visible_child_full, gxg_gtk_stack_set_visible_child_full_w, 3, 0, 0, H_gtk_stack_set_visible_child_full, pl_tusi);
+ Xg_define_procedure(gtk_stack_set_visible_child_full, gxg_gtk_stack_set_visible_child_full_w, 3, 0, 0, H_gtk_stack_set_visible_child_full, pl_tusg);
Xg_define_procedure(gtk_stack_set_homogeneous, gxg_gtk_stack_set_homogeneous_w, 2, 0, 0, H_gtk_stack_set_homogeneous, pl_tub);
Xg_define_procedure(gtk_stack_get_homogeneous, gxg_gtk_stack_get_homogeneous_w, 1, 0, 0, H_gtk_stack_get_homogeneous, pl_bu);
Xg_define_procedure(gtk_stack_set_transition_duration, gxg_gtk_stack_set_transition_duration_w, 2, 0, 0, H_gtk_stack_set_transition_duration, pl_tui);
Xg_define_procedure(gtk_stack_get_transition_duration, gxg_gtk_stack_get_transition_duration_w, 1, 0, 0, H_gtk_stack_get_transition_duration, pl_iu);
- Xg_define_procedure(gtk_stack_set_transition_type, gxg_gtk_stack_set_transition_type_w, 2, 0, 0, H_gtk_stack_set_transition_type, pl_tui);
- Xg_define_procedure(gtk_stack_get_transition_type, gxg_gtk_stack_get_transition_type_w, 1, 0, 0, H_gtk_stack_get_transition_type, pl_iu);
+ Xg_define_procedure(gtk_stack_set_transition_type, gxg_gtk_stack_set_transition_type_w, 2, 0, 0, H_gtk_stack_set_transition_type, pl_tug);
+ Xg_define_procedure(gtk_stack_get_transition_type, gxg_gtk_stack_get_transition_type_w, 1, 0, 0, H_gtk_stack_get_transition_type, pl_gu);
Xg_define_procedure(gtk_revealer_new, gxg_gtk_revealer_new_w, 0, 0, 0, H_gtk_revealer_new, pl_p);
Xg_define_procedure(gtk_revealer_get_reveal_child, gxg_gtk_revealer_get_reveal_child_w, 1, 0, 0, H_gtk_revealer_get_reveal_child, pl_bu);
Xg_define_procedure(gtk_revealer_set_reveal_child, gxg_gtk_revealer_set_reveal_child_w, 2, 0, 0, H_gtk_revealer_set_reveal_child, pl_tub);
Xg_define_procedure(gtk_revealer_get_child_revealed, gxg_gtk_revealer_get_child_revealed_w, 1, 0, 0, H_gtk_revealer_get_child_revealed, pl_bu);
Xg_define_procedure(gtk_revealer_get_transition_duration, gxg_gtk_revealer_get_transition_duration_w, 1, 0, 0, H_gtk_revealer_get_transition_duration, pl_iu);
Xg_define_procedure(gtk_revealer_set_transition_duration, gxg_gtk_revealer_set_transition_duration_w, 2, 0, 0, H_gtk_revealer_set_transition_duration, pl_tui);
- Xg_define_procedure(gtk_revealer_set_transition_type, gxg_gtk_revealer_set_transition_type_w, 2, 0, 0, H_gtk_revealer_set_transition_type, pl_tui);
- Xg_define_procedure(gtk_revealer_get_transition_type, gxg_gtk_revealer_get_transition_type_w, 1, 0, 0, H_gtk_revealer_get_transition_type, pl_iu);
+ Xg_define_procedure(gtk_revealer_set_transition_type, gxg_gtk_revealer_set_transition_type_w, 2, 0, 0, H_gtk_revealer_set_transition_type, pl_tug);
+ Xg_define_procedure(gtk_revealer_get_transition_type, gxg_gtk_revealer_get_transition_type_w, 1, 0, 0, H_gtk_revealer_get_transition_type, pl_gu);
Xg_define_procedure(gtk_header_bar_new, gxg_gtk_header_bar_new_w, 0, 0, 0, H_gtk_header_bar_new, pl_p);
Xg_define_procedure(gtk_header_bar_set_title, gxg_gtk_header_bar_set_title_w, 2, 0, 0, H_gtk_header_bar_set_title, pl_tus);
Xg_define_procedure(gtk_header_bar_get_title, gxg_gtk_header_bar_get_title_w, 1, 0, 0, H_gtk_header_bar_get_title, pl_su);
@@ -42763,8 +43177,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_list_box_set_placeholder, gxg_gtk_list_box_set_placeholder_w, 2, 0, 0, H_gtk_list_box_set_placeholder, pl_tu);
Xg_define_procedure(gtk_list_box_set_adjustment, gxg_gtk_list_box_set_adjustment_w, 2, 0, 0, H_gtk_list_box_set_adjustment, pl_tu);
Xg_define_procedure(gtk_list_box_get_adjustment, gxg_gtk_list_box_get_adjustment_w, 1, 0, 0, H_gtk_list_box_get_adjustment, pl_pu);
- Xg_define_procedure(gtk_list_box_set_selection_mode, gxg_gtk_list_box_set_selection_mode_w, 2, 0, 0, H_gtk_list_box_set_selection_mode, pl_tui);
- Xg_define_procedure(gtk_list_box_get_selection_mode, gxg_gtk_list_box_get_selection_mode_w, 1, 0, 0, H_gtk_list_box_get_selection_mode, pl_iu);
+ Xg_define_procedure(gtk_list_box_set_selection_mode, gxg_gtk_list_box_set_selection_mode_w, 2, 0, 0, H_gtk_list_box_set_selection_mode, pl_tug);
+ Xg_define_procedure(gtk_list_box_get_selection_mode, gxg_gtk_list_box_get_selection_mode_w, 1, 0, 0, H_gtk_list_box_get_selection_mode, pl_gu);
Xg_define_procedure(gtk_list_box_invalidate_filter, gxg_gtk_list_box_invalidate_filter_w, 1, 0, 0, H_gtk_list_box_invalidate_filter, pl_tu);
Xg_define_procedure(gtk_list_box_invalidate_sort, gxg_gtk_list_box_invalidate_sort_w, 1, 0, 0, H_gtk_list_box_invalidate_sort, pl_tu);
Xg_define_procedure(gtk_list_box_invalidate_headers, gxg_gtk_list_box_invalidate_headers_w, 1, 0, 0, H_gtk_list_box_invalidate_headers, pl_tu);
@@ -42787,11 +43201,11 @@ pl_unused = NULL;
Xg_define_procedure(gdk_screen_get_monitor_scale_factor, gxg_gdk_screen_get_monitor_scale_factor_w, 2, 0, 0, H_gdk_screen_get_monitor_scale_factor, pl_iui);
Xg_define_procedure(gdk_window_get_scale_factor, gxg_gdk_window_get_scale_factor_w, 1, 0, 0, H_gdk_window_get_scale_factor, pl_iu);
Xg_define_procedure(gdk_window_get_device_position_double, gxg_gdk_window_get_device_position_double_w, 2, 3, 0, H_gdk_window_get_device_position_double, pl_pu);
- Xg_define_procedure(gdk_window_create_similar_image_surface, gxg_gdk_window_create_similar_image_surface_w, 5, 0, 0, H_gdk_window_create_similar_image_surface, pl_pui);
- Xg_define_procedure(gtk_icon_theme_lookup_icon_for_scale, gxg_gtk_icon_theme_lookup_icon_for_scale_w, 5, 0, 0, H_gtk_icon_theme_lookup_icon_for_scale, pl_pusi);
- Xg_define_procedure(gtk_icon_theme_load_icon_for_scale, gxg_gtk_icon_theme_load_icon_for_scale_w, 5, 1, 0, H_gtk_icon_theme_load_icon_for_scale, pl_pusiiiu);
- Xg_define_procedure(gtk_icon_theme_load_surface, gxg_gtk_icon_theme_load_surface_w, 6, 1, 0, H_gtk_icon_theme_load_surface, pl_pusiiuiu);
- Xg_define_procedure(gtk_icon_theme_lookup_by_gicon_for_scale, gxg_gtk_icon_theme_lookup_by_gicon_for_scale_w, 5, 0, 0, H_gtk_icon_theme_lookup_by_gicon_for_scale, pl_puui);
+ Xg_define_procedure(gdk_window_create_similar_image_surface, gxg_gdk_window_create_similar_image_surface_w, 5, 0, 0, H_gdk_window_create_similar_image_surface, pl_pugi);
+ Xg_define_procedure(gtk_icon_theme_lookup_icon_for_scale, gxg_gtk_icon_theme_lookup_icon_for_scale_w, 5, 0, 0, H_gtk_icon_theme_lookup_icon_for_scale, pl_pusiig);
+ Xg_define_procedure(gtk_icon_theme_load_icon_for_scale, gxg_gtk_icon_theme_load_icon_for_scale_w, 5, 1, 0, H_gtk_icon_theme_load_icon_for_scale, pl_pusiigu);
+ Xg_define_procedure(gtk_icon_theme_load_surface, gxg_gtk_icon_theme_load_surface_w, 6, 1, 0, H_gtk_icon_theme_load_surface, pl_pusiiugu);
+ Xg_define_procedure(gtk_icon_theme_lookup_by_gicon_for_scale, gxg_gtk_icon_theme_lookup_by_gicon_for_scale_w, 5, 0, 0, H_gtk_icon_theme_lookup_by_gicon_for_scale, pl_puuiig);
Xg_define_procedure(gtk_icon_info_get_base_scale, gxg_gtk_icon_info_get_base_scale_w, 1, 0, 0, H_gtk_icon_info_get_base_scale, pl_iu);
Xg_define_procedure(gtk_icon_info_load_surface, gxg_gtk_icon_info_load_surface_w, 2, 1, 0, H_gtk_icon_info_load_surface, pl_pu);
Xg_define_procedure(gtk_image_new_from_surface, gxg_gtk_image_new_from_surface_w, 1, 0, 0, H_gtk_image_new_from_surface, pl_pu);
@@ -42804,7 +43218,7 @@ pl_unused = NULL;
Xg_define_procedure(gtk_tree_model_rows_reordered_with_length, gxg_gtk_tree_model_rows_reordered_with_length_w, 5, 0, 0, H_gtk_tree_model_rows_reordered_with_length, pl_tuuuui);
Xg_define_procedure(gdk_cursor_new_from_surface, gxg_gdk_cursor_new_from_surface_w, 4, 0, 0, H_gdk_cursor_new_from_surface, pl_puur);
Xg_define_procedure(gdk_cursor_get_surface, gxg_gdk_cursor_get_surface_w, 1, 2, 0, H_gdk_cursor_get_surface, pl_pu);
- Xg_define_procedure(gdk_event_get_event_type, gxg_gdk_event_get_event_type_w, 1, 0, 0, H_gdk_event_get_event_type, pl_iu);
+ Xg_define_procedure(gdk_event_get_event_type, gxg_gdk_event_get_event_type_w, 1, 0, 0, H_gdk_event_get_event_type, pl_gu);
Xg_define_procedure(gtk_entry_set_tabs, gxg_gtk_entry_set_tabs_w, 2, 0, 0, H_gtk_entry_set_tabs, pl_tu);
Xg_define_procedure(gtk_entry_get_tabs, gxg_gtk_entry_get_tabs_w, 1, 0, 0, H_gtk_entry_get_tabs, pl_pu);
Xg_define_procedure(gtk_header_bar_get_show_close_button, gxg_gtk_header_bar_get_show_close_button_w, 1, 0, 0, H_gtk_header_bar_get_show_close_button, pl_bu);
@@ -42842,8 +43256,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_flow_box_unselect_child, gxg_gtk_flow_box_unselect_child_w, 2, 0, 0, H_gtk_flow_box_unselect_child, pl_tu);
Xg_define_procedure(gtk_flow_box_select_all, gxg_gtk_flow_box_select_all_w, 1, 0, 0, H_gtk_flow_box_select_all, pl_tu);
Xg_define_procedure(gtk_flow_box_unselect_all, gxg_gtk_flow_box_unselect_all_w, 1, 0, 0, H_gtk_flow_box_unselect_all, pl_tu);
- Xg_define_procedure(gtk_flow_box_set_selection_mode, gxg_gtk_flow_box_set_selection_mode_w, 2, 0, 0, H_gtk_flow_box_set_selection_mode, pl_tui);
- Xg_define_procedure(gtk_flow_box_get_selection_mode, gxg_gtk_flow_box_get_selection_mode_w, 1, 0, 0, H_gtk_flow_box_get_selection_mode, pl_iu);
+ Xg_define_procedure(gtk_flow_box_set_selection_mode, gxg_gtk_flow_box_set_selection_mode_w, 2, 0, 0, H_gtk_flow_box_set_selection_mode, pl_tug);
+ Xg_define_procedure(gtk_flow_box_get_selection_mode, gxg_gtk_flow_box_get_selection_mode_w, 1, 0, 0, H_gtk_flow_box_get_selection_mode, pl_gu);
Xg_define_procedure(gtk_flow_box_set_hadjustment, gxg_gtk_flow_box_set_hadjustment_w, 2, 0, 0, H_gtk_flow_box_set_hadjustment, pl_tu);
Xg_define_procedure(gtk_flow_box_set_vadjustment, gxg_gtk_flow_box_set_vadjustment_w, 2, 0, 0, H_gtk_flow_box_set_vadjustment, pl_tu);
Xg_define_procedure(gtk_flow_box_invalidate_filter, gxg_gtk_flow_box_invalidate_filter_w, 1, 0, 0, H_gtk_flow_box_invalidate_filter, pl_tu);
@@ -42869,14 +43283,14 @@ pl_unused = NULL;
Xg_define_procedure(gtk_header_bar_set_decoration_layout, gxg_gtk_header_bar_set_decoration_layout_w, 2, 0, 0, H_gtk_header_bar_set_decoration_layout, pl_tus);
Xg_define_procedure(gtk_header_bar_get_decoration_layout, gxg_gtk_header_bar_get_decoration_layout_w, 1, 0, 0, H_gtk_header_bar_get_decoration_layout, pl_su);
Xg_define_procedure(gtk_icon_info_is_symbolic, gxg_gtk_icon_info_is_symbolic_w, 1, 0, 0, H_gtk_icon_info_is_symbolic, pl_bu);
- Xg_define_procedure(gtk_get_locale_direction, gxg_gtk_get_locale_direction_w, 0, 0, 0, H_gtk_get_locale_direction, pl_i);
+ Xg_define_procedure(gtk_get_locale_direction, gxg_gtk_get_locale_direction_w, 0, 0, 0, H_gtk_get_locale_direction, pl_g);
Xg_define_procedure(gtk_window_is_maximized, gxg_gtk_window_is_maximized_w, 1, 0, 0, H_gtk_window_is_maximized, pl_bu);
Xg_define_procedure(gtk_dialog_get_header_bar, gxg_gtk_dialog_get_header_bar_w, 1, 0, 0, H_gtk_dialog_get_header_bar, pl_pu);
Xg_define_procedure(gtk_popover_new, gxg_gtk_popover_new_w, 1, 0, 0, H_gtk_popover_new, pl_pu);
Xg_define_procedure(gtk_popover_set_relative_to, gxg_gtk_popover_set_relative_to_w, 2, 0, 0, H_gtk_popover_set_relative_to, pl_tu);
Xg_define_procedure(gtk_popover_get_relative_to, gxg_gtk_popover_get_relative_to_w, 1, 0, 0, H_gtk_popover_get_relative_to, pl_pu);
- Xg_define_procedure(gtk_popover_set_position, gxg_gtk_popover_set_position_w, 2, 0, 0, H_gtk_popover_set_position, pl_tui);
- Xg_define_procedure(gtk_popover_get_position, gxg_gtk_popover_get_position_w, 1, 0, 0, H_gtk_popover_get_position, pl_iu);
+ Xg_define_procedure(gtk_popover_set_position, gxg_gtk_popover_set_position_w, 2, 0, 0, H_gtk_popover_set_position, pl_tug);
+ Xg_define_procedure(gtk_popover_get_position, gxg_gtk_popover_get_position_w, 1, 0, 0, H_gtk_popover_get_position, pl_gu);
Xg_define_procedure(gtk_popover_set_modal, gxg_gtk_popover_set_modal_w, 2, 0, 0, H_gtk_popover_set_modal, pl_tub);
Xg_define_procedure(gtk_popover_get_modal, gxg_gtk_popover_get_modal_w, 1, 0, 0, H_gtk_popover_get_modal, pl_bu);
Xg_define_procedure(gtk_box_set_center_widget, gxg_gtk_box_set_center_widget_w, 2, 0, 0, H_gtk_box_set_center_widget, pl_tu);
@@ -42921,9 +43335,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_gesture_drag_get_start_point, gxg_gtk_gesture_drag_get_start_point_w, 1, 2, 0, H_gtk_gesture_drag_get_start_point, pl_bu);
Xg_define_procedure(gtk_gesture_drag_get_offset, gxg_gtk_gesture_drag_get_offset_w, 1, 2, 0, H_gtk_gesture_drag_get_offset, pl_bu);
Xg_define_procedure(gtk_gesture_long_press_new, gxg_gtk_gesture_long_press_new_w, 1, 0, 0, H_gtk_gesture_long_press_new, pl_pu);
- Xg_define_procedure(gtk_gesture_pan_new, gxg_gtk_gesture_pan_new_w, 2, 0, 0, H_gtk_gesture_pan_new, pl_pui);
- Xg_define_procedure(gtk_gesture_pan_get_orientation, gxg_gtk_gesture_pan_get_orientation_w, 1, 0, 0, H_gtk_gesture_pan_get_orientation, pl_iu);
- Xg_define_procedure(gtk_gesture_pan_set_orientation, gxg_gtk_gesture_pan_set_orientation_w, 2, 0, 0, H_gtk_gesture_pan_set_orientation, pl_tui);
+ Xg_define_procedure(gtk_gesture_pan_new, gxg_gtk_gesture_pan_new_w, 2, 0, 0, H_gtk_gesture_pan_new, pl_pug);
+ Xg_define_procedure(gtk_gesture_pan_get_orientation, gxg_gtk_gesture_pan_get_orientation_w, 1, 0, 0, H_gtk_gesture_pan_get_orientation, pl_gu);
+ Xg_define_procedure(gtk_gesture_pan_set_orientation, gxg_gtk_gesture_pan_set_orientation_w, 2, 0, 0, H_gtk_gesture_pan_set_orientation, pl_tug);
Xg_define_procedure(gtk_gesture_multi_press_new, gxg_gtk_gesture_multi_press_new_w, 1, 0, 0, H_gtk_gesture_multi_press_new, pl_pu);
Xg_define_procedure(gtk_gesture_multi_press_set_area, gxg_gtk_gesture_multi_press_set_area_w, 2, 0, 0, H_gtk_gesture_multi_press_set_area, pl_tu);
Xg_define_procedure(gtk_gesture_multi_press_get_area, gxg_gtk_gesture_multi_press_get_area_w, 2, 0, 0, H_gtk_gesture_multi_press_get_area, pl_bu);
@@ -42951,8 +43365,8 @@ pl_unused = NULL;
Xg_define_procedure(gtk_list_box_row_get_activatable, gxg_gtk_list_box_row_get_activatable_w, 1, 0, 0, H_gtk_list_box_row_get_activatable, pl_bu);
Xg_define_procedure(gtk_list_box_row_set_selectable, gxg_gtk_list_box_row_set_selectable_w, 2, 0, 0, H_gtk_list_box_row_set_selectable, pl_tub);
Xg_define_procedure(gtk_list_box_row_get_selectable, gxg_gtk_list_box_row_get_selectable_w, 1, 0, 0, H_gtk_list_box_row_get_selectable, pl_bu);
- Xg_define_procedure(gtk_widget_path_iter_get_state, gxg_gtk_widget_path_iter_get_state_w, 2, 0, 0, H_gtk_widget_path_iter_get_state, pl_iui);
- Xg_define_procedure(gtk_widget_path_iter_set_state, gxg_gtk_widget_path_iter_set_state_w, 3, 0, 0, H_gtk_widget_path_iter_set_state, pl_tui);
+ Xg_define_procedure(gtk_widget_path_iter_get_state, gxg_gtk_widget_path_iter_get_state_w, 2, 0, 0, H_gtk_widget_path_iter_get_state, pl_gui);
+ Xg_define_procedure(gtk_widget_path_iter_set_state, gxg_gtk_widget_path_iter_set_state_w, 3, 0, 0, H_gtk_widget_path_iter_set_state, pl_tuig);
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
@@ -42985,9 +43399,9 @@ pl_unused = NULL;
Xg_define_procedure(gtk_render_focus, gxg_gtk_render_focus_w, 6, 0, 0, H_gtk_render_focus, pl_tuur);
Xg_define_procedure(gtk_render_layout, gxg_gtk_render_layout_w, 5, 0, 0, H_gtk_render_layout, pl_tuurru);
Xg_define_procedure(gtk_render_line, gxg_gtk_render_line_w, 6, 0, 0, H_gtk_render_line, pl_tuur);
- Xg_define_procedure(gtk_render_slider, gxg_gtk_render_slider_w, 7, 0, 0, H_gtk_render_slider, pl_tuurrrri);
- Xg_define_procedure(gtk_render_frame_gap, gxg_gtk_render_frame_gap_w, 0, 0, 1, H_gtk_render_frame_gap, pl_tuurrrrir);
- Xg_define_procedure(gtk_render_extension, gxg_gtk_render_extension_w, 7, 0, 0, H_gtk_render_extension, pl_tuurrrri);
+ Xg_define_procedure(gtk_render_slider, gxg_gtk_render_slider_w, 7, 0, 0, H_gtk_render_slider, pl_tuurrrrg);
+ Xg_define_procedure(gtk_render_frame_gap, gxg_gtk_render_frame_gap_w, 0, 0, 1, H_gtk_render_frame_gap, pl_tuurrrrgr);
+ Xg_define_procedure(gtk_render_extension, gxg_gtk_render_extension_w, 7, 0, 0, H_gtk_render_extension, pl_tuurrrrg);
Xg_define_procedure(gtk_render_handle, gxg_gtk_render_handle_w, 6, 0, 0, H_gtk_render_handle, pl_tuur);
Xg_define_procedure(gtk_render_activity, gxg_gtk_render_activity_w, 6, 0, 0, H_gtk_render_activity, pl_tuur);
Xg_define_procedure(gtk_render_icon, gxg_gtk_render_icon_w, 5, 0, 0, H_gtk_render_icon, pl_tuuur);
@@ -43072,7 +43486,7 @@ pl_unused = NULL;
#if GTK_CHECK_VERSION(3, 20, 0)
Xg_define_procedure(gdk_gl_context_is_legacy, gxg_gdk_gl_context_is_legacy_w, 1, 0, 0, H_gdk_gl_context_is_legacy, pl_bu);
- Xg_define_procedure(gdk_rectangle_equal, gxg_gdk_rectangle_equal_w, 1, 0, 0, H_gdk_rectangle_equal, pl_bu);
+ Xg_define_procedure(gdk_rectangle_equal, gxg_gdk_rectangle_equal_w, 2, 0, 0, H_gdk_rectangle_equal, pl_bu);
Xg_define_procedure(gtk_application_window_set_help_overlay, gxg_gtk_application_window_set_help_overlay_w, 2, 0, 0, H_gtk_application_window_set_help_overlay, pl_tu);
Xg_define_procedure(gtk_settings_reset_property, gxg_gtk_settings_reset_property_w, 2, 0, 0, H_gtk_settings_reset_property, pl_tus);
Xg_define_procedure(gtk_text_tag_changed, gxg_gtk_text_tag_changed_w, 2, 0, 0, H_gtk_text_tag_changed, pl_tub);
@@ -43082,6 +43496,43 @@ pl_unused = NULL;
Xg_define_procedure(gtk_widget_set_focus_on_click, gxg_gtk_widget_set_focus_on_click_w, 2, 0, 0, H_gtk_widget_set_focus_on_click, pl_tub);
Xg_define_procedure(gtk_widget_get_focus_on_click, gxg_gtk_widget_get_focus_on_click_w, 1, 0, 0, H_gtk_widget_get_focus_on_click, pl_bu);
Xg_define_procedure(gtk_widget_get_allocated_size, gxg_gtk_widget_get_allocated_size_w, 1, 2, 0, H_gtk_widget_get_allocated_size, pl_tu);
+ Xg_define_procedure(gdk_drag_context_get_drag_window, gxg_gdk_drag_context_get_drag_window_w, 1, 0, 0, H_gdk_drag_context_get_drag_window, pl_pu);
+ Xg_define_procedure(gtk_popover_set_constrain_to, gxg_gtk_popover_set_constrain_to_w, 2, 0, 0, H_gtk_popover_set_constrain_to, pl_tug);
+ Xg_define_procedure(gtk_popover_get_constrain_to, gxg_gtk_popover_get_constrain_to_w, 1, 0, 0, H_gtk_popover_get_constrain_to, pl_gu);
+ Xg_define_procedure(gtk_text_iter_starts_tag, gxg_gtk_text_iter_starts_tag_w, 2, 0, 0, H_gtk_text_iter_starts_tag, pl_bu);
+ Xg_define_procedure(gdk_device_get_seat, gxg_gdk_device_get_seat_w, 1, 0, 0, H_gdk_device_get_seat, pl_pu);
+ Xg_define_procedure(gdk_display_get_default_seat, gxg_gdk_display_get_default_seat_w, 1, 0, 0, H_gdk_display_get_default_seat, pl_pu);
+ Xg_define_procedure(gdk_display_list_seats, gxg_gdk_display_list_seats_w, 1, 0, 0, H_gdk_display_list_seats, pl_pu);
+ Xg_define_procedure(gdk_drag_begin_from_point, gxg_gdk_drag_begin_from_point_w, 5, 0, 0, H_gdk_drag_begin_from_point, pl_puuui);
+ Xg_define_procedure(gdk_drag_drop_done, gxg_gdk_drag_drop_done_w, 2, 0, 0, H_gdk_drag_drop_done, pl_tub);
+ Xg_define_procedure(gdk_drag_context_set_hotspot, gxg_gdk_drag_context_set_hotspot_w, 3, 0, 0, H_gdk_drag_context_set_hotspot, pl_tui);
+ Xg_define_procedure(gdk_seat_grab, gxg_gdk_seat_grab_w, 0, 0, 1, H_gdk_seat_grab, pl_guugbut);
+ Xg_define_procedure(gdk_seat_ungrab, gxg_gdk_seat_ungrab_w, 1, 0, 0, H_gdk_seat_ungrab, pl_tu);
+ Xg_define_procedure(gdk_seat_get_display, gxg_gdk_seat_get_display_w, 1, 0, 0, H_gdk_seat_get_display, pl_pu);
+ Xg_define_procedure(gdk_seat_get_capabilities, gxg_gdk_seat_get_capabilities_w, 1, 0, 0, H_gdk_seat_get_capabilities, pl_gu);
+ Xg_define_procedure(gdk_seat_get_slaves, gxg_gdk_seat_get_slaves_w, 2, 0, 0, H_gdk_seat_get_slaves, pl_pug);
+ Xg_define_procedure(gdk_seat_get_pointer, gxg_gdk_seat_get_pointer_w, 1, 0, 0, H_gdk_seat_get_pointer, pl_pu);
+ Xg_define_procedure(gdk_seat_get_keyboard, gxg_gdk_seat_get_keyboard_w, 1, 0, 0, H_gdk_seat_get_keyboard, pl_pu);
+ Xg_define_procedure(gdk_drag_context_manage_dnd, gxg_gdk_drag_context_manage_dnd_w, 3, 0, 0, H_gdk_drag_context_manage_dnd, pl_buug);
+ Xg_define_procedure(gdk_event_is_scroll_stop_event, gxg_gdk_event_is_scroll_stop_event_w, 1, 0, 0, H_gdk_event_is_scroll_stop_event, pl_bu);
+ Xg_define_procedure(gtk_text_view_reset_cursor_blink, gxg_gtk_text_view_reset_cursor_blink_w, 1, 0, 0, H_gtk_text_view_reset_cursor_blink, pl_tu);
+ Xg_define_procedure(gtk_render_background_get_clip, gxg_gtk_render_background_get_clip_w, 5, 1, 0, H_gtk_render_background_get_clip, pl_turrrru);
+ Xg_define_procedure(gtk_text_layout_get_iter_at_pixel, gxg_gtk_text_layout_get_iter_at_pixel_w, 4, 0, 0, H_gtk_text_layout_get_iter_at_pixel, pl_buui);
+ Xg_define_procedure(gtk_text_layout_get_iter_at_position, gxg_gtk_text_layout_get_iter_at_position_w, 4, 1, 0, H_gtk_text_layout_get_iter_at_position, pl_buuui);
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+ Xg_define_procedure(gdk_device_get_axes, gxg_gdk_device_get_axes_w, 1, 0, 0, H_gdk_device_get_axes, pl_gu);
+ Xg_define_procedure(gdk_event_get_device_tool, gxg_gdk_event_get_device_tool_w, 1, 0, 0, H_gdk_event_get_device_tool, pl_pu);
+ Xg_define_procedure(gdk_event_set_device_tool, gxg_gdk_event_set_device_tool_w, 2, 0, 0, H_gdk_event_set_device_tool, pl_tu);
+ Xg_define_procedure(gdk_event_get_scancode, gxg_gdk_event_get_scancode_w, 1, 0, 0, H_gdk_event_get_scancode, pl_iu);
+ Xg_define_procedure(gdk_gl_context_set_use_es, gxg_gdk_gl_context_set_use_es_w, 2, 0, 0, H_gdk_gl_context_set_use_es, pl_tub);
+ Xg_define_procedure(gdk_gl_context_get_use_es, gxg_gdk_gl_context_get_use_es_w, 1, 0, 0, H_gdk_gl_context_get_use_es, pl_bu);
+ Xg_define_procedure(gdk_pango_context_get_for_display, gxg_gdk_pango_context_get_for_display_w, 1, 0, 0, H_gdk_pango_context_get_for_display, pl_pu);
+ Xg_define_procedure(gtk_clipboard_get_selection, gxg_gtk_clipboard_get_selection_w, 1, 0, 0, H_gtk_clipboard_get_selection, pl_tu);
+ Xg_define_procedure(gtk_gl_area_set_use_es, gxg_gtk_gl_area_set_use_es_w, 2, 0, 0, H_gtk_gl_area_set_use_es, pl_tub);
+ Xg_define_procedure(gtk_gl_area_get_use_es, gxg_gtk_gl_area_get_use_es_w, 1, 0, 0, H_gtk_gl_area_get_use_es, pl_bu);
+ Xg_define_procedure(gdk_device_tool_get_serial, gxg_gdk_device_tool_get_serial_w, 1, 0, 0, H_gdk_device_tool_get_serial, pl_iu);
#endif
Xg_define_procedure(cairo_create, gxg_cairo_create_w, 1, 0, 0, H_cairo_create, pl_pu);
@@ -43092,20 +43543,20 @@ pl_unused = NULL;
Xg_define_procedure(cairo_save, gxg_cairo_save_w, 1, 0, 0, H_cairo_save, pl_tu);
Xg_define_procedure(cairo_restore, gxg_cairo_restore_w, 1, 0, 0, H_cairo_restore, pl_tu);
Xg_define_procedure(cairo_push_group, gxg_cairo_push_group_w, 1, 0, 0, H_cairo_push_group, pl_tu);
- Xg_define_procedure(cairo_push_group_with_content, gxg_cairo_push_group_with_content_w, 2, 0, 0, H_cairo_push_group_with_content, pl_tui);
+ Xg_define_procedure(cairo_push_group_with_content, gxg_cairo_push_group_with_content_w, 2, 0, 0, H_cairo_push_group_with_content, pl_tug);
Xg_define_procedure(cairo_pop_group, gxg_cairo_pop_group_w, 1, 0, 0, H_cairo_pop_group, pl_pu);
Xg_define_procedure(cairo_pop_group_to_source, gxg_cairo_pop_group_to_source_w, 1, 0, 0, H_cairo_pop_group_to_source, pl_tu);
- Xg_define_procedure(cairo_set_operator, gxg_cairo_set_operator_w, 2, 0, 0, H_cairo_set_operator, pl_tui);
+ Xg_define_procedure(cairo_set_operator, gxg_cairo_set_operator_w, 2, 0, 0, H_cairo_set_operator, pl_tug);
Xg_define_procedure(cairo_set_source, gxg_cairo_set_source_w, 2, 0, 0, H_cairo_set_source, pl_tu);
Xg_define_procedure(cairo_set_source_rgb, gxg_cairo_set_source_rgb_w, 4, 0, 0, H_cairo_set_source_rgb, pl_tur);
Xg_define_procedure(cairo_set_source_rgba, gxg_cairo_set_source_rgba_w, 5, 0, 0, H_cairo_set_source_rgba, pl_tur);
Xg_define_procedure(cairo_set_source_surface, gxg_cairo_set_source_surface_w, 4, 0, 0, H_cairo_set_source_surface, pl_tuur);
Xg_define_procedure(cairo_set_tolerance, gxg_cairo_set_tolerance_w, 2, 0, 0, H_cairo_set_tolerance, pl_tur);
- Xg_define_procedure(cairo_set_antialias, gxg_cairo_set_antialias_w, 2, 0, 0, H_cairo_set_antialias, pl_tui);
- Xg_define_procedure(cairo_set_fill_rule, gxg_cairo_set_fill_rule_w, 2, 0, 0, H_cairo_set_fill_rule, pl_tui);
+ Xg_define_procedure(cairo_set_antialias, gxg_cairo_set_antialias_w, 2, 0, 0, H_cairo_set_antialias, pl_tug);
+ Xg_define_procedure(cairo_set_fill_rule, gxg_cairo_set_fill_rule_w, 2, 0, 0, H_cairo_set_fill_rule, pl_tug);
Xg_define_procedure(cairo_set_line_width, gxg_cairo_set_line_width_w, 2, 0, 0, H_cairo_set_line_width, pl_tur);
- Xg_define_procedure(cairo_set_line_cap, gxg_cairo_set_line_cap_w, 2, 0, 0, H_cairo_set_line_cap, pl_tui);
- Xg_define_procedure(cairo_set_line_join, gxg_cairo_set_line_join_w, 2, 0, 0, H_cairo_set_line_join, pl_tui);
+ Xg_define_procedure(cairo_set_line_cap, gxg_cairo_set_line_cap_w, 2, 0, 0, H_cairo_set_line_cap, pl_tug);
+ Xg_define_procedure(cairo_set_line_join, gxg_cairo_set_line_join_w, 2, 0, 0, H_cairo_set_line_join, pl_tug);
Xg_define_procedure(cairo_set_dash, gxg_cairo_set_dash_w, 4, 0, 0, H_cairo_set_dash, pl_tuuir);
Xg_define_procedure(cairo_set_miter_limit, gxg_cairo_set_miter_limit_w, 2, 0, 0, H_cairo_set_miter_limit, pl_tur);
Xg_define_procedure(cairo_translate, gxg_cairo_translate_w, 3, 0, 0, H_cairo_translate, pl_tur);
@@ -43148,19 +43599,19 @@ pl_unused = NULL;
Xg_define_procedure(cairo_font_options_create, gxg_cairo_font_options_create_w, 0, 0, 0, H_cairo_font_options_create, pl_p);
Xg_define_procedure(cairo_font_options_copy, gxg_cairo_font_options_copy_w, 1, 0, 0, H_cairo_font_options_copy, pl_pu);
Xg_define_procedure(cairo_font_options_destroy, gxg_cairo_font_options_destroy_w, 1, 0, 0, H_cairo_font_options_destroy, pl_tu);
- Xg_define_procedure(cairo_font_options_status, gxg_cairo_font_options_status_w, 1, 0, 0, H_cairo_font_options_status, pl_iu);
+ Xg_define_procedure(cairo_font_options_status, gxg_cairo_font_options_status_w, 1, 0, 0, H_cairo_font_options_status, pl_gu);
Xg_define_procedure(cairo_font_options_merge, gxg_cairo_font_options_merge_w, 2, 0, 0, H_cairo_font_options_merge, pl_tu);
Xg_define_procedure(cairo_font_options_equal, gxg_cairo_font_options_equal_w, 2, 0, 0, H_cairo_font_options_equal, pl_bu);
Xg_define_procedure(cairo_font_options_hash, gxg_cairo_font_options_hash_w, 1, 0, 0, H_cairo_font_options_hash, pl_iu);
- Xg_define_procedure(cairo_font_options_set_antialias, gxg_cairo_font_options_set_antialias_w, 2, 0, 0, H_cairo_font_options_set_antialias, pl_tui);
- Xg_define_procedure(cairo_font_options_get_antialias, gxg_cairo_font_options_get_antialias_w, 1, 0, 0, H_cairo_font_options_get_antialias, pl_iu);
- Xg_define_procedure(cairo_font_options_set_subpixel_order, gxg_cairo_font_options_set_subpixel_order_w, 2, 0, 0, H_cairo_font_options_set_subpixel_order, pl_tui);
- Xg_define_procedure(cairo_font_options_get_subpixel_order, gxg_cairo_font_options_get_subpixel_order_w, 1, 0, 0, H_cairo_font_options_get_subpixel_order, pl_iu);
- Xg_define_procedure(cairo_font_options_set_hint_style, gxg_cairo_font_options_set_hint_style_w, 2, 0, 0, H_cairo_font_options_set_hint_style, pl_tui);
- Xg_define_procedure(cairo_font_options_get_hint_style, gxg_cairo_font_options_get_hint_style_w, 1, 0, 0, H_cairo_font_options_get_hint_style, pl_iu);
- Xg_define_procedure(cairo_font_options_set_hint_metrics, gxg_cairo_font_options_set_hint_metrics_w, 2, 0, 0, H_cairo_font_options_set_hint_metrics, pl_tui);
- Xg_define_procedure(cairo_font_options_get_hint_metrics, gxg_cairo_font_options_get_hint_metrics_w, 1, 0, 0, H_cairo_font_options_get_hint_metrics, pl_iu);
- Xg_define_procedure(cairo_select_font_face, gxg_cairo_select_font_face_w, 4, 0, 0, H_cairo_select_font_face, pl_tusi);
+ Xg_define_procedure(cairo_font_options_set_antialias, gxg_cairo_font_options_set_antialias_w, 2, 0, 0, H_cairo_font_options_set_antialias, pl_tug);
+ Xg_define_procedure(cairo_font_options_get_antialias, gxg_cairo_font_options_get_antialias_w, 1, 0, 0, H_cairo_font_options_get_antialias, pl_gu);
+ Xg_define_procedure(cairo_font_options_set_subpixel_order, gxg_cairo_font_options_set_subpixel_order_w, 2, 0, 0, H_cairo_font_options_set_subpixel_order, pl_tug);
+ Xg_define_procedure(cairo_font_options_get_subpixel_order, gxg_cairo_font_options_get_subpixel_order_w, 1, 0, 0, H_cairo_font_options_get_subpixel_order, pl_gu);
+ Xg_define_procedure(cairo_font_options_set_hint_style, gxg_cairo_font_options_set_hint_style_w, 2, 0, 0, H_cairo_font_options_set_hint_style, pl_tug);
+ Xg_define_procedure(cairo_font_options_get_hint_style, gxg_cairo_font_options_get_hint_style_w, 1, 0, 0, H_cairo_font_options_get_hint_style, pl_gu);
+ Xg_define_procedure(cairo_font_options_set_hint_metrics, gxg_cairo_font_options_set_hint_metrics_w, 2, 0, 0, H_cairo_font_options_set_hint_metrics, pl_tug);
+ Xg_define_procedure(cairo_font_options_get_hint_metrics, gxg_cairo_font_options_get_hint_metrics_w, 1, 0, 0, H_cairo_font_options_get_hint_metrics, pl_gu);
+ Xg_define_procedure(cairo_select_font_face, gxg_cairo_select_font_face_w, 4, 0, 0, H_cairo_select_font_face, pl_tusg);
Xg_define_procedure(cairo_set_font_size, gxg_cairo_set_font_size_w, 2, 0, 0, H_cairo_set_font_size, pl_tur);
Xg_define_procedure(cairo_set_font_matrix, gxg_cairo_set_font_matrix_w, 2, 0, 0, H_cairo_set_font_matrix, pl_tu);
Xg_define_procedure(cairo_get_font_matrix, gxg_cairo_get_font_matrix_w, 2, 0, 0, H_cairo_get_font_matrix, pl_tu);
@@ -43178,13 +43629,13 @@ pl_unused = NULL;
Xg_define_procedure(cairo_glyph_path, gxg_cairo_glyph_path_w, 3, 0, 0, H_cairo_glyph_path, pl_tuui);
Xg_define_procedure(cairo_font_face_reference, gxg_cairo_font_face_reference_w, 1, 0, 0, H_cairo_font_face_reference, pl_pu);
Xg_define_procedure(cairo_font_face_destroy, gxg_cairo_font_face_destroy_w, 1, 0, 0, H_cairo_font_face_destroy, pl_tu);
- Xg_define_procedure(cairo_font_face_status, gxg_cairo_font_face_status_w, 1, 0, 0, H_cairo_font_face_status, pl_iu);
+ Xg_define_procedure(cairo_font_face_status, gxg_cairo_font_face_status_w, 1, 0, 0, H_cairo_font_face_status, pl_gu);
Xg_define_procedure(cairo_font_face_get_user_data, gxg_cairo_font_face_get_user_data_w, 2, 0, 0, H_cairo_font_face_get_user_data, pl_tu);
- Xg_define_procedure(cairo_font_face_set_user_data, gxg_cairo_font_face_set_user_data_w, 4, 0, 0, H_cairo_font_face_set_user_data, pl_iuut);
+ Xg_define_procedure(cairo_font_face_set_user_data, gxg_cairo_font_face_set_user_data_w, 4, 0, 0, H_cairo_font_face_set_user_data, pl_guut);
Xg_define_procedure(cairo_scaled_font_create, gxg_cairo_scaled_font_create_w, 4, 0, 0, H_cairo_scaled_font_create, pl_pu);
Xg_define_procedure(cairo_scaled_font_reference, gxg_cairo_scaled_font_reference_w, 1, 0, 0, H_cairo_scaled_font_reference, pl_pu);
Xg_define_procedure(cairo_scaled_font_destroy, gxg_cairo_scaled_font_destroy_w, 1, 0, 0, H_cairo_scaled_font_destroy, pl_tu);
- Xg_define_procedure(cairo_scaled_font_status, gxg_cairo_scaled_font_status_w, 1, 0, 0, H_cairo_scaled_font_status, pl_iu);
+ Xg_define_procedure(cairo_scaled_font_status, gxg_cairo_scaled_font_status_w, 1, 0, 0, H_cairo_scaled_font_status, pl_gu);
Xg_define_procedure(cairo_scaled_font_extents, gxg_cairo_scaled_font_extents_w, 2, 0, 0, H_cairo_scaled_font_extents, pl_tu);
Xg_define_procedure(cairo_scaled_font_text_extents, gxg_cairo_scaled_font_text_extents_w, 3, 0, 0, H_cairo_scaled_font_text_extents, pl_tusu);
Xg_define_procedure(cairo_scaled_font_glyph_extents, gxg_cairo_scaled_font_glyph_extents_w, 4, 0, 0, H_cairo_scaled_font_glyph_extents, pl_tuuiu);
@@ -43192,15 +43643,15 @@ pl_unused = NULL;
Xg_define_procedure(cairo_scaled_font_get_font_matrix, gxg_cairo_scaled_font_get_font_matrix_w, 2, 0, 0, H_cairo_scaled_font_get_font_matrix, pl_tu);
Xg_define_procedure(cairo_scaled_font_get_ctm, gxg_cairo_scaled_font_get_ctm_w, 2, 0, 0, H_cairo_scaled_font_get_ctm, pl_tu);
Xg_define_procedure(cairo_scaled_font_get_font_options, gxg_cairo_scaled_font_get_font_options_w, 2, 0, 0, H_cairo_scaled_font_get_font_options, pl_tu);
- Xg_define_procedure(cairo_get_operator, gxg_cairo_get_operator_w, 1, 0, 0, H_cairo_get_operator, pl_iu);
+ Xg_define_procedure(cairo_get_operator, gxg_cairo_get_operator_w, 1, 0, 0, H_cairo_get_operator, pl_gu);
Xg_define_procedure(cairo_get_source, gxg_cairo_get_source_w, 1, 0, 0, H_cairo_get_source, pl_pu);
Xg_define_procedure(cairo_get_tolerance, gxg_cairo_get_tolerance_w, 1, 0, 0, H_cairo_get_tolerance, pl_du);
- Xg_define_procedure(cairo_get_antialias, gxg_cairo_get_antialias_w, 1, 0, 0, H_cairo_get_antialias, pl_iu);
+ Xg_define_procedure(cairo_get_antialias, gxg_cairo_get_antialias_w, 1, 0, 0, H_cairo_get_antialias, pl_gu);
Xg_define_procedure(cairo_get_current_point, gxg_cairo_get_current_point_w, 1, 2, 0, H_cairo_get_current_point, pl_tu);
- Xg_define_procedure(cairo_get_fill_rule, gxg_cairo_get_fill_rule_w, 1, 0, 0, H_cairo_get_fill_rule, pl_iu);
+ Xg_define_procedure(cairo_get_fill_rule, gxg_cairo_get_fill_rule_w, 1, 0, 0, H_cairo_get_fill_rule, pl_gu);
Xg_define_procedure(cairo_get_line_width, gxg_cairo_get_line_width_w, 1, 0, 0, H_cairo_get_line_width, pl_du);
- Xg_define_procedure(cairo_get_line_cap, gxg_cairo_get_line_cap_w, 1, 0, 0, H_cairo_get_line_cap, pl_iu);
- Xg_define_procedure(cairo_get_line_join, gxg_cairo_get_line_join_w, 1, 0, 0, H_cairo_get_line_join, pl_iu);
+ Xg_define_procedure(cairo_get_line_cap, gxg_cairo_get_line_cap_w, 1, 0, 0, H_cairo_get_line_cap, pl_gu);
+ Xg_define_procedure(cairo_get_line_join, gxg_cairo_get_line_join_w, 1, 0, 0, H_cairo_get_line_join, pl_gu);
Xg_define_procedure(cairo_get_miter_limit, gxg_cairo_get_miter_limit_w, 1, 0, 0, H_cairo_get_miter_limit, pl_du);
Xg_define_procedure(cairo_get_matrix, gxg_cairo_get_matrix_w, 2, 0, 0, H_cairo_get_matrix, pl_tu);
Xg_define_procedure(cairo_get_target, gxg_cairo_get_target_w, 1, 0, 0, H_cairo_get_target, pl_pu);
@@ -43209,16 +43660,16 @@ pl_unused = NULL;
Xg_define_procedure(cairo_copy_path_flat, gxg_cairo_copy_path_flat_w, 1, 0, 0, H_cairo_copy_path_flat, pl_pu);
Xg_define_procedure(cairo_append_path, gxg_cairo_append_path_w, 2, 0, 0, H_cairo_append_path, pl_tu);
Xg_define_procedure(cairo_path_destroy, gxg_cairo_path_destroy_w, 1, 0, 0, H_cairo_path_destroy, pl_tu);
- Xg_define_procedure(cairo_status, gxg_cairo_status_w, 1, 0, 0, H_cairo_status, pl_iu);
- Xg_define_procedure(cairo_status_to_string, gxg_cairo_status_to_string_w, 1, 0, 0, H_cairo_status_to_string, pl_si);
- Xg_define_procedure(cairo_surface_create_similar, gxg_cairo_surface_create_similar_w, 4, 0, 0, H_cairo_surface_create_similar, pl_pui);
+ Xg_define_procedure(cairo_status, gxg_cairo_status_w, 1, 0, 0, H_cairo_status, pl_gu);
+ Xg_define_procedure(cairo_status_to_string, gxg_cairo_status_to_string_w, 1, 0, 0, H_cairo_status_to_string, pl_sg);
+ Xg_define_procedure(cairo_surface_create_similar, gxg_cairo_surface_create_similar_w, 4, 0, 0, H_cairo_surface_create_similar, pl_pugi);
Xg_define_procedure(cairo_surface_reference, gxg_cairo_surface_reference_w, 1, 0, 0, H_cairo_surface_reference, pl_pu);
Xg_define_procedure(cairo_surface_finish, gxg_cairo_surface_finish_w, 1, 0, 0, H_cairo_surface_finish, pl_tu);
Xg_define_procedure(cairo_surface_destroy, gxg_cairo_surface_destroy_w, 1, 0, 0, H_cairo_surface_destroy, pl_tu);
- Xg_define_procedure(cairo_surface_status, gxg_cairo_surface_status_w, 1, 0, 0, H_cairo_surface_status, pl_iu);
- Xg_define_procedure(cairo_surface_get_content, gxg_cairo_surface_get_content_w, 1, 0, 0, H_cairo_surface_get_content, pl_iu);
+ Xg_define_procedure(cairo_surface_status, gxg_cairo_surface_status_w, 1, 0, 0, H_cairo_surface_status, pl_gu);
+ Xg_define_procedure(cairo_surface_get_content, gxg_cairo_surface_get_content_w, 1, 0, 0, H_cairo_surface_get_content, pl_gu);
Xg_define_procedure(cairo_surface_get_user_data, gxg_cairo_surface_get_user_data_w, 2, 0, 0, H_cairo_surface_get_user_data, pl_tu);
- Xg_define_procedure(cairo_surface_set_user_data, gxg_cairo_surface_set_user_data_w, 4, 0, 0, H_cairo_surface_set_user_data, pl_iuut);
+ Xg_define_procedure(cairo_surface_set_user_data, gxg_cairo_surface_set_user_data_w, 4, 0, 0, H_cairo_surface_set_user_data, pl_guut);
Xg_define_procedure(cairo_surface_get_font_options, gxg_cairo_surface_get_font_options_w, 2, 0, 0, H_cairo_surface_get_font_options, pl_tu);
Xg_define_procedure(cairo_surface_flush, gxg_cairo_surface_flush_w, 1, 0, 0, H_cairo_surface_flush, pl_tu);
Xg_define_procedure(cairo_surface_mark_dirty, gxg_cairo_surface_mark_dirty_w, 1, 0, 0, H_cairo_surface_mark_dirty, pl_tu);
@@ -43226,10 +43677,10 @@ pl_unused = NULL;
Xg_define_procedure(cairo_surface_set_device_offset, gxg_cairo_surface_set_device_offset_w, 3, 0, 0, H_cairo_surface_set_device_offset, pl_tur);
Xg_define_procedure(cairo_surface_get_device_offset, gxg_cairo_surface_get_device_offset_w, 1, 2, 0, H_cairo_surface_get_device_offset, pl_tu);
Xg_define_procedure(cairo_surface_set_fallback_resolution, gxg_cairo_surface_set_fallback_resolution_w, 3, 0, 0, H_cairo_surface_set_fallback_resolution, pl_tur);
- Xg_define_procedure(cairo_image_surface_create, gxg_cairo_image_surface_create_w, 3, 0, 0, H_cairo_image_surface_create, pl_pi);
- Xg_define_procedure(cairo_image_surface_create_for_data, gxg_cairo_image_surface_create_for_data_w, 5, 0, 0, H_cairo_image_surface_create_for_data, pl_psi);
+ Xg_define_procedure(cairo_image_surface_create, gxg_cairo_image_surface_create_w, 3, 0, 0, H_cairo_image_surface_create, pl_pgi);
+ Xg_define_procedure(cairo_image_surface_create_for_data, gxg_cairo_image_surface_create_for_data_w, 5, 0, 0, H_cairo_image_surface_create_for_data, pl_psgi);
Xg_define_procedure(cairo_image_surface_get_data, gxg_cairo_image_surface_get_data_w, 1, 0, 0, H_cairo_image_surface_get_data, pl_su);
- Xg_define_procedure(cairo_image_surface_get_format, gxg_cairo_image_surface_get_format_w, 1, 0, 0, H_cairo_image_surface_get_format, pl_iu);
+ Xg_define_procedure(cairo_image_surface_get_format, gxg_cairo_image_surface_get_format_w, 1, 0, 0, H_cairo_image_surface_get_format, pl_gu);
Xg_define_procedure(cairo_image_surface_get_width, gxg_cairo_image_surface_get_width_w, 1, 0, 0, H_cairo_image_surface_get_width, pl_iu);
Xg_define_procedure(cairo_image_surface_get_height, gxg_cairo_image_surface_get_height_w, 1, 0, 0, H_cairo_image_surface_get_height, pl_iu);
Xg_define_procedure(cairo_image_surface_get_stride, gxg_cairo_image_surface_get_stride_w, 1, 0, 0, H_cairo_image_surface_get_stride, pl_iu);
@@ -43240,15 +43691,15 @@ pl_unused = NULL;
Xg_define_procedure(cairo_pattern_create_radial, gxg_cairo_pattern_create_radial_w, 6, 0, 0, H_cairo_pattern_create_radial, pl_pr);
Xg_define_procedure(cairo_pattern_reference, gxg_cairo_pattern_reference_w, 1, 0, 0, H_cairo_pattern_reference, pl_pu);
Xg_define_procedure(cairo_pattern_destroy, gxg_cairo_pattern_destroy_w, 1, 0, 0, H_cairo_pattern_destroy, pl_tu);
- Xg_define_procedure(cairo_pattern_status, gxg_cairo_pattern_status_w, 1, 0, 0, H_cairo_pattern_status, pl_iu);
+ Xg_define_procedure(cairo_pattern_status, gxg_cairo_pattern_status_w, 1, 0, 0, H_cairo_pattern_status, pl_gu);
Xg_define_procedure(cairo_pattern_add_color_stop_rgb, gxg_cairo_pattern_add_color_stop_rgb_w, 5, 0, 0, H_cairo_pattern_add_color_stop_rgb, pl_tur);
Xg_define_procedure(cairo_pattern_add_color_stop_rgba, gxg_cairo_pattern_add_color_stop_rgba_w, 6, 0, 0, H_cairo_pattern_add_color_stop_rgba, pl_tur);
Xg_define_procedure(cairo_pattern_set_matrix, gxg_cairo_pattern_set_matrix_w, 2, 0, 0, H_cairo_pattern_set_matrix, pl_tu);
Xg_define_procedure(cairo_pattern_get_matrix, gxg_cairo_pattern_get_matrix_w, 2, 0, 0, H_cairo_pattern_get_matrix, pl_tu);
- Xg_define_procedure(cairo_pattern_set_extend, gxg_cairo_pattern_set_extend_w, 2, 0, 0, H_cairo_pattern_set_extend, pl_tui);
- Xg_define_procedure(cairo_pattern_get_extend, gxg_cairo_pattern_get_extend_w, 1, 0, 0, H_cairo_pattern_get_extend, pl_iu);
- Xg_define_procedure(cairo_pattern_set_filter, gxg_cairo_pattern_set_filter_w, 2, 0, 0, H_cairo_pattern_set_filter, pl_tui);
- Xg_define_procedure(cairo_pattern_get_filter, gxg_cairo_pattern_get_filter_w, 1, 0, 0, H_cairo_pattern_get_filter, pl_iu);
+ Xg_define_procedure(cairo_pattern_set_extend, gxg_cairo_pattern_set_extend_w, 2, 0, 0, H_cairo_pattern_set_extend, pl_tug);
+ Xg_define_procedure(cairo_pattern_get_extend, gxg_cairo_pattern_get_extend_w, 1, 0, 0, H_cairo_pattern_get_extend, pl_gu);
+ Xg_define_procedure(cairo_pattern_set_filter, gxg_cairo_pattern_set_filter_w, 2, 0, 0, H_cairo_pattern_set_filter, pl_tug);
+ Xg_define_procedure(cairo_pattern_get_filter, gxg_cairo_pattern_get_filter_w, 1, 0, 0, H_cairo_pattern_get_filter, pl_gu);
Xg_define_procedure(cairo_matrix_init, gxg_cairo_matrix_init_w, 7, 0, 0, H_cairo_matrix_init, pl_tur);
Xg_define_procedure(cairo_matrix_init_identity, gxg_cairo_matrix_init_identity_w, 1, 0, 0, H_cairo_matrix_init_identity, pl_tu);
Xg_define_procedure(cairo_matrix_init_translate, gxg_cairo_matrix_init_translate_w, 3, 0, 0, H_cairo_matrix_init_translate, pl_tur);
@@ -43257,52 +43708,52 @@ pl_unused = NULL;
Xg_define_procedure(cairo_matrix_translate, gxg_cairo_matrix_translate_w, 3, 0, 0, H_cairo_matrix_translate, pl_tur);
Xg_define_procedure(cairo_matrix_scale, gxg_cairo_matrix_scale_w, 3, 0, 0, H_cairo_matrix_scale, pl_tur);
Xg_define_procedure(cairo_matrix_rotate, gxg_cairo_matrix_rotate_w, 2, 0, 0, H_cairo_matrix_rotate, pl_tur);
- Xg_define_procedure(cairo_matrix_invert, gxg_cairo_matrix_invert_w, 1, 0, 0, H_cairo_matrix_invert, pl_iu);
+ Xg_define_procedure(cairo_matrix_invert, gxg_cairo_matrix_invert_w, 1, 0, 0, H_cairo_matrix_invert, pl_gu);
Xg_define_procedure(cairo_matrix_multiply, gxg_cairo_matrix_multiply_w, 3, 0, 0, H_cairo_matrix_multiply, pl_tu);
Xg_define_procedure(cairo_matrix_transform_distance, gxg_cairo_matrix_transform_distance_w, 1, 2, 0, H_cairo_matrix_transform_distance, pl_tu);
Xg_define_procedure(cairo_matrix_transform_point, gxg_cairo_matrix_transform_point_w, 1, 2, 0, H_cairo_matrix_transform_point, pl_tu);
Xg_define_procedure(cairo_get_reference_count, gxg_cairo_get_reference_count_w, 1, 0, 0, H_cairo_get_reference_count, pl_iu);
Xg_define_procedure(cairo_get_user_data, gxg_cairo_get_user_data_w, 2, 0, 0, H_cairo_get_user_data, pl_pu);
- Xg_define_procedure(cairo_set_user_data, gxg_cairo_set_user_data_w, 4, 0, 0, H_cairo_set_user_data, pl_iuuut);
+ Xg_define_procedure(cairo_set_user_data, gxg_cairo_set_user_data_w, 4, 0, 0, H_cairo_set_user_data, pl_guuut);
Xg_define_procedure(cairo_clip_extents, gxg_cairo_clip_extents_w, 1, 4, 0, H_cairo_clip_extents, pl_tu);
Xg_define_procedure(cairo_copy_clip_rectangle_list, gxg_cairo_copy_clip_rectangle_list_w, 1, 0, 0, H_cairo_copy_clip_rectangle_list, pl_pu);
Xg_define_procedure(cairo_rectangle_list_destroy, gxg_cairo_rectangle_list_destroy_w, 1, 0, 0, H_cairo_rectangle_list_destroy, pl_tu);
Xg_define_procedure(cairo_font_face_get_reference_count, gxg_cairo_font_face_get_reference_count_w, 1, 0, 0, H_cairo_font_face_get_reference_count, pl_iu);
Xg_define_procedure(cairo_scaled_font_get_reference_count, gxg_cairo_scaled_font_get_reference_count_w, 1, 0, 0, H_cairo_scaled_font_get_reference_count, pl_iu);
Xg_define_procedure(cairo_scaled_font_get_user_data, gxg_cairo_scaled_font_get_user_data_w, 2, 0, 0, H_cairo_scaled_font_get_user_data, pl_pu);
- Xg_define_procedure(cairo_scaled_font_set_user_data, gxg_cairo_scaled_font_set_user_data_w, 4, 0, 0, H_cairo_scaled_font_set_user_data, pl_iuuut);
+ Xg_define_procedure(cairo_scaled_font_set_user_data, gxg_cairo_scaled_font_set_user_data_w, 4, 0, 0, H_cairo_scaled_font_set_user_data, pl_guuut);
Xg_define_procedure(cairo_get_dash_count, gxg_cairo_get_dash_count_w, 1, 0, 0, H_cairo_get_dash_count, pl_iu);
Xg_define_procedure(cairo_get_dash, gxg_cairo_get_dash_w, 1, 2, 0, H_cairo_get_dash, pl_tu);
Xg_define_procedure(cairo_surface_get_reference_count, gxg_cairo_surface_get_reference_count_w, 1, 0, 0, H_cairo_surface_get_reference_count, pl_iu);
Xg_define_procedure(cairo_pattern_get_reference_count, gxg_cairo_pattern_get_reference_count_w, 1, 0, 0, H_cairo_pattern_get_reference_count, pl_iu);
Xg_define_procedure(cairo_pattern_get_user_data, gxg_cairo_pattern_get_user_data_w, 2, 0, 0, H_cairo_pattern_get_user_data, pl_pu);
- Xg_define_procedure(cairo_pattern_set_user_data, gxg_cairo_pattern_set_user_data_w, 4, 0, 0, H_cairo_pattern_set_user_data, pl_iuuut);
- Xg_define_procedure(cairo_pattern_get_rgba, gxg_cairo_pattern_get_rgba_w, 1, 4, 0, H_cairo_pattern_get_rgba, pl_iu);
- Xg_define_procedure(cairo_pattern_get_surface, gxg_cairo_pattern_get_surface_w, 1, 1, 0, H_cairo_pattern_get_surface, pl_iu);
- Xg_define_procedure(cairo_pattern_get_color_stop_rgba, gxg_cairo_pattern_get_color_stop_rgba_w, 2, 5, 0, H_cairo_pattern_get_color_stop_rgba, pl_iuiu);
- Xg_define_procedure(cairo_pattern_get_color_stop_count, gxg_cairo_pattern_get_color_stop_count_w, 1, 1, 0, H_cairo_pattern_get_color_stop_count, pl_iu);
- Xg_define_procedure(cairo_pattern_get_linear_points, gxg_cairo_pattern_get_linear_points_w, 1, 4, 0, H_cairo_pattern_get_linear_points, pl_iu);
- Xg_define_procedure(cairo_pattern_get_radial_circles, gxg_cairo_pattern_get_radial_circles_w, 1, 6, 0, H_cairo_pattern_get_radial_circles, pl_iu);
+ Xg_define_procedure(cairo_pattern_set_user_data, gxg_cairo_pattern_set_user_data_w, 4, 0, 0, H_cairo_pattern_set_user_data, pl_guuut);
+ Xg_define_procedure(cairo_pattern_get_rgba, gxg_cairo_pattern_get_rgba_w, 1, 4, 0, H_cairo_pattern_get_rgba, pl_gu);
+ Xg_define_procedure(cairo_pattern_get_surface, gxg_cairo_pattern_get_surface_w, 1, 1, 0, H_cairo_pattern_get_surface, pl_gu);
+ Xg_define_procedure(cairo_pattern_get_color_stop_rgba, gxg_cairo_pattern_get_color_stop_rgba_w, 2, 5, 0, H_cairo_pattern_get_color_stop_rgba, pl_guiu);
+ Xg_define_procedure(cairo_pattern_get_color_stop_count, gxg_cairo_pattern_get_color_stop_count_w, 1, 1, 0, H_cairo_pattern_get_color_stop_count, pl_gu);
+ Xg_define_procedure(cairo_pattern_get_linear_points, gxg_cairo_pattern_get_linear_points_w, 1, 4, 0, H_cairo_pattern_get_linear_points, pl_gu);
+ Xg_define_procedure(cairo_pattern_get_radial_circles, gxg_cairo_pattern_get_radial_circles_w, 1, 6, 0, H_cairo_pattern_get_radial_circles, pl_gu);
Xg_define_procedure(cairo_get_scaled_font, gxg_cairo_get_scaled_font_w, 1, 0, 0, H_cairo_get_scaled_font, pl_pu);
Xg_define_procedure(cairo_path_extents, gxg_cairo_path_extents_w, 1, 4, 0, H_cairo_path_extents, pl_tu);
Xg_define_procedure(cairo_has_current_point, gxg_cairo_has_current_point_w, 1, 0, 0, H_cairo_has_current_point, pl_bu);
Xg_define_procedure(cairo_surface_copy_page, gxg_cairo_surface_copy_page_w, 1, 0, 0, H_cairo_surface_copy_page, pl_tu);
Xg_define_procedure(cairo_surface_show_page, gxg_cairo_surface_show_page_w, 1, 0, 0, H_cairo_surface_show_page, pl_tu);
- Xg_define_procedure(cairo_format_stride_for_width, gxg_cairo_format_stride_for_width_w, 2, 0, 0, H_cairo_format_stride_for_width, pl_i);
+ Xg_define_procedure(cairo_format_stride_for_width, gxg_cairo_format_stride_for_width_w, 2, 0, 0, H_cairo_format_stride_for_width, pl_igi);
Xg_define_procedure(cairo_image_surface_create_from_png, gxg_cairo_image_surface_create_from_png_w, 1, 0, 0, H_cairo_image_surface_create_from_png, pl_ps);
- Xg_define_procedure(cairo_surface_write_to_png, gxg_cairo_surface_write_to_png_w, 2, 0, 0, H_cairo_surface_write_to_png, pl_ius);
+ Xg_define_procedure(cairo_surface_write_to_png, gxg_cairo_surface_write_to_png_w, 2, 0, 0, H_cairo_surface_write_to_png, pl_gus);
#if HAVE_CAIRO_1_8
Xg_define_procedure(cairo_glyph_allocate, gxg_cairo_glyph_allocate_w, 1, 0, 0, H_cairo_glyph_allocate, pl_pi);
Xg_define_procedure(cairo_glyph_free, gxg_cairo_glyph_free_w, 1, 0, 0, H_cairo_glyph_free, pl_tu);
Xg_define_procedure(cairo_text_cluster_allocate, gxg_cairo_text_cluster_allocate_w, 1, 0, 0, H_cairo_text_cluster_allocate, pl_pi);
Xg_define_procedure(cairo_text_cluster_free, gxg_cairo_text_cluster_free_w, 1, 0, 0, H_cairo_text_cluster_free, pl_tu);
Xg_define_procedure(cairo_show_text_glyphs, gxg_cairo_show_text_glyphs_w, 0, 0, 1, H_cairo_show_text_glyphs, pl_tusiuiuit);
- Xg_define_procedure(cairo_scaled_font_text_to_glyphs, gxg_cairo_scaled_font_text_to_glyphs_w, 0, 0, 1, H_cairo_scaled_font_text_to_glyphs, pl_iurrsiu);
+ Xg_define_procedure(cairo_scaled_font_text_to_glyphs, gxg_cairo_scaled_font_text_to_glyphs_w, 0, 0, 1, H_cairo_scaled_font_text_to_glyphs, pl_gurrsiu);
Xg_define_procedure(cairo_scaled_font_get_scale_matrix, gxg_cairo_scaled_font_get_scale_matrix_w, 2, 0, 0, H_cairo_scaled_font_get_scale_matrix, pl_tu);
- Xg_define_procedure(cairo_toy_font_face_create, gxg_cairo_toy_font_face_create_w, 3, 0, 0, H_cairo_toy_font_face_create, pl_psi);
+ Xg_define_procedure(cairo_toy_font_face_create, gxg_cairo_toy_font_face_create_w, 3, 0, 0, H_cairo_toy_font_face_create, pl_psg);
Xg_define_procedure(cairo_toy_font_face_get_family, gxg_cairo_toy_font_face_get_family_w, 1, 0, 0, H_cairo_toy_font_face_get_family, pl_su);
- Xg_define_procedure(cairo_toy_font_face_get_slant, gxg_cairo_toy_font_face_get_slant_w, 1, 0, 0, H_cairo_toy_font_face_get_slant, pl_iu);
- Xg_define_procedure(cairo_toy_font_face_get_weight, gxg_cairo_toy_font_face_get_weight_w, 1, 0, 0, H_cairo_toy_font_face_get_weight, pl_iu);
+ Xg_define_procedure(cairo_toy_font_face_get_slant, gxg_cairo_toy_font_face_get_slant_w, 1, 0, 0, H_cairo_toy_font_face_get_slant, pl_gu);
+ Xg_define_procedure(cairo_toy_font_face_get_weight, gxg_cairo_toy_font_face_get_weight_w, 1, 0, 0, H_cairo_toy_font_face_get_weight, pl_gu);
Xg_define_procedure(cairo_user_font_face_create, gxg_cairo_user_font_face_create_w, 0, 0, 0, H_cairo_user_font_face_create, pl_p);
Xg_define_procedure(cairo_surface_get_fallback_resolution, gxg_cairo_surface_get_fallback_resolution_w, 1, 2, 0, H_cairo_surface_get_fallback_resolution, pl_tu);
Xg_define_procedure(cairo_surface_has_show_text_glyphs, gxg_cairo_surface_has_show_text_glyphs_w, 1, 0, 0, H_cairo_surface_has_show_text_glyphs, pl_iu);
@@ -43311,19 +43762,19 @@ pl_unused = NULL;
#if HAVE_CAIRO_1_9_12 && GTK_CHECK_VERSION(3, 0, 0)
Xg_define_procedure(cairo_in_clip, gxg_cairo_in_clip_w, 3, 0, 0, H_cairo_in_clip, pl_iur);
Xg_define_procedure(cairo_device_reference, gxg_cairo_device_reference_w, 1, 0, 0, H_cairo_device_reference, pl_pu);
- Xg_define_procedure(cairo_device_status, gxg_cairo_device_status_w, 1, 0, 0, H_cairo_device_status, pl_iu);
- Xg_define_procedure(cairo_device_acquire, gxg_cairo_device_acquire_w, 1, 0, 0, H_cairo_device_acquire, pl_iu);
+ Xg_define_procedure(cairo_device_status, gxg_cairo_device_status_w, 1, 0, 0, H_cairo_device_status, pl_gu);
+ Xg_define_procedure(cairo_device_acquire, gxg_cairo_device_acquire_w, 1, 0, 0, H_cairo_device_acquire, pl_gu);
Xg_define_procedure(cairo_device_release, gxg_cairo_device_release_w, 1, 0, 0, H_cairo_device_release, pl_tu);
Xg_define_procedure(cairo_device_flush, gxg_cairo_device_flush_w, 1, 0, 0, H_cairo_device_flush, pl_tu);
Xg_define_procedure(cairo_device_finish, gxg_cairo_device_finish_w, 1, 0, 0, H_cairo_device_finish, pl_tu);
Xg_define_procedure(cairo_device_destroy, gxg_cairo_device_destroy_w, 1, 0, 0, H_cairo_device_destroy, pl_tu);
Xg_define_procedure(cairo_device_get_reference_count, gxg_cairo_device_get_reference_count_w, 1, 0, 0, H_cairo_device_get_reference_count, pl_iu);
Xg_define_procedure(cairo_device_get_user_data, gxg_cairo_device_get_user_data_w, 2, 0, 0, H_cairo_device_get_user_data, pl_pu);
- Xg_define_procedure(cairo_device_set_user_data, gxg_cairo_device_set_user_data_w, 4, 0, 0, H_cairo_device_set_user_data, pl_iuuut);
+ Xg_define_procedure(cairo_device_set_user_data, gxg_cairo_device_set_user_data_w, 4, 0, 0, H_cairo_device_set_user_data, pl_guuut);
Xg_define_procedure(cairo_surface_create_for_rectangle, gxg_cairo_surface_create_for_rectangle_w, 5, 0, 0, H_cairo_surface_create_for_rectangle, pl_pur);
Xg_define_procedure(cairo_surface_get_device, gxg_cairo_surface_get_device_w, 1, 0, 0, H_cairo_surface_get_device, pl_pu);
- Xg_define_procedure(cairo_surface_set_mime_data, gxg_cairo_surface_set_mime_data_w, 6, 0, 0, H_cairo_surface_set_mime_data, pl_iussitu);
- Xg_define_procedure(cairo_recording_surface_create, gxg_cairo_recording_surface_create_w, 2, 0, 0, H_cairo_recording_surface_create, pl_piu);
+ Xg_define_procedure(cairo_surface_set_mime_data, gxg_cairo_surface_set_mime_data_w, 6, 0, 0, H_cairo_surface_set_mime_data, pl_gussitu);
+ Xg_define_procedure(cairo_recording_surface_create, gxg_cairo_recording_surface_create_w, 2, 0, 0, H_cairo_recording_surface_create, pl_pgu);
Xg_define_procedure(cairo_recording_surface_ink_extents, gxg_cairo_recording_surface_ink_extents_w, 5, 0, 0, H_cairo_recording_surface_ink_extents, pl_tu);
Xg_define_procedure(cairo_region_create, gxg_cairo_region_create_w, 0, 0, 0, H_cairo_region_create, pl_p);
Xg_define_procedure(cairo_region_create_rectangle, gxg_cairo_region_create_rectangle_w, 1, 0, 0, H_cairo_region_create_rectangle, pl_pu);
@@ -43332,7 +43783,7 @@ pl_unused = NULL;
Xg_define_procedure(cairo_region_reference, gxg_cairo_region_reference_w, 1, 0, 0, H_cairo_region_reference, pl_pu);
Xg_define_procedure(cairo_region_destroy, gxg_cairo_region_destroy_w, 1, 0, 0, H_cairo_region_destroy, pl_tu);
Xg_define_procedure(cairo_region_equal, gxg_cairo_region_equal_w, 2, 0, 0, H_cairo_region_equal, pl_iu);
- Xg_define_procedure(cairo_region_status, gxg_cairo_region_status_w, 1, 0, 0, H_cairo_region_status, pl_iu);
+ Xg_define_procedure(cairo_region_status, gxg_cairo_region_status_w, 1, 0, 0, H_cairo_region_status, pl_gu);
Xg_define_procedure(cairo_region_get_extents, gxg_cairo_region_get_extents_w, 2, 0, 0, H_cairo_region_get_extents, pl_tu);
Xg_define_procedure(cairo_region_num_rectangles, gxg_cairo_region_num_rectangles_w, 1, 0, 0, H_cairo_region_num_rectangles, pl_iu);
Xg_define_procedure(cairo_region_get_rectangle, gxg_cairo_region_get_rectangle_w, 3, 0, 0, H_cairo_region_get_rectangle, pl_tuiu);
@@ -43340,242 +43791,250 @@ pl_unused = NULL;
Xg_define_procedure(cairo_region_contains_rectangle, gxg_cairo_region_contains_rectangle_w, 2, 0, 0, H_cairo_region_contains_rectangle, pl_tu);
Xg_define_procedure(cairo_region_contains_point, gxg_cairo_region_contains_point_w, 3, 0, 0, H_cairo_region_contains_point, pl_iui);
Xg_define_procedure(cairo_region_translate, gxg_cairo_region_translate_w, 3, 0, 0, H_cairo_region_translate, pl_tui);
- Xg_define_procedure(cairo_region_subtract, gxg_cairo_region_subtract_w, 2, 0, 0, H_cairo_region_subtract, pl_iu);
- Xg_define_procedure(cairo_region_subtract_rectangle, gxg_cairo_region_subtract_rectangle_w, 2, 0, 0, H_cairo_region_subtract_rectangle, pl_iu);
- Xg_define_procedure(cairo_region_intersect, gxg_cairo_region_intersect_w, 2, 0, 0, H_cairo_region_intersect, pl_iu);
- Xg_define_procedure(cairo_region_intersect_rectangle, gxg_cairo_region_intersect_rectangle_w, 2, 0, 0, H_cairo_region_intersect_rectangle, pl_iu);
- Xg_define_procedure(cairo_region_union, gxg_cairo_region_union_w, 2, 0, 0, H_cairo_region_union, pl_iu);
- Xg_define_procedure(cairo_region_union_rectangle, gxg_cairo_region_union_rectangle_w, 2, 0, 0, H_cairo_region_union_rectangle, pl_iu);
- Xg_define_procedure(cairo_region_xor, gxg_cairo_region_xor_w, 2, 0, 0, H_cairo_region_xor, pl_iu);
- Xg_define_procedure(cairo_region_xor_rectangle, gxg_cairo_region_xor_rectangle_w, 2, 0, 0, H_cairo_region_xor_rectangle, pl_iu);
+ Xg_define_procedure(cairo_region_subtract, gxg_cairo_region_subtract_w, 2, 0, 0, H_cairo_region_subtract, pl_gu);
+ Xg_define_procedure(cairo_region_subtract_rectangle, gxg_cairo_region_subtract_rectangle_w, 2, 0, 0, H_cairo_region_subtract_rectangle, pl_gu);
+ Xg_define_procedure(cairo_region_intersect, gxg_cairo_region_intersect_w, 2, 0, 0, H_cairo_region_intersect, pl_gu);
+ Xg_define_procedure(cairo_region_intersect_rectangle, gxg_cairo_region_intersect_rectangle_w, 2, 0, 0, H_cairo_region_intersect_rectangle, pl_gu);
+ Xg_define_procedure(cairo_region_union, gxg_cairo_region_union_w, 2, 0, 0, H_cairo_region_union, pl_gu);
+ Xg_define_procedure(cairo_region_union_rectangle, gxg_cairo_region_union_rectangle_w, 2, 0, 0, H_cairo_region_union_rectangle, pl_gu);
+ Xg_define_procedure(cairo_region_xor, gxg_cairo_region_xor_w, 2, 0, 0, H_cairo_region_xor, pl_gu);
+ Xg_define_procedure(cairo_region_xor_rectangle, gxg_cairo_region_xor_rectangle_w, 2, 0, 0, H_cairo_region_xor_rectangle, pl_gu);
#endif
Xg_define_procedure(GPOINTER, gxg_GPOINTER_w, 1, 0, 0, "(GPOINTER obj) casts obj to GPOINTER", NULL);
- Xg_define_procedure(GDK_DRAG_CONTEXT, gxg_GDK_DRAG_CONTEXT_w, 1, 0, 0, "(GDK_DRAG_CONTEXT obj) casts obj to GDK_DRAG_CONTEXT", NULL);
- Xg_define_procedure(GDK_DEVICE, gxg_GDK_DEVICE_w, 1, 0, 0, "(GDK_DEVICE obj) casts obj to GDK_DEVICE", NULL);
- Xg_define_procedure(GDK_KEYMAP, gxg_GDK_KEYMAP_w, 1, 0, 0, "(GDK_KEYMAP obj) casts obj to GDK_KEYMAP", NULL);
- Xg_define_procedure(GDK_VISUAL, gxg_GDK_VISUAL_w, 1, 0, 0, "(GDK_VISUAL obj) casts obj to GDK_VISUAL", NULL);
- Xg_define_procedure(GDK_WINDOW, gxg_GDK_WINDOW_w, 1, 0, 0, "(GDK_WINDOW obj) casts obj to GDK_WINDOW", NULL);
- Xg_define_procedure(GDK_PIXBUF, gxg_GDK_PIXBUF_w, 1, 0, 0, "(GDK_PIXBUF obj) casts obj to GDK_PIXBUF", NULL);
- Xg_define_procedure(GDK_PIXBUF_ANIMATION, gxg_GDK_PIXBUF_ANIMATION_w, 1, 0, 0, "(GDK_PIXBUF_ANIMATION obj) casts obj to GDK_PIXBUF_ANIMATION", NULL);
- Xg_define_procedure(GDK_PIXBUF_ANIMATION_ITER, gxg_GDK_PIXBUF_ANIMATION_ITER_w, 1, 0, 0, "(GDK_PIXBUF_ANIMATION_ITER obj) casts obj to GDK_PIXBUF_ANIMATION_ITER", NULL);
- Xg_define_procedure(GTK_ACCEL_GROUP, gxg_GTK_ACCEL_GROUP_w, 1, 0, 0, "(GTK_ACCEL_GROUP obj) casts obj to GTK_ACCEL_GROUP", NULL);
- Xg_define_procedure(GTK_ACCEL_LABEL, gxg_GTK_ACCEL_LABEL_w, 1, 0, 0, "(GTK_ACCEL_LABEL obj) casts obj to GTK_ACCEL_LABEL", NULL);
- Xg_define_procedure(GTK_ACCESSIBLE, gxg_GTK_ACCESSIBLE_w, 1, 0, 0, "(GTK_ACCESSIBLE obj) casts obj to GTK_ACCESSIBLE", NULL);
- Xg_define_procedure(GTK_ADJUSTMENT, gxg_GTK_ADJUSTMENT_w, 1, 0, 0, "(GTK_ADJUSTMENT obj) casts obj to GTK_ADJUSTMENT", NULL);
- Xg_define_procedure(GTK_ASPECT_FRAME, gxg_GTK_ASPECT_FRAME_w, 1, 0, 0, "(GTK_ASPECT_FRAME obj) casts obj to GTK_ASPECT_FRAME", NULL);
- Xg_define_procedure(GTK_BUTTON_BOX, gxg_GTK_BUTTON_BOX_w, 1, 0, 0, "(GTK_BUTTON_BOX obj) casts obj to GTK_BUTTON_BOX", NULL);
- Xg_define_procedure(GTK_BIN, gxg_GTK_BIN_w, 1, 0, 0, "(GTK_BIN obj) casts obj to GTK_BIN", NULL);
- Xg_define_procedure(GTK_BOX, gxg_GTK_BOX_w, 1, 0, 0, "(GTK_BOX obj) casts obj to GTK_BOX", NULL);
- Xg_define_procedure(GTK_BUTTON, gxg_GTK_BUTTON_w, 1, 0, 0, "(GTK_BUTTON obj) casts obj to GTK_BUTTON", NULL);
- Xg_define_procedure(GTK_CALENDAR, gxg_GTK_CALENDAR_w, 1, 0, 0, "(GTK_CALENDAR obj) casts obj to GTK_CALENDAR", NULL);
- Xg_define_procedure(GTK_CELL_EDITABLE, gxg_GTK_CELL_EDITABLE_w, 1, 0, 0, "(GTK_CELL_EDITABLE obj) casts obj to GTK_CELL_EDITABLE", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER, gxg_GTK_CELL_RENDERER_w, 1, 0, 0, "(GTK_CELL_RENDERER obj) casts obj to GTK_CELL_RENDERER", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_PIXBUF, gxg_GTK_CELL_RENDERER_PIXBUF_w, 1, 0, 0, "(GTK_CELL_RENDERER_PIXBUF obj) casts obj to GTK_CELL_RENDERER_PIXBUF", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_TEXT, gxg_GTK_CELL_RENDERER_TEXT_w, 1, 0, 0, "(GTK_CELL_RENDERER_TEXT obj) casts obj to GTK_CELL_RENDERER_TEXT", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_TOGGLE, gxg_GTK_CELL_RENDERER_TOGGLE_w, 1, 0, 0, "(GTK_CELL_RENDERER_TOGGLE obj) casts obj to GTK_CELL_RENDERER_TOGGLE", NULL);
- Xg_define_procedure(GTK_CHECK_BUTTON, gxg_GTK_CHECK_BUTTON_w, 1, 0, 0, "(GTK_CHECK_BUTTON obj) casts obj to GTK_CHECK_BUTTON", NULL);
- Xg_define_procedure(GTK_CHECK_MENU_ITEM, gxg_GTK_CHECK_MENU_ITEM_w, 1, 0, 0, "(GTK_CHECK_MENU_ITEM obj) casts obj to GTK_CHECK_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_CONTAINER, gxg_GTK_CONTAINER_w, 1, 0, 0, "(GTK_CONTAINER obj) casts obj to GTK_CONTAINER", NULL);
- Xg_define_procedure(GTK_DIALOG, gxg_GTK_DIALOG_w, 1, 0, 0, "(GTK_DIALOG obj) casts obj to GTK_DIALOG", NULL);
- Xg_define_procedure(GTK_DRAWING_AREA, gxg_GTK_DRAWING_AREA_w, 1, 0, 0, "(GTK_DRAWING_AREA obj) casts obj to GTK_DRAWING_AREA", NULL);
- Xg_define_procedure(GTK_EDITABLE, gxg_GTK_EDITABLE_w, 1, 0, 0, "(GTK_EDITABLE obj) casts obj to GTK_EDITABLE", NULL);
- Xg_define_procedure(GTK_ENTRY, gxg_GTK_ENTRY_w, 1, 0, 0, "(GTK_ENTRY obj) casts obj to GTK_ENTRY", NULL);
- Xg_define_procedure(GTK_EVENT_BOX, gxg_GTK_EVENT_BOX_w, 1, 0, 0, "(GTK_EVENT_BOX obj) casts obj to GTK_EVENT_BOX", NULL);
- Xg_define_procedure(GTK_FIXED, gxg_GTK_FIXED_w, 1, 0, 0, "(GTK_FIXED obj) casts obj to GTK_FIXED", NULL);
- Xg_define_procedure(GTK_FRAME, gxg_GTK_FRAME_w, 1, 0, 0, "(GTK_FRAME obj) casts obj to GTK_FRAME", NULL);
- Xg_define_procedure(GTK_IMAGE, gxg_GTK_IMAGE_w, 1, 0, 0, "(GTK_IMAGE obj) casts obj to GTK_IMAGE", NULL);
- Xg_define_procedure(GTK_IM_CONTEXT, gxg_GTK_IM_CONTEXT_w, 1, 0, 0, "(GTK_IM_CONTEXT obj) casts obj to GTK_IM_CONTEXT", NULL);
- Xg_define_procedure(GTK_IM_CONTEXT_SIMPLE, gxg_GTK_IM_CONTEXT_SIMPLE_w, 1, 0, 0, "(GTK_IM_CONTEXT_SIMPLE obj) casts obj to GTK_IM_CONTEXT_SIMPLE", NULL);
- Xg_define_procedure(GTK_INVISIBLE, gxg_GTK_INVISIBLE_w, 1, 0, 0, "(GTK_INVISIBLE obj) casts obj to GTK_INVISIBLE", NULL);
- Xg_define_procedure(GTK_LABEL, gxg_GTK_LABEL_w, 1, 0, 0, "(GTK_LABEL obj) casts obj to GTK_LABEL", NULL);
- Xg_define_procedure(GTK_LAYOUT, gxg_GTK_LAYOUT_w, 1, 0, 0, "(GTK_LAYOUT obj) casts obj to GTK_LAYOUT", NULL);
- Xg_define_procedure(GTK_LIST_STORE, gxg_GTK_LIST_STORE_w, 1, 0, 0, "(GTK_LIST_STORE obj) casts obj to GTK_LIST_STORE", NULL);
- Xg_define_procedure(GTK_MENU_BAR, gxg_GTK_MENU_BAR_w, 1, 0, 0, "(GTK_MENU_BAR obj) casts obj to GTK_MENU_BAR", NULL);
- Xg_define_procedure(GTK_MENU, gxg_GTK_MENU_w, 1, 0, 0, "(GTK_MENU obj) casts obj to GTK_MENU", NULL);
- Xg_define_procedure(GTK_MENU_ITEM, gxg_GTK_MENU_ITEM_w, 1, 0, 0, "(GTK_MENU_ITEM obj) casts obj to GTK_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_MENU_SHELL, gxg_GTK_MENU_SHELL_w, 1, 0, 0, "(GTK_MENU_SHELL obj) casts obj to GTK_MENU_SHELL", NULL);
- Xg_define_procedure(GTK_NOTEBOOK, gxg_GTK_NOTEBOOK_w, 1, 0, 0, "(GTK_NOTEBOOK obj) casts obj to GTK_NOTEBOOK", NULL);
- Xg_define_procedure(GTK_PANED, gxg_GTK_PANED_w, 1, 0, 0, "(GTK_PANED obj) casts obj to GTK_PANED", NULL);
- Xg_define_procedure(GTK_PROGRESS_BAR, gxg_GTK_PROGRESS_BAR_w, 1, 0, 0, "(GTK_PROGRESS_BAR obj) casts obj to GTK_PROGRESS_BAR", NULL);
- Xg_define_procedure(GTK_RADIO_BUTTON, gxg_GTK_RADIO_BUTTON_w, 1, 0, 0, "(GTK_RADIO_BUTTON obj) casts obj to GTK_RADIO_BUTTON", NULL);
- Xg_define_procedure(GTK_RADIO_MENU_ITEM, gxg_GTK_RADIO_MENU_ITEM_w, 1, 0, 0, "(GTK_RADIO_MENU_ITEM obj) casts obj to GTK_RADIO_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_RANGE, gxg_GTK_RANGE_w, 1, 0, 0, "(GTK_RANGE obj) casts obj to GTK_RANGE", NULL);
- Xg_define_procedure(GTK_SCALE, gxg_GTK_SCALE_w, 1, 0, 0, "(GTK_SCALE obj) casts obj to GTK_SCALE", NULL);
- Xg_define_procedure(GTK_SCROLLBAR, gxg_GTK_SCROLLBAR_w, 1, 0, 0, "(GTK_SCROLLBAR obj) casts obj to GTK_SCROLLBAR", NULL);
- Xg_define_procedure(GTK_SCROLLED_WINDOW, gxg_GTK_SCROLLED_WINDOW_w, 1, 0, 0, "(GTK_SCROLLED_WINDOW obj) casts obj to GTK_SCROLLED_WINDOW", NULL);
- Xg_define_procedure(GTK_SEPARATOR, gxg_GTK_SEPARATOR_w, 1, 0, 0, "(GTK_SEPARATOR obj) casts obj to GTK_SEPARATOR", NULL);
- Xg_define_procedure(GTK_SEPARATOR_MENU_ITEM, gxg_GTK_SEPARATOR_MENU_ITEM_w, 1, 0, 0, "(GTK_SEPARATOR_MENU_ITEM obj) casts obj to GTK_SEPARATOR_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_SETTINGS, gxg_GTK_SETTINGS_w, 1, 0, 0, "(GTK_SETTINGS obj) casts obj to GTK_SETTINGS", NULL);
- Xg_define_procedure(GTK_SIZE_GROUP, gxg_GTK_SIZE_GROUP_w, 1, 0, 0, "(GTK_SIZE_GROUP obj) casts obj to GTK_SIZE_GROUP", NULL);
- Xg_define_procedure(GTK_SPIN_BUTTON, gxg_GTK_SPIN_BUTTON_w, 1, 0, 0, "(GTK_SPIN_BUTTON obj) casts obj to GTK_SPIN_BUTTON", NULL);
- Xg_define_procedure(GTK_STATUSBAR, gxg_GTK_STATUSBAR_w, 1, 0, 0, "(GTK_STATUSBAR obj) casts obj to GTK_STATUSBAR", NULL);
- Xg_define_procedure(GTK_TEXT_BUFFER, gxg_GTK_TEXT_BUFFER_w, 1, 0, 0, "(GTK_TEXT_BUFFER obj) casts obj to GTK_TEXT_BUFFER", NULL);
- Xg_define_procedure(GTK_TEXT_CHILD_ANCHOR, gxg_GTK_TEXT_CHILD_ANCHOR_w, 1, 0, 0, "(GTK_TEXT_CHILD_ANCHOR obj) casts obj to GTK_TEXT_CHILD_ANCHOR", NULL);
- Xg_define_procedure(GTK_TEXT_MARK, gxg_GTK_TEXT_MARK_w, 1, 0, 0, "(GTK_TEXT_MARK obj) casts obj to GTK_TEXT_MARK", NULL);
- Xg_define_procedure(GTK_TEXT_TAG, gxg_GTK_TEXT_TAG_w, 1, 0, 0, "(GTK_TEXT_TAG obj) casts obj to GTK_TEXT_TAG", NULL);
- Xg_define_procedure(GTK_TEXT_TAG_TABLE, gxg_GTK_TEXT_TAG_TABLE_w, 1, 0, 0, "(GTK_TEXT_TAG_TABLE obj) casts obj to GTK_TEXT_TAG_TABLE", NULL);
- Xg_define_procedure(GTK_TEXT_VIEW, gxg_GTK_TEXT_VIEW_w, 1, 0, 0, "(GTK_TEXT_VIEW obj) casts obj to GTK_TEXT_VIEW", NULL);
- Xg_define_procedure(GTK_TOGGLE_BUTTON, gxg_GTK_TOGGLE_BUTTON_w, 1, 0, 0, "(GTK_TOGGLE_BUTTON obj) casts obj to GTK_TOGGLE_BUTTON", NULL);
- Xg_define_procedure(GTK_TOOLBAR, gxg_GTK_TOOLBAR_w, 1, 0, 0, "(GTK_TOOLBAR obj) casts obj to GTK_TOOLBAR", NULL);
- Xg_define_procedure(GTK_TREE_DRAG_SOURCE, gxg_GTK_TREE_DRAG_SOURCE_w, 1, 0, 0, "(GTK_TREE_DRAG_SOURCE obj) casts obj to GTK_TREE_DRAG_SOURCE", NULL);
- Xg_define_procedure(GTK_TREE_DRAG_DEST, gxg_GTK_TREE_DRAG_DEST_w, 1, 0, 0, "(GTK_TREE_DRAG_DEST obj) casts obj to GTK_TREE_DRAG_DEST", NULL);
- Xg_define_procedure(GTK_TREE_MODEL, gxg_GTK_TREE_MODEL_w, 1, 0, 0, "(GTK_TREE_MODEL obj) casts obj to GTK_TREE_MODEL", NULL);
- Xg_define_procedure(GTK_TREE_MODEL_SORT, gxg_GTK_TREE_MODEL_SORT_w, 1, 0, 0, "(GTK_TREE_MODEL_SORT obj) casts obj to GTK_TREE_MODEL_SORT", NULL);
- Xg_define_procedure(GTK_TREE_SELECTION, gxg_GTK_TREE_SELECTION_w, 1, 0, 0, "(GTK_TREE_SELECTION obj) casts obj to GTK_TREE_SELECTION", NULL);
- Xg_define_procedure(GTK_TREE_SORTABLE, gxg_GTK_TREE_SORTABLE_w, 1, 0, 0, "(GTK_TREE_SORTABLE obj) casts obj to GTK_TREE_SORTABLE", NULL);
- Xg_define_procedure(GTK_TREE_STORE, gxg_GTK_TREE_STORE_w, 1, 0, 0, "(GTK_TREE_STORE obj) casts obj to GTK_TREE_STORE", NULL);
- Xg_define_procedure(GTK_TREE_VIEW_COLUMN, gxg_GTK_TREE_VIEW_COLUMN_w, 1, 0, 0, "(GTK_TREE_VIEW_COLUMN obj) casts obj to GTK_TREE_VIEW_COLUMN", NULL);
- Xg_define_procedure(GTK_TREE_VIEW, gxg_GTK_TREE_VIEW_w, 1, 0, 0, "(GTK_TREE_VIEW obj) casts obj to GTK_TREE_VIEW", NULL);
- Xg_define_procedure(GTK_VIEWPORT, gxg_GTK_VIEWPORT_w, 1, 0, 0, "(GTK_VIEWPORT obj) casts obj to GTK_VIEWPORT", NULL);
- Xg_define_procedure(GTK_WIDGET, gxg_GTK_WIDGET_w, 1, 0, 0, "(GTK_WIDGET obj) casts obj to GTK_WIDGET", NULL);
- Xg_define_procedure(GTK_WINDOW, gxg_GTK_WINDOW_w, 1, 0, 0, "(GTK_WINDOW obj) casts obj to GTK_WINDOW", NULL);
- Xg_define_procedure(PANGO_CONTEXT, gxg_PANGO_CONTEXT_w, 1, 0, 0, "(PANGO_CONTEXT obj) casts obj to PANGO_CONTEXT", NULL);
- Xg_define_procedure(PANGO_FONT_FAMILY, gxg_PANGO_FONT_FAMILY_w, 1, 0, 0, "(PANGO_FONT_FAMILY obj) casts obj to PANGO_FONT_FAMILY", NULL);
- Xg_define_procedure(PANGO_FONT_FACE, gxg_PANGO_FONT_FACE_w, 1, 0, 0, "(PANGO_FONT_FACE obj) casts obj to PANGO_FONT_FACE", NULL);
- Xg_define_procedure(PANGO_FONT, gxg_PANGO_FONT_w, 1, 0, 0, "(PANGO_FONT obj) casts obj to PANGO_FONT", NULL);
- Xg_define_procedure(PANGO_FONT_MAP, gxg_PANGO_FONT_MAP_w, 1, 0, 0, "(PANGO_FONT_MAP obj) casts obj to PANGO_FONT_MAP", NULL);
- Xg_define_procedure(PANGO_LAYOUT, gxg_PANGO_LAYOUT_w, 1, 0, 0, "(PANGO_LAYOUT obj) casts obj to PANGO_LAYOUT", NULL);
- Xg_define_procedure(G_OBJECT, gxg_G_OBJECT_w, 1, 0, 0, "(G_OBJECT obj) casts obj to G_OBJECT", NULL);
- Xg_define_procedure(GDK_SCREEN, gxg_GDK_SCREEN_w, 1, 0, 0, "(GDK_SCREEN obj) casts obj to GDK_SCREEN", NULL);
- Xg_define_procedure(GDK_DISPLAY_OBJECT, gxg_GDK_DISPLAY_OBJECT_w, 1, 0, 0, "(GDK_DISPLAY_OBJECT obj) casts obj to GDK_DISPLAY_OBJECT", NULL);
- Xg_define_procedure(GDK_EVENT, gxg_GDK_EVENT_w, 1, 0, 0, "(GDK_EVENT obj) casts obj to GDK_EVENT", NULL);
- Xg_define_procedure(GDK_EVENT_ANY, gxg_GDK_EVENT_ANY_w, 1, 0, 0, "(GDK_EVENT_ANY obj) casts obj to GDK_EVENT_ANY", NULL);
- Xg_define_procedure(GDK_EVENT_EXPOSE, gxg_GDK_EVENT_EXPOSE_w, 1, 0, 0, "(GDK_EVENT_EXPOSE obj) casts obj to GDK_EVENT_EXPOSE", NULL);
- Xg_define_procedure(GDK_EVENT_NOEXPOSE, gxg_GDK_EVENT_NOEXPOSE_w, 1, 0, 0, "(GDK_EVENT_NOEXPOSE obj) casts obj to GDK_EVENT_NOEXPOSE", NULL);
- Xg_define_procedure(GDK_EVENT_VISIBILITY, gxg_GDK_EVENT_VISIBILITY_w, 1, 0, 0, "(GDK_EVENT_VISIBILITY obj) casts obj to GDK_EVENT_VISIBILITY", NULL);
- Xg_define_procedure(GDK_EVENT_MOTION, gxg_GDK_EVENT_MOTION_w, 1, 0, 0, "(GDK_EVENT_MOTION obj) casts obj to GDK_EVENT_MOTION", NULL);
- Xg_define_procedure(GDK_EVENT_BUTTON, gxg_GDK_EVENT_BUTTON_w, 1, 0, 0, "(GDK_EVENT_BUTTON obj) casts obj to GDK_EVENT_BUTTON", NULL);
- Xg_define_procedure(GDK_EVENT_SCROLL, gxg_GDK_EVENT_SCROLL_w, 1, 0, 0, "(GDK_EVENT_SCROLL obj) casts obj to GDK_EVENT_SCROLL", NULL);
- Xg_define_procedure(GDK_EVENT_KEY, gxg_GDK_EVENT_KEY_w, 1, 0, 0, "(GDK_EVENT_KEY obj) casts obj to GDK_EVENT_KEY", NULL);
- Xg_define_procedure(GDK_EVENT_CROSSING, gxg_GDK_EVENT_CROSSING_w, 1, 0, 0, "(GDK_EVENT_CROSSING obj) casts obj to GDK_EVENT_CROSSING", NULL);
- Xg_define_procedure(GDK_EVENT_FOCUS, gxg_GDK_EVENT_FOCUS_w, 1, 0, 0, "(GDK_EVENT_FOCUS obj) casts obj to GDK_EVENT_FOCUS", NULL);
- Xg_define_procedure(GDK_EVENT_CONFIGURE, gxg_GDK_EVENT_CONFIGURE_w, 1, 0, 0, "(GDK_EVENT_CONFIGURE obj) casts obj to GDK_EVENT_CONFIGURE", NULL);
- Xg_define_procedure(GDK_EVENT_PROPERTY, gxg_GDK_EVENT_PROPERTY_w, 1, 0, 0, "(GDK_EVENT_PROPERTY obj) casts obj to GDK_EVENT_PROPERTY", NULL);
- Xg_define_procedure(GDK_EVENT_SELECTION, gxg_GDK_EVENT_SELECTION_w, 1, 0, 0, "(GDK_EVENT_SELECTION obj) casts obj to GDK_EVENT_SELECTION", NULL);
- Xg_define_procedure(GDK_EVENT_PROXIMITY, gxg_GDK_EVENT_PROXIMITY_w, 1, 0, 0, "(GDK_EVENT_PROXIMITY obj) casts obj to GDK_EVENT_PROXIMITY", NULL);
- Xg_define_procedure(GDK_EVENT_SETTING, gxg_GDK_EVENT_SETTING_w, 1, 0, 0, "(GDK_EVENT_SETTING obj) casts obj to GDK_EVENT_SETTING", NULL);
- Xg_define_procedure(GDK_EVENT_WINDOWSTATE, gxg_GDK_EVENT_WINDOWSTATE_w, 1, 0, 0, "(GDK_EVENT_WINDOWSTATE obj) casts obj to GDK_EVENT_WINDOWSTATE", NULL);
- Xg_define_procedure(GDK_EVENT_DND, gxg_GDK_EVENT_DND_w, 1, 0, 0, "(GDK_EVENT_DND obj) casts obj to GDK_EVENT_DND", NULL);
- Xg_define_procedure(GTK_FILE_CHOOSER_DIALOG, gxg_GTK_FILE_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_FILE_CHOOSER_DIALOG obj) casts obj to GTK_FILE_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_FILE_CHOOSER_WIDGET, gxg_GTK_FILE_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_FILE_CHOOSER_WIDGET obj) casts obj to GTK_FILE_CHOOSER_WIDGET", NULL);
- Xg_define_procedure(GTK_TREE_MODEL_FILTER, gxg_GTK_TREE_MODEL_FILTER_w, 1, 0, 0, "(GTK_TREE_MODEL_FILTER obj) casts obj to GTK_TREE_MODEL_FILTER", NULL);
- Xg_define_procedure(GTK_COMBO_BOX, gxg_GTK_COMBO_BOX_w, 1, 0, 0, "(GTK_COMBO_BOX obj) casts obj to GTK_COMBO_BOX", NULL);
- Xg_define_procedure(GTK_EXPANDER, gxg_GTK_EXPANDER_w, 1, 0, 0, "(GTK_EXPANDER obj) casts obj to GTK_EXPANDER", NULL);
- Xg_define_procedure(GTK_FONT_BUTTON, gxg_GTK_FONT_BUTTON_w, 1, 0, 0, "(GTK_FONT_BUTTON obj) casts obj to GTK_FONT_BUTTON", NULL);
- Xg_define_procedure(GTK_COLOR_BUTTON, gxg_GTK_COLOR_BUTTON_w, 1, 0, 0, "(GTK_COLOR_BUTTON obj) casts obj to GTK_COLOR_BUTTON", NULL);
- Xg_define_procedure(GTK_ENTRY_COMPLETION, gxg_GTK_ENTRY_COMPLETION_w, 1, 0, 0, "(GTK_ENTRY_COMPLETION obj) casts obj to GTK_ENTRY_COMPLETION", NULL);
- Xg_define_procedure(GTK_RADIO_TOOL_BUTTON, gxg_GTK_RADIO_TOOL_BUTTON_w, 1, 0, 0, "(GTK_RADIO_TOOL_BUTTON obj) casts obj to GTK_RADIO_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_SEPARATOR_TOOL_ITEM, gxg_GTK_SEPARATOR_TOOL_ITEM_w, 1, 0, 0, "(GTK_SEPARATOR_TOOL_ITEM obj) casts obj to GTK_SEPARATOR_TOOL_ITEM", NULL);
- Xg_define_procedure(GTK_TOGGLE_TOOL_BUTTON, gxg_GTK_TOGGLE_TOOL_BUTTON_w, 1, 0, 0, "(GTK_TOGGLE_TOOL_BUTTON obj) casts obj to GTK_TOGGLE_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_FILE_FILTER, gxg_GTK_FILE_FILTER_w, 1, 0, 0, "(GTK_FILE_FILTER obj) casts obj to GTK_FILE_FILTER", NULL);
- Xg_define_procedure(GTK_CELL_LAYOUT, gxg_GTK_CELL_LAYOUT_w, 1, 0, 0, "(GTK_CELL_LAYOUT obj) casts obj to GTK_CELL_LAYOUT", NULL);
- Xg_define_procedure(GTK_CLIPBOARD, gxg_GTK_CLIPBOARD_w, 1, 0, 0, "(GTK_CLIPBOARD obj) casts obj to GTK_CLIPBOARD", NULL);
- Xg_define_procedure(GTK_FILE_CHOOSER, gxg_GTK_FILE_CHOOSER_w, 1, 0, 0, "(GTK_FILE_CHOOSER obj) casts obj to GTK_FILE_CHOOSER", NULL);
- Xg_define_procedure(GTK_ICON_THEME, gxg_GTK_ICON_THEME_w, 1, 0, 0, "(GTK_ICON_THEME obj) casts obj to GTK_ICON_THEME", NULL);
- Xg_define_procedure(GTK_TOOL_BUTTON, gxg_GTK_TOOL_BUTTON_w, 1, 0, 0, "(GTK_TOOL_BUTTON obj) casts obj to GTK_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_TOOL_ITEM, gxg_GTK_TOOL_ITEM_w, 1, 0, 0, "(GTK_TOOL_ITEM obj) casts obj to GTK_TOOL_ITEM", NULL);
- Xg_define_procedure(GTK_ACCEL_MAP, gxg_GTK_ACCEL_MAP_w, 1, 0, 0, "(GTK_ACCEL_MAP obj) casts obj to GTK_ACCEL_MAP", NULL);
- Xg_define_procedure(GTK_CELL_VIEW, gxg_GTK_CELL_VIEW_w, 1, 0, 0, "(GTK_CELL_VIEW obj) casts obj to GTK_CELL_VIEW", NULL);
- Xg_define_procedure(GTK_ABOUT_DIALOG, gxg_GTK_ABOUT_DIALOG_w, 1, 0, 0, "(GTK_ABOUT_DIALOG obj) casts obj to GTK_ABOUT_DIALOG", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_COMBO, gxg_GTK_CELL_RENDERER_COMBO_w, 1, 0, 0, "(GTK_CELL_RENDERER_COMBO obj) casts obj to GTK_CELL_RENDERER_COMBO", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_PROGRESS, gxg_GTK_CELL_RENDERER_PROGRESS_w, 1, 0, 0, "(GTK_CELL_RENDERER_PROGRESS obj) casts obj to GTK_CELL_RENDERER_PROGRESS", NULL);
- Xg_define_procedure(GTK_ICON_VIEW, gxg_GTK_ICON_VIEW_w, 1, 0, 0, "(GTK_ICON_VIEW obj) casts obj to GTK_ICON_VIEW", NULL);
- Xg_define_procedure(GTK_FILE_CHOOSER_BUTTON, gxg_GTK_FILE_CHOOSER_BUTTON_w, 1, 0, 0, "(GTK_FILE_CHOOSER_BUTTON obj) casts obj to GTK_FILE_CHOOSER_BUTTON", NULL);
- Xg_define_procedure(GTK_MENU_TOOL_BUTTON, gxg_GTK_MENU_TOOL_BUTTON_w, 1, 0, 0, "(GTK_MENU_TOOL_BUTTON obj) casts obj to GTK_MENU_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_ASSISTANT, gxg_GTK_ASSISTANT_w, 1, 0, 0, "(GTK_ASSISTANT obj) casts obj to GTK_ASSISTANT", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_ACCEL, gxg_GTK_CELL_RENDERER_ACCEL_w, 1, 0, 0, "(GTK_CELL_RENDERER_ACCEL obj) casts obj to GTK_CELL_RENDERER_ACCEL", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_SPIN, gxg_GTK_CELL_RENDERER_SPIN_w, 1, 0, 0, "(GTK_CELL_RENDERER_SPIN obj) casts obj to GTK_CELL_RENDERER_SPIN", NULL);
- Xg_define_procedure(GTK_LINK_BUTTON, gxg_GTK_LINK_BUTTON_w, 1, 0, 0, "(GTK_LINK_BUTTON obj) casts obj to GTK_LINK_BUTTON", NULL);
- Xg_define_procedure(GTK_RECENT_CHOOSER_DIALOG, gxg_GTK_RECENT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_DIALOG obj) casts obj to GTK_RECENT_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_RECENT_CHOOSER, gxg_GTK_RECENT_CHOOSER_w, 1, 0, 0, "(GTK_RECENT_CHOOSER obj) casts obj to GTK_RECENT_CHOOSER", NULL);
- Xg_define_procedure(GTK_RECENT_CHOOSER_MENU, gxg_GTK_RECENT_CHOOSER_MENU_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_MENU obj) casts obj to GTK_RECENT_CHOOSER_MENU", NULL);
- Xg_define_procedure(GTK_RECENT_CHOOSER_WIDGET, gxg_GTK_RECENT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_WIDGET obj) casts obj to GTK_RECENT_CHOOSER_WIDGET", NULL);
- Xg_define_procedure(GTK_RECENT_FILTER, gxg_GTK_RECENT_FILTER_w, 1, 0, 0, "(GTK_RECENT_FILTER obj) casts obj to GTK_RECENT_FILTER", NULL);
- Xg_define_procedure(GTK_RECENT_MANAGER, gxg_GTK_RECENT_MANAGER_w, 1, 0, 0, "(GTK_RECENT_MANAGER obj) casts obj to GTK_RECENT_MANAGER", NULL);
- Xg_define_procedure(GTK_PRINT_CONTEXT, gxg_GTK_PRINT_CONTEXT_w, 1, 0, 0, "(GTK_PRINT_CONTEXT obj) casts obj to GTK_PRINT_CONTEXT", NULL);
- Xg_define_procedure(GTK_PRINT_OPERATION, gxg_GTK_PRINT_OPERATION_w, 1, 0, 0, "(GTK_PRINT_OPERATION obj) casts obj to GTK_PRINT_OPERATION", NULL);
- Xg_define_procedure(GTK_PRINT_OPERATION_PREVIEW, gxg_GTK_PRINT_OPERATION_PREVIEW_w, 1, 0, 0, "(GTK_PRINT_OPERATION_PREVIEW obj) casts obj to GTK_PRINT_OPERATION_PREVIEW", NULL);
- Xg_define_procedure(GTK_PRINT_SETTINGS, gxg_GTK_PRINT_SETTINGS_w, 1, 0, 0, "(GTK_PRINT_SETTINGS obj) casts obj to GTK_PRINT_SETTINGS", NULL);
- Xg_define_procedure(GTK_TOOLTIP, gxg_GTK_TOOLTIP_w, 1, 0, 0, "(GTK_TOOLTIP obj) casts obj to GTK_TOOLTIP", NULL);
+ Xg_define_procedure(GDK_DRAG_CONTEXT, gxg_GDK_DRAG_CONTEXT_w, 1, 0, 0, "(GDK_DRAG_CONTEXT obj) casts obj to GDK_DRAG_CONTEXT", pl_bpt);
+ Xg_define_procedure(GDK_DEVICE, gxg_GDK_DEVICE_w, 1, 0, 0, "(GDK_DEVICE obj) casts obj to GDK_DEVICE", pl_bpt);
+ Xg_define_procedure(GDK_KEYMAP, gxg_GDK_KEYMAP_w, 1, 0, 0, "(GDK_KEYMAP obj) casts obj to GDK_KEYMAP", pl_bpt);
+ Xg_define_procedure(GDK_VISUAL, gxg_GDK_VISUAL_w, 1, 0, 0, "(GDK_VISUAL obj) casts obj to GDK_VISUAL", pl_bpt);
+ Xg_define_procedure(GDK_WINDOW, gxg_GDK_WINDOW_w, 1, 0, 0, "(GDK_WINDOW obj) casts obj to GDK_WINDOW", pl_bpt);
+ Xg_define_procedure(GDK_PIXBUF, gxg_GDK_PIXBUF_w, 1, 0, 0, "(GDK_PIXBUF obj) casts obj to GDK_PIXBUF", pl_bpt);
+ Xg_define_procedure(GDK_PIXBUF_ANIMATION, gxg_GDK_PIXBUF_ANIMATION_w, 1, 0, 0, "(GDK_PIXBUF_ANIMATION obj) casts obj to GDK_PIXBUF_ANIMATION", pl_bpt);
+ Xg_define_procedure(GDK_PIXBUF_ANIMATION_ITER, gxg_GDK_PIXBUF_ANIMATION_ITER_w, 1, 0, 0, "(GDK_PIXBUF_ANIMATION_ITER obj) casts obj to GDK_PIXBUF_ANIMATION_ITER", pl_bpt);
+ Xg_define_procedure(GTK_ACCEL_GROUP, gxg_GTK_ACCEL_GROUP_w, 1, 0, 0, "(GTK_ACCEL_GROUP obj) casts obj to GTK_ACCEL_GROUP", pl_bpt);
+ Xg_define_procedure(GTK_ACCEL_LABEL, gxg_GTK_ACCEL_LABEL_w, 1, 0, 0, "(GTK_ACCEL_LABEL obj) casts obj to GTK_ACCEL_LABEL", pl_bpt);
+ Xg_define_procedure(GTK_ACCESSIBLE, gxg_GTK_ACCESSIBLE_w, 1, 0, 0, "(GTK_ACCESSIBLE obj) casts obj to GTK_ACCESSIBLE", pl_bpt);
+ Xg_define_procedure(GTK_ADJUSTMENT, gxg_GTK_ADJUSTMENT_w, 1, 0, 0, "(GTK_ADJUSTMENT obj) casts obj to GTK_ADJUSTMENT", pl_bpt);
+ Xg_define_procedure(GTK_ASPECT_FRAME, gxg_GTK_ASPECT_FRAME_w, 1, 0, 0, "(GTK_ASPECT_FRAME obj) casts obj to GTK_ASPECT_FRAME", pl_bpt);
+ Xg_define_procedure(GTK_BUTTON_BOX, gxg_GTK_BUTTON_BOX_w, 1, 0, 0, "(GTK_BUTTON_BOX obj) casts obj to GTK_BUTTON_BOX", pl_bpt);
+ Xg_define_procedure(GTK_BIN, gxg_GTK_BIN_w, 1, 0, 0, "(GTK_BIN obj) casts obj to GTK_BIN", pl_bpt);
+ Xg_define_procedure(GTK_BOX, gxg_GTK_BOX_w, 1, 0, 0, "(GTK_BOX obj) casts obj to GTK_BOX", pl_bpt);
+ Xg_define_procedure(GTK_BUTTON, gxg_GTK_BUTTON_w, 1, 0, 0, "(GTK_BUTTON obj) casts obj to GTK_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_CALENDAR, gxg_GTK_CALENDAR_w, 1, 0, 0, "(GTK_CALENDAR obj) casts obj to GTK_CALENDAR", pl_bpt);
+ Xg_define_procedure(GTK_CELL_EDITABLE, gxg_GTK_CELL_EDITABLE_w, 1, 0, 0, "(GTK_CELL_EDITABLE obj) casts obj to GTK_CELL_EDITABLE", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER, gxg_GTK_CELL_RENDERER_w, 1, 0, 0, "(GTK_CELL_RENDERER obj) casts obj to GTK_CELL_RENDERER", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_PIXBUF, gxg_GTK_CELL_RENDERER_PIXBUF_w, 1, 0, 0, "(GTK_CELL_RENDERER_PIXBUF obj) casts obj to GTK_CELL_RENDERER_PIXBUF", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_TEXT, gxg_GTK_CELL_RENDERER_TEXT_w, 1, 0, 0, "(GTK_CELL_RENDERER_TEXT obj) casts obj to GTK_CELL_RENDERER_TEXT", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_TOGGLE, gxg_GTK_CELL_RENDERER_TOGGLE_w, 1, 0, 0, "(GTK_CELL_RENDERER_TOGGLE obj) casts obj to GTK_CELL_RENDERER_TOGGLE", pl_bpt);
+ Xg_define_procedure(GTK_CHECK_BUTTON, gxg_GTK_CHECK_BUTTON_w, 1, 0, 0, "(GTK_CHECK_BUTTON obj) casts obj to GTK_CHECK_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_CHECK_MENU_ITEM, gxg_GTK_CHECK_MENU_ITEM_w, 1, 0, 0, "(GTK_CHECK_MENU_ITEM obj) casts obj to GTK_CHECK_MENU_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_CONTAINER, gxg_GTK_CONTAINER_w, 1, 0, 0, "(GTK_CONTAINER obj) casts obj to GTK_CONTAINER", pl_bpt);
+ Xg_define_procedure(GTK_DIALOG, gxg_GTK_DIALOG_w, 1, 0, 0, "(GTK_DIALOG obj) casts obj to GTK_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_DRAWING_AREA, gxg_GTK_DRAWING_AREA_w, 1, 0, 0, "(GTK_DRAWING_AREA obj) casts obj to GTK_DRAWING_AREA", pl_bpt);
+ Xg_define_procedure(GTK_EDITABLE, gxg_GTK_EDITABLE_w, 1, 0, 0, "(GTK_EDITABLE obj) casts obj to GTK_EDITABLE", pl_bpt);
+ Xg_define_procedure(GTK_ENTRY, gxg_GTK_ENTRY_w, 1, 0, 0, "(GTK_ENTRY obj) casts obj to GTK_ENTRY", pl_bpt);
+ Xg_define_procedure(GTK_EVENT_BOX, gxg_GTK_EVENT_BOX_w, 1, 0, 0, "(GTK_EVENT_BOX obj) casts obj to GTK_EVENT_BOX", pl_bpt);
+ Xg_define_procedure(GTK_FIXED, gxg_GTK_FIXED_w, 1, 0, 0, "(GTK_FIXED obj) casts obj to GTK_FIXED", pl_bpt);
+ Xg_define_procedure(GTK_FRAME, gxg_GTK_FRAME_w, 1, 0, 0, "(GTK_FRAME obj) casts obj to GTK_FRAME", pl_bpt);
+ Xg_define_procedure(GTK_IMAGE, gxg_GTK_IMAGE_w, 1, 0, 0, "(GTK_IMAGE obj) casts obj to GTK_IMAGE", pl_bpt);
+ Xg_define_procedure(GTK_IM_CONTEXT, gxg_GTK_IM_CONTEXT_w, 1, 0, 0, "(GTK_IM_CONTEXT obj) casts obj to GTK_IM_CONTEXT", pl_bpt);
+ Xg_define_procedure(GTK_IM_CONTEXT_SIMPLE, gxg_GTK_IM_CONTEXT_SIMPLE_w, 1, 0, 0, "(GTK_IM_CONTEXT_SIMPLE obj) casts obj to GTK_IM_CONTEXT_SIMPLE", pl_bpt);
+ Xg_define_procedure(GTK_INVISIBLE, gxg_GTK_INVISIBLE_w, 1, 0, 0, "(GTK_INVISIBLE obj) casts obj to GTK_INVISIBLE", pl_bpt);
+ Xg_define_procedure(GTK_LABEL, gxg_GTK_LABEL_w, 1, 0, 0, "(GTK_LABEL obj) casts obj to GTK_LABEL", pl_bpt);
+ Xg_define_procedure(GTK_LAYOUT, gxg_GTK_LAYOUT_w, 1, 0, 0, "(GTK_LAYOUT obj) casts obj to GTK_LAYOUT", pl_bpt);
+ Xg_define_procedure(GTK_LIST_STORE, gxg_GTK_LIST_STORE_w, 1, 0, 0, "(GTK_LIST_STORE obj) casts obj to GTK_LIST_STORE", pl_bpt);
+ Xg_define_procedure(GTK_MENU_BAR, gxg_GTK_MENU_BAR_w, 1, 0, 0, "(GTK_MENU_BAR obj) casts obj to GTK_MENU_BAR", pl_bpt);
+ Xg_define_procedure(GTK_MENU, gxg_GTK_MENU_w, 1, 0, 0, "(GTK_MENU obj) casts obj to GTK_MENU", pl_bpt);
+ Xg_define_procedure(GTK_MENU_ITEM, gxg_GTK_MENU_ITEM_w, 1, 0, 0, "(GTK_MENU_ITEM obj) casts obj to GTK_MENU_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_MENU_SHELL, gxg_GTK_MENU_SHELL_w, 1, 0, 0, "(GTK_MENU_SHELL obj) casts obj to GTK_MENU_SHELL", pl_bpt);
+ Xg_define_procedure(GTK_NOTEBOOK, gxg_GTK_NOTEBOOK_w, 1, 0, 0, "(GTK_NOTEBOOK obj) casts obj to GTK_NOTEBOOK", pl_bpt);
+ Xg_define_procedure(GTK_PANED, gxg_GTK_PANED_w, 1, 0, 0, "(GTK_PANED obj) casts obj to GTK_PANED", pl_bpt);
+ Xg_define_procedure(GTK_PROGRESS_BAR, gxg_GTK_PROGRESS_BAR_w, 1, 0, 0, "(GTK_PROGRESS_BAR obj) casts obj to GTK_PROGRESS_BAR", pl_bpt);
+ Xg_define_procedure(GTK_RADIO_BUTTON, gxg_GTK_RADIO_BUTTON_w, 1, 0, 0, "(GTK_RADIO_BUTTON obj) casts obj to GTK_RADIO_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_RADIO_MENU_ITEM, gxg_GTK_RADIO_MENU_ITEM_w, 1, 0, 0, "(GTK_RADIO_MENU_ITEM obj) casts obj to GTK_RADIO_MENU_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_RANGE, gxg_GTK_RANGE_w, 1, 0, 0, "(GTK_RANGE obj) casts obj to GTK_RANGE", pl_bpt);
+ Xg_define_procedure(GTK_SCALE, gxg_GTK_SCALE_w, 1, 0, 0, "(GTK_SCALE obj) casts obj to GTK_SCALE", pl_bpt);
+ Xg_define_procedure(GTK_SCROLLBAR, gxg_GTK_SCROLLBAR_w, 1, 0, 0, "(GTK_SCROLLBAR obj) casts obj to GTK_SCROLLBAR", pl_bpt);
+ Xg_define_procedure(GTK_SCROLLED_WINDOW, gxg_GTK_SCROLLED_WINDOW_w, 1, 0, 0, "(GTK_SCROLLED_WINDOW obj) casts obj to GTK_SCROLLED_WINDOW", pl_bpt);
+ Xg_define_procedure(GTK_SEPARATOR, gxg_GTK_SEPARATOR_w, 1, 0, 0, "(GTK_SEPARATOR obj) casts obj to GTK_SEPARATOR", pl_bpt);
+ Xg_define_procedure(GTK_SEPARATOR_MENU_ITEM, gxg_GTK_SEPARATOR_MENU_ITEM_w, 1, 0, 0, "(GTK_SEPARATOR_MENU_ITEM obj) casts obj to GTK_SEPARATOR_MENU_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_SETTINGS, gxg_GTK_SETTINGS_w, 1, 0, 0, "(GTK_SETTINGS obj) casts obj to GTK_SETTINGS", pl_bpt);
+ Xg_define_procedure(GTK_SIZE_GROUP, gxg_GTK_SIZE_GROUP_w, 1, 0, 0, "(GTK_SIZE_GROUP obj) casts obj to GTK_SIZE_GROUP", pl_bpt);
+ Xg_define_procedure(GTK_SPIN_BUTTON, gxg_GTK_SPIN_BUTTON_w, 1, 0, 0, "(GTK_SPIN_BUTTON obj) casts obj to GTK_SPIN_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_STATUSBAR, gxg_GTK_STATUSBAR_w, 1, 0, 0, "(GTK_STATUSBAR obj) casts obj to GTK_STATUSBAR", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_BUFFER, gxg_GTK_TEXT_BUFFER_w, 1, 0, 0, "(GTK_TEXT_BUFFER obj) casts obj to GTK_TEXT_BUFFER", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_CHILD_ANCHOR, gxg_GTK_TEXT_CHILD_ANCHOR_w, 1, 0, 0, "(GTK_TEXT_CHILD_ANCHOR obj) casts obj to GTK_TEXT_CHILD_ANCHOR", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_MARK, gxg_GTK_TEXT_MARK_w, 1, 0, 0, "(GTK_TEXT_MARK obj) casts obj to GTK_TEXT_MARK", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_TAG, gxg_GTK_TEXT_TAG_w, 1, 0, 0, "(GTK_TEXT_TAG obj) casts obj to GTK_TEXT_TAG", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_TAG_TABLE, gxg_GTK_TEXT_TAG_TABLE_w, 1, 0, 0, "(GTK_TEXT_TAG_TABLE obj) casts obj to GTK_TEXT_TAG_TABLE", pl_bpt);
+ Xg_define_procedure(GTK_TEXT_VIEW, gxg_GTK_TEXT_VIEW_w, 1, 0, 0, "(GTK_TEXT_VIEW obj) casts obj to GTK_TEXT_VIEW", pl_bpt);
+ Xg_define_procedure(GTK_TOGGLE_BUTTON, gxg_GTK_TOGGLE_BUTTON_w, 1, 0, 0, "(GTK_TOGGLE_BUTTON obj) casts obj to GTK_TOGGLE_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_TOOLBAR, gxg_GTK_TOOLBAR_w, 1, 0, 0, "(GTK_TOOLBAR obj) casts obj to GTK_TOOLBAR", pl_bpt);
+ Xg_define_procedure(GTK_TREE_DRAG_SOURCE, gxg_GTK_TREE_DRAG_SOURCE_w, 1, 0, 0, "(GTK_TREE_DRAG_SOURCE obj) casts obj to GTK_TREE_DRAG_SOURCE", pl_bpt);
+ Xg_define_procedure(GTK_TREE_DRAG_DEST, gxg_GTK_TREE_DRAG_DEST_w, 1, 0, 0, "(GTK_TREE_DRAG_DEST obj) casts obj to GTK_TREE_DRAG_DEST", pl_bpt);
+ Xg_define_procedure(GTK_TREE_MODEL, gxg_GTK_TREE_MODEL_w, 1, 0, 0, "(GTK_TREE_MODEL obj) casts obj to GTK_TREE_MODEL", pl_bpt);
+ Xg_define_procedure(GTK_TREE_MODEL_SORT, gxg_GTK_TREE_MODEL_SORT_w, 1, 0, 0, "(GTK_TREE_MODEL_SORT obj) casts obj to GTK_TREE_MODEL_SORT", pl_bpt);
+ Xg_define_procedure(GTK_TREE_SELECTION, gxg_GTK_TREE_SELECTION_w, 1, 0, 0, "(GTK_TREE_SELECTION obj) casts obj to GTK_TREE_SELECTION", pl_bpt);
+ Xg_define_procedure(GTK_TREE_SORTABLE, gxg_GTK_TREE_SORTABLE_w, 1, 0, 0, "(GTK_TREE_SORTABLE obj) casts obj to GTK_TREE_SORTABLE", pl_bpt);
+ Xg_define_procedure(GTK_TREE_STORE, gxg_GTK_TREE_STORE_w, 1, 0, 0, "(GTK_TREE_STORE obj) casts obj to GTK_TREE_STORE", pl_bpt);
+ Xg_define_procedure(GTK_TREE_VIEW_COLUMN, gxg_GTK_TREE_VIEW_COLUMN_w, 1, 0, 0, "(GTK_TREE_VIEW_COLUMN obj) casts obj to GTK_TREE_VIEW_COLUMN", pl_bpt);
+ Xg_define_procedure(GTK_TREE_VIEW, gxg_GTK_TREE_VIEW_w, 1, 0, 0, "(GTK_TREE_VIEW obj) casts obj to GTK_TREE_VIEW", pl_bpt);
+ Xg_define_procedure(GTK_VIEWPORT, gxg_GTK_VIEWPORT_w, 1, 0, 0, "(GTK_VIEWPORT obj) casts obj to GTK_VIEWPORT", pl_bpt);
+ Xg_define_procedure(GTK_WIDGET, gxg_GTK_WIDGET_w, 1, 0, 0, "(GTK_WIDGET obj) casts obj to GTK_WIDGET", pl_bpt);
+ Xg_define_procedure(GTK_WINDOW, gxg_GTK_WINDOW_w, 1, 0, 0, "(GTK_WINDOW obj) casts obj to GTK_WINDOW", pl_bpt);
+ Xg_define_procedure(PANGO_CONTEXT, gxg_PANGO_CONTEXT_w, 1, 0, 0, "(PANGO_CONTEXT obj) casts obj to PANGO_CONTEXT", pl_bpt);
+ Xg_define_procedure(PANGO_FONT_FAMILY, gxg_PANGO_FONT_FAMILY_w, 1, 0, 0, "(PANGO_FONT_FAMILY obj) casts obj to PANGO_FONT_FAMILY", pl_bpt);
+ Xg_define_procedure(PANGO_FONT_FACE, gxg_PANGO_FONT_FACE_w, 1, 0, 0, "(PANGO_FONT_FACE obj) casts obj to PANGO_FONT_FACE", pl_bpt);
+ Xg_define_procedure(PANGO_FONT, gxg_PANGO_FONT_w, 1, 0, 0, "(PANGO_FONT obj) casts obj to PANGO_FONT", pl_bpt);
+ Xg_define_procedure(PANGO_FONT_MAP, gxg_PANGO_FONT_MAP_w, 1, 0, 0, "(PANGO_FONT_MAP obj) casts obj to PANGO_FONT_MAP", pl_bpt);
+ Xg_define_procedure(PANGO_LAYOUT, gxg_PANGO_LAYOUT_w, 1, 0, 0, "(PANGO_LAYOUT obj) casts obj to PANGO_LAYOUT", pl_bpt);
+ Xg_define_procedure(G_OBJECT, gxg_G_OBJECT_w, 1, 0, 0, "(G_OBJECT obj) casts obj to G_OBJECT", pl_bpt);
+ Xg_define_procedure(GDK_SCREEN, gxg_GDK_SCREEN_w, 1, 0, 0, "(GDK_SCREEN obj) casts obj to GDK_SCREEN", pl_bpt);
+ Xg_define_procedure(GDK_DISPLAY_OBJECT, gxg_GDK_DISPLAY_OBJECT_w, 1, 0, 0, "(GDK_DISPLAY_OBJECT obj) casts obj to GDK_DISPLAY_OBJECT", pl_bpt);
+ Xg_define_procedure(GDK_EVENT, gxg_GDK_EVENT_w, 1, 0, 0, "(GDK_EVENT obj) casts obj to GDK_EVENT", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_ANY, gxg_GDK_EVENT_ANY_w, 1, 0, 0, "(GDK_EVENT_ANY obj) casts obj to GDK_EVENT_ANY", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_EXPOSE, gxg_GDK_EVENT_EXPOSE_w, 1, 0, 0, "(GDK_EVENT_EXPOSE obj) casts obj to GDK_EVENT_EXPOSE", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_NOEXPOSE, gxg_GDK_EVENT_NOEXPOSE_w, 1, 0, 0, "(GDK_EVENT_NOEXPOSE obj) casts obj to GDK_EVENT_NOEXPOSE", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_VISIBILITY, gxg_GDK_EVENT_VISIBILITY_w, 1, 0, 0, "(GDK_EVENT_VISIBILITY obj) casts obj to GDK_EVENT_VISIBILITY", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_MOTION, gxg_GDK_EVENT_MOTION_w, 1, 0, 0, "(GDK_EVENT_MOTION obj) casts obj to GDK_EVENT_MOTION", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_BUTTON, gxg_GDK_EVENT_BUTTON_w, 1, 0, 0, "(GDK_EVENT_BUTTON obj) casts obj to GDK_EVENT_BUTTON", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_SCROLL, gxg_GDK_EVENT_SCROLL_w, 1, 0, 0, "(GDK_EVENT_SCROLL obj) casts obj to GDK_EVENT_SCROLL", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_KEY, gxg_GDK_EVENT_KEY_w, 1, 0, 0, "(GDK_EVENT_KEY obj) casts obj to GDK_EVENT_KEY", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_CROSSING, gxg_GDK_EVENT_CROSSING_w, 1, 0, 0, "(GDK_EVENT_CROSSING obj) casts obj to GDK_EVENT_CROSSING", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_FOCUS, gxg_GDK_EVENT_FOCUS_w, 1, 0, 0, "(GDK_EVENT_FOCUS obj) casts obj to GDK_EVENT_FOCUS", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_CONFIGURE, gxg_GDK_EVENT_CONFIGURE_w, 1, 0, 0, "(GDK_EVENT_CONFIGURE obj) casts obj to GDK_EVENT_CONFIGURE", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_PROPERTY, gxg_GDK_EVENT_PROPERTY_w, 1, 0, 0, "(GDK_EVENT_PROPERTY obj) casts obj to GDK_EVENT_PROPERTY", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_SELECTION, gxg_GDK_EVENT_SELECTION_w, 1, 0, 0, "(GDK_EVENT_SELECTION obj) casts obj to GDK_EVENT_SELECTION", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_PROXIMITY, gxg_GDK_EVENT_PROXIMITY_w, 1, 0, 0, "(GDK_EVENT_PROXIMITY obj) casts obj to GDK_EVENT_PROXIMITY", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_SETTING, gxg_GDK_EVENT_SETTING_w, 1, 0, 0, "(GDK_EVENT_SETTING obj) casts obj to GDK_EVENT_SETTING", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_WINDOWSTATE, gxg_GDK_EVENT_WINDOWSTATE_w, 1, 0, 0, "(GDK_EVENT_WINDOWSTATE obj) casts obj to GDK_EVENT_WINDOWSTATE", pl_bpt);
+ Xg_define_procedure(GDK_EVENT_DND, gxg_GDK_EVENT_DND_w, 1, 0, 0, "(GDK_EVENT_DND obj) casts obj to GDK_EVENT_DND", pl_bpt);
+ Xg_define_procedure(GTK_FILE_CHOOSER_DIALOG, gxg_GTK_FILE_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_FILE_CHOOSER_DIALOG obj) casts obj to GTK_FILE_CHOOSER_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_FILE_CHOOSER_WIDGET, gxg_GTK_FILE_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_FILE_CHOOSER_WIDGET obj) casts obj to GTK_FILE_CHOOSER_WIDGET", pl_bpt);
+ Xg_define_procedure(GTK_TREE_MODEL_FILTER, gxg_GTK_TREE_MODEL_FILTER_w, 1, 0, 0, "(GTK_TREE_MODEL_FILTER obj) casts obj to GTK_TREE_MODEL_FILTER", pl_bpt);
+ Xg_define_procedure(GTK_COMBO_BOX, gxg_GTK_COMBO_BOX_w, 1, 0, 0, "(GTK_COMBO_BOX obj) casts obj to GTK_COMBO_BOX", pl_bpt);
+ Xg_define_procedure(GTK_EXPANDER, gxg_GTK_EXPANDER_w, 1, 0, 0, "(GTK_EXPANDER obj) casts obj to GTK_EXPANDER", pl_bpt);
+ Xg_define_procedure(GTK_FONT_BUTTON, gxg_GTK_FONT_BUTTON_w, 1, 0, 0, "(GTK_FONT_BUTTON obj) casts obj to GTK_FONT_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_COLOR_BUTTON, gxg_GTK_COLOR_BUTTON_w, 1, 0, 0, "(GTK_COLOR_BUTTON obj) casts obj to GTK_COLOR_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_ENTRY_COMPLETION, gxg_GTK_ENTRY_COMPLETION_w, 1, 0, 0, "(GTK_ENTRY_COMPLETION obj) casts obj to GTK_ENTRY_COMPLETION", pl_bpt);
+ Xg_define_procedure(GTK_RADIO_TOOL_BUTTON, gxg_GTK_RADIO_TOOL_BUTTON_w, 1, 0, 0, "(GTK_RADIO_TOOL_BUTTON obj) casts obj to GTK_RADIO_TOOL_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_SEPARATOR_TOOL_ITEM, gxg_GTK_SEPARATOR_TOOL_ITEM_w, 1, 0, 0, "(GTK_SEPARATOR_TOOL_ITEM obj) casts obj to GTK_SEPARATOR_TOOL_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_TOGGLE_TOOL_BUTTON, gxg_GTK_TOGGLE_TOOL_BUTTON_w, 1, 0, 0, "(GTK_TOGGLE_TOOL_BUTTON obj) casts obj to GTK_TOGGLE_TOOL_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_FILE_FILTER, gxg_GTK_FILE_FILTER_w, 1, 0, 0, "(GTK_FILE_FILTER obj) casts obj to GTK_FILE_FILTER", pl_bpt);
+ Xg_define_procedure(GTK_CELL_LAYOUT, gxg_GTK_CELL_LAYOUT_w, 1, 0, 0, "(GTK_CELL_LAYOUT obj) casts obj to GTK_CELL_LAYOUT", pl_bpt);
+ Xg_define_procedure(GTK_CLIPBOARD, gxg_GTK_CLIPBOARD_w, 1, 0, 0, "(GTK_CLIPBOARD obj) casts obj to GTK_CLIPBOARD", pl_bpt);
+ Xg_define_procedure(GTK_FILE_CHOOSER, gxg_GTK_FILE_CHOOSER_w, 1, 0, 0, "(GTK_FILE_CHOOSER obj) casts obj to GTK_FILE_CHOOSER", pl_bpt);
+ Xg_define_procedure(GTK_ICON_THEME, gxg_GTK_ICON_THEME_w, 1, 0, 0, "(GTK_ICON_THEME obj) casts obj to GTK_ICON_THEME", pl_bpt);
+ Xg_define_procedure(GTK_TOOL_BUTTON, gxg_GTK_TOOL_BUTTON_w, 1, 0, 0, "(GTK_TOOL_BUTTON obj) casts obj to GTK_TOOL_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_TOOL_ITEM, gxg_GTK_TOOL_ITEM_w, 1, 0, 0, "(GTK_TOOL_ITEM obj) casts obj to GTK_TOOL_ITEM", pl_bpt);
+ Xg_define_procedure(GTK_ACCEL_MAP, gxg_GTK_ACCEL_MAP_w, 1, 0, 0, "(GTK_ACCEL_MAP obj) casts obj to GTK_ACCEL_MAP", pl_bpt);
+ Xg_define_procedure(GTK_CELL_VIEW, gxg_GTK_CELL_VIEW_w, 1, 0, 0, "(GTK_CELL_VIEW obj) casts obj to GTK_CELL_VIEW", pl_bpt);
+ Xg_define_procedure(GTK_ABOUT_DIALOG, gxg_GTK_ABOUT_DIALOG_w, 1, 0, 0, "(GTK_ABOUT_DIALOG obj) casts obj to GTK_ABOUT_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_COMBO, gxg_GTK_CELL_RENDERER_COMBO_w, 1, 0, 0, "(GTK_CELL_RENDERER_COMBO obj) casts obj to GTK_CELL_RENDERER_COMBO", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_PROGRESS, gxg_GTK_CELL_RENDERER_PROGRESS_w, 1, 0, 0, "(GTK_CELL_RENDERER_PROGRESS obj) casts obj to GTK_CELL_RENDERER_PROGRESS", pl_bpt);
+ Xg_define_procedure(GTK_ICON_VIEW, gxg_GTK_ICON_VIEW_w, 1, 0, 0, "(GTK_ICON_VIEW obj) casts obj to GTK_ICON_VIEW", pl_bpt);
+ Xg_define_procedure(GTK_FILE_CHOOSER_BUTTON, gxg_GTK_FILE_CHOOSER_BUTTON_w, 1, 0, 0, "(GTK_FILE_CHOOSER_BUTTON obj) casts obj to GTK_FILE_CHOOSER_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_MENU_TOOL_BUTTON, gxg_GTK_MENU_TOOL_BUTTON_w, 1, 0, 0, "(GTK_MENU_TOOL_BUTTON obj) casts obj to GTK_MENU_TOOL_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_ASSISTANT, gxg_GTK_ASSISTANT_w, 1, 0, 0, "(GTK_ASSISTANT obj) casts obj to GTK_ASSISTANT", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_ACCEL, gxg_GTK_CELL_RENDERER_ACCEL_w, 1, 0, 0, "(GTK_CELL_RENDERER_ACCEL obj) casts obj to GTK_CELL_RENDERER_ACCEL", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_SPIN, gxg_GTK_CELL_RENDERER_SPIN_w, 1, 0, 0, "(GTK_CELL_RENDERER_SPIN obj) casts obj to GTK_CELL_RENDERER_SPIN", pl_bpt);
+ Xg_define_procedure(GTK_LINK_BUTTON, gxg_GTK_LINK_BUTTON_w, 1, 0, 0, "(GTK_LINK_BUTTON obj) casts obj to GTK_LINK_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_CHOOSER_DIALOG, gxg_GTK_RECENT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_DIALOG obj) casts obj to GTK_RECENT_CHOOSER_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_CHOOSER, gxg_GTK_RECENT_CHOOSER_w, 1, 0, 0, "(GTK_RECENT_CHOOSER obj) casts obj to GTK_RECENT_CHOOSER", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_CHOOSER_MENU, gxg_GTK_RECENT_CHOOSER_MENU_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_MENU obj) casts obj to GTK_RECENT_CHOOSER_MENU", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_CHOOSER_WIDGET, gxg_GTK_RECENT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_RECENT_CHOOSER_WIDGET obj) casts obj to GTK_RECENT_CHOOSER_WIDGET", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_FILTER, gxg_GTK_RECENT_FILTER_w, 1, 0, 0, "(GTK_RECENT_FILTER obj) casts obj to GTK_RECENT_FILTER", pl_bpt);
+ Xg_define_procedure(GTK_RECENT_MANAGER, gxg_GTK_RECENT_MANAGER_w, 1, 0, 0, "(GTK_RECENT_MANAGER obj) casts obj to GTK_RECENT_MANAGER", pl_bpt);
+ Xg_define_procedure(GTK_PRINT_CONTEXT, gxg_GTK_PRINT_CONTEXT_w, 1, 0, 0, "(GTK_PRINT_CONTEXT obj) casts obj to GTK_PRINT_CONTEXT", pl_bpt);
+ Xg_define_procedure(GTK_PRINT_OPERATION, gxg_GTK_PRINT_OPERATION_w, 1, 0, 0, "(GTK_PRINT_OPERATION obj) casts obj to GTK_PRINT_OPERATION", pl_bpt);
+ Xg_define_procedure(GTK_PRINT_OPERATION_PREVIEW, gxg_GTK_PRINT_OPERATION_PREVIEW_w, 1, 0, 0, "(GTK_PRINT_OPERATION_PREVIEW obj) casts obj to GTK_PRINT_OPERATION_PREVIEW", pl_bpt);
+ Xg_define_procedure(GTK_PRINT_SETTINGS, gxg_GTK_PRINT_SETTINGS_w, 1, 0, 0, "(GTK_PRINT_SETTINGS obj) casts obj to GTK_PRINT_SETTINGS", pl_bpt);
+ Xg_define_procedure(GTK_TOOLTIP, gxg_GTK_TOOLTIP_w, 1, 0, 0, "(GTK_TOOLTIP obj) casts obj to GTK_TOOLTIP", pl_bpt);
#if GTK_CHECK_VERSION(2, 18, 0)
- Xg_define_procedure(GTK_INFO_BAR, gxg_GTK_INFO_BAR_w, 1, 0, 0, "(GTK_INFO_BAR obj) casts obj to GTK_INFO_BAR", NULL);
- Xg_define_procedure(GTK_ENTRY_BUFFER, gxg_GTK_ENTRY_BUFFER_w, 1, 0, 0, "(GTK_ENTRY_BUFFER obj) casts obj to GTK_ENTRY_BUFFER", NULL);
+ Xg_define_procedure(GTK_INFO_BAR, gxg_GTK_INFO_BAR_w, 1, 0, 0, "(GTK_INFO_BAR obj) casts obj to GTK_INFO_BAR", pl_bpt);
+ Xg_define_procedure(GTK_ENTRY_BUFFER, gxg_GTK_ENTRY_BUFFER_w, 1, 0, 0, "(GTK_ENTRY_BUFFER obj) casts obj to GTK_ENTRY_BUFFER", pl_bpt);
#endif
#if GTK_CHECK_VERSION(2, 20, 0)
- Xg_define_procedure(GTK_SPINNER, gxg_GTK_SPINNER_w, 1, 0, 0, "(GTK_SPINNER obj) casts obj to GTK_SPINNER", NULL);
- Xg_define_procedure(GTK_CELL_RENDERER_SPINNER, gxg_GTK_CELL_RENDERER_SPINNER_w, 1, 0, 0, "(GTK_CELL_RENDERER_SPINNER obj) casts obj to GTK_CELL_RENDERER_SPINNER", NULL);
- Xg_define_procedure(GTK_TOOL_PALETTE, gxg_GTK_TOOL_PALETTE_w, 1, 0, 0, "(GTK_TOOL_PALETTE obj) casts obj to GTK_TOOL_PALETTE", NULL);
- Xg_define_procedure(GTK_TOOL_ITEM_GROUP, gxg_GTK_TOOL_ITEM_GROUP_w, 1, 0, 0, "(GTK_TOOL_ITEM_GROUP obj) casts obj to GTK_TOOL_ITEM_GROUP", NULL);
+ Xg_define_procedure(GTK_SPINNER, gxg_GTK_SPINNER_w, 1, 0, 0, "(GTK_SPINNER obj) casts obj to GTK_SPINNER", pl_bpt);
+ Xg_define_procedure(GTK_CELL_RENDERER_SPINNER, gxg_GTK_CELL_RENDERER_SPINNER_w, 1, 0, 0, "(GTK_CELL_RENDERER_SPINNER obj) casts obj to GTK_CELL_RENDERER_SPINNER", pl_bpt);
+ Xg_define_procedure(GTK_TOOL_PALETTE, gxg_GTK_TOOL_PALETTE_w, 1, 0, 0, "(GTK_TOOL_PALETTE obj) casts obj to GTK_TOOL_PALETTE", pl_bpt);
+ Xg_define_procedure(GTK_TOOL_ITEM_GROUP, gxg_GTK_TOOL_ITEM_GROUP_w, 1, 0, 0, "(GTK_TOOL_ITEM_GROUP obj) casts obj to GTK_TOOL_ITEM_GROUP", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 0, 0)
- Xg_define_procedure(GTK_COMBO_BOX_TEXT, gxg_GTK_COMBO_BOX_TEXT_w, 1, 0, 0, "(GTK_COMBO_BOX_TEXT obj) casts obj to GTK_COMBO_BOX_TEXT", NULL);
- Xg_define_procedure(GTK_GRID, gxg_GTK_GRID_w, 1, 0, 0, "(GTK_GRID obj) casts obj to GTK_GRID", NULL);
- Xg_define_procedure(GTK_SCROLLABLE, gxg_GTK_SCROLLABLE_w, 1, 0, 0, "(GTK_SCROLLABLE obj) casts obj to GTK_SCROLLABLE", NULL);
- Xg_define_procedure(GDK_RGBA, gxg_GDK_RGBA_w, 1, 0, 0, "(GDK_RGBA obj) casts obj to GDK_RGBA", NULL);
- Xg_define_procedure(GTK_SWITCH, gxg_GTK_SWITCH_w, 1, 0, 0, "(GTK_SWITCH obj) casts obj to GTK_SWITCH", NULL);
- Xg_define_procedure(GTK_ORIENTABLE, gxg_GTK_ORIENTABLE_w, 1, 0, 0, "(GTK_ORIENTABLE obj) casts obj to GTK_ORIENTABLE", NULL);
- Xg_define_procedure(GTK_WINDOW_GROUP, gxg_GTK_WINDOW_GROUP_w, 1, 0, 0, "(GTK_WINDOW_GROUP obj) casts obj to GTK_WINDOW_GROUP", NULL);
- Xg_define_procedure(GTK_TOOL_SHELL, gxg_GTK_TOOL_SHELL_w, 1, 0, 0, "(GTK_TOOL_SHELL obj) casts obj to GTK_TOOL_SHELL", NULL);
+ Xg_define_procedure(GTK_COMBO_BOX_TEXT, gxg_GTK_COMBO_BOX_TEXT_w, 1, 0, 0, "(GTK_COMBO_BOX_TEXT obj) casts obj to GTK_COMBO_BOX_TEXT", pl_bpt);
+ Xg_define_procedure(GTK_GRID, gxg_GTK_GRID_w, 1, 0, 0, "(GTK_GRID obj) casts obj to GTK_GRID", pl_bpt);
+ Xg_define_procedure(GTK_SCROLLABLE, gxg_GTK_SCROLLABLE_w, 1, 0, 0, "(GTK_SCROLLABLE obj) casts obj to GTK_SCROLLABLE", pl_bpt);
+ Xg_define_procedure(GDK_RGBA, gxg_GDK_RGBA_w, 1, 0, 0, "(GDK_RGBA obj) casts obj to GDK_RGBA", pl_bpt);
+ Xg_define_procedure(GTK_SWITCH, gxg_GTK_SWITCH_w, 1, 0, 0, "(GTK_SWITCH obj) casts obj to GTK_SWITCH", pl_bpt);
+ Xg_define_procedure(GTK_ORIENTABLE, gxg_GTK_ORIENTABLE_w, 1, 0, 0, "(GTK_ORIENTABLE obj) casts obj to GTK_ORIENTABLE", pl_bpt);
+ Xg_define_procedure(GTK_WINDOW_GROUP, gxg_GTK_WINDOW_GROUP_w, 1, 0, 0, "(GTK_WINDOW_GROUP obj) casts obj to GTK_WINDOW_GROUP", pl_bpt);
+ Xg_define_procedure(GTK_TOOL_SHELL, gxg_GTK_TOOL_SHELL_w, 1, 0, 0, "(GTK_TOOL_SHELL obj) casts obj to GTK_TOOL_SHELL", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 2, 0)
- Xg_define_procedure(GTK_OVERLAY, gxg_GTK_OVERLAY_w, 1, 0, 0, "(GTK_OVERLAY obj) casts obj to GTK_OVERLAY", NULL);
- Xg_define_procedure(GTK_FONT_CHOOSER, gxg_GTK_FONT_CHOOSER_w, 1, 0, 0, "(GTK_FONT_CHOOSER obj) casts obj to GTK_FONT_CHOOSER", NULL);
- Xg_define_procedure(GTK_FONT_CHOOSER_DIALOG, gxg_GTK_FONT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_FONT_CHOOSER_DIALOG obj) casts obj to GTK_FONT_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_FONT_CHOOSER_WIDGET, gxg_GTK_FONT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_FONT_CHOOSER_WIDGET obj) casts obj to GTK_FONT_CHOOSER_WIDGET", NULL);
+ Xg_define_procedure(GTK_OVERLAY, gxg_GTK_OVERLAY_w, 1, 0, 0, "(GTK_OVERLAY obj) casts obj to GTK_OVERLAY", pl_bpt);
+ Xg_define_procedure(GTK_FONT_CHOOSER, gxg_GTK_FONT_CHOOSER_w, 1, 0, 0, "(GTK_FONT_CHOOSER obj) casts obj to GTK_FONT_CHOOSER", pl_bpt);
+ Xg_define_procedure(GTK_FONT_CHOOSER_DIALOG, gxg_GTK_FONT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_FONT_CHOOSER_DIALOG obj) casts obj to GTK_FONT_CHOOSER_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_FONT_CHOOSER_WIDGET, gxg_GTK_FONT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_FONT_CHOOSER_WIDGET obj) casts obj to GTK_FONT_CHOOSER_WIDGET", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
- Xg_define_procedure(GTK_APPLICATION_WINDOW, gxg_GTK_APPLICATION_WINDOW_w, 1, 0, 0, "(GTK_APPLICATION_WINDOW obj) casts obj to GTK_APPLICATION_WINDOW", NULL);
- Xg_define_procedure(GTK_COLOR_CHOOSER_DIALOG, gxg_GTK_COLOR_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_COLOR_CHOOSER_DIALOG obj) casts obj to GTK_COLOR_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_COLOR_CHOOSER_WIDGET, gxg_GTK_COLOR_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_COLOR_CHOOSER_WIDGET obj) casts obj to GTK_COLOR_CHOOSER_WIDGET", NULL);
+ Xg_define_procedure(GTK_APPLICATION_WINDOW, gxg_GTK_APPLICATION_WINDOW_w, 1, 0, 0, "(GTK_APPLICATION_WINDOW obj) casts obj to GTK_APPLICATION_WINDOW", pl_bpt);
+ Xg_define_procedure(GTK_COLOR_CHOOSER_DIALOG, gxg_GTK_COLOR_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_COLOR_CHOOSER_DIALOG obj) casts obj to GTK_COLOR_CHOOSER_DIALOG", pl_bpt);
+ Xg_define_procedure(GTK_COLOR_CHOOSER_WIDGET, gxg_GTK_COLOR_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_COLOR_CHOOSER_WIDGET obj) casts obj to GTK_COLOR_CHOOSER_WIDGET", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
- Xg_define_procedure(GTK_MENU_BUTTON, gxg_GTK_MENU_BUTTON_w, 1, 0, 0, "(GTK_MENU_BUTTON obj) casts obj to GTK_MENU_BUTTON", NULL);
- Xg_define_procedure(GTK_SEARCH_ENTRY, gxg_GTK_SEARCH_ENTRY_w, 1, 0, 0, "(GTK_SEARCH_ENTRY obj) casts obj to GTK_SEARCH_ENTRY", NULL);
- Xg_define_procedure(GTK_LEVEL_BAR, gxg_GTK_LEVEL_BAR_w, 1, 0, 0, "(GTK_LEVEL_BAR obj) casts obj to GTK_LEVEL_BAR", NULL);
+ Xg_define_procedure(GTK_MENU_BUTTON, gxg_GTK_MENU_BUTTON_w, 1, 0, 0, "(GTK_MENU_BUTTON obj) casts obj to GTK_MENU_BUTTON", pl_bpt);
+ Xg_define_procedure(GTK_SEARCH_ENTRY, gxg_GTK_SEARCH_ENTRY_w, 1, 0, 0, "(GTK_SEARCH_ENTRY obj) casts obj to GTK_SEARCH_ENTRY", pl_bpt);
+ Xg_define_procedure(GTK_LEVEL_BAR, gxg_GTK_LEVEL_BAR_w, 1, 0, 0, "(GTK_LEVEL_BAR obj) casts obj to GTK_LEVEL_BAR", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- Xg_define_procedure(GTK_PLACES_SIDEBAR, gxg_GTK_PLACES_SIDEBAR_w, 1, 0, 0, "(GTK_PLACES_SIDEBAR obj) casts obj to GTK_PLACES_SIDEBAR", NULL);
- Xg_define_procedure(GTK_STACK_SWITCHER, gxg_GTK_STACK_SWITCHER_w, 1, 0, 0, "(GTK_STACK_SWITCHER obj) casts obj to GTK_STACK_SWITCHER", NULL);
- Xg_define_procedure(GTK_STACK, gxg_GTK_STACK_w, 1, 0, 0, "(GTK_STACK obj) casts obj to GTK_STACK", NULL);
- Xg_define_procedure(GTK_REVEALER, gxg_GTK_REVEALER_w, 1, 0, 0, "(GTK_REVEALER obj) casts obj to GTK_REVEALER", NULL);
- Xg_define_procedure(GTK_HEADER_BAR, gxg_GTK_HEADER_BAR_w, 1, 0, 0, "(GTK_HEADER_BAR obj) casts obj to GTK_HEADER_BAR", NULL);
- Xg_define_procedure(GTK_LIST_BOX, gxg_GTK_LIST_BOX_w, 1, 0, 0, "(GTK_LIST_BOX obj) casts obj to GTK_LIST_BOX", NULL);
- Xg_define_procedure(GTK_LIST_BOX_ROW, gxg_GTK_LIST_BOX_ROW_w, 1, 0, 0, "(GTK_LIST_BOX_ROW obj) casts obj to GTK_LIST_BOX_ROW", NULL);
- Xg_define_procedure(GTK_SEARCH_BAR, gxg_GTK_SEARCH_BAR_w, 1, 0, 0, "(GTK_SEARCH_BAR obj) casts obj to GTK_SEARCH_BAR", NULL);
+ Xg_define_procedure(GTK_PLACES_SIDEBAR, gxg_GTK_PLACES_SIDEBAR_w, 1, 0, 0, "(GTK_PLACES_SIDEBAR obj) casts obj to GTK_PLACES_SIDEBAR", pl_bpt);
+ Xg_define_procedure(GTK_STACK_SWITCHER, gxg_GTK_STACK_SWITCHER_w, 1, 0, 0, "(GTK_STACK_SWITCHER obj) casts obj to GTK_STACK_SWITCHER", pl_bpt);
+ Xg_define_procedure(GTK_STACK, gxg_GTK_STACK_w, 1, 0, 0, "(GTK_STACK obj) casts obj to GTK_STACK", pl_bpt);
+ Xg_define_procedure(GTK_REVEALER, gxg_GTK_REVEALER_w, 1, 0, 0, "(GTK_REVEALER obj) casts obj to GTK_REVEALER", pl_bpt);
+ Xg_define_procedure(GTK_HEADER_BAR, gxg_GTK_HEADER_BAR_w, 1, 0, 0, "(GTK_HEADER_BAR obj) casts obj to GTK_HEADER_BAR", pl_bpt);
+ Xg_define_procedure(GTK_LIST_BOX, gxg_GTK_LIST_BOX_w, 1, 0, 0, "(GTK_LIST_BOX obj) casts obj to GTK_LIST_BOX", pl_bpt);
+ Xg_define_procedure(GTK_LIST_BOX_ROW, gxg_GTK_LIST_BOX_ROW_w, 1, 0, 0, "(GTK_LIST_BOX_ROW obj) casts obj to GTK_LIST_BOX_ROW", pl_bpt);
+ Xg_define_procedure(GTK_SEARCH_BAR, gxg_GTK_SEARCH_BAR_w, 1, 0, 0, "(GTK_SEARCH_BAR obj) casts obj to GTK_SEARCH_BAR", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 12, 0)
- Xg_define_procedure(GTK_FLOW_BOX, gxg_GTK_FLOW_BOX_w, 1, 0, 0, "(GTK_FLOW_BOX obj) casts obj to GTK_FLOW_BOX", NULL);
- Xg_define_procedure(GTK_FLOW_BOX_CHILD, gxg_GTK_FLOW_BOX_CHILD_w, 1, 0, 0, "(GTK_FLOW_BOX_CHILD obj) casts obj to GTK_FLOW_BOX_CHILD", NULL);
- Xg_define_procedure(GTK_ACTION_BAR, gxg_GTK_ACTION_BAR_w, 1, 0, 0, "(GTK_ACTION_BAR obj) casts obj to GTK_ACTION_BAR", NULL);
- Xg_define_procedure(GTK_POPOVER, gxg_GTK_POPOVER_w, 1, 0, 0, "(GTK_POPOVER obj) casts obj to GTK_POPOVER", NULL);
+ Xg_define_procedure(GTK_FLOW_BOX, gxg_GTK_FLOW_BOX_w, 1, 0, 0, "(GTK_FLOW_BOX obj) casts obj to GTK_FLOW_BOX", pl_bpt);
+ Xg_define_procedure(GTK_FLOW_BOX_CHILD, gxg_GTK_FLOW_BOX_CHILD_w, 1, 0, 0, "(GTK_FLOW_BOX_CHILD obj) casts obj to GTK_FLOW_BOX_CHILD", pl_bpt);
+ Xg_define_procedure(GTK_ACTION_BAR, gxg_GTK_ACTION_BAR_w, 1, 0, 0, "(GTK_ACTION_BAR obj) casts obj to GTK_ACTION_BAR", pl_bpt);
+ Xg_define_procedure(GTK_POPOVER, gxg_GTK_POPOVER_w, 1, 0, 0, "(GTK_POPOVER obj) casts obj to GTK_POPOVER", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 14, 0)
- Xg_define_procedure(GTK_GESTURE, gxg_GTK_GESTURE_w, 1, 0, 0, "(GTK_GESTURE obj) casts obj to GTK_GESTURE", NULL);
- Xg_define_procedure(GTK_GESTURE_DRAG, gxg_GTK_GESTURE_DRAG_w, 1, 0, 0, "(GTK_GESTURE_DRAG obj) casts obj to GTK_GESTURE_DRAG", NULL);
- Xg_define_procedure(GTK_GESTURE_LONG_PRESS, gxg_GTK_GESTURE_LONG_PRESS_w, 1, 0, 0, "(GTK_GESTURE_LONG_PRESS obj) casts obj to GTK_GESTURE_LONG_PRESS", NULL);
- Xg_define_procedure(GTK_GESTURE_ZOOM, gxg_GTK_GESTURE_ZOOM_w, 1, 0, 0, "(GTK_GESTURE_ZOOM obj) casts obj to GTK_GESTURE_ZOOM", NULL);
- Xg_define_procedure(GTK_GESTURE_SWIPE, gxg_GTK_GESTURE_SWIPE_w, 1, 0, 0, "(GTK_GESTURE_SWIPE obj) casts obj to GTK_GESTURE_SWIPE", NULL);
- Xg_define_procedure(GTK_GESTURE_SINGLE, gxg_GTK_GESTURE_SINGLE_w, 1, 0, 0, "(GTK_GESTURE_SINGLE obj) casts obj to GTK_GESTURE_SINGLE", NULL);
- Xg_define_procedure(GTK_GESTURE_PAN, gxg_GTK_GESTURE_PAN_w, 1, 0, 0, "(GTK_GESTURE_PAN obj) casts obj to GTK_GESTURE_PAN", NULL);
- Xg_define_procedure(GTK_GESTURE_MULTI_PRESS, gxg_GTK_GESTURE_MULTI_PRESS_w, 1, 0, 0, "(GTK_GESTURE_MULTI_PRESS obj) casts obj to GTK_GESTURE_MULTI_PRESS", NULL);
- Xg_define_procedure(GTK_GESTURE_ROTATE, gxg_GTK_GESTURE_ROTATE_w, 1, 0, 0, "(GTK_GESTURE_ROTATE obj) casts obj to GTK_GESTURE_ROTATE", NULL);
- Xg_define_procedure(GTK_EVENT_CONTROLLER, gxg_GTK_EVENT_CONTROLLER_w, 1, 0, 0, "(GTK_EVENT_CONTROLLER obj) casts obj to GTK_EVENT_CONTROLLER", NULL);
+ Xg_define_procedure(GTK_GESTURE, gxg_GTK_GESTURE_w, 1, 0, 0, "(GTK_GESTURE obj) casts obj to GTK_GESTURE", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_DRAG, gxg_GTK_GESTURE_DRAG_w, 1, 0, 0, "(GTK_GESTURE_DRAG obj) casts obj to GTK_GESTURE_DRAG", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_LONG_PRESS, gxg_GTK_GESTURE_LONG_PRESS_w, 1, 0, 0, "(GTK_GESTURE_LONG_PRESS obj) casts obj to GTK_GESTURE_LONG_PRESS", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_ZOOM, gxg_GTK_GESTURE_ZOOM_w, 1, 0, 0, "(GTK_GESTURE_ZOOM obj) casts obj to GTK_GESTURE_ZOOM", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_SWIPE, gxg_GTK_GESTURE_SWIPE_w, 1, 0, 0, "(GTK_GESTURE_SWIPE obj) casts obj to GTK_GESTURE_SWIPE", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_SINGLE, gxg_GTK_GESTURE_SINGLE_w, 1, 0, 0, "(GTK_GESTURE_SINGLE obj) casts obj to GTK_GESTURE_SINGLE", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_PAN, gxg_GTK_GESTURE_PAN_w, 1, 0, 0, "(GTK_GESTURE_PAN obj) casts obj to GTK_GESTURE_PAN", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_MULTI_PRESS, gxg_GTK_GESTURE_MULTI_PRESS_w, 1, 0, 0, "(GTK_GESTURE_MULTI_PRESS obj) casts obj to GTK_GESTURE_MULTI_PRESS", pl_bpt);
+ Xg_define_procedure(GTK_GESTURE_ROTATE, gxg_GTK_GESTURE_ROTATE_w, 1, 0, 0, "(GTK_GESTURE_ROTATE obj) casts obj to GTK_GESTURE_ROTATE", pl_bpt);
+ Xg_define_procedure(GTK_EVENT_CONTROLLER, gxg_GTK_EVENT_CONTROLLER_w, 1, 0, 0, "(GTK_EVENT_CONTROLLER obj) casts obj to GTK_EVENT_CONTROLLER", pl_bpt);
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
- Xg_define_procedure(GTK_GL_AREA, gxg_GTK_GL_AREA_w, 1, 0, 0, "(GTK_GL_AREA obj) casts obj to GTK_GL_AREA", NULL);
- Xg_define_procedure(GDK_GL_CONTEXT, gxg_GDK_GL_CONTEXT_w, 1, 0, 0, "(GDK_GL_CONTEXT obj) casts obj to GDK_GL_CONTEXT", NULL);
- Xg_define_procedure(GTK_POPOVER_MENU, gxg_GTK_POPOVER_MENU_w, 1, 0, 0, "(GTK_POPOVER_MENU obj) casts obj to GTK_POPOVER_MENU", NULL);
- Xg_define_procedure(GTK_STACK_SIDEBAR, gxg_GTK_STACK_SIDEBAR_w, 1, 0, 0, "(GTK_STACK_SIDEBAR obj) casts obj to GTK_STACK_SIDEBAR", NULL);
+ Xg_define_procedure(GTK_GL_AREA, gxg_GTK_GL_AREA_w, 1, 0, 0, "(GTK_GL_AREA obj) casts obj to GTK_GL_AREA", pl_bpt);
+ Xg_define_procedure(GDK_GL_CONTEXT, gxg_GDK_GL_CONTEXT_w, 1, 0, 0, "(GDK_GL_CONTEXT obj) casts obj to GDK_GL_CONTEXT", pl_bpt);
+ Xg_define_procedure(GTK_POPOVER_MENU, gxg_GTK_POPOVER_MENU_w, 1, 0, 0, "(GTK_POPOVER_MENU obj) casts obj to GTK_POPOVER_MENU", pl_bpt);
+ Xg_define_procedure(GTK_STACK_SIDEBAR, gxg_GTK_STACK_SIDEBAR_w, 1, 0, 0, "(GTK_STACK_SIDEBAR obj) casts obj to GTK_STACK_SIDEBAR", pl_bpt);
+#endif
+
+#if GTK_CHECK_VERSION(3, 20, 0)
+ Xg_define_procedure(GDK_SEAT, gxg_GDK_SEAT_w, 1, 0, 0, "(GDK_SEAT obj) casts obj to GDK_SEAT", pl_bpt);
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+ Xg_define_procedure(GDK_DEVICE_TOOL, gxg_GDK_DEVICE_TOOL_w, 1, 0, 0, "(GDK_DEVICE_TOOL obj) casts obj to GDK_DEVICE_TOOL", pl_bpt);
#endif
Xg_define_procedure(c-array->list, c_array_to_xen_list_w, 2, 0, 0, NULL, NULL);
@@ -43586,212 +44045,400 @@ pl_unused = NULL;
Xg_define_procedure(gtk_event_keyval, xg_gtk_event_keyval_w, 1, 0, 0, NULL, NULL);
Xg_define_procedure(gtk_init, gxg_gtk_init_w, 0, 2, 0, H_gtk_init, NULL);
Xg_define_procedure(gtk_init_check, gxg_gtk_init_check_w, 0, 2, 0, H_gtk_init_check, NULL);
- Xg_define_procedure(GDK_IS_DRAG_CONTEXT, gxg_GDK_IS_DRAG_CONTEXT_w, 1, 0, 0, "(GDK_IS_DRAG_CONTEXT obj): " PROC_TRUE " if obj is a GDK_IS_DRAG_CONTEXT", NULL);
- Xg_define_procedure(GDK_IS_DEVICE, gxg_GDK_IS_DEVICE_w, 1, 0, 0, "(GDK_IS_DEVICE obj): " PROC_TRUE " if obj is a GDK_IS_DEVICE", NULL);
- Xg_define_procedure(GDK_IS_KEYMAP, gxg_GDK_IS_KEYMAP_w, 1, 0, 0, "(GDK_IS_KEYMAP obj): " PROC_TRUE " if obj is a GDK_IS_KEYMAP", NULL);
- Xg_define_procedure(GDK_IS_VISUAL, gxg_GDK_IS_VISUAL_w, 1, 0, 0, "(GDK_IS_VISUAL obj): " PROC_TRUE " if obj is a GDK_IS_VISUAL", NULL);
- Xg_define_procedure(GDK_IS_WINDOW, gxg_GDK_IS_WINDOW_w, 1, 0, 0, "(GDK_IS_WINDOW obj): " PROC_TRUE " if obj is a GDK_IS_WINDOW", NULL);
- Xg_define_procedure(GDK_IS_PIXBUF, gxg_GDK_IS_PIXBUF_w, 1, 0, 0, "(GDK_IS_PIXBUF obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF", NULL);
- Xg_define_procedure(GDK_IS_PIXBUF_ANIMATION, gxg_GDK_IS_PIXBUF_ANIMATION_w, 1, 0, 0, "(GDK_IS_PIXBUF_ANIMATION obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF_ANIMATION", NULL);
- Xg_define_procedure(GDK_IS_PIXBUF_ANIMATION_ITER, gxg_GDK_IS_PIXBUF_ANIMATION_ITER_w, 1, 0, 0, "(GDK_IS_PIXBUF_ANIMATION_ITER obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF_ANIMATION_ITER", NULL);
- Xg_define_procedure(GTK_IS_ACCEL_GROUP, gxg_GTK_IS_ACCEL_GROUP_w, 1, 0, 0, "(GTK_IS_ACCEL_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_GROUP", NULL);
- Xg_define_procedure(GTK_IS_ACCEL_LABEL, gxg_GTK_IS_ACCEL_LABEL_w, 1, 0, 0, "(GTK_IS_ACCEL_LABEL obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_LABEL", NULL);
- Xg_define_procedure(GTK_IS_ACCESSIBLE, gxg_GTK_IS_ACCESSIBLE_w, 1, 0, 0, "(GTK_IS_ACCESSIBLE obj): " PROC_TRUE " if obj is a GTK_IS_ACCESSIBLE", NULL);
- Xg_define_procedure(GTK_IS_ADJUSTMENT, gxg_GTK_IS_ADJUSTMENT_w, 1, 0, 0, "(GTK_IS_ADJUSTMENT obj): " PROC_TRUE " if obj is a GTK_IS_ADJUSTMENT", NULL);
- Xg_define_procedure(GTK_IS_ASPECT_FRAME, gxg_GTK_IS_ASPECT_FRAME_w, 1, 0, 0, "(GTK_IS_ASPECT_FRAME obj): " PROC_TRUE " if obj is a GTK_IS_ASPECT_FRAME", NULL);
- Xg_define_procedure(GTK_IS_BUTTON_BOX, gxg_GTK_IS_BUTTON_BOX_w, 1, 0, 0, "(GTK_IS_BUTTON_BOX obj): " PROC_TRUE " if obj is a GTK_IS_BUTTON_BOX", NULL);
- Xg_define_procedure(GTK_IS_BIN, gxg_GTK_IS_BIN_w, 1, 0, 0, "(GTK_IS_BIN obj): " PROC_TRUE " if obj is a GTK_IS_BIN", NULL);
- Xg_define_procedure(GTK_IS_BOX, gxg_GTK_IS_BOX_w, 1, 0, 0, "(GTK_IS_BOX obj): " PROC_TRUE " if obj is a GTK_IS_BOX", NULL);
- Xg_define_procedure(GTK_IS_BUTTON, gxg_GTK_IS_BUTTON_w, 1, 0, 0, "(GTK_IS_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_CALENDAR, gxg_GTK_IS_CALENDAR_w, 1, 0, 0, "(GTK_IS_CALENDAR obj): " PROC_TRUE " if obj is a GTK_IS_CALENDAR", NULL);
- Xg_define_procedure(GTK_IS_CELL_EDITABLE, gxg_GTK_IS_CELL_EDITABLE_w, 1, 0, 0, "(GTK_IS_CELL_EDITABLE obj): " PROC_TRUE " if obj is a GTK_IS_CELL_EDITABLE", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER, gxg_GTK_IS_CELL_RENDERER_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_PIXBUF, gxg_GTK_IS_CELL_RENDERER_PIXBUF_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_PIXBUF obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_PIXBUF", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_TEXT, gxg_GTK_IS_CELL_RENDERER_TEXT_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_TEXT obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_TEXT", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_TOGGLE, gxg_GTK_IS_CELL_RENDERER_TOGGLE_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_TOGGLE obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_TOGGLE", NULL);
- Xg_define_procedure(GTK_IS_CHECK_BUTTON, gxg_GTK_IS_CHECK_BUTTON_w, 1, 0, 0, "(GTK_IS_CHECK_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_CHECK_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_CHECK_MENU_ITEM, gxg_GTK_IS_CHECK_MENU_ITEM_w, 1, 0, 0, "(GTK_IS_CHECK_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_CHECK_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_IS_CONTAINER, gxg_GTK_IS_CONTAINER_w, 1, 0, 0, "(GTK_IS_CONTAINER obj): " PROC_TRUE " if obj is a GTK_IS_CONTAINER", NULL);
- Xg_define_procedure(GTK_IS_DIALOG, gxg_GTK_IS_DIALOG_w, 1, 0, 0, "(GTK_IS_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_DRAWING_AREA, gxg_GTK_IS_DRAWING_AREA_w, 1, 0, 0, "(GTK_IS_DRAWING_AREA obj): " PROC_TRUE " if obj is a GTK_IS_DRAWING_AREA", NULL);
- Xg_define_procedure(GTK_IS_EDITABLE, gxg_GTK_IS_EDITABLE_w, 1, 0, 0, "(GTK_IS_EDITABLE obj): " PROC_TRUE " if obj is a GTK_IS_EDITABLE", NULL);
- Xg_define_procedure(GTK_IS_ENTRY, gxg_GTK_IS_ENTRY_w, 1, 0, 0, "(GTK_IS_ENTRY obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY", NULL);
- Xg_define_procedure(GTK_IS_EVENT_BOX, gxg_GTK_IS_EVENT_BOX_w, 1, 0, 0, "(GTK_IS_EVENT_BOX obj): " PROC_TRUE " if obj is a GTK_IS_EVENT_BOX", NULL);
- Xg_define_procedure(GTK_IS_FIXED, gxg_GTK_IS_FIXED_w, 1, 0, 0, "(GTK_IS_FIXED obj): " PROC_TRUE " if obj is a GTK_IS_FIXED", NULL);
- Xg_define_procedure(GTK_IS_FRAME, gxg_GTK_IS_FRAME_w, 1, 0, 0, "(GTK_IS_FRAME obj): " PROC_TRUE " if obj is a GTK_IS_FRAME", NULL);
- Xg_define_procedure(GTK_IS_IMAGE, gxg_GTK_IS_IMAGE_w, 1, 0, 0, "(GTK_IS_IMAGE obj): " PROC_TRUE " if obj is a GTK_IS_IMAGE", NULL);
- Xg_define_procedure(GTK_IS_IM_CONTEXT, gxg_GTK_IS_IM_CONTEXT_w, 1, 0, 0, "(GTK_IS_IM_CONTEXT obj): " PROC_TRUE " if obj is a GTK_IS_IM_CONTEXT", NULL);
- Xg_define_procedure(GTK_IS_IM_CONTEXT_SIMPLE, gxg_GTK_IS_IM_CONTEXT_SIMPLE_w, 1, 0, 0, "(GTK_IS_IM_CONTEXT_SIMPLE obj): " PROC_TRUE " if obj is a GTK_IS_IM_CONTEXT_SIMPLE", NULL);
- Xg_define_procedure(GTK_IS_INVISIBLE, gxg_GTK_IS_INVISIBLE_w, 1, 0, 0, "(GTK_IS_INVISIBLE obj): " PROC_TRUE " if obj is a GTK_IS_INVISIBLE", NULL);
- Xg_define_procedure(GTK_IS_LABEL, gxg_GTK_IS_LABEL_w, 1, 0, 0, "(GTK_IS_LABEL obj): " PROC_TRUE " if obj is a GTK_IS_LABEL", NULL);
- Xg_define_procedure(GTK_IS_LAYOUT, gxg_GTK_IS_LAYOUT_w, 1, 0, 0, "(GTK_IS_LAYOUT obj): " PROC_TRUE " if obj is a GTK_IS_LAYOUT", NULL);
- Xg_define_procedure(GTK_IS_LIST_STORE, gxg_GTK_IS_LIST_STORE_w, 1, 0, 0, "(GTK_IS_LIST_STORE obj): " PROC_TRUE " if obj is a GTK_IS_LIST_STORE", NULL);
- Xg_define_procedure(GTK_IS_MENU_BAR, gxg_GTK_IS_MENU_BAR_w, 1, 0, 0, "(GTK_IS_MENU_BAR obj): " PROC_TRUE " if obj is a GTK_IS_MENU_BAR", NULL);
- Xg_define_procedure(GTK_IS_MENU, gxg_GTK_IS_MENU_w, 1, 0, 0, "(GTK_IS_MENU obj): " PROC_TRUE " if obj is a GTK_IS_MENU", NULL);
- Xg_define_procedure(GTK_IS_MENU_ITEM, gxg_GTK_IS_MENU_ITEM_w, 1, 0, 0, "(GTK_IS_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_IS_MENU_SHELL, gxg_GTK_IS_MENU_SHELL_w, 1, 0, 0, "(GTK_IS_MENU_SHELL obj): " PROC_TRUE " if obj is a GTK_IS_MENU_SHELL", NULL);
- Xg_define_procedure(GTK_IS_NOTEBOOK, gxg_GTK_IS_NOTEBOOK_w, 1, 0, 0, "(GTK_IS_NOTEBOOK obj): " PROC_TRUE " if obj is a GTK_IS_NOTEBOOK", NULL);
- Xg_define_procedure(GTK_IS_PANED, gxg_GTK_IS_PANED_w, 1, 0, 0, "(GTK_IS_PANED obj): " PROC_TRUE " if obj is a GTK_IS_PANED", NULL);
- Xg_define_procedure(GTK_IS_PROGRESS_BAR, gxg_GTK_IS_PROGRESS_BAR_w, 1, 0, 0, "(GTK_IS_PROGRESS_BAR obj): " PROC_TRUE " if obj is a GTK_IS_PROGRESS_BAR", NULL);
- Xg_define_procedure(GTK_IS_RADIO_BUTTON, gxg_GTK_IS_RADIO_BUTTON_w, 1, 0, 0, "(GTK_IS_RADIO_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_RADIO_MENU_ITEM, gxg_GTK_IS_RADIO_MENU_ITEM_w, 1, 0, 0, "(GTK_IS_RADIO_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_IS_RANGE, gxg_GTK_IS_RANGE_w, 1, 0, 0, "(GTK_IS_RANGE obj): " PROC_TRUE " if obj is a GTK_IS_RANGE", NULL);
- Xg_define_procedure(GTK_IS_SCALE, gxg_GTK_IS_SCALE_w, 1, 0, 0, "(GTK_IS_SCALE obj): " PROC_TRUE " if obj is a GTK_IS_SCALE", NULL);
- Xg_define_procedure(GTK_IS_SCROLLBAR, gxg_GTK_IS_SCROLLBAR_w, 1, 0, 0, "(GTK_IS_SCROLLBAR obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLBAR", NULL);
- Xg_define_procedure(GTK_IS_SCROLLED_WINDOW, gxg_GTK_IS_SCROLLED_WINDOW_w, 1, 0, 0, "(GTK_IS_SCROLLED_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLED_WINDOW", NULL);
- Xg_define_procedure(GTK_IS_SEPARATOR, gxg_GTK_IS_SEPARATOR_w, 1, 0, 0, "(GTK_IS_SEPARATOR obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR", NULL);
- Xg_define_procedure(GTK_IS_SEPARATOR_MENU_ITEM, gxg_GTK_IS_SEPARATOR_MENU_ITEM_w, 1, 0, 0, "(GTK_IS_SEPARATOR_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR_MENU_ITEM", NULL);
- Xg_define_procedure(GTK_IS_SETTINGS, gxg_GTK_IS_SETTINGS_w, 1, 0, 0, "(GTK_IS_SETTINGS obj): " PROC_TRUE " if obj is a GTK_IS_SETTINGS", NULL);
- Xg_define_procedure(GTK_IS_SIZE_GROUP, gxg_GTK_IS_SIZE_GROUP_w, 1, 0, 0, "(GTK_IS_SIZE_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_SIZE_GROUP", NULL);
- Xg_define_procedure(GTK_IS_SPIN_BUTTON, gxg_GTK_IS_SPIN_BUTTON_w, 1, 0, 0, "(GTK_IS_SPIN_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_SPIN_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_STATUSBAR, gxg_GTK_IS_STATUSBAR_w, 1, 0, 0, "(GTK_IS_STATUSBAR obj): " PROC_TRUE " if obj is a GTK_IS_STATUSBAR", NULL);
- Xg_define_procedure(GTK_IS_TEXT_BUFFER, gxg_GTK_IS_TEXT_BUFFER_w, 1, 0, 0, "(GTK_IS_TEXT_BUFFER obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_BUFFER", NULL);
- Xg_define_procedure(GTK_IS_TEXT_CHILD_ANCHOR, gxg_GTK_IS_TEXT_CHILD_ANCHOR_w, 1, 0, 0, "(GTK_IS_TEXT_CHILD_ANCHOR obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_CHILD_ANCHOR", NULL);
- Xg_define_procedure(GTK_IS_TEXT_MARK, gxg_GTK_IS_TEXT_MARK_w, 1, 0, 0, "(GTK_IS_TEXT_MARK obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_MARK", NULL);
- Xg_define_procedure(GTK_IS_TEXT_TAG, gxg_GTK_IS_TEXT_TAG_w, 1, 0, 0, "(GTK_IS_TEXT_TAG obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_TAG", NULL);
- Xg_define_procedure(GTK_IS_TEXT_TAG_TABLE, gxg_GTK_IS_TEXT_TAG_TABLE_w, 1, 0, 0, "(GTK_IS_TEXT_TAG_TABLE obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_TAG_TABLE", NULL);
- Xg_define_procedure(GTK_IS_TEXT_VIEW, gxg_GTK_IS_TEXT_VIEW_w, 1, 0, 0, "(GTK_IS_TEXT_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_VIEW", NULL);
- Xg_define_procedure(GTK_IS_TOGGLE_BUTTON, gxg_GTK_IS_TOGGLE_BUTTON_w, 1, 0, 0, "(GTK_IS_TOGGLE_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOGGLE_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_TOOLBAR, gxg_GTK_IS_TOOLBAR_w, 1, 0, 0, "(GTK_IS_TOOLBAR obj): " PROC_TRUE " if obj is a GTK_IS_TOOLBAR", NULL);
- Xg_define_procedure(GTK_IS_TREE_DRAG_SOURCE, gxg_GTK_IS_TREE_DRAG_SOURCE_w, 1, 0, 0, "(GTK_IS_TREE_DRAG_SOURCE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_DRAG_SOURCE", NULL);
- Xg_define_procedure(GTK_IS_TREE_DRAG_DEST, gxg_GTK_IS_TREE_DRAG_DEST_w, 1, 0, 0, "(GTK_IS_TREE_DRAG_DEST obj): " PROC_TRUE " if obj is a GTK_IS_TREE_DRAG_DEST", NULL);
- Xg_define_procedure(GTK_IS_TREE_MODEL, gxg_GTK_IS_TREE_MODEL_w, 1, 0, 0, "(GTK_IS_TREE_MODEL obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL", NULL);
- Xg_define_procedure(GTK_IS_TREE_MODEL_SORT, gxg_GTK_IS_TREE_MODEL_SORT_w, 1, 0, 0, "(GTK_IS_TREE_MODEL_SORT obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL_SORT", NULL);
- Xg_define_procedure(GTK_IS_TREE_SELECTION, gxg_GTK_IS_TREE_SELECTION_w, 1, 0, 0, "(GTK_IS_TREE_SELECTION obj): " PROC_TRUE " if obj is a GTK_IS_TREE_SELECTION", NULL);
- Xg_define_procedure(GTK_IS_TREE_SORTABLE, gxg_GTK_IS_TREE_SORTABLE_w, 1, 0, 0, "(GTK_IS_TREE_SORTABLE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_SORTABLE", NULL);
- Xg_define_procedure(GTK_IS_TREE_STORE, gxg_GTK_IS_TREE_STORE_w, 1, 0, 0, "(GTK_IS_TREE_STORE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_STORE", NULL);
- Xg_define_procedure(GTK_IS_TREE_VIEW_COLUMN, gxg_GTK_IS_TREE_VIEW_COLUMN_w, 1, 0, 0, "(GTK_IS_TREE_VIEW_COLUMN obj): " PROC_TRUE " if obj is a GTK_IS_TREE_VIEW_COLUMN", NULL);
- Xg_define_procedure(GTK_IS_TREE_VIEW, gxg_GTK_IS_TREE_VIEW_w, 1, 0, 0, "(GTK_IS_TREE_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_TREE_VIEW", NULL);
- Xg_define_procedure(GTK_IS_VIEWPORT, gxg_GTK_IS_VIEWPORT_w, 1, 0, 0, "(GTK_IS_VIEWPORT obj): " PROC_TRUE " if obj is a GTK_IS_VIEWPORT", NULL);
- Xg_define_procedure(GTK_IS_WIDGET, gxg_GTK_IS_WIDGET_w, 1, 0, 0, "(GTK_IS_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_WIDGET", NULL);
- Xg_define_procedure(GTK_IS_WINDOW, gxg_GTK_IS_WINDOW_w, 1, 0, 0, "(GTK_IS_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_WINDOW", NULL);
- Xg_define_procedure(PANGO_IS_CONTEXT, gxg_PANGO_IS_CONTEXT_w, 1, 0, 0, "(PANGO_IS_CONTEXT obj): " PROC_TRUE " if obj is a PANGO_IS_CONTEXT", NULL);
- Xg_define_procedure(PANGO_IS_FONT_FAMILY, gxg_PANGO_IS_FONT_FAMILY_w, 1, 0, 0, "(PANGO_IS_FONT_FAMILY obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_FAMILY", NULL);
- Xg_define_procedure(PANGO_IS_FONT_FACE, gxg_PANGO_IS_FONT_FACE_w, 1, 0, 0, "(PANGO_IS_FONT_FACE obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_FACE", NULL);
- Xg_define_procedure(PANGO_IS_FONT, gxg_PANGO_IS_FONT_w, 1, 0, 0, "(PANGO_IS_FONT obj): " PROC_TRUE " if obj is a PANGO_IS_FONT", NULL);
- Xg_define_procedure(PANGO_IS_FONT_MAP, gxg_PANGO_IS_FONT_MAP_w, 1, 0, 0, "(PANGO_IS_FONT_MAP obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_MAP", NULL);
- Xg_define_procedure(PANGO_IS_LAYOUT, gxg_PANGO_IS_LAYOUT_w, 1, 0, 0, "(PANGO_IS_LAYOUT obj): " PROC_TRUE " if obj is a PANGO_IS_LAYOUT", NULL);
- Xg_define_procedure(G_IS_OBJECT, gxg_G_IS_OBJECT_w, 1, 0, 0, "(G_IS_OBJECT obj): " PROC_TRUE " if obj is a G_IS_OBJECT", NULL);
- Xg_define_procedure(GDK_IS_SCREEN, gxg_GDK_IS_SCREEN_w, 1, 0, 0, "(GDK_IS_SCREEN obj): " PROC_TRUE " if obj is a GDK_IS_SCREEN", NULL);
- Xg_define_procedure(GDK_IS_DISPLAY, gxg_GDK_IS_DISPLAY_w, 1, 0, 0, "(GDK_IS_DISPLAY obj): " PROC_TRUE " if obj is a GDK_IS_DISPLAY", NULL);
- Xg_define_procedure(GTK_IS_FILE_CHOOSER_DIALOG, gxg_GTK_IS_FILE_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_IS_FILE_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_FILE_CHOOSER_WIDGET, gxg_GTK_IS_FILE_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_IS_FILE_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_WIDGET", NULL);
- Xg_define_procedure(GTK_IS_TREE_MODEL_FILTER, gxg_GTK_IS_TREE_MODEL_FILTER_w, 1, 0, 0, "(GTK_IS_TREE_MODEL_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL_FILTER", NULL);
- Xg_define_procedure(GTK_IS_COMBO_BOX, gxg_GTK_IS_COMBO_BOX_w, 1, 0, 0, "(GTK_IS_COMBO_BOX obj): " PROC_TRUE " if obj is a GTK_IS_COMBO_BOX", NULL);
- Xg_define_procedure(GTK_IS_EXPANDER, gxg_GTK_IS_EXPANDER_w, 1, 0, 0, "(GTK_IS_EXPANDER obj): " PROC_TRUE " if obj is a GTK_IS_EXPANDER", NULL);
- Xg_define_procedure(GTK_IS_FONT_BUTTON, gxg_GTK_IS_FONT_BUTTON_w, 1, 0, 0, "(GTK_IS_FONT_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_FONT_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_COLOR_BUTTON, gxg_GTK_IS_COLOR_BUTTON_w, 1, 0, 0, "(GTK_IS_COLOR_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_ENTRY_COMPLETION, gxg_GTK_IS_ENTRY_COMPLETION_w, 1, 0, 0, "(GTK_IS_ENTRY_COMPLETION obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY_COMPLETION", NULL);
- Xg_define_procedure(GTK_IS_RADIO_TOOL_BUTTON, gxg_GTK_IS_RADIO_TOOL_BUTTON_w, 1, 0, 0, "(GTK_IS_RADIO_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_SEPARATOR_TOOL_ITEM, gxg_GTK_IS_SEPARATOR_TOOL_ITEM_w, 1, 0, 0, "(GTK_IS_SEPARATOR_TOOL_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR_TOOL_ITEM", NULL);
- Xg_define_procedure(GTK_IS_TOGGLE_TOOL_BUTTON, gxg_GTK_IS_TOGGLE_TOOL_BUTTON_w, 1, 0, 0, "(GTK_IS_TOGGLE_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOGGLE_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_FILE_FILTER, gxg_GTK_IS_FILE_FILTER_w, 1, 0, 0, "(GTK_IS_FILE_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_FILE_FILTER", NULL);
- Xg_define_procedure(GTK_IS_CELL_LAYOUT, gxg_GTK_IS_CELL_LAYOUT_w, 1, 0, 0, "(GTK_IS_CELL_LAYOUT obj): " PROC_TRUE " if obj is a GTK_IS_CELL_LAYOUT", NULL);
- Xg_define_procedure(GTK_IS_CLIPBOARD, gxg_GTK_IS_CLIPBOARD_w, 1, 0, 0, "(GTK_IS_CLIPBOARD obj): " PROC_TRUE " if obj is a GTK_IS_CLIPBOARD", NULL);
- Xg_define_procedure(GTK_IS_FILE_CHOOSER, gxg_GTK_IS_FILE_CHOOSER_w, 1, 0, 0, "(GTK_IS_FILE_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER", NULL);
- Xg_define_procedure(GTK_IS_ICON_THEME, gxg_GTK_IS_ICON_THEME_w, 1, 0, 0, "(GTK_IS_ICON_THEME obj): " PROC_TRUE " if obj is a GTK_IS_ICON_THEME", NULL);
- Xg_define_procedure(GTK_IS_TOOL_BUTTON, gxg_GTK_IS_TOOL_BUTTON_w, 1, 0, 0, "(GTK_IS_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_TOOL_ITEM, gxg_GTK_IS_TOOL_ITEM_w, 1, 0, 0, "(GTK_IS_TOOL_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_ITEM", NULL);
- Xg_define_procedure(GTK_IS_ACCEL_MAP, gxg_GTK_IS_ACCEL_MAP_w, 1, 0, 0, "(GTK_IS_ACCEL_MAP obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_MAP", NULL);
- Xg_define_procedure(GTK_IS_CELL_VIEW, gxg_GTK_IS_CELL_VIEW_w, 1, 0, 0, "(GTK_IS_CELL_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_CELL_VIEW", NULL);
- Xg_define_procedure(GTK_IS_ABOUT_DIALOG, gxg_GTK_IS_ABOUT_DIALOG_w, 1, 0, 0, "(GTK_IS_ABOUT_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_ABOUT_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_COMBO, gxg_GTK_IS_CELL_RENDERER_COMBO_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_COMBO obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_COMBO", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_PROGRESS, gxg_GTK_IS_CELL_RENDERER_PROGRESS_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_PROGRESS obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_PROGRESS", NULL);
- Xg_define_procedure(GTK_IS_ICON_VIEW, gxg_GTK_IS_ICON_VIEW_w, 1, 0, 0, "(GTK_IS_ICON_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_ICON_VIEW", NULL);
- Xg_define_procedure(GTK_IS_FILE_CHOOSER_BUTTON, gxg_GTK_IS_FILE_CHOOSER_BUTTON_w, 1, 0, 0, "(GTK_IS_FILE_CHOOSER_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_MENU_TOOL_BUTTON, gxg_GTK_IS_MENU_TOOL_BUTTON_w, 1, 0, 0, "(GTK_IS_MENU_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_MENU_TOOL_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_ASSISTANT, gxg_GTK_IS_ASSISTANT_w, 1, 0, 0, "(GTK_IS_ASSISTANT obj): " PROC_TRUE " if obj is a GTK_IS_ASSISTANT", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_ACCEL, gxg_GTK_IS_CELL_RENDERER_ACCEL_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_ACCEL obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_ACCEL", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_SPIN, gxg_GTK_IS_CELL_RENDERER_SPIN_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_SPIN obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_SPIN", NULL);
- Xg_define_procedure(GTK_IS_LINK_BUTTON, gxg_GTK_IS_LINK_BUTTON_w, 1, 0, 0, "(GTK_IS_LINK_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_LINK_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_RECENT_CHOOSER_DIALOG, gxg_GTK_IS_RECENT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_IS_RECENT_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_RECENT_CHOOSER, gxg_GTK_IS_RECENT_CHOOSER_w, 1, 0, 0, "(GTK_IS_RECENT_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER", NULL);
- Xg_define_procedure(GTK_IS_RECENT_CHOOSER_MENU, gxg_GTK_IS_RECENT_CHOOSER_MENU_w, 1, 0, 0, "(GTK_IS_RECENT_CHOOSER_MENU obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_MENU", NULL);
- Xg_define_procedure(GTK_IS_RECENT_CHOOSER_WIDGET, gxg_GTK_IS_RECENT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_IS_RECENT_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_WIDGET", NULL);
- Xg_define_procedure(GTK_IS_RECENT_FILTER, gxg_GTK_IS_RECENT_FILTER_w, 1, 0, 0, "(GTK_IS_RECENT_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_FILTER", NULL);
- Xg_define_procedure(GTK_IS_RECENT_MANAGER, gxg_GTK_IS_RECENT_MANAGER_w, 1, 0, 0, "(GTK_IS_RECENT_MANAGER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_MANAGER", NULL);
- Xg_define_procedure(GTK_IS_PRINT_CONTEXT, gxg_GTK_IS_PRINT_CONTEXT_w, 1, 0, 0, "(GTK_IS_PRINT_CONTEXT obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_CONTEXT", NULL);
- Xg_define_procedure(GTK_IS_PRINT_OPERATION, gxg_GTK_IS_PRINT_OPERATION_w, 1, 0, 0, "(GTK_IS_PRINT_OPERATION obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_OPERATION", NULL);
- Xg_define_procedure(GTK_IS_PRINT_OPERATION_PREVIEW, gxg_GTK_IS_PRINT_OPERATION_PREVIEW_w, 1, 0, 0, "(GTK_IS_PRINT_OPERATION_PREVIEW obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_OPERATION_PREVIEW", NULL);
- Xg_define_procedure(GTK_IS_PRINT_SETTINGS, gxg_GTK_IS_PRINT_SETTINGS_w, 1, 0, 0, "(GTK_IS_PRINT_SETTINGS obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_SETTINGS", NULL);
- Xg_define_procedure(GTK_IS_TOOLTIP, gxg_GTK_IS_TOOLTIP_w, 1, 0, 0, "(GTK_IS_TOOLTIP obj): " PROC_TRUE " if obj is a GTK_IS_TOOLTIP", NULL);
+ Xg_define_procedure(GDK_IS_DRAG_CONTEXT, gxg_GDK_IS_DRAG_CONTEXT_w, 1, 0, 0,
+ "(GDK_IS_DRAG_CONTEXT obj): " PROC_TRUE " if obj is a GDK_IS_DRAG_CONTEXT", pl_bt);
+ Xg_define_procedure(GDK_IS_DEVICE, gxg_GDK_IS_DEVICE_w, 1, 0, 0,
+ "(GDK_IS_DEVICE obj): " PROC_TRUE " if obj is a GDK_IS_DEVICE", pl_bt);
+ Xg_define_procedure(GDK_IS_KEYMAP, gxg_GDK_IS_KEYMAP_w, 1, 0, 0,
+ "(GDK_IS_KEYMAP obj): " PROC_TRUE " if obj is a GDK_IS_KEYMAP", pl_bt);
+ Xg_define_procedure(GDK_IS_VISUAL, gxg_GDK_IS_VISUAL_w, 1, 0, 0,
+ "(GDK_IS_VISUAL obj): " PROC_TRUE " if obj is a GDK_IS_VISUAL", pl_bt);
+ Xg_define_procedure(GDK_IS_WINDOW, gxg_GDK_IS_WINDOW_w, 1, 0, 0,
+ "(GDK_IS_WINDOW obj): " PROC_TRUE " if obj is a GDK_IS_WINDOW", pl_bt);
+ Xg_define_procedure(GDK_IS_PIXBUF, gxg_GDK_IS_PIXBUF_w, 1, 0, 0,
+ "(GDK_IS_PIXBUF obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF", pl_bt);
+ Xg_define_procedure(GDK_IS_PIXBUF_ANIMATION, gxg_GDK_IS_PIXBUF_ANIMATION_w, 1, 0, 0,
+ "(GDK_IS_PIXBUF_ANIMATION obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF_ANIMATION", pl_bt);
+ Xg_define_procedure(GDK_IS_PIXBUF_ANIMATION_ITER, gxg_GDK_IS_PIXBUF_ANIMATION_ITER_w, 1, 0, 0,
+ "(GDK_IS_PIXBUF_ANIMATION_ITER obj): " PROC_TRUE " if obj is a GDK_IS_PIXBUF_ANIMATION_ITER", pl_bt);
+ Xg_define_procedure(GTK_IS_ACCEL_GROUP, gxg_GTK_IS_ACCEL_GROUP_w, 1, 0, 0,
+ "(GTK_IS_ACCEL_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_GROUP", pl_bt);
+ Xg_define_procedure(GTK_IS_ACCEL_LABEL, gxg_GTK_IS_ACCEL_LABEL_w, 1, 0, 0,
+ "(GTK_IS_ACCEL_LABEL obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_LABEL", pl_bt);
+ Xg_define_procedure(GTK_IS_ACCESSIBLE, gxg_GTK_IS_ACCESSIBLE_w, 1, 0, 0,
+ "(GTK_IS_ACCESSIBLE obj): " PROC_TRUE " if obj is a GTK_IS_ACCESSIBLE", pl_bt);
+ Xg_define_procedure(GTK_IS_ADJUSTMENT, gxg_GTK_IS_ADJUSTMENT_w, 1, 0, 0,
+ "(GTK_IS_ADJUSTMENT obj): " PROC_TRUE " if obj is a GTK_IS_ADJUSTMENT", pl_bt);
+ Xg_define_procedure(GTK_IS_ASPECT_FRAME, gxg_GTK_IS_ASPECT_FRAME_w, 1, 0, 0,
+ "(GTK_IS_ASPECT_FRAME obj): " PROC_TRUE " if obj is a GTK_IS_ASPECT_FRAME", pl_bt);
+ Xg_define_procedure(GTK_IS_BUTTON_BOX, gxg_GTK_IS_BUTTON_BOX_w, 1, 0, 0,
+ "(GTK_IS_BUTTON_BOX obj): " PROC_TRUE " if obj is a GTK_IS_BUTTON_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_BIN, gxg_GTK_IS_BIN_w, 1, 0, 0,
+ "(GTK_IS_BIN obj): " PROC_TRUE " if obj is a GTK_IS_BIN", pl_bt);
+ Xg_define_procedure(GTK_IS_BOX, gxg_GTK_IS_BOX_w, 1, 0, 0,
+ "(GTK_IS_BOX obj): " PROC_TRUE " if obj is a GTK_IS_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_BUTTON, gxg_GTK_IS_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_CALENDAR, gxg_GTK_IS_CALENDAR_w, 1, 0, 0,
+ "(GTK_IS_CALENDAR obj): " PROC_TRUE " if obj is a GTK_IS_CALENDAR", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_EDITABLE, gxg_GTK_IS_CELL_EDITABLE_w, 1, 0, 0,
+ "(GTK_IS_CELL_EDITABLE obj): " PROC_TRUE " if obj is a GTK_IS_CELL_EDITABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER, gxg_GTK_IS_CELL_RENDERER_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_PIXBUF, gxg_GTK_IS_CELL_RENDERER_PIXBUF_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_PIXBUF obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_PIXBUF", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_TEXT, gxg_GTK_IS_CELL_RENDERER_TEXT_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_TEXT obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_TEXT", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_TOGGLE, gxg_GTK_IS_CELL_RENDERER_TOGGLE_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_TOGGLE obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_TOGGLE", pl_bt);
+ Xg_define_procedure(GTK_IS_CHECK_BUTTON, gxg_GTK_IS_CHECK_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_CHECK_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_CHECK_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_CHECK_MENU_ITEM, gxg_GTK_IS_CHECK_MENU_ITEM_w, 1, 0, 0,
+ "(GTK_IS_CHECK_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_CHECK_MENU_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_CONTAINER, gxg_GTK_IS_CONTAINER_w, 1, 0, 0,
+ "(GTK_IS_CONTAINER obj): " PROC_TRUE " if obj is a GTK_IS_CONTAINER", pl_bt);
+ Xg_define_procedure(GTK_IS_DIALOG, gxg_GTK_IS_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_DRAWING_AREA, gxg_GTK_IS_DRAWING_AREA_w, 1, 0, 0,
+ "(GTK_IS_DRAWING_AREA obj): " PROC_TRUE " if obj is a GTK_IS_DRAWING_AREA", pl_bt);
+ Xg_define_procedure(GTK_IS_EDITABLE, gxg_GTK_IS_EDITABLE_w, 1, 0, 0,
+ "(GTK_IS_EDITABLE obj): " PROC_TRUE " if obj is a GTK_IS_EDITABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_ENTRY, gxg_GTK_IS_ENTRY_w, 1, 0, 0,
+ "(GTK_IS_ENTRY obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY", pl_bt);
+ Xg_define_procedure(GTK_IS_EVENT_BOX, gxg_GTK_IS_EVENT_BOX_w, 1, 0, 0,
+ "(GTK_IS_EVENT_BOX obj): " PROC_TRUE " if obj is a GTK_IS_EVENT_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_FIXED, gxg_GTK_IS_FIXED_w, 1, 0, 0,
+ "(GTK_IS_FIXED obj): " PROC_TRUE " if obj is a GTK_IS_FIXED", pl_bt);
+ Xg_define_procedure(GTK_IS_FRAME, gxg_GTK_IS_FRAME_w, 1, 0, 0,
+ "(GTK_IS_FRAME obj): " PROC_TRUE " if obj is a GTK_IS_FRAME", pl_bt);
+ Xg_define_procedure(GTK_IS_IMAGE, gxg_GTK_IS_IMAGE_w, 1, 0, 0,
+ "(GTK_IS_IMAGE obj): " PROC_TRUE " if obj is a GTK_IS_IMAGE", pl_bt);
+ Xg_define_procedure(GTK_IS_IM_CONTEXT, gxg_GTK_IS_IM_CONTEXT_w, 1, 0, 0,
+ "(GTK_IS_IM_CONTEXT obj): " PROC_TRUE " if obj is a GTK_IS_IM_CONTEXT", pl_bt);
+ Xg_define_procedure(GTK_IS_IM_CONTEXT_SIMPLE, gxg_GTK_IS_IM_CONTEXT_SIMPLE_w, 1, 0, 0,
+ "(GTK_IS_IM_CONTEXT_SIMPLE obj): " PROC_TRUE " if obj is a GTK_IS_IM_CONTEXT_SIMPLE", pl_bt);
+ Xg_define_procedure(GTK_IS_INVISIBLE, gxg_GTK_IS_INVISIBLE_w, 1, 0, 0,
+ "(GTK_IS_INVISIBLE obj): " PROC_TRUE " if obj is a GTK_IS_INVISIBLE", pl_bt);
+ Xg_define_procedure(GTK_IS_LABEL, gxg_GTK_IS_LABEL_w, 1, 0, 0,
+ "(GTK_IS_LABEL obj): " PROC_TRUE " if obj is a GTK_IS_LABEL", pl_bt);
+ Xg_define_procedure(GTK_IS_LAYOUT, gxg_GTK_IS_LAYOUT_w, 1, 0, 0,
+ "(GTK_IS_LAYOUT obj): " PROC_TRUE " if obj is a GTK_IS_LAYOUT", pl_bt);
+ Xg_define_procedure(GTK_IS_LIST_STORE, gxg_GTK_IS_LIST_STORE_w, 1, 0, 0,
+ "(GTK_IS_LIST_STORE obj): " PROC_TRUE " if obj is a GTK_IS_LIST_STORE", pl_bt);
+ Xg_define_procedure(GTK_IS_MENU_BAR, gxg_GTK_IS_MENU_BAR_w, 1, 0, 0,
+ "(GTK_IS_MENU_BAR obj): " PROC_TRUE " if obj is a GTK_IS_MENU_BAR", pl_bt);
+ Xg_define_procedure(GTK_IS_MENU, gxg_GTK_IS_MENU_w, 1, 0, 0,
+ "(GTK_IS_MENU obj): " PROC_TRUE " if obj is a GTK_IS_MENU", pl_bt);
+ Xg_define_procedure(GTK_IS_MENU_ITEM, gxg_GTK_IS_MENU_ITEM_w, 1, 0, 0,
+ "(GTK_IS_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_MENU_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_MENU_SHELL, gxg_GTK_IS_MENU_SHELL_w, 1, 0, 0,
+ "(GTK_IS_MENU_SHELL obj): " PROC_TRUE " if obj is a GTK_IS_MENU_SHELL", pl_bt);
+ Xg_define_procedure(GTK_IS_NOTEBOOK, gxg_GTK_IS_NOTEBOOK_w, 1, 0, 0,
+ "(GTK_IS_NOTEBOOK obj): " PROC_TRUE " if obj is a GTK_IS_NOTEBOOK", pl_bt);
+ Xg_define_procedure(GTK_IS_PANED, gxg_GTK_IS_PANED_w, 1, 0, 0,
+ "(GTK_IS_PANED obj): " PROC_TRUE " if obj is a GTK_IS_PANED", pl_bt);
+ Xg_define_procedure(GTK_IS_PROGRESS_BAR, gxg_GTK_IS_PROGRESS_BAR_w, 1, 0, 0,
+ "(GTK_IS_PROGRESS_BAR obj): " PROC_TRUE " if obj is a GTK_IS_PROGRESS_BAR", pl_bt);
+ Xg_define_procedure(GTK_IS_RADIO_BUTTON, gxg_GTK_IS_RADIO_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_RADIO_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_RADIO_MENU_ITEM, gxg_GTK_IS_RADIO_MENU_ITEM_w, 1, 0, 0,
+ "(GTK_IS_RADIO_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_MENU_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_RANGE, gxg_GTK_IS_RANGE_w, 1, 0, 0,
+ "(GTK_IS_RANGE obj): " PROC_TRUE " if obj is a GTK_IS_RANGE", pl_bt);
+ Xg_define_procedure(GTK_IS_SCALE, gxg_GTK_IS_SCALE_w, 1, 0, 0,
+ "(GTK_IS_SCALE obj): " PROC_TRUE " if obj is a GTK_IS_SCALE", pl_bt);
+ Xg_define_procedure(GTK_IS_SCROLLBAR, gxg_GTK_IS_SCROLLBAR_w, 1, 0, 0,
+ "(GTK_IS_SCROLLBAR obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLBAR", pl_bt);
+ Xg_define_procedure(GTK_IS_SCROLLED_WINDOW, gxg_GTK_IS_SCROLLED_WINDOW_w, 1, 0, 0,
+ "(GTK_IS_SCROLLED_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLED_WINDOW", pl_bt);
+ Xg_define_procedure(GTK_IS_SEPARATOR, gxg_GTK_IS_SEPARATOR_w, 1, 0, 0,
+ "(GTK_IS_SEPARATOR obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR", pl_bt);
+ Xg_define_procedure(GTK_IS_SEPARATOR_MENU_ITEM, gxg_GTK_IS_SEPARATOR_MENU_ITEM_w, 1, 0, 0,
+ "(GTK_IS_SEPARATOR_MENU_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR_MENU_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_SETTINGS, gxg_GTK_IS_SETTINGS_w, 1, 0, 0,
+ "(GTK_IS_SETTINGS obj): " PROC_TRUE " if obj is a GTK_IS_SETTINGS", pl_bt);
+ Xg_define_procedure(GTK_IS_SIZE_GROUP, gxg_GTK_IS_SIZE_GROUP_w, 1, 0, 0,
+ "(GTK_IS_SIZE_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_SIZE_GROUP", pl_bt);
+ Xg_define_procedure(GTK_IS_SPIN_BUTTON, gxg_GTK_IS_SPIN_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_SPIN_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_SPIN_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_STATUSBAR, gxg_GTK_IS_STATUSBAR_w, 1, 0, 0,
+ "(GTK_IS_STATUSBAR obj): " PROC_TRUE " if obj is a GTK_IS_STATUSBAR", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_BUFFER, gxg_GTK_IS_TEXT_BUFFER_w, 1, 0, 0,
+ "(GTK_IS_TEXT_BUFFER obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_BUFFER", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_CHILD_ANCHOR, gxg_GTK_IS_TEXT_CHILD_ANCHOR_w, 1, 0, 0,
+ "(GTK_IS_TEXT_CHILD_ANCHOR obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_CHILD_ANCHOR", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_MARK, gxg_GTK_IS_TEXT_MARK_w, 1, 0, 0,
+ "(GTK_IS_TEXT_MARK obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_MARK", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_TAG, gxg_GTK_IS_TEXT_TAG_w, 1, 0, 0,
+ "(GTK_IS_TEXT_TAG obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_TAG", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_TAG_TABLE, gxg_GTK_IS_TEXT_TAG_TABLE_w, 1, 0, 0,
+ "(GTK_IS_TEXT_TAG_TABLE obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_TAG_TABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_TEXT_VIEW, gxg_GTK_IS_TEXT_VIEW_w, 1, 0, 0,
+ "(GTK_IS_TEXT_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_TEXT_VIEW", pl_bt);
+ Xg_define_procedure(GTK_IS_TOGGLE_BUTTON, gxg_GTK_IS_TOGGLE_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_TOGGLE_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOGGLE_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOLBAR, gxg_GTK_IS_TOOLBAR_w, 1, 0, 0,
+ "(GTK_IS_TOOLBAR obj): " PROC_TRUE " if obj is a GTK_IS_TOOLBAR", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_DRAG_SOURCE, gxg_GTK_IS_TREE_DRAG_SOURCE_w, 1, 0, 0,
+ "(GTK_IS_TREE_DRAG_SOURCE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_DRAG_SOURCE", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_DRAG_DEST, gxg_GTK_IS_TREE_DRAG_DEST_w, 1, 0, 0,
+ "(GTK_IS_TREE_DRAG_DEST obj): " PROC_TRUE " if obj is a GTK_IS_TREE_DRAG_DEST", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_MODEL, gxg_GTK_IS_TREE_MODEL_w, 1, 0, 0,
+ "(GTK_IS_TREE_MODEL obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_MODEL_SORT, gxg_GTK_IS_TREE_MODEL_SORT_w, 1, 0, 0,
+ "(GTK_IS_TREE_MODEL_SORT obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL_SORT", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_SELECTION, gxg_GTK_IS_TREE_SELECTION_w, 1, 0, 0,
+ "(GTK_IS_TREE_SELECTION obj): " PROC_TRUE " if obj is a GTK_IS_TREE_SELECTION", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_SORTABLE, gxg_GTK_IS_TREE_SORTABLE_w, 1, 0, 0,
+ "(GTK_IS_TREE_SORTABLE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_SORTABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_STORE, gxg_GTK_IS_TREE_STORE_w, 1, 0, 0,
+ "(GTK_IS_TREE_STORE obj): " PROC_TRUE " if obj is a GTK_IS_TREE_STORE", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_VIEW_COLUMN, gxg_GTK_IS_TREE_VIEW_COLUMN_w, 1, 0, 0,
+ "(GTK_IS_TREE_VIEW_COLUMN obj): " PROC_TRUE " if obj is a GTK_IS_TREE_VIEW_COLUMN", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_VIEW, gxg_GTK_IS_TREE_VIEW_w, 1, 0, 0,
+ "(GTK_IS_TREE_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_TREE_VIEW", pl_bt);
+ Xg_define_procedure(GTK_IS_VIEWPORT, gxg_GTK_IS_VIEWPORT_w, 1, 0, 0,
+ "(GTK_IS_VIEWPORT obj): " PROC_TRUE " if obj is a GTK_IS_VIEWPORT", pl_bt);
+ Xg_define_procedure(GTK_IS_WIDGET, gxg_GTK_IS_WIDGET_w, 1, 0, 0,
+ "(GTK_IS_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_WIDGET", pl_bt);
+ Xg_define_procedure(GTK_IS_WINDOW, gxg_GTK_IS_WINDOW_w, 1, 0, 0,
+ "(GTK_IS_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_WINDOW", pl_bt);
+ Xg_define_procedure(PANGO_IS_CONTEXT, gxg_PANGO_IS_CONTEXT_w, 1, 0, 0,
+ "(PANGO_IS_CONTEXT obj): " PROC_TRUE " if obj is a PANGO_IS_CONTEXT", pl_bt);
+ Xg_define_procedure(PANGO_IS_FONT_FAMILY, gxg_PANGO_IS_FONT_FAMILY_w, 1, 0, 0,
+ "(PANGO_IS_FONT_FAMILY obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_FAMILY", pl_bt);
+ Xg_define_procedure(PANGO_IS_FONT_FACE, gxg_PANGO_IS_FONT_FACE_w, 1, 0, 0,
+ "(PANGO_IS_FONT_FACE obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_FACE", pl_bt);
+ Xg_define_procedure(PANGO_IS_FONT, gxg_PANGO_IS_FONT_w, 1, 0, 0,
+ "(PANGO_IS_FONT obj): " PROC_TRUE " if obj is a PANGO_IS_FONT", pl_bt);
+ Xg_define_procedure(PANGO_IS_FONT_MAP, gxg_PANGO_IS_FONT_MAP_w, 1, 0, 0,
+ "(PANGO_IS_FONT_MAP obj): " PROC_TRUE " if obj is a PANGO_IS_FONT_MAP", pl_bt);
+ Xg_define_procedure(PANGO_IS_LAYOUT, gxg_PANGO_IS_LAYOUT_w, 1, 0, 0,
+ "(PANGO_IS_LAYOUT obj): " PROC_TRUE " if obj is a PANGO_IS_LAYOUT", pl_bt);
+ Xg_define_procedure(G_IS_OBJECT, gxg_G_IS_OBJECT_w, 1, 0, 0,
+ "(G_IS_OBJECT obj): " PROC_TRUE " if obj is a G_IS_OBJECT", pl_bt);
+ Xg_define_procedure(GDK_IS_SCREEN, gxg_GDK_IS_SCREEN_w, 1, 0, 0,
+ "(GDK_IS_SCREEN obj): " PROC_TRUE " if obj is a GDK_IS_SCREEN", pl_bt);
+ Xg_define_procedure(GDK_IS_DISPLAY, gxg_GDK_IS_DISPLAY_w, 1, 0, 0,
+ "(GDK_IS_DISPLAY obj): " PROC_TRUE " if obj is a GDK_IS_DISPLAY", pl_bt);
+ Xg_define_procedure(GTK_IS_FILE_CHOOSER_DIALOG, gxg_GTK_IS_FILE_CHOOSER_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_FILE_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_FILE_CHOOSER_WIDGET, gxg_GTK_IS_FILE_CHOOSER_WIDGET_w, 1, 0, 0,
+ "(GTK_IS_FILE_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_WIDGET", pl_bt);
+ Xg_define_procedure(GTK_IS_TREE_MODEL_FILTER, gxg_GTK_IS_TREE_MODEL_FILTER_w, 1, 0, 0,
+ "(GTK_IS_TREE_MODEL_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_TREE_MODEL_FILTER", pl_bt);
+ Xg_define_procedure(GTK_IS_COMBO_BOX, gxg_GTK_IS_COMBO_BOX_w, 1, 0, 0,
+ "(GTK_IS_COMBO_BOX obj): " PROC_TRUE " if obj is a GTK_IS_COMBO_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_EXPANDER, gxg_GTK_IS_EXPANDER_w, 1, 0, 0,
+ "(GTK_IS_EXPANDER obj): " PROC_TRUE " if obj is a GTK_IS_EXPANDER", pl_bt);
+ Xg_define_procedure(GTK_IS_FONT_BUTTON, gxg_GTK_IS_FONT_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_FONT_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_FONT_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_COLOR_BUTTON, gxg_GTK_IS_COLOR_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_COLOR_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_ENTRY_COMPLETION, gxg_GTK_IS_ENTRY_COMPLETION_w, 1, 0, 0,
+ "(GTK_IS_ENTRY_COMPLETION obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY_COMPLETION", pl_bt);
+ Xg_define_procedure(GTK_IS_RADIO_TOOL_BUTTON, gxg_GTK_IS_RADIO_TOOL_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_RADIO_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_RADIO_TOOL_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_SEPARATOR_TOOL_ITEM, gxg_GTK_IS_SEPARATOR_TOOL_ITEM_w, 1, 0, 0,
+ "(GTK_IS_SEPARATOR_TOOL_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_SEPARATOR_TOOL_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_TOGGLE_TOOL_BUTTON, gxg_GTK_IS_TOGGLE_TOOL_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_TOGGLE_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOGGLE_TOOL_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_FILE_FILTER, gxg_GTK_IS_FILE_FILTER_w, 1, 0, 0,
+ "(GTK_IS_FILE_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_FILE_FILTER", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_LAYOUT, gxg_GTK_IS_CELL_LAYOUT_w, 1, 0, 0,
+ "(GTK_IS_CELL_LAYOUT obj): " PROC_TRUE " if obj is a GTK_IS_CELL_LAYOUT", pl_bt);
+ Xg_define_procedure(GTK_IS_CLIPBOARD, gxg_GTK_IS_CLIPBOARD_w, 1, 0, 0,
+ "(GTK_IS_CLIPBOARD obj): " PROC_TRUE " if obj is a GTK_IS_CLIPBOARD", pl_bt);
+ Xg_define_procedure(GTK_IS_FILE_CHOOSER, gxg_GTK_IS_FILE_CHOOSER_w, 1, 0, 0,
+ "(GTK_IS_FILE_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER", pl_bt);
+ Xg_define_procedure(GTK_IS_ICON_THEME, gxg_GTK_IS_ICON_THEME_w, 1, 0, 0,
+ "(GTK_IS_ICON_THEME obj): " PROC_TRUE " if obj is a GTK_IS_ICON_THEME", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOL_BUTTON, gxg_GTK_IS_TOOL_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOL_ITEM, gxg_GTK_IS_TOOL_ITEM_w, 1, 0, 0,
+ "(GTK_IS_TOOL_ITEM obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_ITEM", pl_bt);
+ Xg_define_procedure(GTK_IS_ACCEL_MAP, gxg_GTK_IS_ACCEL_MAP_w, 1, 0, 0,
+ "(GTK_IS_ACCEL_MAP obj): " PROC_TRUE " if obj is a GTK_IS_ACCEL_MAP", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_VIEW, gxg_GTK_IS_CELL_VIEW_w, 1, 0, 0,
+ "(GTK_IS_CELL_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_CELL_VIEW", pl_bt);
+ Xg_define_procedure(GTK_IS_ABOUT_DIALOG, gxg_GTK_IS_ABOUT_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_ABOUT_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_ABOUT_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_COMBO, gxg_GTK_IS_CELL_RENDERER_COMBO_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_COMBO obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_COMBO", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_PROGRESS, gxg_GTK_IS_CELL_RENDERER_PROGRESS_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_PROGRESS obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_PROGRESS", pl_bt);
+ Xg_define_procedure(GTK_IS_ICON_VIEW, gxg_GTK_IS_ICON_VIEW_w, 1, 0, 0,
+ "(GTK_IS_ICON_VIEW obj): " PROC_TRUE " if obj is a GTK_IS_ICON_VIEW", pl_bt);
+ Xg_define_procedure(GTK_IS_FILE_CHOOSER_BUTTON, gxg_GTK_IS_FILE_CHOOSER_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_FILE_CHOOSER_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_FILE_CHOOSER_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_MENU_TOOL_BUTTON, gxg_GTK_IS_MENU_TOOL_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_MENU_TOOL_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_MENU_TOOL_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_ASSISTANT, gxg_GTK_IS_ASSISTANT_w, 1, 0, 0,
+ "(GTK_IS_ASSISTANT obj): " PROC_TRUE " if obj is a GTK_IS_ASSISTANT", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_ACCEL, gxg_GTK_IS_CELL_RENDERER_ACCEL_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_ACCEL obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_ACCEL", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_SPIN, gxg_GTK_IS_CELL_RENDERER_SPIN_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_SPIN obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_SPIN", pl_bt);
+ Xg_define_procedure(GTK_IS_LINK_BUTTON, gxg_GTK_IS_LINK_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_LINK_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_LINK_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_CHOOSER_DIALOG, gxg_GTK_IS_RECENT_CHOOSER_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_RECENT_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_CHOOSER, gxg_GTK_IS_RECENT_CHOOSER_w, 1, 0, 0,
+ "(GTK_IS_RECENT_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_CHOOSER_MENU, gxg_GTK_IS_RECENT_CHOOSER_MENU_w, 1, 0, 0,
+ "(GTK_IS_RECENT_CHOOSER_MENU obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_MENU", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_CHOOSER_WIDGET, gxg_GTK_IS_RECENT_CHOOSER_WIDGET_w, 1, 0, 0,
+ "(GTK_IS_RECENT_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_CHOOSER_WIDGET", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_FILTER, gxg_GTK_IS_RECENT_FILTER_w, 1, 0, 0,
+ "(GTK_IS_RECENT_FILTER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_FILTER", pl_bt);
+ Xg_define_procedure(GTK_IS_RECENT_MANAGER, gxg_GTK_IS_RECENT_MANAGER_w, 1, 0, 0,
+ "(GTK_IS_RECENT_MANAGER obj): " PROC_TRUE " if obj is a GTK_IS_RECENT_MANAGER", pl_bt);
+ Xg_define_procedure(GTK_IS_PRINT_CONTEXT, gxg_GTK_IS_PRINT_CONTEXT_w, 1, 0, 0,
+ "(GTK_IS_PRINT_CONTEXT obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_CONTEXT", pl_bt);
+ Xg_define_procedure(GTK_IS_PRINT_OPERATION, gxg_GTK_IS_PRINT_OPERATION_w, 1, 0, 0,
+ "(GTK_IS_PRINT_OPERATION obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_OPERATION", pl_bt);
+ Xg_define_procedure(GTK_IS_PRINT_OPERATION_PREVIEW, gxg_GTK_IS_PRINT_OPERATION_PREVIEW_w, 1, 0, 0,
+ "(GTK_IS_PRINT_OPERATION_PREVIEW obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_OPERATION_PREVIEW", pl_bt);
+ Xg_define_procedure(GTK_IS_PRINT_SETTINGS, gxg_GTK_IS_PRINT_SETTINGS_w, 1, 0, 0,
+ "(GTK_IS_PRINT_SETTINGS obj): " PROC_TRUE " if obj is a GTK_IS_PRINT_SETTINGS", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOLTIP, gxg_GTK_IS_TOOLTIP_w, 1, 0, 0,
+ "(GTK_IS_TOOLTIP obj): " PROC_TRUE " if obj is a GTK_IS_TOOLTIP", pl_bt);
#if GTK_CHECK_VERSION(2, 18, 0)
- Xg_define_procedure(GTK_IS_INFO_BAR, gxg_GTK_IS_INFO_BAR_w, 1, 0, 0, "(GTK_IS_INFO_BAR obj): " PROC_TRUE " if obj is a GTK_IS_INFO_BAR", NULL);
- Xg_define_procedure(GTK_IS_ENTRY_BUFFER, gxg_GTK_IS_ENTRY_BUFFER_w, 1, 0, 0, "(GTK_IS_ENTRY_BUFFER obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY_BUFFER", NULL);
+ Xg_define_procedure(GTK_IS_INFO_BAR, gxg_GTK_IS_INFO_BAR_w, 1, 0, 0,
+ "(GTK_IS_INFO_BAR obj): " PROC_TRUE " if obj is a GTK_IS_INFO_BAR", pl_bt);
+ Xg_define_procedure(GTK_IS_ENTRY_BUFFER, gxg_GTK_IS_ENTRY_BUFFER_w, 1, 0, 0,
+ "(GTK_IS_ENTRY_BUFFER obj): " PROC_TRUE " if obj is a GTK_IS_ENTRY_BUFFER", pl_bt);
#endif
#if GTK_CHECK_VERSION(2, 20, 0)
- Xg_define_procedure(GTK_IS_SPINNER, gxg_GTK_IS_SPINNER_w, 1, 0, 0, "(GTK_IS_SPINNER obj): " PROC_TRUE " if obj is a GTK_IS_SPINNER", NULL);
- Xg_define_procedure(GTK_IS_CELL_RENDERER_SPINNER, gxg_GTK_IS_CELL_RENDERER_SPINNER_w, 1, 0, 0, "(GTK_IS_CELL_RENDERER_SPINNER obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_SPINNER", NULL);
- Xg_define_procedure(GTK_IS_TOOL_PALETTE, gxg_GTK_IS_TOOL_PALETTE_w, 1, 0, 0, "(GTK_IS_TOOL_PALETTE obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_PALETTE", NULL);
- Xg_define_procedure(GTK_IS_TOOL_ITEM_GROUP, gxg_GTK_IS_TOOL_ITEM_GROUP_w, 1, 0, 0, "(GTK_IS_TOOL_ITEM_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_ITEM_GROUP", NULL);
+ Xg_define_procedure(GTK_IS_SPINNER, gxg_GTK_IS_SPINNER_w, 1, 0, 0,
+ "(GTK_IS_SPINNER obj): " PROC_TRUE " if obj is a GTK_IS_SPINNER", pl_bt);
+ Xg_define_procedure(GTK_IS_CELL_RENDERER_SPINNER, gxg_GTK_IS_CELL_RENDERER_SPINNER_w, 1, 0, 0,
+ "(GTK_IS_CELL_RENDERER_SPINNER obj): " PROC_TRUE " if obj is a GTK_IS_CELL_RENDERER_SPINNER", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOL_PALETTE, gxg_GTK_IS_TOOL_PALETTE_w, 1, 0, 0,
+ "(GTK_IS_TOOL_PALETTE obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_PALETTE", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOL_ITEM_GROUP, gxg_GTK_IS_TOOL_ITEM_GROUP_w, 1, 0, 0,
+ "(GTK_IS_TOOL_ITEM_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_ITEM_GROUP", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 0, 0)
- Xg_define_procedure(GTK_IS_COMBO_BOX_TEXT, gxg_GTK_IS_COMBO_BOX_TEXT_w, 1, 0, 0, "(GTK_IS_COMBO_BOX_TEXT obj): " PROC_TRUE " if obj is a GTK_IS_COMBO_BOX_TEXT", NULL);
- Xg_define_procedure(GTK_IS_GRID, gxg_GTK_IS_GRID_w, 1, 0, 0, "(GTK_IS_GRID obj): " PROC_TRUE " if obj is a GTK_IS_GRID", NULL);
- Xg_define_procedure(GTK_IS_SCROLLABLE, gxg_GTK_IS_SCROLLABLE_w, 1, 0, 0, "(GTK_IS_SCROLLABLE obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLABLE", NULL);
- Xg_define_procedure(GTK_IS_SWITCH, gxg_GTK_IS_SWITCH_w, 1, 0, 0, "(GTK_IS_SWITCH obj): " PROC_TRUE " if obj is a GTK_IS_SWITCH", NULL);
- Xg_define_procedure(GTK_IS_ORIENTABLE, gxg_GTK_IS_ORIENTABLE_w, 1, 0, 0, "(GTK_IS_ORIENTABLE obj): " PROC_TRUE " if obj is a GTK_IS_ORIENTABLE", NULL);
- Xg_define_procedure(GTK_IS_WINDOW_GROUP, gxg_GTK_IS_WINDOW_GROUP_w, 1, 0, 0, "(GTK_IS_WINDOW_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_WINDOW_GROUP", NULL);
- Xg_define_procedure(GTK_IS_TOOL_SHELL, gxg_GTK_IS_TOOL_SHELL_w, 1, 0, 0, "(GTK_IS_TOOL_SHELL obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_SHELL", NULL);
+ Xg_define_procedure(GTK_IS_COMBO_BOX_TEXT, gxg_GTK_IS_COMBO_BOX_TEXT_w, 1, 0, 0,
+ "(GTK_IS_COMBO_BOX_TEXT obj): " PROC_TRUE " if obj is a GTK_IS_COMBO_BOX_TEXT", pl_bt);
+ Xg_define_procedure(GTK_IS_GRID, gxg_GTK_IS_GRID_w, 1, 0, 0,
+ "(GTK_IS_GRID obj): " PROC_TRUE " if obj is a GTK_IS_GRID", pl_bt);
+ Xg_define_procedure(GTK_IS_SCROLLABLE, gxg_GTK_IS_SCROLLABLE_w, 1, 0, 0,
+ "(GTK_IS_SCROLLABLE obj): " PROC_TRUE " if obj is a GTK_IS_SCROLLABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_SWITCH, gxg_GTK_IS_SWITCH_w, 1, 0, 0,
+ "(GTK_IS_SWITCH obj): " PROC_TRUE " if obj is a GTK_IS_SWITCH", pl_bt);
+ Xg_define_procedure(GTK_IS_ORIENTABLE, gxg_GTK_IS_ORIENTABLE_w, 1, 0, 0,
+ "(GTK_IS_ORIENTABLE obj): " PROC_TRUE " if obj is a GTK_IS_ORIENTABLE", pl_bt);
+ Xg_define_procedure(GTK_IS_WINDOW_GROUP, gxg_GTK_IS_WINDOW_GROUP_w, 1, 0, 0,
+ "(GTK_IS_WINDOW_GROUP obj): " PROC_TRUE " if obj is a GTK_IS_WINDOW_GROUP", pl_bt);
+ Xg_define_procedure(GTK_IS_TOOL_SHELL, gxg_GTK_IS_TOOL_SHELL_w, 1, 0, 0,
+ "(GTK_IS_TOOL_SHELL obj): " PROC_TRUE " if obj is a GTK_IS_TOOL_SHELL", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 2, 0)
- Xg_define_procedure(GTK_IS_OVERLAY, gxg_GTK_IS_OVERLAY_w, 1, 0, 0, "(GTK_IS_OVERLAY obj): " PROC_TRUE " if obj is a GTK_IS_OVERLAY", NULL);
- Xg_define_procedure(GTK_IS_FONT_CHOOSER, gxg_GTK_IS_FONT_CHOOSER_w, 1, 0, 0, "(GTK_IS_FONT_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER", NULL);
- Xg_define_procedure(GTK_IS_FONT_CHOOSER_DIALOG, gxg_GTK_IS_FONT_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_IS_FONT_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_FONT_CHOOSER_WIDGET, gxg_GTK_IS_FONT_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_IS_FONT_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER_WIDGET", NULL);
+ Xg_define_procedure(GTK_IS_OVERLAY, gxg_GTK_IS_OVERLAY_w, 1, 0, 0,
+ "(GTK_IS_OVERLAY obj): " PROC_TRUE " if obj is a GTK_IS_OVERLAY", pl_bt);
+ Xg_define_procedure(GTK_IS_FONT_CHOOSER, gxg_GTK_IS_FONT_CHOOSER_w, 1, 0, 0,
+ "(GTK_IS_FONT_CHOOSER obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER", pl_bt);
+ Xg_define_procedure(GTK_IS_FONT_CHOOSER_DIALOG, gxg_GTK_IS_FONT_CHOOSER_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_FONT_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_FONT_CHOOSER_WIDGET, gxg_GTK_IS_FONT_CHOOSER_WIDGET_w, 1, 0, 0,
+ "(GTK_IS_FONT_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_FONT_CHOOSER_WIDGET", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
- Xg_define_procedure(GTK_IS_APPLICATION_WINDOW, gxg_GTK_IS_APPLICATION_WINDOW_w, 1, 0, 0, "(GTK_IS_APPLICATION_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_APPLICATION_WINDOW", NULL);
- Xg_define_procedure(GTK_IS_COLOR_CHOOSER_DIALOG, gxg_GTK_IS_COLOR_CHOOSER_DIALOG_w, 1, 0, 0, "(GTK_IS_COLOR_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_CHOOSER_DIALOG", NULL);
- Xg_define_procedure(GTK_IS_COLOR_CHOOSER_WIDGET, gxg_GTK_IS_COLOR_CHOOSER_WIDGET_w, 1, 0, 0, "(GTK_IS_COLOR_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_CHOOSER_WIDGET", NULL);
+ Xg_define_procedure(GTK_IS_APPLICATION_WINDOW, gxg_GTK_IS_APPLICATION_WINDOW_w, 1, 0, 0,
+ "(GTK_IS_APPLICATION_WINDOW obj): " PROC_TRUE " if obj is a GTK_IS_APPLICATION_WINDOW", pl_bt);
+ Xg_define_procedure(GTK_IS_COLOR_CHOOSER_DIALOG, gxg_GTK_IS_COLOR_CHOOSER_DIALOG_w, 1, 0, 0,
+ "(GTK_IS_COLOR_CHOOSER_DIALOG obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_CHOOSER_DIALOG", pl_bt);
+ Xg_define_procedure(GTK_IS_COLOR_CHOOSER_WIDGET, gxg_GTK_IS_COLOR_CHOOSER_WIDGET_w, 1, 0, 0,
+ "(GTK_IS_COLOR_CHOOSER_WIDGET obj): " PROC_TRUE " if obj is a GTK_IS_COLOR_CHOOSER_WIDGET", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
- Xg_define_procedure(GTK_IS_MENU_BUTTON, gxg_GTK_IS_MENU_BUTTON_w, 1, 0, 0, "(GTK_IS_MENU_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_MENU_BUTTON", NULL);
- Xg_define_procedure(GTK_IS_SEARCH_ENTRY, gxg_GTK_IS_SEARCH_ENTRY_w, 1, 0, 0, "(GTK_IS_SEARCH_ENTRY obj): " PROC_TRUE " if obj is a GTK_IS_SEARCH_ENTRY", NULL);
- Xg_define_procedure(GTK_IS_LEVEL_BAR, gxg_GTK_IS_LEVEL_BAR_w, 1, 0, 0, "(GTK_IS_LEVEL_BAR obj): " PROC_TRUE " if obj is a GTK_IS_LEVEL_BAR", NULL);
+ Xg_define_procedure(GTK_IS_MENU_BUTTON, gxg_GTK_IS_MENU_BUTTON_w, 1, 0, 0,
+ "(GTK_IS_MENU_BUTTON obj): " PROC_TRUE " if obj is a GTK_IS_MENU_BUTTON", pl_bt);
+ Xg_define_procedure(GTK_IS_SEARCH_ENTRY, gxg_GTK_IS_SEARCH_ENTRY_w, 1, 0, 0,
+ "(GTK_IS_SEARCH_ENTRY obj): " PROC_TRUE " if obj is a GTK_IS_SEARCH_ENTRY", pl_bt);
+ Xg_define_procedure(GTK_IS_LEVEL_BAR, gxg_GTK_IS_LEVEL_BAR_w, 1, 0, 0,
+ "(GTK_IS_LEVEL_BAR obj): " PROC_TRUE " if obj is a GTK_IS_LEVEL_BAR", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- Xg_define_procedure(GTK_IS_PLACES_SIDEBAR, gxg_GTK_IS_PLACES_SIDEBAR_w, 1, 0, 0, "(GTK_IS_PLACES_SIDEBAR obj): " PROC_TRUE " if obj is a GTK_IS_PLACES_SIDEBAR", NULL);
- Xg_define_procedure(GTK_IS_STACK_SWITCHER, gxg_GTK_IS_STACK_SWITCHER_w, 1, 0, 0, "(GTK_IS_STACK_SWITCHER obj): " PROC_TRUE " if obj is a GTK_IS_STACK_SWITCHER", NULL);
- Xg_define_procedure(GTK_IS_STACK, gxg_GTK_IS_STACK_w, 1, 0, 0, "(GTK_IS_STACK obj): " PROC_TRUE " if obj is a GTK_IS_STACK", NULL);
- Xg_define_procedure(GTK_IS_REVEALER, gxg_GTK_IS_REVEALER_w, 1, 0, 0, "(GTK_IS_REVEALER obj): " PROC_TRUE " if obj is a GTK_IS_REVEALER", NULL);
- Xg_define_procedure(GTK_IS_HEADER_BAR, gxg_GTK_IS_HEADER_BAR_w, 1, 0, 0, "(GTK_IS_HEADER_BAR obj): " PROC_TRUE " if obj is a GTK_IS_HEADER_BAR", NULL);
- Xg_define_procedure(GTK_IS_LIST_BOX, gxg_GTK_IS_LIST_BOX_w, 1, 0, 0, "(GTK_IS_LIST_BOX obj): " PROC_TRUE " if obj is a GTK_IS_LIST_BOX", NULL);
- Xg_define_procedure(GTK_IS_LIST_BOX_ROW, gxg_GTK_IS_LIST_BOX_ROW_w, 1, 0, 0, "(GTK_IS_LIST_BOX_ROW obj): " PROC_TRUE " if obj is a GTK_IS_LIST_BOX_ROW", NULL);
- Xg_define_procedure(GTK_IS_SEARCH_BAR, gxg_GTK_IS_SEARCH_BAR_w, 1, 0, 0, "(GTK_IS_SEARCH_BAR obj): " PROC_TRUE " if obj is a GTK_IS_SEARCH_BAR", NULL);
+ Xg_define_procedure(GTK_IS_PLACES_SIDEBAR, gxg_GTK_IS_PLACES_SIDEBAR_w, 1, 0, 0,
+ "(GTK_IS_PLACES_SIDEBAR obj): " PROC_TRUE " if obj is a GTK_IS_PLACES_SIDEBAR", pl_bt);
+ Xg_define_procedure(GTK_IS_STACK_SWITCHER, gxg_GTK_IS_STACK_SWITCHER_w, 1, 0, 0,
+ "(GTK_IS_STACK_SWITCHER obj): " PROC_TRUE " if obj is a GTK_IS_STACK_SWITCHER", pl_bt);
+ Xg_define_procedure(GTK_IS_STACK, gxg_GTK_IS_STACK_w, 1, 0, 0,
+ "(GTK_IS_STACK obj): " PROC_TRUE " if obj is a GTK_IS_STACK", pl_bt);
+ Xg_define_procedure(GTK_IS_REVEALER, gxg_GTK_IS_REVEALER_w, 1, 0, 0,
+ "(GTK_IS_REVEALER obj): " PROC_TRUE " if obj is a GTK_IS_REVEALER", pl_bt);
+ Xg_define_procedure(GTK_IS_HEADER_BAR, gxg_GTK_IS_HEADER_BAR_w, 1, 0, 0,
+ "(GTK_IS_HEADER_BAR obj): " PROC_TRUE " if obj is a GTK_IS_HEADER_BAR", pl_bt);
+ Xg_define_procedure(GTK_IS_LIST_BOX, gxg_GTK_IS_LIST_BOX_w, 1, 0, 0,
+ "(GTK_IS_LIST_BOX obj): " PROC_TRUE " if obj is a GTK_IS_LIST_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_LIST_BOX_ROW, gxg_GTK_IS_LIST_BOX_ROW_w, 1, 0, 0,
+ "(GTK_IS_LIST_BOX_ROW obj): " PROC_TRUE " if obj is a GTK_IS_LIST_BOX_ROW", pl_bt);
+ Xg_define_procedure(GTK_IS_SEARCH_BAR, gxg_GTK_IS_SEARCH_BAR_w, 1, 0, 0,
+ "(GTK_IS_SEARCH_BAR obj): " PROC_TRUE " if obj is a GTK_IS_SEARCH_BAR", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 12, 0)
- Xg_define_procedure(GTK_IS_FLOW_BOX, gxg_GTK_IS_FLOW_BOX_w, 1, 0, 0, "(GTK_IS_FLOW_BOX obj): " PROC_TRUE " if obj is a GTK_IS_FLOW_BOX", NULL);
- Xg_define_procedure(GTK_IS_FLOW_BOX_CHILD, gxg_GTK_IS_FLOW_BOX_CHILD_w, 1, 0, 0, "(GTK_IS_FLOW_BOX_CHILD obj): " PROC_TRUE " if obj is a GTK_IS_FLOW_BOX_CHILD", NULL);
- Xg_define_procedure(GTK_IS_ACTION_BAR, gxg_GTK_IS_ACTION_BAR_w, 1, 0, 0, "(GTK_IS_ACTION_BAR obj): " PROC_TRUE " if obj is a GTK_IS_ACTION_BAR", NULL);
- Xg_define_procedure(GTK_IS_POPOVER, gxg_GTK_IS_POPOVER_w, 1, 0, 0, "(GTK_IS_POPOVER obj): " PROC_TRUE " if obj is a GTK_IS_POPOVER", NULL);
+ Xg_define_procedure(GTK_IS_FLOW_BOX, gxg_GTK_IS_FLOW_BOX_w, 1, 0, 0,
+ "(GTK_IS_FLOW_BOX obj): " PROC_TRUE " if obj is a GTK_IS_FLOW_BOX", pl_bt);
+ Xg_define_procedure(GTK_IS_FLOW_BOX_CHILD, gxg_GTK_IS_FLOW_BOX_CHILD_w, 1, 0, 0,
+ "(GTK_IS_FLOW_BOX_CHILD obj): " PROC_TRUE " if obj is a GTK_IS_FLOW_BOX_CHILD", pl_bt);
+ Xg_define_procedure(GTK_IS_ACTION_BAR, gxg_GTK_IS_ACTION_BAR_w, 1, 0, 0,
+ "(GTK_IS_ACTION_BAR obj): " PROC_TRUE " if obj is a GTK_IS_ACTION_BAR", pl_bt);
+ Xg_define_procedure(GTK_IS_POPOVER, gxg_GTK_IS_POPOVER_w, 1, 0, 0,
+ "(GTK_IS_POPOVER obj): " PROC_TRUE " if obj is a GTK_IS_POPOVER", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 14, 0)
- Xg_define_procedure(GTK_IS_GESTURE, gxg_GTK_IS_GESTURE_w, 1, 0, 0, "(GTK_IS_GESTURE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_DRAG, gxg_GTK_IS_GESTURE_DRAG_w, 1, 0, 0, "(GTK_IS_GESTURE_DRAG obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_DRAG", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_LONG_PRESS, gxg_GTK_IS_GESTURE_LONG_PRESS_w, 1, 0, 0, "(GTK_IS_GESTURE_LONG_PRESS obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_LONG_PRESS", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_ZOOM, gxg_GTK_IS_GESTURE_ZOOM_w, 1, 0, 0, "(GTK_IS_GESTURE_ZOOM obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_ZOOM", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_SWIPE, gxg_GTK_IS_GESTURE_SWIPE_w, 1, 0, 0, "(GTK_IS_GESTURE_SWIPE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_SWIPE", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_SINGLE, gxg_GTK_IS_GESTURE_SINGLE_w, 1, 0, 0, "(GTK_IS_GESTURE_SINGLE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_SINGLE", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_PAN, gxg_GTK_IS_GESTURE_PAN_w, 1, 0, 0, "(GTK_IS_GESTURE_PAN obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_PAN", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_MULTI_PRESS, gxg_GTK_IS_GESTURE_MULTI_PRESS_w, 1, 0, 0, "(GTK_IS_GESTURE_MULTI_PRESS obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_MULTI_PRESS", NULL);
- Xg_define_procedure(GTK_IS_GESTURE_ROTATE, gxg_GTK_IS_GESTURE_ROTATE_w, 1, 0, 0, "(GTK_IS_GESTURE_ROTATE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_ROTATE", NULL);
- Xg_define_procedure(GTK_IS_EVENT_CONTROLLER, gxg_GTK_IS_EVENT_CONTROLLER_w, 1, 0, 0, "(GTK_IS_EVENT_CONTROLLER obj): " PROC_TRUE " if obj is a GTK_IS_EVENT_CONTROLLER", NULL);
+ Xg_define_procedure(GTK_IS_GESTURE, gxg_GTK_IS_GESTURE_w, 1, 0, 0,
+ "(GTK_IS_GESTURE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_DRAG, gxg_GTK_IS_GESTURE_DRAG_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_DRAG obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_DRAG", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_LONG_PRESS, gxg_GTK_IS_GESTURE_LONG_PRESS_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_LONG_PRESS obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_LONG_PRESS", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_ZOOM, gxg_GTK_IS_GESTURE_ZOOM_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_ZOOM obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_ZOOM", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_SWIPE, gxg_GTK_IS_GESTURE_SWIPE_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_SWIPE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_SWIPE", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_SINGLE, gxg_GTK_IS_GESTURE_SINGLE_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_SINGLE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_SINGLE", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_PAN, gxg_GTK_IS_GESTURE_PAN_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_PAN obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_PAN", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_MULTI_PRESS, gxg_GTK_IS_GESTURE_MULTI_PRESS_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_MULTI_PRESS obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_MULTI_PRESS", pl_bt);
+ Xg_define_procedure(GTK_IS_GESTURE_ROTATE, gxg_GTK_IS_GESTURE_ROTATE_w, 1, 0, 0,
+ "(GTK_IS_GESTURE_ROTATE obj): " PROC_TRUE " if obj is a GTK_IS_GESTURE_ROTATE", pl_bt);
+ Xg_define_procedure(GTK_IS_EVENT_CONTROLLER, gxg_GTK_IS_EVENT_CONTROLLER_w, 1, 0, 0,
+ "(GTK_IS_EVENT_CONTROLLER obj): " PROC_TRUE " if obj is a GTK_IS_EVENT_CONTROLLER", pl_bt);
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
- Xg_define_procedure(GTK_IS_GL_AREA, gxg_GTK_IS_GL_AREA_w, 1, 0, 0, "(GTK_IS_GL_AREA obj): " PROC_TRUE " if obj is a GTK_IS_GL_AREA", NULL);
- Xg_define_procedure(GDK_IS_GL_CONTEXT, gxg_GDK_IS_GL_CONTEXT_w, 1, 0, 0, "(GDK_IS_GL_CONTEXT obj): " PROC_TRUE " if obj is a GDK_IS_GL_CONTEXT", NULL);
- Xg_define_procedure(GTK_IS_POPOVER_MENU, gxg_GTK_IS_POPOVER_MENU_w, 1, 0, 0, "(GTK_IS_POPOVER_MENU obj): " PROC_TRUE " if obj is a GTK_IS_POPOVER_MENU", NULL);
- Xg_define_procedure(GTK_IS_STACK_SIDEBAR, gxg_GTK_IS_STACK_SIDEBAR_w, 1, 0, 0, "(GTK_IS_STACK_SIDEBAR obj): " PROC_TRUE " if obj is a GTK_IS_STACK_SIDEBAR", NULL);
+ Xg_define_procedure(GTK_IS_GL_AREA, gxg_GTK_IS_GL_AREA_w, 1, 0, 0,
+ "(GTK_IS_GL_AREA obj): " PROC_TRUE " if obj is a GTK_IS_GL_AREA", pl_bt);
+ Xg_define_procedure(GDK_IS_GL_CONTEXT, gxg_GDK_IS_GL_CONTEXT_w, 1, 0, 0,
+ "(GDK_IS_GL_CONTEXT obj): " PROC_TRUE " if obj is a GDK_IS_GL_CONTEXT", pl_bt);
+ Xg_define_procedure(GTK_IS_POPOVER_MENU, gxg_GTK_IS_POPOVER_MENU_w, 1, 0, 0,
+ "(GTK_IS_POPOVER_MENU obj): " PROC_TRUE " if obj is a GTK_IS_POPOVER_MENU", pl_bt);
+ Xg_define_procedure(GTK_IS_STACK_SIDEBAR, gxg_GTK_IS_STACK_SIDEBAR_w, 1, 0, 0,
+ "(GTK_IS_STACK_SIDEBAR obj): " PROC_TRUE " if obj is a GTK_IS_STACK_SIDEBAR", pl_bt);
+#endif
+
+#if GTK_CHECK_VERSION(3, 20, 0)
+ Xg_define_procedure(GDK_IS_SEAT, gxg_GDK_IS_SEAT_w, 1, 0, 0,
+ "(GDK_IS_SEAT obj): " PROC_TRUE " if obj is a GDK_IS_SEAT", pl_bt);
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+ Xg_define_procedure(GDK_IS_DEVICE_TOOL, gxg_GDK_IS_DEVICE_TOOL_w, 1, 0, 0,
+ "(GDK_IS_DEVICE_TOOL obj): " PROC_TRUE " if obj is a GDK_IS_DEVICE_TOOL", pl_bt);
#endif
}
@@ -44818,7 +45465,6 @@ static void define_integers(void)
define_integer(GTK_TOOL_PALETTE_DRAG_ITEMS);
define_integer(GTK_TOOL_PALETTE_DRAG_GROUPS);
define_integer(GTK_IMAGE_GICON);
- define_integer(GTK_FILE_CHOOSER_ERROR);
define_integer(GTK_FILE_CHOOSER_ERROR_NONEXISTENT);
define_integer(GTK_FILE_CHOOSER_ERROR_BAD_FILENAME);
define_integer(GTK_FILE_CHOOSER_ERROR_ALREADY_EXISTS);
@@ -44963,6 +45609,57 @@ static void define_integers(void)
define_integer(GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_LEFT);
define_integer(GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_RIGHT);
define_integer(GTK_SHORTCUT_GESTURE);
+ define_integer(GTK_POPOVER_CONSTRAINT_NONE);
+ define_integer(GTK_POPOVER_CONSTRAINT_WINDOW);
+ define_integer(GDK_WINDOW_TYPE_HINT_SPLASHSCREEN);
+ define_integer(GDK_WINDOW_TYPE_HINT_UTILITY);
+ define_integer(GDK_WINDOW_TYPE_HINT_DOCK);
+ define_integer(GDK_WINDOW_TYPE_HINT_DESKTOP);
+ define_integer(GDK_WINDOW_TYPE_HINT_DROPDOWN_MENU);
+ define_integer(GDK_WINDOW_TYPE_HINT_POPUP_MENU);
+ define_integer(GDK_WINDOW_TYPE_HINT_TOOLTIP);
+ define_integer(GDK_WINDOW_TYPE_HINT_NOTIFICATION);
+ define_integer(GDK_WINDOW_TYPE_HINT_COMBO);
+ define_integer(GDK_WINDOW_TYPE_HINT_DND);
+ define_integer(GDK_SEAT_CAPABILITY_NONE);
+ define_integer(GDK_SEAT_CAPABILITY_POINTER);
+ define_integer(GDK_SEAT_CAPABILITY_TOUCH);
+ define_integer(GDK_SEAT_CAPABILITY_TABLET_STYLUS);
+ define_integer(GDK_SEAT_CAPABILITY_KEYBOARD);
+ define_integer(GDK_SEAT_CAPABILITY_ALL_POINTING);
+ define_integer(GDK_SEAT_CAPABILITY_ALL);
+ define_integer(GTK_STATE_FLAG_DROP_ACTIVE);
+ define_integer(GDK_DRAG_CANCEL_NO_TARGET);
+ define_integer(GDK_DRAG_CANCEL_USER_CANCELLED);
+ define_integer(GDK_DRAG_CANCEL_ERROR);
+#endif
+
+#if GTK_CHECK_VERSION(3, 22, 0)
+ define_integer(GDK_AXIS_IGNORE);
+ define_integer(GDK_AXIS_X);
+ define_integer(GDK_AXIS_Y);
+ define_integer(GDK_AXIS_PRESSURE);
+ define_integer(GDK_AXIS_XTILT);
+ define_integer(GDK_AXIS_YTILT);
+ define_integer(GDK_AXIS_WHEEL);
+ define_integer(GDK_AXIS_LAST);
+ define_integer(GDK_AXIS_FLAG_X);
+ define_integer(GDK_AXIS_FLAG_Y);
+ define_integer(GDK_AXIS_FLAG_PRESSURE);
+ define_integer(GDK_AXIS_FLAG_XTILT);
+ define_integer(GDK_AXIS_FLAG_YTILT);
+ define_integer(GDK_AXIS_FLAG_WHEEL);
+ define_integer(GDK_AXIS_FLAG_DISTANCE);
+ define_integer(GDK_AXIS_FLAG_ROTATION);
+ define_integer(GDK_AXIS_FLAG_SLIDER);
+ define_integer(GDK_DEVICE_TOOL_TYPE_UNKNOWN);
+ define_integer(GDK_DEVICE_TOOL_TYPE_PEN);
+ define_integer(GDK_DEVICE_TOOL_TYPE_ERASER);
+ define_integer(GDK_DEVICE_TOOL_TYPE_BRUSH);
+ define_integer(GDK_DEVICE_TOOL_TYPE_PENCIL);
+ define_integer(GDK_DEVICE_TOOL_TYPE_AIRBRUSH);
+ define_integer(GDK_DEVICE_TOOL_TYPE_MOUSE);
+ define_integer(GDK_DEVICE_TOOL_TYPE_LENS);
#endif
define_integer(CAIRO_STATUS_SUCCESS);
@@ -45158,6 +45855,16 @@ static void define_atoms(void)
static void define_symbols(void)
{
+ xg_GdkDeviceTool__symbol = C_string_to_Xen_symbol("GdkDeviceTool_");
+ xg_GdkAxisFlags_symbol = C_string_to_Xen_symbol("GdkAxisFlags");
+ xg_GtkTextLayout__symbol = C_string_to_Xen_symbol("GtkTextLayout_");
+ xg_GdkRectangle_symbol = C_string_to_Xen_symbol("GdkRectangle");
+ xg_prepare_func_symbol = C_string_to_Xen_symbol("prepare_func");
+ xg_event_symbol = C_string_to_Xen_symbol("event");
+ xg_const_symbol = C_string_to_Xen_symbol("const");
+ xg_GdkSeatCapabilities_symbol = C_string_to_Xen_symbol("GdkSeatCapabilities");
+ xg_GdkGrabStatus_symbol = C_string_to_Xen_symbol("GdkGrabStatus");
+ xg_GtkPopoverConstraint_symbol = C_string_to_Xen_symbol("GtkPopoverConstraint");
xg_GtkAllocation_symbol = C_string_to_Xen_symbol("GtkAllocation");
xg_GtkShortcutsWindow__symbol = C_string_to_Xen_symbol("GtkShortcutsWindow_");
xg_GtkStackSidebar__symbol = C_string_to_Xen_symbol("GtkStackSidebar_");
@@ -45242,7 +45949,6 @@ static void define_symbols(void)
xg_cairo_region_t__symbol = C_string_to_Xen_symbol("cairo_region_t_");
xg_GtkMessageDialog__symbol = C_string_to_Xen_symbol("GtkMessageDialog_");
xg_GdkDevice__symbol = C_string_to_Xen_symbol("GdkDevice_");
- xg_GdkDeviceManager__symbol = C_string_to_Xen_symbol("GdkDeviceManager_");
xg_GtkAccessible__symbol = C_string_to_Xen_symbol("GtkAccessible_");
xg_GdkModifierType__symbol = C_string_to_Xen_symbol("GdkModifierType_");
xg_GtkToolPaletteDragTargets_symbol = C_string_to_Xen_symbol("GtkToolPaletteDragTargets");
@@ -45562,7 +46268,6 @@ static void define_symbols(void)
xg_GdkEventFunc_symbol = C_string_to_Xen_symbol("GdkEventFunc");
xg_gdouble_symbol = C_string_to_Xen_symbol("gdouble");
xg_GList__symbol = C_string_to_Xen_symbol("GList_");
- xg_GdkWindow__symbol = C_string_to_Xen_symbol("GdkWindow_");
xg_guint32_symbol = C_string_to_Xen_symbol("guint32");
xg_GdkDragAction_symbol = C_string_to_Xen_symbol("GdkDragAction");
xg_GdkDragContext__symbol = C_string_to_Xen_symbol("GdkDragContext_");
@@ -45592,6 +46297,8 @@ static void define_symbols(void)
xg_gssize_symbol = C_string_to_Xen_symbol("gssize");
xg_gunichar__symbol = C_string_to_Xen_symbol("gunichar_");
xg_void_symbol = C_string_to_Xen_symbol("void");
+ xg_GdkWindow__symbol = C_string_to_Xen_symbol("GdkWindow_");
+ xg_GdkSeat__symbol = C_string_to_Xen_symbol("GdkSeat_");
xg_GtkRecentInfo__symbol = C_string_to_Xen_symbol("GtkRecentInfo_");
xg_gsize_symbol = C_string_to_Xen_symbol("gsize");
xg_guint8__symbol = C_string_to_Xen_symbol("guint8_");
@@ -45710,6 +46417,10 @@ static void define_strings(void)
define_string(GTK_STYLE_CLASS_VERTICAL);
#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+ define_string(GTK_LEVEL_BAR_OFFSET_FULL);
+#endif
+
#if HAVE_CAIRO_1_9_12 && GTK_CHECK_VERSION(3, 0, 0)
define_string(CAIRO_MIME_TYPE_JPEG);
define_string(CAIRO_MIME_TYPE_PNG);
@@ -45719,6 +46430,1174 @@ static void define_strings(void)
}
+/* -------------------------------- lint -------------------------------- */
+
+#if HAVE_SCHEME
+typedef struct {const char *name, *type; long long int value;} enummer_t;
+static enummer_t enum_info[] = {
+#if GTK_CHECK_VERSION(2, 0, 0)
+ {"G_NORMALIZE_DEFAULT", "GNormalizeMode", G_NORMALIZE_DEFAULT},
+ {"G_NORMALIZE_NFD", "GNormalizeMode", G_NORMALIZE_NFD},
+ {"G_NORMALIZE_DEFAULT_COMPOSE", "GNormalizeMode", G_NORMALIZE_DEFAULT_COMPOSE},
+ {"G_NORMALIZE_NFC", "GNormalizeMode", G_NORMALIZE_NFC},
+ {"G_NORMALIZE_ALL", "GNormalizeMode", G_NORMALIZE_ALL},
+ {"G_NORMALIZE_NFKD", "GNormalizeMode", G_NORMALIZE_NFKD},
+ {"G_NORMALIZE_ALL_COMPOSE", "GNormalizeMode", G_NORMALIZE_ALL_COMPOSE},
+ {"G_NORMALIZE_NFKC", "GNormalizeMode", G_NORMALIZE_NFKC},
+ {"G_SIGNAL_RUN_FIRST", "GSignalFlags", G_SIGNAL_RUN_FIRST},
+ {"G_SIGNAL_RUN_LAST", "GSignalFlags", G_SIGNAL_RUN_LAST},
+ {"G_SIGNAL_RUN_CLEANUP", "GSignalFlags", G_SIGNAL_RUN_CLEANUP},
+ {"G_SIGNAL_NO_RECURSE", "GSignalFlags", G_SIGNAL_NO_RECURSE},
+ {"G_SIGNAL_DETAILED", "GSignalFlags", G_SIGNAL_DETAILED},
+ {"G_SIGNAL_ACTION", "GSignalFlags", G_SIGNAL_ACTION},
+ {"G_SIGNAL_NO_HOOKS", "GSignalFlags", G_SIGNAL_NO_HOOKS},
+ {"G_CONNECT_AFTER", "GConnectFlags", G_CONNECT_AFTER},
+ {"G_CONNECT_SWAPPED", "GConnectFlags", G_CONNECT_SWAPPED},
+ {"G_SIGNAL_MATCH_ID", "GSignalMatchType", G_SIGNAL_MATCH_ID},
+ {"G_SIGNAL_MATCH_DETAIL", "GSignalMatchType", G_SIGNAL_MATCH_DETAIL},
+ {"G_SIGNAL_MATCH_CLOSURE", "GSignalMatchType", G_SIGNAL_MATCH_CLOSURE},
+ {"G_SIGNAL_MATCH_FUNC", "GSignalMatchType", G_SIGNAL_MATCH_FUNC},
+ {"G_SIGNAL_MATCH_DATA", "GSignalMatchType", G_SIGNAL_MATCH_DATA},
+ {"G_SIGNAL_MATCH_UNBLOCKED", "GSignalMatchType", G_SIGNAL_MATCH_UNBLOCKED},
+ {"GDK_X_CURSOR", "GdkCursorType", GDK_X_CURSOR},
+ {"GDK_ARROW", "GdkCursorType", GDK_ARROW},
+ {"GDK_BASED_ARROW_DOWN", "GdkCursorType", GDK_BASED_ARROW_DOWN},
+ {"GDK_BASED_ARROW_UP", "GdkCursorType", GDK_BASED_ARROW_UP},
+ {"GDK_BOAT", "GdkCursorType", GDK_BOAT},
+ {"GDK_BOGOSITY", "GdkCursorType", GDK_BOGOSITY},
+ {"GDK_BOTTOM_LEFT_CORNER", "GdkCursorType", GDK_BOTTOM_LEFT_CORNER},
+ {"GDK_BOTTOM_RIGHT_CORNER", "GdkCursorType", GDK_BOTTOM_RIGHT_CORNER},
+ {"GDK_BOTTOM_SIDE", "GdkCursorType", GDK_BOTTOM_SIDE},
+ {"GDK_BOTTOM_TEE", "GdkCursorType", GDK_BOTTOM_TEE},
+ {"GDK_BOX_SPIRAL", "GdkCursorType", GDK_BOX_SPIRAL},
+ {"GDK_CENTER_PTR", "GdkCursorType", GDK_CENTER_PTR},
+ {"GDK_CIRCLE", "GdkCursorType", GDK_CIRCLE},
+ {"GDK_CLOCK", "GdkCursorType", GDK_CLOCK},
+ {"GDK_COFFEE_MUG", "GdkCursorType", GDK_COFFEE_MUG},
+ {"GDK_CROSS", "GdkCursorType", GDK_CROSS},
+ {"GDK_CROSS_REVERSE", "GdkCursorType", GDK_CROSS_REVERSE},
+ {"GDK_CROSSHAIR", "GdkCursorType", GDK_CROSSHAIR},
+ {"GDK_DIAMOND_CROSS", "GdkCursorType", GDK_DIAMOND_CROSS},
+ {"GDK_DOT", "GdkCursorType", GDK_DOT},
+ {"GDK_DOTBOX", "GdkCursorType", GDK_DOTBOX},
+ {"GDK_DOUBLE_ARROW", "GdkCursorType", GDK_DOUBLE_ARROW},
+ {"GDK_DRAFT_LARGE", "GdkCursorType", GDK_DRAFT_LARGE},
+ {"GDK_DRAFT_SMALL", "GdkCursorType", GDK_DRAFT_SMALL},
+ {"GDK_DRAPED_BOX", "GdkCursorType", GDK_DRAPED_BOX},
+ {"GDK_EXCHANGE", "GdkCursorType", GDK_EXCHANGE},
+ {"GDK_FLEUR", "GdkCursorType", GDK_FLEUR},
+ {"GDK_GOBBLER", "GdkCursorType", GDK_GOBBLER},
+ {"GDK_GUMBY", "GdkCursorType", GDK_GUMBY},
+ {"GDK_HAND1", "GdkCursorType", GDK_HAND1},
+ {"GDK_HAND2", "GdkCursorType", GDK_HAND2},
+ {"GDK_HEART", "GdkCursorType", GDK_HEART},
+ {"GDK_ICON", "GdkCursorType", GDK_ICON},
+ {"GDK_IRON_CROSS", "GdkCursorType", GDK_IRON_CROSS},
+ {"GDK_LEFT_PTR", "GdkCursorType", GDK_LEFT_PTR},
+ {"GDK_LEFT_SIDE", "GdkCursorType", GDK_LEFT_SIDE},
+ {"GDK_LEFT_TEE", "GdkCursorType", GDK_LEFT_TEE},
+ {"GDK_LEFTBUTTON", "GdkCursorType", GDK_LEFTBUTTON},
+ {"GDK_LL_ANGLE", "GdkCursorType", GDK_LL_ANGLE},
+ {"GDK_LR_ANGLE", "GdkCursorType", GDK_LR_ANGLE},
+ {"GDK_MAN", "GdkCursorType", GDK_MAN},
+ {"GDK_MIDDLEBUTTON", "GdkCursorType", GDK_MIDDLEBUTTON},
+ {"GDK_MOUSE", "GdkCursorType", GDK_MOUSE},
+ {"GDK_PENCIL", "GdkCursorType", GDK_PENCIL},
+ {"GDK_PIRATE", "GdkCursorType", GDK_PIRATE},
+ {"GDK_PLUS", "GdkCursorType", GDK_PLUS},
+ {"GDK_QUESTION_ARROW", "GdkCursorType", GDK_QUESTION_ARROW},
+ {"GDK_RIGHT_PTR", "GdkCursorType", GDK_RIGHT_PTR},
+ {"GDK_RIGHT_SIDE", "GdkCursorType", GDK_RIGHT_SIDE},
+ {"GDK_RIGHT_TEE", "GdkCursorType", GDK_RIGHT_TEE},
+ {"GDK_RIGHTBUTTON", "GdkCursorType", GDK_RIGHTBUTTON},
+ {"GDK_RTL_LOGO", "GdkCursorType", GDK_RTL_LOGO},
+ {"GDK_SAILBOAT", "GdkCursorType", GDK_SAILBOAT},
+ {"GDK_SB_DOWN_ARROW", "GdkCursorType", GDK_SB_DOWN_ARROW},
+ {"GDK_SB_H_DOUBLE_ARROW", "GdkCursorType", GDK_SB_H_DOUBLE_ARROW},
+ {"GDK_SB_LEFT_ARROW", "GdkCursorType", GDK_SB_LEFT_ARROW},
+ {"GDK_SB_RIGHT_ARROW", "GdkCursorType", GDK_SB_RIGHT_ARROW},
+ {"GDK_SB_UP_ARROW", "GdkCursorType", GDK_SB_UP_ARROW},
+ {"GDK_SB_V_DOUBLE_ARROW", "GdkCursorType", GDK_SB_V_DOUBLE_ARROW},
+ {"GDK_SHUTTLE", "GdkCursorType", GDK_SHUTTLE},
+ {"GDK_SIZING", "GdkCursorType", GDK_SIZING},
+ {"GDK_SPIDER", "GdkCursorType", GDK_SPIDER},
+ {"GDK_SPRAYCAN", "GdkCursorType", GDK_SPRAYCAN},
+ {"GDK_STAR", "GdkCursorType", GDK_STAR},
+ {"GDK_TARGET", "GdkCursorType", GDK_TARGET},
+ {"GDK_TCROSS", "GdkCursorType", GDK_TCROSS},
+ {"GDK_TOP_LEFT_ARROW", "GdkCursorType", GDK_TOP_LEFT_ARROW},
+ {"GDK_TOP_LEFT_CORNER", "GdkCursorType", GDK_TOP_LEFT_CORNER},
+ {"GDK_TOP_RIGHT_CORNER", "GdkCursorType", GDK_TOP_RIGHT_CORNER},
+ {"GDK_TOP_SIDE", "GdkCursorType", GDK_TOP_SIDE},
+ {"GDK_TOP_TEE", "GdkCursorType", GDK_TOP_TEE},
+ {"GDK_TREK", "GdkCursorType", GDK_TREK},
+ {"GDK_UL_ANGLE", "GdkCursorType", GDK_UL_ANGLE},
+ {"GDK_UMBRELLA", "GdkCursorType", GDK_UMBRELLA},
+ {"GDK_UR_ANGLE", "GdkCursorType", GDK_UR_ANGLE},
+ {"GDK_WATCH", "GdkCursorType", GDK_WATCH},
+ {"GDK_XTERM", "GdkCursorType", GDK_XTERM},
+ {"GDK_LAST_CURSOR ", "GdkCursorType", GDK_LAST_CURSOR },
+ {"GDK_ACTION_DEFAULT", "GdkDragAction", GDK_ACTION_DEFAULT},
+ {"GDK_ACTION_COPY", "GdkDragAction", GDK_ACTION_COPY},
+ {"GDK_ACTION_MOVE", "GdkDragAction", GDK_ACTION_MOVE},
+ {"GDK_ACTION_LINK", "GdkDragAction", GDK_ACTION_LINK},
+ {"GDK_ACTION_PRIVATE", "GdkDragAction", GDK_ACTION_PRIVATE},
+ {"GDK_ACTION_ASK", "GdkDragAction", GDK_ACTION_ASK},
+ {"GDK_NOTHING", "GdkEventType", GDK_NOTHING},
+ {"GDK_DELETE", "GdkEventType", GDK_DELETE},
+ {"GDK_DESTROY", "GdkEventType", GDK_DESTROY},
+ {"GDK_EXPOSE", "GdkEventType", GDK_EXPOSE},
+ {"GDK_MOTION_NOTIFY", "GdkEventType", GDK_MOTION_NOTIFY},
+ {"GDK_BUTTON_PRESS", "GdkEventType", GDK_BUTTON_PRESS},
+ {"GDK_2BUTTON_PRESS", "GdkEventType", GDK_2BUTTON_PRESS},
+ {"GDK_3BUTTON_PRESS", "GdkEventType", GDK_3BUTTON_PRESS},
+ {"GDK_BUTTON_RELEASE", "GdkEventType", GDK_BUTTON_RELEASE},
+ {"GDK_KEY_PRESS", "GdkEventType", GDK_KEY_PRESS},
+ {"GDK_KEY_RELEASE", "GdkEventType", GDK_KEY_RELEASE},
+ {"GDK_ENTER_NOTIFY", "GdkEventType", GDK_ENTER_NOTIFY},
+ {"GDK_LEAVE_NOTIFY", "GdkEventType", GDK_LEAVE_NOTIFY},
+ {"GDK_FOCUS_CHANGE", "GdkEventType", GDK_FOCUS_CHANGE},
+ {"GDK_CONFIGURE", "GdkEventType", GDK_CONFIGURE},
+ {"GDK_MAP", "GdkEventType", GDK_MAP},
+ {"GDK_UNMAP", "GdkEventType", GDK_UNMAP},
+ {"GDK_PROPERTY_NOTIFY", "GdkEventType", GDK_PROPERTY_NOTIFY},
+ {"GDK_SELECTION_CLEAR", "GdkEventType", GDK_SELECTION_CLEAR},
+ {"GDK_SELECTION_REQUEST", "GdkEventType", GDK_SELECTION_REQUEST},
+ {"GDK_SELECTION_NOTIFY", "GdkEventType", GDK_SELECTION_NOTIFY},
+ {"GDK_PROXIMITY_IN", "GdkEventType", GDK_PROXIMITY_IN},
+ {"GDK_PROXIMITY_OUT", "GdkEventType", GDK_PROXIMITY_OUT},
+ {"GDK_DRAG_ENTER", "GdkEventType", GDK_DRAG_ENTER},
+ {"GDK_DRAG_LEAVE", "GdkEventType", GDK_DRAG_LEAVE},
+ {"GDK_DRAG_MOTION", "GdkEventType", GDK_DRAG_MOTION},
+ {"GDK_DRAG_STATUS", "GdkEventType", GDK_DRAG_STATUS},
+ {"GDK_DROP_START", "GdkEventType", GDK_DROP_START},
+ {"GDK_DROP_FINISHED", "GdkEventType", GDK_DROP_FINISHED},
+ {"GDK_CLIENT_EVENT", "GdkEventType", GDK_CLIENT_EVENT},
+ {"GDK_VISIBILITY_NOTIFY", "GdkEventType", GDK_VISIBILITY_NOTIFY},
+ {"GDK_SCROLL", "GdkEventType", GDK_SCROLL},
+ {"GDK_WINDOW_STATE", "GdkEventType", GDK_WINDOW_STATE},
+ {"GDK_SETTING", "GdkEventType", GDK_SETTING},
+ {"GDK_OWNER_CHANGE", "GdkEventType", GDK_OWNER_CHANGE},
+ {"GDK_GRAB_BROKEN", "GdkEventType", GDK_GRAB_BROKEN},
+ {"GDK_EXPOSURE_MASK", "GdkEventMask", GDK_EXPOSURE_MASK},
+ {"GDK_POINTER_MOTION_MASK", "GdkEventMask", GDK_POINTER_MOTION_MASK},
+ {"GDK_BUTTON_MOTION_MASK", "GdkEventMask", GDK_BUTTON_MOTION_MASK},
+ {"GDK_BUTTON1_MOTION_MASK", "GdkEventMask", GDK_BUTTON1_MOTION_MASK},
+ {"GDK_BUTTON2_MOTION_MASK", "GdkEventMask", GDK_BUTTON2_MOTION_MASK},
+ {"GDK_BUTTON3_MOTION_MASK", "GdkEventMask", GDK_BUTTON3_MOTION_MASK},
+ {"GDK_BUTTON_PRESS_MASK", "GdkEventMask", GDK_BUTTON_PRESS_MASK},
+ {"GDK_BUTTON_RELEASE_MASK", "GdkEventMask", GDK_BUTTON_RELEASE_MASK},
+ {"GDK_KEY_PRESS_MASK", "GdkEventMask", GDK_KEY_PRESS_MASK},
+ {"GDK_KEY_RELEASE_MASK", "GdkEventMask", GDK_KEY_RELEASE_MASK},
+ {"GDK_ENTER_NOTIFY_MASK", "GdkEventMask", GDK_ENTER_NOTIFY_MASK},
+ {"GDK_LEAVE_NOTIFY_MASK", "GdkEventMask", GDK_LEAVE_NOTIFY_MASK},
+ {"GDK_FOCUS_CHANGE_MASK", "GdkEventMask", GDK_FOCUS_CHANGE_MASK},
+ {"GDK_STRUCTURE_MASK", "GdkEventMask", GDK_STRUCTURE_MASK},
+ {"GDK_PROPERTY_CHANGE_MASK", "GdkEventMask", GDK_PROPERTY_CHANGE_MASK},
+ {"GDK_VISIBILITY_NOTIFY_MASK", "GdkEventMask", GDK_VISIBILITY_NOTIFY_MASK},
+ {"GDK_PROXIMITY_IN_MASK", "GdkEventMask", GDK_PROXIMITY_IN_MASK},
+ {"GDK_PROXIMITY_OUT_MASK", "GdkEventMask", GDK_PROXIMITY_OUT_MASK},
+ {"GDK_SUBSTRUCTURE_MASK", "GdkEventMask", GDK_SUBSTRUCTURE_MASK},
+ {"GDK_SCROLL_MASK", "GdkEventMask", GDK_SCROLL_MASK},
+ {"GDK_ALL_EVENTS_MASK", "GdkEventMask", GDK_ALL_EVENTS_MASK},
+ {"GDK_SCROLL_UP", "GdkScrollDirection", GDK_SCROLL_UP},
+ {"GDK_SCROLL_DOWN", "GdkScrollDirection", GDK_SCROLL_DOWN},
+ {"GDK_SCROLL_LEFT", "GdkScrollDirection", GDK_SCROLL_LEFT},
+ {"GDK_SCROLL_RIGHT", "GdkScrollDirection", GDK_SCROLL_RIGHT},
+ {"GDK_NOTIFY_ANCESTOR", "GdkNotifyType", GDK_NOTIFY_ANCESTOR},
+ {"GDK_NOTIFY_VIRTUAL", "GdkNotifyType", GDK_NOTIFY_VIRTUAL},
+ {"GDK_NOTIFY_INFERIOR", "GdkNotifyType", GDK_NOTIFY_INFERIOR},
+ {"GDK_NOTIFY_NONLINEAR", "GdkNotifyType", GDK_NOTIFY_NONLINEAR},
+ {"GDK_NOTIFY_NONLINEAR_VIRTUAL", "GdkNotifyType", GDK_NOTIFY_NONLINEAR_VIRTUAL},
+ {"GDK_NOTIFY_UNKNOWN", "GdkNotifyType", GDK_NOTIFY_UNKNOWN},
+ {"GDK_CROSSING_NORMAL", "GdkCrossingMode", GDK_CROSSING_NORMAL},
+ {"GDK_CROSSING_GRAB", "GdkNotifyType", GDK_CROSSING_GRAB},
+ {"GDK_CROSSING_UNGRAB", "GdkNotifyType", GDK_CROSSING_UNGRAB},
+ {"GDK_PROPERTY_NEW_VALUE", "GdkPropertyState", GDK_PROPERTY_NEW_VALUE},
+ {"GDK_PROPERTY_DELETE", "GdkPropertyState", GDK_PROPERTY_DELETE},
+ {"GDK_WINDOW_STATE_WITHDRAWN", "GdkWindowState", GDK_WINDOW_STATE_WITHDRAWN},
+ {"GDK_WINDOW_STATE_ICONIFIED", "GdkWindowState", GDK_WINDOW_STATE_ICONIFIED},
+ {"GDK_WINDOW_STATE_MAXIMIZED", "GdkWindowState", GDK_WINDOW_STATE_MAXIMIZED},
+ {"GDK_WINDOW_STATE_STICKY", "GdkWindowState", GDK_WINDOW_STATE_STICKY},
+ {"GDK_SETTING_ACTION_NEW", "GdkSettingAction", GDK_SETTING_ACTION_NEW},
+ {"GDK_SETTING_ACTION_CHANGED", "GdkSettingAction", GDK_SETTING_ACTION_CHANGED},
+ {"GDK_SETTING_ACTION_DELETED", "GdkSettingAction", GDK_SETTING_ACTION_DELETED},
+ {"GDK_PROP_MODE_REPLACE", "GdkPropMode", GDK_PROP_MODE_REPLACE},
+ {"GDK_PROP_MODE_PREPEND", "GdkPropMode", GDK_PROP_MODE_PREPEND},
+ {"GDK_PROP_MODE_APPEND", "GdkPropMode", GDK_PROP_MODE_APPEND},
+ {"GDK_LSB_FIRST", "GdkByteOrder", GDK_LSB_FIRST},
+ {"GDK_MSB_FIRST", "GdkByteOrder", GDK_MSB_FIRST},
+ {"GDK_SHIFT_MASK", "GdkModifierType", GDK_SHIFT_MASK},
+ {"GDK_LOCK_MASK", "GdkModifierType", GDK_LOCK_MASK},
+ {"GDK_CONTROL_MASK", "GdkModifierType", GDK_CONTROL_MASK},
+ {"GDK_MOD1_MASK", "GdkModifierType", GDK_MOD1_MASK},
+ {"GDK_MOD2_MASK", "GdkModifierType", GDK_MOD2_MASK},
+ {"GDK_MOD3_MASK", "GdkModifierType", GDK_MOD3_MASK},
+ {"GDK_MOD4_MASK", "GdkModifierType", GDK_MOD4_MASK},
+ {"GDK_MOD5_MASK", "GdkModifierType", GDK_MOD5_MASK},
+ {"GDK_BUTTON1_MASK", "GdkModifierType", GDK_BUTTON1_MASK},
+ {"GDK_BUTTON2_MASK", "GdkModifierType", GDK_BUTTON2_MASK},
+ {"GDK_BUTTON3_MASK", "GdkModifierType", GDK_BUTTON3_MASK},
+ {"GDK_BUTTON4_MASK", "GdkModifierType", GDK_BUTTON4_MASK},
+ {"GDK_BUTTON5_MASK", "GdkModifierType", GDK_BUTTON5_MASK},
+ {"GDK_RELEASE_MASK", "GdkModifierType", GDK_RELEASE_MASK},
+ {"GDK_MODIFIER_MASK", "GdkModifierType", GDK_MODIFIER_MASK},
+ {"GDK_OK", "GdkStatus", GDK_OK},
+ {"GDK_ERROR", "GdkStatus", GDK_ERROR},
+ {"GDK_ERROR_PARAM", "GdkStatus", GDK_ERROR_PARAM},
+ {"GDK_ERROR_FILE", "GdkStatus", GDK_ERROR_FILE},
+ {"GDK_ERROR_MEM", "GdkStatus", GDK_ERROR_MEM},
+ {"GDK_GRAB_SUCCESS", "GdkGrabStatus", GDK_GRAB_SUCCESS},
+ {"GDK_GRAB_ALREADY_GRABBED", "GdkGrabStatus", GDK_GRAB_ALREADY_GRABBED},
+ {"GDK_GRAB_INVALID_TIME", "GdkGrabStatus", GDK_GRAB_INVALID_TIME},
+ {"GDK_GRAB_NOT_VIEWABLE", "GdkGrabStatus", GDK_GRAB_NOT_VIEWABLE},
+ {"GDK_GRAB_FROZEN", "GdkGrabStatus", GDK_GRAB_FROZEN},
+ {"GDK_VISUAL_STATIC_GRAY", "GdkVisualType", GDK_VISUAL_STATIC_GRAY},
+ {"GDK_VISUAL_GRAYSCALE", "GdkVisualType", GDK_VISUAL_GRAYSCALE},
+ {"GDK_VISUAL_STATIC_COLOR", "GdkVisualType", GDK_VISUAL_STATIC_COLOR},
+ {"GDK_VISUAL_PSEUDO_COLOR", "GdkVisualType", GDK_VISUAL_PSEUDO_COLOR},
+ {"GDK_VISUAL_TRUE_COLOR", "GdkVisualType", GDK_VISUAL_TRUE_COLOR},
+ {"GDK_VISUAL_DIRECT_COLOR", "GdkVisualType", GDK_VISUAL_DIRECT_COLOR},
+ {"GDK_INPUT_OUTPUT", "GdkWindowClass", GDK_INPUT_OUTPUT},
+ {"GDK_INPUT_ONLY", "GdkWindowClass", GDK_INPUT_ONLY},
+ {"GDK_WINDOW_ROOT", "GdkWindowType", GDK_WINDOW_ROOT},
+ {"GDK_WINDOW_TOPLEVEL", "GdkWindowType", GDK_WINDOW_TOPLEVEL},
+ {"GDK_WINDOW_CHILD", "GdkWindowType", GDK_WINDOW_CHILD},
+ {"GDK_WINDOW_TEMP", "GdkWindowType", GDK_WINDOW_TEMP},
+ {"GDK_WINDOW_FOREIGN", "GdkWindowType", GDK_WINDOW_FOREIGN},
+ {"GDK_WA_TITLE", "GdkWindowAttributesType", GDK_WA_TITLE},
+ {"GDK_WA_X", "GdkWindowAttributesType", GDK_WA_X},
+ {"GDK_WA_Y", "GdkWindowAttributesType", GDK_WA_Y},
+ {"GDK_WA_CURSOR", "GdkWindowAttributesType", GDK_WA_CURSOR},
+ {"GDK_WA_VISUAL", "GdkWindowAttributesType", GDK_WA_VISUAL},
+ {"GDK_WA_WMCLASS", "GdkWindowAttributesType", GDK_WA_WMCLASS},
+ {"GDK_WA_NOREDIR", "GdkWindowAttributesType", GDK_WA_NOREDIR},
+ {"GDK_HINT_POS", "GdkWindowHints", GDK_HINT_POS},
+ {"GDK_HINT_MIN_SIZE", "GdkWindowHints", GDK_HINT_MIN_SIZE},
+ {"GDK_HINT_MAX_SIZE", "GdkWindowHints", GDK_HINT_MAX_SIZE},
+ {"GDK_HINT_BASE_SIZE", "GdkWindowHints", GDK_HINT_BASE_SIZE},
+ {"GDK_HINT_ASPECT", "GdkWindowHints", GDK_HINT_ASPECT},
+ {"GDK_HINT_RESIZE_INC", "GdkWindowHints", GDK_HINT_RESIZE_INC},
+ {"GDK_HINT_WIN_GRAVITY", "GdkWindowHints", GDK_HINT_WIN_GRAVITY},
+ {"GDK_HINT_USER_POS", "GdkWindowHints", GDK_HINT_USER_POS},
+ {"GDK_HINT_USER_SIZE", "GdkWindowHints", GDK_HINT_USER_SIZE},
+ {"GDK_WINDOW_TYPE_HINT_NORMAL", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_NORMAL},
+ {"GDK_WINDOW_TYPE_HINT_DIALOG", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_DIALOG},
+ {"GDK_WINDOW_TYPE_HINT_MENU", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_MENU},
+ {"GDK_WINDOW_TYPE_HINT_TOOLBAR", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_TOOLBAR},
+ {"GDK_DECOR_ALL", "GdkWMDecoration", GDK_DECOR_ALL},
+ {"GDK_DECOR_BORDER", "GdkWMDecoration", GDK_DECOR_BORDER},
+ {"GDK_DECOR_RESIZEH", "GdkWMDecoration", GDK_DECOR_RESIZEH},
+ {"GDK_DECOR_TITLE", "GdkWMDecoration", GDK_DECOR_TITLE},
+ {"GDK_DECOR_MENU", "GdkWMDecoration", GDK_DECOR_MENU},
+ {"GDK_DECOR_MINIMIZE", "GdkWMDecoration", GDK_DECOR_MINIMIZE},
+ {"GDK_DECOR_MAXIMIZE", "GdkWMDecoration", GDK_DECOR_MAXIMIZE},
+ {"GDK_FUNC_ALL", "GdkWMFunction", GDK_FUNC_ALL},
+ {"GDK_FUNC_RESIZE", "GdkWMFunction", GDK_FUNC_RESIZE},
+ {"GDK_FUNC_MOVE", "GdkWMFunction", GDK_FUNC_MOVE},
+ {"GDK_FUNC_MINIMIZE", "GdkWMFunction", GDK_FUNC_MINIMIZE},
+ {"GDK_FUNC_MAXIMIZE", "GdkWMFunction", GDK_FUNC_MAXIMIZE},
+ {"GDK_FUNC_CLOSE", "GdkWMFunction", GDK_FUNC_CLOSE},
+ {"GDK_GRAVITY_NORTH_WEST", "GdkGravity", GDK_GRAVITY_NORTH_WEST},
+ {"GDK_GRAVITY_NORTH", "GdkGravity", GDK_GRAVITY_NORTH},
+ {"GDK_GRAVITY_NORTH_EAST", "GdkGravity", GDK_GRAVITY_NORTH_EAST},
+ {"GDK_GRAVITY_WEST", "GdkGravity", GDK_GRAVITY_WEST},
+ {"GDK_GRAVITY_CENTER", "GdkGravity", GDK_GRAVITY_CENTER},
+ {"GDK_GRAVITY_EAST", "GdkGravity", GDK_GRAVITY_EAST},
+ {"GDK_GRAVITY_SOUTH_WEST", "GdkGravity", GDK_GRAVITY_SOUTH_WEST},
+ {"GDK_GRAVITY_SOUTH", "GdkGravity", GDK_GRAVITY_SOUTH},
+ {"GDK_GRAVITY_SOUTH_EAST", "GdkGravity", GDK_GRAVITY_SOUTH_EAST},
+ {"GDK_GRAVITY_STATIC", "GdkGravity", GDK_GRAVITY_STATIC},
+ {"GDK_WINDOW_EDGE_NORTH_WEST", "GdkWindowEdge", GDK_WINDOW_EDGE_NORTH_WEST},
+ {"GDK_WINDOW_EDGE_NORTH", "GdkWindowEdge", GDK_WINDOW_EDGE_NORTH},
+ {"GDK_WINDOW_EDGE_NORTH_EAST", "GdkWindowEdge", GDK_WINDOW_EDGE_NORTH_EAST},
+ {"GDK_WINDOW_EDGE_WEST", "GdkWindowEdge", GDK_WINDOW_EDGE_WEST},
+ {"GDK_WINDOW_EDGE_EAST", "GdkWindowEdge", GDK_WINDOW_EDGE_EAST},
+ {"GDK_WINDOW_EDGE_SOUTH_WEST", "GdkWindowEdge", GDK_WINDOW_EDGE_SOUTH_WEST},
+ {"GDK_WINDOW_EDGE_SOUTH", "GdkWindowEdge", GDK_WINDOW_EDGE_SOUTH},
+ {"GDK_WINDOW_EDGE_SOUTH_EAST", "GdkWindowEdge", GDK_WINDOW_EDGE_SOUTH_EAST},
+ {"GDK_PIXBUF_ALPHA_BILEVEL", "GdkPixbufAlphaMode", GDK_PIXBUF_ALPHA_BILEVEL},
+ {"GDK_PIXBUF_ALPHA_FULL", "GdkPixbufAlphaMode", GDK_PIXBUF_ALPHA_FULL},
+ {"GDK_COLORSPACE_RGB", "GdkColorspace", GDK_COLORSPACE_RGB},
+ {"GDK_PIXBUF_ERROR_CORRUPT_IMAGE", "GdkPixbufError", GDK_PIXBUF_ERROR_CORRUPT_IMAGE},
+ {"GDK_PIXBUF_ERROR_INSUFFICIENT_MEMORY", "GdkPixbufError", GDK_PIXBUF_ERROR_INSUFFICIENT_MEMORY},
+ {"GDK_PIXBUF_ERROR_BAD_OPTION", "GdkPixbufError", GDK_PIXBUF_ERROR_BAD_OPTION},
+ {"GDK_PIXBUF_ERROR_UNKNOWN_TYPE", "GdkPixbufError", GDK_PIXBUF_ERROR_UNKNOWN_TYPE},
+ {"GDK_PIXBUF_ERROR_UNSUPPORTED_OPERATION", "GdkPixbufError", GDK_PIXBUF_ERROR_UNSUPPORTED_OPERATION},
+ {"GDK_PIXBUF_ERROR_FAILED", "GdkPixbufError", GDK_PIXBUF_ERROR_FAILED},
+ {"GDK_INTERP_NEAREST", "GdkInterpType", GDK_INTERP_NEAREST},
+ {"GDK_INTERP_TILES", "GdkInterpType", GDK_INTERP_TILES},
+ {"GDK_INTERP_BILINEAR", "GdkInterpType", GDK_INTERP_BILINEAR},
+ {"GDK_INTERP_HYPER", "GdkInterpType", GDK_INTERP_HYPER},
+ {"GTK_ACCEL_VISIBLE", "GtkAccelFlags", GTK_ACCEL_VISIBLE},
+ {"GTK_ACCEL_LOCKED", "GtkAccelFlags", GTK_ACCEL_LOCKED},
+ {"GTK_ACCEL_MASK", "GtkAccelFlags", GTK_ACCEL_MASK},
+ {"GTK_CALENDAR_SHOW_HEADING", "GtkCalendarDisplayOptions", GTK_CALENDAR_SHOW_HEADING},
+ {"GTK_CALENDAR_SHOW_DAY_NAMES", "GtkCalendarDisplayOptions", GTK_CALENDAR_SHOW_DAY_NAMES},
+ {"GTK_CALENDAR_NO_MONTH_CHANGE", "GtkCalendarDisplayOptions", GTK_CALENDAR_NO_MONTH_CHANGE},
+ {"GTK_CALENDAR_SHOW_WEEK_NUMBERS", "GtkCalendarDisplayOptions", GTK_CALENDAR_SHOW_WEEK_NUMBERS},
+ {"GTK_CELL_RENDERER_SELECTED", "GtkCellRendererState", GTK_CELL_RENDERER_SELECTED},
+ {"GTK_CELL_RENDERER_PRELIT", "GtkCellRendererState", GTK_CELL_RENDERER_PRELIT},
+ {"GTK_CELL_RENDERER_INSENSITIVE", "GtkCellRendererState", GTK_CELL_RENDERER_INSENSITIVE},
+ {"GTK_CELL_RENDERER_SORTED", "GtkCellRendererState", GTK_CELL_RENDERER_SORTED},
+ {"GTK_CELL_RENDERER_FOCUSED", "GtkCellRendererState", GTK_CELL_RENDERER_FOCUSED},
+ {"GTK_DIALOG_MODAL", "GtkDialogFlags", GTK_DIALOG_MODAL},
+ {"GTK_DIALOG_DESTROY_WITH_PARENT", "GtkDialogFlags", GTK_DIALOG_DESTROY_WITH_PARENT},
+ {"GTK_RESPONSE_NONE", "GtkResponseType", GTK_RESPONSE_NONE},
+ {"GTK_RESPONSE_REJECT", "GtkResponseType", GTK_RESPONSE_REJECT},
+ {"GTK_RESPONSE_ACCEPT", "GtkResponseType", GTK_RESPONSE_ACCEPT},
+ {"GTK_RESPONSE_DELETE_EVENT", "GtkResponseType", GTK_RESPONSE_DELETE_EVENT},
+ {"GTK_RESPONSE_OK", "GtkResponseType", GTK_RESPONSE_OK},
+ {"GTK_RESPONSE_CANCEL", "GtkResponseType", GTK_RESPONSE_CANCEL},
+ {"GTK_RESPONSE_CLOSE", "GtkResponseType", GTK_RESPONSE_CLOSE},
+ {"GTK_RESPONSE_YES", "GtkResponseType", GTK_RESPONSE_YES},
+ {"GTK_RESPONSE_NO", "GtkResponseType", GTK_RESPONSE_NO},
+ {"GTK_RESPONSE_APPLY", "GtkResponseType", GTK_RESPONSE_APPLY},
+ {"GTK_RESPONSE_HELP", "GtkResponseType", GTK_RESPONSE_HELP},
+ {"GTK_DEST_DEFAULT_MOTION", "GtkDestDefaults", GTK_DEST_DEFAULT_MOTION},
+ {"GTK_DEST_DEFAULT_HIGHLIGHT", "GtkDestDefaults", GTK_DEST_DEFAULT_HIGHLIGHT},
+ {"GTK_DEST_DEFAULT_DROP", "GtkDestDefaults", GTK_DEST_DEFAULT_DROP},
+ {"GTK_DEST_DEFAULT_ALL", "GtkDestDefaults", GTK_DEST_DEFAULT_ALL},
+ {"GTK_BUTTONBOX_SPREAD", "GtkButtonBoxStyle", GTK_BUTTONBOX_SPREAD},
+ {"GTK_BUTTONBOX_EDGE", "GtkButtonBoxStyle", GTK_BUTTONBOX_EDGE},
+ {"GTK_BUTTONBOX_START", "GtkButtonBoxStyle", GTK_BUTTONBOX_START},
+ {"GTK_BUTTONBOX_END", "GtkButtonBoxStyle", GTK_BUTTONBOX_END},
+ {"GTK_BUTTONBOX_CENTER", "GtkButtonBoxStyle", GTK_BUTTONBOX_CENTER},
+ {"GTK_DELETE_CHARS", "GtkDeleteType", GTK_DELETE_CHARS},
+ {"GTK_DELETE_WORD_ENDS", "GtkDeleteType", GTK_DELETE_WORD_ENDS},
+ {"GTK_DELETE_WORDS", "GtkDeleteType", GTK_DELETE_WORDS},
+ {"GTK_DELETE_DISPLAY_LINES", "GtkDeleteType", GTK_DELETE_DISPLAY_LINES},
+ {"GTK_DELETE_DISPLAY_LINE_ENDS", "GtkDeleteType", GTK_DELETE_DISPLAY_LINE_ENDS},
+ {"GTK_DELETE_PARAGRAPH_ENDS", "GtkDeleteType", GTK_DELETE_PARAGRAPH_ENDS},
+ {"GTK_DELETE_PARAGRAPHS", "GtkDeleteType", GTK_DELETE_PARAGRAPHS},
+ {"GTK_DELETE_WHITESPACE", "GtkDeleteType", GTK_DELETE_WHITESPACE},
+ {"GTK_DIR_TAB_FORWARD", "GtkDirectionType", GTK_DIR_TAB_FORWARD},
+ {"GTK_DIR_TAB_BACKWARD", "GtkDirectionType", GTK_DIR_TAB_BACKWARD},
+ {"GTK_DIR_UP", "GtkDirectionType", GTK_DIR_UP},
+ {"GTK_DIR_DOWN", "GtkDirectionType", GTK_DIR_DOWN},
+ {"GTK_DIR_LEFT", "GtkDirectionType", GTK_DIR_LEFT},
+ {"GTK_DIR_RIGHT", "GtkDirectionType", GTK_DIR_RIGHT},
+ {"GTK_TEXT_DIR_NONE", "GtkTextDirection", GTK_TEXT_DIR_NONE},
+ {"GTK_TEXT_DIR_LTR", "GtkTextDirection", GTK_TEXT_DIR_LTR},
+ {"GTK_TEXT_DIR_RTL", "GtkTextDirection", GTK_TEXT_DIR_RTL},
+ {"GTK_JUSTIFY_LEFT", "GtkJustification", GTK_JUSTIFY_LEFT},
+ {"GTK_JUSTIFY_RIGHT", "GtkJustification", GTK_JUSTIFY_RIGHT},
+ {"GTK_JUSTIFY_CENTER", "GtkJustification", GTK_JUSTIFY_CENTER},
+ {"GTK_JUSTIFY_FILL", "GtkJustification", GTK_JUSTIFY_FILL},
+ {"GTK_MENU_DIR_PARENT", "GtkMenuDirectionType", GTK_MENU_DIR_PARENT},
+ {"GTK_MENU_DIR_CHILD", "GtkMenuDirectionType", GTK_MENU_DIR_CHILD},
+ {"GTK_MENU_DIR_NEXT", "GtkMenuDirectionType", GTK_MENU_DIR_NEXT},
+ {"GTK_MENU_DIR_PREV", "GtkMenuDirectionType", GTK_MENU_DIR_PREV},
+ {"GTK_MOVEMENT_LOGICAL_POSITIONS", "GtkMovementStep", GTK_MOVEMENT_LOGICAL_POSITIONS},
+ {"GTK_MOVEMENT_VISUAL_POSITIONS", "GtkMovementStep", GTK_MOVEMENT_VISUAL_POSITIONS},
+ {"GTK_MOVEMENT_WORDS", "GtkMovementStep", GTK_MOVEMENT_WORDS},
+ {"GTK_MOVEMENT_DISPLAY_LINES", "GtkMovementStep", GTK_MOVEMENT_DISPLAY_LINES},
+ {"GTK_MOVEMENT_DISPLAY_LINE_ENDS", "GtkMovementStep", GTK_MOVEMENT_DISPLAY_LINE_ENDS},
+ {"GTK_MOVEMENT_PARAGRAPHS", "GtkMovementStep", GTK_MOVEMENT_PARAGRAPHS},
+ {"GTK_MOVEMENT_PARAGRAPH_ENDS", "GtkMovementStep", GTK_MOVEMENT_PARAGRAPH_ENDS},
+ {"GTK_MOVEMENT_PAGES", "GtkMovementStep", GTK_MOVEMENT_PAGES},
+ {"GTK_MOVEMENT_BUFFER_ENDS", "GtkMovementStep", GTK_MOVEMENT_BUFFER_ENDS},
+ {"GTK_ORIENTATION_HORIZONTAL", "GtkOrientation", GTK_ORIENTATION_HORIZONTAL},
+ {"GTK_ORIENTATION_VERTICAL", "GtkOrientation", GTK_ORIENTATION_VERTICAL},
+ {"GTK_CORNER_TOP_LEFT", "GtkCornerType", GTK_CORNER_TOP_LEFT},
+ {"GTK_CORNER_BOTTOM_LEFT", "GtkCornerType", GTK_CORNER_BOTTOM_LEFT},
+ {"GTK_CORNER_TOP_RIGHT", "GtkCornerType", GTK_CORNER_TOP_RIGHT},
+ {"GTK_CORNER_BOTTOM_RIGHT", "GtkCornerType", GTK_CORNER_BOTTOM_RIGHT},
+ {"GTK_PACK_START", "GtkPackType", GTK_PACK_START},
+ {"GTK_PACK_END", "GtkPackType", GTK_PACK_END},
+ {"GTK_POLICY_ALWAYS", "GtkPolicyType", GTK_POLICY_ALWAYS},
+ {"GTK_POLICY_AUTOMATIC", "GtkPolicyType", GTK_POLICY_AUTOMATIC},
+ {"GTK_POLICY_NEVER", "GtkPolicyType", GTK_POLICY_NEVER},
+ {"GTK_POS_LEFT", "GtkPositionType", GTK_POS_LEFT},
+ {"GTK_POS_RIGHT", "GtkPositionType", GTK_POS_RIGHT},
+ {"GTK_POS_TOP", "GtkPositionType", GTK_POS_TOP},
+ {"GTK_POS_BOTTOM", "GtkPositionType", GTK_POS_BOTTOM},
+ {"GTK_RELIEF_NORMAL", "GtkReliefStyle", GTK_RELIEF_NORMAL},
+ {"GTK_RELIEF_HALF", "GtkReliefStyle", GTK_RELIEF_HALF},
+ {"GTK_RELIEF_NONE", "GtkReliefStyle", GTK_RELIEF_NONE},
+ {"GTK_RESIZE_PARENT", "GtkResizeMode", GTK_RESIZE_PARENT},
+ {"GTK_RESIZE_QUEUE", "GtkResizeMode", GTK_RESIZE_QUEUE},
+ {"GTK_RESIZE_IMMEDIATE", "GtkResizeMode", GTK_RESIZE_IMMEDIATE},
+ {"GTK_SCROLL_NONE", "GtkScrollType", GTK_SCROLL_NONE},
+ {"GTK_SCROLL_JUMP", "GtkScrollType", GTK_SCROLL_JUMP},
+ {"GTK_SCROLL_STEP_BACKWARD", "GtkScrollType", GTK_SCROLL_STEP_BACKWARD},
+ {"GTK_SCROLL_STEP_FORWARD", "GtkScrollType", GTK_SCROLL_STEP_FORWARD},
+ {"GTK_SCROLL_PAGE_BACKWARD", "GtkScrollType", GTK_SCROLL_PAGE_BACKWARD},
+ {"GTK_SCROLL_PAGE_FORWARD", "GtkScrollType", GTK_SCROLL_PAGE_FORWARD},
+ {"GTK_SCROLL_STEP_UP", "GtkScrollType", GTK_SCROLL_STEP_UP},
+ {"GTK_SCROLL_STEP_DOWN", "GtkScrollType", GTK_SCROLL_STEP_DOWN},
+ {"GTK_SCROLL_PAGE_UP", "GtkScrollType", GTK_SCROLL_PAGE_UP},
+ {"GTK_SCROLL_PAGE_DOWN", "GtkScrollType", GTK_SCROLL_PAGE_DOWN},
+ {"GTK_SCROLL_STEP_LEFT", "GtkScrollType", GTK_SCROLL_STEP_LEFT},
+ {"GTK_SCROLL_STEP_RIGHT", "GtkScrollType", GTK_SCROLL_STEP_RIGHT},
+ {"GTK_SCROLL_PAGE_LEFT", "GtkScrollType", GTK_SCROLL_PAGE_LEFT},
+ {"GTK_SCROLL_PAGE_RIGHT", "GtkScrollType", GTK_SCROLL_PAGE_RIGHT},
+ {"GTK_SCROLL_START", "GtkScrollType", GTK_SCROLL_START},
+ {"GTK_SCROLL_END", "GtkScrollType", GTK_SCROLL_END},
+ {"GTK_SELECTION_NONE", "GtkSelectionMode", GTK_SELECTION_NONE},
+ {"GTK_SELECTION_SINGLE", "GtkSelectionMode", GTK_SELECTION_SINGLE},
+ {"GTK_SELECTION_BROWSE", "GtkSelectionMode", GTK_SELECTION_BROWSE},
+ {"GTK_SELECTION_MULTIPLE", "GtkSelectionMode", GTK_SELECTION_MULTIPLE},
+ {"GTK_SHADOW_NONE", "GtkShadowType", GTK_SHADOW_NONE},
+ {"GTK_SHADOW_IN", "GtkShadowType", GTK_SHADOW_IN},
+ {"GTK_SHADOW_OUT", "GtkShadowType", GTK_SHADOW_OUT},
+ {"GTK_SHADOW_ETCHED_IN", "GtkShadowType", GTK_SHADOW_ETCHED_IN},
+ {"GTK_SHADOW_ETCHED_OUT", "GtkShadowType", GTK_SHADOW_ETCHED_OUT},
+ {"GTK_TOOLBAR_ICONS", "GtkToolbarStyle", GTK_TOOLBAR_ICONS},
+ {"GTK_TOOLBAR_TEXT", "GtkToolbarStyle", GTK_TOOLBAR_TEXT},
+ {"GTK_TOOLBAR_BOTH", "GtkToolbarStyle", GTK_TOOLBAR_BOTH},
+ {"GTK_TOOLBAR_BOTH_HORIZ", "GtkToolbarStyle", GTK_TOOLBAR_BOTH_HORIZ},
+ {"GTK_WIN_POS_NONE", "GtkWindowPosition", GTK_WIN_POS_NONE},
+ {"GTK_WIN_POS_CENTER", "GtkWindowPosition", GTK_WIN_POS_CENTER},
+ {"GTK_WIN_POS_MOUSE", "GtkWindowPosition", GTK_WIN_POS_MOUSE},
+ {"GTK_WIN_POS_CENTER_ALWAYS", "GtkWindowPosition", GTK_WIN_POS_CENTER_ALWAYS},
+ {"GTK_WIN_POS_CENTER_ON_PARENT", "GtkWindowPosition", GTK_WIN_POS_CENTER_ON_PARENT},
+ {"GTK_WINDOW_TOPLEVEL", "GtkWindowType", GTK_WINDOW_TOPLEVEL},
+ {"GTK_WINDOW_POPUP", "GtkWindowType", GTK_WINDOW_POPUP},
+ {"GTK_WRAP_NONE", "GtkWrapMode", GTK_WRAP_NONE},
+ {"GTK_WRAP_CHAR", "GtkWrapMode", GTK_WRAP_CHAR},
+ {"GTK_WRAP_WORD", "GtkWrapMode", GTK_WRAP_WORD},
+ {"GTK_SORT_ASCENDING", "GtkSortType", GTK_SORT_ASCENDING},
+ {"GTK_SORT_DESCENDING", "GtkSortType", GTK_SORT_DESCENDING},
+ {"GTK_IMAGE_EMPTY", "GtkImageType", GTK_IMAGE_EMPTY},
+ {"GTK_IMAGE_PIXBUF", "GtkImageType", GTK_IMAGE_PIXBUF},
+ {"GTK_IMAGE_STOCK", "GtkImageType", GTK_IMAGE_STOCK},
+ {"GTK_IMAGE_ICON_SET", "GtkImageType", GTK_IMAGE_ICON_SET},
+ {"GTK_IMAGE_ANIMATION", "GtkImageType", GTK_IMAGE_ANIMATION},
+ {"GTK_MESSAGE_INFO", "GtkMessageType", GTK_MESSAGE_INFO},
+ {"GTK_MESSAGE_WARNING", "GtkMessageType", GTK_MESSAGE_WARNING},
+ {"GTK_MESSAGE_QUESTION", "GtkMessageType", GTK_MESSAGE_QUESTION},
+ {"GTK_MESSAGE_ERROR", "GtkMessageType", GTK_MESSAGE_ERROR},
+ {"GTK_BUTTONS_NONE", "GtkButtonsType", GTK_BUTTONS_NONE},
+ {"GTK_BUTTONS_OK", "GtkButtonsType", GTK_BUTTONS_OK},
+ {"GTK_BUTTONS_CLOSE", "GtkButtonsType", GTK_BUTTONS_CLOSE},
+ {"GTK_BUTTONS_CANCEL", "GtkButtonsType", GTK_BUTTONS_CANCEL},
+ {"GTK_BUTTONS_YES_NO", "GtkButtonsType", GTK_BUTTONS_YES_NO},
+ {"GTK_BUTTONS_OK_CANCEL", "GtkButtonsType", GTK_BUTTONS_OK_CANCEL},
+ {"GTK_NOTEBOOK_TAB_FIRST", "GtkNotebookTab", GTK_NOTEBOOK_TAB_FIRST},
+ {"GTK_NOTEBOOK_TAB_LAST", "GtkNotebookTab", GTK_NOTEBOOK_TAB_LAST},
+ {"GTK_SIZE_GROUP_NONE", "GtkSizeGroupMode", GTK_SIZE_GROUP_NONE},
+ {"GTK_SIZE_GROUP_HORIZONTAL", "GtkSizeGroupMode", GTK_SIZE_GROUP_HORIZONTAL},
+ {"GTK_SIZE_GROUP_VERTICAL", "GtkSizeGroupMode", GTK_SIZE_GROUP_VERTICAL},
+ {"GTK_SIZE_GROUP_BOTH", "GtkSizeGroupMode", GTK_SIZE_GROUP_BOTH},
+ {"GTK_UPDATE_ALWAYS", "GtkSpinButtonUpdatePolicy", GTK_UPDATE_ALWAYS},
+ {"GTK_UPDATE_IF_VALID", "GtkSpinButtonUpdatePolicy", GTK_UPDATE_IF_VALID},
+ {"GTK_SPIN_STEP_FORWARD", "GtkSpinType", GTK_SPIN_STEP_FORWARD},
+ {"GTK_SPIN_STEP_BACKWARD", "GtkSpinType", GTK_SPIN_STEP_BACKWARD},
+ {"GTK_SPIN_PAGE_FORWARD", "GtkSpinType", GTK_SPIN_PAGE_FORWARD},
+ {"GTK_SPIN_PAGE_BACKWARD", "GtkSpinType", GTK_SPIN_PAGE_BACKWARD},
+ {"GTK_SPIN_HOME", "GtkSpinType", GTK_SPIN_HOME},
+ {"GTK_SPIN_END", "GtkSpinType", GTK_SPIN_END},
+ {"GTK_TEXT_SEARCH_VISIBLE_ONLY", "GtkTextSearchFlags", GTK_TEXT_SEARCH_VISIBLE_ONLY},
+ {"GTK_TEXT_SEARCH_TEXT_ONLY", "GtkTextSearchFlags", GTK_TEXT_SEARCH_TEXT_ONLY},
+ {"GTK_TEXT_WINDOW_PRIVATE", "GtkTextWindowType", GTK_TEXT_WINDOW_PRIVATE},
+ {"GTK_TEXT_WINDOW_WIDGET", "GtkTextWindowType", GTK_TEXT_WINDOW_WIDGET},
+ {"GTK_TEXT_WINDOW_TEXT", "GtkTextWindowType", GTK_TEXT_WINDOW_TEXT},
+ {"GTK_TEXT_WINDOW_LEFT", "GtkTextWindowType", GTK_TEXT_WINDOW_LEFT},
+ {"GTK_TEXT_WINDOW_RIGHT", "GtkTextWindowType", GTK_TEXT_WINDOW_RIGHT},
+ {"GTK_TEXT_WINDOW_TOP", "GtkTextWindowType", GTK_TEXT_WINDOW_TOP},
+ {"GTK_TEXT_WINDOW_BOTTOM", "GtkTextWindowType", GTK_TEXT_WINDOW_BOTTOM},
+ {"GTK_TREE_MODEL_ITERS_PERSIST", "GtkTreeModelFlags", GTK_TREE_MODEL_ITERS_PERSIST},
+ {"GTK_TREE_MODEL_LIST_ONLY", "GtkTreeModelFlags", GTK_TREE_MODEL_LIST_ONLY},
+ {"GTK_TREE_VIEW_COLUMN_GROW_ONLY", "GtkTreeViewColumnSizing", GTK_TREE_VIEW_COLUMN_GROW_ONLY},
+ {"GTK_TREE_VIEW_COLUMN_AUTOSIZE", "GtkTreeViewColumnSizing", GTK_TREE_VIEW_COLUMN_AUTOSIZE},
+ {"GTK_TREE_VIEW_COLUMN_FIXED", "GtkTreeViewColumnSizing", GTK_TREE_VIEW_COLUMN_FIXED},
+ {"GTK_TREE_VIEW_DROP_BEFORE", "GtkTreeViewDropPosition", GTK_TREE_VIEW_DROP_BEFORE},
+ {"GTK_TREE_VIEW_DROP_AFTER", "GtkTreeViewDropPosition", GTK_TREE_VIEW_DROP_AFTER},
+ {"GTK_TREE_VIEW_DROP_INTO_OR_BEFORE", "GtkTreeViewDropPosition", GTK_TREE_VIEW_DROP_INTO_OR_BEFORE},
+ {"GTK_TREE_VIEW_DROP_INTO_OR_AFTER", "GtkTreeViewDropPosition", GTK_TREE_VIEW_DROP_INTO_OR_AFTER},
+ {"PANGO_ATTR_INVALID", "PangoAttrType", PANGO_ATTR_INVALID},
+ {"PANGO_ATTR_LANGUAGE", "PangoAttrType", PANGO_ATTR_LANGUAGE},
+ {"PANGO_ATTR_FAMILY", "PangoAttrType", PANGO_ATTR_FAMILY},
+ {"PANGO_ATTR_STYLE", "PangoAttrType", PANGO_ATTR_STYLE},
+ {"PANGO_ATTR_WEIGHT", "PangoAttrType", PANGO_ATTR_WEIGHT},
+ {"PANGO_ATTR_VARIANT", "PangoAttrType", PANGO_ATTR_VARIANT},
+ {"PANGO_ATTR_STRETCH", "PangoAttrType", PANGO_ATTR_STRETCH},
+ {"PANGO_ATTR_SIZE", "PangoAttrType", PANGO_ATTR_SIZE},
+ {"PANGO_ATTR_FONT_DESC", "PangoAttrType", PANGO_ATTR_FONT_DESC},
+ {"PANGO_ATTR_FOREGROUND", "PangoAttrType", PANGO_ATTR_FOREGROUND},
+ {"PANGO_ATTR_BACKGROUND", "PangoAttrType", PANGO_ATTR_BACKGROUND},
+ {"PANGO_ATTR_UNDERLINE", "PangoAttrType", PANGO_ATTR_UNDERLINE},
+ {"PANGO_ATTR_STRIKETHROUGH", "PangoAttrType", PANGO_ATTR_STRIKETHROUGH},
+ {"PANGO_ATTR_RISE", "PangoAttrType", PANGO_ATTR_RISE},
+ {"PANGO_ATTR_SHAPE", "PangoAttrType", PANGO_ATTR_SHAPE},
+ {"PANGO_ATTR_SCALE", "PangoAttrType", PANGO_ATTR_SCALE},
+ {"PANGO_UNDERLINE_NONE", "PangoUnderline", PANGO_UNDERLINE_NONE},
+ {"PANGO_UNDERLINE_SINGLE", "PangoUnderline", PANGO_UNDERLINE_SINGLE},
+ {"PANGO_UNDERLINE_DOUBLE", "PangoUnderline", PANGO_UNDERLINE_DOUBLE},
+ {"PANGO_UNDERLINE_LOW", "PangoUnderline", PANGO_UNDERLINE_LOW},
+ {"PANGO_COVERAGE_NONE", "PangoCoverageLevel", PANGO_COVERAGE_NONE},
+ {"PANGO_COVERAGE_FALLBACK", "PangoCoverageLevel", PANGO_COVERAGE_FALLBACK},
+ {"PANGO_COVERAGE_APPROXIMATE", "PangoCoverageLevel", PANGO_COVERAGE_APPROXIMATE},
+ {"PANGO_COVERAGE_EXACT", "PangoCoverageLevel", PANGO_COVERAGE_EXACT},
+ {"PANGO_STYLE_NORMAL", "PangoStyle", PANGO_STYLE_NORMAL},
+ {"PANGO_STYLE_OBLIQUE", "PangoStyle", PANGO_STYLE_OBLIQUE},
+ {"PANGO_STYLE_ITALIC", "PangoStyle", PANGO_STYLE_ITALIC},
+ {"PANGO_VARIANT_NORMAL", "PangoVariant", PANGO_VARIANT_NORMAL},
+ {"PANGO_VARIANT_SMALL_CAPS", "PangoVariant", PANGO_VARIANT_SMALL_CAPS},
+ {"PANGO_WEIGHT_ULTRALIGHT", "PangoWeight", PANGO_WEIGHT_ULTRALIGHT},
+ {"PANGO_WEIGHT_LIGHT", "PangoWeight", PANGO_WEIGHT_LIGHT},
+ {"PANGO_WEIGHT_NORMAL", "PangoWeight", PANGO_WEIGHT_NORMAL},
+ {"PANGO_WEIGHT_BOLD", "PangoWeight", PANGO_WEIGHT_BOLD},
+ {"PANGO_WEIGHT_ULTRABOLD", "PangoWeight", PANGO_WEIGHT_ULTRABOLD},
+ {"PANGO_WEIGHT_HEAVY", "PangoWeight", PANGO_WEIGHT_HEAVY},
+ {"PANGO_STRETCH_ULTRA_CONDENSED", "PangoStretch", PANGO_STRETCH_ULTRA_CONDENSED},
+ {"PANGO_STRETCH_EXTRA_CONDENSED", "PangoStretch", PANGO_STRETCH_EXTRA_CONDENSED},
+ {"PANGO_STRETCH_CONDENSED", "PangoStretch", PANGO_STRETCH_CONDENSED},
+ {"PANGO_STRETCH_SEMI_CONDENSED", "PangoStretch", PANGO_STRETCH_SEMI_CONDENSED},
+ {"PANGO_STRETCH_NORMAL", "PangoStretch", PANGO_STRETCH_NORMAL},
+ {"PANGO_STRETCH_SEMI_EXPANDED", "PangoStretch", PANGO_STRETCH_SEMI_EXPANDED},
+ {"PANGO_STRETCH_EXPANDED", "PangoStretch", PANGO_STRETCH_EXPANDED},
+ {"PANGO_STRETCH_EXTRA_EXPANDED", "PangoStretch", PANGO_STRETCH_EXTRA_EXPANDED},
+ {"PANGO_STRETCH_ULTRA_EXPANDED", "PangoStretch", PANGO_STRETCH_ULTRA_EXPANDED},
+ {"PANGO_FONT_MASK_FAMILY", "PangoFontMask", PANGO_FONT_MASK_FAMILY},
+ {"PANGO_FONT_MASK_STYLE", "PangoFontMask", PANGO_FONT_MASK_STYLE},
+ {"PANGO_FONT_MASK_VARIANT", "PangoFontMask", PANGO_FONT_MASK_VARIANT},
+ {"PANGO_FONT_MASK_WEIGHT", "PangoFontMask", PANGO_FONT_MASK_WEIGHT},
+ {"PANGO_FONT_MASK_STRETCH", "PangoFontMask", PANGO_FONT_MASK_STRETCH},
+ {"PANGO_FONT_MASK_SIZE", "PangoFontMask", PANGO_FONT_MASK_SIZE},
+ {"PANGO_ALIGN_LEFT", "PangoAlignment", PANGO_ALIGN_LEFT},
+ {"PANGO_ALIGN_CENTER", "PangoAlignment", PANGO_ALIGN_CENTER},
+ {"PANGO_ALIGN_RIGHT", "PangoAlignment", PANGO_ALIGN_RIGHT},
+ {"PANGO_WRAP_WORD", "PangoWrapMode", PANGO_WRAP_WORD},
+ {"PANGO_WRAP_CHAR", "PangoWrapMode", PANGO_WRAP_CHAR},
+ {"PANGO_DIRECTION_LTR", "PangoDirection", PANGO_DIRECTION_LTR},
+ {"PANGO_DIRECTION_RTL", "PangoDirection", PANGO_DIRECTION_RTL},
+ {"PANGO_DIRECTION_TTB_LTR", "PangoDirection", PANGO_DIRECTION_TTB_LTR},
+ {"PANGO_DIRECTION_TTB_RTL", "PangoDirection", PANGO_DIRECTION_TTB_RTL},
+ {"GDK_WINDOW_STATE_FULLSCREEN", "GdkWindowState", GDK_WINDOW_STATE_FULLSCREEN},
+ {"GDK_WINDOW_STATE_ABOVE", "GdkWindowState", GDK_WINDOW_STATE_ABOVE},
+ {"GDK_WINDOW_STATE_BELOW", "GdkWindowState", GDK_WINDOW_STATE_BELOW},
+ {"GTK_MOVEMENT_HORIZONTAL_PAGES", "GtkMovementStep", GTK_MOVEMENT_HORIZONTAL_PAGES},
+ {"GTK_SCROLL_STEPS", "GtkScrollStep", GTK_SCROLL_STEPS},
+ {"GTK_SCROLL_PAGES", "GtkScrollStep", GTK_SCROLL_PAGES},
+ {"GTK_SCROLL_ENDS", "GtkScrollStep", GTK_SCROLL_ENDS},
+ {"GTK_SCROLL_HORIZONTAL_STEPS", "GtkScrollStep", GTK_SCROLL_HORIZONTAL_STEPS},
+ {"GTK_SCROLL_HORIZONTAL_PAGES", "GtkScrollStep", GTK_SCROLL_HORIZONTAL_PAGES},
+ {"GTK_SCROLL_HORIZONTAL_ENDS", "GtkScrollStep", GTK_SCROLL_HORIZONTAL_ENDS},
+ {"GTK_WRAP_WORD_CHAR", "GtkWrapMode", GTK_WRAP_WORD_CHAR},
+ {"GTK_FILE_FILTER_FILENAME", "GtkFileFilterFlags", GTK_FILE_FILTER_FILENAME},
+ {"GTK_FILE_FILTER_URI", "GtkFileFilterFlags", GTK_FILE_FILTER_URI},
+ {"GTK_FILE_FILTER_DISPLAY_NAME", "GtkFileFilterFlags", GTK_FILE_FILTER_DISPLAY_NAME},
+ {"GTK_FILE_FILTER_MIME_TYPE", "GtkFileFilterFlags", GTK_FILE_FILTER_MIME_TYPE},
+ {"GTK_ICON_LOOKUP_NO_SVG", "GtkIconLookupFlags", GTK_ICON_LOOKUP_NO_SVG},
+ {"GTK_ICON_LOOKUP_FORCE_SVG", "GtkIconLookupFlags", GTK_ICON_LOOKUP_FORCE_SVG},
+ {"GTK_ICON_LOOKUP_USE_BUILTIN", "GtkIconLookupFlags", GTK_ICON_LOOKUP_USE_BUILTIN},
+ {"GTK_ICON_LOOKUP_GENERIC_FALLBACK", "GtkIconLookupFlags", GTK_ICON_LOOKUP_GENERIC_FALLBACK},
+ {"GTK_FILE_CHOOSER_ACTION_OPEN", "GtkFileChooserAction", GTK_FILE_CHOOSER_ACTION_OPEN},
+ {"GTK_FILE_CHOOSER_ACTION_SAVE", "GtkFileChooserAction", GTK_FILE_CHOOSER_ACTION_SAVE},
+ {"GTK_FILE_CHOOSER_ACTION_SELECT_FOLDER", "GtkFileChooserAction", GTK_FILE_CHOOSER_ACTION_SELECT_FOLDER},
+ {"GTK_FILE_CHOOSER_ACTION_CREATE_FOLDER", "GtkFileChooserAction", GTK_FILE_CHOOSER_ACTION_CREATE_FOLDER},
+ {"PANGO_ATTR_FALLBACK", "PangoAttrType", PANGO_ATTR_FALLBACK},
+ {"PANGO_ATTR_LETTER_SPACING", "PangoAttrType", PANGO_ATTR_LETTER_SPACING},
+ {"PANGO_UNDERLINE_ERROR", "PangoUnderline", PANGO_UNDERLINE_ERROR},
+ {"PANGO_WRAP_WORD_CHAR", "PangoWrapMode", PANGO_WRAP_WORD_CHAR},
+ {"PANGO_ELLIPSIZE_NONE", "PangoEllipsizeMode", PANGO_ELLIPSIZE_NONE},
+ {"PANGO_ELLIPSIZE_START", "PangoEllipsizeMode", PANGO_ELLIPSIZE_START},
+ {"PANGO_ELLIPSIZE_MIDDLE", "PangoEllipsizeMode", PANGO_ELLIPSIZE_MIDDLE},
+ {"PANGO_ELLIPSIZE_END", "PangoEllipsizeMode", PANGO_ELLIPSIZE_END},
+ {"PANGO_SCRIPT_INVALID_CODE", "PangoScript", PANGO_SCRIPT_INVALID_CODE},
+ {"PANGO_SCRIPT_COMMON", "PangoScript", PANGO_SCRIPT_COMMON},
+ {"PANGO_SCRIPT_INHERITED", "PangoScript", PANGO_SCRIPT_INHERITED},
+ {"PANGO_SCRIPT_ARABIC", "PangoScript", PANGO_SCRIPT_ARABIC},
+ {"PANGO_SCRIPT_ARMENIAN", "PangoScript", PANGO_SCRIPT_ARMENIAN},
+ {"PANGO_SCRIPT_BENGALI", "PangoScript", PANGO_SCRIPT_BENGALI},
+ {"PANGO_SCRIPT_BOPOMOFO", "PangoScript", PANGO_SCRIPT_BOPOMOFO},
+ {"PANGO_SCRIPT_CHEROKEE", "PangoScript", PANGO_SCRIPT_CHEROKEE},
+ {"PANGO_SCRIPT_COPTIC", "PangoScript", PANGO_SCRIPT_COPTIC},
+ {"PANGO_SCRIPT_CYRILLIC", "PangoScript", PANGO_SCRIPT_CYRILLIC},
+ {"PANGO_SCRIPT_DESERET", "PangoScript", PANGO_SCRIPT_DESERET},
+ {"PANGO_SCRIPT_DEVANAGARI", "PangoScript", PANGO_SCRIPT_DEVANAGARI},
+ {"PANGO_SCRIPT_ETHIOPIC", "PangoScript", PANGO_SCRIPT_ETHIOPIC},
+ {"PANGO_SCRIPT_GEORGIAN", "PangoScript", PANGO_SCRIPT_GEORGIAN},
+ {"PANGO_SCRIPT_GOTHIC", "PangoScript", PANGO_SCRIPT_GOTHIC},
+ {"PANGO_SCRIPT_GREEK", "PangoScript", PANGO_SCRIPT_GREEK},
+ {"PANGO_SCRIPT_GUJARATI", "PangoScript", PANGO_SCRIPT_GUJARATI},
+ {"PANGO_SCRIPT_GURMUKHI", "PangoScript", PANGO_SCRIPT_GURMUKHI},
+ {"PANGO_SCRIPT_HAN", "PangoScript", PANGO_SCRIPT_HAN},
+ {"PANGO_SCRIPT_HANGUL", "PangoScript", PANGO_SCRIPT_HANGUL},
+ {"PANGO_SCRIPT_HEBREW", "PangoScript", PANGO_SCRIPT_HEBREW},
+ {"PANGO_SCRIPT_HIRAGANA", "PangoScript", PANGO_SCRIPT_HIRAGANA},
+ {"PANGO_SCRIPT_KANNADA", "PangoScript", PANGO_SCRIPT_KANNADA},
+ {"PANGO_SCRIPT_KATAKANA", "PangoScript", PANGO_SCRIPT_KATAKANA},
+ {"PANGO_SCRIPT_KHMER", "PangoScript", PANGO_SCRIPT_KHMER},
+ {"PANGO_SCRIPT_LAO", "PangoScript", PANGO_SCRIPT_LAO},
+ {"PANGO_SCRIPT_LATIN", "PangoScript", PANGO_SCRIPT_LATIN},
+ {"PANGO_SCRIPT_MALAYALAM", "PangoScript", PANGO_SCRIPT_MALAYALAM},
+ {"PANGO_SCRIPT_MONGOLIAN", "PangoScript", PANGO_SCRIPT_MONGOLIAN},
+ {"PANGO_SCRIPT_MYANMAR", "PangoScript", PANGO_SCRIPT_MYANMAR},
+ {"PANGO_SCRIPT_OGHAM", "PangoScript", PANGO_SCRIPT_OGHAM},
+ {"PANGO_SCRIPT_OLD_ITALIC", "PangoScript", PANGO_SCRIPT_OLD_ITALIC},
+ {"PANGO_SCRIPT_ORIYA", "PangoScript", PANGO_SCRIPT_ORIYA},
+ {"PANGO_SCRIPT_RUNIC", "PangoScript", PANGO_SCRIPT_RUNIC},
+ {"PANGO_SCRIPT_SINHALA", "PangoScript", PANGO_SCRIPT_SINHALA},
+ {"PANGO_SCRIPT_SYRIAC", "PangoScript", PANGO_SCRIPT_SYRIAC},
+ {"PANGO_SCRIPT_TAMIL", "PangoScript", PANGO_SCRIPT_TAMIL},
+ {"PANGO_SCRIPT_TELUGU", "PangoScript", PANGO_SCRIPT_TELUGU},
+ {"PANGO_SCRIPT_THAANA", "PangoScript", PANGO_SCRIPT_THAANA},
+ {"PANGO_SCRIPT_THAI", "PangoScript", PANGO_SCRIPT_THAI},
+ {"PANGO_SCRIPT_TIBETAN", "PangoScript", PANGO_SCRIPT_TIBETAN},
+ {"PANGO_SCRIPT_CANADIAN_ABORIGINAL", "PangoScript", PANGO_SCRIPT_CANADIAN_ABORIGINAL},
+ {"PANGO_SCRIPT_YI", "PangoScript", PANGO_SCRIPT_YI},
+ {"PANGO_SCRIPT_TAGALOG", "PangoScript", PANGO_SCRIPT_TAGALOG},
+ {"PANGO_SCRIPT_HANUNOO", "PangoScript", PANGO_SCRIPT_HANUNOO},
+ {"PANGO_SCRIPT_BUHID", "PangoScript", PANGO_SCRIPT_BUHID},
+ {"PANGO_SCRIPT_TAGBANWA", "PangoScript", PANGO_SCRIPT_TAGBANWA},
+ {"PANGO_SCRIPT_BRAILLE", "PangoScript", PANGO_SCRIPT_BRAILLE},
+ {"PANGO_SCRIPT_CYPRIOT", "PangoScript", PANGO_SCRIPT_CYPRIOT},
+ {"PANGO_SCRIPT_LIMBU", "PangoScript", PANGO_SCRIPT_LIMBU},
+ {"PANGO_SCRIPT_OSMANYA", "PangoScript", PANGO_SCRIPT_OSMANYA},
+ {"PANGO_SCRIPT_SHAVIAN", "PangoScript", PANGO_SCRIPT_SHAVIAN},
+ {"PANGO_SCRIPT_LINEAR_B", "PangoScript", PANGO_SCRIPT_LINEAR_B},
+ {"PANGO_SCRIPT_TAI_LE", "PangoScript", PANGO_SCRIPT_TAI_LE},
+ {"PANGO_SCRIPT_UGARITIC", "PangoScript", PANGO_SCRIPT_UGARITIC},
+ {"PANGO_TAB_LEFT", "PangoTabAlign", PANGO_TAB_LEFT},
+ {"PANGO_DIRECTION_WEAK_LTR", "PangoDirection", PANGO_DIRECTION_WEAK_LTR},
+ {"PANGO_DIRECTION_WEAK_RTL", "PangoDirection", PANGO_DIRECTION_WEAK_RTL},
+ {"PANGO_DIRECTION_NEUTRAL", "PangoDirection", PANGO_DIRECTION_NEUTRAL},
+ {"GTK_IMAGE_ICON_NAME", "GtkImageType", GTK_IMAGE_ICON_NAME},
+ {"PANGO_ATTR_UNDERLINE_COLOR", "PangoAttrType", PANGO_ATTR_UNDERLINE_COLOR},
+ {"PANGO_ATTR_STRIKETHROUGH_COLOR", "PangoAttrType", PANGO_ATTR_STRIKETHROUGH_COLOR},
+ {"PANGO_RENDER_PART_FOREGROUND", "PangoRenderPart", PANGO_RENDER_PART_FOREGROUND},
+ {"PANGO_RENDER_PART_BACKGROUND", "PangoRenderPart", PANGO_RENDER_PART_BACKGROUND},
+ {"PANGO_RENDER_PART_UNDERLINE", "PangoRenderPart", PANGO_RENDER_PART_UNDERLINE},
+ {"PANGO_RENDER_PART_STRIKETHROUGH", "PangoRenderPart", PANGO_RENDER_PART_STRIKETHROUGH},
+ {"G_LOG_FLAG_RECURSION", "GLogLevelFlags", G_LOG_FLAG_RECURSION},
+ {"G_LOG_FLAG_FATAL", "GLogLevelFlags", G_LOG_FLAG_FATAL},
+ {"G_LOG_LEVEL_ERROR", "GLogLevelFlags", G_LOG_LEVEL_ERROR},
+ {"G_LOG_LEVEL_CRITICAL", "GLogLevelFlags", G_LOG_LEVEL_CRITICAL},
+ {"G_LOG_LEVEL_WARNING", "GLogLevelFlags", G_LOG_LEVEL_WARNING},
+ {"G_LOG_LEVEL_MESSAGE", "GLogLevelFlags", G_LOG_LEVEL_MESSAGE},
+ {"G_LOG_LEVEL_INFO", "GLogLevelFlags", G_LOG_LEVEL_INFO},
+ {"G_LOG_LEVEL_DEBUG", "GLogLevelFlags", G_LOG_LEVEL_DEBUG},
+ {"G_LOG_LEVEL_MASK", "GLogLevelFlags", G_LOG_LEVEL_MASK},
+ {"G_LOG_FATAL_MASK", "GLogLevelFlags", G_LOG_FATAL_MASK},
+ {"GTK_PACK_DIRECTION_LTR", "GtkPackDirection", GTK_PACK_DIRECTION_LTR},
+ {"GTK_PACK_DIRECTION_RTL", "GtkPackDirection", GTK_PACK_DIRECTION_RTL},
+ {"GTK_PACK_DIRECTION_TTB", "GtkPackDirection", GTK_PACK_DIRECTION_TTB},
+ {"GTK_PACK_DIRECTION_BTT", "GtkPackDirection", GTK_PACK_DIRECTION_BTT},
+ {"GTK_ICON_VIEW_NO_DROP", "GtkIconViewDropPosition", GTK_ICON_VIEW_NO_DROP},
+ {"GTK_ICON_VIEW_DROP_INTO", "GtkIconViewDropPosition", GTK_ICON_VIEW_DROP_INTO},
+ {"GTK_ICON_VIEW_DROP_LEFT", "GtkIconViewDropPosition", GTK_ICON_VIEW_DROP_LEFT},
+ {"GTK_ICON_VIEW_DROP_RIGHT", "GtkIconViewDropPosition", GTK_ICON_VIEW_DROP_RIGHT},
+ {"GTK_ICON_VIEW_DROP_ABOVE", "GtkIconViewDropPosition", GTK_ICON_VIEW_DROP_ABOVE},
+ {"GTK_ICON_VIEW_DROP_BELOW", "GtkIconViewDropPosition", GTK_ICON_VIEW_DROP_BELOW},
+ {"GTK_FILE_CHOOSER_CONFIRMATION_CONFIRM", "GtkFileChooserConfirmation", GTK_FILE_CHOOSER_CONFIRMATION_CONFIRM},
+ {"GTK_FILE_CHOOSER_CONFIRMATION_ACCEPT_FILENAME", "GtkFileChooserConfirmation", GTK_FILE_CHOOSER_CONFIRMATION_ACCEPT_FILENAME},
+ {"GTK_FILE_CHOOSER_CONFIRMATION_SELECT_AGAIN", "GtkFileChooserConfirmation", GTK_FILE_CHOOSER_CONFIRMATION_SELECT_AGAIN},
+ {"PANGO_SCRIPT_NEW_TAI_LUE", "PangoScript", PANGO_SCRIPT_NEW_TAI_LUE},
+ {"PANGO_SCRIPT_BUGINESE", "PangoScript", PANGO_SCRIPT_BUGINESE},
+ {"PANGO_SCRIPT_GLAGOLITIC", "PangoScript", PANGO_SCRIPT_GLAGOLITIC},
+ {"PANGO_SCRIPT_TIFINAGH", "PangoScript", PANGO_SCRIPT_TIFINAGH},
+ {"PANGO_SCRIPT_SYLOTI_NAGRI", "PangoScript", PANGO_SCRIPT_SYLOTI_NAGRI},
+ {"PANGO_SCRIPT_OLD_PERSIAN", "PangoScript", PANGO_SCRIPT_OLD_PERSIAN},
+ {"PANGO_SCRIPT_KHAROSHTHI", "PangoScript", PANGO_SCRIPT_KHAROSHTHI},
+ {"GDK_SUPER_MASK", "GdkModifierType", GDK_SUPER_MASK},
+ {"GDK_HYPER_MASK", "GdkModifierType", GDK_HYPER_MASK},
+ {"GDK_META_MASK", "GdkModifierType", GDK_META_MASK},
+ {"GTK_SENSITIVITY_AUTO", "GtkSensitivityType", GTK_SENSITIVITY_AUTO},
+ {"GTK_SENSITIVITY_ON", "GtkSensitivityType", GTK_SENSITIVITY_ON},
+ {"GTK_SENSITIVITY_OFF", "GtkSensitivityType", GTK_SENSITIVITY_OFF},
+ {"GTK_TEXT_BUFFER_TARGET_INFO_BUFFER_CONTENTS", "GtkTextBufferTargetInfo", GTK_TEXT_BUFFER_TARGET_INFO_BUFFER_CONTENTS},
+ {"GTK_TEXT_BUFFER_TARGET_INFO_RICH_TEXT", "GtkTextBufferTargetInfo", GTK_TEXT_BUFFER_TARGET_INFO_RICH_TEXT},
+ {"GTK_TEXT_BUFFER_TARGET_INFO_TEXT", "GtkTextBufferTargetInfo", GTK_TEXT_BUFFER_TARGET_INFO_TEXT},
+ {"GTK_ASSISTANT_PAGE_CONTENT", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_CONTENT},
+ {"GTK_ASSISTANT_PAGE_INTRO", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_INTRO},
+ {"GTK_ASSISTANT_PAGE_CONFIRM", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_CONFIRM},
+ {"GTK_ASSISTANT_PAGE_SUMMARY", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_SUMMARY},
+ {"GTK_ASSISTANT_PAGE_PROGRESS", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_PROGRESS},
+ {"GTK_CELL_RENDERER_ACCEL_MODE_GTK", "GtkCellRendererAccelMode", GTK_CELL_RENDERER_ACCEL_MODE_GTK},
+ {"GTK_CELL_RENDERER_ACCEL_MODE_OTHER", "GtkCellRendererAccelMode", GTK_CELL_RENDERER_ACCEL_MODE_OTHER},
+ {"GTK_RECENT_SORT_NONE", "GtkRecentSortType", GTK_RECENT_SORT_NONE},
+ {"GTK_RECENT_SORT_MRU", "GtkRecentSortType", GTK_RECENT_SORT_MRU},
+ {"GTK_RECENT_SORT_LRU", "GtkRecentSortType", GTK_RECENT_SORT_LRU},
+ {"GTK_RECENT_SORT_CUSTOM", "GtkRecentSortType", GTK_RECENT_SORT_CUSTOM},
+ {"GTK_RECENT_CHOOSER_ERROR_NOT_FOUND", "GtkRecentChooserError", GTK_RECENT_CHOOSER_ERROR_NOT_FOUND},
+ {"GTK_RECENT_CHOOSER_ERROR_INVALID_URI", "GtkRecentChooserError", GTK_RECENT_CHOOSER_ERROR_INVALID_URI},
+ {"GTK_RECENT_MANAGER_ERROR_NOT_FOUND", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_NOT_FOUND},
+ {"GTK_RECENT_MANAGER_ERROR_INVALID_URI", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_INVALID_URI},
+ {"GTK_RECENT_MANAGER_ERROR_INVALID_ENCODING", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_INVALID_ENCODING},
+ {"GTK_RECENT_MANAGER_ERROR_NOT_REGISTERED", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_NOT_REGISTERED},
+ {"GTK_RECENT_MANAGER_ERROR_READ", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_READ},
+ {"GTK_RECENT_MANAGER_ERROR_WRITE", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_WRITE},
+ {"GTK_RECENT_MANAGER_ERROR_UNKNOWN", "GtkRecentManagerError", GTK_RECENT_MANAGER_ERROR_UNKNOWN},
+ {"GTK_MESSAGE_OTHER", "GtkMessageType", GTK_MESSAGE_OTHER},
+ {"GTK_TREE_VIEW_GRID_LINES_NONE", "GtkTreeViewGridLines", GTK_TREE_VIEW_GRID_LINES_NONE},
+ {"GTK_TREE_VIEW_GRID_LINES_HORIZONTAL", "GtkTreeViewGridLines", GTK_TREE_VIEW_GRID_LINES_HORIZONTAL},
+ {"GTK_TREE_VIEW_GRID_LINES_VERTICAL", "GtkTreeViewGridLines", GTK_TREE_VIEW_GRID_LINES_VERTICAL},
+ {"GTK_TREE_VIEW_GRID_LINES_BOTH", "GtkTreeViewGridLines", GTK_TREE_VIEW_GRID_LINES_BOTH},
+ {"GTK_PRINT_STATUS_INITIAL", "GtkPrintStatus", GTK_PRINT_STATUS_INITIAL},
+ {"GTK_PRINT_STATUS_PREPARING", "GtkPrintStatus", GTK_PRINT_STATUS_PREPARING},
+ {"GTK_PRINT_STATUS_GENERATING_DATA", "GtkPrintStatus", GTK_PRINT_STATUS_GENERATING_DATA},
+ {"GTK_PRINT_STATUS_SENDING_DATA", "GtkPrintStatus", GTK_PRINT_STATUS_SENDING_DATA},
+ {"GTK_PRINT_STATUS_PENDING", "GtkPrintStatus", GTK_PRINT_STATUS_PENDING},
+ {"GTK_PRINT_STATUS_PENDING_ISSUE", "GtkPrintStatus", GTK_PRINT_STATUS_PENDING_ISSUE},
+ {"GTK_PRINT_STATUS_PRINTING", "GtkPrintStatus", GTK_PRINT_STATUS_PRINTING},
+ {"GTK_PRINT_STATUS_FINISHED", "GtkPrintStatus", GTK_PRINT_STATUS_FINISHED},
+ {"GTK_PRINT_STATUS_FINISHED_ABORTED", "GtkPrintStatus", GTK_PRINT_STATUS_FINISHED_ABORTED},
+ {"GTK_PRINT_OPERATION_RESULT_ERROR", "GtkPrintOperationResult", GTK_PRINT_OPERATION_RESULT_ERROR},
+ {"GTK_PRINT_OPERATION_RESULT_APPLY", "GtkPrintOperationResult", GTK_PRINT_OPERATION_RESULT_APPLY},
+ {"GTK_PRINT_OPERATION_RESULT_CANCEL", "GtkPrintOperationResult", GTK_PRINT_OPERATION_RESULT_CANCEL},
+ {"GTK_PRINT_OPERATION_RESULT_IN_PROGRESS", "GtkPrintOperationResult", GTK_PRINT_OPERATION_RESULT_IN_PROGRESS},
+ {"GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG", "GtkPrintOperationAction", GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG},
+ {"GTK_PRINT_OPERATION_ACTION_PRINT", "GtkPrintOperationAction", GTK_PRINT_OPERATION_ACTION_PRINT},
+ {"GTK_PRINT_OPERATION_ACTION_PREVIEW", "GtkPrintOperationAction", GTK_PRINT_OPERATION_ACTION_PREVIEW},
+ {"GTK_PRINT_OPERATION_ACTION_EXPORT", "GtkPrintOperationAction", GTK_PRINT_OPERATION_ACTION_EXPORT},
+ {"GTK_PRINT_ERROR_GENERAL", "GtkPrintError", GTK_PRINT_ERROR_GENERAL},
+ {"GTK_PRINT_ERROR_INTERNAL_ERROR", "GtkPrintError", GTK_PRINT_ERROR_INTERNAL_ERROR},
+ {"GTK_PRINT_ERROR_NOMEM", "GtkPrintError", GTK_PRINT_ERROR_NOMEM},
+ {"GTK_PRINT_ERROR_INVALID_FILE", "GtkPrintError", GTK_PRINT_ERROR_INVALID_FILE},
+ {"CAIRO_STATUS_SUCCESS", "cairo_status_t", CAIRO_STATUS_SUCCESS},
+ {"CAIRO_STATUS_NO_MEMORY", "cairo_status_t", CAIRO_STATUS_NO_MEMORY},
+ {"CAIRO_STATUS_INVALID_RESTORE", "cairo_status_t", CAIRO_STATUS_INVALID_RESTORE},
+ {"CAIRO_STATUS_INVALID_POP_GROUP", "cairo_status_t", CAIRO_STATUS_INVALID_POP_GROUP},
+ {"CAIRO_STATUS_NO_CURRENT_POINT", "cairo_status_t", CAIRO_STATUS_NO_CURRENT_POINT},
+ {"CAIRO_STATUS_INVALID_MATRIX", "cairo_status_t", CAIRO_STATUS_INVALID_MATRIX},
+ {"CAIRO_STATUS_INVALID_STATUS", "cairo_status_t", CAIRO_STATUS_INVALID_STATUS},
+ {"CAIRO_STATUS_NULL_POINTER", "cairo_status_t", CAIRO_STATUS_NULL_POINTER},
+ {"CAIRO_STATUS_INVALID_STRING", "cairo_status_t", CAIRO_STATUS_INVALID_STRING},
+ {"CAIRO_STATUS_INVALID_PATH_DATA", "cairo_status_t", CAIRO_STATUS_INVALID_PATH_DATA},
+ {"CAIRO_STATUS_READ_ERROR", "cairo_status_t", CAIRO_STATUS_READ_ERROR},
+ {"CAIRO_STATUS_WRITE_ERROR", "cairo_status_t", CAIRO_STATUS_WRITE_ERROR},
+ {"CAIRO_STATUS_SURFACE_FINISHED", "cairo_status_t", CAIRO_STATUS_SURFACE_FINISHED},
+ {"CAIRO_STATUS_SURFACE_TYPE_MISMATCH", "cairo_status_t", CAIRO_STATUS_SURFACE_TYPE_MISMATCH},
+ {"CAIRO_STATUS_PATTERN_TYPE_MISMATCH", "cairo_status_t", CAIRO_STATUS_PATTERN_TYPE_MISMATCH},
+ {"CAIRO_STATUS_INVALID_CONTENT", "cairo_status_t", CAIRO_STATUS_INVALID_CONTENT},
+ {"CAIRO_STATUS_INVALID_FORMAT", "cairo_status_t", CAIRO_STATUS_INVALID_FORMAT},
+ {"CAIRO_STATUS_INVALID_VISUAL", "cairo_status_t", CAIRO_STATUS_INVALID_VISUAL},
+ {"CAIRO_STATUS_FILE_NOT_FOUND", "cairo_status_t", CAIRO_STATUS_FILE_NOT_FOUND},
+ {"CAIRO_STATUS_INVALID_DASH", "cairo_status_t", CAIRO_STATUS_INVALID_DASH},
+ {"CAIRO_STATUS_INVALID_DSC_COMMENT", "cairo_status_t", CAIRO_STATUS_INVALID_DSC_COMMENT},
+ {"CAIRO_STATUS_INVALID_INDEX", "cairo_status_t", CAIRO_STATUS_INVALID_INDEX},
+ {"CAIRO_STATUS_CLIP_NOT_REPRESENTABLE", "cairo_status_t", CAIRO_STATUS_CLIP_NOT_REPRESENTABLE},
+ {"CAIRO_STATUS_TEMP_FILE_ERROR", "cairo_status_t", CAIRO_STATUS_TEMP_FILE_ERROR},
+ {"CAIRO_STATUS_INVALID_STRIDE", "cairo_status_t", CAIRO_STATUS_INVALID_STRIDE},
+ {"CAIRO_CONTENT_COLOR", "cairo_content_t", CAIRO_CONTENT_COLOR},
+ {"CAIRO_CONTENT_ALPHA", "cairo_content_t", CAIRO_CONTENT_ALPHA},
+ {"CAIRO_CONTENT_COLOR_ALPHA", "cairo_content_t", CAIRO_CONTENT_COLOR_ALPHA},
+ {"CAIRO_OPERATOR_CLEAR", "cairo_operator_t", CAIRO_OPERATOR_CLEAR},
+ {"CAIRO_OPERATOR_SOURCE", "cairo_operator_t", CAIRO_OPERATOR_SOURCE},
+ {"CAIRO_OPERATOR_OVER", "cairo_operator_t", CAIRO_OPERATOR_OVER},
+ {"CAIRO_OPERATOR_IN", "cairo_operator_t", CAIRO_OPERATOR_IN},
+ {"CAIRO_OPERATOR_OUT", "cairo_operator_t", CAIRO_OPERATOR_OUT},
+ {"CAIRO_OPERATOR_ATOP", "cairo_operator_t", CAIRO_OPERATOR_ATOP},
+ {"CAIRO_OPERATOR_DEST", "cairo_operator_t", CAIRO_OPERATOR_DEST},
+ {"CAIRO_OPERATOR_DEST_OVER", "cairo_operator_t", CAIRO_OPERATOR_DEST_OVER},
+ {"CAIRO_OPERATOR_DEST_IN", "cairo_operator_t", CAIRO_OPERATOR_DEST_IN},
+ {"CAIRO_OPERATOR_DEST_OUT", "cairo_operator_t", CAIRO_OPERATOR_DEST_OUT},
+ {"CAIRO_OPERATOR_DEST_ATOP", "cairo_operator_t", CAIRO_OPERATOR_DEST_ATOP},
+ {"CAIRO_OPERATOR_XOR", "cairo_operator_t", CAIRO_OPERATOR_XOR},
+ {"CAIRO_OPERATOR_ADD", "cairo_operator_t", CAIRO_OPERATOR_ADD},
+ {"CAIRO_OPERATOR_SATURATE", "cairo_operator_t", CAIRO_OPERATOR_SATURATE},
+ {"CAIRO_ANTIALIAS_DEFAULT", "cairo_antialias_t", CAIRO_ANTIALIAS_DEFAULT},
+ {"CAIRO_ANTIALIAS_NONE", "cairo_antialias_t", CAIRO_ANTIALIAS_NONE},
+ {"CAIRO_ANTIALIAS_GRAY", "cairo_antialias_t", CAIRO_ANTIALIAS_GRAY},
+ {"CAIRO_ANTIALIAS_SUBPIXEL", "cairo_antialias_t", CAIRO_ANTIALIAS_SUBPIXEL},
+ {"CAIRO_FILL_RULE_WINDING", "cairo_fill_rule_t", CAIRO_FILL_RULE_WINDING},
+ {"CAIRO_FILL_RULE_EVEN_ODD", "cairo_fill_rule_t", CAIRO_FILL_RULE_EVEN_ODD},
+ {"CAIRO_LINE_CAP_BUTT", "cairo_line_cap_t", CAIRO_LINE_CAP_BUTT},
+ {"CAIRO_LINE_CAP_ROUND", "cairo_line_cap_t", CAIRO_LINE_CAP_ROUND},
+ {"CAIRO_LINE_CAP_SQUARE", "cairo_line_cap_t", CAIRO_LINE_CAP_SQUARE},
+ {"CAIRO_LINE_JOIN_MITER", "cairo_line_join_t", CAIRO_LINE_JOIN_MITER},
+ {"CAIRO_LINE_JOIN_ROUND", "cairo_line_join_t", CAIRO_LINE_JOIN_ROUND},
+ {"CAIRO_LINE_JOIN_BEVEL", "cairo_line_join_t", CAIRO_LINE_JOIN_BEVEL},
+ {"CAIRO_FONT_SLANT_NORMAL", "cairo_font_slant_t", CAIRO_FONT_SLANT_NORMAL},
+ {"CAIRO_FONT_SLANT_ITALIC", "cairo_font_slant_t", CAIRO_FONT_SLANT_ITALIC},
+ {"CAIRO_FONT_SLANT_OBLIQUE", "cairo_font_slant_t", CAIRO_FONT_SLANT_OBLIQUE},
+ {"CAIRO_FONT_WEIGHT_NORMAL", "cairo_font_weight_t", CAIRO_FONT_WEIGHT_NORMAL},
+ {"CAIRO_FONT_WEIGHT_BOLD", "cairo_font_weight_t", CAIRO_FONT_WEIGHT_BOLD},
+ {"CAIRO_SUBPIXEL_ORDER_DEFAULT", "cairo_subpixel_order_t", CAIRO_SUBPIXEL_ORDER_DEFAULT},
+ {"CAIRO_SUBPIXEL_ORDER_RGB", "cairo_subpixel_order_t", CAIRO_SUBPIXEL_ORDER_RGB},
+ {"CAIRO_SUBPIXEL_ORDER_BGR", "cairo_subpixel_order_t", CAIRO_SUBPIXEL_ORDER_BGR},
+ {"CAIRO_SUBPIXEL_ORDER_VRGB", "cairo_subpixel_order_t", CAIRO_SUBPIXEL_ORDER_VRGB},
+ {"CAIRO_SUBPIXEL_ORDER_VBGR", "cairo_subpixel_order_t", CAIRO_SUBPIXEL_ORDER_VBGR},
+ {"CAIRO_HINT_STYLE_DEFAULT", "cairo_hint_style_t", CAIRO_HINT_STYLE_DEFAULT},
+ {"CAIRO_HINT_STYLE_NONE", "cairo_hint_style_t", CAIRO_HINT_STYLE_NONE},
+ {"CAIRO_HINT_STYLE_SLIGHT", "cairo_hint_style_t", CAIRO_HINT_STYLE_SLIGHT},
+ {"CAIRO_HINT_STYLE_MEDIUM", "cairo_hint_style_t", CAIRO_HINT_STYLE_MEDIUM},
+ {"CAIRO_HINT_STYLE_FULL", "cairo_hint_style_t", CAIRO_HINT_STYLE_FULL},
+ {"CAIRO_HINT_METRICS_DEFAULT", "cairo_hint_metrics_t", CAIRO_HINT_METRICS_DEFAULT},
+ {"CAIRO_HINT_METRICS_OFF", "cairo_hint_metrics_t", CAIRO_HINT_METRICS_OFF},
+ {"CAIRO_HINT_METRICS_ON", "cairo_hint_metrics_t", CAIRO_HINT_METRICS_ON},
+ {"CAIRO_FONT_TYPE_TOY", "cairo_font_type_t", CAIRO_FONT_TYPE_TOY},
+ {"CAIRO_FONT_TYPE_FT", "cairo_font_type_t", CAIRO_FONT_TYPE_FT},
+ {"CAIRO_FONT_TYPE_WIN32", "cairo_font_type_t", CAIRO_FONT_TYPE_WIN32},
+ {"CAIRO_FONT_TYPE_QUARTZ", "cairo_font_type_t", CAIRO_FONT_TYPE_QUARTZ},
+ {"CAIRO_PATH_MOVE_TO", "cairo_path_data_type_t", CAIRO_PATH_MOVE_TO},
+ {"CAIRO_PATH_LINE_TO", "cairo_path_data_type_t", CAIRO_PATH_LINE_TO},
+ {"CAIRO_PATH_CURVE_TO", "cairo_path_data_type_t", CAIRO_PATH_CURVE_TO},
+ {"CAIRO_PATH_CLOSE_PATH", "cairo_path_data_type_t", CAIRO_PATH_CLOSE_PATH},
+ {"CAIRO_SURFACE_TYPE_IMAGE", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_IMAGE},
+ {"CAIRO_SURFACE_TYPE_PDF", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_PDF},
+ {"CAIRO_SURFACE_TYPE_PS", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_PS},
+ {"CAIRO_SURFACE_TYPE_XLIB", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_XLIB},
+ {"CAIRO_SURFACE_TYPE_XCB", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_XCB},
+ {"CAIRO_SURFACE_TYPE_GLITZ", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_GLITZ},
+ {"CAIRO_SURFACE_TYPE_QUARTZ", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_QUARTZ},
+ {"CAIRO_SURFACE_TYPE_WIN32", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_WIN32},
+ {"CAIRO_SURFACE_TYPE_BEOS", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_BEOS},
+ {"CAIRO_SURFACE_TYPE_DIRECTFB", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_DIRECTFB},
+ {"CAIRO_SURFACE_TYPE_SVG", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_SVG},
+ {"CAIRO_SURFACE_TYPE_OS2", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_OS2},
+ {"CAIRO_SURFACE_TYPE_WIN32_PRINTING", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_WIN32_PRINTING},
+ {"CAIRO_SURFACE_TYPE_QUARTZ_IMAGE", "cairo_surface_type_t", CAIRO_SURFACE_TYPE_QUARTZ_IMAGE},
+ {"CAIRO_FORMAT_ARGB32", "cairo_format_t", CAIRO_FORMAT_ARGB32},
+ {"CAIRO_FORMAT_RGB24", "cairo_format_t", CAIRO_FORMAT_RGB24},
+ {"CAIRO_FORMAT_A8", "cairo_format_t", CAIRO_FORMAT_A8},
+ {"CAIRO_FORMAT_A1", "cairo_format_t", CAIRO_FORMAT_A1},
+ {"CAIRO_PATTERN_TYPE_SOLID", "cairo_pattern_type_t", CAIRO_PATTERN_TYPE_SOLID},
+ {"CAIRO_PATTERN_TYPE_SURFACE", "cairo_pattern_type_t", CAIRO_PATTERN_TYPE_SURFACE},
+ {"CAIRO_PATTERN_TYPE_LINEAR", "cairo_pattern_type_t", CAIRO_PATTERN_TYPE_LINEAR},
+ {"CAIRO_PATTERN_TYPE_RADIAL", "cairo_pattern_type_t", CAIRO_PATTERN_TYPE_RADIAL},
+ {"CAIRO_EXTEND_NONE", "cairo_extend_t", CAIRO_EXTEND_NONE},
+ {"CAIRO_EXTEND_REPEAT", "cairo_extend_t", CAIRO_EXTEND_REPEAT},
+ {"CAIRO_EXTEND_REFLECT", "cairo_extend_t", CAIRO_EXTEND_REFLECT},
+ {"CAIRO_EXTEND_PAD", "cairo_extend_t", CAIRO_EXTEND_PAD},
+ {"CAIRO_FILTER_FAST", "cairo_filter_t", CAIRO_FILTER_FAST},
+ {"CAIRO_FILTER_GOOD", "cairo_filter_t", CAIRO_FILTER_GOOD},
+ {"CAIRO_FILTER_BEST", "cairo_filter_t", CAIRO_FILTER_BEST},
+ {"CAIRO_FILTER_NEAREST", "cairo_filter_t", CAIRO_FILTER_NEAREST},
+ {"CAIRO_FILTER_BILINEAR", "cairo_filter_t", CAIRO_FILTER_BILINEAR},
+ {"CAIRO_FILTER_GAUSSIAN", "cairo_filter_t", CAIRO_FILTER_GAUSSIAN},
+ {"GTK_DRAG_RESULT_SUCCESS", "GtkDragResult", GTK_DRAG_RESULT_SUCCESS},
+ {"GTK_DRAG_RESULT_NO_TARGET", "GtkDragResult", GTK_DRAG_RESULT_NO_TARGET},
+ {"GTK_DRAG_RESULT_USER_CANCELLED", "GtkDragResult", GTK_DRAG_RESULT_USER_CANCELLED},
+ {"GTK_DRAG_RESULT_TIMEOUT_EXPIRED", "GtkDragResult", GTK_DRAG_RESULT_TIMEOUT_EXPIRED},
+ {"GTK_DRAG_RESULT_GRAB_BROKEN", "GtkDragResult", GTK_DRAG_RESULT_GRAB_BROKEN},
+ {"GTK_DRAG_RESULT_ERROR", "GtkDragResult", GTK_DRAG_RESULT_ERROR},
+#endif
+#if GTK_CHECK_VERSION(2, 14, 0)
+ {"GTK_CALENDAR_SHOW_DETAILS", "GtkCalendarDisplayOptions", GTK_CALENDAR_SHOW_DETAILS},
+ {"GDK_CROSSING_GTK_GRAB", "GdkCrossingMode", GDK_CROSSING_GTK_GRAB},
+ {"GDK_CROSSING_GTK_UNGRAB", "GdkCrossingMode", GDK_CROSSING_GTK_UNGRAB},
+ {"GDK_CROSSING_STATE_CHANGED", "GdkCrossingMode", GDK_CROSSING_STATE_CHANGED},
+#endif
+#if GTK_CHECK_VERSION(2, 16, 0)
+ {"GTK_ENTRY_ICON_PRIMARY", "GtkEntryIconPosition", GTK_ENTRY_ICON_PRIMARY},
+ {"GTK_ENTRY_ICON_SECONDARY", "GtkEntryIconPosition", GTK_ENTRY_ICON_SECONDARY},
+ {"GDK_BLANK_CURSOR ", "GdkCursorType", GDK_BLANK_CURSOR },
+#endif
+#if GTK_CHECK_VERSION(2, 18, 0)
+ {"PANGO_WEIGHT_THIN", "PangoWeight", PANGO_WEIGHT_THIN},
+ {"PANGO_WEIGHT_BOOK", "PangoWeight", PANGO_WEIGHT_BOOK},
+ {"PANGO_WEIGHT_MEDIUM", "PangoWeight", PANGO_WEIGHT_MEDIUM},
+ {"GDK_WINDOW_OFFSCREEN", "GdkWindowType", GDK_WINDOW_OFFSCREEN},
+#endif
+#if GTK_CHECK_VERSION(3, 0, 0)
+ {"GTK_SIZE_REQUEST_HEIGHT_FOR_WIDTH", "GtkSizeRequestMode", GTK_SIZE_REQUEST_HEIGHT_FOR_WIDTH},
+ {"GTK_SIZE_REQUEST_WIDTH_FOR_HEIGHT", "GtkSizeRequestMode", GTK_SIZE_REQUEST_WIDTH_FOR_HEIGHT},
+ {"GTK_ASSISTANT_PAGE_CUSTOM", "GtkAssistantPageType", GTK_ASSISTANT_PAGE_CUSTOM},
+ {"GTK_TEXT_SEARCH_CASE_INSENSITIVE", "GtkTextSearchFlags", GTK_TEXT_SEARCH_CASE_INSENSITIVE},
+ {"GTK_SCROLL_MINIMUM", "GtkScrollablePolicy", GTK_SCROLL_MINIMUM},
+ {"GTK_SCROLL_NATURAL", "GtkScrollablePolicy", GTK_SCROLL_NATURAL},
+ {"GTK_TARGET_SAME_APP", "GtkTargetFlags", GTK_TARGET_SAME_APP},
+ {"GTK_TARGET_SAME_WIDGET", "GtkTargetFlags", GTK_TARGET_SAME_WIDGET},
+ {"GTK_TARGET_OTHER_APP", "GtkTargetFlags", GTK_TARGET_OTHER_APP},
+ {"GTK_TARGET_OTHER_WIDGET", "GtkTargetFlags", GTK_TARGET_OTHER_WIDGET},
+ {"GTK_ALIGN_FILL", "GtkAlign", GTK_ALIGN_FILL},
+ {"GTK_ALIGN_START", "GtkAlign", GTK_ALIGN_START},
+ {"GTK_ALIGN_END", "GtkAlign", GTK_ALIGN_END},
+ {"GTK_ALIGN_CENTER", "GtkAlign", GTK_ALIGN_CENTER},
+ {"GTK_TOOL_PALETTE_DRAG_ITEMS", "GtkToolPaletteDragTargets", GTK_TOOL_PALETTE_DRAG_ITEMS},
+ {"GTK_TOOL_PALETTE_DRAG_GROUPS", "GtkToolPaletteDragTargets", GTK_TOOL_PALETTE_DRAG_GROUPS},
+ {"GTK_IMAGE_GICON", "GtkImageType", GTK_IMAGE_GICON},
+ {"GTK_FILE_CHOOSER_ERROR_NONEXISTENT", "GtkFileChooserError", GTK_FILE_CHOOSER_ERROR_NONEXISTENT},
+ {"GTK_FILE_CHOOSER_ERROR_BAD_FILENAME", "GtkFileChooserError", GTK_FILE_CHOOSER_ERROR_BAD_FILENAME},
+ {"GTK_FILE_CHOOSER_ERROR_ALREADY_EXISTS", "GtkFileChooserError", GTK_FILE_CHOOSER_ERROR_ALREADY_EXISTS},
+ {"GTK_FILE_CHOOSER_ERROR_INCOMPLETE_HOSTNAME", "GtkFileChooserError", GTK_FILE_CHOOSER_ERROR_INCOMPLETE_HOSTNAME},
+ {"GTK_ICON_LOOKUP_FORCE_SIZE", "GtkIconLookupFlags", GTK_ICON_LOOKUP_FORCE_SIZE},
+ {"GTK_ICON_THEME_NOT_FOUND", "GtkIconThemeError", GTK_ICON_THEME_NOT_FOUND},
+ {"GTK_ICON_THEME_FAILED", "GtkIconThemeError", GTK_ICON_THEME_FAILED},
+ {"GTK_STATE_FLAG_NORMAL", "GtkStateFlags", GTK_STATE_FLAG_NORMAL},
+ {"GTK_STATE_FLAG_ACTIVE", "GtkStateFlags", GTK_STATE_FLAG_ACTIVE},
+ {"GTK_STATE_FLAG_PRELIGHT", "GtkStateFlags", GTK_STATE_FLAG_PRELIGHT},
+ {"GTK_STATE_FLAG_SELECTED", "GtkStateFlags", GTK_STATE_FLAG_SELECTED},
+ {"GTK_STATE_FLAG_INSENSITIVE", "GtkStateFlags", GTK_STATE_FLAG_INSENSITIVE},
+ {"GTK_STATE_FLAG_INCONSISTENT", "GtkStateFlags", GTK_STATE_FLAG_INCONSISTENT},
+ {"GTK_STATE_FLAG_FOCUSED", "GtkStateFlags", GTK_STATE_FLAG_FOCUSED},
+#endif
+#if GTK_CHECK_VERSION(3, 10, 0)
+ {"GTK_ALIGN_BASELINE", "GtkAlign", GTK_ALIGN_BASELINE},
+ {"GTK_BASELINE_POSITION_TOP", "GtkBaselinePosition", GTK_BASELINE_POSITION_TOP},
+ {"GTK_BASELINE_POSITION_CENTER", "GtkBaselinePosition", GTK_BASELINE_POSITION_CENTER},
+ {"GTK_BASELINE_POSITION_BOTTOM", "GtkBaselinePosition", GTK_BASELINE_POSITION_BOTTOM},
+ {"GTK_PLACES_OPEN_NORMAL", "GtkPlacesOpenFlags", GTK_PLACES_OPEN_NORMAL},
+ {"GTK_PLACES_OPEN_NEW_TAB", "GtkPlacesOpenFlags", GTK_PLACES_OPEN_NEW_TAB},
+ {"GTK_PLACES_OPEN_NEW_WINDOW", "GtkPlacesOpenFlags", GTK_PLACES_OPEN_NEW_WINDOW},
+ {"GTK_STACK_TRANSITION_TYPE_NONE", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_NONE},
+ {"GTK_STACK_TRANSITION_TYPE_CROSSFADE", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_CROSSFADE},
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_RIGHT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_RIGHT},
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_LEFT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_LEFT},
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_UP", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_UP},
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_DOWN", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_DOWN},
+ {"GTK_REVEALER_TRANSITION_TYPE_NONE", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_NONE},
+ {"GTK_REVEALER_TRANSITION_TYPE_CROSSFADE", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_CROSSFADE},
+ {"GTK_REVEALER_TRANSITION_TYPE_SLIDE_RIGHT", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_SLIDE_RIGHT},
+ {"GTK_REVEALER_TRANSITION_TYPE_SLIDE_LEFT", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_SLIDE_LEFT},
+ {"GTK_REVEALER_TRANSITION_TYPE_SLIDE_UP", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_SLIDE_UP},
+ {"GTK_REVEALER_TRANSITION_TYPE_SLIDE_DOWN", "GtkRevealerTransitionType", GTK_REVEALER_TRANSITION_TYPE_SLIDE_DOWN},
+ {"GDK_WINDOW_STATE_TILED", "GdkWindowState", GDK_WINDOW_STATE_TILED},
+#endif
+#if GTK_CHECK_VERSION(3, 12, 0)
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_LEFT_RIGHT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_LEFT_RIGHT},
+ {"GTK_STACK_TRANSITION_TYPE_SLIDE_UP_DOWN", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_SLIDE_UP_DOWN},
+ {"GTK_STACK_TRANSITION_TYPE_OVER_UP", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_OVER_UP},
+ {"GTK_STACK_TRANSITION_TYPE_OVER_DOWN", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_OVER_DOWN},
+ {"GTK_STACK_TRANSITION_TYPE_OVER_LEFT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_OVER_LEFT},
+ {"GTK_STACK_TRANSITION_TYPE_OVER_RIGHT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_OVER_RIGHT},
+ {"GTK_STACK_TRANSITION_TYPE_UNDER_UP", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_UNDER_UP},
+ {"GTK_STACK_TRANSITION_TYPE_UNDER_DOWN", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_UNDER_DOWN},
+ {"GTK_STACK_TRANSITION_TYPE_UNDER_LEFT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_UNDER_LEFT},
+ {"GTK_STACK_TRANSITION_TYPE_UNDER_RIGHT", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_UNDER_RIGHT},
+ {"GTK_STACK_TRANSITION_TYPE_OVER_UP_DOWN", "GtkStackTransitionType", GTK_STACK_TRANSITION_TYPE_OVER_UP_DOWN},
+#endif
+#if GTK_CHECK_VERSION(3, 14, 0)
+ {"GTK_TEXT_VIEW_LAYER_BELOW", "GtkTextViewLayer", GTK_TEXT_VIEW_LAYER_BELOW},
+ {"GTK_TEXT_VIEW_LAYER_ABOVE", "GtkTextViewLayer", GTK_TEXT_VIEW_LAYER_ABOVE},
+#endif
+#if GTK_CHECK_VERSION(3, 16, 0)
+ {"GTK_POLICY_EXTERNAL", "GtkPolicyType", GTK_POLICY_EXTERNAL},
+ {"PANGO_WEIGHT_SEMILIGHT", "PangoWeight", PANGO_WEIGHT_SEMILIGHT},
+ {"GTK_TEXT_EXTEND_SELECTION_WORD", "GtkTextExtendSelection", GTK_TEXT_EXTEND_SELECTION_WORD},
+ {"GTK_TEXT_EXTEND_SELECTION_LINE", "GtkTextExtendSelection", GTK_TEXT_EXTEND_SELECTION_LINE},
+#endif
+#if GTK_CHECK_VERSION(3, 18, 0)
+ {"GDK_TOUCHPAD_SWIPE", "GdkEventType", GDK_TOUCHPAD_SWIPE},
+ {"GDK_TOUCHPAD_PINCH", "GdkEventType", GDK_TOUCHPAD_PINCH},
+ {"GDK_TOUCHPAD_GESTURE_PHASE_BEGIN", "GdkTouchpadGesturePhase", GDK_TOUCHPAD_GESTURE_PHASE_BEGIN},
+ {"GDK_TOUCHPAD_GESTURE_PHASE_UPDATE", "GdkTouchpadGesturePhase", GDK_TOUCHPAD_GESTURE_PHASE_UPDATE},
+ {"GDK_TOUCHPAD_GESTURE_PHASE_END", "GdkTouchpadGesturePhase", GDK_TOUCHPAD_GESTURE_PHASE_END},
+ {"GDK_TOUCHPAD_GESTURE_PHASE_CANCEL", "GdkTouchpadGesturePhase", GDK_TOUCHPAD_GESTURE_PHASE_CANCEL},
+ {"GDK_TOUCHPAD_GESTURE_MASK", "GdkEventMask", GDK_TOUCHPAD_GESTURE_MASK},
+ {"GDK_MODIFIER_INTENT_DEFAULT_MOD_MASK", "GdkModifierIntent", GDK_MODIFIER_INTENT_DEFAULT_MOD_MASK},
+#endif
+#if GTK_CHECK_VERSION(3, 2, 0)
+ {"GTK_SIZE_REQUEST_CONSTANT_SIZE", "GtkSizeRequestMode", GTK_SIZE_REQUEST_CONSTANT_SIZE},
+#endif
+#if GTK_CHECK_VERSION(3, 20, 0)
+ {"GTK_SHORTCUT_ACCELERATOR", "GtkShortcutType", GTK_SHORTCUT_ACCELERATOR},
+ {"GTK_SHORTCUT_GESTURE_PINCH", "GtkShortcutType", GTK_SHORTCUT_GESTURE_PINCH},
+ {"GTK_SHORTCUT_GESTURE_STRETCH", "GtkShortcutType", GTK_SHORTCUT_GESTURE_STRETCH},
+ {"GTK_SHORTCUT_GESTURE_ROTATE_CLOCKWISE", "GtkShortcutType", GTK_SHORTCUT_GESTURE_ROTATE_CLOCKWISE},
+ {"GTK_SHORTCUT_GESTURE_ROTATE_COUNTERCLOCKWISE", "GtkShortcutType", GTK_SHORTCUT_GESTURE_ROTATE_COUNTERCLOCKWISE},
+ {"GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_LEFT", "GtkShortcutType", GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_LEFT},
+ {"GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_RIGHT", "GtkShortcutType", GTK_SHORTCUT_GESTURE_TWO_FINGER_SWIPE_RIGHT},
+ {"GTK_SHORTCUT_GESTURE", "GtkShortcutType", GTK_SHORTCUT_GESTURE},
+ {"GTK_POPOVER_CONSTRAINT_NONE", "GtkPopoverConstraint", GTK_POPOVER_CONSTRAINT_NONE},
+ {"GTK_POPOVER_CONSTRAINT_WINDOW", "GtkPopoverConstraint", GTK_POPOVER_CONSTRAINT_WINDOW},
+ {"GDK_WINDOW_TYPE_HINT_SPLASHSCREEN", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_SPLASHSCREEN},
+ {"GDK_WINDOW_TYPE_HINT_UTILITY", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_UTILITY},
+ {"GDK_WINDOW_TYPE_HINT_DOCK", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_DOCK},
+ {"GDK_WINDOW_TYPE_HINT_DESKTOP", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_DESKTOP},
+ {"GDK_WINDOW_TYPE_HINT_DROPDOWN_MENU", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_DROPDOWN_MENU},
+ {"GDK_WINDOW_TYPE_HINT_POPUP_MENU", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_POPUP_MENU},
+ {"GDK_WINDOW_TYPE_HINT_TOOLTIP", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_TOOLTIP},
+ {"GDK_WINDOW_TYPE_HINT_NOTIFICATION", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_NOTIFICATION},
+ {"GDK_WINDOW_TYPE_HINT_COMBO", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_COMBO},
+ {"GDK_WINDOW_TYPE_HINT_DND", "GdkWindowTypeHint", GDK_WINDOW_TYPE_HINT_DND},
+ {"GDK_SEAT_CAPABILITY_NONE", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_NONE},
+ {"GDK_SEAT_CAPABILITY_POINTER", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_POINTER},
+ {"GDK_SEAT_CAPABILITY_TOUCH", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_TOUCH},
+ {"GDK_SEAT_CAPABILITY_TABLET_STYLUS", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_TABLET_STYLUS},
+ {"GDK_SEAT_CAPABILITY_KEYBOARD", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_KEYBOARD},
+ {"GDK_SEAT_CAPABILITY_ALL_POINTING", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_ALL_POINTING},
+ {"GDK_SEAT_CAPABILITY_ALL", "GdkSeatCapabilities", GDK_SEAT_CAPABILITY_ALL},
+ {"GTK_STATE_FLAG_DROP_ACTIVE", "GtkStateFlags", GTK_STATE_FLAG_DROP_ACTIVE},
+ {"GDK_DRAG_CANCEL_NO_TARGET", "GdkDragCancelReason", GDK_DRAG_CANCEL_NO_TARGET},
+ {"GDK_DRAG_CANCEL_USER_CANCELLED", "GdkDragCancelReason", GDK_DRAG_CANCEL_USER_CANCELLED},
+ {"GDK_DRAG_CANCEL_ERROR", "GdkDragCancelReason", GDK_DRAG_CANCEL_ERROR},
+#endif
+#if GTK_CHECK_VERSION(3, 22, 0)
+ {"GDK_AXIS_IGNORE", "GdkAxisUse", GDK_AXIS_IGNORE},
+ {"GDK_AXIS_X", "GdkAxisUse", GDK_AXIS_X},
+ {"GDK_AXIS_Y", "GdkAxisUse", GDK_AXIS_Y},
+ {"GDK_AXIS_PRESSURE", "GdkAxisUse", GDK_AXIS_PRESSURE},
+ {"GDK_AXIS_XTILT", "GdkAxisUse", GDK_AXIS_XTILT},
+ {"GDK_AXIS_YTILT", "GdkAxisUse", GDK_AXIS_YTILT},
+ {"GDK_AXIS_WHEEL", "GdkAxisUse", GDK_AXIS_WHEEL},
+ {"GDK_AXIS_LAST", "GdkAxisUse", GDK_AXIS_LAST},
+ {"GDK_AXIS_FLAG_X", "GdkAxisFlags", GDK_AXIS_FLAG_X},
+ {"GDK_AXIS_FLAG_Y", "GdkAxisFlags", GDK_AXIS_FLAG_Y},
+ {"GDK_AXIS_FLAG_PRESSURE", "GdkAxisFlags", GDK_AXIS_FLAG_PRESSURE},
+ {"GDK_AXIS_FLAG_XTILT", "GdkAxisFlags", GDK_AXIS_FLAG_XTILT},
+ {"GDK_AXIS_FLAG_YTILT", "GdkAxisFlags", GDK_AXIS_FLAG_YTILT},
+ {"GDK_AXIS_FLAG_WHEEL", "GdkAxisFlags", GDK_AXIS_FLAG_WHEEL},
+ {"GDK_AXIS_FLAG_DISTANCE", "GdkAxisFlags", GDK_AXIS_FLAG_DISTANCE},
+ {"GDK_AXIS_FLAG_ROTATION", "GdkAxisFlags", GDK_AXIS_FLAG_ROTATION},
+ {"GDK_AXIS_FLAG_SLIDER", "GdkAxisFlags", GDK_AXIS_FLAG_SLIDER},
+ {"GDK_DEVICE_TOOL_TYPE_UNKNOWN", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_UNKNOWN},
+ {"GDK_DEVICE_TOOL_TYPE_PEN", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_PEN},
+ {"GDK_DEVICE_TOOL_TYPE_ERASER", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_ERASER},
+ {"GDK_DEVICE_TOOL_TYPE_BRUSH", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_BRUSH},
+ {"GDK_DEVICE_TOOL_TYPE_PENCIL", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_PENCIL},
+ {"GDK_DEVICE_TOOL_TYPE_AIRBRUSH", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_AIRBRUSH},
+ {"GDK_DEVICE_TOOL_TYPE_MOUSE", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_MOUSE},
+ {"GDK_DEVICE_TOOL_TYPE_LENS", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_LENS},
+#endif
+#if GTK_CHECK_VERSION(3, 4, 0)
+ {"GDK_MODIFIER_INTENT_PRIMARY_ACCELERATOR", "GdkModifierIntent", GDK_MODIFIER_INTENT_PRIMARY_ACCELERATOR},
+ {"GDK_MODIFIER_INTENT_CONTEXT_MENU", "GdkModifierIntent", GDK_MODIFIER_INTENT_CONTEXT_MENU},
+ {"GDK_MODIFIER_INTENT_EXTEND_SELECTION", "GdkModifierIntent", GDK_MODIFIER_INTENT_EXTEND_SELECTION},
+ {"GDK_MODIFIER_INTENT_MODIFY_SELECTION", "GdkModifierIntent", GDK_MODIFIER_INTENT_MODIFY_SELECTION},
+ {"GDK_MODIFIER_INTENT_NO_TEXT_INPUT", "GdkModifierIntent", GDK_MODIFIER_INTENT_NO_TEXT_INPUT},
+ {"GDK_MODIFIER_INTENT_SHIFT_GROUP", "GdkModifierIntent", GDK_MODIFIER_INTENT_SHIFT_GROUP},
+ {"GTK_REGION_ONLY", "GtkRegionFlags", GTK_REGION_ONLY},
+ {"GDK_WINDOW_STATE_FOCUSED", "GdkWindowState", GDK_WINDOW_STATE_FOCUSED},
+ {"GTK_CELL_RENDERER_EXPANDABLE", "GtkCellRendererState", GTK_CELL_RENDERER_EXPANDABLE},
+ {"GTK_CELL_RENDERER_EXPANDED", "GtkCellRendererState", GTK_CELL_RENDERER_EXPANDED},
+ {"GTK_STATE_FLAG_BACKDROP", "GtkStateFlags", GTK_STATE_FLAG_BACKDROP},
+#endif
+#if GTK_CHECK_VERSION(3, 6, 0)
+ {"GDK_TOUCH_BEGIN", "GdkEventType", GDK_TOUCH_BEGIN},
+ {"GDK_TOUCH_UPDATE", "GdkEventType", GDK_TOUCH_UPDATE},
+ {"GDK_TOUCH_END", "GdkEventType", GDK_TOUCH_END},
+ {"GDK_TOUCH_CANCEL", "GdkEventType", GDK_TOUCH_CANCEL},
+ {"GDK_SCROLL_SMOOTH", "GdkScrollDirection", GDK_SCROLL_SMOOTH},
+ {"GDK_CROSSING_TOUCH_BEGIN", "GdkCrossingMode", GDK_CROSSING_TOUCH_BEGIN},
+ {"GDK_CROSSING_TOUCH_END", "GdkCrossingMode", GDK_CROSSING_TOUCH_END},
+ {"GDK_CROSSING_DEVICE_SWITCH", "GdkCrossingMode", GDK_CROSSING_DEVICE_SWITCH},
+ {"GDK_TOUCH_MASK", "GdkEventMask", GDK_TOUCH_MASK},
+ {"GDK_SMOOTH_SCROLL_MASK", "GdkEventMask", GDK_SMOOTH_SCROLL_MASK},
+ {"GTK_LEVEL_BAR_MODE_CONTINUOUS", "GtkLevelBarMode", GTK_LEVEL_BAR_MODE_CONTINUOUS},
+ {"GTK_LEVEL_BAR_MODE_DISCRETE", "GtkLevelBarMode", GTK_LEVEL_BAR_MODE_DISCRETE},
+ {"GTK_INPUT_PURPOSE_FREE_FORM", "GtkInputPurpose", GTK_INPUT_PURPOSE_FREE_FORM},
+ {"GTK_INPUT_PURPOSE_ALPHA", "GtkInputPurpose", GTK_INPUT_PURPOSE_ALPHA},
+ {"GTK_INPUT_PURPOSE_DIGITS", "GtkInputPurpose", GTK_INPUT_PURPOSE_DIGITS},
+ {"GTK_INPUT_PURPOSE_NUMBER", "GtkInputPurpose", GTK_INPUT_PURPOSE_NUMBER},
+ {"GTK_INPUT_PURPOSE_PHONE", "GtkInputPurpose", GTK_INPUT_PURPOSE_PHONE},
+ {"GTK_INPUT_PURPOSE_URL", "GtkInputPurpose", GTK_INPUT_PURPOSE_URL},
+ {"GTK_INPUT_PURPOSE_EMAIL", "GtkInputPurpose", GTK_INPUT_PURPOSE_EMAIL},
+ {"GTK_INPUT_PURPOSE_NAME", "GtkInputPurpose", GTK_INPUT_PURPOSE_NAME},
+ {"GTK_INPUT_PURPOSE_PASSWORD", "GtkInputPurpose", GTK_INPUT_PURPOSE_PASSWORD},
+ {"GTK_INPUT_PURPOSE_PIN", "GtkInputPurpose", GTK_INPUT_PURPOSE_PIN},
+ {"GTK_INPUT_HINT_NONE", "GtkInputHints", GTK_INPUT_HINT_NONE},
+ {"GTK_INPUT_HINT_SPELLCHECK", "GtkInputHints", GTK_INPUT_HINT_SPELLCHECK},
+ {"GTK_INPUT_HINT_NO_SPELLCHECK", "GtkInputHints", GTK_INPUT_HINT_NO_SPELLCHECK},
+ {"GTK_INPUT_HINT_WORD_COMPLETION", "GtkInputHints", GTK_INPUT_HINT_WORD_COMPLETION},
+ {"GTK_INPUT_HINT_LOWERCASE", "GtkInputHints", GTK_INPUT_HINT_LOWERCASE},
+ {"GTK_INPUT_HINT_UPPERCASE_CHARS", "GtkInputHints", GTK_INPUT_HINT_UPPERCASE_CHARS},
+ {"GTK_INPUT_HINT_UPPERCASE_WORDS", "GtkInputHints", GTK_INPUT_HINT_UPPERCASE_WORDS},
+ {"GTK_INPUT_HINT_UPPERCASE_SENTENCES", "GtkInputHints", GTK_INPUT_HINT_UPPERCASE_SENTENCES},
+ {"GTK_INPUT_HINT_INHIBIT_OSK", "GtkInputHints", GTK_INPUT_HINT_INHIBIT_OSK},
+#endif
+#if GTK_CHECK_VERSION(3, 8, 0)
+ {"GTK_STATE_FLAG_DIR_LTR", "GtkStateFlags", GTK_STATE_FLAG_DIR_LTR},
+ {"GTK_STATE_FLAG_DIR_RTL", "GtkStateFlags", GTK_STATE_FLAG_DIR_RTL},
+ {"GDK_FULLSCREEN_ON_CURRENT_MONITOR", "GdkFullscreenMode", GDK_FULLSCREEN_ON_CURRENT_MONITOR},
+ {"GDK_FULLSCREEN_ON_ALL_MONITORS", "GdkFullscreenMode", GDK_FULLSCREEN_ON_ALL_MONITORS},
+#endif
+ {NULL, NULL, 0}};
+
+static s7_pointer enum_value_to_name(s7_scheme *sc, long long int val, const char *type)
+{
+ int k;
+ long long int range_min = 0, range_max = 0;
+ bool range_set = false;
+ for (k = 0; ; k++)
+ {
+ enummer_t nt;
+ nt = enum_info[k];
+ if (!nt.name)
+ break;
+ if (strcmp(nt.type, type) == 0)
+ {
+ if (nt.value == val) /* ... value should be <nt.name> */
+ return(s7_make_string(sc, nt.name));
+ if (!range_set)
+ {
+ range_min = nt.value;
+ range_max = nt.value;
+ range_set = true;
+ }
+ else
+ {
+ if (range_min > nt.value) range_min = nt.value;
+ if (range_max < nt.value) range_max = nt.value;
+ }
+ }
+ }
+ if (range_set) /* here we found a matching name, its type is wrong, and it's out of range */
+ {
+ char *range_string;
+ s7_pointer str;
+ range_string = (char *)malloc(256 * sizeof(char));
+ snprintf(range_string, 256, "between %lld and %lld", range_min, range_max);
+ str = s7_make_string(sc, range_string);
+ free(range_string);
+ return(str); /* ... value should be between <min> and <max> */
+ }
+ return(s_integer);
+}
+
+static s7_pointer g_gtk_enum_t(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer form, argn, func, arg;
+ const char *doc_string, *p;
+ int arg_number;
+ form = s7_car(args);
+ argn = s7_cadr(args);
+ arg_number = s7_integer(argn);
+ arg = s7_list_ref(sc, form, arg_number);
+ if ((!s7_is_integer(arg)) &&
+ (!s7_is_symbol(arg)))
+ return(s_integer);
+ func = s7_car(form);
+ doc_string = s7_procedure_documentation(sc, func);
+ p = strchr(doc_string, (int)'(');
+ if (p)
+ {
+ int i;
+ for (i = 1; i < arg_number; i++)
+ p = strchr((char *)(p + 1), (int)',');
+ if (p)
+ {
+ const char *e;
+ p += 2; /* past comma and space */
+ e = strchr(p, (int)' ');
+ if (e)
+ {
+ int len;
+ char *type;
+ len = e - p + 1;
+ type = (char *)malloc(len * sizeof(char));
+ for (i = 0; i < len; i++) type[i] = p[i];
+ type[len - 1] = '\0';
+ if (s7_is_symbol(arg))
+ {
+ const char *arg_name;
+ arg_name = s7_symbol_name(arg); /* no free */
+ for (i = 0; ; i++)
+ {
+ enummer_t et;
+ et = enum_info[i];
+ if (!et.name)
+ break;
+ if (strcmp(et.name, arg_name) == 0)
+ {
+ if (strcmp(et.type, type) == 0) /* success -- name and type match */
+ {
+ free(type);
+ return(s7_t(sc));
+ }
+ return(enum_value_to_name(sc, et.value, type)); /* here the type is wrong, so try to find the correct name */
+ }
+ }
+ return(s_integer); /* here we got no matches, so return 'integer? */
+ }
+ return(enum_value_to_name(sc, s7_integer(arg), type)); /* here arg is an integer */
+ }
+ }
+ }
+ return(s_integer);
+}
+
+static void define_lint(void)
+{
+ s7_define_typed_function(s7, "gtk_enum_t?", g_gtk_enum_t, 2, 0, 0, "lint helper", pl_bti);
+}
+#endif
+
+
/* -------------------------------- initialization -------------------------------- */
static bool xg_already_inited = false;
@@ -45736,13 +47615,16 @@ void Init_libxg(void)
define_atoms();
define_strings();
define_structs();
+ #if HAVE_SCHEME
+ define_lint();
+ #endif
Xen_provide_feature("xg");
#if GTK_CHECK_VERSION(3, 0, 0)
Xen_provide_feature("gtk3");
#else
Xen_provide_feature("gtk2");
#endif
- Xen_define("xg-version", C_string_to_Xen_string("26-Nov-15"));
+ Xen_define("xg-version", C_string_to_Xen_string("05-May-16"));
xg_already_inited = true;
#if HAVE_SCHEME
#if USE_SND
diff --git a/xm-enved.scm b/xm-enved.scm
index 61f91c9..73a10b6 100644
--- a/xm-enved.scm
+++ b/xm-enved.scm
@@ -24,57 +24,6 @@
(define (xe-create-enved name parent args axis-bounds)
- (define (xe-add-envelope-point x y cur-env)
- (let ((new-env ()))
- (define (search-point e)
- (if (null? e)
- (append new-env (list x y))
- (if (= (car e) x)
- (append new-env (list x y) (cddr e))
- (if (> (car e) x)
- (append new-env (list x y) e)
- (begin
- (set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e)))))))
- (search-point cur-env)))
-
- (define (xe-edit-envelope-point pos x y cur-env)
- (let ((new-env ()))
- (define (search-point e npos)
- (if (= npos pos)
- (append new-env (list x y) (cddr e))
- (begin
- (set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e) (+ npos 2)))))
- (search-point cur-env 0)))
-
- (define (xe-remove-envelope-point pos cur-env)
- (let ((new-env ()))
- (define (search-point e npos)
- (if (null? e)
- new-env
- (if (= pos npos)
- (append new-env (cddr e))
- (begin
- (set! new-env (append new-env (list (car e) (cadr e))))
- (search-point (cddr e) (+ npos 2))))))
- (search-point cur-env 0)))
-
- (define (xe-envelope-position x cur-env)
- (define (search-point e pos)
- (if (= (car e) x)
- pos
- (search-point (cddr e) (+ pos 2))))
- (search-point cur-env 0))
-
- (define (xe-on-dot? x y cur-env pos)
- (define xe-mouse-radius .03)
- (and (pair? cur-env)
- (or (and (< (abs (- (car cur-env) x)) xe-mouse-radius)
- (< (abs (- (cadr cur-env) y)) xe-mouse-radius)
- pos)
- (xe-on-dot? x y (cddr cur-env) (+ pos 2)))))
-
(define (xe-ungrfy drawer y)
(let* ((bounds (drawer 3))
(locs (drawer 2))
@@ -106,26 +55,62 @@
(- px1 px0)))))))))
(define xe-mouse-down 0)
- (define xe-mouse-up 0)
- (define xe-click-time .1)
(define xe-mouse-pos 0)
(define xe-mouse-new #f)
(define (xe-mouse-press drawer xx yy)
+
+ (define (xe-envelope-position x cur-env)
+ (let search-point ((e cur-env)
+ (pos 0))
+ (if (= (car e) x)
+ pos
+ (search-point (cddr e) (+ pos 2)))))
+
+ (define (xe-on-dot? x y cur-env pos)
+ (let ((xe-mouse-radius .03))
+ (and (pair? cur-env)
+ (pair? (cdr cur-env))
+ (or (and (< (abs (- (car cur-env) x)) xe-mouse-radius)
+ (< (abs (- (cadr cur-env) y)) xe-mouse-radius)
+ pos)
+ (xe-on-dot? x y (cddr cur-env) (+ pos 2))))))
+
+ (define (xe-add-envelope-point x y cur-env)
+ (let ((new-env ()))
+ (let search-point ((e cur-env))
+ (cond ((null? e) (append new-env (list x y)))
+ ((= (car e) x) (append new-env (list x y) (cddr e)))
+ ((> (car e) x) (append new-env (list x y) e))
+ (else
+ (set! new-env (append new-env (list (car e) (cadr e))))
+ (search-point (cddr e)))))))
+
(let* ((cur-env (xe-envelope drawer))
(x (xe-ungrfx drawer xx))
(y (xe-ungrfy drawer yy))
(pos (xe-on-dot? x y cur-env 0)))
(set! xe-mouse-new (not pos))
(set! xe-mouse-down (get-internal-real-time))
- (if (not pos)
+ (if pos
+ (set! xe-mouse-pos pos)
(begin
- (set! (xe-envelope drawer)
- (xe-add-envelope-point x y cur-env))
- (set! xe-mouse-pos (xe-envelope-position x (xe-envelope drawer))))
- (set! xe-mouse-pos pos))))
+ (set! (xe-envelope drawer) (xe-add-envelope-point x y cur-env))
+ (set! xe-mouse-pos (xe-envelope-position x (xe-envelope drawer)))))))
+
(define (xe-mouse-drag drawer xx yy)
+
+ (define (xe-edit-envelope-point pos x y cur-env)
+ (let ((new-env ()))
+ (let search-point ((e cur-env)
+ (npos 0))
+ (if (= npos pos)
+ (append new-env (list x y) (cddr e))
+ (begin
+ (set! new-env (append new-env (list (car e) (cadr e))))
+ (search-point (cddr e) (+ npos 2)))))))
+
;; point exists, needs to be edited with check for various bounds
(let* ((cur-env (xe-envelope drawer))
(x (xe-ungrfx drawer xx))
@@ -135,23 +120,39 @@
(if (>= xe-mouse-pos (- (length cur-env) 2))
(cur-env (- (length cur-env) 2))
(max (cur-env (- xe-mouse-pos 2))
- (min x
- (cur-env (+ xe-mouse-pos 2))))))))
+ (min x (cur-env (+ xe-mouse-pos 2))))))))
(set! (xe-envelope drawer)
(xe-edit-envelope-point xe-mouse-pos lx y cur-env))
(xe-redraw drawer)))
- (define (xe-mouse-release drawer xx yy)
- (let ((cur-env (xe-envelope drawer)))
- (set! xe-mouse-up (get-internal-real-time))
- (if (and (not xe-mouse-new)
- (<= (- xe-mouse-up xe-mouse-down) xe-click-time)
- (not (= xe-mouse-pos 0))
- (< xe-mouse-pos (- (length cur-env) 2)))
- (set! (xe-envelope drawer)
- (xe-remove-envelope-point xe-mouse-pos cur-env)))
- (xe-redraw drawer)
- (set! xe-mouse-new #f)))
+
+ (define xe-mouse-release
+ (let ((xe-click-time .1)
+ (xe-mouse-up 0))
+
+ (define (xe-remove-envelope-point pos cur-env)
+ (let ((new-env ()))
+ (let search-point ((e cur-env)
+ (npos 0))
+ (if (null? e)
+ new-env
+ (if (= pos npos)
+ (append new-env (cddr e))
+ (begin
+ (set! new-env (append new-env (list (car e) (cadr e))))
+ (search-point (cddr e) (+ npos 2))))))))
+
+ (lambda (drawer)
+ (let ((cur-env (xe-envelope drawer)))
+ (set! xe-mouse-up (get-internal-real-time))
+ (if (and (not xe-mouse-new)
+ (<= (- xe-mouse-up xe-mouse-down) xe-click-time)
+ (not (= xe-mouse-pos 0))
+ (< xe-mouse-pos (- (length cur-env) 2)))
+ (set! (xe-envelope drawer)
+ (xe-remove-envelope-point xe-mouse-pos cur-env))))
+ (xe-redraw drawer)
+ (set! xe-mouse-new #f))))
(if (provided? 'snd-motif)
(with-let (sublet *motif*
@@ -190,7 +191,7 @@
(xe-mouse-drag editor (.x ev) (.y ev))))
(XtAddEventHandler drawer ButtonReleaseMask #f
(lambda (w context ev flag)
- (xe-mouse-release editor (.x ev) (.y ev))))
+ (xe-mouse-release editor)))
(XtAddEventHandler drawer EnterWindowMask #f
(lambda (w context ev flag)
(XDefineCursor (XtDisplay w) (XtWindow w) arrow-cursor)))
@@ -221,10 +222,10 @@
;; (xe-create-enved "hi" ((sound-widgets 0) 9) () '(0.0 1.0 0.0 1.0))
(define (local-draw-axes wid gc label x0 x1 y0 y1)
- (let ((cr (make-cairo wid)))
- (let ((val (draw-axes wid gc label x0 x1 y0 y1 x-axis-in-seconds show-all-axes cr)))
- (free-cairo cr)
- val)))
+ (let* ((cr (make-cairo wid))
+ (val (draw-axes wid gc label x0 x1 y0 y1 x-axis-in-seconds show-all-axes cr)))
+ (free-cairo cr)
+ val))
(gtk_widget_set_events drawer GDK_ALL_EVENTS_MASK)
(gtk_box_pack_start (GTK_BOX parent) drawer #t #t 10)
@@ -262,12 +263,8 @@
(g_signal_connect_closure_by_id (GPOINTER drawer)
(g_signal_lookup "button_release_event" (G_OBJECT_TYPE (G_OBJECT drawer)))
0 (g_cclosure_new (lambda (w e d)
- (let* ((ev (GDK_EVENT e))
- (coords (gdk_event_get_coords ev))
- (x (cadr coords))
- (y (caddr coords)))
- (set! dragging #f)
- (xe-mouse-release editor x y))
+ (set! dragging #f)
+ (xe-mouse-release editor)
#f)
#f #f)
#f)
@@ -276,10 +273,8 @@
0 (g_cclosure_new (lambda (w e d)
(if dragging
(let* ((ev (GDK_EVENT e))
- (coords (gdk_event_get_coords ev))
- (x (cadr coords))
- (y (caddr coords)))
- (xe-mouse-drag editor x y)))
+ (coords (gdk_event_get_coords ev)))
+ (xe-mouse-drag editor (cadr coords) (caddr coords))))
#f)
#f #f)
#f)
@@ -311,91 +306,91 @@
(name (drawer 5))
(len (and (list? cur-env) (length cur-env)))
(get_realized (if (provided? 'snd-gtk) (*gtk* 'gtk_widget_get_realized))))
- (if (and (list? ax-pix)
- (list? cur-env)
- (if (provided? 'snd-motif)
- ((*motif* 'XtIsManaged) widget)
- (get_realized widget)))
- (let ((px0 (ax-pix 0))
- (px1 (ax-pix 2))
- (py0 (ax-pix 1))
- (py1 (ax-pix 3))
- (ix0 (ax-inf 0))
- (ix1 (ax-inf 2))
- (iy0 (ax-inf 1))
- (iy1 (ax-inf 3))
- (mouse-d 10)
- (mouse-r 5))
-
- (define (xe-grfx drawer x)
- (if (= px0 px1)
- px0
- (min px1
- (max px0
- (floor (+ px0 (* (- px1 px0)
- (/ (- x ix0)
- (- ix1 ix0)))))))))
-
- (define (xe-grfy drawer y)
- (if (= py0 py1)
- py0
- (min py0 ; grows downward so y1 < y0
- (max py1
- (floor (+ py1 (* (- py0 py1)
- (/ (- y iy1)
- (- iy0 iy1)))))))))
-
- (if (> py0 py1)
+ (when (and (list? ax-pix)
+ (list? cur-env)
+ (if (provided? 'snd-motif)
+ ((*motif* 'XtIsManaged) widget)
+ (get_realized widget)))
+ (let ((py0 (ax-pix 1))
+ (py1 (ax-pix 3))
+ (ix0 (ax-inf 0))
+ (ix1 (ax-inf 2))
+ (iy0 (ax-inf 1))
+ (iy1 (ax-inf 3))
+ (mouse-d 10)
+ (mouse-r 5))
+
+ (define xe-grfx
+ (let ((px0 (ax-pix 0))
+ (px1 (ax-pix 2)))
+ (lambda (x)
+ (if (= px0 px1)
+ px0
+ (min px1
+ (max px0
+ (floor (+ px0 (* (- px1 px0)
+ (/ (- x ix0)
+ (- ix1 ix0)))))))))))
+
+ (define (xe-grfy y)
+ (if (= py0 py1)
+ py0
+ (min py0 ; grows downward so y1 < y0
+ (max py1
+ (floor (+ py1 (* (- py0 py1)
+ (/ (- y iy1)
+ (- iy0 iy1)))))))))
+
+ (when (> py0 py1)
+ (if (provided? 'snd-motif)
(begin
- (if (provided? 'snd-motif)
- (begin
- ((*motif* 'XClearWindow) dpy wn)
- (draw-axes widget gc name ix0 ix1 iy0 iy1)
- (let ((lx #f)
- (ly #f))
- (do ((i 0 (+ i 2)))
- ((= i len))
- (let ((cx (xe-grfx drawer (cur-env i)))
- (cy (xe-grfy drawer (cur-env (+ i 1)))))
- ((*motif* 'XFillArc)
- dpy wn gc
- (- cx mouse-r)
- (- cy mouse-r)
- mouse-d mouse-d
- 0 (* 360 64))
- (if lx
- ((*motif* 'XDrawLine) dpy wn gc lx ly cx cy))
- (set! lx cx)
- (set! ly cy)))))
- ;; *gtk*
- (let ((lx #f)
- (ly #f)
- (cr ((*gtk* 'gdk_cairo_create) ((*gtk* 'GDK_WINDOW) wn)))
- (size (widget-size ((*gtk* 'GTK_WIDGET) widget))))
-
- ((*gtk* 'cairo_push_group) cr)
- ((*gtk* 'cairo_set_source_rgb) cr 1.0 1.0 1.0)
- ((*gtk* 'cairo_rectangle) cr 0 0 (car size) (cadr size))
- ((*gtk* 'cairo_fill) cr)
-
- (draw-axes widget gc name ix0 ix1 iy0 iy1 x-axis-in-seconds show-all-axes cr)
+ ((*motif* 'XClearWindow) dpy wn)
+ (draw-axes widget gc name ix0 ix1 iy0 iy1)
+ (let ((lx #f)
+ (ly #f))
+ (do ((i 0 (+ i 2)))
+ ((= i len))
+ (let ((cx (xe-grfx (cur-env i)))
+ (cy (xe-grfy (cur-env (+ i 1)))))
+ ((*motif* 'XFillArc)
+ dpy wn gc
+ (- cx mouse-r)
+ (- cy mouse-r)
+ mouse-d mouse-d
+ 0 23040) ; (* 360 64))
+ (if lx
+ ((*motif* 'XDrawLine) dpy wn gc lx ly cx cy))
+ (set! lx cx)
+ (set! ly cy)))))
+ ;; *gtk*
+ (let ((lx #f)
+ (ly #f)
+ (cr ((*gtk* 'gdk_cairo_create) ((*gtk* 'GDK_WINDOW) wn))))
+
+ (let ((size (widget-size ((*gtk* 'GTK_WIDGET) widget))))
+ ((*gtk* 'cairo_push_group) cr)
+ ((*gtk* 'cairo_set_source_rgb) cr 1.0 1.0 1.0)
+ ((*gtk* 'cairo_rectangle) cr 0 0 (car size) (cadr size))
+ ((*gtk* 'cairo_fill) cr))
+
+ (draw-axes widget gc name ix0 ix1 iy0 iy1 x-axis-in-seconds show-all-axes cr)
+
+ ((*gtk* 'cairo_set_line_width) cr 1.0)
+ ((*gtk* 'cairo_set_source_rgb) cr 0.0 0.0 0.0)
+ (do ((i 0 (+ i 2)))
+ ((= i len))
+ (let ((cx (xe-grfx (cur-env i)))
+ (cy (xe-grfy (cur-env (+ i 1)))))
+ ((*gtk* 'cairo_arc) cr cx cy mouse-r 0.0 (* 2 pi))
+ ((*gtk* 'cairo_fill) cr)
+ (if lx
+ (begin
+ ((*gtk* 'cairo_move_to) cr lx ly)
+ ((*gtk* 'cairo_line_to) cr cx cy)
+ ((*gtk* 'cairo_stroke) cr)))
+ (set! lx cx)
+ (set! ly cy)))
+ ((*gtk* 'cairo_pop_group_to_source) cr)
+ ((*gtk* 'cairo_paint) cr)
+ ((*gtk* 'cairo_destroy) cr))))))))
- ((*gtk* 'cairo_set_line_width) cr 1.0)
- ((*gtk* 'cairo_set_source_rgb) cr 0.0 0.0 0.0)
- (do ((i 0 (+ i 2)))
- ((= i len))
- (let ((cx (xe-grfx drawer (cur-env i)))
- (cy (xe-grfy drawer (cur-env (+ i 1)))))
- ((*gtk* 'cairo_arc) cr cx cy mouse-r 0.0 (* 2 pi))
- ((*gtk* 'cairo_fill) cr)
- (if lx
- (begin
- ((*gtk* 'cairo_move_to) cr lx ly)
- ((*gtk* 'cairo_line_to) cr cx cy)
- ((*gtk* 'cairo_stroke) cr)))
- (set! lx cx)
- (set! ly cy)))
- ((*gtk* 'cairo_pop_group_to_source) cr)
- ((*gtk* 'cairo_paint) cr)
- ((*gtk* 'cairo_destroy) cr)))))))))
-
diff --git a/zip.scm b/zip.scm
index 22d1526..b7be3ee 100644
--- a/zip.scm
+++ b/zip.scm
@@ -60,35 +60,34 @@ an envelope (normally a ramp from 0 to 1) which sets where we are in the zipping
;; else we're in the ramp phase
;; read frame if we're within its bounds
(begin
- (if (>= frame-loc cursamples)
- ;; now get next portion of the ramp
- (begin
- (set! frame-loc 0)
- (set! cursamples frame-samples)
- (do ((k 0 (+ k 1)))
- ((= k frame-samples))
- (float-vector-set! frame1 k (read-sample input1)))
- (do ((k 0 (+ k 1)))
- ((= k frame-samples))
- (float-vector-set! frame2 k (read-sample input2)))
- ;; now resample each dependent on location in ramp (samp1 and samp2 are increments)
- (fill! frame0 0.0)
- (let ((samp2 (* 1.0 (/ frame-samples chunk-len)))) ; this was floor (and also below)?
- (do ((k 0 (+ k 1))
- (start-ctr 0.0 (+ start-ctr samp2)))
- ((= k chunk-len))
- (let ((ictr (floor start-ctr)))
- (let ((y0 (float-vector-ref frame2 ictr))
- (y1 (float-vector-ref frame2 (+ ictr 1))))
- (float-vector-set! frame0 k (+ y0 (* (- y1 y0) (- start-ctr ictr))))))))
- (let ((samp1 (* 1.0 (/ frame-samples (- frame-samples chunk-len)))))
- (do ((k chunk-len (+ k 1))
- (start-ctr 0.0 (+ start-ctr samp1)))
- ((= k frame-samples))
- (let ((ictr (floor start-ctr)))
- (let ((y0 (float-vector-ref frame1 ictr))
- (y1 (float-vector-ref frame1 (+ ictr 1))))
- (float-vector-set! frame0 k (+ y0 (* (- y1 y0) (- start-ctr ictr))))))))))
+ (when (>= frame-loc cursamples)
+ ;; now get next portion of the ramp
+ (set! frame-loc 0)
+ (set! cursamples frame-samples)
+ (do ((k 0 (+ k 1)))
+ ((= k frame-samples))
+ (float-vector-set! frame1 k (read-sample input1)))
+ (do ((k 0 (+ k 1)))
+ ((= k frame-samples))
+ (float-vector-set! frame2 k (read-sample input2)))
+ ;; now resample each dependent on location in ramp (samp1 and samp2 are increments)
+ (fill! frame0 0.0)
+ (do ((samp2 (* 1.0 (/ frame-samples chunk-len))) ; this was floor (and also below)?
+ (k 0 (+ k 1))
+ (start-ctr 0.0 (+ start-ctr samp2)))
+ ((= k chunk-len))
+ (let ((ictr (floor start-ctr)))
+ (let ((y0 (float-vector-ref frame2 ictr))
+ (y1 (float-vector-ref frame2 (+ ictr 1))))
+ (float-vector-set! frame0 k (+ y0 (* (- y1 y0) (- start-ctr ictr)))))))
+ (do ((samp1 (* 1.0 (/ frame-samples (- frame-samples chunk-len))))
+ (k chunk-len (+ k 1))
+ (start-ctr 0.0 (+ start-ctr samp1)))
+ ((= k frame-samples))
+ (let ((ictr (floor start-ctr)))
+ (let ((y0 (float-vector-ref frame1 ictr))
+ (y1 (float-vector-ref frame1 (+ ictr 1))))
+ (float-vector-set! frame0 k (+ y0 (* (- y1 y0) (- start-ctr ictr))))))))
(let ((result (float-vector-ref frame0 frame-loc)))
(set! frame-loc (+ frame-loc 1))
result)))))))))
--
snd packaging
More information about the pkg-multimedia-commits
mailing list